From ec5077a57edf8a6edf50c8c2b705195e7180ddf3 Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Tue, 31 May 2022 10:24:03 -0400 Subject: [PATCH] Adds source code to implement a mesh-based NUOPC cap (#641) in the dev/ufs-weather-model branch. Co-authored-by: Mariana Vertenstein --- .github/workflows/gnu.yml | 6 +- .github/workflows/intel.yml | 6 +- CMakeLists.txt | 10 +- model/bin/build_utils.sh | 112 +- model/bin/make_makefile.sh | 31 +- model/bin/switch_meshcap | 1 + model/bin/w3_make | 8 + model/esmf/Makefile | 9 +- model/src/CMakeLists.txt | 13 +- model/src/cmake/src_list.cmake | 13 + model/src/w3adatmd.F90 | 116 ++- model/src/w3idatmd.F90 | 44 +- model/src/w3initmd.F90 | 152 ++- model/src/w3iogomd.F90 | 186 +++- model/src/w3iogoncdmd.F90 | 765 ++++++++++++++ model/src/w3iorsmd.F90 | 149 ++- model/src/w3odatmd.F90 | 5 +- model/src/w3sic4md.F90 | 110 +- model/src/w3timemd.F90 | 24 +- model/src/w3updtmd.F90 | 122 ++- model/src/w3wavemd.F90 | 141 ++- model/src/wav_comp_nuopc.F90 | 1490 +++++++++++++++++++++++++++ model/src/wav_import_export.F90 | 1718 +++++++++++++++++++++++++++++++ model/src/wav_kind_mod.F90 | 27 + model/src/wav_shel_inp.F90 | 1057 +++++++++++++++++++ model/src/wav_shr_mod.F90 | 1158 +++++++++++++++++++++ 26 files changed, 7124 insertions(+), 349 deletions(-) create mode 100644 model/bin/switch_meshcap create mode 100644 model/src/w3iogoncdmd.F90 create mode 100644 model/src/wav_comp_nuopc.F90 create mode 100644 model/src/wav_import_export.F90 create mode 100644 model/src/wav_kind_mod.F90 create mode 100644 model/src/wav_shel_inp.F90 create mode 100644 model/src/wav_shr_mod.F90 diff --git a/.github/workflows/gnu.yml b/.github/workflows/gnu.yml index a063de01b..f44498d0c 100644 --- a/.github/workflows/gnu.yml +++ b/.github/workflows/gnu.yml @@ -66,7 +66,7 @@ jobs: needs: setup strategy: matrix: - switch: [Ifremer1, NCEP_st2, NCEP_st4, ite_pdlib, NCEP_st4sbs, NCEP_glwu, OASACM, UKMO, MULTI_ESMF] + switch: [Ifremer1, NCEP_st2, NCEP_st4, ite_pdlib, NCEP_st4sbs, NCEP_glwu, OASACM, UKMO, MULTI_ESMF, NUOPC_MESH] runs-on: ubuntu-20.04 steps: @@ -95,7 +95,9 @@ jobs: export OASISDIR=${GITHUB_WORKSPACE}/work_oasis3-mct mkdir build && cd build if [[ ${{ matrix.switch }} == "MULTI_ESMF" ]]; then - cmake .. -DMULTI_ESMF=ON -DSWITCH=multi_esmf + cmake .. -DUFS_CAP=MULTI_ESMF -DSWITCH=multi_esmf + elif [[ ${{ matrix.switch }} == "NUOPC_MESH" ]]; then + cmake .. -DUFS_CAP=NUOPC_MESH -DSWITCH=meshcap else cmake .. -DSWITCH=${{ matrix.switch }} fi diff --git a/.github/workflows/intel.yml b/.github/workflows/intel.yml index ad944c1da..7c63d28c3 100644 --- a/.github/workflows/intel.yml +++ b/.github/workflows/intel.yml @@ -86,7 +86,7 @@ jobs: needs: setup strategy: matrix: - switch: [Ifremer1, NCEP_st2, NCEP_st4, ite_pdlib, NCEP_st4sbs, NCEP_glwu, OASACM, UKMO, MULTI_ESMF] + switch: [Ifremer1, NCEP_st2, NCEP_st4, ite_pdlib, NCEP_st4sbs, NCEP_glwu, OASACM, UKMO, MULTI_ESMF, NUOPC_MESH] runs-on: ubuntu-latest steps: @@ -120,7 +120,9 @@ jobs: export OASISDIR=${GITHUB_WORKSPACE}/work_oasis3-mct mkdir build && cd build if [[ ${{ matrix.switch }} == "MULTI_ESMF" ]]; then - cmake .. -DMULTI_ESMF=ON -DSWITCH=multi_esmf + cmake .. -DUFS_CAP=MULTI_ESMF -DSWITCH=multi_esmf + elif [[ ${{ matrix.switch }} == "NUOPC_MESH" ]]; then + cmake .. -DUFS_CAP=NUOPC_MESH -DSWITCH=meshcap else cmake .. -DSWITCH=${{ matrix.switch }} fi diff --git a/CMakeLists.txt b/CMakeLists.txt index 58115b3aa..9dff6c12f 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -20,7 +20,9 @@ if(hasParent) remove_definitions(-DDEBUG) endif() -set(MULTI_ESMF OFF CACHE BOOL "Build ww3_multi_esmf library") +set(valid_caps "MULTI_ESMF" "NUOPC_MESH") + +set(UFS_CAP "" CACHE STRING "Valid options are ${valid_caps}") set(NETCDF ON CACHE BOOL "Build NetCDF programs (requires NetCDF)") set(ENDIAN "BIG" CACHE STRING "Endianness of unformatted output files. Valid values are 'BIG', 'LITTLE', 'NATIVE'.") set(EXCLUDE_FIND "" CACHE STRING "Don't try and search for these libraries (assumd to be handled by the compiler/wrapper)") @@ -44,6 +46,12 @@ else() endif() endif() +if(UFS_CAP) + if(NOT UFS_CAP IN_LIST valid_caps) + message(FATAL_ERROR "Invalid UFS_CAP selection. Valids options are ${valid_caps}") + endif() +endif() + message(STATUS "Build with switch: ${switch_file}") # Copy switch file to build dir configure_file(${switch_file} ${CMAKE_BINARY_DIR}/switch COPYONLY) diff --git a/model/bin/build_utils.sh b/model/bin/build_utils.sh index 67cf63367..40451cb92 100755 --- a/model/bin/build_utils.sh +++ b/model/bin/build_utils.sh @@ -1,6 +1,6 @@ #!/bin/bash -e # --------------------------------------------------------------------------- # -# build_utils.sh : Shell functions that can be used by multiple scripts # +# build_utils.sh : Shell functions that can be used by multiple scripts # # for building the model # # # # programs used : w3_new Touches the correct files if compiler switches # @@ -24,7 +24,7 @@ # Performs quality check on switches defined in variable $switch. Checks # # to make sure that swtich choices are compatible and that only the valid # # switches have been identified. Groups switched into different variables # -# by type # +# by type # # --------------------------------------------------------------------------- # @@ -32,7 +32,7 @@ check_switches() { - # 1.a Step through categories + # 1.a Step through categories for type in nco grib scrip scripnc \ shared mpp mpiexp thread GSE prop smcg \ @@ -291,7 +291,7 @@ check_switches() ID='use pdlib' TS='PDLIB' OK='PDLIB' ;; -#sort:memck: +#sort:memck: memck ) TY='upto1' ID='check memory use' TS='MEMCHECK' @@ -436,7 +436,7 @@ check_switches() esac done -# 1.b Check switch compatibility +# 1.b Check switch compatibility case $stress in FLX0) str_st1='no' ; str_st2='no' ; str_st3='OK' ; str_st6='no' ;; @@ -541,11 +541,11 @@ check_switches() fi if [ "$pdlib" = 'PDLIB' ] && [ "$mpp" != 'MPI' ] - then + then echo ' ' echo " *** For PDLIB, we need to have MPI as well." echo ' ' ; exit 17 - fi + fi } #end of check_switches @@ -565,12 +565,12 @@ switch_files() PR1) pr='w3profsmd w3pro1md' ;; PR2) pr='w3profsmd w3pro2md' ;; PR3) pr='w3profsmd w3pro3md' ;; - esac + esac case $p_switch in UQ ) pr="$pr w3uqckmd" ;; UNO) pr="$pr w3uno2md" ;; - esac + esac smcm=$NULL smco=$NULL @@ -697,16 +697,16 @@ switch_files() REF1) refcode='w3ref1md' esac - pdlibcode=$NULL - pdlibyow=$NULL + pdlibcode=$NULL + pdlibyow=$NULL case $pdlib in PDLIB) pdlibcode='yowfunction pdlib_field_vec w3profsmd_pdlib' pdlibyow='yowsidepool yowdatapool yowerr yownodepool yowelementpool yowexchangeModule yowrankModule yowpdlibmain yowpd' ;; esac - memcode=$NULL - case $memck in - MEMCHECK) memcode='w3meminfo' + memcode=$NULL + case $memck in + MEMCHECK) memcode='w3meminfo' esac setupcode=$NULL @@ -756,13 +756,13 @@ switch_files() # --------------------------------------------------------------------------- # -# 3. Create list of files for a prog # +# 3. Create list of files for a prog # # For a particular prog create files and filesl a list of files and a # # list of files to be linked. The variable prog needs to be set and # -# the switch_files should be used first (which requires check_switches() # +# the switch_files should be used first (which requires check_switches() # # --------------------------------------------------------------------------- # -create_file_list() +create_file_list() { case $prog in ww3_grid) @@ -776,8 +776,8 @@ create_file_list() then aux="$aux scrip_constants scrip_grids scrip_iounitsmod" aux="$aux scrip_remap_vars scrip_timers scrip_errormod scrip_interface" - aux="$aux scrip_kindsmod scrip_remap_conservative wmscrpmd" - fi + aux="$aux scrip_kindsmod scrip_remap_conservative wmscrpmd" + fi if [ "$scripnc" = 'SCRIPNC' ] then aux="$aux scrip_netcdfmod scrip_remap_write scrip_remap_read" @@ -803,7 +803,7 @@ create_file_list() sourcet="$pdlibcode $pdlibyow $db $bt $setupcode $stx $nlx $btx $is wmmdatmd w3parall w3triamd $uostmd" IO='w3iobcmd w3iogrmd w3dispmd w3gsrumd' aux="constants w3servmd w3arrymd w3timemd w3cspcmd w3nmlbouncmd" ;; - ww3_prep) + ww3_prep) core='w3fldsmd' data="$memcode w3gdatmd w3adatmd w3idatmd w3odatmd w3wdatmd wmmdatmd" prop= @@ -817,22 +817,30 @@ create_file_list() sourcet="$pdlibcode $pdlibyow $db $bt $setupcode w3triamd $stx $flx $nlx $btx $is w3parall $uostmd" IO="w3iogrmd $oasismd $agcmmd $ogcmmd $igcmmd" aux="constants w3servmd w3timemd w3arrymd w3dispmd w3gsrumd w3tidemd w3nmlprncmd" ;; - ww3_prtide) + ww3_prtide) core='w3fldsmd' data="wmmdatmd $memcode w3gdatmd w3wdatmd w3adatmd w3idatmd w3odatmd" prop="$pr $smcm" sourcet="$pdlibcode $pdlibyow $db $bt $setupcode w3triamd $stx $nlx $btx $is w3parall $uostmd" IO="w3iogrmd $oasismd $agcmmd $ogcmmd $igcmmd" aux="constants w3servmd w3timemd w3arrymd w3dispmd w3gsrumd $tidecode" ;; - ww3_shel) - core='w3fldsmd w3initmd w3wavemd w3wdasmd w3updtmd' + ww3_shel|ww3_shel_esmf) + if [ "$prog" = "ww3_shel" ] + then + core='' + else + core='wav_kind_mod wav_shr_mod wav_shel_inp wav_comp_nuopc wav_import_export w3iogoncdmd' + fi + core="$core w3fldsmd w3initmd w3wavemd w3wdasmd w3updtmd" + core="$core wminitmd wmwavemd wmfinlmd wmgridmd wmupdtmd wminiomd" data="wmmdatmd $memcode w3gdatmd w3wdatmd w3adatmd w3idatmd w3odatmd" prop="$pr $smcm" sourcet="$pdlibcode $setupcode w3triamd w3srcemd $dsx $flx $ln $st $nl $bt $ic" sourcet="$sourcet $is $db $tr $bs $refcode $igcode w3parall $uostmd" IO="w3iogrmd w3iogomd w3iopomd w3iotrmd w3iorsmd w3iobcmd $oasismd $agcmmd $ogcmmd $igcmmd" - IO="$IO w3iosfmd w3partmd" + IO="$IO w3iosfmd w3partmd wmiopomd" aux="constants w3servmd w3timemd $tidecode w3arrymd w3dispmd w3cspcmd w3gsrumd" + aux="$aux wmunitmd w3nmlmultimd" aux="$aux w3nmlshelmd $pdlibyow" ;; ww3_multi|ww3_multi_esmf) if [ "$prog" = "ww3_multi" ] @@ -849,7 +857,7 @@ create_file_list() IO='w3iogrmd w3iogomd w3iopomd wmiopomd' IO="$IO w3iotrmd w3iorsmd w3iobcmd w3iosfmd w3partmd $oasismd $agcmmd $ogcmmd $igcmmd" aux="constants $tidecode w3servmd w3timemd w3arrymd w3dispmd w3cspcmd w3gsrumd $mprfaux" - aux="$aux wmunitmd w3nmlmultimd" + aux="$aux wmunitmd w3nmlmultimd" if [ "$scrip" = 'SCRIP' ] then aux="$aux scrip_constants scrip_grids scrip_iounitsmod" @@ -860,22 +868,22 @@ create_file_list() then aux="$aux scrip_netcdfmod scrip_remap_write scrip_remap_read" fi ;; - ww3_sbs1) - core='wminitmd wmwavemd wmfinlmd wmgridmd wmupdtmd wminiomd' - core="$core w3fldsmd w3initmd w3wavemd w3wdasmd w3updtmd" - data="w3parall wmmdatmd $memcode w3gdatmd w3wdatmd w3adatmd w3idatmd w3odatmd" - prop="$pr $smcm" - sourcet="$pdlibcode $pdlibyow w3triamd w3srcemd $dsx $flx $ln $st $nl $bt $db $tr $bs $refcode $igcode $is $ic $uostmd" - IO='w3iogrmd w3iogomd w3iopomd wmiopomd' - IO="$IO w3iotrmd w3iorsmd w3iobcmd w3iosfmd w3partmd $oasismd $agcmmd $ogcmmd $igcmmd" - aux="constants w3servmd w3timemd w3arrymd w3dispmd w3cspcmd w3gsrumd $mprfaux $tidecode" - aux="$aux wmunitmd w3nmlmultimd" + ww3_sbs1) + core='wminitmd wmwavemd wmfinlmd wmgridmd wmupdtmd wminiomd' + core="$core w3fldsmd w3initmd w3wavemd w3wdasmd w3updtmd" + data="w3parall wmmdatmd $memcode w3gdatmd w3wdatmd w3adatmd w3idatmd w3odatmd" + prop="$pr $smcm" + sourcet="$pdlibcode $pdlibyow w3triamd w3srcemd $dsx $flx $ln $st $nl $bt $db $tr $bs $refcode $igcode $is $ic $uostmd" + IO='w3iogrmd w3iogomd w3iopomd wmiopomd' + IO="$IO w3iotrmd w3iorsmd w3iobcmd w3iosfmd w3partmd $oasismd $agcmmd $ogcmmd $igcmmd" + aux="constants w3servmd w3timemd w3arrymd w3dispmd w3cspcmd w3gsrumd $mprfaux $tidecode" + aux="$aux wmunitmd w3nmlmultimd" if [ "$scrip" = 'SCRIP' ] then aux="$aux scrip_constants scrip_grids scrip_iounitsmod" aux="$aux scrip_remap_vars scrip_timers scrip_errormod scrip_interface" aux="$aux scrip_kindsmod scrip_remap_conservative wmscrpmd" - fi + fi if [ "$scripnc" = 'SCRIPNC' ] then aux="$aux scrip_netcdfmod scrip_remap_write scrip_remap_read" @@ -896,7 +904,7 @@ create_file_list() IO='w3iogrmd w3iogomd w3iorsmd w3iopomd' aux="constants w3servmd w3timemd w3arrymd w3dispmd w3gsrumd" aux="$aux w3nmlounfmd $smco w3ounfmetamd w3metamd" ;; - ww3_outp) + ww3_outp) core= data="wmmdatmd w3parall w3triamd $memcode w3gdatmd w3wdatmd w3adatmd w3idatmd w3odatmd" prop= @@ -911,7 +919,7 @@ create_file_list() IO='w3bullmd w3iogrmd w3iopomd w3partmd' aux="constants w3servmd w3timemd w3arrymd w3dispmd w3gsrumd" aux="$aux w3nmlounpmd" ;; - ww3_trck) + ww3_trck) core= data="$memcode w3gdatmd w3odatmd" prop= @@ -925,7 +933,7 @@ create_file_list() sourcet= IO= aux="constants w3servmd w3timemd w3gsrumd w3nmltrncmd" ;; - ww3_grib) + ww3_grib) core= data="w3parall wmmdatmd w3triamd $memcode w3gdatmd w3wdatmd w3adatmd w3idatmd w3odatmd" prop= @@ -933,14 +941,14 @@ create_file_list() IO='w3iogrmd w3iogomd' aux="constants w3servmd w3timemd w3arrymd w3dispmd w3gsrumd" aux="$aux" ;; - ww3_gspl) + ww3_gspl) core='w3fldsmd' data="$memcode w3gdatmd w3wdatmd w3adatmd w3idatmd w3odatmd" prop= sourcet="$pdlibcode $pdlibyow $db $bt $setupcode wmmdatmd w3parall w3triamd $stx $flx $nlx $btx $is $uostmd" IO="w3iogrmd $oasismd $agcmmd $ogcmmd $igcmmd" aux="constants w3servmd w3timemd w3arrymd w3dispmd w3gsrumd $tidecode" ;; - ww3_gint) + ww3_gint) core= data="w3parall wmmdatmd $memcode w3gdatmd w3wdatmd w3adatmd w3idatmd w3odatmd" IO='w3iogrmd w3iogomd' @@ -956,38 +964,38 @@ create_file_list() IO='w3iogrmd w3iogomd' aux="constants w3servmd w3timemd w3arrymd w3dispmd w3gsrumd" aux="$aux" ;; - gx_outp) + gx_outp) core= data="$memcode w3gdatmd w3wdatmd w3adatmd w3idatmd w3odatmd" prop= sourcet="$pdlibcode $pdlibyow $db $bt $setupcode wmmdatmd w3parall w3triamd $ln $flx $st $nlx $btx $tr $bs $is $ic $uostmd" IO='w3iogrmd w3iopomd' aux="constants w3servmd w3timemd w3arrymd w3dispmd w3gsrumd" ;; - ww3_systrk) + ww3_systrk) core='w3strkmd' data="$memcode w3gdatmd w3adatmd w3idatmd w3odatmd w3wdatmd" prop= sourcet="$pdlibcode $pdlibyow $db $bt $setupcode wmmdatmd w3dispmd w3triamd $ln $stx $flx $nlx $btx $tr $bs $is $uostmd" IO= aux="constants w3servmd w3timemd w3arrymd w3gsrumd w3parall" ;; - libww3|libww3.so) + libww3|libww3.so) core='w3fldsmd w3initmd w3wavemd w3wdasmd w3updtmd' data='wmmdatmd w3gdatmd w3wdatmd w3adatmd w3idatmd w3odatmd' prop="$pr $smcm" sourcet="w3triamd w3srcemd $dsx $flx $ln $st $nl $bt $ic $is $db $tr $bs $refcode $igcode $uostmd" IO='w3iogrmd w3iogomd w3iopomd w3iotrmd w3iorsmd w3iobcmd w3iosfmd w3partmd' aux="constants w3servmd w3timemd $tidecode w3arrymd w3dispmd w3cspcmd w3gsrumd" ;; - ww3_uprstr) - core= - data='wmmdatmd w3triamd w3gdatmd w3wdatmd w3adatmd w3idatmd w3odatmd' - prop= + ww3_uprstr) + core= + data='wmmdatmd w3triamd w3gdatmd w3wdatmd w3adatmd w3idatmd w3odatmd' + prop= sourcet="$memcode $pdlibcode $pdlibyow $flx $ln $st $nl $bt $ic $is $db $tr $bs $uostmd" - IO='w3iogrmd w3iogomd w3iorsmd' - aux="constants w3servmd w3timemd w3arrymd w3dispmd w3gsrumd" - aux="$aux w3parall w3nmluprstrmd" ;; + IO='w3iogrmd w3iogomd w3iorsmd' + aux="constants w3servmd w3timemd w3arrymd w3dispmd w3gsrumd" + aux="$aux w3parall w3nmluprstrmd" ;; esac - # if esmf is included in program name or if + # if esmf is included in program name or if # the target is compile and create archive if [ -n "`echo $prog | grep esmf 2>/dev/null`" ] then diff --git a/model/bin/make_makefile.sh b/model/bin/make_makefile.sh index c05301220..230a52c48 100755 --- a/model/bin/make_makefile.sh +++ b/model/bin/make_makefile.sh @@ -36,7 +36,7 @@ echo ' *****************************' echo ' ' -# 1.b Get data from setup file - - - - - - - - - - - - - - - - - - - - - - - - +# 1.b Get data from setup file - - - - - - - - - - - - - - - - - - - - - - - - source $(dirname $0)/w3_setenv main_dir=$WWATCH3_DIR @@ -48,7 +48,7 @@ . ${main_dir}/bin/build_utils.sh -# 1.d Go to temp dir +# 1.d Go to temp dir cd $temp_dir @@ -116,15 +116,15 @@ progs="ww3_grid ww3_strt ww3_prep ww3_prnc ww3_shel ww3_multi ww3_sbs1 ww3_outf ww3_outp ww3_trck ww3_trnc ww3_grib gx_outf gx_outp ww3_ounf ww3_ounp ww3_gspl ww3_gint ww3_bound ww3_bounc ww3_systrk $tideprog" - progs="$progs ww3_multi_esmf ww3_uprstr" + progs="$progs ww3_multi_esmf ww3_shel_esmf ww3_uprstr" progs="$progs libww3" progs="$progs libww3.so" for prog in $progs do - # Get file - the list of files to be compiled - # and filel - list of files for linking a particular prog + # 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 @@ -136,6 +136,7 @@ ww3_prnc) IDstring='NetCDF field preprocessor' ;; ww3_prtide) IDstring='Tide prediction' ;; ww3_shel) IDstring='Generic shell' ;; + ww3_shel_esmf) IDstring='Generic shell ESMF module' ;; ww3_multi) IDstring='Multi-grid shell' ;; ww3_multi_esmf) IDstring='Multi-grid ESMF module' ;; ww3_sbs1) IDstring='Multi-grid shell sbs version' ;; @@ -160,7 +161,7 @@ echo "# $IDstring" >> makefile echo ' ' >> makefile - # if esmf is included in program name or if + # if esmf is included in program name or if # the target is compile and create archive if [ -n "`echo $prog | grep esmf 2>/dev/null`" ] then @@ -251,6 +252,7 @@ suffixes="ftn f F f90 F90 c" fexti=none ispdlibi=no + isnuopci=no for s in $suffixes do if [ -f $main_dir/src/$file.$s ] @@ -264,6 +266,12 @@ ispdlibi=yes break fi + if [ -f $main_dir/src/$file.$s ] + then + fexti=$s + isnuopci=yes + break + fi done if [ "$fexti" = 'none' ] then @@ -289,6 +297,11 @@ string1='$(aPo)/'$file'.o : PDLIB/'$file.$fexti' ' fi + if [ "$ispdlibi" = 'yes' ] + then + string1='$(aPo)/'$file'.o : '$file.$fexti' ' + fi + $main_dir/bin/ad3 $file 0 1 > ad3.out 2>&1 if [ -n "`grep error ad3.out`" ] @@ -437,6 +450,12 @@ 'W3OUNFMETAMD' ) modtest=w3ounfmetamd.o ;; 'W3METAMD' ) modtest=w3metamd.o ;; 'W3GRIDMD' ) modtest=w3gridmd.o ;; + 'wav_kind_mod' ) modtest=wav_kind_mod.o ;; + 'wav_shr_mod' ) modtest=wav_shr_mod.o ;; + 'wav_shel_inp' ) modtest=wav_shel_inp.o ;; + 'wav_comp_nuopc' ) modtest=wav_comp_nuopc.o ;; + 'wav_import_export' ) modtest=wav_import_export.o ;; + 'w3iogoncdmd' ) modtest=w3iogoncdmd.o ;; * ) modfound=no ;; esac diff --git a/model/bin/switch_meshcap b/model/bin/switch_meshcap new file mode 100644 index 000000000..9b5b36c03 --- /dev/null +++ b/model/bin/switch_meshcap @@ -0,0 +1 @@ +UWM NCO NOGRB DIST MPI OMPG OMPH PR3 UQ FLX0 SEED ST4 STAB0 NL1 BT1 DB1 MLIM FLD2 TR0 BS0 RWND WNX1 WNT1 CRX1 CRT1 O0 O1 O2 O3 O4 O5 O6 O7 O14 O15 IC0 IS0 REF0 diff --git a/model/bin/w3_make b/model/bin/w3_make index 1fae69e61..b2369df09 100755 --- a/model/bin/w3_make +++ b/model/bin/w3_make @@ -201,8 +201,16 @@ if [ -n "`grep OASIS $switch_file`" ] || [ -n "`grep PDLIB $switch_file`" ] then cdf_programs="$cdf_programs ww3_shel" + if [ $ESMFMKFILE ] + then + cdf_programs="$cdf_programs ww3_shel_esmf" + fi else reg_programs="$reg_programs ww3_shel" + if [ $ESMFMKFILE ] + then + reg_programs="$reg_programs ww3_shel_esmf" + fi fi #Shared Object diff --git a/model/esmf/Makefile b/model/esmf/Makefile index 06dd34c4f..9f5862350 100644 --- a/model/esmf/Makefile +++ b/model/esmf/Makefile @@ -33,7 +33,7 @@ ifeq ($(WW3_COMP),Portland) else ifeq ("$(WW3_COMP)",$(filter "$(WW3_COMP)","pgi" "datarmor_pgi" "datarmor_pgi_debug")) ESMF_F90COMPILEOPTS := $(ESMF_F90COMPILEOPTS) -byteswapio # intel -else ifeq ("$(WW3_COMP)",$(filter "$(WW3_COMP)","Intel" "hera.intel" "orion.intel" "jet.intel" "s4.intel")) +else ifeq ("$(WW3_COMP)",$(filter "$(WW3_COMP)","Intel" "hera.intel" "orion.intel" "jet.intel" "s4.intel")) ESMF_F90COMPILEOPTS := $(ESMF_F90COMPILEOPTS) -convert big_endian else ifeq ("$(WW3_COMP)",$(filter "$(WW3_COMP)", "cheyenne.intel" "stampede.intel" "expanse.intel")) ESMF_F90COMPILEOPTS := $(ESMF_F90COMPILEOPTS) -convert big_endian @@ -100,6 +100,9 @@ ww3_nems: env setup gout switch ww3_nemslibonly: env setup switch $(WW3_BINDIR)/w3_make ww3_multi_esmf +ww3_nuopclibonly: env setup switch + $(WW3_BINDIR)/w3_make ww3_shel_esmf + ww3_multi_esmf: esmApp.o $(DEP_LINK_OBJS) $(ESMF_F90LINKER) $(ESMF_F90LINKOPTS) -o $(EXE) $^ \ $(ESMF_F90LINKPATHS) $(ESMF_F90LINKRPATHS) $(ESMF_F90ESMFLINKLIBS) @@ -161,9 +164,9 @@ switch: # ------------------------------------------------------------------------------ # ------------------------------------------------------------------------------ -# Setup switch file and compile serial routines ww3_grid, ww3_outf and ww3_outp +# Setup switch file and compile serial routines ww3_grid, ww3_outf and ww3_outp # ------------------------------------------------------------------------------ -gout: +gout: @echo "$(SWITCHES)" > $(WW3_BINDIR)/tempswitch @sed -e "s/DIST/SHRD/g"\ -e "s/OMPG/ /g"\ diff --git a/model/src/CMakeLists.txt b/model/src/CMakeLists.txt index 7ea7c9f38..04d26f317 100644 --- a/model/src/CMakeLists.txt +++ b/model/src/CMakeLists.txt @@ -126,18 +126,23 @@ if(NetCDF_Fortran_FOUND) list(APPEND programs ${netcdf_programs}) endif() -if(MULTI_ESMF) +if(UFS_CAP) # Don't search for ESMF if target already exists (when build WW3 as UFS submodule) if (NOT TARGET esmf) find_package(ESMF MODULE REQUIRED) endif() + + if(UFS_CAP STREQUAL "MULTI_ESMF") + set(cap_src ${esmf_multi_cap_src}) + elseif(UFS_CAP STREQUAL "NUOPC_MESH") + set(cap_src ${nuopc_mesh_cap_src}) + endif() - target_sources(ww3_lib PRIVATE wmesmfmd.F90) + target_sources(ww3_lib PRIVATE ${cap_src}) target_link_libraries(ww3_lib PUBLIC esmf) - set_target_properties(ww3_lib PROPERTIES OUTPUT_NAME "ww3_multi_esmf") # Don't build executables when building WW3 ESMF library set(programs "") -endif() +endif() set_property(SOURCE w3initmd.F90 APPEND diff --git a/model/src/cmake/src_list.cmake b/model/src/cmake/src_list.cmake index a73f3b72b..5c011508f 100644 --- a/model/src/cmake/src_list.cmake +++ b/model/src/cmake/src_list.cmake @@ -57,6 +57,19 @@ set(ftn_src w3tidemd.F90 ) +set(nuopc_mesh_cap_src + wav_kind_mod.F90 + wav_shr_mod.F90 + wav_shel_inp.F90 + wav_comp_nuopc.F90 + wav_import_export.F90 + w3iogoncdmd.F90 + ) + +set(esmf_multi_cap_src + wmesmfmd.F90 + ) + # Built when PDLIB is enabled set(pdlib_src ${CMAKE_CURRENT_SOURCE_DIR}/pdlib_field_vec.F90 diff --git a/model/src/w3adatmd.F90 b/model/src/w3adatmd.F90 index 3c0a70591..61d97aeff 100644 --- a/model/src/w3adatmd.F90 +++ b/model/src/w3adatmd.F90 @@ -23,13 +23,13 @@ MODULE W3ADATMD !/ 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) +!/ (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 +!/ 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. @@ -46,7 +46,7 @@ MODULE W3ADATMD !/ !/ Copyright 2009-2013 National Weather Service (NWS), !/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. +!/ reserved. WAVEWATCH III is a trademark of the NWS. !/ No unauthorized use without permission. !/ ! 1. Purpose : @@ -217,7 +217,7 @@ MODULE W3ADATMD ! Empty dummy fields (NOEXTR) ! ! USERO R.A. Public Empty output arrays than can be -! used by users as a simple means to +! used by users as a simple means to ! add output. ! ! Map data for propagation schemes (1Up). @@ -228,13 +228,13 @@ MODULE W3ADATMD ! Map data for propagation schemes (UQ). ! ! NMXn Int. Public Counters for MAPX2, see W3MAP3. -! NMYn Int. Public +! 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 +! 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 @@ -275,7 +275,7 @@ MODULE W3ADATMD ! (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): +! BSTAT I.A. Public Status of buffer (size MPIBUF): ! 0: Inactive. ! 1: A --> STORE (active or finished). ! 2: STORE --> A (active or finished). @@ -358,7 +358,7 @@ MODULE W3ADATMD TYPE WADAT ! ! The grid -! +! REAL, POINTER :: CG(:,:), WN(:,:) #ifdef W3_IC3 REAL, POINTER :: IC3WN_R(:,:), IC3WN_I(:,:), IC3CG(:,:) @@ -440,6 +440,9 @@ MODULE W3ADATMD XPRMS(:), XTPMS(:), XPHICE(:), & XTAUICE(:,:) REAL, POINTER :: XP2SMS(:,:), XUS3D(:,:), XUSSP(:,:) +#ifdef W3_CESMCOUPLED + REAL, POINTER :: XLANGMT(:) +#endif ! ! Output fields group 7) ! @@ -468,6 +471,12 @@ MODULE W3ADATMD ! 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 ! @@ -498,7 +507,7 @@ MODULE W3ADATMD LOGICAL, POINTER :: MAPTRN(:) #endif ! -! Warning Defined but not set if UGTYPE .EQ. .T. +! Warning Defined but not set if UGTYPE .EQ. .T. INTEGER, POINTER :: ITER(:,:) ! #ifdef W3_NL1 @@ -548,6 +557,11 @@ MODULE W3ADATMD !/ !/ 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(:,:) ! @@ -591,7 +605,7 @@ MODULE W3ADATMD BEDFORMS(:,:), PHIBBL(:), TAUBBL(:,:) ! REAL, POINTER :: MSSX(:), MSSY(:), MSSD(:), & - MSCX(:), MSCY(:), MSCD(:) + MSCX(:), MSCY(:), MSCD(:) ! REAL, POINTER :: DTDYN(:), FCUT(:), CFLXYMAX(:), & CFLTHMAX(:), CFLKMAX(:) @@ -862,7 +876,7 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) ! ! 7. Remarks : ! -! - W3SETA needs to be called after allocation to point to +! - W3SETA needs to be called after allocation to point to ! proper allocated arrays. ! ! 8. Structure : @@ -963,8 +977,8 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) ! CALL W3SETA ( IMOD, NDSE, NDST ) -! -!AR: Check this below more ... +! +!AR: Check this below more ... NXXX = NSEALM * NAPROC ! ! Output and input parameteres by output type @@ -973,13 +987,13 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) ! ALLOCATE ( WADATS(IMOD)%DW(0:NSEA) , STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) - WADATS(IMOD)%DW(:)=0. + 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. + WADATS(IMOD)%CY(:)=0. ! ALLOCATE ( WADATS(IMOD)%UA(0:NSEA) , WADATS(IMOD)%UD(0:NSEA) , & WADATS(IMOD)%U10(NSEA) , WADATS(IMOD)%U10D(NSEA) , & @@ -990,7 +1004,7 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) WADATS(IMOD)%TAUADIR(0:NSEA), STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) WADATS(IMOD)%TAUA(:) =0. - WADATS(IMOD)%TAUADIR(:)=0. + WADATS(IMOD)%TAUADIR(:)=0. #ifdef W3_MEMCHECK WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 2' @@ -1027,6 +1041,20 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) 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 @@ -1059,8 +1087,8 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) ! 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. +! by specific variables defined through the mod_def file +! and read by w3iogr, which is called before W3DIMA. #ifdef W3_DEBUGINIT WRITE(740+IAPROC,*) 'Before the EF allocation' WRITE(740+IAPROC,*) 'E3DF=', E3DF(1,1) @@ -1206,8 +1234,8 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) 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. +! 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 ) @@ -1241,6 +1269,9 @@ SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) WADATS(IMOD)%TPMS = UNDEF WADATS(IMOD)%PHICE = UNDEF WADATS(IMOD)%TAUICE = UNDEF +#ifdef W3_CESMCOUPLED + 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 @@ -1800,7 +1831,7 @@ SUBROUTINE W3XDMA ( IMOD, NDSE, NDST, OUTFLAGS ) ELSE ALLOCATE ( WADATS(IMOD)%XEF(1,1), STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) - END IF + END IF IF ( OUTFLAGS( 3, 2) ) THEN ALLOCATE ( WADATS(IMOD)%XTH1M(NXXX,E3DF(2,2):E3DF(3,2)), STAT=ISTAT ) @@ -2155,7 +2186,7 @@ SUBROUTINE W3XDMA ( IMOD, NDSE, NDST, OUTFLAGS ) ELSE ALLOCATE ( WADATS(IMOD)%XUS3D(1,1), STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) - END IF + END IF ! IF ( OUTFLAGS( 6, 9) ) THEN ALLOCATE ( WADATS(IMOD)%XP2SMS(NXXX,P2MSF(2):P2MSF(3)), STAT=ISTAT ) @@ -2163,7 +2194,7 @@ SUBROUTINE W3XDMA ( IMOD, NDSE, NDST, OUTFLAGS ) ELSE ALLOCATE ( WADATS(IMOD)%XP2SMS(1,1), STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) - END IF + END IF ! IF ( OUTFLAGS( 6,10) ) THEN ALLOCATE ( WADATS(IMOD)%XTAUICE(NXXX,2), STAT=ISTAT ) @@ -2200,7 +2231,16 @@ SUBROUTINE W3XDMA ( IMOD, NDSE, NDST, OUTFLAGS ) 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 @@ -2222,6 +2262,9 @@ SUBROUTINE W3XDMA ( IMOD, NDSE, NDST, OUTFLAGS ) 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 ) @@ -2481,7 +2524,7 @@ SUBROUTINE W3DMNL ( IMOD, NDSE, NDST, NSP, NSPX ) ! ! 7. Remarks : ! -! - W3SETA needs to be called after allocation to point to +! - W3SETA needs to be called after allocation to point to ! proper allocated arrays. ! ! 8. Structure : @@ -2737,7 +2780,7 @@ SUBROUTINE W3SETA ( IMOD, NDSE, NDST ) IF ( NADATA .EQ. -1 ) THEN WRITE (NDSE,1001) CALL EXTCDE (1) - END IF + END IF ! IF ( IMOD.LT.1 .OR. IMOD.GT.NADATA ) THEN WRITE (NDSE,1002) IMOD, NADATA @@ -2847,7 +2890,7 @@ SUBROUTINE W3SETA ( IMOD, NDSE, NDST ) WLM => WADATS(IMOD)%WLM T02 => WADATS(IMOD)%T02 T0M1 => WADATS(IMOD)%T0M1 - T01 => WADATS(IMOD)%T01 + T01 => WADATS(IMOD)%T01 FP0 => WADATS(IMOD)%FP0 THM => WADATS(IMOD)%THM THS => WADATS(IMOD)%THS @@ -2944,6 +2987,18 @@ SUBROUTINE W3SETA ( IMOD, NDSE, NDST ) 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 +#endif #ifdef W3_IC3 IC3WN_R=> WADATS(IMOD)%IC3WN_R IC3WN_I=> WADATS(IMOD)%IC3WN_I @@ -3160,7 +3215,7 @@ SUBROUTINE W3XETA ( IMOD, NDSE, NDST ) IF ( NADATA .EQ. -1 ) THEN WRITE (NDSE,1001) CALL EXTCDE (1) - END IF + END IF ! IF ( IMOD.LT.1 .OR. IMOD.GT.NADATA ) THEN WRITE (NDSE,1002) IMOD, NADATA @@ -3185,7 +3240,7 @@ SUBROUTINE W3XETA ( IMOD, NDSE, NDST ) WLM => WADATS(IMOD)%XWLM T02 => WADATS(IMOD)%XT02 T0M1 => WADATS(IMOD)%XT0M1 - T01 => WADATS(IMOD)%XT01 + T01 => WADATS(IMOD)%XT01 FP0 => WADATS(IMOD)%XFP0 THM => WADATS(IMOD)%XTHM THS => WADATS(IMOD)%XTHS @@ -3264,6 +3319,9 @@ SUBROUTINE W3XETA ( IMOD, NDSE, NDST ) 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 diff --git a/model/src/w3idatmd.F90 b/model/src/w3idatmd.F90 index 64c6b2c69..417706a93 100644 --- a/model/src/w3idatmd.F90 +++ b/model/src/w3idatmd.F90 @@ -21,7 +21,7 @@ MODULE W3IDATMD !/ !/ Copyright 2009 National Weather Service (NWS), !/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. +!/ reserved. WAVEWATCH III is a trademark of the NWS. !/ No unauthorized use without permission. !/ ! 1. Purpose : @@ -81,9 +81,12 @@ MODULE W3IDATMD ! 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 +#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 +! 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 @@ -124,7 +127,7 @@ MODULE W3IDATMD ! - 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 +! - INFLAGS1 dimensioning is hardwired as INFLAGS1(-7:14) where lowest possible ! value of JFIRST is JFIRST=-7 ! ! 6. Switches : @@ -198,11 +201,13 @@ MODULE W3IDATMD REAL, POINTER :: ICEP3(:,:) REAL, POINTER :: ICEP4(:,:) REAL, POINTER :: ICEP5(:,:) - #ifdef W3_TIDE REAL, POINTER :: CXTIDE(:,:,:,:) REAL, POINTER :: CYTIDE(:,:,:,:) REAL, POINTER :: WLTIDE(:,:,:,:) +#endif +#ifdef W3_CESMCOUPLED + REAL, POINTER :: HML(:,:) #endif LOGICAL :: IINIT #ifdef W3_WRST @@ -226,7 +231,7 @@ MODULE W3IDATMD TIN(:), TR0(:), TRN(:), T0N(:), & T1N(:), T2N(:), TDN(:), TG0(:), & TGN(:), TTN(:), TVN(:), TZN(:), & - TI1(:), TI2(:), TI3(:), TI4(:), TI5(:) + TI1(:), TI2(:), TI3(:), TI4(:), TI5(:) REAL, POINTER :: GA0, GD0, GAN, GDN REAL, POINTER :: WX0(:,:), WY0(:,:), DT0(:,:), & WXN(:,:), WYN(:,:), DTN(:,:), & @@ -249,11 +254,14 @@ MODULE W3IDATMD LOGICAL, POINTER :: FLLEV, FLCUR, FLWIND, FLICE, FLTAUA, & FLRHOA LOGICAL, POINTER :: FLMTH, FLMVS, FLMDN - LOGICAL, POINTER :: FLIC1, FLIC2, FLIC3, FLIC4, FLIC5 + LOGICAL, POINTER :: FLIC1, FLIC2, FLIC3, FLIC4, FLIC5 #ifdef W3_TIDE LOGICAL, POINTER :: FLLEVTIDE, FLCURTIDE, & FLLEVRESI, FLCURRESI #endif +#ifdef W3_CESMCOUPLED + REAL , POINTER :: HML(:,:) +#endif !/ CONTAINS !/ ------------------------------------------------------------------- / @@ -438,7 +446,7 @@ SUBROUTINE W3DIMI ( IMOD, NDSE, NDST, FLAGSTIDEIN ) ! See module documentation. ! ! 5. Called by : -! +! ! Main wave model drivers. ! ! 6. Error messages : @@ -448,7 +456,7 @@ SUBROUTINE W3DIMI ( IMOD, NDSE, NDST, FLAGSTIDEIN ) ! ! 7. Remarks : ! -! - W3SETI needs to be called after allocation to point to +! - W3SETI needs to be called after allocation to point to ! proper allocated arrays. ! ! 8. Structure : @@ -548,7 +556,7 @@ SUBROUTINE W3DIMI ( IMOD, NDSE, NDST, FLAGSTIDEIN ) FLLEVTIDE = FLAGSTIDE(1) FLCURTIDE = FLAGSTIDE(2) FLLEVRESI = FLAGSTIDE(3) - FLCURRESI = FLAGSTIDE(4) + FLCURRESI = FLAGSTIDE(4) #endif FLWIND => INPUTS(IMOD)%INFLAGS1(3) @@ -556,7 +564,7 @@ SUBROUTINE W3DIMI ( IMOD, NDSE, NDST, FLAGSTIDEIN ) FLTAUA => INPUTS(IMOD)%INFLAGS1(5) FLRHOA => INPUTS(IMOD)%INFLAGS1(6) ! -! notes: future improvement: flags for ICEPx should be +! notes: future improvement: flags for ICEPx should be ! "all or nothing" rather than 5 individual flags IF ( FLIC1 ) THEN @@ -632,7 +640,7 @@ SUBROUTINE W3DIMI ( IMOD, NDSE, NDST, FLAGSTIDEIN ) ! #ifdef W3_WRST - IF(.NOT.(INPUTS(IMOD)%WRSTIINIT)) THEN + IF(.NOT.(INPUTS(IMOD)%WRSTIINIT)) THEN ALLOCATE ( INPUTS(IMOD)%WXNwrst(NX,NY) , & INPUTS(IMOD)%WYNwrst(NX,NY) , STAT=ISTAT ) INPUTS(IMOD)%WRSTIINIT=.TRUE. @@ -704,6 +712,11 @@ SUBROUTINE W3DIMI ( IMOD, NDSE, NDST, FLAGSTIDEIN ) #endif CHECK_ALLOC_STATUS ( ISTAT ) END IF +! +#ifdef W3_CESMCOUPLED + ALLOCATE ( INPUTS(IMOD)%HML(NX,NY), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif ! INPUTS(IMOD)%IINIT = .TRUE. ! @@ -861,7 +874,7 @@ SUBROUTINE W3SETI ( IMOD, NDSE, NDST ) IF ( NIDATA .EQ. -1 ) THEN WRITE (NDSE,1001) CALL EXTCDE (1) - END IF + END IF ! IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NIDATA ) THEN WRITE (NDSE,1002) IMOD, -NAUXGR, NIDATA @@ -982,10 +995,10 @@ SUBROUTINE W3SETI ( IMOD, NDSE, NDST ) CYN => INPUTS(IMOD)%CYN END IF #ifdef W3_TIDE - IF ( FLLEVTIDE ) THEN + IF ( FLLEVTIDE ) THEN WLTIDE => INPUTS(IMOD)%WLTIDE END IF - IF ( FLCURTIDE ) THEN + IF ( FLCURTIDE ) THEN CXTIDE => INPUTS(IMOD)%CXTIDE CYTIDE => INPUTS(IMOD)%CYTIDE END IF @@ -1009,6 +1022,9 @@ SUBROUTINE W3SETI ( IMOD, NDSE, NDST ) ICEI => INPUTS(IMOD)%ICEI BERGI => INPUTS(IMOD)%BERGI END IF +#ifdef W3_CESMCOUPLED + HML => INPUTS(IMOD)%HML +#endif ! IF ( FLTAUA ) THEN UX0 => INPUTS(IMOD)%UX0 diff --git a/model/src/w3initmd.F90 b/model/src/w3initmd.F90 index a426cd884..b19f2bc66 100644 --- a/model/src/w3initmd.F90 +++ b/model/src/w3initmd.F90 @@ -63,7 +63,7 @@ MODULE W3INITMD !/ !/ Copyright 2009-2013 National Weather Service (NWS), !/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. +!/ reserved. WAVEWATCH III is a trademark of the NWS. !/ No unauthorized use without permission. !/ !/ Note: Changes in version numbers not logged above. @@ -154,14 +154,14 @@ SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & !/ 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 +!/ 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) +!/ (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) @@ -184,14 +184,14 @@ SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & ! ---------------------------------------------------------------- ! IMOD Int. I Model number. ! FEXT Char I Extension of data files. -! MDS I.A. I Array with dataset numbers (see below), +! 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. +! the shell. ! 5: Model definition file unit number. ! 6: Restart file unit number. ! 7: Grid output file unit number. @@ -252,7 +252,7 @@ SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & ! 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 +! CALL MPI_COMM_SIZE, CALL MPI_COMM_RANK ! Subr. mpif.h Standard MPI routines. ! ---------------------------------------------------------------- ! @@ -275,9 +275,9 @@ SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & ! 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 +! - 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. +! time by using /var/tmp/ for log files. ! See commented line at "OPEN (MDS(1),FILE=..." ! ! 8. Structure : @@ -376,7 +376,7 @@ SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & #endif USE W3IDATMD, ONLY: FLLEV, FLCUR, FLWIND, FLICE, FLTAUA, FLRHOA,& FLMDN, FLMTH, FLMVS, FLIC1, FLIC2, FLIC3, & - FLIC4, FLIC5 + FLIC4, FLIC5 USE W3DISPMD, ONLY: WAVNU1, WAVNU3 USE W3PARALL, ONLY: SET_UP_NSEAL_NSEALM #ifdef W3_PDLIB @@ -644,7 +644,7 @@ SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & #endif !!!/PDLIB CALL W3SETG(IMOD, NDSE, NDST) ! - LPDLIB = .FALSE. + LPDLIB = .FALSE. #ifdef W3_PDLIB LPDLIB = .TRUE. #endif @@ -669,7 +669,7 @@ SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & #endif #ifdef W3_DIST IW = 1 + INT ( LOG10 ( REAL(NAPROC) + 0.5 ) ) - IW = MAX ( 3 , MIN ( 9 , IW ) ) + IW = MAX ( 3 , MIN ( 9 , IW ) ) WRITE (FORMAT,'(A5,I1.1,A1,I1.1,A4)') & '(A4,I', IW, '.', IW, ',2A)' WRITE (TFILE,FORMAT) 'test', & @@ -678,11 +678,15 @@ SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & IFT = LEN_TRIM(TFILE) J = LEN_TRIM(FNMPRE) ! - IF ( OUTPTS(IMOD)%IAPROC .EQ. OUTPTS(IMOD)%NAPLOG ) & + +#ifndef W3_CESMCOUPLED #ifdef W3_DEBUGINIT + IF ( OUTPTS(IMOD)%IAPROC .EQ. OUTPTS(IMOD)%NAPLOG ) & WRITE(*,*) '1: w3initmd f=', TRIM(FNMPRE(:J)//LFILE(:IFL)) #endif - OPEN (MDS(1),FILE=FNMPRE(:J)//LFILE(:IFL),ERR=888,IOSTAT=IERR) + 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) @@ -845,7 +849,7 @@ SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & ! 2.b Save MAPSTA ! ALLOCATE ( MAPTST(NY,NX) ) - MAPTST = MAPSTA + MAPTST = MAPSTA #ifdef W3_MEMCHECK WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2e' @@ -1032,7 +1036,7 @@ SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & IAPPRO(ISP) = -1 END IF END IF - END DO + END DO END DO #endif ! @@ -1279,10 +1283,10 @@ SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & ! DO J=1, NOTYPE J0 = (J-1)*5 - TONEXT(1,J) = ODAT(J0+1) + 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(1,J) = ODAT(J0+4) TOLAST(2,J) = ODAT(J0+5) END DO ! @@ -1290,10 +1294,10 @@ SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & J=8 J0 = (J-1)*5 IF(ODAT(J0+1) .NE. 0) THEN - TONEXT(1,J) = ODAT(J0+1) + 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(1,J) = ODAT(J0+4) TOLAST(2,J) = ODAT(J0+5) FLOUT(8) = .TRUE. ELSE @@ -1375,12 +1379,12 @@ SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & #endif DO J=1, NOTYPE ! -! ... check time step +! ... check time step ! DTOUT(J) = MAX ( 0. , DTOUT(J) ) FLOUT(J) = FLOUT(J) .AND. ( DTOUT(J) .GT. 0.5 ) ! -! ... get first time +! ... get first time ! IF ( FLOUT(J) ) THEN #ifdef W3_NL5 @@ -1433,12 +1437,12 @@ SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & ! J=8 ! -! ... check time step +! ... check time step ! DTOUT(J) = MAX ( 0. , DTOUT(J) ) FLOUT(J) = FLOUT(J) .AND. ( DTOUT(J) .GT. 0.5 ) ! -! ... get first time +! ... get first time ! IF ( FLOUT(J) ) THEN TOUT = TONEXT(:,J) @@ -1519,7 +1523,7 @@ SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & ! ! 5. Define wavenumber grid ----------------------------------------- * ! 5.a Calculate depth -! +! #ifdef W3_T ALLOCATE ( MAPOUT(NX,NY), XOUT(NX,NY) ) XOUT = -1. @@ -1679,7 +1683,7 @@ SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & DEPTH = MAX ( DMIN , DW(IS) ) ELSE DEPTH = DMIN - END IF + END IF ! #ifdef W3_T1 WRITE (NDST,9051) IS, DEPTH @@ -2105,7 +2109,7 @@ SUBROUTINE W3MPII ( IMOD ) ! - 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 +! - 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. @@ -2575,6 +2579,11 @@ SUBROUTINE W3MPIO ( IMOD ) TAUOCX, TAUOCY, WNMEAN #endif +#ifdef W3_CESMCOUPLED + 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, & @@ -2670,7 +2679,7 @@ SUBROUTINE W3MPIO ( IMOD ) #ifdef W3_MPI ! Calculation of NRQMAX splitted by output groups and field type ! scalar 2-comp 3-comp - NRQMAX = 1 + 0 + 0 + & ! group 1 + 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 @@ -2694,7 +2703,7 @@ SUBROUTINE W3MPIO ( IMOD ) #endif ! #ifdef W3_MPI - IF ( NRQMAX .GT. 0 ) THEN + IF ( NRQMAX .GT. 0 ) THEN ALLOCATE ( OUTPTS(IMOD)%OUT1%IRQGO(NRQMAX) ) ALLOCATE ( OUTPTS(IMOD)%OUT1%IRQGO2(NRQMAX*NAPROC) ) END IF @@ -2984,7 +2993,7 @@ SUBROUTINE W3MPIO ( IMOD ) #endif ! #ifdef W3_MPI - IF ( FLGRDALL( 3, 1) ) THEN + IF ( FLGRDALL( 3, 1) ) THEN DO IK=E3DF(2,1),E3DF(3,1) IH = IH + 1 IT = IT + 1 @@ -2998,9 +3007,9 @@ SUBROUTINE W3MPIO ( IMOD ) END DO END IF #endif -! +! #ifdef W3_MPI - IF ( FLGRDALL( 3, 2) ) THEN + IF ( FLGRDALL( 3, 2) ) THEN DO IK=E3DF(2,2),E3DF(3,2) IH = IH + 1 IT = IT + 1 @@ -3014,9 +3023,9 @@ SUBROUTINE W3MPIO ( IMOD ) END DO END IF #endif -! +! #ifdef W3_MPI - IF ( FLGRDALL( 3, 3) ) THEN + IF ( FLGRDALL( 3, 3) ) THEN DO IK=E3DF(2,3),E3DF(3,3) IH = IH + 1 IT = IT + 1 @@ -3030,9 +3039,9 @@ SUBROUTINE W3MPIO ( IMOD ) END DO END IF #endif -! +! #ifdef W3_MPI - IF ( FLGRDALL( 3, 4) ) THEN + IF ( FLGRDALL( 3, 4) ) THEN DO IK=E3DF(2,4),E3DF(3,4) IH = IH + 1 IT = IT + 1 @@ -3046,9 +3055,9 @@ SUBROUTINE W3MPIO ( IMOD ) END DO END IF #endif -! +! #ifdef W3_MPI - IF ( FLGRDALL( 3, 5) ) THEN + IF ( FLGRDALL( 3, 5) ) THEN DO IK=E3DF(2,5),E3DF(3,5) IH = IH + 1 IT = IT + 1 @@ -3361,7 +3370,7 @@ SUBROUTINE W3MPIO ( IMOD ) WRITE (NDST,9011) IH, ' 5/01', IROOT, IT, IRQGO(IH), IERR #endif #ifdef W3_MPI - END IF + END IF #endif ! #ifdef W3_MPI @@ -3689,9 +3698,9 @@ SUBROUTINE W3MPIO ( IMOD ) END DO END IF #endif -! +! #ifdef W3_MPI - IF ( FLGRDALL( 6, 9) ) THEN + IF ( FLGRDALL( 6, 9) ) THEN DO K=P2MSF(2),P2MSF(3) IH = IH + 1 IT = IT + 1 @@ -3742,6 +3751,7 @@ SUBROUTINE W3MPIO ( IMOD ) #ifdef W3_MPI END IF #endif + ! #ifdef W3_MPI IF ( FLGRDALL( 6, 12) ) THEN @@ -3756,8 +3766,9 @@ SUBROUTINE W3MPIO ( IMOD ) #endif #ifdef W3_MPI END DO - END IF + END IF #endif + ! #ifdef W3_MPI IF ( FLGRDALL( 6, 13) ) THEN @@ -3778,6 +3789,20 @@ SUBROUTINE W3MPIO ( IMOD ) #ifdef W3_MPIT WRITE (NDST,9011) IH, ' 6/13', IROOT, IT, IRQGO(IH), IERR #endif +#ifdef W3_CESMCOUPLED +#ifdef W3_MPI + 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) + END IF +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/14', IROOT, IT, IRQGO(IH), IERR +#endif +#endif + #ifdef W3_MPI END IF #endif @@ -4392,7 +4417,7 @@ SUBROUTINE W3MPIO ( IMOD ) #endif ! #ifdef W3_MPI - IF ( FLGRDALL( 3, 1) ) THEN + IF ( FLGRDALL( 3, 1) ) THEN DO IK=E3DF(2,1),E3DF(3,1) IH = IH + 1 IT = IT + 1 @@ -4406,9 +4431,9 @@ SUBROUTINE W3MPIO ( IMOD ) END DO END IF #endif -! +! #ifdef W3_MPI - IF ( FLGRDALL( 3, 2) ) THEN + IF ( FLGRDALL( 3, 2) ) THEN DO IK=E3DF(2,2),E3DF(3,2) IH = IH + 1 IT = IT + 1 @@ -4422,9 +4447,9 @@ SUBROUTINE W3MPIO ( IMOD ) END DO END IF #endif -! +! #ifdef W3_MPI - IF ( FLGRDALL( 3, 3) ) THEN + IF ( FLGRDALL( 3, 3) ) THEN DO IK=E3DF(2,3),E3DF(3,3) IH = IH + 1 IT = IT + 1 @@ -4438,9 +4463,9 @@ SUBROUTINE W3MPIO ( IMOD ) END DO END IF #endif -! +! #ifdef W3_MPI - IF ( FLGRDALL( 3, 4) ) THEN + IF ( FLGRDALL( 3, 4) ) THEN DO IK=E3DF(2,4),E3DF(3,4) IH = IH + 1 IT = IT + 1 @@ -4454,9 +4479,9 @@ SUBROUTINE W3MPIO ( IMOD ) END DO END IF #endif -! +! #ifdef W3_MPI - IF ( FLGRDALL( 3, 5) ) THEN + IF ( FLGRDALL( 3, 5) ) THEN DO IK=E3DF(2,5),E3DF(3,5) IH = IH + 1 IT = IT + 1 @@ -5096,7 +5121,7 @@ SUBROUTINE W3MPIO ( IMOD ) END DO END IF #endif -! +! #ifdef W3_MPI IF ( FLGRDALL( 6, 9) ) THEN DO K=P2MSF(2),P2MSF(3) @@ -5163,7 +5188,7 @@ SUBROUTINE W3MPIO ( IMOD ) #endif #ifdef W3_MPI END DO - END IF + END IF #endif ! #ifdef W3_MPI @@ -5185,6 +5210,19 @@ SUBROUTINE W3MPIO ( IMOD ) #ifdef W3_MPIT WRITE (NDST,9011) IH, ' 6/13', IFROM, IT, IRQGO2(IH), IERR #endif +#ifdef W3_CESMCOUPLED +#ifdef W3_MPI + IF ( FLGRDALL( 6, 14) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (LANGMT (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END IF +#endif +#ifdef W3_MPIT + WRITE (NDST,9011) IH, ' 6/14', IROOT, IT, IRQGO(IH), IERR +#endif +#endif #ifdef W3_MPI END IF #endif @@ -6715,7 +6753,7 @@ SUBROUTINE W3MPIO ( IMOD ) ALLOCATE ( OUTPTS(IMOD)%OUT3%IRQTR(2*NAPROC) ) IRQTR => OUTPTS(IMOD)%OUT3%IRQTR DO I0=1, NAPROC - IFROM = I0 - 1 + IFROM = I0 - 1 IF ( I0 .NE. IAPROC ) THEN IH = IH + 1 IT = IT0 + 1 @@ -6741,13 +6779,13 @@ SUBROUTINE W3MPIO ( IMOD ) #endif ! #ifdef W3_MPI - NRQTR = IH + NRQTR = IH IT0 = IT0 + 2 #endif ! #ifdef W3_MPIT WRITE (NDST,9042) - WRITE (NDST,9043) NRQTR + WRITE (NDST,9043) NRQTR #endif ! #ifdef W3_MPI @@ -7054,9 +7092,9 @@ SUBROUTINE W3MPIP ( IMOD ) #ifdef W3_MPI DO I=1, NOPTS DO K=1,4 - IX(K)=IPTINT(1,K,I) + IX(K)=IPTINT(1,K,I) IY(K)=IPTINT(2,K,I) - END DO + END DO #endif ! #ifdef W3_MPI diff --git a/model/src/w3iogomd.F90 b/model/src/w3iogomd.F90 index 82f0e4a97..84fe9f9c0 100644 --- a/model/src/w3iogomd.F90 +++ b/model/src/w3iogomd.F90 @@ -444,7 +444,7 @@ SUBROUTINE W3READFLGRD ( NDSI , NDSO, NDSS, NDSEN, COMSTR, & ! TESTSTR=OUT_NAMES(IOUT+1) CALL W3FLDTOIJ(TESTSTR, IFI, IFJ, IAPROC, NAPOUT, NDSEN) - + IF(IFI .NE. -1) THEN FLG2D(IFI, IFJ) = .TRUE. ENDIF @@ -642,7 +642,7 @@ SUBROUTINE W3FLGRDFLAG ( NDSO, NDSS, NDSEN, FLDOUT, & ! TESTSTR=OUT_NAMES(IOUT+1) CALL W3FLDTOIJ(TESTSTR, IFI, IFJ, IAPROC, NAPOUT, NDSEN) - + IF(IFI .NE. -1) THEN FLG2D(IFI, IFJ) = .TRUE. ENDIF @@ -653,7 +653,7 @@ SUBROUTINE W3FLGRDFLAG ( NDSO, NDSS, NDSEN, FLDOUT, & ! FLT = .TRUE. DO IFI=1, NOGRP - IF ( IAPROC .EQ. NAPOUT ) THEN + IF ( IAPROC .EQ. NAPOUT ) THEN DO IFJ=1, NGRPP IF ( FLG2D(IFI,IFJ) ) THEN IF ( FLT ) THEN @@ -667,7 +667,7 @@ SUBROUTINE W3FLGRDFLAG ( NDSO, NDSS, NDSEN, FLDOUT, & ENDIF IF(ANY(FLG2D(IFI,:))) FLG1D(IFI)=.TRUE. !Update FLG1D END DO - IF ( IAPROC .EQ. NAPOUT ) THEN + IF ( IAPROC .EQ. NAPOUT ) THEN IF ( FLT ) WRITE (NDSO,1945) 'no fields defined' ENDIF ! @@ -1219,6 +1219,23 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) 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 +#endif #ifdef W3_S USE W3SERVMD, ONLY: STRACE #endif @@ -1278,6 +1295,17 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) 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) +#endif !/ !/ ------------------------------------------------------------------- / !/ @@ -1398,6 +1426,25 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) ! FP1 = UNDEF THP1 = 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. +#endif ! ! 2. Integral over discrete part of spectrum ------------------------ * ! @@ -1433,7 +1480,7 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) 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) + 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) @@ -1523,6 +1570,13 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) 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 +#endif + ! ! Directional moments in the last freq. band ! @@ -1562,8 +1616,39 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) 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 +#endif 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 +#endif END IF ! ABXX(JSEA) = MAX ( 0. , ABXX(JSEA) ) * FACTOR @@ -1876,6 +1961,11 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) ! 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 +#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 @@ -1905,6 +1995,11 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) 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) +#endif ! ! Tail for surface stokes drift is commented out: very sensitive to tail power ! @@ -1978,6 +2073,87 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) 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 + + 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 + + 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 + + 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 + + ! 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 + END IF +#endif ! ! Add here USERO(JSEA,1) ... ! diff --git a/model/src/w3iogoncdmd.F90 b/model/src/w3iogoncdmd.F90 new file mode 100644 index 000000000..53d0c0b2a --- /dev/null +++ b/model/src/w3iogoncdmd.F90 @@ -0,0 +1,765 @@ +!> @file w3iogoncmd +!! +!> @brief Write gridded model output as netCDF +!! +!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov +!> @date 01-05-2022 +#include "w3macros.h" + +module W3IOGONCDMD + +contains + +!/ ------------------------------------------------------------------- / + subroutine W3IOGONCD () + + ! Write netcdf ww3 history output + + USE CONSTANTS + USE W3WDATMD, ONLY: W3SETW, W3DIMW, TIME, WLV, ICE, ICEF, ICEH, BERG, UST, USTDIR, ASF + USE W3GDATMD, ONLY: NX, NY, E3DF, MAPSF, MAPSTA, NSEA, W3SETG + USE W3ODATMD, ONLY: NOGRP, NGRPP, IDOUT, UNDEF, NDST, NDSE, FLOGRD, NOSWLL, W3SETO + USE W3ADATMD, ONLY: W3SETA, W3DIMA, W3XETA + USE W3ADATMD, ONLY: AINIT, DW, UA, UD, AS, CX, CY, WN + USE W3ADATMD, ONLY: HS, WLM, T02, T0M1, T01, FP0, THM, THS, THP0, WBT + USE W3ADATMD, ONLY: FP1, THP1, DTDYN + USE W3ADATMD, ONLY: FCUT, ABA, ABD, UBA, UBD, SXX, SYY, SXY + USE W3ADATMD, ONLY: PHS, PTP, PLP, PDIR, PSI, PWS, PWST, PNR + USE W3ADATMD, ONLY: PTHP0, PQP, PPE, PGW, PSW, PTM1, PT1, PT2 + USE W3ADATMD, ONLY: PEP, USERO, TAUOX, TAUOY, TAUWIX, TAUWIY + USE W3ADATMD, ONLY: PHIAW, PHIOC, TUSX, TUSY, PRMS, TPMS + USE W3ADATMD, ONLY: USSX, USSY, MSSX, MSSY, MSSD, MSCX, MSCY + USE W3ADATMD, ONLY: MSCD, QP, TAUWNX, TAUWNY, CHARN, TWS, BHD + USE W3ADATMD, ONLY: PHIBBL, TAUBBL, WHITECAP, BEDFORMS, CGE, EF + USE W3ADATMD, ONLY: CFLXYMAX, CFLTHMAX, CFLKMAX, P2SMS, US3D + USE W3ADATMD, ONLY: TH1M, STH1M, TH2M, STH2M, HSIG, PHICE, TAUICE + USE W3ADATMD, ONLY: STMAXE, STMAXD, HMAXE, HCMAXE, HMAXD, HCMAXD, USSP +#ifdef W3_CESMCOUPLED + USE W3ADATMD, ONLY: LANGMT +#endif + use wav_shr_mod, only: time_origin, calendar_name, elapsed_secs + USE NETCDF + + IMPLICIT NONE +!/ +!/ ------------------------------------------------------------------- / +!/ Local parameters +!/ + INTEGER :: IGRD, IERR, I, J, IX, IY, ISEA, IFI, IFJ + REAL :: AUX1(NSEA), AUX2(NSEA), AUX3(NSEA), AUX4(NSEA) + REAL :: AUXE(NSEA,0:NOSWLL), AUXEF(NSEA,E3DF(2,1):E3DF(3,1)) + REAL, ALLOCATABLE :: AUX2D1(:,:), AUX2D2(:,:), AUX2D3(:,:) + REAL, ALLOCATABLE :: AUX3DEF(:,:,:), AUX3DE(:,:,:) + LOGICAL :: WAUX1, WAUX2, WAUX3, WAUXE, WAUXEF + INTEGER :: VARID, NCLOOP + CHARACTER(LEN=16) :: FLDSTR1, FLDSTR2, FLDSTR3, FLDSTRE + CHARACTER(LEN=16) :: UNITSTR1, UNITSTR2, UNITSTR3, UNITSTRE + CHARACTER(LEN=128) :: LNSTR1, LNSTR2, LNSTR3, LNSTRE + INTEGER :: EF_LEN + INTEGER :: NCID, DIMID(5) + CHARACTER(len=1024) :: FNAME + LOGICAL :: EXISTS +!/ +!/ ------------------------------------------------------------------- / +!/ +! + IGRD = 1 + CALL W3SETO ( IGRD, NDSE, NDST ) + CALL W3SETG ( IGRD, NDSE, NDST ) + CALL W3SETA ( IGRD, NDSE, NDST ) ! sets pointers into wadats in w3adatmd + CALL W3XETA ( IGRD, NDSE, NDST ) ! sets pointers into wadats in w3adatmd + CALL W3SETW ( IGRD, NDSE, NDST ) ! sets pointers into wdatas in w3wdatmd + + ! ------------------------------------------------------------- + ! Allocate fields needed for write + ! ------------------------------------------------------------- + + ALLOCATE ( AUX2D1(NX,NY), AUX2D2(NX,NY), AUX2D3(NX,NY), AUX3DE(NX,NY,0:NOSWLL) ) + ALLOCATE ( AUX3DEF(NX,NY,E3DF(2,1):E3DF(3,1)) ) + ! + ! ------------------------------------------------------------- + ! Create the netcdf file and return the ncid and dimid + ! ------------------------------------------------------------- + call hist_filename(fname) + + ef_len = e3df(3,1) - e3df(2,1) + 1 + inquire(file=trim(fname),exist=exists) + if (.not. exists) then + ierr = nf90_create(trim(fname),nf90_clobber,ncid) + call handle_err(ierr,'create') + ierr = nf90_def_dim(ncid,'nx',nx,dimid(1)) + call handle_err(ierr,'def_dimid1') + ierr = nf90_def_dim(ncid,'ny',ny,dimid(2)) + call handle_err(ierr,'def_dimid2') + ierr = nf90_def_dim(ncid,'noswll',noswll+1,dimid(3)) + call handle_err(ierr,'def_dimid3') + ierr = nf90_def_dim(ncid,'freq', ef_len, dimid(4)) !ef_len=25 + call handle_err(ierr,'def_dimid4') + ierr = nf90_def_dim(ncid,'time', nf90_unlimited, dimid(5)) + call handle_err(ierr,'def_dimid5') + ! define time axis + ierr = nf90_def_var(ncid, 'time', nf90_double, (/dimid(5)/), varid) + call handle_err(ierr,'def_timevar') + ierr = nf90_put_att(ncid, varid, 'units', trim(time_origin)) + call handle_err(ierr,'def_time_units') + ierr = nf90_put_att(ncid, varid, 'calendar', trim(calendar_name)) + call handle_err(ierr,'def_time_calendar') + else + ierr = nf90_open(trim(fname),nf90_write,ncid) + call handle_err(ierr,'open') + endif + + ! ------------------------------------------------------------- + ! Initialization + ! ------------------------------------------------------------- + + 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) ) FP0 (ISEA) = UNDEF + 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( 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 +#ifdef W3_CESMCOUPLED + IF ( FLOGRD( 6, 14) ) LANGMT(ISEA) = UNDEF !cesm specific +#endif + ! + 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)) == 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 + ! + ! ------------------------------------------------------------- + ! Actual output + ! ------------------------------------------------------------- + ! + ! 1st loop step define the netcdf variables and attributes + ! 2nd loop step, write the variables + + NC_LOOP: do NCLOOP = 1,2 + if (NCLOOP == 1) then + IERR = NF90_REDEF(NCID) + else if (NCLOOP == 2) then + IERR = NF90_ENDDEF(NCID) + endif + IFI_LOOP: do IFI=1, NOGRP + IFJ_LOOP: do IFJ=1, NGRPP + if ( FLOGRD(IFI,IFJ) ) then + WAUX1 = .false. ! vars with dims (nx,ny) shoved into AUX1 + WAUX2 = .false. ! y-component of vars with dims (nx,ny) shoved into AUX2 + WAUX3 = .false. ! unused + WAUXE = .false. ! wave height of partition vars with dims of NOSWLL, a mess + WAUXEF = .false. ! for vars with dims of (Freq,nx,ny) shoved into AUXEF + ! + ! Section 1) + ! + if ( IFI .eq. 1 .and. IFJ .eq. 1 ) then + AUX1(1:NSEA) = DW(1:NSEA) + WAUX1 = .true. + FLDSTR1 = 'DW' + UNITSTR1 = 'm' + LNSTR1 = 'Water depth' !CMB should use IDOUT here, see w3odatmd + else if ( IFI .eq. 1 .and. IFJ .eq. 2 ) then + AUX1(1:NSEA) = CX(1:NSEA) + AUX2(1:NSEA) = CY(1:NSEA) + WAUX1 = .true. + WAUX2 = .true. + FLDSTR1 = 'CX' + FLDSTR2 = 'CY' + UNITSTR1 = 'm/s' + UNITSTR2 = 'm/s' + LNSTR1 = 'Mean current, x-component' + LNSTR2 = 'Mean current, y-component' + else if ( IFI .eq. 1 .and. IFJ .eq. 3 ) 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 + WAUX1 = .true. + WAUX2 = .true. + FLDSTR1 = 'UAX' + FLDSTR2 = 'UAY' + UNITSTR1 = 'm/s' + UNITSTR2 = 'm/s' + LNSTR1 = 'Mean wind, x-component' + LNSTR2 = 'Mean wind, y-component' + else if ( IFI .eq. 1 .and. IFJ .eq. 4 ) then + AUX1(1:NSEA) = AS(1:NSEA) + WAUX1 = .true. + FLDSTR1 = 'AS' + UNITSTR1 = 'deg C' + LNSTR1 = 'Air-sea temperature difference' + else if ( IFI .eq. 1 .and. IFJ .eq. 5 ) then + AUX1(1:NSEA) = WLV(1:NSEA) + WAUX1 = .true. + FLDSTR1 = 'WLV' + UNITSTR1 = 'm' + LNSTR1 = 'Water levels' + else if ( IFI .eq. 1 .and. IFJ .eq. 6 ) then + AUX1(1:NSEA) = ICE(1:NSEA) + WAUX1 = .true. + FLDSTR1 = 'ICE' + UNITSTR1 = '1' + LNSTR1 = 'Ice coverage' + else if ( IFI .eq. 1 .and. IFJ .eq. 7 ) then + AUX1(1:NSEA) = BERG(1:NSEA) + WAUX1 = .true. + FLDSTR1 = 'BERG' + UNITSTR1 = '1' + LNSTR1 = '' + ! + ! Section 2) + ! + else if ( IFI .eq. 2 .and. IFJ .eq. 1 ) then + AUX1(1:NSEA) = HS(1:NSEA) + WAUX1 = .true. + FLDSTR1 = 'HS' + UNITSTR1 = 'm' + LNSTR1 = 'Significant wave height' + else if ( IFI .eq. 2 .and. IFJ .eq. 2 ) then + WAUX1 = .true. + FLDSTR1 = 'WLM' + UNITSTR1 = 'm' + LNSTR1 = 'Mean wave length' + else if ( IFI .eq. 2 .and. IFJ .eq. 3 ) then + AUX1(1:NSEA) = T02(1:NSEA) + WAUX1 = .true. + FLDSTR1 = 'T02' + UNITSTR1 = 's' + LNSTR1 = 'Mean wave period' + else if ( IFI .eq. 2 .and. IFJ .eq. 4 ) then + AUX1(1:NSEA) = T0M1(1:NSEA) + WAUX1 = .true. + FLDSTR1 = 'T0M1' + UNITSTR1 = 's' + LNSTR1 = 'Mean wave period' + else if ( IFI .eq. 2 .and. IFJ .eq. 5 ) then + AUX1(1:NSEA) = T01(1:NSEA) + WAUX1 = .true. + FLDSTR1 = 'T01' + UNITSTR1 = 's' + LNSTR1 = 'Mean wave period' + else if ( IFI .eq. 2 .and. IFJ .eq. 6 ) then + AUX1(1:NSEA) = FP0(1:NSEA) + WAUX1 = .true. + FLDSTR1 = 'FP0' + UNITSTR1 = 'Hz' + LNSTR1 = 'Peak frequency' + else if ( IFI .eq. 2 .and. IFJ .eq. 7 ) then + AUX1(1:NSEA) = THM(1:NSEA) + WAUX1 = .true. + FLDSTR1 = 'THM' + UNITSTR1 = 'rad' + LNSTR1 = 'Mean wave direction' + else if ( IFI .eq. 2 .and. IFJ .eq. 8 ) then + AUX1(1:NSEA) = THS(1:NSEA) + WAUX1 = .true. + FLDSTR1 = 'THS' + UNITSTR1 = 'rad' + LNSTR1 = 'Mean directional spread' + else if ( IFI .eq. 2 .and. IFJ .eq. 9 ) then + AUX1(1:NSEA) = THP0(1:NSEA) + WAUX1 = .true. + FLDSTR1 = 'THP0' + UNITSTR1 = 'rad' + LNSTR1 = 'Peak direction' + else if ( IFI .eq. 2 .and. IFJ .eq. 10 ) then + AUX1(1:NSEA) = HSIG(1:NSEA) + WAUX1 = .true. + FLDSTR1 = 'HSIG' + UNITSTR1 = '1' + LNSTR1 = '' + else if ( IFI .eq. 2 .and. IFJ .eq. 11 ) then + AUX1(1:NSEA) = STMAXE(1:NSEA) + WAUX1 = .true. + FLDSTR1 = 'STMAXE' + UNITSTR1 = 'm' + LNSTR1 = 'Max surface elev STE' + else if ( IFI .eq. 2 .and. IFJ .eq. 12 ) then + AUX1(1:NSEA) = STMAXD(1:NSEA) + WAUX1 = .true. + FLDSTR1 = 'STMAXD' + UNITSTR1 = 'm' + LNSTR1 = 'St Dev Max surface elev STE' + else if ( IFI .eq. 2 .and. IFJ .eq. 13 ) then + AUX1(1:NSEA) = HMAXE(1:NSEA) + WAUX1 = .true. + FLDSTR1 = 'HMAXE' + UNITSTR1 = 'm' + LNSTR1 = 'Max wave height STE' + else if ( IFI .eq. 2 .and. IFJ .eq. 14 ) then + AUX1(1:NSEA) = HCMAXE(1:NSEA) + WAUX1 = .true. + FLDSTR1 = 'HCMAXE' + UNITSTR1 = 'm' + LNSTR1 = 'Max wave height from crest STE' + else if ( IFI .eq. 2 .and. IFJ .eq. 15 ) then + AUX1(1:NSEA) = HMAXD(1:NSEA) + WAUX1 = .true. + FLDSTR1 = 'HMAXD' + UNITSTR1 = 'm' + LNSTR1 = 'St Dev of MXC (STE)' + else if ( IFI .eq. 2 .and. IFJ .eq. 16 ) then + AUX1(1:NSEA) = HCMAXD(1:NSEA) + WAUX1 = .true. + FLDSTR1 = 'HCMAXD' + UNITSTR1 = 'm' + LNSTR1 = 'St Dev of MXHC (STE)' + else if ( IFI .eq. 2 .and. IFJ .eq. 17 ) then + AUX1(1:NSEA) = WBT(1:NSEA) + WAUX1 = .true. + FLDSTR1 = 'WBT' + UNITSTR1 = 'm' + LNSTR1 = 'Dominant wave breaking probability b' + ! + ! Section 3) + ! + else if ( IFI .eq. 3 .and. IFJ .eq. 1 ) then + AUXEF(1:NSEA,E3DF(2,1):E3DF(3,1)) = EF(1:NSEA,E3DF(2,1):E3DF(3,1)) + WAUXEF = .true. + FLDSTRE = 'EF' + UNITSTRE = '1' + LNSTRE = '1D spectral density' + ! + ! Section 4) + ! + else if ( IFI .eq. 4 .and. IFJ .eq. 1 ) then + AUXE(1:NSEA,0:NOSWLL) = PHS(1:NSEA,0:NOSWLL) + WAUXE = .true. + FLDSTRE = 'PHS' + UNITSTRE = 'm' + LNSTRE = 'Wave height of partitions' + else if ( IFI .eq. 4 .and. IFJ .eq. 2 ) then + AUXE(1:NSEA,0:NOSWLL) = PTP(1:NSEA,0:NOSWLL) + WAUXE = .true. + FLDSTRE = 'PTP' + UNITSTRE = 's' + LNSTRE = 'Peak wave period of partitions' + else if ( IFI .eq. 4 .and. IFJ .eq. 3 ) then + AUXE(1:NSEA,0:NOSWLL) = PLP(1:NSEA,0:NOSWLL) + WAUXE = .true. + FLDSTRE = 'PLP' + UNITSTRE = 'm' + LNSTRE = 'Peak wave length of partitions' + ! + ! 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 + WAUX1 = .true. + WAUX2 = .true. + FLDSTR1 = 'ASFX' + FLDSTR2 = 'ASFY' + UNITSTR1 = 'm/s' + UNITSTR2 = 'm/s' + LNSTR1 = 'Skin friction velocity, x-component' + LNSTR2 = 'Skin friction velocity, y-component' + ! + ! Section 6) + ! + else if ( IFI .eq. 6 .and. IFJ .eq. 6 ) then + AUX1(1:NSEA) = USSX(1:NSEA) + AUX2(1:NSEA) = USSY(1:NSEA) + WAUX1 = .true. + WAUX2 = .true. + FLDSTR1 = 'USSX' + FLDSTR2 = 'USSY' + UNITSTR1 = 'm/s' + UNITSTR2 = 'm/s' + LNSTR1 = 'Stokes drift at z=0' + LNSTR2 = 'Stokes drift at z=0' +#ifdef W3_CESMCOUPLED + else if ( IFI .eq. 6 .and. IFJ .eq. 14 ) then + write(6,*)'DEBUG: nsea = ',nsea + write(6,*)'DEBUG: size(langmt) = ',size(langmt) + AUX1(1:NSEA) = LANGMT(1:NSEA) + WAUX1 = .true. + FLDSTR1 = 'LANGMT' + UNITSTR1 = '' + LNSTR1 = 'Turbulent Langmuir number (La_t)' +#endif + ! + ! 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 + WAUX1 = .true. + WAUX2 = .true. + FLDSTR1 = 'ABAX' + FLDSTR2 = 'ABAY' + UNITSTR1 = 'm' + UNITSTR2 = 'm' + LNSTR1 = 'Near bottom rms wave excursion amplitude, x-component' + LNSTR2 = 'Near bottom rms wave excursion amplitude, y-component' + 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 + WAUX1 = .true. + WAUX2 = .true. + FLDSTR1 = 'UBAX' + FLDSTR2 = 'UBAY' + UNITSTR1 = 'm/s' + UNITSTR2 = 'm/s' + LNSTR1 = 'Near bottom rms wave velocity, x-component' + LNSTR2 = 'Near bottom rms wave velocity, y-component' + ! + ! Section 8) + ! + ! + ! Section 9) + ! + ! + ! Section 10) + ! + else if ( IFI .eq. 10 ) then + AUX1(1:NSEA) = USERO(1:NSEA,2) + WAUX1 = .true. + FLDSTR1 = 'USERO' + UNITSTR1 = '1' + LNSTR1 = 'User defined variable' + end if + + ! netcdf history + if (NCLOOP == 1) then + ! write(ndse,*) 'w3iogo NCLOOP=',NCLOOP, WAUX1, WAUX2, WAUX3,WAUXE,WAUXEF + !--- no error checking here in case file/vars exists already --- + if (WAUX1) then + ! write(ndse,*) ' w3iogo NCLOOP=1, WAUX1=T, FLDSTR1, VARID', TRIM(FLDSTR1), VARID + IERR = NF90_DEF_VAR(NCID,trim(FLDSTR1),NF90_FLOAT,(/DIMID(1),DIMID(2),dimid(5)/),VARID) + IERR = NF90_PUT_ATT(NCID,VARID,"_FillValue",UNDEF) + IERR = NF90_PUT_ATT(NCID,VARID,"units",UNITSTR1) + IERR = NF90_PUT_ATT(NCID,VARID,"long_name",LNSTR1) + endif + if (WAUX2) then + ! write(ndse,*) ' w3iogo NCLOOP=1, WAUX2=T, FLDSTR2, VARID', TRIM(FLDSTR2), VARID + IERR = NF90_DEF_VAR(NCID,trim(FLDSTR2),NF90_FLOAT,(/DIMID(1),DIMID(2),dimid(5)/),VARID) + IERR = NF90_PUT_ATT(NCID,VARID,"_FillValue",UNDEF) + IERR = NF90_PUT_ATT(NCID,VARID,"units",UNITSTR2) + IERR = NF90_PUT_ATT(NCID,VARID,"long_name",LNSTR2) + endif + if (WAUX3) then + ! write(ndse,*) ' w3iogo NCLOOP=1, WAUX3=T, FLDSTR3, VARID ', TRIM(FLDSTR3), VARID + IERR = NF90_DEF_VAR(NCID,trim(FLDSTR3),NF90_FLOAT,(/DIMID(1),DIMID(2),dimid(5)/),VARID) + IERR = NF90_PUT_ATT(NCID,VARID,"_FillValue",UNDEF) + IERR = NF90_PUT_ATT(NCID,VARID,"units",UNITSTR3) + IERR = NF90_PUT_ATT(NCID,VARID,"long_name",LNSTR3) + endif + if (WAUXE) then + ! write(ndse,*) ' w3iogo NCLOOP=1, WAUXE=T, FLDSTRE, VARID ', TRIM(FLDSTRE), VARID + IERR = NF90_DEF_VAR(NCID,trim(FLDSTRE),NF90_FLOAT,(/DIMID(1),DIMID(2),DIMID(3),dimid(5)/),VARID) + IERR = NF90_PUT_ATT(NCID,VARID,"_FillValue",UNDEF) + IERR = NF90_PUT_ATT(NCID,VARID,"units",UNITSTRE) + IERR = NF90_PUT_ATT(NCID,VARID,"long_name",LNSTRE) + endif + if (WAUXEF) then + ! write(ndse,*) ' w3iogo NCLOOP=1, WAUXEF=T, FLDSTRE, VARID', TRIM(FLDSTRE), VARID + IERR = NF90_DEF_VAR(NCID,trim(FLDSTRE),NF90_FLOAT,(/DIMID(1),DIMID(2),DIMID(4),dimid(5)/),VARID) + IERR = NF90_PUT_ATT(NCID,VARID,"_FillValue",UNDEF) + IERR = NF90_PUT_ATT(NCID,VARID,"units",UNITSTRE) + IERR = NF90_PUT_ATT(NCID,VARID,"long_name",LNSTRE) + endif + + elseif (NCLOOP == 2) then + IERR = nf90_inq_varid(ncid, 'time', varid) + call HANDLE_ERR(IERR,'INQ_VARID_TIME'//trim('time')) + IERR = nf90_put_var(ncid, varid, elapsed_secs) + call HANDLE_ERR(IERR,'PUT_VAR_TIME'//trim('time')) + ! write(ndse,*) ' w3iogo write NCLOOP=',NCLOOP, WAUX1, WAUX2, WAUX3,WAUXE,WAUXEF + if (WAUX1) then + ! write(ndse,*) 'w3iogo write ',trim(fldstr1) + AUX2D1 = UNDEF + do ISEA=1, NSEA + AUX2D1(MAPSF(ISEA,1),MAPSF(ISEA,2)) = AUX1(ISEA) + enddo + IERR = NF90_INQ_VARID(NCID,trim(FLDSTR1),VARID) + call HANDLE_ERR(IERR,'INQ_VARID_AUX2D1_'//trim(FLDSTR1)) + IERR = NF90_PUT_VAR(NCID,VARID,AUX2D1) + call HANDLE_ERR(IERR,'PUT_VAR_AUX2D1_'//trim(FLDSTR1)) + endif + if (WAUX2) then + ! write(ndse,*) 'w3iogo write ',trim(fldstr2) + AUX2D2 = UNDEF + do ISEA=1, NSEA + AUX2D2(MAPSF(ISEA,1),MAPSF(ISEA,2)) = AUX2(ISEA) + enddo + IERR = NF90_INQ_VARID(NCID,trim(FLDSTR2),VARID) + call HANDLE_ERR(IERR,'INQ_VARID_AUX2D2_'//trim(FLDSTR2)) + IERR = NF90_PUT_VAR(NCID,VARID,AUX2D2) + call HANDLE_ERR(IERR,'PUT_VAR_AUX2D2_'//trim(FLDSTR2)) + endif + if (WAUX3) then + ! write(ndse,*) 'w3iogo write ',trim(fldstr3) + AUX2D3 = UNDEF + do ISEA=1, NSEA + AUX2D3(MAPSF(ISEA,1),MAPSF(ISEA,2)) = AUX3(ISEA) + enddo + IERR = NF90_INQ_VARID(NCID,trim(FLDSTR3),VARID) + call HANDLE_ERR(IERR,'INQ_VARID_AUX2D3_'//trim(FLDSTR3)) + IERR = NF90_PUT_VAR(NCID,VARID,AUX2D3) + call HANDLE_ERR(IERR,'PUT_VAR_AUX2D3_'//trim(FLDSTR3)) + endif + if (WAUXE) then + ! write(ndse,*) 'w3iogo write ',trim(fldstre) + AUX3DE = UNDEF + do ISEA=1, NSEA + AUX3DE(MAPSF(ISEA,1),MAPSF(ISEA,2),0:NOSWLL) = AUXE(ISEA,0:NOSWLL) + enddo + IERR = NF90_INQ_VARID(NCID,trim(FLDSTRE),VARID) + call HANDLE_ERR(IERR,'INQ_VARID_AUX2D1_'//trim(FLDSTRE)) + IERR = NF90_PUT_VAR(NCID,VARID,AUX3DE) + call HANDLE_ERR(IERR,'PUT_VAR_AUX3DE_'//trim(FLDSTRE)) + endif + if (WAUXEF) then + ! write(ndse,*) 'w3iogo write ',trim(fldstre) + AUX3DEF = UNDEF + do ISEA=1, NSEA + AUX3DEF(MAPSF(ISEA,1),MAPSF(ISEA,2),E3DF(2,1):E3DF(3,1)) = AUXEF(ISEA,E3DF(2,1):E3DF(3,1)) + enddo + IERR = NF90_INQ_VARID(NCID,trim(FLDSTRE),VARID) + call HANDLE_ERR(IERR,'INQ_VARID_AUX2D1_'//trim(FLDSTRE)) + IERR = NF90_PUT_VAR(NCID,VARID,AUX3DEF) + call HANDLE_ERR(IERR,'PUT_VAR_AUX3DE_'//trim(FLDSTRE)) + endif + endif !NC + + end if ! end of if ( FLOGRD(IFI,IFJ) ) + end do IFJ_LOOP + end do IFI_LOOP + end do NC_LOOP + + ierr = NF90_CLOSE(NCID) + call handle_err(IERR,'CLOSE') + deallocate(AUX2D1,AUX2D2,AUX2D3,AUX3DE,AUX3DEF) + + ! Flush the buffers for write + call W3SETA ( IGRD, NDSE, NDST ) + + end subroutine W3IOGONCD + +!/ ------------------------------------------------------------------- / + subroutine hist_filename(fname) + + USE WAV_SHR_MOD , ONLY : CASENAME, INST_SUFFIX + USE W3WDATMD , ONLY : TIME + USE W3ODATMD , ONLY : NDS, IAPROC, NAPOUT + + implicit none + + ! input/output variables + character(len=*), intent(out) :: fname + + ! 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 + + if (len_trim(inst_suffix) > 0) then + write(fname,'(a,i4.4,a,i2.2,a,i2.2,a,i5.5,a)') & + trim(casename)//'.ww3'//trim(inst_suffix)//'.hi.',yy,'-',mm,'-',dd,'-',totsec,'.nc' + else + write(fname,'(a,i4.4,a,i2.2,a,i2.2,a,i5.5,a)') & + trim(casename)//'.ww3.hi.',yy,'-',mm,'-',dd,'-',totsec,'.nc' + endif + + if (iaproc == napout) then + write(nds(1),'(a)') 'w3iogomdncd: writing history '//trim(fname) + end if + + end subroutine hist_filename + +!/ ------------------------------------------------------------------- / + SUBROUTINE HANDLE_ERR(IERR,STRING) + USE W3ODATMD, ONLY: NDSE + USE W3SERVMD, ONLY: EXTCDE + USE NETCDF + + IMPLICIT NONE + + ! input/output variables + integer ,intent(in) :: ierr + 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 ) + END IF + end SUBROUTINE HANDLE_ERR + +end module W3IOGONCDMD diff --git a/model/src/w3iorsmd.F90 b/model/src/w3iorsmd.F90 index 05371ed16..1f2815dda 100644 --- a/model/src/w3iorsmd.F90 +++ b/model/src/w3iorsmd.F90 @@ -101,7 +101,7 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) !/ 05-Jun-2018 : Add PDLIB/TIMINGS/DEBUGIO ( version 6.04 ) !/ DEBUGINIT/MPI !/ 19-Dec-2019 : Optional second stream of ( version 7.00 ) -!/ restart files +!/ 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 ) @@ -109,7 +109,7 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) !/ !/ Copyright 2009-2013 National Weather Service (NWS), !/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. +!/ reserved. WAVEWATCH III is a trademark of the NWS. !/ No unauthorized use without permission. !/ ! 1. Purpose : @@ -172,7 +172,7 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) ! 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 : ! @@ -260,11 +260,11 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) USE W3WDATMD #ifdef W3_WRST USE W3IDATMD, ONLY: WXN, WYN, W3SETI - USE W3IDATMD, ONLY: WXNwrst, WYNwrst + USE W3IDATMD, ONLY: WXNwrst, WYNwrst #endif USE W3ODATMD, ONLY: NDSE, NDST, IAPROC, NAPROC, NAPERR, NAPRST, & IFILE => IFILE4, FNMPRE, NTPROC, IOSTYP, & - FLOGRR, NOGRP, NGRPP, SCREEN + FLOGRR, NOGRP, NGRPP, SCREEN #ifdef W3_MPI USE W3ODATMD, ONLY: NRQRS, NBLKRS, RSBLKS, IRQRS, IRQRSS, & VAAUX @@ -278,6 +278,10 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) #ifdef W3_TIMINGS USE W3PARALL, ONLY: PRINT_MY_TIME #endif +#ifdef W3_CESMCOUPLED + USE W3ADATMD , ONLY : LAMULT + USE WAV_SHR_MOD, ONLY : RUNTYPE +#endif !!!!!/PDLIB USE PDLIB_FIELD_VEC!, only : UNST_PDLIB_READ_FROM_FILE, UNST_PDLIB_WRITE_TO_FILE #ifdef W3_PDLIB USE PDLIB_FIELD_VEC @@ -328,11 +332,15 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) LOGICAL :: WRITE, IOSFLG LOGICAL :: FLOGOA(NOGRP,NGRPP) - LOGICAL :: NDSROPN + LOGICAL :: NDSROPN CHARACTER(LEN=4) :: TYPE CHARACTER(LEN=10) :: VERTST +#ifdef W3_CESMCOUPLED + CHARACTER(LEN=512) :: FNAME +#else ! CHARACTER(LEN=21) :: FNAME CHARACTER(LEN=40) :: FNAME +#endif CHARACTER(LEN=26) :: IDTST CHARACTER(LEN=30) :: TNAME CHARACTER(LEN=15) :: TIMETAG @@ -344,7 +352,7 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) #endif ! ! -! Constant NDSR for using mpiifort in ZEUS ... paralell runs crashing +! 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 ! @@ -430,18 +438,32 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) ! ! open file ---------------------------------------------------------- * ! +#ifdef W3_CESMCOUPLED + call CESM_REST_FILENAME(WRITE, FNAME) + IFILE = IFILE + 1 + + IF ( WRITE ) THEN + IF ( .NOT.IOSFLG .OR. IAPROC.EQ.NAPRST ) & + OPEN (NDSR,FILE=FNAME,FORM='UNFORMATTED', & + ACCESS='STREAM',ERR=800,IOSTAT=IERR) + ELSE ! READ + OPEN (NDSR, FILE=FNAME, FORM='UNFORMATTED', & + 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 ( PRESENT(FLRSTRT) ) THEN IF (FLRSTRT) THEN WRITE(TIMETAG,"(i8.8,'.'i6.6)")TIME(1),TIME(2) FNAME=TIMETAG//'.restart.'//FILEXT(:I) - ITMP=1 - END IF - END IF + ITMP=1 + 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) @@ -451,7 +473,6 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) WRITE (FNAME(8:10),'(I3.3)') IFILE END IF END IF - IFILE = IFILE + 1 ! #ifdef W3_T @@ -479,6 +500,7 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) ACCESS='STREAM',ERR=800,IOSTAT=IERR, & STATUS='OLD',ACTION='READ') END IF +#endif ! ! test info ---------------------------------------------------------- * ! @@ -539,7 +561,7 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) DO I=1, NOGRP DO J=1, NGRPP IF (FLOGRR(I,J) .AND. .NOT. FLOGOA(I,J)) THEN - WRITE(SCREEN,1000) I, J + WRITE(SCREEN,1000) I, J ENDIF ENDDO ENDDO @@ -570,11 +592,21 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) 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 +#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 +#endif END IF ! #ifdef W3_T @@ -607,7 +639,7 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) #ifdef W3_T WRITE (NDST,9005) TYPE #endif - ! Clean up file handles and allocated arrays + ! Clean up file handles and allocated arrays INQUIRE (UNIT=NDSR, OPENED=NDSROPN) IF (NDSROPN) CLOSE(NDSR) IF (ALLOCATED(WRITEBUFF)) DEALLOCATE(WRITEBUFF) @@ -887,8 +919,8 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) 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 + 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) @@ -923,7 +955,7 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & (WXN(IX,IYL),IYL=1+(IPART-1)*NSIZE, & MIN(NY,IPART*NSIZE)) - END DO + END DO END DO DO IX=1, NX DO IPART=1,NPRTY2 @@ -933,7 +965,7 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & (WYN(IX,IYL),IYL=1+(IPART-1)*NSIZE, & MIN(NY,IPART*NSIZE)) - END DO + END DO END DO #endif ALLOCATE ( MAPTMP(NY,NX) ) @@ -1053,7 +1085,7 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) #ifdef W3_MPI CALL W3SETA ( IGRD, NDSE, NDST ) #endif - ENDIF + ENDIF #ifdef W3_T WRITE (NDST,9007) ELSE @@ -1127,15 +1159,15 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) MAPST2 = (MAPTMP-MAPSTA) / 8 DEALLOCATE ( MAPTMP ) ! -! Updates reflections maps: +! Updates reflections maps: ! IF (GTYPE.EQ.UNGTYPE) THEN !AR: not needed since already initialized on w3iogr CALL SET_UG_IOBP #ifdef W3_REF1 - ELSE + ELSE CALL W3SETREF #endif - ENDIF + ENDIF ! #ifdef W3_DEBUGINIT WRITE(740+IAPROC,*) 'Before reading UST' @@ -1438,8 +1470,8 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) TIC5(1) = -1 TIC5(2) = 0 #ifdef W3_WRST - WXNwrst = 0. - WYNwrst = 0. + WXNwrst = 0. + WYNwrst = 0. #endif WLV = 0. ICE = 0. @@ -1486,7 +1518,7 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) ! ! Close file --------------------------------------------------------- * ! - IF (WRITE) THEN + IF (WRITE) THEN IF ( .NOT.IOSFLG .OR. IAPROC.EQ.NAPRST ) THEN CLOSE ( NDSR ) END IF @@ -1608,6 +1640,71 @@ SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) !/ End of W3IORS ----------------------------------------------------- / !/ END SUBROUTINE W3IORS +#ifdef W3_CESMCOUPLED + SUBROUTINE CESM_REST_FILENAME(LWRITE, FNAME) + + USE WAV_SHR_MOD , ONLY : CASENAME, INITFILE, INST_SUFFIX, RUNTYPE + USE W3WDATMD , ONLY : TIME + USE W3SERVMD , ONLY : EXTCDE + USE W3ODATMD , ONLY : NDS, IAPROC, NAPOUT + + ! input/output variables + logical, intent(in) :: lwrite + character(len=*), intent(out) :: fname + + ! local variables + integer :: yy,mm,dd,hh,mn,ss,totsec + logical :: exists + logical :: lread + !---------------------------------------------- + + ! create local lread logical for clarity + if (lwrite) then + lread = .false. + else + lread = .true. + end if + + ! determine restart filename + if (lread .and. runtype /= 'continue') then + fname = initfile + else + 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 + + if (len_trim(inst_suffix) > 0) then + write(fname,'(a,i4.4,a,i2.2,a,i2.2,a,i5.5)') & + trim(casename)//'.ww3'//trim(inst_suffix)//'.r.',yy,'-',mm,'-',dd,'-',totsec + else + write(fname,'(a,i4.4,a,i2.2,a,i2.2,a,i5.5)') & + trim(casename)//'.ww3.r.',yy,'-',mm,'-',dd,'-',totsec + endif + end if + + ! check that if read the file exists + if (lread) then + inquire( file=fname, exist=exists) + if (.not. exists ) then + CALL EXTCDE (60, MSG="required initial/restart file " // trim(fname) // "does not exist") + end if + end if + + ! write out filename + if (iaproc == napout) then + if (lwrite) then + write (nds(1),'(a)') ' writing restart file '//trim(fname) + else + write (nds(1),'(a)') ' reading initial/restart file '//trim(fname) + end if + end if + + end subroutine cesm_rest_filename +#endif !/ !/ End of module W3IORSMD -------------------------------------------- / !/ diff --git a/model/src/w3odatmd.F90 b/model/src/w3odatmd.F90 index 3b9ecb04d..075b3118a 100644 --- a/model/src/w3odatmd.F90 +++ b/model/src/w3odatmd.F90 @@ -855,7 +855,7 @@ SUBROUTINE W3NOUT ( NDSERR, NDSTST ) ! ! 6) Wave-ocean layer ! - NOGE(6) = 13 + NOGE(6) = 13 ! IDOUT( 6, 1) = 'Radiation stresses ' IDOUT( 6, 2) = 'Wave-ocean mom. flux' @@ -870,6 +870,9 @@ SUBROUTINE W3NOUT ( NDSERR, NDSTST ) 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 ! diff --git a/model/src/w3sic4md.F90 b/model/src/w3sic4md.F90 index 8661b42af..9f9347de2 100644 --- a/model/src/w3sic4md.F90 +++ b/model/src/w3sic4md.F90 @@ -15,9 +15,9 @@ MODULE W3SIC4MD ! 1. Purpose : ! ! Calculate ice source term S_{ice} according to simple methods. -! Attenuation is a function of frequency and specified directly +! 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). +! the empirical data of Wadhams et al. (1988). ! ! 2. Variables and types : ! @@ -38,24 +38,24 @@ MODULE W3SIC4MD ! 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 +! 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 +! ---> "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 +! 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 +! ---> "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) +! ---> New recommendations for IC4 Method 2 (polynomial fit) ! and IC4 Method 6 (step function via namelist) ! ! 6. Switches : @@ -96,7 +96,7 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) !/ !/ Copyright 2009 National Weather Service (NWS), !/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. +!/ reserved. WAVEWATCH III is a trademark of the NWS. !/ No unauthorized use without permission. !/ ! 1. Purpose : @@ -117,11 +117,11 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) ! 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 +! 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 +! 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 @@ -157,7 +157,7 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) ! ICEP5=FC5=0.10 ! MUDD=FC6=0.12 ! MUDT=FC7=0.16 -! In terms of the 3-character IDs for "Homogeneous field +! 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 @@ -183,17 +183,17 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) ! 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, +! 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, +! 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 +! 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 @@ -250,11 +250,11 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) ! 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 +! 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. !/ ------------------------------------------------------------------- / ! @@ -292,6 +292,9 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) #ifdef W3_T1 USE W3ARRYMD, ONLY: OUTMAT #endif +#ifdef W3_CESMCOUPLED + USE W3IDATMD, ONLY: ICEI +#endif ! IMPLICIT NONE !/ @@ -316,6 +319,10 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) REAL :: ICECOEF1, ICECOEF2, ICECOEF3, & ICECOEF4, ICECOEF5, ICECOEF6, & ICECOEF7, ICECOEF8 +#ifdef W3_CESMCOUPLED + REAL :: x1,x2,x3,x1sqr,x2sqr,x3sqr + REAL :: perfour,amhb,bmhb,iceconc +#endif REAL :: KI1,KI2,KI3,KI4,FC5,FC6,FC7,FREQ REAL :: HS, EMEAN, HICE REAL, ALLOCATABLE :: WN_I(:) ! exponential decay rate for amplitude @@ -347,6 +354,9 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) KARG2 = 0.0 KARG3 = 0.0 WN_I = 0.0 +#ifdef W3_CESMCOUPLED + iceconc = 0.0 +#endif ALPHA = 0.0 ICECOEF1 = 0.0 ICECOEF2 = 0.0 @@ -358,7 +368,7 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) ICECOEF8 = 0.0 HS = 0.0 HICE = 0.0 - EMEAN = 0.0 + EMEAN = 0.0 ! ! IF (.NOT.INFLAGS2(-7))THEN ! WRITE (NDSE,1001) 'ICE PARAMETER 1' @@ -366,7 +376,7 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) ! ENDIF ! -! We cannot remove the other use of INFLAGS below, +! 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. @@ -375,6 +385,9 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) IF (INFLAGS2(-5)) ICECOEF3 = ICEP3(IX,IY) IF (INFLAGS2(-4)) ICECOEF4 = ICEP4(IX,IY) IF (INFLAGS2(-3)) ICECOEF5 = ICEP5(IX,IY) +#ifdef W3_CESMCOUPLED + IF (INFLAGS2(4)) iceconc = ICEI(IX,IY) +#endif ! Borrow from Smud (error if BT8 or BT9) #ifdef W3_BT8 @@ -388,7 +401,6 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) 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 --------------------------------------------------------- / @@ -409,7 +421,7 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) #endif ! ! 1. Make calculations ---------------------------------------------- / -! +! ! 1.a Calculate WN_I SELECT CASE (IC4METHOD) @@ -419,7 +431,7 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) 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, + !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 @@ -430,12 +442,12 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) 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 + 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 + CASE (4) !Eq. 1 from Kohout et al. 2014 !Calculate HS DO IK=1, NK EB(IK) = 0. @@ -514,6 +526,50 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) END DO WN_I= 0.5 * ALPHA +#ifdef W3_CESMCOUPLED + 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 + ! write(*,*) 'floe size', x2 + ! write(*,*) 'sic',iceconc + amhb = 2.12e-3 + bmhb = 4.59e-2 + + 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) + ! if (WN_I(ik).gt.0.9) then + ! write(*,*) 'whacky',WN_I(ik),x1,x2,x3 + ! endif + 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 + ! write(*,*) 'Attena',(10.0**KARG1(IK),IK=1,5) + ! write(*,*) 'Attenb',(WN_I(IK),IK=1,5) +#endif CASE DEFAULT WN_I = ICECOEF1 !Default to IC1: Uniform in k @@ -521,7 +577,7 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) ! ! 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 diff --git a/model/src/w3timemd.F90 b/model/src/w3timemd.F90 index 43bae0c02..73aee8399 100644 --- a/model/src/w3timemd.F90 +++ b/model/src/w3timemd.F90 @@ -11,7 +11,7 @@ MODULE W3TIMEMD !/ !/ Copyright 2009 National Weather Service (NWS), !/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. +!/ reserved. WAVEWATCH III is a trademark of the NWS. !/ No unauthorized use without permission. !/ ! 1. Purpose : @@ -36,7 +36,7 @@ MODULE W3TIMEMD ! 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 +! 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. @@ -588,18 +588,18 @@ REAL FUNCTION TDIFF ( T1, T2 ) ! 1. Purpose : ! ! Calculate the time difference in seconds between two time arrays -! that have been generated from the F90 internal function +! 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 +! 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(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 @@ -619,7 +619,7 @@ REAL FUNCTION TDIFF ( T1, T2 ) ! Any routine. ! ! 7. Remarks : -! +! ! This code has been provided by Mark Szyszka of RPSGROUP ! ! 8. Structure : @@ -918,7 +918,7 @@ REAL(KIND=8) FUNCTION TIME2HOURS(TIME) IH = TIME(2) / 10000 IMI = MOD(TIME(2),10000) / 100 IS = MOD(TIME(2),100) - JDAY = julday(id,IMO,iy) + JDAY = julday(id,IMO,iy) TIME2HOURS = 24.d0*dfloat(JDAY)+dfloat(IH)+dfloat(IS+IMI*60)/3600.d0 RETURN !/ @@ -935,7 +935,7 @@ SUBROUTINE PRINIT !/ | Last update : 06-May-2005 ! !/ +-----------------------------------+ !/ -!/ 06-May-2005 : Origination. ( version 3.07 ) +!/ 06-May-2005 : Origination. ( version 3.07 ) !/ ! 1. Purpose : ! @@ -1239,7 +1239,7 @@ SUBROUTINE D2J(DAT,JULIAN,IERR) ! Converts proleptic Gregorian date array to Julian Day ! ! -! * UDUNITS standard : mixed Gregorian/Julian calendar system. +! * 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 @@ -1332,7 +1332,7 @@ SUBROUTINE D2J(DAT,JULIAN,IERR) 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 + IF(JULIAN.lt.0.d0) THEN IERR=1 ELSE IERR=0 diff --git a/model/src/w3updtmd.F90 b/model/src/w3updtmd.F90 index b549d8144..9858ed659 100644 --- a/model/src/w3updtmd.F90 +++ b/model/src/w3updtmd.F90 @@ -32,17 +32,17 @@ MODULE W3UPDTMD !/ 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 ) +!/ 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. +!/ 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 +!/ 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 ) @@ -61,7 +61,7 @@ MODULE W3UPDTMD !/ !/ Copyright 2009-2014 National Weather Service (NWS), !/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. +!/ reserved. WAVEWATCH III is a trademark of the NWS. !/ No unauthorized use without permission. !/ ! 1. Purpose : @@ -214,8 +214,8 @@ SUBROUTINE W3UCUR ( FLFRST ) !/ ------------------------------------------------------------------- / 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 @@ -264,9 +264,9 @@ SUBROUTINE W3UCUR ( FLFRST ) 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 2-D CX0(NSEA, 1) variable. IF( FSWND ) THEN - IX = ISEA + IX = ISEA IY = 1 ELSE #endif @@ -324,7 +324,7 @@ SUBROUTINE W3UCUR ( FLFRST ) #endif #ifdef W3_TIDE - IF (FLCURTIDE) THEN + IF (FLCURTIDE) THEN ! WRITE(6,*) 'TIME CUR:',TIME, '##',TC0, '##',TCN TIDE_HOUR = TIME2HOURS(TIME) ! @@ -350,7 +350,7 @@ SUBROUTINE W3UCUR ( FLFRST ) ! DO ISEA=1, NSEA #ifdef W3_TIDE - IF (FLCURTIDE) THEN ! could move IF test outside of ISEA loop ... + 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) @@ -362,14 +362,14 @@ SUBROUTINE W3UCUR ( FLFRST ) 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) + 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) @@ -398,7 +398,7 @@ SUBROUTINE W3UCUR ( FLFRST ) #ifdef W3_TIDE CX(ISEA) = WCURTIDEX CY(ISEA) = WCURTIDEY - ELSE + ELSE #endif CABS = CA0(ISEA) + RD * CAI(ISEA) @@ -421,7 +421,7 @@ SUBROUTINE W3UCUR ( FLFRST ) 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 + ! CX(ISEA), CY(ISEA),WCURTIDEX, WCURTIDEY END IF #endif ! @@ -538,7 +538,7 @@ SUBROUTINE W3UWND ( FLFRST, VGX, VGY ) USE W3GDATMD, ONLY: ZWIND, OFSTAB, FFNG, FFPS, CCNG, CCPS, SHSTAB #endif #ifdef W3_SMC - USE W3GDATMD, ONLY: NARC, NGLO, ANGARC, ARCTC, FSWND + 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, & @@ -583,7 +583,7 @@ SUBROUTINE W3UWND ( FLFRST, VGX, VGY ) !!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 + IX = ISEA IY = 1 ELSE #endif @@ -839,8 +839,8 @@ SUBROUTINE W3UTAU ( FLFRST ) !/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY: 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: TAUA, TAUADIR, MA0, MAI, MD0, MDI @@ -880,7 +880,7 @@ SUBROUTINE W3UTAU ( FLFRST ) !!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 + IX = ISEA IY = 1 ELSE #endif @@ -1101,12 +1101,12 @@ SUBROUTINE W3UINI ( A ) WRITE (NDST,9010) #endif ! -! this is not clear what is going on betwen w3init and this ... +! 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 + IF (GTYPE.EQ.UNGTYPE) THEN + XGR=1. ! to be fixed later ELSE IX = MAPSF(ISEA,1) IY = MAPSF(ISEA,2) @@ -1243,10 +1243,10 @@ SUBROUTINE W3UBPT !/ 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. +!/ 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 ) +!/ 13-Jun-2019 : Rotation only if POLAT<90 (C.Hansen)( version 7.11 ) !/ ! 1. Purpose : ! @@ -1322,7 +1322,7 @@ SUBROUTINE W3UBPT REAL :: HS1, HS2 #endif #ifdef W3_RTD - !! Declare a temporary spectr variable. JGLi12Jun2012 + !! Declare a temporary spectr variable. JGLi12Jun2012 REAL :: Spectr(NSPEC), AnglBP #endif !/ @@ -1441,7 +1441,7 @@ SUBROUTINE W3UIC1( FLFRST ) !/ | Last update : 27-Aug-2015 | !/ +-----------------------------------+ !/ -!/ 27-Aug-2015 : Creation ( version 5.10 ) +!/ 27-Aug-2015 : Creation ( version 5.10 ) !/ ! 1. Purpose : ! @@ -1488,7 +1488,7 @@ SUBROUTINE W3UIC1( FLFRST ) ! ! 10. Source code : ! -!/ ------------------------------------------------------------------- / +!/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY: NSEA, NSEA, MAPSF, IICEHMIN, IICEHFAC USE W3WDATMD, ONLY: TIME, TIC1, ICEH USE W3IDATMD, ONLY: TI1, ICEP1, FLIC1 @@ -1498,10 +1498,10 @@ SUBROUTINE W3UIC1( FLFRST ) !/ ------------------------------------------------------------------- / !/ Parameter list LOGICAL, INTENT(IN) :: FLFRST -!/ +!/ !/ ------------------------------------------------------------------- / !/ Local variables -!/ +!/ INTEGER :: IX, IY, ISEA !/ !/ @@ -1533,7 +1533,7 @@ SUBROUTINE W3UIC1( FLFRST ) !/ End of W3UIC1 ----------------------------------------------------- / !/ END SUBROUTINE W3UIC1 -!/ ------------------------------------------------------------------- / +!/ ------------------------------------------------------------------- / SUBROUTINE W3UIC5( FLFRST ) !/ !/ +-----------------------------------+ @@ -1543,8 +1543,8 @@ SUBROUTINE W3UIC5( FLFRST ) !/ | Last update : 13-Jan-2016 | !/ +-----------------------------------+ !/ -!/ 27-Aug-2015 : Creation ( version 5.08 ) -!/ 13-Jan-2016 : Changed initial value of ICEDMAX ( version 5.08 ) +!/ 27-Aug-2015 : Creation ( version 5.08 ) +!/ 13-Jan-2016 : Changed initial value of ICEDMAX ( version 5.08 ) !/ ! 1. Purpose : ! @@ -1591,7 +1591,7 @@ SUBROUTINE W3UIC5( FLFRST ) ! ! 10. Source code : ! -!/ ------------------------------------------------------------------- / +!/ ------------------------------------------------------------------- / USE W3IDATMD, ONLY: TI5, ICEP5 USE W3GDATMD, ONLY: NSEA, MAPSF USE W3WDATMD, ONLY: TIME, TIC5, ICE, ICEH, ICEF, ICEDMAX @@ -1601,11 +1601,11 @@ SUBROUTINE W3UIC5( FLFRST ) !/ ------------------------------------------------------------------- / !/ Parameter list LOGICAL, INTENT(IN) :: FLFRST -!/ +!/ !/ !/ ------------------------------------------------------------------- / !/ Local variables -!/ +!/ INTEGER :: IX, IY, ISEA LOGICAL :: FLFLOE !/ @@ -1621,17 +1621,17 @@ SUBROUTINE W3UIC5( FLFRST ) ! 2. Main loop over sea points -------------------------------------- * - DO ISEA=1, NSEA + 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 + IF ( FLFLOE) THEN ICEF(ISEA) = 0.0 ICEDMAX(ISEA) = 1000.0 ELSE ICEF(ISEA) = ICEP5(IX,IY) - ICEDMAX(ISEA) = ICEP5(IX,IY) + ICEDMAX(ISEA) = ICEP5(IX,IY) END IF END DO ! @@ -1647,7 +1647,7 @@ SUBROUTINE W3UIC5( FLFRST ) !/ End of W3UIC5 ----------------------------------------------------- / !/ END SUBROUTINE W3UIC5 -!/ ------------------------------------------------------------------- / +!/ ------------------------------------------------------------------- / SUBROUTINE W3UICE ( VA ) !/ @@ -1731,6 +1731,10 @@ SUBROUTINE W3UICE ( VA ) 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 !/ @@ -1803,6 +1807,9 @@ SUBROUTINE W3UICE ( VA ) ICEI(IX,IY), 'ICE (NEW)' #endif VA(:,JSEA) = 0. +#if defined(W3_UWM) || defined(W3_CESMCOUPLED) + charn(jsea) = aalpha +#endif #ifdef W3_T ELSE WRITE (NDST,9021) ISEA, IX, IY, MAPSTA(IY,IX), & @@ -1834,6 +1841,9 @@ SUBROUTINE W3UICE ( VA ) ICEI(IX,IY), 'SEA (NEW)' #endif VA(:,JSEA) = 0. +#if defined(W3_UWM) || defined(W3_CESMCOUPLED) + charn(jsea) = aalpha +#endif ! #ifdef W3_T ELSE @@ -2092,7 +2102,7 @@ SUBROUTINE W3ULEV ( A, VA ) ! 1.d Update water levels and save old ! #ifdef W3_TIDE - IF (FLLEVTIDE) THEN + IF (FLLEVTIDE) THEN ! WRITE(6,*) 'TIME:',TIME TIDE_HOUR = TIME2HOURS(TIME) ! @@ -2122,12 +2132,12 @@ SUBROUTINE W3ULEV ( A, VA ) DWO(ISEA) = DW(ISEA) ! #ifdef W3_TIDE - IF (FLLEVTIDE) 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 + !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) @@ -2155,7 +2165,7 @@ SUBROUTINE W3ULEV ( A, VA ) ! END IF ! End of verification WLV(ISEA) = WLEVTIDE - ELSE + ELSE #endif ! WLV(ISEA) = WLEV(IX,IY) @@ -2167,7 +2177,7 @@ SUBROUTINE W3ULEV ( A, VA ) END IF #endif #ifdef W3_TIDE - ENDIF + ENDIF #endif DW (ISEA) = MAX ( 0. , WLVeff-ZB(ISEA) ) @@ -2405,7 +2415,7 @@ SUBROUTINE W3ULEV ( A, VA ) WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 8' FLUSH(740+IAPROC) #endif - IF (GTYPE.EQ.UNGTYPE) THEN + IF (GTYPE.EQ.UNGTYPE) THEN #ifdef W3_DEBUGW3ULEV WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 9' FLUSH(740+IAPROC) @@ -2419,10 +2429,10 @@ SUBROUTINE W3ULEV ( A, VA ) FLUSH(740+IAPROC) #endif #ifdef W3_REF1 - ELSE + ELSE CALL W3SETREF #endif - ENDIF + ENDIF #ifdef W3_DEBUGW3ULEV WRITE(740+IAPROC,*) 'Beginning of W3ULEV, step 11' FLUSH(740+IAPROC) @@ -2563,7 +2573,7 @@ SUBROUTINE W3URHO ( FLFRST ) !!Li For sea-point only SMC grid air density is stored on !!Li 2-D RH0(NSEA, 1) variable. IF( FSWND ) THEN - IX = ISEA + IX = ISEA IY = 1 ELSE #endif @@ -2650,7 +2660,7 @@ SUBROUTINE W3UTRN ( TRNX, TRNY ) ! ! 2. Method : ! -! Two arrays are generated with the size (NY*NX,-1:1). The value +! 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 @@ -2703,7 +2713,7 @@ SUBROUTINE W3UTRN ( TRNX, TRNY ) !/ !/ ------------------------------------------------------------------- / !/ Parameter list -!/ +!/ REAL, INTENT(IN) :: TRNX(NY*NX), TRNY(NY*NX) !/ !/ ------------------------------------------------------------------- / @@ -2901,7 +2911,7 @@ SUBROUTINE W3UTRN ( TRNX, TRNY ) IF (FICEL.GT.0.) THEN TRIX(IXY) = EXP(-ICE(ISEA)*DX/FICEL) TRIY(IXY) = EXP(-ICE(ISEA)*DY/FICEL) - ELSE + ELSE #endif ! Otherwise: original Tolman expression (Tolman 2003) #ifdef W3_IC0 @@ -2927,8 +2937,8 @@ SUBROUTINE W3UTRN ( TRNX, TRNY ) ! #ifdef W3_IC0 TRIX(IXY) = MAX ( 0. , MIN ( 1. , TRIX(IXY) ) ) - TRIY(IXY) = MAX ( 0. , MIN ( 1. , TRIY(IXY) ) ) - END IF + TRIY(IXY) = MAX ( 0. , MIN ( 1. , TRIY(IXY) ) ) + END IF #endif ! ! Adding iceberg attenuation @@ -3046,7 +3056,7 @@ SUBROUTINE W3DZXY( ZZ, ZUNIT, DZZDX, DZZDY ) ! 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. +! 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 diff --git a/model/src/w3wavemd.F90 b/model/src/w3wavemd.F90 index 29659b39a..645b9902d 100644 --- a/model/src/w3wavemd.F90 +++ b/model/src/w3wavemd.F90 @@ -85,7 +85,7 @@ MODULE W3WAVEMD !/ 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 ) +!/ 11-Nov-2021 : Remove XYB since it is obsolete ( version 7.xx ) !/ !/ Copyright 2009-2014 National Weather Service (NWS), !/ National Oceanic and Atmospheric Administration. All rights @@ -450,6 +450,11 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & #ifdef W3_TIMINGS USE W3PARALL, only : PRINT_MY_TIME #endif +#if defined(W3_UWMNCOUT) || defined(W3_CESMCOUPLED) + ! flags for restart and history writes + USE WAV_SHR_MOD , only : RSTWR, HISTWR + USE W3IOGONCDMD , ONLY : W3IOGONCD +#endif ! IMPLICIT NONE ! @@ -1269,8 +1274,8 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & 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 #ifdef W3_DEBUGDCXDX @@ -1283,7 +1288,7 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & 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 + ENDIF !! End GTYPE ! #ifdef W3_MEMCHECK write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 4' @@ -1544,9 +1549,7 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & ! #ifdef W3_IS2 IF ( FLIC5 .AND. DTI50.NE.0. ) THEN -#endif ! -#ifdef W3_IS2 IF ( TIC5(1).GE.0 ) THEN IF ( DTI50 .LT. 0. ) THEN IDACT(18:18) = 'B' @@ -1557,18 +1560,14 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & ELSE IDACT(18:18) = 'I' END IF -#endif ! -#ifdef W3_IS2 IF ( IDACT(18:18).NE.' ' ) THEN CALL W3UIC5( FLFRST ) DTI50 = 0. FLACT = .TRUE. FLMAP = .TRUE. END IF -#endif ! -#ifdef W3_IS2 END IF #endif @@ -1674,7 +1673,7 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & #ifdef W3_PR3 CALL W3MAPT #endif - END IF !! GTYPE + END IF !! GTYPE CALL W3NMIN ( MAPSTA, FLAG0 ) IF ( FLAG0 .AND. IAPROC.EQ.NAPERR ) WRITE (NDSE,1030) IMOD FLMAP = .FALSE. @@ -1694,8 +1693,8 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & 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) @@ -2166,8 +2165,8 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & 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) ) + DCXDY(IY,IX), DCYDX(IY,IX), DCYDY(IY,IX), & + DCDX(:,IY,IX), DCDY(:,IY,IX), VA(:,JSEA) ) #endif ! ELSE @@ -2196,10 +2195,10 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & 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) ) + CFLTHMAX(JSEA), CFLKMAX(JSEA) ) #endif ! - END IF !! GTYPE + END IF !! GTYPE ! END IF END DO @@ -2432,28 +2431,28 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & #ifdef W3_SMC !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 - - !Li Work out root PE (ISPEC) and JSEA numbers for IY + IY = NGLO + IK + ENDIF + + !Li Work out root PE (ISPEC) and JSEA numbers for IY #ifdef W3_DIST - ISPEC = MOD( IY-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 ... ! #ifdef W3_SMC - !!Li Assign boundary cell spectra. + !!Li Assign boundary cell spectra. IF( IAPROC .EQ. ISPEC+1 ) THEN SPCBAC(:,IK)=VA(:,JSEA) ENDIF @@ -2476,32 +2475,32 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & ALLOCATE ( BACSPEC(NSPEC) ) DO IK = 1, NBAC IF( IK .LE. (NBAC-NBGL) ) THEN - IX = NGLO + IK + IX = NGLO + IK BACANGL = ANGARC(IK) ELSE IX = ICLBAC(IK) BACANGL = - ANGARC(IK) - ENDIF + ENDIF - !!Li Work out boundary PE (ISPEC) and JSEA numbers for IX + !!Li Work out boundary PE (ISPEC) and JSEA numbers for IX #ifdef W3_DIST - ISPEC = MOD( IX-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) - + CALL w3acturn( NTH, NK, BACANGL, BACSPEC ) - VA(:,JSEA) = BACSPEC - !!Li WRITE(NDSE,*) "IAPROC, IX, JSEAx, IK=", IAPROC, IX, JSEA, IK + VA(:,JSEA) = BACSPEC + !!Li WRITE(NDSE,*) "IAPROC, IX, JSEAx, IK=", IAPROC, IX, JSEA, IK ENDIF END DO !! Loop IK ends. @@ -2579,8 +2578,8 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & 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) ) + DCXDY(IY,IX), DCYDX(IY,IX), DCYDY(IY,IX), & + DCDX(:,IY,IX), DCDY(:,IY,IX), VA(:,JSEA) ) #endif ! ELSE @@ -2611,7 +2610,7 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & CFLTHMAX(JSEA), CFLKMAX(JSEA) ) #endif ! - END IF !! GTYPE + END IF !! GTYPE ! END IF END DO @@ -3020,9 +3019,19 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & #endif ! #ifdef W3_MPI +#if defined(W3_UWMNCOUT) || defined(W3_CESMCOUPLED) + ! CMB: dsec21 computes the difference between time1, time2 in sec + ! pretty sure tonext always equal to time on the hour + ! so this is getting called every hour + ! seems like it only needs to be done when histwr=T though + ! so am chaning + IF ( histwr .and. & + (FLOUT(1) .OR. FLOUT(7)) ) THEN +#else IF ( ( (DSEC21(TIME,TONEXT(:,1)).EQ.0.) .AND. FLOUT(1) ) .OR. & ( (DSEC21(TIME,TONEXT(:,7)).EQ.0.) .AND. FLOUT(7) .AND. & SBSED ) ) THEN +#endif IF (.NOT. LPDLIB .or. (GTYPE.ne.UNGTYPE)) THEN IF (NRQGO.NE.0 ) THEN #endif @@ -3033,6 +3042,9 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & #endif #ifdef W3_MPI CALL MPI_STARTALL ( NRQGO, IRQGO , IERR_MPI ) +#if defined(W3_UWMNCOUT) || defined(W3_CESMCOUPLED) + write(*,*) 'UWM/CESM histwr mpi_startall', histwr, NRQGO, IERR_MPI +#endif #endif #ifdef W3_DEBUGRUN WRITE(740+IAPROC,*) 'AFTER STARTALL NRQGO.NE.0, step 0' @@ -3054,16 +3066,19 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & IF (NRQGO2.NE.0 ) THEN #endif #ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'BEFORE STARTALL NRQGO2.NE.0, step 0', & - NRQGO2, IRQGO2, GTYPE, UNGTYPE, .NOT. LPDLIB .or. (GTYPE.ne.UNGTYPE) - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'BEFORE STARTALL NRQGO2.NE.0, step 0', & + NRQGO2, IRQGO2, GTYPE, UNGTYPE, .NOT. LPDLIB .or. (GTYPE.ne.UNGTYPE) + FLUSH(740+IAPROC) #endif #ifdef W3_MPI CALL MPI_STARTALL ( NRQGO2, IRQGO2, IERR_MPI ) +#if defined(W3_UWMNCOUT) || defined(W3_CESMCOUPLED) + write(*,*) 'UWM/CESM: histwr mpi_startall', histwr, NRQGO, IERR_MPI +#endif #endif #ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'AFTER STARTALL NRQGO2.NE.0, step 0' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'AFTER STARTALL NRQGO2.NE.0, step 0' + FLUSH(740+IAPROC) #endif #ifdef W3_MPI FLGMPI(1) = .TRUE. @@ -3077,11 +3092,11 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & ELSE #endif #ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'BEFORE DO_OUTPUT_EXCHANGES, step 0' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'BEFORE DO_OUTPUT_EXCHANGES, step 0' + FLUSH(740+IAPROC) #endif #ifdef W3_PDLIB - CALL DO_OUTPUT_EXCHANGES(IMOD) + CALL DO_OUTPUT_EXCHANGES(IMOD) #endif #ifdef W3_MPI END IF @@ -3246,6 +3261,20 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & DTTST = DSEC21 ( TIME, TOUT ) ! IF ( DTTST .EQ. 0. ) THEN +#if defined(W3_UWMNCOUT) || defined(W3_CESMCOUPLED) + ! This assumes that W3_SBS is not defined + IF ( ( J .EQ. 1 ) .AND. histwr) THEN + CALL MPI_WAITALL( NRQGO, IRQGO, STATIO, IERR_MPI ) + FLGMPI(0) = .FALSE. + write(*,*) 'CESM w3wavemd: hist flag 1', j, histwr, time, IERR_MPI + IF ( IAPROC .EQ. NAPFLD ) THEN + IF ( FLGMPI(1) ) CALL MPI_WAITALL & + ( NRQGO2, IRQGO2, STATIO, IERR_MPI ) + FLGMPI(1) = .FALSE. + write(*,*) 'CESM w3wavemd: hist flag 2', j, histwr, time, IERR_MPI + CALL W3IOGONCD () + END IF +#else IF ( ( J .EQ. 1 ) & #ifdef W3_SBS .OR. ( J .EQ. 7 ) & @@ -3264,9 +3293,7 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & CALL W3IOGO( 'WRITE', NDS(7), ITEST, IMOD ) #ifdef W3_SBS ENDIF -#endif -! -#ifdef W3_SBS + ! ! ! Generate output flag file for fields and SBS coupling. ! @@ -3275,14 +3302,14 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & FOUTNAME = 'Field_done.' // IDTIME(1:4) & // IDTIME(6:7) // IDTIME(9:10) & // IDTIME(12:13) // '.' // FILEXT(1:JJ) -#endif ! -#ifdef W3_SBS OPEN( UNIT=NDSOFLG, FILE=FOUTNAME) CLOSE( NDSOFLG ) #endif END IF ! +! end of UWMNCOUT/W3_CESMCOUPLED cppif-block +#endif ELSE IF ( J .EQ. 2 ) THEN ! ! Point output @@ -3300,8 +3327,14 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & ! Track output ! CALL W3IOTR ( NDS(11), NDS(12), VA, IMOD ) +#ifdef W3_CESMCOUPLED + ! add restart flag + ELSE IF ( J .EQ. 4 .AND. rstwr ) THEN + CALL W3IORS ('HOT', NDS(6), XXX, IMOD, FLOUT(8) ) +#else ELSE IF ( J .EQ. 4 ) THEN CALL W3IORS ('HOT', NDS(6), XXX, IMOD, FLOUT(8) ) +#endif ITEST = RSTYPE ELSE IF ( J .EQ. 5 ) THEN IF ( IAPROC .EQ. NAPBPT ) THEN @@ -3321,7 +3354,7 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & ! IF (DTOUT(7).NE.0) THEN IF ( (MOD(ID_OASIS_TIME,NINT(DTOUT(7))) .EQ. 0 ) .AND. & - (DSEC21 (TIME00, TIME) .GT. 0.0) ) THEN + (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 )) @@ -3442,6 +3475,10 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & #ifdef W3_MPI IF ( FLGMPI(0) ) CALL MPI_WAITALL & ( NRQGO, IRQGO , STATIO, IERR_MPI ) +#if defined(W3_UWMNCOUT) || defined(W3_CESMCOUPLED) + IF ( FLGMPI(1) .and. ( IAPROC .EQ. NAPFLD ) ) CALL MPI_WAITALL & + ( NRQGO2, IRQGO2 , STATIO, IERR_MPI ) +#endif IF ( FLGMPI(2) ) CALL MPI_WAITALL & ( NRQPO, IRQPO1, STATIO, IERR_MPI ) IF ( FLGMPI(4) ) CALL MPI_WAITALL & diff --git a/model/src/wav_comp_nuopc.F90 b/model/src/wav_comp_nuopc.F90 new file mode 100644 index 000000000..4109ac05a --- /dev/null +++ b/model/src/wav_comp_nuopc.F90 @@ -0,0 +1,1490 @@ +!> @file wav_comp_nuopc +!! +!> A NUOPC interface for WAVEWATCH III using the CMEPS mediator +!! +!> @details This module contains the base functionality of a mesh-based +!! NUOPC cap for WW3. It contains the only public entry point, SetServices +!! which registers all of the user-provided subroutines accessed by the NUOPC +!! layer. These include the user-routines to advertise the standard names of the +!! import and export fields (InitializeAdvertise), initialize the Wave model and +!! and realize the required fields within the import and export States on an +!! ESMF Mesh (InitializeRealize), fill the export State with initial values +!! (DataInitialize), advance the model one timestep (ModelAdvance), manage the +!! component clock (ModelSetRunClock), and finalize the component model at the +!! (ModelFinalize). +!! +!! The module wav_import_export includes the public routines to advertise and +!! realize the import and export fields called during the InitializeAdvertise and +!! InitializRealize phases, respectively and to fill the import and export states +!! during the ModelAdvance phase. +!! +!! The module wav_shr_mod contains public routines to access basic ESMF functions +!! and reduce code duplication. +!! +!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov +!> @date 01-05-2022 +module wav_comp_nuopc + + use ESMF + use NUOPC , only : NUOPC_CompDerive, NUOPC_CompSetEntryPoint, NUOPC_CompSpecialize + use NUOPC , only : NUOPC_CompFilterPhaseMap, NUOPC_IsUpdated, NUOPC_IsAtTime + use NUOPC , only : NUOPC_CompAttributeGet, NUOPC_Advertise + use NUOPC , only : NUOPC_SetAttribute, NUOPC_CompAttributeGet, NUOPC_CompAttributeSet + use NUOPC_Model , only : model_routine_SS => SetServices + use NUOPC_Model , only : model_label_Advance => label_Advance + use NUOPC_Model , only : model_label_DataInitialize => label_DataInitialize + use NUOPC_Model , only : model_label_SetRunClock => label_SetRunClock + use NUOPC_Model , only : model_label_Finalize => label_Finalize + use NUOPC_Model , only : NUOPC_ModelGet, SetVM + use wav_kind_mod , only : r8=>shr_kind_r8, i8=>shr_kind_i8, i4=>shr_kind_i4 + use wav_kind_mod , only : cl=>shr_kind_cl, cs=>shr_kind_cs + 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 : runtype, merge_import, dbug_flag + use w3odatmd , only : nds, iaproc, napout + use wav_shr_mod , only : casename, multigrid, inst_suffix, inst_index + use wav_shr_mod , only : time_origin, calendar_name, elapsed_secs +#ifndef W3_CESMCOUPLED + use wmwavemd , only : wmwave + use wmupdtmd , only : wmupd2 + use wmmdatmd , only : mdse, mdst, nrgrd, improc, nmproc, wmsetm, stime, etime + use wmmdatmd , only : nmpscr + use w3updtmd , only : w3uini + use w3adatmd , only : flcold, fliwnd +#endif + use constants , only : is_esmf_component + + implicit none + private ! except + + public :: SetServices + public :: SetVM + private :: InitializeP0 + private :: InitializeAdvertise + private :: InitializeRealize + private :: ModelSetRunClock + private :: ModelAdvance + private :: ModelFinalize + + include "mpif.h" + + !-------------------------------------------------------------------------- + ! Private module data + !-------------------------------------------------------------------------- + + character(len=CL) :: flds_scalar_name = '' !< the default scalar field name + integer :: flds_scalar_num = 0 !< the default number of scalar fields + integer :: flds_scalar_index_nx = 0 !< the default size of the scalar field nx + integer :: flds_scalar_index_ny = 0 !< the default size of the scalar field ny + logical :: profile_memory = .false. !< default logical to control use of ESMF + !! memory profiling + + logical :: histwr_is_active = .false. !< default logical to control use of ESMF + !! alarms for writing history files + logical :: root_task = .false. !< logical to indicate root task +#ifdef W3_CESMCOUPLED + logical :: cesmcoupled = .true. !< logical to indicate CESM use case +#else + logical :: cesmcoupled = .false. !< logical to indicate non-CESM use case + integer, allocatable :: tend(:,:) !< the ending time of ModelAdvance when + !! run with multigrid=true +#endif + + character(*), parameter :: modName = "(wav_comp_nuopc)" !< the name of this module + character(*), parameter :: u_FILE_u = & !< a character string for an ESMF log message + __FILE__ + +!=============================================================================== +contains +!=============================================================================== +!> The public entry point. The NUOPC SetService method registers all of the +!! user-provided subroutines in the module with the NUOPC layer +!! +!! @param[in] gcomp an ESMF_GridComp object +!! @param[out] rc return code +!! +!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov +!> @date 01-05-2022 + subroutine SetServices(gcomp, rc) + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + character(len=*),parameter :: subname=trim(modName)//':(SetServices) ' + + rc = ESMF_SUCCESS + call ESMF_LogWrite(trim(subname)//' called', ESMF_LOGMSG_INFO) + + ! the NUOPC gcomp component will register the generic methods + call NUOPC_CompDerive(gcomp, model_routine_SS, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! switching to IPD versions + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + userRoutine=InitializeP0, phase=0, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! set entry point for methods that require specific implementation + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + phaseLabelList=(/"IPDv01p1"/), userRoutine=InitializeAdvertise, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + phaseLabelList=(/"IPDv01p3"/), userRoutine=InitializeRealize, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! attach specializing method(s) + + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_DataInitialize, & + specRoutine=DataInitialize, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Advance, & + specRoutine=ModelAdvance, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_MethodRemove(gcomp, label=model_label_SetRunClock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_SetRunClock, & + specRoutine=ModelSetRunClock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Finalize, & + specRoutine=ModelFinalize, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) + + end subroutine SetServices + + !=============================================================================== +!> Switch to IPDv01 by filtering all other phaseMap entries +!! +!> @details Called by NUOPC to set the version of the Initialize Phase Definition +!! (IPD) to use. +!! +!! @param[in] gcomp an ESMF_GridComp object +!! @param[in] importState an ESMF_State object for import fields +!! @param[in] exportState an ESMF_State object for export fields +!! @param[in] clock an ESMF_Clock object +!! @param[out] rc return code +!! +!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov +!> @date 01-05-2022 + subroutine InitializeP0(gcomp, importState, exportState, clock, rc) + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! Switch to IPDv01 by filtering all other phaseMap entries + + call NUOPC_CompFilterPhaseMap(gcomp, ESMF_METHOD_INITIALIZE, acceptStringList=(/"IPDv01p"/), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + end subroutine InitializeP0 + + !=============================================================================== +!> Read configuration attributes and advertise the import/export fields + +!> @details Called by NUOPC to read configuration attributes and to advertise the +!! import and export fields. The configuration attributes are used to control run +!! time settings, such as ESMF memory profiling, additional debug logging, multigrid +!! mode and character strings for specific use cases. A set of configuration attributes +!! is also read to describe any scalar fields to be added to a state. For coupling +!! with the wave model, only a scalar field for the dimensions of the wave model +!! is required. The scalar field is added to the export state to communicate to the +!! CMEPS mediator the domain dimensions of the wave model in order to write +!! mediator history and restart files. The attribute ScalarFieldName sets the name +!! of the scalar field in the export state, the ScalarFieldCount sets the +!! dimensionality of the scalar field and the ScalarFieldIdxGridNX (NY) set the +!! index of the NX or NY dimension in the scalar field. +!! +!! @param[in] gcomp an ESMF_GridComp object +!! @param[in] importState an ESMF_State object for import fields +!! @param[in] exportState an ESMF_State object for export fields +!! @param[in] clock an ESMF_Clock object +!! @param[out] rc return code +!! +!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov +!> @date 01-05-2022 + subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) + + ! input/output arguments + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! local variables + character(len=CL) :: logmsg + logical :: isPresent, isSet + character(len=CL) :: cvalue + character(len=*), parameter :: subname=trim(modName)//':(InitializeAdvertise) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + call ESMF_LogWrite(trim(subname)//' called', ESMF_LOGMSG_INFO) + + !---------------------------------------------------------------------------- + ! advertise fields + !---------------------------------------------------------------------------- + + 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 + else + 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 + else + 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 + else + 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 + else + 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) + 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 + 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 + end if + write(logmsg,'(A,i6)') trim(subname)//': Wave cap dbug_flag is ',dbug_flag + call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO) + + ! Get casename + call NUOPC_CompAttributeGet(gcomp, name="case_name", value=casename, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write(logmsg,'(A)') trim(subname)//': Wave casename setting : '//trim(casename) + call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO) + + ! Get component instance + 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 + else + inst_suffix = "" + inst_index=1 + endif + + multigrid = .false. + 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) multigrid=(trim(cvalue)=="true") + write(logmsg,'(A,l)') trim(subname)//': Wave multigrid setting is ',multigrid + call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO) + + call advertise_fields(importState, exportState, flds_scalar_name, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) + + end subroutine InitializeAdvertise + + !======================================================================== +!> Realize the import and export fields. + +!> @details Called by NUOPC to realize the import and export fields +!! for the wave model. After the wave model initializes, the global index +!! for all sea points is retrieved using the WW3 mapsf array. A global index +!! array is then constructed which contains both land and sea points, with +!! the land points at the end of the array. An ESMF Distgrid object is created +!! using this global index array. The distgrid is then transfered to the ESMF +!! Mesh provided for the wave model domain. If the provided Mesh does not contain +!! a grid mask, then the internal WW3 mask is transfered to the Mesh, otherwise +!! the mask provided with the mesh file will be used. This mask is used by +!! CMEPS to map to and from the wave model. Once the mesh has been created, the +!! advertised fields are realized on the mesh. +!! +!! @param[in] gcomp an ESMF_GridComp object +!! @param[in] importState an ESMF_State object for import fields +!! @param[in] exportState an ESMF_State object for export fields +!! @param[in] clock an ESMF_Clock object +!! @param[out] rc return code +!! +!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov +!> @date 01-05-2022 + subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) + + use w3odatmd , only : w3nout, w3seto, naproc, iaproc, naperr, napout + 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 w3wdatmd , only : va, time, w3ndat, w3dimw, w3setw +#ifndef W3_CESMCOUPLED + use wminitmd , only : wminit, wminitnml + use wmunitmd , only : wmuget, wmuset +#endif + use wav_shel_inp , only : set_shel_io + + ! input/output variables + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState + type(ESMF_State) :: exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! local variables + type(ESMF_DistGrid) :: distGrid + type(ESMF_Mesh) :: Emesh, EmeshTemp + type(ESMF_Array) :: elemMaskArray + type(ESMF_VM) :: vm + type(ESMF_Time) :: esmfTime, stopTime + type(ESMF_TimeInterval) :: TimeStep + type(ESMF_Calendar) :: calendar + character(CL) :: cvalue + integer :: shrlogunit + integer :: yy,mm,dd,hh,ss + integer :: dtime_sync ! integer timestep size + integer :: start_ymd ! start date (yyyymmdd) + integer :: start_tod ! start time of day (sec) + integer :: stop_ymd ! stop date (yyyymmdd) + integer :: stop_tod ! stop time of day (sec) + integer :: ix, iy + character(CL) :: starttype + integer :: time0(2), ntrace(2) + integer :: timen(2) + integer :: i,j + integer :: ierr + integer :: n, jsea,isea, ncnt + integer :: ntotal, nlnd + integer :: nlnd_global, nlnd_local + integer :: my_lnd_start, my_lnd_end + integer, allocatable, target :: mask_global(:) + integer, allocatable, target :: mask_local(:) + integer, allocatable :: gindex_lnd(:) + integer, allocatable :: gindex_sea(:) + integer, allocatable :: gindex(:) + integer(i4) :: maskmin + integer(i4), pointer :: meshmask(:) + logical :: isPresent, isSet + character(23) :: dtme21 + integer :: iam, mpi_comm + character(ESMF_MAXSTR) :: msgString + character(ESMF_MAXSTR) :: diro + character(ESMF_MAXSTR) :: timestring + character(CL) :: logfile + logical :: local + integer :: imod, idsi, idso, idss, idst, idse + integer :: mds(13) ! Note that nds is set to this in w3initmod + integer :: stdout + integer :: petcount + character(ESMF_MAXSTR) :: preamb = './' + character(ESMF_MAXSTR) :: ifname = 'ww3_multi.inp' + character(len=*), parameter :: subname = '(wav_comp_nuopc:InitializeRealize)' + ! ------------------------------------------------------------------- + + rc = ESMF_SUCCESS + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' called', ESMF_LOGMSG_INFO) + + !-------------------------------------------------------------------- + ! Set up data structures + !-------------------------------------------------------------------- + + 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 ) + end if + + !---------------------------------------------------------------------------- + ! Generate local mpi comm + !---------------------------------------------------------------------------- + + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_VMGet(vm, mpiCommunicator=mpi_comm, peCount=petcount, localPet=iam, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return +#ifndef W3_CESMCOUPLED + nmproc = petcount +#else + naproc = petcount +#endif + + ! naproc,iproc, napout, naperr are not available until after wminit +#ifndef W3_CESMCOUPLED + improc = iam + 1 + if (multigrid) then + nmpscr = 1 + is_esmf_component = .true. + else + iaproc = iam + 1 + naproc = nmproc + napout = 1 + naperr = 1 + end if + if (improc == 1) root_task = .true. +#else + iaproc = iam + 1 + napout = 1 + naperr = 1 + if (iaproc == napout) root_task = .true. +#endif + + !-------------------------------------------------------------------- + ! IO set-up + !-------------------------------------------------------------------- + + 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 + else + 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)')'===============================================' + end if + + !-------------------------------------------------------------------- + ! Initialize run type + !-------------------------------------------------------------------- + + 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" + else if (trim(starttype) == trim('continue') ) then + runtype = "continue" + else if (trim(starttype) == trim('branch')) then + runtype = "branch" + end if + if ( root_task ) then + write(stdout,*) 'WW3 runtype is '//trim(runtype) + end if + call ESMF_LogWrite('WW3 runtype is '//trim(runtype), ESMF_LOGMSG_INFO) + + !-------------------------------------------------------------------- + ! Time initialization + !-------------------------------------------------------------------- + + ! TIME0 = from ESMF clock + ! NOTE - are not setting TIMEN here + + if ( root_task ) then + 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 + else + 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 ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + 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' + else if (calendar == ESMF_CALKIND_NOLEAP) then + 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 + call ymd2date(yy, mm, dd, start_ymd) + + hh = start_tod/3600 + mm = (start_tod - (hh * 3600))/60 + ss = start_tod - (hh*3600) - (mm*60) + + time0(1) = start_ymd + time0(2) = hh*10000 + mm*100 + ss + + call ESMF_ClockGet( clock, stopTime=stopTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet( stopTime, yy=yy, mm=mm, dd=dd, s=stop_tod, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ymd2date(yy, mm, dd, stop_ymd) + + hh = stop_tod/3600 + mm = (stop_tod - (hh * 3600))/60 + ss = stop_tod - (hh*3600) - (mm*60) + + timen(1) = stop_ymd + timen(2) = hh*10000 + mm*100 + ss + + 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 + end if +#ifndef W3_CESMCOUPLED + stime = time0 + etime = timen +#endif + + !-------------------------------------------------------------------- + ! Wave model initialization + !-------------------------------------------------------------------- + +#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) + else + call waveinit_ufs(gcomp, ntrace, mpi_comm, mds, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if +#else + time = time0 + call ESMF_ClockGet( clock, timeStep=timeStep, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeIntervalGet( timeStep, s=dtime_sync, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call waveinit_cesm(gcomp, ntrace, mpi_comm, dtime_sync, mds, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return +#endif + + ! call mpi_barrier ( mpi_comm, ierr ) + + !-------------------------------------------------------------------- + ! Mesh initialization + !-------------------------------------------------------------------- + + ! Note that nsea is the global number of sea points - and nseal is + ! the local number of sea points + + ! 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 + end do + + ! create a global index array for non-sea (i.e. land points) + allocate(mask_global(nx*ny), mask_local(nx*ny)) + 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 + end do + call ESMF_VMAllReduce(vm, sendData=mask_local, recvData=mask_global, count=nx*ny, & + reduceflag=ESMF_REDUCE_MAX, rc=rc) + + nlnd_global = nx*ny - nsea + 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 + 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 + end do + deallocate(mask_global) + deallocate(mask_local) + + ! create a global index that includes both sea and land - but put land at the end + 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 + end do + deallocate(gindex_sea) + deallocate(gindex_lnd) + + ! create distGrid from global index array + DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! create the mesh + call NUOPC_CompAttributeGet(gcomp, name='mesh_wav', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! read in the mesh with an auto-generated distGrid + 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(stdout,*)'mesh file for domain is ',trim(cvalue) + end if + + ! recreate the mesh using the above distGrid + EMesh = ESMF_MeshCreate(EMeshTemp, elementDistgrid=Distgrid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! obtain the mesh mask and find the minimum value across all PEs + call ESMF_DistGridGet(Distgrid, localDe=0, elementCount=ncnt, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + allocate(meshmask(ncnt)) + elemMaskArray = ESMF_ArrayCreate(Distgrid, farrayPtr=meshmask, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_MeshGet(Emesh, elemMaskArray=elemMaskArray, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMAllFullReduce(vm, sendData=meshmask, recvData=maskmin, count=ncnt, & + reduceflag=ESMF_REDUCE_MIN, rc=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 + 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 + end if + deallocate(meshmask) + deallocate(gindex) + + !-------------------------------------------------------------------- + ! Realize the actively coupled fields + !-------------------------------------------------------------------- + call realize_fields(gcomp, mesh=Emesh, flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + +#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 + end if +#endif + + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) + + end subroutine InitializeRealize + + !=============================================================================== +!> Initialize the field values in the export state +!! +!! @details Called by NUOPC to initialize the field values in the export state and +!! the values for the scalar field which describes the wave model global domain +!! size. +!! +!! @param gcomp an ESMF_GridComp object +!! @param[out] rc return code +!! +!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov +!> @date 01-05-2022 + subroutine DataInitialize(gcomp, rc) + + use wav_import_export, only : calcRoughl + use wav_shr_mod , only : wav_coupling_to_cice + use w3gdatmd , only : nx, ny + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + type(ESMF_State) :: exportState + integer :: jsea + real(r8), pointer :: z0rlen(:) + real(r8), pointer :: sw_lamult(:) + real(r8), pointer :: sw_ustokes(:) + real(r8), pointer :: sw_vstokes(:) + real(r8), pointer :: wav_tauice1(:) + real(r8), pointer :: wav_tauice2(:) + real(r8), pointer :: wave_elevation_spectrum(:,:) + character(len=*),parameter :: subname = '(wav_comp_nuopc:DataInitialize)' + ! ------------------------------------------------------------------- + + !-------------------------------------------------------------------- + ! Create export state + !-------------------------------------------------------------------- + + rc = ESMF_SUCCESS + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' called', ESMF_LOGMSG_INFO) + + call NUOPC_ModelGet(gcomp, exportState=exportState, rc=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. + 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. + 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. + 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) + endif + + if (wav_coupling_to_cice) then + call state_getfldptr(exportState, 'wav_tauice1', wav_tauice1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'wav_tauice2', wav_tauice2, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'wave_elevation_spectrum', wave_elevation_spectrum, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + wav_tauice1(:) = 0. + wav_tauice2(:) = 0. + wave_elevation_spectrum(:,:) = 0. + endif + + ! Set global grid size scalars in export state + call State_SetScalar(dble(nx), flds_scalar_index_nx, exportState, flds_scalar_name, flds_scalar_num, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call State_SetScalar(dble(ny), flds_scalar_index_ny, exportState, flds_scalar_name, flds_scalar_num, 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 + end if + + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) + + end subroutine DataInitialize + + !===================================================================== +!> Called by NUOPC to advance the model a single timestep +!! +!! @details At each model advance, the call to import_fields fills the +!! import state with the updated values. If a history alarm is present +!! and ringing, a logical to write a wave history file is set true. The +!! wave model itself is then advanced during which a history file will +!! be written via a call to w3iogonc in place of w3iogo. The export +!! fields at the current model Advance are filled in export_fields +!! +!! @param gcomp an ESMF_GridComp object +!! @param[out] rc return code +!! +!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov +!> @date 01-05-2022 + subroutine ModelAdvance(gcomp, rc) + + !------------------------ + ! Run WW3 + !------------------------ + + use w3wavemd , only : w3wave + use w3wdatmd , only : time, w3setw + use wav_import_export , only : import_fields, export_fields + use wav_shel_inp , only : odat + use wav_shr_mod , only : rstwr, histwr, outfreq ! only used by cesm + + ! arguments: + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + type(ESMF_State) :: importState + type(ESMF_State) :: exportState + type(ESMF_Clock) :: clock + type(ESMF_Alarm) :: alarm + type(ESMF_TimeInterval) :: timeStep, elapsedTime + type(ESMF_Time) :: currTime, nextTime, startTime, stopTime + integer :: yy,mm,dd,hh,ss + integer :: imod + integer :: ymd ! current year-month-day + integer :: tod ! current time of day (sec) + integer :: time0(2) + integer :: timen(2) + integer :: shrlogunit ! original log unit and level + character(ESMF_MAXSTR) :: msgString + character(len=*),parameter :: subname = '(wav_comp_nuopc:ModelAdvance) ' + !------------------------------------------------------- + + rc = ESMF_SUCCESS + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' called', ESMF_LOGMSG_INFO) + + !------------ + ! query the Component for its importState, exportState and clock + !------------ + call ESMF_GridCompGet(gcomp, importState=importState, exportState=exportState, clock=clock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + 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) + + !------------ + ! Determine time info + !------------ + call ESMF_ClockGet( clock, currTime=currTime, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet( currTime, yy=yy, mm=mm, dd=dd, s=tod, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ymd2date(yy, mm, dd, ymd) + hh = tod/3600 + mm = (tod - (hh * 3600))/60 + ss = tod - (hh*3600) - (mm*60) + 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 + end if + + ! use next time; the NUOPC clock is not updated + ! until the end of the time interval + call ESMF_ClockGetNextTime(clock, nextTime=nextTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet( nextTime, yy=yy, mm=mm, dd=dd, s=tod, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + elapsedTime = nextTime - startTime + call ESMF_TimeIntervalGet(elapsedTime, s_i8=elapsed_secs,rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ymd2date(yy, mm, dd, ymd) + hh = tod/3600 + mm = (tod - (hh * 3600))/60 + ss = tod - (hh*3600) - (mm*60) + + timen(1) = ymd + timen(2) = hh*10000 + mm*100 + ss + + time = time0 +#ifndef W3_CESMCOUPLED + if (multigrid) then + do imod = 1,nrgrd + tend(1,imod) = timen(1) + tend(2,imod) = timen(2) + end do + end if +#endif + + !------------ + ! Obtain import data from import state + !------------ + call import_fields(gcomp, time0, timen, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !------------ + ! Run the wave model for the given interval + !------------ + if(profile_memory) call ESMF_VMLogMemInfo("Entering WW3 Run : ") + + if (cesmcoupled) then + ! Determine if time to write cesm ww3 restart files + ! rstwr is set in wav_shr_mod and used in w3wavmd to determine if restart should be written + 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. + end if + + !TODO: what is outfreq used for if an alarm is created with history_n,history_option? + ! Determine if time to write ww3 history files + ! histwr is set in wav_shr_mod and used in w3wavmd to determine if history should be written + ! if history alarms are not active, control of WW3 grd output remains with WW3 + histwr = .false. + if (outfreq .gt. 0) then + ! output every outfreq hours if appropriate + if( mod(hh, outfreq) == 0 ) then + histwr = .true. + endif + endif + if (.not. histwr) then + if (histwr_is_active) then + 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 + end if + if ( root_task ) then + ! write(nds(1),*) 'wav_comp_nuopc time', time, timen + ! write(nds(1),*) 'ww3 hist flag ', histwr, outfreq, hh, mod(hh, outfreq) + end if + end if + + ! Advance the wave model +#ifndef W3_CESMCOUPLED + if (multigrid) then + call wmwave ( tend ) + else + call w3wave ( 1, odat, timen ) + end if +#else + call w3wave ( 1, odat, timen ) +#endif + if(profile_memory) call ESMF_VMLogMemInfo("Exiting WW3 Run : ") + + !------------ + ! Create export state + !------------ + + call export_fields(gcomp, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) + + end subroutine ModelAdvance + + !=============================================================================== +!> Called by NUOPC to manage the model clock +!! +!! @param[in] gcomp an ESMF_GridComp object +!! @param[out] rc return code +!! +!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov +!> @date 01-05-2022 + subroutine ModelSetRunClock(gcomp, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + type(ESMF_Clock) :: mclock, dclock + type(ESMF_Time) :: mcurrtime, dcurrtime + type(ESMF_Time) :: mstoptime + type(ESMF_Time) :: mstarttime + type(ESMF_TimeInterval) :: mtimestep, dtimestep + logical :: isPresent + logical :: isSet + character(len=256) :: cvalue + character(len=256) :: restart_option ! Restart option units + integer :: restart_n ! Number until restart interval + integer :: restart_ymd ! Restart date (YYYYMMDD) + type(ESMF_ALARM) :: restart_alarm + character(len=256) :: stop_option ! Stop option units + integer :: stop_n ! Number until stop interval + integer :: stop_ymd ! Stop date (YYYYMMDD) + type(ESMF_ALARM) :: stop_alarm + character(len=256) :: history_option ! History option units + integer :: history_n ! Number until history interval + integer :: history_ymd ! History date (YYYYMMDD) + type(ESMF_ALARM) :: history_alarm + character(len=128) :: name + integer :: alarmcount + character(len=*),parameter :: subname=trim(modName)//':(ModelSetRunClock) ' + + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + call ESMF_LogWrite(trim(subname)//' called', ESMF_LOGMSG_INFO) + + ! query the Component for its clocks + call NUOPC_ModelGet(gcomp, driverClock=dclock, modelClock=mclock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_ClockGet(dclock, currTime=dcurrtime, timeStep=dtimestep, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_ClockGet(mclock, currTime=mcurrtime, timeStep=mtimestep, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !-------------------------------- + ! force model clock currtime and timestep to match driver and set stoptime + !-------------------------------- + + mstoptime = mcurrtime + dtimestep + call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, stopTime=mstoptime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !-------------------------------- + ! set restart, stop and history alarms + !-------------------------------- + + call ESMF_ClockGetAlarmList(mclock, alarmlistflag=ESMF_ALARMLIST_ALL, alarmCount=alarmCount, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + 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", 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 + + !---------------- + ! 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 + histwr_is_active = .true. + else + ! If attribute is not present - write history native WW3 output if requested + history_option = 'none' + history_n = -999 + histwr_is_active = .false. + end if + + end if + + !-------------------------------- + ! Advance model clock to trigger alarms then reset model clock back to currtime + !-------------------------------- + + call ESMF_ClockAdvance(mclock,rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, stopTime=mstoptime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) + + end subroutine ModelSetRunClock + + !=============================================================================== +!> Called by NUOPC at the end of the run to clean up. +!! +!! @param[in] gcomp an ESMF_GridComp object +!! @param[out] rc return code +!! +!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov +!> @date 01-05-2022 + subroutine ModelFinalize(gcomp, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + character(*), parameter :: F00 = "('(ww3_comp_nuopc) ',8a)" + character(*), parameter :: F91 = "('(ww3_comp_nuopc) ',73('-'))" + character(len=*),parameter :: subname=trim(modName)//':(ModelFinalize) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + 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) + end if + + call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) + + end subroutine ModelFinalize + + !=============================================================================== +!> Initialize the wave model for the CESM use case +!! +!! @param[in] gcomp an ESMF_GridComp object +!! @param[in] ntrace unit numbers for trace +!! @param[in] mpi_comm an mpi communicator +!! @param[in] dtime_sync the coupling interval +!! @param[in] mds unit numbers +!! @param[out] rc return code +!! +!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov +!> @date 01-05-2022 + subroutine waveinit_cesm(gcomp, ntrace, mpi_comm, dtime_sync, mds, rc) + + ! Initialize ww3 for cesm (called from InitializeRealize) + + use w3initmd , only : w3init + use w3gdatmd , only : dtcfl, dtcfli, dtmax, dtmin + use wav_shr_mod , only : casename, initfile, outfreq + use wav_shr_mod , only : inst_index, inst_name, inst_suffix + use wav_shel_inp , only : set_shel_inp + use wav_shel_inp , only : npts, odat, iprt, x, y, pnames, prtfrm + use wav_shel_inp , only : flgrd, flgd, flgr2, flg2 + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer , intent(in) :: ntrace(:) + integer , intent(in) :: mpi_comm + integer , intent(in) :: dtime_sync + integer , intent(in) :: mds(:) + integer , intent(out) :: rc + + ! local variables + integer :: ierr + integer :: unitn ! namelist unit number + integer :: shrlogunit + logical :: isPresent, isSet + real(r8) :: dtmax_in ! Maximum overall time step. + real(r8) :: dtmin_in ! Minimum dynamic time step for source + real(r8) :: dtcfl_in ! Maximum CFL time step X-Y propagation. + real(r8) :: dtcfli_in ! Maximum CFL time step X-Y propagation intra-spectral + integer :: stdout + character(len=CL) :: cvalue + character(len=*), parameter :: subname = '(wav_comp_nuopc:wavinit_cesm)' + ! ------------------------------------------------------------------- + + namelist /ww3_inparm/ initfile, outfreq, dtcfl, dtcfli, dtmax, dtmin + + rc = ESMF_SUCCESS + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' called', ESMF_LOGMSG_INFO) + + inst_name = "WAV"//trim(inst_suffix) + ! Read namelist (set initfile in wav_shr_mod) + 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,'(a, 2x, i8)' )' outfreq = ',outfreq + write(stdout,*) + end if + + ! ESMF does not have a broadcast for chars + call mpi_bcast(initfile, len_trim(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 + end if + call mpi_bcast(outfreq, 1, MPI_INTEGER, 0, mpi_comm, ierr) + if (ierr /= MPI_SUCCESS) then + call ESMF_LogWrite(trim(subname)//' error in mpi broadcast for outfreq ', & + 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 + 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 + 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 + 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 + end if + dtmax_in = dtmax + dtcfl_in = dtcfl + dtcfli_in = dtcfli + dtmin_in = dtmin + + ! Determine module variables in wav_shel_inp that are used for call to w3init + call set_shel_inp(dtime_sync) + + ! Read in initial/restart data and initialize the model + ! ww3 read initialization occurs in w3iors (which is called by initmd in module w3initmd) + ! ww3 always starts up from a 'restart' file type + ! For a startup (including hybrid) or branch run the restart file is obtained from 'initfile' + ! For a continue run, the restart filename upon read is created from the time(1:2) array + ! flgr2 is flags for coupling output, not ready yet so keep .false. + ! 1 is model number + ! IsMulti does not appear to be used, setting to .false. + + call w3init ( 1, .false., 'ww3', mds, ntrace, odat, flgrd, flgr2, flgd, flg2, & + npts, x, y, pnames, iprt, prtfrm, mpi_comm ) + + ! NOTE: these need to be set again AFTER w3init is run - since these values will be overwritten + ! by the read of mod_def.ww3 + dtmax = dtmax_in + dtcfl = dtcfl_in + dtcfli = dtcfli_in + dtmin = dtmin_in + + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) + end subroutine waveinit_cesm + + !=============================================================================== +!> Initialize the wave model for the UWM use case +!! +!> @details Calls public routine read_shel_inp to read the ww3_shel.inp file. Calls +!! w3init to initialize the wave model +!! +!! @param[in] gcomp an ESMF_GridComp object +!! @param[in] ntrace unit numbers for trace +!! @param[in] mpi_comm an mpi communicator +!! @param[in] mds unit numbers +!! @param[out] rc return code +!! +!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov +!> @date 01-05-2022 + subroutine waveinit_ufs( gcomp, ntrace, mpi_comm, mds, rc) + + ! Initialize ww3 for ufs (called from InitializeRealize) + + use w3odatmd , only : fnmpre + use w3initmd , only : w3init + use wav_shr_mod , only : outfreq + use wav_shel_inp , only : read_shel_inp + use wav_shel_inp , only : npts, odat, iprt, x, y, pnames, prtfrm + use wav_shel_inp , only : flgrd, flgd, flgr2, flg2 + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer, intent(in) :: ntrace(:) + integer, intent(in) :: mpi_comm + integer, intent(in) :: mds(:) + integer, intent(out) :: rc + + ! local variables + character(len=*), parameter :: subname = '(wav_comp_nuopc:wavinit_ufs)' + ! ------------------------------------------------------------------- + + rc = ESMF_SUCCESS + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' called', ESMF_LOGMSG_INFO) + + outfreq = 0 + fnmpre = './' + + call ESMF_LogWrite(trim(subname)//' call read_shel_inp', ESMF_LOGMSG_INFO) + call read_shel_inp(mpi_comm) + + call ESMF_LogWrite(trim(subname)//' call w3init', ESMF_LOGMSG_INFO) + call w3init ( 1, .false., 'ww3', mds, ntrace, odat, flgrd, flgr2, flgd, flg2, & + npts, x, y, pnames, iprt, prtfrm, mpi_comm ) + + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) + end subroutine waveinit_ufs + +end module wav_comp_nuopc diff --git a/model/src/wav_import_export.F90 b/model/src/wav_import_export.F90 new file mode 100644 index 000000000..7a2c33b2d --- /dev/null +++ b/model/src/wav_import_export.F90 @@ -0,0 +1,1718 @@ +!> @file wav_import_export +!! +!> Manage the import/export state and fields +!! +!> @details Contains the public routines to advertise and realize +!! the import and export fields and the public routines to fill +!! the import and export fields within the ESMF States. +!! +!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov +!> @date 01-05-2022 +module wav_import_export + + use ESMF + use NUOPC + use NUOPC_Model + use wav_kind_mod , only : r8 => shr_kind_r8, r4 => shr_kind_r4, i4 => shr_kind_i4 + use wav_kind_mod , only : CL => shr_kind_cl, CS => shr_kind_cs + 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 constants , only : grav, tpi, dwat + + implicit none + private ! except + + public :: advertise_fields !< @public create a list of fields and advertise them + public :: realize_fields !< @public realize a list of advertised fields + public :: import_fields !< @public fill WW3 fields using values in the import state + public :: export_fields !< @public fill values in the export state using WW3 fields + public :: CalcRoughl !< @public calculate the roughness length + + private :: fldlist_add !< @private add a field name to a list of field names + private :: fldlist_realize !< @private realize a field in a list of field names + private :: set_importmask !< @private set the import mask when merge_import is true + private :: check_globaldata !< @private write values in a field to a netCDF file for debugging + 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 + end type fld_list_type + + integer, parameter :: fldsMax = 100 !< the maximum allowed number of fields in a state + integer :: fldsToWav_num = 0 !< initial value of the number of fields sent to the wave model + integer :: fldsFrWav_num = 0 !< initial value of the number of fields sent from the wave model + type (fld_list_type) :: fldsToWav(fldsMax) !< a structure containing the list of fields to the wave model + type (fld_list_type) :: fldsFrWav(fldsMax) !< a structure containing the list of fields from the wave model + + real(r4), allocatable :: import_mask(:) !< the mask for valid import data + real(r8), parameter :: zero = 0.0_r8 !< a named constant + +#ifdef W3_CESMCOUPLED + logical :: cesmcoupled = .true. !< logical defining a CESM use case +#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 + subroutine advertise_fields(importState, ExportState, flds_scalar_name, rc) + ! input/output variables + type(ESMF_State) :: importState + type(ESMF_State) :: exportState + character(len=*) , intent(in) :: flds_scalar_name + integer , intent(out) :: rc + + ! local variables + integer :: n, num + character(len=2) :: fvalue + character(len=*), parameter :: subname='(wav_import_export:advertise_fields)' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' called', ESMF_LOGMSG_INFO) + + !-------------------------------- + ! Advertise import fields + !-------------------------------- + + !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' ) + else + 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') + 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 + end do + + !-------------------------------- + ! Advertise export fields + !-------------------------------- + + 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_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) + 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') + end if + + ! AA TODO: In the above fldlist_add calls, we are passing hardcoded ungridded_ubound values (3) because, USSPF(2) + ! is not initialized yet. It is set during w3init which gets called at a later phase (realize). A permanent solution + ! 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, 'wav_tauice1') + call fldlist_add(fldsFrWav_num, fldsFrWav, 'wav_tauice2') + 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 + end do + + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) + + 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 + subroutine realize_fields(gcomp, mesh, flds_scalar_name, flds_scalar_num, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + type(ESMF_Mesh) :: mesh + character(len=*) , intent(in) :: flds_scalar_name + integer , intent(in) :: flds_scalar_num + integer , intent(out) :: rc + + ! local variables + type(ESMF_State) :: importState + type(ESMF_State) :: exportState + character(len=*), parameter :: subname='(wav_import_export:realize_fields)' + !--------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' called', ESMF_LOGMSG_INFO) + + call NUOPC_ModelGet(gcomp, importState=importState, exportState=exportState, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call fldlist_realize( & + state=ExportState, & + fldList=fldsFrWav, & + numflds=fldsFrWav_num, & + flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, & + tag=subname//':WW3Export',& + mesh=mesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call fldlist_realize( & + state=importState, & + fldList=fldsToWav, & + numflds=fldsToWav_num, & + flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, & + tag=subname//':WW3Import',& + mesh=mesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call state_reset(ExportState, zero, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_reset(ImportState, zero, rc=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 + end if + + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) + + 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 + subroutine import_fields( gcomp, time0, timen, rc ) + + !--------------------------------------------------------------------------- + ! Obtain the wave input from the mediator + !--------------------------------------------------------------------------- + + use w3gdatmd , only: nsea, nseal, MAPSTA, NX, NY, w3setg + use w3idatmd , only: CX0, CY0, CXN, CYN, DT0, DTN, ICEI, WLEV, INFLAGS1, ICEP1, ICEP5 + use w3idatmd , only: TC0, TCN, TLN, TIN, TI1, TI5, TW0, TWN, WX0, WY0, WXN, WYN + use w3idatmd , only: UX0, UY0, UXN, UYN, TU0, TUN + use w3idatmd , only: tfn, w3seti + use w3odatmd , only: w3seto + use w3wdatmd , only: time, w3setw +#ifdef W3_CESMCOUPLED + use w3idatmd , only: HML +#else + use wmupdtmd , only: wmupd2 + use wmmdatmd , only: wmsetm, mpi_comm_grd + use wmmdatmd , only: mdse, mdst, nrgrd, inpmap +#endif + + ! input/output variables + type(ESMF_GridComp) , intent(inout) :: gcomp + integer , intent(in) :: time0(2), timen(2) + integer , intent(out) :: rc + + ! Local variables + type(ESMF_State) :: importState + type(ESMF_VM) :: vm + type(ESMF_Clock) :: clock + real(r4) :: global_data(nsea) + real(r4), allocatable :: global_data2(:) + real(r4) :: def_value + character(len=10) :: uwnd + character(len=10) :: vwnd + integer :: imod, j, jmod + integer :: mpi_comm_null = -1 + real(r4), allocatable :: wxdata(:) ! only needed if merge_import + real(r4), allocatable :: wydata(:) ! only needed if merge_import + character(len=CL) :: msgString + character(len=*), parameter :: subname='(wav_import_export:import_fields)' + !--------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' called', ESMF_LOGMSG_INFO) + + if (cesmcoupled) then + uwnd = 'Sa_u' + vwnd = 'Sa_v' + else + uwnd = 'Sa_u10m' + vwnd = 'Sa_v10m' + end if + + ! Get import state, clock and vm + call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, vm=vm, rc=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 + end if + + ! input fields associated with W3FLDG calls in ww3_shel.ftn + ! fill both the lower (0) and upper (N) bound data with the same values + ! fill with special values as default, these should not be used in practice + ! set time for input data to time0 and timen (shouldn't matter) + + def_value = 0.0_r4 + +#ifndef W3_CESMCOUPLED + call w3setg ( 1, mdse, mdst ) + call w3seti ( 1, mdse, mdst ) +#endif + + ! --------------- + ! 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 + 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 + 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) + 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 + 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) + 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 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) + 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 + end if +#ifdef W3_CESMCOUPLED + ! --------------- + ! ocean boundary layer depth - always assume that this is being imported for CESM + ! --------------- + call SetGlobalInput(importState, 'So_bldepth', vm, global_data, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! ocn mixing layer depth + global_data = max(global_data, 5.) + call FillGlobalInput(global_data, HML) +#endif + ! --------------- + ! 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 + 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 + 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 + 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 ) +#ifdef W3_MPI + 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 + end if +#endif + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) + + 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 + subroutine export_fields (gcomp, rc) + + !--------------------------------------------------------------------------- + ! Create the export state + !--------------------------------------------------------------------------- + + use wav_kind_mod, only : R8 => SHR_KIND_R8 + use w3adatmd , only : USSX, USSY, EF, TAUICE, USSP + use w3adatmd , only : w3seta + use w3idatmd , only : w3seti + use w3wdatmd , only : va, w3setw + use w3odatmd , only : w3seto, naproc, iaproc + use w3gdatmd , only : nseal, mapsf, MAPSTA, USSPF, NK, w3setg + use w3iogomd , only : CALC_U3STOKES +#ifdef W3_CESMCOUPLED + use w3adatmd , only : LAMULT +#else + use wmmdatmd , only : mdse, mdst, wmsetm +#endif + + ! input/output/variables + type(ESMF_GridComp) :: gcomp + integer , intent(out) :: rc + + ! Local variables + real(R8) :: fillvalue = 1.0e30_R8 ! special missing value + type(ESMF_State) :: exportState + integer :: n, jsea, isea, ix, iy, lsize, 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 :: sxxn(:) + real(r8), pointer :: sxyn(:) + real(r8), pointer :: syyn(:) + + real(r8), pointer :: sw_lamult(:) + real(r8), pointer :: sw_ustokes(:) + real(r8), pointer :: sw_vstokes(:) + real(r8), pointer :: wav_tauice1(:) + real(r8), pointer :: wav_tauice2(:) + + ! d2 is location, d1 is frequency - nwav_elev_spectrum frequencies will be used + real(r8), pointer :: wave_elevation_spectrum(:,:) + + ! Partitioned stokes drift + real(r8), pointer :: sw_pstokes_x(:,:) ! cesm + real(r8), pointer :: sw_pstokes_y(:,:) ! cesm + real(r8), pointer :: sw_ustokes1(:) ! ufs + real(r8), pointer :: sw_vstokes1(:) ! ufs + real(r8), pointer :: sw_ustokes2(:) ! ufs + real(r8), pointer :: sw_vstokes2(:) ! ufs + real(r8), pointer :: sw_ustokes3(:) ! ufs + real(r8), pointer :: sw_vstokes3(:) ! ufs + character(len=*), parameter :: subname='(wav_import_export:export_fields)' + !--------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' called', ESMF_LOGMSG_INFO) + + ! Get export state + call NUOPC_ModelGet(gcomp, exportState=exportState, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + +#ifndef W3_CESMCOUPLED + call w3setg ( 1, mdse, mdst ) + call w3setw ( 1, mdse, mdst ) + call w3seta ( 1, mdse, mdst ) + call w3seti ( 1, mdse, mdst ) + call w3seto ( 1, mdse, mdst ) + if (multigrid) then + 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 + 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 + 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 + 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) + 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) + endif + + !TODO: what is difference between uscurr/vscurr and sw_ustokes,sw_vstokes? + ! uscurr has standard name eastward_stokes_drift_current + ! vscurr has standard name northward_stokes_drift_current + ! in fd_nems.yaml but this seems to be calculated a (:,:) value + !if ( state_fldchk(exportState, 'uscurr') .and. & + ! state_fldchk(exportState, 'vscurr')) then + ! call state_getfldptr(exportState, 'uscurr', uscurr, rc=rc) + ! if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! call state_getfldptr(exportState, 'vscurr', vscurr, rc=rc) + ! if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! call CalcStokes3D( va, uscurr, vscurr ) + !endif + + 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) + 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) + end if + + if (wav_coupling_to_cice) then + call state_getfldptr(exportState, 'wav_tauice1', wav_tauice1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'wav_tauice2', wav_tauice2, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(exportState, 'wave_elevation_spectrum', wave_elevation_spectrum, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + + ! Initialize wave elevation spectrum + wav_tauice1(:) = fillvalue + wav_tauice2(:) = fillvalue + 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 + wav_tauice1(jsea) = TAUICE(jsea,1) ! tau ice is 2D + wav_tauice2(jsea) = TAUICE(jsea,2) ! tau ice is 2D + + ! 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 + wav_tauice1(jsea) = 0. + wav_tauice2(jsea) = 0. + wave_elevation_spectrum(:,jsea) = 0. + endif + enddo + 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 + endif + + if ( state_fldchk(exportState, 'Sw_ustokes1') .and. & + state_fldchk(exportState, 'Sw_ustokes2') .and. & + state_fldchk(exportState, 'Sw_ustokes3') .and. & + state_fldchk(exportState, 'Sw_vstokes1') .and. & + 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 + end if + + if (dbug_flag > 5) then + 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 + subroutine fldlist_add(num, fldlist, stdname, ungridded_lbound, ungridded_ubound) + integer, intent(inout) :: num + type(fld_list_type), intent(inout) :: fldlist(:) + character(len=*), intent(in) :: stdname + integer, optional, intent(in) :: ungridded_lbound + integer, optional, intent(in) :: ungridded_ubound + + ! local variables + character(len=*), parameter :: subname='(wav_import_export:fldlist_add)' + !------------------------------------------------------------------------------- + + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' called', ESMF_LOGMSG_INFO) + + ! 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 + 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 + 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 + subroutine fldlist_realize(state, fldList, numflds, flds_scalar_name, flds_scalar_num, mesh, tag, rc) + + ! input/output variables + type(ESMF_State) , intent(inout) :: state + type(fld_list_type) , intent(in) :: fldList(:) + integer , intent(in) :: numflds + character(len=*) , intent(in) :: flds_scalar_name + integer , intent(in) :: flds_scalar_num + character(len=*) , intent(in) :: tag + type(ESMF_Mesh) , intent(in) :: mesh + integer , intent(inout) :: rc + + ! local variables + integer :: n + type(ESMF_Field) :: field + character(len=80) :: stdname + character(len=*),parameter :: subname='(wav_import_export:fldlist_realize)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + 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) + 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 + subroutine SetScalarField(field, flds_scalar_name, flds_scalar_num, rc) + ! ---------------------------------------------- + ! create a field with scalar data on the root pe + ! ---------------------------------------------- + + type(ESMF_Field) , intent(inout) :: field + character(len=*) , intent(in) :: flds_scalar_name + integer , intent(in) :: flds_scalar_num + integer , intent(inout) :: rc + + ! local variables + type(ESMF_Distgrid) :: distgrid + type(ESMF_Grid) :: grid + character(len=*), parameter :: subname='(wav_import_export:SetScalarField)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + ! create a DistGrid with a single index space element, which gets mapped onto DE 0. + distgrid = ESMF_DistGridCreate(minIndex=(/1/), maxIndex=(/1/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + grid = ESMF_GridCreate(distgrid, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + field = ESMF_FieldCreate(name=trim(flds_scalar_name), grid=grid, typekind=ESMF_TYPEKIND_R8, & + ungriddedLBound=(/1/), ungriddedUBound=(/flds_scalar_num/), gridToFieldMap=(/2/), rc=rc) ! num of scalar values + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + 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 + subroutine CalcCharnk ( chkn ) + + ! Calculate Charnok for export + + use w3gdatmd, only : nseal, nk, nth, sig, mapsf, mapsta, nspec + use w3adatmd, only : cg, wn, charn, u10, u10d + use w3wdatmd, only : va + use w3odatmd, only : naproc, iaproc +#ifdef W3_ST3 + use w3src3md, only : w3spr3 +#endif +#ifdef W3_ST4 + use w3src4md, only : w3spr4 +#endif + + ! input/output variables + real(ESMF_KIND_R8), pointer :: chkn(:) ! 1D Charnock export field pointer + + ! local variables + real , parameter :: zero = 0.0 + integer :: isea, jsea, ix, iy + real :: emean, fmean, fmean1, wnmean, amax, ustar, ustdr + real :: tauwx, tauwy, cd, z0, fmeanws, dlwmean + logical :: llws(nspec) + logical, save :: firstCall = .true. + !---------------------------------------------------------------------- + + !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 +#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 ) +#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 ) +#endif + endif !firstCall + chkn(jsea) = charn(jsea) + enddo jsea_loop + + firstCall = .false. + + 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 + subroutine CalcRoughl ( wrln) + + ! Calculate 2D wave roughness length for export + + use w3gdatmd, only : nseal, nk, nth, sig, dmin, ecos, esin, dden, mapsf, mapsta, nspec + use w3adatmd, only : dw, cg, wn, charn, u10, u10d + use w3wdatmd, only : va, ust + use w3odatmd, only : naproc, iaproc +#ifdef W3_ST3 + use w3src3md, only : w3spr3 +#endif +#ifdef W3_ST4 + use w3src4md, only : w3spr4 +#endif + use wav_shr_mod, only : runtype + + ! input/output variables + real(r8), pointer :: wrln(:) ! 1D roughness length export field ponter + + ! local variables + integer :: isea, jsea, ix, iy + real :: emean, fmean, fmean1, wnmean, amax, ustar, ustdr + real :: tauwx, tauwy, cd, z0, fmeanws, dlwmean + logical :: llws(nspec) + logical, save :: firstCall = .true. + + !---------------------------------------------------------------------- + + 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. & + ( runtype == 'continue' .and. abs(mapsta(iy,ix)) == 1 )) then + 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 ) +#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 ) +#endif + end if + endif !firstCall + wrln(jsea) = charn(jsea)*ust(isea)**2/grav + enddo jsea_loop + + firstCall = .false. + + 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 + subroutine CalcBotcur ( a, wbxn, wbyn, wbpn ) + + ! Calculate wave-bottom currents for export + + use w3gdatmd, only : nseal, nk, nth, sig, dmin, ecos, esin, dden, mapsf, mapsta, nspec + use w3adatmd, only : dw, cg, wn + use w3odatmd, only : naproc, iaproc + + ! input/output variables + real, intent(in) :: a(nth,nk,0:nseal) ! Input spectra (in par list to change shape) + real(ESMF_KIND_R8), pointer :: wbxn(:) ! 2D eastward-component export field pointer + real(ESMF_KIND_R8), pointer :: wbyn(:) ! 2D northward-component export field pointer + real(ESMF_KIND_R8), pointer :: wbpn(:) ! 2D period export field pointer + + ! local variables + real(8), parameter :: half = 0.5_r8 + real(8), parameter :: one = 1.0_r8 + real(8), parameter :: two = 2.0_r8 + real(8), parameter :: kdmin = 1e-7_r8 + real(8), parameter :: kdmax = 18.0_r8 + 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(:) + !---------------------------------------------------------------------- + + allocate( sig2(1:nk) ) + sig2(1:nk) = sig(1:nk)**2 + + wbxn(:) = zero + wbyn(:) = zero + 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 + enddo jsea_loop + + deallocate( sig2 ) + + 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 + subroutine CalcRadstr2D ( a, sxxn, sxyn, syyn ) + + ! Calculate 2D radiation stresses for export + + use w3gdatmd, only : nseal, nk, nth, sig, es2, esc, ec2, fte, dden + use w3adatmd, only : dw, cg, wn + use w3odatmd, only : naproc, iaproc +#ifdef W3_PDLIB + use yowNodepool, only: np, iplg +#endif + + ! input/output variables + real, intent(in) :: a(nth,nk,0:nseal) ! Input spectra (in par list to change shape) + real(ESMF_KIND_R8), pointer :: sxxn(:) ! 2D eastward-component export field + real(ESMF_KIND_R8), pointer :: sxyn(:) ! 2D eastward-northward-component export field + real(ESMF_KIND_R8), pointer :: syyn(:) ! 2D northward-component export field + + ! local variables + character(ESMF_MAXSTR) :: cname + character(128) :: msg + 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 + !---------------------------------------------------------------------- + + 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 + enddo jsea_loop + + end subroutine CalcRadstr2D + + !==================================================================================== +!> 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 + use w3odatmd, only: naproc, iaproc + + ! input/output variables + type(ESMF_State) , intent(in) :: importState + character(len=*) , intent(in) :: fldname + type(ESMF_VM) , intent(in) :: vm + real(r4) , intent(out) :: global_output(nsea) + integer , intent(out) :: rc + + ! local variables + integer :: jsea, isea, ix, iy + real(r4) :: global_input(nsea) + real(r8), pointer :: dataptr(:) + character(len=*), parameter :: subname = '(wav_import_export:setGlobalInput)' + + !--------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' called', ESMF_LOGMSG_INFO) + + call state_getfldptr(importState, trim(fldname), dataptr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + global_output(:) = 0._r4 + global_input(:) = 0._r4 + do jsea = 1, nseal + 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 + + 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 + subroutine fillglobal_with_import(global_data, globalfield) + + use w3gdatmd, only: nsea, mapsf, nx, ny + + real(r4), intent(in) :: global_data(nsea) + real(r4), intent(inout) :: globalfield(nx,ny) + + ! local variables + integer :: isea, ix, iy + + do isea = 1,nsea + 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 + subroutine fillglobal_with_merge_import(global_data, global_mask, filedata, globalfield) + + use w3gdatmd, only: nsea, mapsf, nx, ny + + real(r4), intent(in) :: global_data(nsea) + real(r4), intent(in) :: global_mask(nsea) + real(r4), intent(in) :: filedata(nsea) + real(r4), intent(inout) :: globalfield(nx,ny) + + ! local variables + 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) + 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 + subroutine set_importmask(importState, clock, fldname, vm, rc) + + use w3gdatmd, only: nsea, nseal, nx, ny + use w3odatmd, only: naproc, iaproc + + ! input/output variables + type(ESMF_State) , intent(in) :: importState + type(ESMF_Clock) , intent(in) :: clock + character(len=*) , intent(in) :: fldname + type(ESMF_VM) , intent(in) :: vm + integer , intent(out) :: rc + + ! local variables + type(ESMF_Time) :: currTime, startTime + type(ESMF_TimeInterval) :: timeStep + logical :: firstCall, secondCall + real(r4) :: fillValue = 9.99e20 + integer :: isea, jsea, ix, iy + real(r8), pointer :: dataptr(:) + real(r4) :: mask_local(nsea) + character(len=CL) :: msgString + character(len=*), parameter :: subname = '(wav_import_export:set_importmask)' + !--------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' called', ESMF_LOGMSG_INFO) + + call ESMF_ClockGet(clock, startTime=startTime, currTime=currTime, timeStep=timeStep, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! set call flags + if (startTime == currTime) then + firstCall = .true. + secondCall = .false. + elseif (currTime == startTime+timeStep) then + firstCall = .false. + secondCall = .true. + else + firstCall = .false. + secondCall = .false. + end if + if (firstcall) then + allocate(import_mask(nsea)) + end if + + ! return if not the first or second call, mask has already been set + if (.not. firstCall .and. .not. secondCall) return + + ! 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) + 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 + end if + + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) + + 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 + subroutine check_globaldata(gcomp, fldname, global_data, nvals, rc) + + use w3gdatmd, only: nseal, nsea, mapsf, nx, ny + use w3odatmd, only: naproc, iaproc + + ! input/output variables + type(ESMF_GridComp) , intent(inout) :: gcomp + character(len=*) , intent(in) :: fldname + integer , intent(in) :: nvals + real(r4) , intent(in) :: global_data(nvals) + integer , intent(out) :: rc + + ! local variables + type(ESMF_Clock) :: clock + type(ESMF_State) :: importState + type(ESMF_Time) :: currtime, nexttime + type(ESMF_Field) :: lfield + type(ESMF_Field) :: newfield + type(ESMF_MeshLoc) :: meshloc + type(ESMF_Mesh) :: lmesh + character(len=CS) :: timestr + character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) + integer :: fieldCount + integer :: lrank + integer :: yr,mon,day,sec ! time units + integer :: jsea, isea, ix, iy + real(r8), pointer :: dataptr1d(:) + real(r8) :: fillValue = 9.99e20 + character(len=*), parameter :: subname = '(wav_import_export:check_globaldata)' + + !--------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' called', ESMF_LOGMSG_INFO) + + call ESMF_GridCompGet(gcomp, importState=importstate, clock=clock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! use next time; the NUOPC clock is not updated until the end of the time interval + call ESMF_ClockGetNextTime(clock, nextTime=nexttime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet(nexttime,yy=yr, mm=mon, dd=day, s=sec, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write(timestr,'(i4.4,a,i2.2,a,i2.2,a,i5.5)') yr,'-',mon,'-',day,'-',sec + + call ESMF_StateGet(importState, itemCount=fieldCount, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(lfieldNameList(fieldCount)) + call ESMF_StateGet(importState, itemNameList=lfieldNameList, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! assumes no scalar field is present in importState + call ESMF_StateGet(importState, itemName=lfieldNameList(1), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + deallocate(lfieldNameList) + + call ESMF_FieldGet(lfield, mesh=lmesh, meshloc=meshloc, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + newfield = ESMF_FieldCreate(lmesh, ESMF_TYPEKIND_R8, meshloc=meshloc, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(newfield, farrayptr=dataPtr1d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + 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 + else + 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) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldDestroy(newfield, rc=rc, noGarbage=.true.) + + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) + + 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 + subroutine readfromfile (idfld, wxdata, wydata, time0, timen, rc) + + use w3gdatmd, only: nsea, mapsf, gtype, nx, ny + use w3fldsmd, only: w3fldo, w3fldg + + ! input/output variables + character(len=*) , intent(in) :: idfld + integer , intent(in) :: time0(2) + integer , intent(in) :: timen(2) + real(r4) , intent(out) :: wxdata(nsea) + real(r4) , intent(out) :: wydata(nsea) + integer, optional, intent(out) :: rc + + ! local variables + integer :: ierr, tw0l(2), twnl(2) + integer :: ix, iy, isea + integer :: nxt, nyt, gtypet, filler(3), tideflag + integer :: mdse = 6 + integer :: mdst = 10 + integer :: mdsf = 13 ! same as ndsf(3) in ww3_shel + real :: wx0l(nx,ny), wy0l(nx,ny) + real :: wxnl(nx,ny), wynl(nx,ny) + real :: dt0l(nx,ny), dtnl(nx,ny) + logical :: flagsc = .false. + logical, save :: firstCall = .true. + character(len=13) :: tsstr + character(len=3) :: tsfld, lstring + character(CL) :: logmsg + character(len=*), parameter :: subname = '(wav_import_export:readfromfile)' + !--------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' called', ESMF_LOGMSG_INFO) + + lstring = trim(idfld) + if (firstCall) then + ! open file + call w3fldo('READ', lstring, mdsf, mdst, mdse, nx, ny, gtype, ierr) + write(logmsg,*) "Opening "//lstring//", iostat = ", ierr + call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO) + if (ierr.ne.0) then + write(logmsg,*) "Error in opening "//lstring//", iostat = ", ierr + call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + endif + 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', lstring, mdsf, mdst, mdse, nx, ny, & + 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) + end do + + if (dbug_flag > 5) call ESMF_LogWrite(trim(subname)//' done', ESMF_LOGMSG_INFO) + + end subroutine readfromfile +end module wav_import_export diff --git a/model/src/wav_kind_mod.F90 b/model/src/wav_kind_mod.F90 new file mode 100644 index 000000000..05e0a79a1 --- /dev/null +++ b/model/src/wav_kind_mod.F90 @@ -0,0 +1,27 @@ +!> @file wav_kind_mod +!! +!> Precision and kind constants +!! +!> @details Contains public definitions of variable types and constants +!! +!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov +!> @date 01-05-2022 +module wav_kind_mod + + !---------------------------------------------------------------------------- + ! precision/kind constants add data public + !---------------------------------------------------------------------------- + public + integer,parameter :: SHR_KIND_R8 = selected_real_kind(12) !< @public 8 byte real + integer,parameter :: SHR_KIND_R4 = selected_real_kind( 6) !< @public 4 byte real + integer,parameter :: SHR_KIND_RN = kind(1.0) !< @public native real + integer,parameter :: SHR_KIND_I8 = selected_int_kind (13) !< @public 8 byte integer + integer,parameter :: SHR_KIND_I4 = selected_int_kind ( 6) !< @public 4 byte integer + integer,parameter :: SHR_KIND_IN = kind(1) !< @public native integer + integer,parameter :: SHR_KIND_CS = 80 !< @public short char + integer,parameter :: SHR_KIND_CM = 160 !< @public mid-sized char + integer,parameter :: SHR_KIND_CL = 256 !< @public long char + integer,parameter :: SHR_KIND_CX = 512 !< @public extra-long char + integer,parameter :: SHR_KIND_CXX= 4096 !< @public extra-extra-long char + +end module wav_kind_mod diff --git a/model/src/wav_shel_inp.F90 b/model/src/wav_shel_inp.F90 new file mode 100644 index 000000000..12c955aec --- /dev/null +++ b/model/src/wav_shel_inp.F90 @@ -0,0 +1,1057 @@ +!> @file wav_shel_inp +!! +!> Set up for running in shel mode +!! +!> @details Contains public routines to sets up IO unit numbers and to +!! either reads a shel.inp file (UWM) or set the required values directly +!! (CESM). +!! +!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov +!> @date 01-05-2022 +module wav_shel_inp + + use w3odatmd, only: nogrp, ngrpp + + implicit none + private ! except + + public :: set_shel_io !< @public set the IO unit numbers + public :: set_shel_inp !< @public directly set required input variabls (CESM) + public :: read_shel_inp !< @public read ww3_shel.inp (UWM) + + integer, public :: odat(40) !< @public output dates + character(len=40), allocatable, public :: pnames(:) !< @public point names + + integer, public :: npts !< @public number of points for point output + integer, public :: iprt(6) !< @public partitioning grid information + logical, public :: prtfrm !< @public partitioning format flag + logical, public :: flgrd(nogrp,ngrpp) !< @public flags for gridded output + logical, public :: flgr2(nogrp,ngrpp) !< @public flags for coupling output + logical, public :: flgd(nogrp) !< @public flags for whole group - not currently used in cesm + logical, public :: flg2(nogrp) !< @public flags for whole group - not currently used in cesm + real, allocatable, public :: x(:) !< @public x locations for point output + real, allocatable, public :: y(:) !< @public y locations for point output + + include "mpif.h" + +!=============================================================================== +contains +!=============================================================================== +!> Set IO unit numbers +!! +!! @param[in] stdout unit number for stdout +!! @param[out] mds an array of 13 unit numbers +!! @param[out] ntrace an array of 2 unit numbers used for trace output +!! +!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov +!> @date 01-05-2022 + subroutine set_shel_io(stdout,mds,ntrace) + + use ESMF, only : ESMF_UtilIOUnitGet + + ! Input parameter + integer , intent(in) :: stdout + integer , intent(out) :: mds(13), ntrace(2) + + ! Note that nds is set to mds in w3initmd.F90 - mds is a local array + ! The following units are referenced in module w3initmd + ! NDS(1) ! OUTPUT LOG: General output unit number ("log file") + ! NDS(2) ! OUTPUT LOG: Error output unit number + ! NDS(3) ! OUTPUT LOG: Test output unit number + ! NDS(4) ! OUTPUT LOG: Unit for 'direct' output (SCREEN) + ! NDS(5) ! INPUT: mod_def.ww3 file (model definition) unit number + ! NDS(9) ! INPUT: unit for read in boundary conditions (based on FLBPI) + + ! The following units are referenced in module w3wavemd for output + ! NDS( 6) ! OUTPUT DATA: restart(N).ww3 file (model restart) unit number + ! NDS( 7) ! OUTPUT DATA: unit for output for FLOUT(1) flag grid unformmatted output + ! NDS( 8) ! OUTPUT DATA: unit for output for FLOUT(2) flag point unformmatted output + ! etc through 13 + + mds(1) = stdout + mds(2) = stdout + mds(3) = stdout + mds(4) = stdout + + ! 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 W3INIT. + ! By default, unit numbers between 50 and 99 are scanned to find an + ! unopened unit number + + call ESMF_UtilIOUnitGet(mds(5)) ; open(unit=mds(5) , status='scratch') + call ESMF_UtilIOUnitGet(mds(6)) ; open(unit=mds(6) , status='scratch') + call ESMF_UtilIOUnitGet(mds(7)) ; open(unit=mds(7) , status='scratch') + call ESMF_UtilIOUnitGet(mds(8)) ; open(unit=mds(8) , status='scratch') + call ESMF_UtilIOUnitGet(mds(9)) ; open(unit=mds(9) , status='scratch') + call ESMF_UtilIOUnitGet(mds(10)); open(unit=mds(10) , status='scratch') + call ESMF_UtilIOUnitGet(mds(11)); open(unit=mds(11) , status='scratch') + call ESMF_UtilIOUnitGet(mds(12)); open(unit=mds(12) , status='scratch') + call ESMF_UtilIOUnitGet(mds(13)); open(unit=mds(13) , status='scratch') + close(mds(5)); close(mds(6)); close(mds(7)); close(mds(8)); close(mds(9)); close(mds(10)) + close(mds(11)); close(mds(12)); close(mds(13)) + + ntrace(1) = mds(3) + ntrace(2) = 10 + + end subroutine set_shel_io +!> Set up variables used in shel mode directly (CESM) +!! +!! @param[in] dtime_sync coupling interval in s +!! +!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov +!> @date 01-05-2022 + subroutine set_shel_inp(dtime_sync) + + use w3idatmd , only : inflags1, inflags2 + use w3odatmd , only : noge, idout, nds, notype, iaproc, napout + use w3wdatmd , only : time + use wav_shr_mod , only : wav_coupling_to_cice + + ! Input parameter + integer , intent(in) :: dtime_sync + + ! Local parameters + logical :: flt + integer :: i,j,j0 + !--------------------------------------------------- + + !-------------------------------------------------------------------- + ! Define input fields inflags1 and inflags2 settings + !-------------------------------------------------------------------- + + ! fllev inflags1(1) flag for water level input. + ! flcur inflags1(2) flag for current input. + ! flwind inflags1(3) flag for wind input. + ! flice inflags1(4) flag for ice input (ice fraction) + + ! inflags1 array consolidating the above flags, as well as four additional data flags. + ! inflags2 like inflags1 but does *not* get changed when model reads last record of ice.ww3 + ! inflags2 is just "initial value of INFLAGS1" + + ! flags for passing variables from coupler to ww3, lev, curr, wind, ice and mixing layer depth + ! ice params : inflags1(-7) => inflags1(-3) + ! mud density : inflags1(-2) + ! mud thickness : inflags1(-1) + ! muc viscos : inflags1(0) + ! water levels : inflags1(1) + ! currents : inflags1(2) + ! winds : inflags1(3) + ! ice fields : inflags1(4) + ! momentum fluxes : inflags1(5) + + inflags1(:) = .false. + inflags1(1:4) = .true. + inflags2(:) = .false. + if (wav_coupling_to_cice) then + inflags1(-7) = .true. ! ice thickness + inflags1(-3) = .true. ! ice floe size + inflags2(-7) = .true. ! thickness + inflags2(-3) = .true. ! floe size + inflags2( 4) = .true. ! inflags2(4) is true if ice concentration was read during initialization + end if + + !-------------------------------------------------------------------- + ! Define output type and fields + !-------------------------------------------------------------------- + + ! Set number of output types. This is nomally set in w3_shel, CMB made 7. + notype = 7 + + if (iaproc == napout) then + write(nds(1),'(a)') ' Output requests : ' + write(nds(1),'(a)')'--------------------------------------------------' + write(nds(1),'(a)')' no dedicated output process on any file system ' + end if + + ! Initialize ODAT. Normally set in w3_shel. + ! ODAT is initializated in w3initmd + ! Output data, five parameters per output type + ! 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. + ! 1-5 Data for OTYPE = 1; gridded fields. + ! 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. + ! 26-30 Id. for OTYPE = 6; ? + ! 31-35 Id. for OTYPE = 7; coupled fields + ! Hardwire gridded output for now + ! - first output time stamp is now read from file + ! - 1-5 for history files, 16-20 for restart files + ! - restart output interval is set to the total time of run, restart is taken over by rstwr + ! - output interval is set to coupling interval, so that variables calculated in W3IOGO + ! could be updated at every coupling interval + ! - changed odat so all 35 values are set, only permitting one frequency controlled by histwr + do j=1,7 + J0 = (j-1)*5 + odat(J0+1) = time(1) ! YYYYMMDD for first output + odat(J0+2) = time(2) ! HHMMSS for first output + odat(J0+3) = dtime_sync ! output interval in sec + odat(J0+4) = 99990101 ! YYYYMMDD for last output + odat(J0+5) = 0 ! HHMMSS for last output + end do + + ! FLGRD L.A. I Flags for gridded output. + ! NPT Int. I Number of output points + ! X/YPT R.A. I Coordinates of output points. + ! PNAMES C.A. I Output point names. + ! output index is now a in a 2D array + + flgrd(:,:) = .false. ! gridded fields + flgr2(:,:) = .false. ! coupled fields, w3init w3iog are not ready to deal with these yet + + ! 1) Forcing fields + flgrd( 1, 1) = .false. ! Water depth + flgrd( 1, 2) = .false. ! Current vel. + flgrd( 1, 3) = .true. ! Wind speed + flgrd( 1, 4) = .false. ! Air-sea temp. dif. + flgrd( 1, 5) = .false. ! Water level + flgrd( 1, 6) = .true. ! Ice concentration + flgrd( 1, 7) = .false. ! Iceberg damp coeffic + + ! 2) Standard mean wave parameters + flgrd( 2, 1) = .true. ! Wave height + flgrd( 2, 2) = .false. ! Mean wave length + flgrd( 2, 3) = .true. ! Mean wave period(+2) + flgrd( 2, 4) = .true. ! Mean wave period(-1) + flgrd( 2, 5) = .true. ! Mean wave period(+1) + flgrd( 2, 6) = .true. ! Peak frequency + flgrd( 2, 7) = .true. ! Mean wave dir. a1b1 + flgrd( 2, 8) = .false. ! Mean dir. spr. a1b1 + flgrd( 2, 9) = .false. ! Peak direction + flgrd( 2, 10) = .false. ! Infragravity height + flgrd( 2, 11) = .false. ! Space-Time Max E + flgrd( 2, 12) = .false. ! Space-Time Max Std + flgrd( 2, 13) = .false. ! Space-Time Hmax + flgrd( 2, 14) = .false. ! Spc-Time Hmax^crest + flgrd( 2, 15) = .false. ! STD Space-Time Hmax + flgrd( 2, 16) = .false. ! STD ST Hmax^crest + flgrd( 2, 17) = .false. ! Dominant wave bT + + ! 3) Frequency-dependent standard parameters + ! Whether the 1D Freq. Spectrum gets allocated is decided in the grid_inp file + ! ~/ww3_toolbox/grids/grid_inp/ww3_grid.inp.ww3a namelist section: &OUTS E3D = 1 / + flgrd( 3, 1) = .true. ! 1D Freq. Spectrum + flgrd( 3, 2) = .false. ! Mean wave dir. a1b1 + flgrd( 3, 3) = .false. ! Mean dir. spr. a1b1 + flgrd( 3, 4) = .false. ! Mean wave dir. a2b2 + flgrd( 3, 5) = .false. ! Mean dir. spr. a2b2 + flgrd( 3, 6) = .false. ! Wavenumber array ' + + ! 4) Spectral Partitions parameters + flgrd( 4, 1) = .false. ! Part. wave height ' + flgrd( 4, 2) = .false. ! Part. peak period ' + flgrd( 4, 3) = .false. ! Part. peak wave len.' + flgrd( 4, 4) = .false. ! Part. mean direction' + flgrd( 4, 5) = .false. ! Part. dir. spread ' + flgrd( 4, 6) = .false. ! Part. wind sea frac.' + flgrd( 4, 7) = .false. ! Part. peak direction' + flgrd( 4, 8) = .false. ! Part. peakedness ' + flgrd( 4, 9) = .false. ! Part. peak enh. fac.' + flgrd( 4,10) = .false. ! Part. gaussian width' + flgrd( 4,11) = .false. ! Part. spectral width' + flgrd( 4,12) = .false. ! Part. mean per. (-1)' + flgrd( 4,13) = .false. ! Part. mean per. (+1)' + flgrd( 4,14) = .false. ! Part. mean per. (+2)' + flgrd( 4,15) = .false. ! Part. peak density ' + flgrd( 4,16) = .false. ! Total wind sea frac.' + flgrd( 4,17) = .false. ! Number of partitions' + + ! 5) Atmosphere-waves layer + flgrd( 5, 1) = .false. ! Friction velocity ' + flgrd( 5, 2) = .false. ! Charnock parameter ' + flgrd( 5, 3) = .false. ! Energy flux ' + flgrd( 5, 4) = .false. ! Wind-wave enrgy flux' + flgrd( 5, 5) = .false. ! Wind-wave net mom. f' + flgrd( 5, 6) = .false. ! Wind-wave neg.mom.f.' + flgrd( 5, 7) = .false. ! Whitecap coverage ' + flgrd( 5, 8) = .false. ! Whitecap mean thick.' + flgrd( 5, 9) = .false. ! Mean breaking height' + flgrd( 5,10) = .false. ! Dominant break prob ' + flgrd( 5,11) = .false. ! Breaker passage rate' + + ! 6) Wave-ocean layer + flgrd( 6, 1) = .false. ! 'Radiation stresses ' + flgrd( 6, 2) = .false. ! 'Wave-ocean mom. flux' + flgrd( 6, 3) = .false. ! 'wave ind p Bern Head' + flgrd( 6, 4) = .false. ! 'Wave-ocean TKE flux' + flgrd( 6, 5) = .false. ! 'Stokes transport ' + flgrd( 6, 6) = .true. ! 'Stokes drift at z=0 ' + flgrd( 6, 7) = .false. ! '2nd order pressure ' + flgrd( 6, 8) = .false. ! 'Stokes drft spectrum' + flgrd( 6, 9) = .false. ! '2nd ord press spectr' + flgrd( 6,10) = .false. ! 'Wave-ice mom. flux ' + flgrd( 6,11) = .false. ! 'Wave-ice energy flux' + flgrd( 6,12) = .false. ! 'Split Surface Stokes' + flgrd( 6,13) = .false. ! 'Tot wav-ocn mom flux' + flgrd( 6,13) = .true. ! 'Turbulent Langmuir number (La_t)' + + ! 7) Wave-bottom layer + flgrd( 7, 1) = .false. ! 'Bottom rms ampl. ' + flgrd( 7, 2) = .false. ! 'Bottom rms velocity ' + flgrd( 7, 3) = .false. ! 'Bedform parameters ' + flgrd( 7, 4) = .false. ! 'Energy diss. in WBBL' + flgrd( 7, 5) = .false. ! 'Moment. loss in WBBL' + + ! 8) Spectrum parameters + flgrd( 8, 1) = .false. ! 'Mean square slopes ' + flgrd( 8, 2) = .false. ! 'Phillips tail const' + flgrd( 8, 3) = .false. ! 'Slope direction ' + flgrd( 8, 4) = .false. ! 'Tail slope direction' + flgrd( 8, 5) = .false. ! 'Goda peakedness parm' + + ! 9) Numerical diagnostics + flgrd( 9, 1) = .false. ! 'Avg. time step. ' + flgrd( 9, 2) = .false. ! 'Cut-off freq. ' + flgrd( 9, 3) = .false. ! 'Maximum spatial CFL ' + flgrd( 9, 4) = .false. ! 'Maximum angular CFL ' + flgrd( 9, 5) = .false. ! 'Maximum k advect CFL' + + ! 10) is user defined + + ! write out which fields will be output to first hist file + ! IDOUT(NOGRP,NGRPP) + ! NOGRP = number of output field groups + ! NGRPP = Max num of parameters per output + ! NOGE(NOGRP) = number of output group elements + if (iaproc == napout) then + flt = .true. + do i=1, nogrp + do j=1, noge(i) + if ( flgrd(i,j) ) then + if ( flt ) then + write (nds(1),'(a)') ' Fields : '//trim(idout(i,j)) + flt = .false. + else + write (nds(1),'(a)')' '//trim(idout(i,j)) + end if + end if + end do + end do + if ( flt ) then + write (nds(1),'(a)') ' Fields : '//'no fields defined' + end if + end if + + ! npts, pnames are fpr point output + allocate ( x(1), y(1), pnames(1) ) + npts = 0 + pnames(1) = ' ' + prtfrm = .false. + + end subroutine set_shel_inp + + !=============================================================================== +!> Read ww3_shel.inp (UWM) +!! +!! @param[in] mpi_comm mpi communicator +!! +!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov +!> @date 01-05-2022 + subroutine read_shel_inp(mpi_comm) + + USE W3GDATMD, ONLY: FLAGLL + USE W3WDATMD, ONLY: TIME, VA, W3NDAT, W3DIMW, W3SETW + USE W3ADATMD, ONLY: W3NAUX, W3DIMA, W3SETA + USE W3IDATMD, ONLY: INFLAGS1, INFLAGS2, FLAGSC + USE W3ODATMD, ONLY: W3NOUT, W3SETO, NDS + USE W3ODATMD, ONLY: NAPROC, IAPROC, NAPOUT, NAPERR + USE W3ODATMD, ONLY: IDOUT, FNMPRE, IOSTYP, NOTYPE + USE W3ODATMD, ONLY: FLOGRR, FLOGR, OFILES + USE W3IOGRMD, ONLY: W3IOGR + USE W3IOGOMD, ONLY: W3READFLGRD, W3FLGRDFLAG + USE W3SERVMD, ONLY: NEXTLN, EXTCDE + USE W3TIMEMD, ONLY: DSEC21, STME21, TICK21 + + INTEGER, INTENT(IN) :: MPI_COMM + + ! Local parameters + INTEGER, PARAMETER :: NHMAX = 200 + + INTEGER :: NDSI, NDSI2, NDSS, NDSO, NDSE, NDST, NDSL,& + NDSEN, IERR, J, I, ILOOP, IPTS + INTEGER :: NDSF(-7:9), & + NH(-7:10), THO(2,-7:10,NHMAX) + INTEGER :: jfirst, IERR_MPI + REAL :: FACTOR, DTTST, XX, YY, HA(NHMAX,-7:10), & + HD(NHMAX,-7:10), HS(NHMAX,-7:10) + + CHARACTER(LEN=1) :: COMSTR, FLAGTFC(-7:10) + CHARACTER(LEN=3) :: IDSTR(-7:10), IDTST + CHARACTER(LEN=6) :: YESXNO + CHARACTER(LEN=40) :: PN + 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=1024) :: FLDRST='' + CHARACTER(LEN=80) :: LINEIN + CHARACTER(LEN=8) :: WORDS(7)='' + LOGICAL :: FLFLG, FLHOM, TFLAGI, FLH(-7:10) + INTEGER :: THRLEV = 1 + INTEGER :: TIME0(2), TIMEN(2), TTIME(2) + + 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. + FLH(:) = .FALSE. + iprt(:) = 0 + + ! IO setup comes next---do we want to move it from initreal? + + NDSI = 10 + NDSS = 90 + NDSO = 6 + NDSE = 6 + NDST = 6 + NDSL = 50 + + IF ( IAPROC .EQ. NAPERR ) THEN + NDSEN = NDSE + ELSE + NDSEN = -1 + END IF + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,905) & + MPI_THREAD_FUNNELED, THRLEV + 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 + ! 1.c Local parameters + + ! Default COMSTR to "$" (for when using nml input files) + COMSTR = "$" + ! 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. + JFIRST=1 + + ! process old ww3_shel.inp format + OPEN (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 + + 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 + + INFLAGS1(10) = .FALSE. + 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 + ! 2.2 Time setup + + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*) TIME0 + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*) TIMEN + + ! 2.3 Domain setup + + CALL NEXTLN ( COMSTR , NDSI , NDSEN ) + READ (NDSI,*) IOSTYP + CALL W3IOGR ( 'GRID', NDSF(7) ) + IF ( FLAGLL ) THEN + FACTOR = 1. + ELSE + FACTOR = 1.E-3 + END IF + + ! 2.4 Output dates + + NPTS = 0 + NOTYPE = 6 + 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 ) + 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 + OFILES(J)=0 + READ (NDSI,*,END=2001,ERR=2002)(ODAT(I),I=5*(J-1)+1,5*J) + END IF + ODAT(5*(J-1)+3) = MAX ( 0 , ODAT(5*(J-1)+3) ) + ! 2.5 Output types + + 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 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 + CALL MPI_BARRIER (MPI_COMM,IERR_MPI) + 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 + IF ( NPTS.EQ.0 .AND. IAPROC.EQ.NAPOUT ) & + WRITE (NDSO,2947) + IF ( IAPROC .EQ. 1 ) THEN + CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) + CLOSE (NDSS,STATUS='DELETE') + ELSE + CLOSE (NDSS) + CALL MPI_BARRIER ( MPI_COMM, IERR_MPI ) + 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 + END IF + 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 + + 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 +#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 + 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 ! if not flgnml + + ! 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 + DTTST = DSEC21 ( TIME0 , TIMEN ) + IF ( DTTST .LE. 0. ) GOTO 2003 + + ! 2.3 Domain setup + + IOSTYP = MAX ( 0 , MIN ( 3 , IOSTYP ) ) + 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,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 + + ! 2.5 Output types + ! 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 + + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 5. Initializations + + IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,951) 'Wave model ...' + GOTO 2222 + + ! Error escape locations +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 ) +2003 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1003) + CALL EXTCDE ( 1003 ) +2005 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1005) IDTST + CALL EXTCDE ( 1005 ) +2054 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1054) + CALL EXTCDE ( 1054 ) +2006 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1006) IDTST, NH(J) + CALL EXTCDE ( 1006 ) +2007 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1007) + CALL EXTCDE ( 1007 ) + +2222 CONTINUE + + ! Formats +900 FORMAT (/15X,' *** WAVEWATCH III Program shell *** '/ & + 15X,'==============================================='/) +901 FORMAT ( ' Comment character is ''',A,''''/) +905 FORMAT ( ' Hybrid MPI/OMP thread support level:'/ & + ' 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) +941 FORMAT (/' Type',I2,' : ',A/ & + ' -----------------------------------------') +942 FORMAT ( ' From : ',A) +943 FORMAT ( ' To : ',A) +1944 FORMAT ( ' Interval : ', 8X,A11/) +2944 FORMAT ( ' Interval : ', 9X,A10/) +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) +3944 FORMAT ( ' Interval : ',11X,A8/) + +8945 FORMAT ( ' output dates out of run dates : ', A, & + ' deactivated') +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'/) +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) +1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & + ' ILLEGAL TIME INTERVAL'/) +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/) +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/) +1054 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & + ' POINT OUTPUT ACTIVATED BUT NO POINTS DEFINED'/) + end subroutine read_shel_inp + +end module wav_shel_inp diff --git a/model/src/wav_shr_mod.F90 b/model/src/wav_shr_mod.F90 new file mode 100644 index 000000000..1afd0706e --- /dev/null +++ b/model/src/wav_shr_mod.F90 @@ -0,0 +1,1158 @@ +!> @file wav_shr_mod +!! +!> Shared utility routines +!! +!> @details Contains public routines to execute repeated operations +!! +!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov +!> @date 01-05-2022 +module wav_shr_mod + + use ESMF , only : operator(<), operator(/=), operator(+) + use ESMF , only : operator(-), operator(*) , operator(>=) + use ESMF , only : operator(<=), operator(>), operator(==) + use ESMF , only : ESMF_LOGERR_PASSTHRU, ESMF_LogFoundError, ESMF_LOGMSG_ERROR, ESMF_MAXSTR + use ESMF , only : ESMF_SUCCESS, ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_FAILURE + use ESMF , only : ESMF_State, ESMF_StateGet, ESMF_StateItem_Flag, ESMF_STATEITEM_NOTFOUND + use ESMF , only : ESMF_Field, ESMF_FieldGet + use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_GridCompSet + use ESMF , only : ESMF_GeomType_Flag, ESMF_FieldStatus_Flag + use ESMF , only : ESMF_Mesh, ESMF_MeshGet + use ESMF , only : ESMF_GEOMTYPE_MESH, ESMF_GEOMTYPE_GRID, ESMF_FIELDSTATUS_COMPLETE + use ESMF , only : ESMF_Clock, ESMF_ClockCreate, ESMF_ClockGet, ESMF_ClockSet + use ESMF , only : ESMF_ClockPrint, ESMF_ClockAdvance + use ESMF , only : ESMF_Alarm, ESMF_AlarmCreate, ESMF_AlarmGet, ESMF_AlarmSet + use ESMF , only : ESMF_Calendar, ESMF_CALKIND_NOLEAP, ESMF_CALKIND_GREGORIAN + use ESMF , only : ESMF_Time, ESMF_TimeGet, ESMF_TimeSet + use ESMF , only : ESMF_TimeInterval, ESMF_TimeIntervalSet, ESMF_TimeIntervalGet + use ESMF , only : ESMF_VM, ESMF_VMGet, ESMF_VMBroadcast, ESMF_VMGetCurrent + use NUOPC , only : NUOPC_CompAttributeGet + use NUOPC_Model , only : NUOPC_ModelGet + use wav_kind_mod , only : r8 => shr_kind_r8, i8 => shr_kind_i8, cl=>shr_kind_cl, cs=>shr_kind_cs + + implicit none + private + + public :: state_getscalar !< @public obtain a scalar field from a state + public :: state_setscalar !< @public set scalar data from state for a particular name + public :: state_reset !< @public reset field values in a state + public :: state_getfldptr !< @public obtain a pointer to a field in a state + public :: state_fldchk !< @public check whether a field is in a state + public :: state_diagnose !< @public print min,max,sum and size of a field in a state + public :: alarmInit !< @public set up an alarm in a clock + public :: chkerr !< @public check if an error was returned from and ESMF call + public :: ymd2date !< @public convert year,month,day to integer + private :: timeInit !< @public create an ESMF_Time object + private :: field_getfldptr !< @private obtain a pointer to a field + + interface state_getfldptr + module procedure state_getfldptr_1d + module procedure state_getfldptr_2d + end interface state_getfldptr + + ! used by both CESM and UFS + ! runtype is used by W3SRCE (values are startup, branch, continue) + character(len=cs) , public :: runtype !< @public the run type (startup,branch,continue) + logical , public :: wav_coupling_to_cice = .false. !< @public flag to specify additional wave export + !! fields for coupling to CICE (TODO: generalize) + 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 + character(len= 36) , public :: time_origin !< @public the time_origin used for netCDF output + character(len= 36) , public :: calendar_name !< @public the calendar used for netCDF output + integer(i8) , public :: elapsed_secs !< @public the time in seconds from the time_origin + + ! Only used by cesm + ! if a run is a startup or branch run, then initfile is used + ! to construct the initial file and used in W3IORSMD + ! if a run is a continue run, then casename is used to construct + ! the restart filename in W3IORSMD + character(len=256) , public :: initfile !< @public name of wave initial condition file + logical , public :: rstwr !< @public logical to control restart write. if true => write restart + logical , public :: histwr !< @public logical to control history write. if true => write history file (snapshot) + integer , public :: outfreq !< @public output frequency in hours (TODO: not used?) + integer , public :: inst_index !< @public number of current instance (ie 1) + character(len=16) , public :: inst_name !< @public fullname of current instance (ie "wav_0001") + character(len=16) , public :: inst_suffix !< @public char string associated with instance + + ! Only used by ufs + logical , public :: merge_import = .false. !< @public logical to specify whether import fields will + !! be merged with a field provided from a file + logical , public :: multigrid = .false. !< @public logical to control whether wave model is run + !! as multigrid + + interface ymd2date + module procedure ymd2date_int + module procedure ymd2date_long + end interface ymd2date + + ! Clock and alarm option + character(len=*), private, parameter :: & + optNONE = "none" , & !< alarm option none + optNever = "never" , & !< alarm option never + optNSteps = "nsteps" , & !< alarm option nsteps + optNStep = "nstep" , & !< alarm option nstep + optNSeconds = "nseconds" , & !< alarm option nseconds + optNSecond = "nsecond" , & !< alarm option nsecond + optNMinutes = "nminutes" , & !< alarm option nminutes + optNMinute = "nminute" , & !< alarm option nminute + optNHours = "nhours" , & !< alarm option nhours + optNHour = "nhour" , & !< alarm option nhour + optNDays = "ndays" , & !< alarm option ndays + optNDay = "nday" , & !< alarm option nday + optNMonths = "nmonths" , & !< alarm option nmonths + optNMonth = "nmonth" , & !< alarm option nmonth + optNYears = "nyears" , & !< alarm option nyears + optNYear = "nyear" , & !< alarm option nyear + optMonthly = "monthly" , & !< alarm option monthly + optYearly = "yearly" , & !< alarm option yearly + optDate = "date" , & !< alarm option date + optIfdays0 = "ifdays0" !< alarm option for number of days 0 + + ! Module data + 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 + subroutine state_getscalar(state, scalar_id, scalar_value, flds_scalar_name, flds_scalar_num, rc) + + ! ---------------------------------------------- + ! Get scalar data from State for a particular name and broadcast it to all other pets + ! ---------------------------------------------- + + ! input/output variables + type(ESMF_State), intent(in) :: state + integer, intent(in) :: scalar_id + real(r8), intent(out) :: scalar_value + character(len=*), intent(in) :: flds_scalar_name + integer, intent(in) :: flds_scalar_num + integer, intent(inout) :: rc + + ! local variables + integer :: mytask, ierr, len + type(ESMF_VM) :: vm + type(ESMF_Field) :: field + real(r8), pointer :: farrayptr(:,:) + real(r8) :: tmp(1) + character(len=*), parameter :: subname = ' (wav_shr_mod:state_getscalar) ' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_VMGetCurrent(vm, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_VMGet(vm, localPet=mytask, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_StateGet(State, itemName=trim(flds_scalar_name), field=field, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (mytask == 0) then + call ESMF_FieldGet(field, 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, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + endif + tmp(:) = farrayptr(scalar_id,:) + endif + call ESMF_VMBroadCast(vm, tmp, 1, 0, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + scalar_value = tmp(1) + + 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 + subroutine state_setscalar(scalar_value, scalar_id, State, flds_scalar_name, flds_scalar_num, rc) + + ! ---------------------------------------------- + ! Set scalar data from State for a particular name + ! ---------------------------------------------- + + ! input/output arguments + real(r8), intent(in) :: scalar_value + integer, intent(in) :: scalar_id + type(ESMF_State), intent(inout) :: State + character(len=*), intent(in) :: flds_scalar_name + integer, intent(in) :: flds_scalar_num + integer, intent(inout) :: rc + + ! local variables + integer :: mytask + type(ESMF_Field) :: lfield + type(ESMF_VM) :: vm + real(r8), pointer :: farrayptr(:,:) + character(len=*), parameter :: subname = ' (wav_shr_mod:state_setscalar) ' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_VMGetCurrent(vm, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_VMGet(vm, localPet=mytask, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_StateGet(State, itemName=trim(flds_scalar_name), field=lfield, rc=rc) + 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 + 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 + subroutine state_reset(State, reset_value, rc) + + ! ---------------------------------------------- + ! Set all fields to value in State to value + ! ---------------------------------------------- + + ! intput/output variables + type(ESMF_State) , intent(inout) :: State + real(R8) , intent(in) :: reset_value + integer , intent(out) :: rc + + ! local variables + integer :: i,j,n + type(ESMF_Field) :: lfield + integer :: fieldCount + integer :: lrank + character(ESMF_MAXSTR), allocatable :: lfieldnamelist(:) + real(R8), pointer :: fldptr1(:) + real(R8), pointer :: fldptr2(:,:) + character(len=*), parameter :: subname = ' (wav_shr_mod:state_reset) ' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_StateGet(State, itemCount=fieldCount, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + allocate(lfieldnamelist(fieldCount)) + call ESMF_StateGet(State, itemNameList=lfieldnamelist, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + + 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 + enddo + + deallocate(lfieldnamelist) + + 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 + subroutine state_getfldptr_1d(State, fldname, fldptr, rc) + ! ---------------------------------------------- + ! Get pointer to a state field + ! ---------------------------------------------- + + ! input/output variables + type(ESMF_State) , intent(in) :: State + character(len=*) , intent(in) :: fldname + real(R8) , pointer , intent(inout) :: fldptr(:) + integer, optional , intent(out) :: rc + + ! local variables + type(ESMF_Field) :: lfield + type(ESMF_FieldStatus_Flag) :: status + character(len=*),parameter :: subname='(wav_import_export:state_getfldptr_1d)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_StateGet(State, itemName=trim(fldname), field=lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_FieldGet(lfield, status=status, rc=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 + else + 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 + subroutine state_getfldptr_2d(State, fldname, fldptr, rc) + ! ---------------------------------------------- + ! Get pointer to a state field + ! ---------------------------------------------- + + ! input/output variables + type(ESMF_State) , intent(in) :: State + character(len=*) , intent(in) :: fldname + real(R8) , pointer , intent(inout) :: fldptr(:,:) + integer , optional , intent(out) :: rc + + ! local variables + type(ESMF_Field) :: lfield + type(ESMF_FieldStatus_Flag) :: status + character(len=*),parameter :: subname='(wav_import_export:state_getfldptr_2d)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_StateGet(State, itemName=trim(fldname), field=lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_FieldGet(lfield, status=status, rc=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 + else + 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 + logical function state_fldchk(State, fldname) + ! ---------------------------------------------- + ! Determine if field is in state + ! ---------------------------------------------- + + ! input/output variables + type(ESMF_State) , intent(in) :: State + character(len=*) , intent(in) :: fldname + + ! local variables + type(ESMF_StateItem_Flag) :: itemType + ! ---------------------------------------------- + + call ESMF_StateGet(State, trim(fldname), itemType) + State_FldChk = (itemType /= ESMF_STATEITEM_NOTFOUND) + + 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 + subroutine state_diagnose(State, string, rc) + + ! ---------------------------------------------- + ! Diagnose status of State + ! ---------------------------------------------- + + type(ESMF_State), intent(in) :: state + character(len=*), intent(in) :: string + integer , intent(out) :: rc + + ! local variables + integer :: i,j,n + type(ESMf_Field) :: lfield + integer :: fieldCount, lrank + character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) + real(r8), pointer :: dataPtr1d(:) + real(r8), pointer :: dataPtr2d(:,:) + character(len=ESMF_MAXSTR) :: msgString + character(len=*), parameter :: subname = ' (wav_shr_mod:state_diagnose) ' + ! ---------------------------------------------- + + + call ESMF_StateGet(state, itemCount=fieldCount, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(lfieldnamelist(fieldCount)) + + call ESMF_StateGet(state, itemNameList=lfieldnamelist, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + 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) + 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 + subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) + + ! ---------------------------------------------- + ! for a field, determine rank and return fldptr1 or fldptr2 + ! abort is true by default and will abort if fldptr is not yet allocated in field + ! rank returns 0, 1, or 2. 0 means fldptr not allocated and abort=false + ! ---------------------------------------------- + + ! input/output variables + type(ESMF_Field) , intent(in) :: field + real(r8), pointer , intent(inout), optional :: fldptr1(:) + real(r8), pointer , intent(inout), optional :: fldptr2(:,:) + integer , intent(out) , optional :: rank + logical , intent(in) , optional :: abort + integer , intent(out) , optional :: rc + + ! local variables + type(ESMF_GeomType_Flag) :: geomtype + type(ESMF_FieldStatus_Flag) :: status + type(ESMF_Mesh) :: lmesh + integer :: lrank, nnodes, nelements + logical :: labort + character(len=*), parameter :: subname = ' (wav_shr_mod:field_getfldptr) ' + ! ---------------------------------------------- + + 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 + endif + + rc = ESMF_SUCCESS + + labort = .true. + if (present(abort)) then + labort = abort + endif + lrank = -99 + + call ESMF_FieldGet(field, status=status, rc=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 + 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) + 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 ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif + + endif ! status + + if (present(rank)) then + 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 + subroutine alarmInit( clock, alarm, option, & + opt_n, opt_ymd, opt_tod, RefTime, alarmname, rc) + + ! Setup an alarm in a clock + ! Notes: The ringtime sent to AlarmCreate MUST be the next alarm + ! time. If you send an arbitrary but proper ringtime from the + ! past and the ring interval, the alarm will always go off on the + ! next clock advance and this will cause serious problems. Even + ! if it makes sense to initialize an alarm with some reference + ! time and the alarm interval, that reference time has to be + ! advance forward to be >= the current time. In the logic below + ! we set an appropriate "NextAlarm" and then we make sure to + ! advance it properly based on the ring interval. + + ! input/output variables + type(ESMF_Clock) , intent(inout) :: clock ! clock + type(ESMF_Alarm) , intent(inout) :: alarm ! alarm + character(len=*) , intent(in) :: option ! alarm option + integer , optional , intent(in) :: opt_n ! alarm freq + integer , optional , intent(in) :: opt_ymd ! alarm ymd + integer , optional , intent(in) :: opt_tod ! alarm tod (sec) + type(ESMF_Time) , optional , intent(in) :: RefTime ! ref time + character(len=*) , optional , intent(in) :: alarmname ! alarm name + integer , intent(inout) :: rc ! Return code + + ! local variables + type(ESMF_Calendar) :: cal ! calendar + integer :: lymd ! local ymd + integer :: ltod ! local tod + integer :: cyy,cmm,cdd,csec ! time info + character(len=64) :: lalarmname ! local alarm name + logical :: update_nextalarm ! update next alarm + type(ESMF_Time) :: CurrTime ! Current Time + type(ESMF_Time) :: NextAlarm ! Next restart alarm time + type(ESMF_TimeInterval) :: AlarmInterval ! Alarm interval + integer :: sec + + character(len=*), parameter :: subname = ' (wav_shr_mod:set_alarmInit) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + lalarmname = 'alarm_unknown' + if (present(alarmname)) lalarmname = trim(alarmname) + ltod = 0 + if (present(opt_tod)) ltod = opt_tod + lymd = -1 + if (present(opt_ymd)) lymd = opt_ymd + + call ESMF_ClockGet(clock, CurrTime=CurrTime, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_TimeGet(CurrTime, yy=cyy, mm=cmm, dd=cdd, s=csec, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! initial guess of next alarm, this will be updated below + if (present(RefTime)) then + NextAlarm = RefTime + else + NextAlarm = CurrTime + endif + + ! Determine calendar + call ESMF_ClockGet(clock, calendar=cal) + + ! Determine inputs for call to create alarm + 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. + + 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 + + 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. + + 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. + + 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. + + 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. + + 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. + + 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. + + 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. + + 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. + + 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. + + 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. + + 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. + + 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. + + 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. + + 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. + + 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. + + 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. + + 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. + + 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. + + case default + call ESMF_LogWrite(trim(subname)//'unknown option '//trim(option), & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + + end select + + ! -------------------------------------------------------------------------------- + ! --- AlarmInterval and NextAlarm should be set --- + ! -------------------------------------------------------------------------------- + + ! --- advance Next Alarm so it won't ring on first timestep for + ! --- 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 + endif + + alarm = ESMF_AlarmCreate( name=lalarmname, clock=clock, ringTime=NextAlarm, & + ringInterval=AlarmInterval, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + 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 + subroutine timeInit( Time, ymd, cal, tod, rc) + + ! Create the ESMF_Time object corresponding to the given input time, + ! given in YMD (Year Month Day) and TOD (Time-of-day) format. + ! Set the time by an integer as YYYYMMDD and integer seconds in the day + + ! input/output parameters: + type(ESMF_Time) , intent(inout) :: Time ! ESMF time + integer , intent(in) :: ymd ! year, month, day YYYYMMDD + type(ESMF_Calendar) , intent(in) :: cal ! ESMF calendar + integer , intent(in) :: tod ! time of day in seconds + integer , intent(out) :: rc + + ! local variables + integer :: year, mon, day ! year, month, day as integers + integer :: tdate ! temporary date + integer :: date ! coded-date (yyyymmdd) + integer, parameter :: SecPerDay = 86400 ! Seconds per day + character(len=*), parameter :: subname = ' (wav_shr_mod:timeInit) ' + !------------------------------------------------------------------------------- + + 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 + end if + + tdate = abs(date) + year = int(tdate/10000) + if (date < 0) year = -year + mon = int( mod(tdate,10000)/ 100) + day = mod(tdate, 100) + + call ESMF_TimeSet( Time, yy=year, mm=mon, dd=day, s=tod, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + 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 + subroutine ymd2date_int(year,month,day,date) + ! Converts year, month, day to coded-date + + ! input/output variables + integer,intent(in ) :: year,month,day ! calendar year,month,day + integer,intent(out) :: date ! coded (yyyymmdd) calendar date + !--------------------------------------- + + ! NOTE: this calendar has a year zero (but no day or month zero) + date = abs(year)*10000 + month*100 + day ! coded calendar date + if (year < 0) date = -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 + subroutine ymd2date_long(year,month,day,date) + ! Converts year, month, day to coded-date + + ! input/output variables + integer ,intent(in ) :: year,month,day ! calendar year,month,day + integer(I8),intent(out) :: date ! coded ([yy]yyyymmdd) calendar date + !--------------------------------------- + + ! NOTE: this calendar has a year zero (but no day or month zero) + date = abs(year)*10000_I8 + month*100 + day ! coded calendar 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 + logical function chkerr(rc, line, file) + + integer, intent(in) :: rc + integer, intent(in) :: line + character(len=*), intent(in) :: file + + integer :: lrc + + chkerr = .false. + lrc = rc + if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=line, file=file)) then + chkerr = .true. + endif + end function chkerr + +end module wav_shr_mod