diff --git a/.github/workflows/gnu.yml b/.github/workflows/gnu.yml index f44498d0ce..df920ec4fd 100644 --- a/.github/workflows/gnu.yml +++ b/.github/workflows/gnu.yml @@ -1,14 +1,20 @@ name: GNU Linux Build on: [push, pull_request] +# Cancel in-progress workflows when pushing to a branch +concurrency: + group: ${{ github.workflow }}-${{ github.event.pull_request.number || github.ref }} + cancel-in-progress: true + env: - cache_key: gnu4 + cache_key: gnu5 CC: gcc-10 FC: gfortran-10 CXX: g++-10 + # Split into a steup step, and a WW3 build step which -# builds multiple switches in a matrix. The setup is run once and +# builds multiple switches in a matrix. The setup is run once and # the environment is cached so each build of WW3 can share the dependencies. jobs: @@ -16,6 +22,11 @@ jobs: runs-on: ubuntu-20.04 steps: + - name: checkout-ww3 + if: steps.cache-env.outputs.cache-hit != 'true' + uses: actions/checkout@v2 + with: + path: ww3 # Cache spack, OASIS, and compiler # No way to flush Action cache, so key may have # appended - name: cache-env @@ -26,13 +37,7 @@ jobs: spack ~/.spack work_oasis3-mct - key: spack-${{ runner.os }}-${{ env.cache_key }} - - - name: checkout-ww3 - if: steps.cache-env.outputs.cache-hit != 'true' - uses: actions/checkout@v2 - with: - path: ww3 + key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('ww3/model/ci/spack.yaml') }} # Build WW3 spack environment - name: install-dependencies-with-spack @@ -72,7 +77,7 @@ jobs: steps: - name: checkout-ww3 uses: actions/checkout@v2 - with: + with: path: ww3 - name: cache-env @@ -83,7 +88,7 @@ jobs: spack ~/.spack work_oasis3-mct - key: spack-${{ runner.os }}-${{ env.cache_key }} + key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('ww3/model/ci/spack.yaml') }} - name: build-ww3 run: | @@ -102,5 +107,3 @@ jobs: cmake .. -DSWITCH=${{ matrix.switch }} fi make -j2 VERBOSE=1 - - diff --git a/.github/workflows/intel.yml b/.github/workflows/intel.yml index 7c63d28c32..eec7697aea 100644 --- a/.github/workflows/intel.yml +++ b/.github/workflows/intel.yml @@ -1,6 +1,11 @@ name: Intel Linux Build on: [push, pull_request] +# Cancel in-progress workflows when pushing to a branch +concurrency: + group: ${{ github.workflow }}-${{ github.event.pull_request.number || github.ref }} + cancel-in-progress: true + # Use custom shell with -l so .bash_profile is sourced which loads intel/oneapi/setvars.sh # without having to do it in manually every step defaults: @@ -9,7 +14,7 @@ defaults: # Set I_MPI_CC/F90 so Intel MPI wrapper uses icc/ifort instead of gcc/gfortran env: - cache_key: intel5 + cache_key: intel6 CC: icc FC: ifort CXX: icpc @@ -17,7 +22,7 @@ env: I_MPI_F90: ifort # Split into a dependency build step, and a WW3 build step which -# builds multiple switches in a matrix. The setup is run once and +# builds multiple switches in a matrix. The setup is run once and # the environment is cached so each build of WW3 can share the dependencies. jobs: @@ -25,6 +30,13 @@ jobs: runs-on: ubuntu-latest steps: + + - name: checkout-ww3 + if: steps.cache-env.outputs.cache-hit != 'true' + uses: actions/checkout@v2 + with: + path: ww3 + # Cache spack, OASIS, and compiler # No way to flush Action cache, so key may have # appended - name: cache-env @@ -36,7 +48,7 @@ jobs: ~/.spack work_oasis3-mct /opt/intel - key: spack-${{ runner.os }}-${{ env.cache_key }} + key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('ww3/model/ci/spack.yaml') }} - name: install-intel-compilers if: steps.cache-env.outputs.cache-hit != 'true' @@ -48,12 +60,6 @@ jobs: sudo apt-get install intel-oneapi-dev-utilities intel-oneapi-mpi-devel intel-oneapi-openmp intel-oneapi-compiler-fortran intel-oneapi-compiler-dpcpp-cpp-and-cpp-classic echo "source /opt/intel/oneapi/setvars.sh" >> ~/.bash_profile - - name: checkout-ww3 - if: steps.cache-env.outputs.cache-hit != 'true' - uses: actions/checkout@v2 - with: - path: ww3 - # Build WW3 spack environment - name: install-dependencies-with-spack if: steps.cache-env.outputs.cache-hit != 'true' @@ -92,7 +98,7 @@ jobs: steps: - name: checkout-ww3 uses: actions/checkout@v2 - with: + with: path: ww3 - name: install-intel @@ -108,7 +114,7 @@ jobs: ~/.spack work_oasis3-mct /opt/intel - key: spack-${{ runner.os }}-${{ env.cache_key }} + key: spack-${{ runner.os }}-${{ env.cache_key }}-${{ hashFiles('ww3/model/ci/spack.yaml') }} - name: build-ww3 run: | @@ -127,5 +133,3 @@ jobs: cmake .. -DSWITCH=${{ matrix.switch }} fi make -j2 VERBOSE=1 - - diff --git a/model/bin/build_utils.sh b/model/bin/build_utils.sh index 40451cb924..77be83da52 100755 --- a/model/bin/build_utils.sh +++ b/model/bin/build_utils.sh @@ -829,7 +829,7 @@ create_file_list() then core='' else - core='wav_kind_mod wav_shr_mod wav_shel_inp wav_comp_nuopc wav_import_export w3iogoncdmd' + core='wav_kind_mod wav_shr_mod wav_shel_inp wav_comp_nuopc wav_import_export wav_grdout wav_shr_flags w3iogoncdmd' fi core="$core w3fldsmd w3initmd w3wavemd w3wdasmd w3updtmd" core="$core wminitmd wmwavemd wmfinlmd wmgridmd wmupdtmd wminiomd" diff --git a/model/bin/make_makefile.sh b/model/bin/make_makefile.sh index a114f9d3a6..75b2a0de2f 100755 --- a/model/bin/make_makefile.sh +++ b/model/bin/make_makefile.sh @@ -452,6 +452,8 @@ '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_grdout' ) modtest=wav_grdout.o ;; + 'wav_shr_flags'. ) modtest=wav_shr_flags.o ;; 'wav_comp_nuopc' ) modtest=wav_comp_nuopc.o ;; 'wav_import_export' ) modtest=wav_import_export.o ;; 'w3iogoncdmd' ) modtest=w3iogoncdmd.o ;; diff --git a/model/src/cmake/src_list.cmake b/model/src/cmake/src_list.cmake index 5c011508f6..051529c127 100644 --- a/model/src/cmake/src_list.cmake +++ b/model/src/cmake/src_list.cmake @@ -55,6 +55,9 @@ set(ftn_src wmupdtmd.F90 wmwavemd.F90 w3tidemd.F90 + wav_grdout.F90 + w3iogoncdmd.F90 + wav_shr_flags.F90 ) set(nuopc_mesh_cap_src @@ -63,7 +66,6 @@ set(nuopc_mesh_cap_src wav_shel_inp.F90 wav_comp_nuopc.F90 wav_import_export.F90 - w3iogoncdmd.F90 ) set(esmf_multi_cap_src diff --git a/model/src/w3adatmd.F90 b/model/src/w3adatmd.F90 index 61d97aeff8..18de9cdac8 100644 --- a/model/src/w3adatmd.F90 +++ b/model/src/w3adatmd.F90 @@ -1,3363 +1,3206 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3ADATMD +MODULE W3ADATMD #ifdef W3_MEMCHECK - USE MallocInfo_m -#endif -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 28-Dec-2004 : Origination. ( version 3.06 ) -!/ 04-May-2005 : Adding MPI_COMM_WAVE. ( version 3.07 ) -!/ 20-Jul-2005 : Adding output fields. ( version 3.07 ) -!/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) -!/ 13-Jun-2006 : Splitting STORE in G/SSTORE. ( version 3.09 ) -!/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 28_Mar-2007 : Add partitioned data arrays. ( version 3.11 ) -!/ Add aditional undefined arrays. -!/ 22-Feb-2008 ; Modify MAPTH2 declaration. ( version 3.13 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 29-Oct-2010 : Adding unstructured grid data. ( version 3.14 ) -!/ (A. Roland and F. Ardhuin) -!/ 31-Oct-2010 : Adding output parameters ( version 3.14 ) -!/ 12-Dec-2012 : Adding SMC grid. JG_Li ( version 4.08 ) -!/ 26-Dec-2012 : Memory reduction for outputs. ( version 4.11 ) -!/ Add W3XETA. -!/ 28-Jun-2013 : Bug fix initialization P2SMS. ( version 4.11 ) -!/ 11-Nov-2013 : SMC and rotated grid incorporated in the main -!/ trunk ( version 4.13 ) -!/ 14-Nov-2013 : Move orphaned arrays as scalar to W3SRCE. -!/ Here update of documentation only. -!/ (Z0S, CDS, EMN, FMN, WNM, AMX) ( version 4.13 ) -!/ 30-Apr-2014 : Memory reduction for group3. ( version 5.00 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 01-May-2017 : Adds directional MSS parameters ( version 6.02 ) -!/ 30-Jul-2017 : Adds TWS parameter ( version 6.02 ) -!/ 05-Jun-2018 : Adds PDLIB and MEMCHECK ( version 6.04 ) -!/ 21-Aug-2018 : Add WBT parameter ( version 6.06 ) -!/ 22-Mar-2021 : Adds TAUA, WNMEAN, TAUOC parameters ( version 7.13 ) -!/ 06-May-2021 : SMC shares variables with PR2/3. ( version 7.13 ) -! -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Define data structures to set up wave model auxiliary data for -! several models simultaneously. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NADATA Int. Public Number of models in array dim. -! IADATA Int. Public Selected model for output, init. at -1. -! MPIBUF I.P. Public Number of buffer arrays for 'hidden' -! MPI communications (no hiding for -! MPIBUF = 1). -! WADAT TYPE Public Basic data structure. -! WADATS WADAT Public Array of data structures. -! ---------------------------------------------------------------- -! -! All elements of WADAT are aliased to pointers with the same -! name. These pointers are defined as : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! Internal model definition: -! -! CG R.A. Public Group velocities for all wave model -! sea points and frequencies. -! WN R.A. Public Idem, wavenumbers. -! -! Aux. arrays for model input: -! -! CA0-I R.A. Public Absolute current velocity (initial -! and inc.) in W3UCUR. -! CD0-I R.A. Public Current direction (initial and -! increment) in W3UCUR. -! UA0-I R.A. Public Absolute wind speeds (initial and -! incr.) in W3UWND (m/s) -! UD0-I R.A. Public Wind direction (initial and incr.) -! in W3UWND (rad) -! AS0-I R.A. Public Stability par. (initial and incr.) -! in W3UWND (degr) -! MA0-I R.A. Public Absolute atmospheric momentum (initial -! and inc.) in W3UTAU. -! RA0-I R.A. Public Absolute air density (initial and inc.) -! in W3URHO. -! MD0-I R.A. Public Atmospheric momentum direction (initial and -! increment) in W3UTAU. -! ATRNX/Y R.A. Public Actual transparency info. -! -! Fields of mean wave parameters: -! -! DW R.A. Public Water depths. -! UA R.A. Public Absolute wind speeds. -! UD R.A. Public Absolute wind direction. -! U10 R.A. Public Wind speed used. -! U10D R.A. Public Wind direction used. -! AS R.A. Public Stability parameter. -! CX/Y R.A. Public Current components. -! TAUA R.A. Public Absolute atmospheric momentum. -! TAUADIR R.A. Public Absolute atmospheric momentum direction. -! -! HS R.A. Public Wave Height. -! WLM R.A. Public Mean wave length. -! T02 R.A. Public Mean wave period (m0,2). -! T0M1 R.A. Public Mean wave period (m0,-1). -! T01 R.A. Public Mean wave period (m0,1). -! FP0 R.A. Public Peak frequency. -! THM R.A. Public Mean wave direction. -! THS R.A. Public Mean directional spread. -! THP0 R.A. Public Peak direction. -! HSIG R.A. Public Height of infragravity waves -! STMAXE R.A. Public Expected maximum surface elevation (crest) -! STMAXD R.A. Public STD of maximum surface elevation -! HMAXE R.A. Public Expected maximum wave height (from covariance) -! HMAXD R.A. Public Std of HMAXE -! HCMAXE R.A. Public Expected maximum wave height (from crest) -! HCMAXD R.A. Public STD of HCMAXE -! WBT R.A. Public Dominant wave breaking probability -! (b_T in Babanin et al. (2001, JGR)) -! WNMEAN R.A. Public Mean wave number -! -! CHARN R.A. Public Charnock parameter for air-sea friction. -! TWS R.A. Public Wind sea period (used for flux parameterizations) -! CGE R.A. Public Energy flux. -! PHIAW R.A. Public Wind to wave energy flux. -! TAUWIX/Y R.A. Public Wind to wave energy flux. -! TAUWNX/Y R.A. Public Wind to wave energy flux. -! WHITECAP R.A. Public 1 : Whitecap coverage -! 2 : Whitecap thickness -! 3 : Mean breaking height -! 4 : Mean breaking height -! -! Sxx R.A. Public Radiation stresses. -! TAUOX/Y R.A. Public Wave-ocean momentum flux. -! BHD R.A. Public Wave-induced pressure (J term, Smith JPO 2006) -! PHIOC R.A. Public Waves to ocean energy flux. -! TUSX/Y R.A. Public Volume transport associated to Stokes drift. -! USSX/Y R.A. Public Surface Stokes drift. -! TAUOCX/Y R.A. Public Total ocean momentum flux -! TAUICE R.A. Public Wave-ice momentum flux. -! PHICE R.A. Public Waves to ice energy flux. -! -! US3D R.A. Public 3D Stokes drift. -! USSP R.A. Public Partitioned Surface Stokes drift -! -! ABA R.A. Public Near-bottom rms wave ex. amplitude. -! ABD R.A. Public Corresponding direction. -! UBA R.A. Public Near-bottom rms wave velocity. -! UBD R.A. Public Corresponding direction. -! BEDFORMS R.A. Public Bed for parameters -! PHIBBL R.A. Public Energy loss in WBBL. -! TAUBBL R.A. Public Momentum loss in WBBL. -! -! MSSX/Y R.A. Public Surface mean square slopes in X and Y direction. -! MSCX/Y R.A. Public Phillips constant. -! MSSD R.A. Public Direction of MSSX -! MSCD R.A. Public Direction of MSCX -! QP R.A. Public Goda peakedness parameter. -! -! DTDYN R.A. Public Mean dynamic time step (raw). -! FCUT R.A. Public Cut-off frequency for tail. -! CFLXYMAX R.A. Public Max. CFL number for spatial advection. -! CFLTHMAX R.A. Public Max. CFL number for refraction. -! CFLKMAX R.A. Public Max. CFL number for wavenumber shift. -! -! Old parameters not yet in new structure ... -! -! FP1 R.A. Public Wind sea peak frequency. (parked in 2) -! THP1 R.A. Public Wind sea peak direction. (parked in 2) -! -! Orphans, commented out here, now automatic arrays in W3WAVE, .... -! -! DRAT R.A. Public Density ration air/water. Was -! placeholder only. Now scalar in W3SRCE, -! TAUWX/Y R.A. Public Stresses. -! -! Derivatives in space .... -! -! DDDx R.A. Public Spatial derivatives of the depth. -! DCxDx R.A. Public Spatial dirivatives of the current. -! -! Mean parameters from partitiones spectra, 2D array with el. -! 0 holding wind sea data, and 1:NOSWLL holding swell fields. -! Last two arrays are regular single-entry arrays. -! -! PHS R.A. Public Wave height of partition. -! PTP R.A. Public Peak period of partition. -! PLP R.A. Public Peak wave leingth of partition. -! PDIR R.A. Public Mean direction of partition. -! PSI R.A. Public Mean spread of partition. -! PWS R.A. Public Wind sea fraction of partition. -! -! PWST R.A. Public Total wind sea fraction. -! PNR R.A. Public Number of partitions found. -! -! PTHP0 R.A. Public Peak wave direction of partition. -! PQP R.A. Public Goda peakdedness parameter of partition. -! PPE R.A. Public JONSWAP peak enhancement factor of partition. -! PGW R.A. Public Gaussian frequency width of partition. -! PSW R.A. Public Spectral width of partition. -! PTM1 R.A. Public Mean wave period (m-1,0) of partition. -! PT1 R.A. Public Mean wave period (m0,1) of partition. -! PT2 R.A. Public Mean wave period (m0,2) of partition. -! PEP R.A. Public Peak spectral density of partition. -! -! Empty dummy fields (NOEXTR) -! -! USERO R.A. Public Empty output arrays than can be -! used by users as a simple means to -! add output. -! -! Map data for propagation schemes (1Up). -! -! IS0/2 I.A. Public Spectral propagation maps. -! FACVX/Y R.A. Public Spatial propagation factor map. -! -! Map data for propagation schemes (UQ). -! -! NMXn Int. Public Counters for MAPX2, see W3MAP3. -! NMYn Int. Public -! NMXY Int. Public Dimension of MAPXY. -! NACTn Int. Public Dimension of MAPAXY. -! NCENT Int. Public Dimension of MAPAXY. -! MAPX2 I.A. Public Map for prop. in 'x' (longitude) dir. -! MAPY2 I.A. Public Idem in y' (latitude) direction. -! MAPXY I.A. Public -! MAPAXY I.A. Public List of active points used in W3QCK1. -! MAPCXY I.A. Public List of central points used in avg. -! MAPTH2 I.A. Public Like MAPX2 for refraction (rotated -! and shifted, see W3KTP3). Like MAPAXY. -! MAPWN2 I.A. Public Like MAPX2 for wavenumber shift. -! MAPTRN L.A. Public Map to block out GSE mitigation in -! proper grid points. -! -! Nonlinear interactions ( !/NL1 ) : -! -! NFR Int. Public Nuber of frequencies ( NFR = NK ) -! NFRHGH Int. Public Auxiliary frequency counter. -! NFRCHG Int. Public Id. -! NSPECX-Y Int. Public Auxiliary spectral counter. -! IPnn I.A. Public Spectral address for Snl. -! IMnn I.A. Public Id. -! ICnn I.A. Public Id. -! DALn Real Public Lambda dependend weight factors. -! AWGn Real Public Interpolation weights for Snl. -! SWGn Real Public Interpolation weights for diag. term. -! AF11 R.A. Public Scaling array (f**11) -! NLINIT Log. Public Flag for initialization. -! -! MPP / MPI variables : -! -! IAPPRO I.A. Public Processor numbers for propagation calc. -! for each spectral component. -! MPI_COMM_WAVE -! Int. Public Communicator used in the wave model. -! MPI_COMM_WCMP -! Int. Public Idem, computational proc. only. -! WW3_FIELD_VEC, WW3_SPEC_VEC -! Int. Public MPI derived vecor types. -! NRQSG1 Int. Public Number of handles in IRQSG1. -! NRQSG2 Int. Public Number of handles in IRQSG2. -! IBFLOC Int. Public Present active buffer number. -! ISPLOC Int. Public Corresponding local spectral bin number -! (1,NSPLOC,1). -! NSPLOC Int. Public Total number of spectral bins for which -! prop. is performed on present CPU. -! BSTAT I.A. Public Status of buffer (size MPIBUF): -! 0: Inactive. -! 1: A --> STORE (active or finished). -! 2: STORE --> A (active or finished). -! BISPL I.A. Public Local spectral bin number for buffer -! (size MPIBUF). -! IRQSG1 I.A. Public MPI request handles for scatters and -! gathers to A() (persistent). -! IRQSG2 I.A. Public MPI request handles for gathers and -! scatters to STORE (persistent). -! G/SSTORE R.A. Public Communication buffer (NSEA,MPIBUF). -! SPPNT R.A. Public Point output buffer. -! -! Other: -! -! ITIME Int. Public Discrete time step counter. -! IPASS Int. Public Pass counter for log file. -! IDLAST Int. Public Last day ID for log file. -! NSEALM Int. Public Maximum number of local sea points. -! ALPHA R.A. Public Phillips' alpha. -! FLCOLD Log. Public Flag for 'cold start' of model. -! FLIWND Log. Public Flag for initialization of model -! based on wind. -! AINIT(2) Log. Public Flag for array initialization. -! FL_ALL Log. Public Flag for all/partial initialization. -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3NAUX Subr. Public Set number of grids/models. -! W3DIMA Subr. Public Set dimensions of arrays. -! W3DMNL Subr. Public Set dimensions of arrays. ( !/NL1 ) -! W3SETA Subr. Public Point to selected grid / model. -! W3XETA Subr. Public Like W3SETA for expanded output arrays. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG Subr. W3GDATMD Point to proper model grid. -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. W3SERVMD Abort program with exit code. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - The number of grids is taken from W3GDATMD, and needs to be -! set first with W3DIMG. -! -! 6. Switches : -! -! !/SHRD, !/DIST, !/MPI -! Shared / distributed memory model -! -! !/PRn Propagation scheme selection. -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -!/ -!/ Module private variable for checking error returns -!/ - INTEGER, PRIVATE :: ISTAT -!/ -!/ Conventional declarations -!/ - INTEGER :: NADATA = -1, IADATA = -1 -#ifdef W3_MPI - INTEGER, PARAMETER :: MPIBUF = 6 -#endif -!/ -!/ Data structure WADAT -!/ - TYPE WADAT -! -! The grid -! - REAL, POINTER :: CG(:,:), WN(:,:) + USE MallocInfo_m +#endif + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 28-Dec-2004 : Origination. ( version 3.06 ) + !/ 04-May-2005 : Adding MPI_COMM_WAVE. ( version 3.07 ) + !/ 20-Jul-2005 : Adding output fields. ( version 3.07 ) + !/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) + !/ 13-Jun-2006 : Splitting STORE in G/SSTORE. ( version 3.09 ) + !/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 28_Mar-2007 : Add partitioned data arrays. ( version 3.11 ) + !/ Add aditional undefined arrays. + !/ 22-Feb-2008 ; Modify MAPTH2 declaration. ( version 3.13 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 29-Oct-2010 : Adding unstructured grid data. ( version 3.14 ) + !/ (A. Roland and F. Ardhuin) + !/ 31-Oct-2010 : Adding output parameters ( version 3.14 ) + !/ 12-Dec-2012 : Adding SMC grid. JG_Li ( version 4.08 ) + !/ 26-Dec-2012 : Memory reduction for outputs. ( version 4.11 ) + !/ Add W3XETA. + !/ 28-Jun-2013 : Bug fix initialization P2SMS. ( version 4.11 ) + !/ 11-Nov-2013 : SMC and rotated grid incorporated in the main + !/ trunk ( version 4.13 ) + !/ 14-Nov-2013 : Move orphaned arrays as scalar to W3SRCE. + !/ Here update of documentation only. + !/ (Z0S, CDS, EMN, FMN, WNM, AMX) ( version 4.13 ) + !/ 30-Apr-2014 : Memory reduction for group3. ( version 5.00 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 01-May-2017 : Adds directional MSS parameters ( version 6.02 ) + !/ 30-Jul-2017 : Adds TWS parameter ( version 6.02 ) + !/ 05-Jun-2018 : Adds PDLIB and MEMCHECK ( version 6.04 ) + !/ 21-Aug-2018 : Add WBT parameter ( version 6.06 ) + !/ 22-Mar-2021 : Adds TAUA, WNMEAN, TAUOC parameters ( version 7.13 ) + !/ 06-May-2021 : SMC shares variables with PR2/3. ( version 7.13 ) + ! + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Define data structures to set up wave model auxiliary data for + ! several models simultaneously. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NADATA Int. Public Number of models in array dim. + ! IADATA Int. Public Selected model for output, init. at -1. + ! MPIBUF I.P. Public Number of buffer arrays for 'hidden' + ! MPI communications (no hiding for + ! MPIBUF = 1). + ! WADAT TYPE Public Basic data structure. + ! WADATS WADAT Public Array of data structures. + ! ---------------------------------------------------------------- + ! + ! All elements of WADAT are aliased to pointers with the same + ! name. These pointers are defined as : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! Internal model definition: + ! + ! CG R.A. Public Group velocities for all wave model + ! sea points and frequencies. + ! WN R.A. Public Idem, wavenumbers. + ! + ! Aux. arrays for model input: + ! + ! CA0-I R.A. Public Absolute current velocity (initial + ! and inc.) in W3UCUR. + ! CD0-I R.A. Public Current direction (initial and + ! increment) in W3UCUR. + ! UA0-I R.A. Public Absolute wind speeds (initial and + ! incr.) in W3UWND (m/s) + ! UD0-I R.A. Public Wind direction (initial and incr.) + ! in W3UWND (rad) + ! AS0-I R.A. Public Stability par. (initial and incr.) + ! in W3UWND (degr) + ! MA0-I R.A. Public Absolute atmospheric momentum (initial + ! and inc.) in W3UTAU. + ! RA0-I R.A. Public Absolute air density (initial and inc.) + ! in W3URHO. + ! MD0-I R.A. Public Atmospheric momentum direction (initial and + ! increment) in W3UTAU. + ! ATRNX/Y R.A. Public Actual transparency info. + ! + ! Fields of mean wave parameters: + ! + ! DW R.A. Public Water depths. + ! UA R.A. Public Absolute wind speeds. + ! UD R.A. Public Absolute wind direction. + ! U10 R.A. Public Wind speed used. + ! U10D R.A. Public Wind direction used. + ! AS R.A. Public Stability parameter. + ! CX/Y R.A. Public Current components. + ! TAUA R.A. Public Absolute atmospheric momentum. + ! TAUADIR R.A. Public Absolute atmospheric momentum direction. + ! + ! HS R.A. Public Wave Height. + ! WLM R.A. Public Mean wave length. + ! T02 R.A. Public Mean wave period (m0,2). + ! T0M1 R.A. Public Mean wave period (m0,-1). + ! T01 R.A. Public Mean wave period (m0,1). + ! FP0 R.A. Public Peak frequency. + ! THM R.A. Public Mean wave direction. + ! THS R.A. Public Mean directional spread. + ! THP0 R.A. Public Peak direction. + ! HSIG R.A. Public Height of infragravity waves + ! STMAXE R.A. Public Expected maximum surface elevation (crest) + ! STMAXD R.A. Public STD of maximum surface elevation + ! HMAXE R.A. Public Expected maximum wave height (from covariance) + ! HMAXD R.A. Public Std of HMAXE + ! HCMAXE R.A. Public Expected maximum wave height (from crest) + ! HCMAXD R.A. Public STD of HCMAXE + ! WBT R.A. Public Dominant wave breaking probability + ! (b_T in Babanin et al. (2001, JGR)) + ! WNMEAN R.A. Public Mean wave number + ! + ! CHARN R.A. Public Charnock parameter for air-sea friction. + ! TWS R.A. Public Wind sea period (used for flux parameterizations) + ! CGE R.A. Public Energy flux. + ! PHIAW R.A. Public Wind to wave energy flux. + ! TAUWIX/Y R.A. Public Wind to wave energy flux. + ! TAUWNX/Y R.A. Public Wind to wave energy flux. + ! WHITECAP R.A. Public 1 : Whitecap coverage + ! 2 : Whitecap thickness + ! 3 : Mean breaking height + ! 4 : Mean breaking height + ! + ! Sxx R.A. Public Radiation stresses. + ! TAUOX/Y R.A. Public Wave-ocean momentum flux. + ! BHD R.A. Public Wave-induced pressure (J term, Smith JPO 2006) + ! PHIOC R.A. Public Waves to ocean energy flux. + ! TUSX/Y R.A. Public Volume transport associated to Stokes drift. + ! USSX/Y R.A. Public Surface Stokes drift. + ! TAUOCX/Y R.A. Public Total ocean momentum flux + ! TAUICE R.A. Public Wave-ice momentum flux. + ! PHICE R.A. Public Waves to ice energy flux. + ! + ! US3D R.A. Public 3D Stokes drift. + ! USSP R.A. Public Partitioned Surface Stokes drift + ! + ! ABA R.A. Public Near-bottom rms wave ex. amplitude. + ! ABD R.A. Public Corresponding direction. + ! UBA R.A. Public Near-bottom rms wave velocity. + ! UBD R.A. Public Corresponding direction. + ! BEDFORMS R.A. Public Bed for parameters + ! PHIBBL R.A. Public Energy loss in WBBL. + ! TAUBBL R.A. Public Momentum loss in WBBL. + ! + ! MSSX/Y R.A. Public Surface mean square slopes in X and Y direction. + ! MSCX/Y R.A. Public Phillips constant. + ! MSSD R.A. Public Direction of MSSX + ! MSCD R.A. Public Direction of MSCX + ! QP R.A. Public Goda peakedness parameter. + ! + ! DTDYN R.A. Public Mean dynamic time step (raw). + ! FCUT R.A. Public Cut-off frequency for tail. + ! CFLXYMAX R.A. Public Max. CFL number for spatial advection. + ! CFLTHMAX R.A. Public Max. CFL number for refraction. + ! CFLKMAX R.A. Public Max. CFL number for wavenumber shift. + ! + ! Old parameters not yet in new structure ... + ! + ! FP1 R.A. Public Wind sea peak frequency. (parked in 2) + ! THP1 R.A. Public Wind sea peak direction. (parked in 2) + ! + ! Orphans, commented out here, now automatic arrays in W3WAVE, .... + ! + ! DRAT R.A. Public Density ration air/water. Was + ! placeholder only. Now scalar in W3SRCE, + ! TAUWX/Y R.A. Public Stresses. + ! + ! Derivatives in space .... + ! + ! DDDx R.A. Public Spatial derivatives of the depth. + ! DCxDx R.A. Public Spatial dirivatives of the current. + ! + ! Mean parameters from partitiones spectra, 2D array with el. + ! 0 holding wind sea data, and 1:NOSWLL holding swell fields. + ! Last two arrays are regular single-entry arrays. + ! + ! PHS R.A. Public Wave height of partition. + ! PTP R.A. Public Peak period of partition. + ! PLP R.A. Public Peak wave leingth of partition. + ! PDIR R.A. Public Mean direction of partition. + ! PSI R.A. Public Mean spread of partition. + ! PWS R.A. Public Wind sea fraction of partition. + ! + ! PWST R.A. Public Total wind sea fraction. + ! PNR R.A. Public Number of partitions found. + ! + ! PTHP0 R.A. Public Peak wave direction of partition. + ! PQP R.A. Public Goda peakdedness parameter of partition. + ! PPE R.A. Public JONSWAP peak enhancement factor of partition. + ! PGW R.A. Public Gaussian frequency width of partition. + ! PSW R.A. Public Spectral width of partition. + ! PTM1 R.A. Public Mean wave period (m-1,0) of partition. + ! PT1 R.A. Public Mean wave period (m0,1) of partition. + ! PT2 R.A. Public Mean wave period (m0,2) of partition. + ! PEP R.A. Public Peak spectral density of partition. + ! + ! Empty dummy fields (NOEXTR) + ! + ! USERO R.A. Public Empty output arrays than can be + ! used by users as a simple means to + ! add output. + ! + ! Map data for propagation schemes (1Up). + ! + ! IS0/2 I.A. Public Spectral propagation maps. + ! FACVX/Y R.A. Public Spatial propagation factor map. + ! + ! Map data for propagation schemes (UQ). + ! + ! NMXn Int. Public Counters for MAPX2, see W3MAP3. + ! NMYn Int. Public + ! NMXY Int. Public Dimension of MAPXY. + ! NACTn Int. Public Dimension of MAPAXY. + ! NCENT Int. Public Dimension of MAPAXY. + ! MAPX2 I.A. Public Map for prop. in 'x' (longitude) dir. + ! MAPY2 I.A. Public Idem in y' (latitude) direction. + ! MAPXY I.A. Public + ! MAPAXY I.A. Public List of active points used in W3QCK1. + ! MAPCXY I.A. Public List of central points used in avg. + ! MAPTH2 I.A. Public Like MAPX2 for refraction (rotated + ! and shifted, see W3KTP3). Like MAPAXY. + ! MAPWN2 I.A. Public Like MAPX2 for wavenumber shift. + ! MAPTRN L.A. Public Map to block out GSE mitigation in + ! proper grid points. + ! + ! Nonlinear interactions ( !/NL1 ) : + ! + ! NFR Int. Public Nuber of frequencies ( NFR = NK ) + ! NFRHGH Int. Public Auxiliary frequency counter. + ! NFRCHG Int. Public Id. + ! NSPECX-Y Int. Public Auxiliary spectral counter. + ! IPnn I.A. Public Spectral address for Snl. + ! IMnn I.A. Public Id. + ! ICnn I.A. Public Id. + ! DALn Real Public Lambda dependend weight factors. + ! AWGn Real Public Interpolation weights for Snl. + ! SWGn Real Public Interpolation weights for diag. term. + ! AF11 R.A. Public Scaling array (f**11) + ! NLINIT Log. Public Flag for initialization. + ! + ! MPP / MPI variables : + ! + ! IAPPRO I.A. Public Processor numbers for propagation calc. + ! for each spectral component. + ! MPI_COMM_WAVE + ! Int. Public Communicator used in the wave model. + ! MPI_COMM_WCMP + ! Int. Public Idem, computational proc. only. + ! WW3_FIELD_VEC, WW3_SPEC_VEC + ! Int. Public MPI derived vecor types. + ! NRQSG1 Int. Public Number of handles in IRQSG1. + ! NRQSG2 Int. Public Number of handles in IRQSG2. + ! IBFLOC Int. Public Present active buffer number. + ! ISPLOC Int. Public Corresponding local spectral bin number + ! (1,NSPLOC,1). + ! NSPLOC Int. Public Total number of spectral bins for which + ! prop. is performed on present CPU. + ! BSTAT I.A. Public Status of buffer (size MPIBUF): + ! 0: Inactive. + ! 1: A --> STORE (active or finished). + ! 2: STORE --> A (active or finished). + ! BISPL I.A. Public Local spectral bin number for buffer + ! (size MPIBUF). + ! IRQSG1 I.A. Public MPI request handles for scatters and + ! gathers to A() (persistent). + ! IRQSG2 I.A. Public MPI request handles for gathers and + ! scatters to STORE (persistent). + ! G/SSTORE R.A. Public Communication buffer (NSEA,MPIBUF). + ! SPPNT R.A. Public Point output buffer. + ! + ! Other: + ! + ! ITIME Int. Public Discrete time step counter. + ! IPASS Int. Public Pass counter for log file. + ! IDLAST Int. Public Last day ID for log file. + ! NSEALM Int. Public Maximum number of local sea points. + ! ALPHA R.A. Public Phillips' alpha. + ! FLCOLD Log. Public Flag for 'cold start' of model. + ! FLIWND Log. Public Flag for initialization of model + ! based on wind. + ! AINIT(2) Log. Public Flag for array initialization. + ! FL_ALL Log. Public Flag for all/partial initialization. + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3NAUX Subr. Public Set number of grids/models. + ! W3DIMA Subr. Public Set dimensions of arrays. + ! W3DMNL Subr. Public Set dimensions of arrays. ( !/NL1 ) + ! W3SETA Subr. Public Point to selected grid / model. + ! W3XETA Subr. Public Like W3SETA for expanded output arrays. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG Subr. W3GDATMD Point to proper model grid. + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. W3SERVMD Abort program with exit code. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - The number of grids is taken from W3GDATMD, and needs to be + ! set first with W3DIMG. + ! + ! 6. Switches : + ! + ! !/SHRD, !/DIST, !/MPI + ! Shared / distributed memory model + ! + ! !/PRn Propagation scheme selection. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + use wav_shr_flags + + ! module default + IMPLICIT NONE + + PUBLIC + !/ + !/ Module private variable for checking error returns + !/ + INTEGER, PRIVATE :: ISTAT + !/ + !/ Conventional declarations + !/ + INTEGER :: NADATA = -1, IADATA = -1 + INTEGER, PARAMETER :: MPIBUF = 6 + !/ + !/ Data structure WADAT + !/ + TYPE WADAT + ! + ! The grid + ! + REAL, POINTER :: CG(:,:), WN(:,:) #ifdef W3_IC3 - REAL, POINTER :: IC3WN_R(:,:), IC3WN_I(:,:), IC3CG(:,:) -#endif -! -! Arrays for processing model input -! - REAL, POINTER :: CA0(:), CAI(:), CD0(:), CDI(:), & - UA0(:), UAI(:), UD0(:), UDI(:), & - MA0(:), MAI(:), RA0(:), RAI(:), & - MD0(:), MDI(:), AS0(:), ASI(:), & - ATRNX(:,:), ATRNY(:,:) -! -! Output fields group 1) -! - REAL, POINTER :: DW(:), UA(:), UD(:), U10(:), U10D(:),& - AS(:), CX(:), CY(:), TAUA(:), TAUADIR(:) -! -! Output fields group 2) -! - REAL, POINTER :: HS(:), WLM(:), T02(:), T0M1(:), & - T01 (:), FP0(:), THM(:), & - THS(:), THP0(:), FP1(:), THP1(:), & - HSIG(:), STMAXE(:), STMAXD(:), & - HMAXE(:), HCMAXE(:), HMAXD(:), & - HCMAXD(:), QP(:), WBT(:), WNMEAN(:) - REAL, POINTER :: XHS(:), XWLM(:), XT02(:), XT0M1(:), & - XT01 (:), XFP0(:), XTHM(:), & - XTHS(:), XTHP0(:), XFP1(:), XTHP1(:),& - XHSIG(:), XSTMAXE(:), XSTMAXD(:), & - XHMAXE(:), XHCMAXE(:), XHMAXD(:), & - XHCMAXD(:), XQP(:), XWBT(:), & - XWNMEAN(:) -! -! Output fields group 3) -! - REAL, POINTER :: EF(:,:), TH1M(:,:), STH1M(:,:), & - TH2M(:,:), STH2M(:,:) !, WN(:,:) - REAL, POINTER :: XEF(:,:), XTH1M(:,:), XSTH1M(:,:),& - XTH2M(:,:), XSTH2M(:,:) !, XWN(:,:) -! -! Output fields group 4) -! - REAL, POINTER :: PHS(:,:), PTP(:,:), PLP(:,:), & - PDIR(:,:), PSI(:,:), PWS(:,:), & - PWST(:), PNR(:), PGW(:,:), & - PTHP0(:,:), PQP(:,:), PPE(:,:), & - PSW(:,:), PTM1(:,:), PT1(:,:), & - PT2(:,:), PEP(:,:) - REAL, POINTER :: XPHS(:,:), XPTP(:,:), XPLP(:,:), & - XPDIR(:,:), XPSI(:,:), XPWS(:,:), & - XPWST(:), XPNR(:), XPGW(:,:), & - XPTHP0(:,:), XPQP(:,:), XPPE(:,:), & - XPSW(:,:), XPTM1(:,:), XPT1(:,:), & - XPT2(:,:), XPEP(:,:) -! -! Output fields group 5) -! - REAL, POINTER :: CHARN(:), CGE(:), PHIAW(:), & - TAUWIX(:), TAUWIY(:), TAUWNX(:), & - TAUWNY(:), WHITECAP(:,:), TWS(:) - REAL, POINTER :: XCHARN(:), XCGE(:), XPHIAW(:), & - XTAUWIX(:), XTAUWIY(:), XTAUWNX(:), & - XTAUWNY(:), XWHITECAP(:,:), XTWS(:) -! -! Output fields group 6) -! - REAL, POINTER :: SXX(:), SYY(:), SXY(:), TAUOX(:),& - TAUOY(:), BHD(:), PHIOC(:), & - TUSX(:), TUSY(:), USSX(:), & - USSY(:), TAUOCX(:), TAUOCY(:), & - PRMS(:), TPMS(:), PHICE(:), & - TAUICE(:,:) - REAL, POINTER :: P2SMS(:,:), US3D(:,:), USSP(:,:) - REAL, POINTER :: XSXX(:), XSYY(:), XSXY(:), XTAUOX(:),& - XTAUOY(:), XBHD(:), XPHIOC(:), & - XTUSX(:), XTUSY(:), XUSSX(:), & - XUSSY(:), XTAUOCX(:), XTAUOCY(:), & - XPRMS(:), XTPMS(:), XPHICE(:), & - XTAUICE(:,:) - REAL, POINTER :: XP2SMS(:,:), XUS3D(:,:), XUSSP(:,:) + REAL, POINTER :: IC3WN_R(:,:), IC3WN_I(:,:), IC3CG(:,:) +#endif + ! + ! Arrays for processing model input + ! + REAL, POINTER :: CA0(:), CAI(:), CD0(:), CDI(:), UA0(:), UAI(:), UD0(:), UDI(:) + REAL, POINTER :: MA0(:), MAI(:), RA0(:), RAI(:), MD0(:), MDI(:), AS0(:), ASI(:) + REAL, POINTER :: ATRNX(:,:), ATRNY(:,:) + ! + ! Output fields group 1) + ! + REAL, POINTER :: DW(:), UA(:), UD(:), U10(:), U10D(:), AS(:), CX(:), CY(:) + REAL, POINTER :: TAUA(:), TAUADIR(:) + ! + ! Output fields group 2) + ! + REAL, POINTER :: HS(:), WLM(:), T02(:), T0M1(:), T01 (:), FP0(:), THM(:) + REAL, POINTER :: THS(:), THP0(:), FP1(:), THP1(:), HSIG(:), STMAXE(:), STMAXD(:) + REAL, POINTER :: HMAXE(:), HCMAXE(:), HMAXD(:), HCMAXD(:), QP(:), WBT(:), WNMEAN(:) + + REAL, POINTER :: XHS(:), XWLM(:), XT02(:), XT0M1(:), XT01 (:), XFP0(:), XTHM(:) + REAL, POINTER :: XTHS(:), XTHP0(:), XFP1(:), XTHP1(:), XHSIG(:), XSTMAXE(:), XSTMAXD(:) + REAL, POINTER :: XHMAXE(:), XHCMAXE(:), XHMAXD(:), XHCMAXD(:), XQP(:), XWBT(:), XWNMEAN(:) + ! + ! Output fields group 3) + ! + REAL, POINTER :: EF(:,:), TH1M(:,:), STH1M(:,:), TH2M(:,:), STH2M(:,:) ! WN(:,:) + REAL, POINTER :: XEF(:,:), XTH1M(:,:), XSTH1M(:,:), XTH2M(:,:), XSTH2M(:,:) ! XWN(:,:) + ! + ! Output fields group 4) + ! + REAL, POINTER :: PHS(:,:), PTP(:,:), PLP(:,:), PDIR(:,:), PSI(:,:), PWS(:,:) + REAL, POINTER :: PWST(:), PNR(:), PGW(:,:), PTHP0(:,:), PQP(:,:), PPE(:,:) + REAL, POINTER :: PSW(:,:), PTM1(:,:), PT1(:,:), PT2(:,:), PEP(:,:) + + REAL, POINTER :: XPHS(:,:), XPTP(:,:), XPLP(:,:), XPDIR(:,:), XPSI(:,:), XPWS(:,:) + REAL, POINTER :: XPWST(:), XPNR(:), XPGW(:,:), XPTHP0(:,:), XPQP(:,:), XPPE(:,:), XPSW(:,:) + REAL, POINTER :: XPTM1(:,:), XPT1(:,:), XPT2(:,:), XPEP(:,:) + ! + ! Output fields group 5) + ! + REAL, POINTER :: CHARN(:), CGE(:), PHIAW(:) + REAL, POINTER :: TAUWIX(:), TAUWIY(:), TAUWNX(:) + REAL, POINTER :: TAUWNY(:), WHITECAP(:,:), TWS(:) + REAL, POINTER :: XCHARN(:), XCGE(:), XPHIAW(:) + REAL, POINTER :: XTAUWIX(:), XTAUWIY(:), XTAUWNX(:) + REAL, POINTER :: XTAUWNY(:), XWHITECAP(:,:), XTWS(:) + ! + ! Output fields group 6) + ! + REAL, POINTER :: SXX(:), SYY(:), SXY(:), TAUOX(:) + REAL, POINTER :: TAUOY(:), BHD(:), PHIOC(:) + REAL, POINTER :: TUSX(:), TUSY(:), USSX(:) + REAL, POINTER :: USSY(:), TAUOCX(:), TAUOCY(:) + REAL, POINTER :: PRMS(:), TPMS(:), PHICE(:) + REAL, POINTER :: TAUICE(:,:) + REAL, POINTER :: P2SMS(:,:), US3D(:,:), USSP(:,:) + REAL, POINTER :: XSXX(:), XSYY(:), XSXY(:), XTAUOX(:) + REAL, POINTER :: XTAUOY(:), XBHD(:), XPHIOC(:) + REAL, POINTER :: XTUSX(:), XTUSY(:), XUSSX(:) + REAL, POINTER :: XUSSY(:), XTAUOCX(:), XTAUOCY(:) + REAL, POINTER :: XPRMS(:), XTPMS(:), XPHICE(:) + REAL, POINTER :: XTAUICE(:,:) + REAL, POINTER :: XP2SMS(:,:), XUS3D(:,:), XUSSP(:,:) #ifdef W3_CESMCOUPLED - REAL, POINTER :: XLANGMT(:) -#endif -! -! Output fields group 7) -! - REAL, POINTER :: ABA(:), ABD(:), UBA(:), UBD(:), & - BEDFORMS(:,:), PHIBBL(:), & - TAUBBL(:,:) - REAL, POINTER :: XABA(:), XABD(:), XUBA(:), XUBD(:), & - XBEDFORMS(:,:), XPHIBBL(:), & - XTAUBBL(:,:) -! -! Output fields group 8) -! - REAL, POINTER :: MSSX(:), MSSY(:), MSSD(:), & - MSCX(:), MSCY(:), MSCD(:) - REAL, POINTER :: XMSSX(:), XMSSY(:), XMSSD(:), & - XMSCX(:), XMSCY(:), XMSCD(:) -! -! Output fields group 9) -! - REAL, POINTER :: DTDYN(:), FCUT(:), CFLXYMAX(:), & - CFLTHMAX(:), CFLKMAX(:) - REAL, POINTER :: XDTDYN(:), XFCUT(:), XCFLXYMAX(:), & - XCFLTHMAX(:), XCFLKMAX(:) -! -! Output fields group 10) -! - REAL, POINTER :: USERO(:,:) - REAL, POINTER :: XUSERO(:,:) + REAL, POINTER :: XLANGMT(:) +#endif + ! + ! Output fields group 7) + ! + REAL, POINTER :: ABA(:), ABD(:), UBA(:), UBD(:), BEDFORMS(:,:), PHIBBL(:), TAUBBL(:,:) + REAL, POINTER :: XABA(:), XABD(:), XUBA(:), XUBD(:), XBEDFORMS(:,:), XPHIBBL(:), XTAUBBL(:,:) + ! + ! Output fields group 8) + ! + REAL, POINTER :: MSSX(:), MSSY(:), MSSD(:), MSCX(:), MSCY(:), MSCD(:) + REAL, POINTER :: XMSSX(:), XMSSY(:), XMSSD(:), XMSCX(:), XMSCY(:), XMSCD(:) + ! + ! Output fields group 9) + ! + REAL, POINTER :: DTDYN(:), FCUT(:), CFLXYMAX(:), CFLTHMAX(:), CFLKMAX(:) + REAL, POINTER :: XDTDYN(:), XFCUT(:), XCFLXYMAX(:), XCFLTHMAX(:), XCFLKMAX(:) + ! + ! Output fields group 10) + ! + REAL, POINTER :: USERO(:,:) + REAL, POINTER :: XUSERO(:,:) #ifdef W3_CESMCOUPLED - ! Output fileds for Langmuir mixing in group - REAL, POINTER :: LANGMT(:), LAPROJ(:), LASL(:), & - LASLPJ(:), LAMULT(:), ALPHAL(:), & - ALPHALS(:), USSXH(:), USSYH(:) -#endif -! -! Spatial derivatives -! - REAL, POINTER :: DDDX(:,:), DDDY(:,:), DCXDX(:,:), & - DCYDX(:,:), DCXDY(:,:), DCYDY(:,:) - REAL, POINTER :: DCDX(:,:,:), DCDY(:,:,:) + ! Output fileds for Langmuir mixing in group + REAL, POINTER :: LANGMT(:), LAPROJ(:), LASL(:) ! W3_CESMCOUPLED + REAL, POINTER :: LASLPJ(:), LAMULT(:), ALPHAL(:) ! W3_CESMCOUPLED + REAL, POINTER :: ALPHALS(:), USSXH(:), USSYH(:) ! W3_CESMCOUPLED +#endif + ! + ! Spatial derivatives + ! + REAL, POINTER :: DDDX(:,:), DDDY(:,:), DCXDX(:,:) + REAL, POINTER :: DCYDX(:,:), DCXDY(:,:), DCYDY(:,:) + REAL, POINTER :: DCDX(:,:,:), DCDY(:,:,:) #ifdef W3_SMC - REAL, POINTER :: DHDX(:), DHDY(:), DHLMT(:,:) + REAL, POINTER :: DHDX(:), DHDY(:), DHLMT(:,:) #endif -! + ! #ifdef W3_PR1 - INTEGER, POINTER :: IS0(:), IS2(:) - REAL, POINTER :: FACVX(:), FACVY(:) + INTEGER, POINTER :: IS0(:), IS2(:) + REAL, POINTER :: FACVX(:), FACVY(:) #endif -! + ! #ifdef W3_PR2 - INTEGER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, & - NACT, NMXY - INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), & - MAPXY(:), MAPTH2(:), MAPWN2(:) + INTEGER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, NACT, NMXY + INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), MAPXY(:), MAPTH2(:), MAPWN2(:) #endif -! + ! #ifdef W3_PR3 - INTEGER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, & - NACT, NCENT - INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), & - MAPCXY(:), MAPTH2(:), MAPWN2(:) - LOGICAL, POINTER :: MAPTRN(:) -#endif -! -! Warning Defined but not set if UGTYPE .EQ. .T. - INTEGER, POINTER :: ITER(:,:) -! + INTEGER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, NACT, NCENT + INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), MAPCXY(:), MAPTH2(:), MAPWN2(:) + LOGICAL, POINTER :: MAPTRN(:) +#endif + ! + ! Warning Defined but not set if UGTYPE .EQ. .T. + INTEGER, POINTER :: ITER(:,:) + ! #ifdef W3_NL1 - INTEGER :: NFR, NFRHGH, NFRCHG, NSPECX, NSPECY - INTEGER, POINTER :: IP11(:), IP12(:), IP13(:), IP14(:), & - IM11(:), IM12(:), IM13(:), IM14(:), & - IP21(:), IP22(:), IP23(:), IP24(:), & - IM21(:), IM22(:), IM23(:), IM24(:), & - IC11(:), IC12(:), IC21(:), IC22(:), & - IC31(:), IC32(:), IC41(:), IC42(:), & - IC51(:), IC52(:), IC61(:), IC62(:), & - IC71(:), IC72(:), IC81(:), IC82(:) - REAL :: DAL1, DAL2, DAL3, & - AWG1, AWG2, AWG3, AWG4, AWG5, AWG6, & - AWG7, AWG8, SWG1, SWG2, SWG3, SWG4, & - SWG5, SWG6, SWG7, SWG8 - REAL, POINTER :: AF11(:) - LOGICAL :: NLINIT -#endif -! - INTEGER, POINTER :: IAPPRO(:) -#ifdef W3_MPI - INTEGER :: MPI_COMM_WAVE, MPI_COMM_WCMP, & - WW3_FIELD_VEC, WW3_SPEC_VEC, & - NRQSG1 = 0, NRQSG2, IBFLOC, ISPLOC, & - NSPLOC -#endif + INTEGER :: NFR, NFRHGH, NFRCHG, NSPECX, NSPECY + INTEGER, POINTER :: IP11(:), IP12(:), IP13(:), IP14(:) + INTEGER, POINTER :: IM11(:), IM12(:), IM13(:), IM14(:) + INTEGER, POINTER :: IP21(:), IP22(:), IP23(:), IP24(:) + INTEGER, POINTER :: IM21(:), IM22(:), IM23(:), IM24(:) + INTEGER, POINTER :: IC11(:), IC12(:), IC21(:), IC22(:) + INTEGER, POINTER :: IC31(:), IC32(:), IC41(:), IC42(:) + INTEGER, POINTER :: IC51(:), IC52(:), IC61(:), IC62(:) + INTEGER, POINTER :: IC71(:), IC72(:), IC81(:), IC82(:) + REAL :: DAL1, DAL2, DAL3 + REAL :: AWG1, AWG2, AWG3, AWG4, AWG5, AWG6 + REAL :: AWG7, AWG8, SWG1, SWG2, SWG3, SWG4 + REAL :: SWG5, SWG6, SWG7, SWG8 + REAL, POINTER :: AF11(:) + LOGICAL :: NLINIT +#endif + ! + INTEGER, POINTER :: IAPPRO(:) + INTEGER :: MPI_COMM_WAVE, MPI_COMM_WCMP, WW3_FIELD_VEC, WW3_SPEC_VEC + INTEGER :: NRQSG1 = 0, NRQSG2, IBFLOC, ISPLOC, NSPLOC #ifdef W3_PDLIB - INTEGER :: NBFIELD, PDLIB_MPI_TYPE -#endif -#ifdef W3_MPI - INTEGER :: BSTAT(MPIBUF), BISPL(MPIBUF) - INTEGER, POINTER :: IRQSG1(:,:), IRQSG2(:,:) - REAL, POINTER :: GSTORE(:,:), SSTORE(:,:) -#endif - REAL, POINTER :: SPPNT(:,:,:) -! - INTEGER :: ITIME, IPASS, IDLAST, NSEALM - REAL, POINTER :: ALPHA(:,:) - LOGICAL :: AINIT, AINIT2, FL_ALL, FLCOLD, FLIWND -! - END TYPE WADAT -!/ -!/ Data storage -!/ - TYPE(WADAT), TARGET, ALLOCATABLE :: WADATS(:) -!/ -!/ Data aliases for structure WADAT(S) -!/ + INTEGER :: NBFIELD, PDLIB_MPI_TYPE +#endif + INTEGER :: BSTAT(MPIBUF), BISPL(MPIBUF) + INTEGER, POINTER :: IRQSG1(:,:), IRQSG2(:,:) + REAL, POINTER :: GSTORE(:,:), SSTORE(:,:) + REAL, POINTER :: SPPNT(:,:,:) + ! + INTEGER :: ITIME, IPASS, IDLAST, NSEALM + REAL, POINTER :: ALPHA(:,:) + LOGICAL :: AINIT, AINIT2, FL_ALL, FLCOLD, FLIWND + ! + END TYPE WADAT + !/ + !/ Data storage + !/ + TYPE(WADAT), TARGET, ALLOCATABLE :: WADATS(:) + !/ + !/ Data aliases for structure WADAT(S) + !/ #ifdef W3_CESMCOUPLED - REAL, POINTER :: LANGMT(:), LAPROJ(:), ALPHAL(:), & - ALPHALS(:), LAMULT(:), LASL(:), & - LASLPJ(:), USSXH(:), USSYH(:) -#endif - REAL, POINTER :: CG(:,:), WN(:,:) - REAL, POINTER :: IC3WN_R(:,:), IC3WN_I(:,:), IC3CG(:,:) -! - REAL, POINTER :: CA0(:), CAI(:), CD0(:), CDI(:), & - UA0(:), UAI(:), UD0(:), UDI(:), & - MA0(:), MAI(:), RA0(:), RAI(:), & - MD0(:), MDI(:), AS0(:), ASI(:), & - ATRNX(:,:), ATRNY(:,:) -! - REAL, POINTER :: DW(:), UA(:), UD(:), U10(:), U10D(:),& - AS(:), CX(:), CY(:), TAUA(:), TAUADIR(:) -! - REAL, POINTER :: HS(:), WLM(:), T02(:), T0M1(:), & - T01 (:), FP0(:), THM(:), THS(:), & - THP0(:), FP1(:), THP1(:), HSIG(:), & - STMAXE(:), STMAXD(:), HMAXE(:), & - HCMAXE(:), HMAXD(:), HCMAXD(:), & - QP(:), WBT(:), WNMEAN(:) -! - REAL, POINTER :: EF(:,:), TH1M(:,:), STH1M(:,:), & - TH2M(:,:), STH2M(:,:) -! - REAL, POINTER :: PHS(:,:), PTP(:,:), PLP(:,:), & - PDIR(:,:), PSI(:,:), PWS(:,:), & - PWST(:), PNR(:), PGW(:,:), PSW(:,:), & - PTHP0(:,:), PQP(:,:), PPE(:,:), & - PTM1(:,:), PT1(:,:), PT2(:,:),PEP(:,:) -! - REAL, POINTER :: CHARN(:), CGE(:), PHIAW(:), & - TAUWIX(:), TAUWIY(:), TAUWNX(:), & - TAUWNY(:), WHITECAP(:,:), TWS(:) -! - REAL, POINTER :: SXX(:), SYY(:), SXY(:), TAUOX(:), & - TAUOY(:), BHD(:), PHIOC(:), & - TUSX(:), TUSY(:), USSX(:), USSY(:), & - TAUOCX(:), TAUOCY(:), PRMS(:), & - TPMS(:), PHICE(:), TAUICE(:,:) - REAL, POINTER :: P2SMS(:,:), US3D(:,:), USSP(:,:) -! - REAL, POINTER :: ABA(:), ABD(:), UBA(:), UBD(:), & - BEDFORMS(:,:), PHIBBL(:), TAUBBL(:,:) -! - REAL, POINTER :: MSSX(:), MSSY(:), MSSD(:), & - MSCX(:), MSCY(:), MSCD(:) -! - REAL, POINTER :: DTDYN(:), FCUT(:), CFLXYMAX(:), & - CFLTHMAX(:), CFLKMAX(:) -! - REAL, POINTER :: USERO(:,:) -! -! REAL, POINTER :: TAUWX(:), TAUWY(:) -! - REAL, POINTER :: DDDX(:,:), DDDY(:,:), DCXDX(:,:), & - DCYDX(:,:), DCXDY(:,:), DCYDY(:,:) - REAL, POINTER :: DCDX(:,:,:), DCDY(:,:,:) + REAL, POINTER :: LANGMT(:), LAPROJ(:), ALPHAL(:), ALPHALS(:), LAMULT(:), LASL(:) + REAL, POINTER :: LASLPJ(:), USSXH(:), USSYH(:) +#endif + REAL, POINTER :: CG(:,:), WN(:,:) + REAL, POINTER :: IC3WN_R(:,:), IC3WN_I(:,:), IC3CG(:,:) + ! + REAL, POINTER :: CA0(:), CAI(:), CD0(:), CDI(:) + REAL, POINTER :: UA0(:), UAI(:), UD0(:), UDI(:) + REAL, POINTER :: MA0(:), MAI(:), RA0(:), RAI(:) + REAL, POINTER :: MD0(:), MDI(:), AS0(:), ASI(:) + REAL, POINTER :: ATRNX(:,:), ATRNY(:,:) + ! + REAL, POINTER :: DW(:), UA(:), UD(:), U10(:), U10D(:) + REAL, POINTER :: AS(:), CX(:), CY(:), TAUA(:), TAUADIR(:) + ! + REAL, POINTER :: HS(:), WLM(:), T02(:), T0M1(:) + REAL, POINTER :: T01 (:), FP0(:), THM(:), THS(:) + REAL, POINTER :: THP0(:), FP1(:), THP1(:), HSIG(:) + REAL, POINTER :: STMAXE(:), STMAXD(:), HMAXE(:) + REAL, POINTER :: HCMAXE(:), HMAXD(:), HCMAXD(:) + REAL, POINTER :: QP(:), WBT(:), WNMEAN(:) + ! + REAL, POINTER :: EF(:,:), TH1M(:,:), STH1M(:,:) + REAL, POINTER :: TH2M(:,:), STH2M(:,:) + ! + REAL, POINTER :: PHS(:,:), PTP(:,:), PLP(:,:), PDIR(:,:), PSI(:,:), PWS(:,:) + REAL, POINTER :: PWST(:), PNR(:), PGW(:,:), PSW(:,:), PTHP0(:,:), PQP(:,:), PPE(:,:) + REAL, POINTER :: PTM1(:,:), PT1(:,:), PT2(:,:),PEP(:,:) + ! + REAL, POINTER :: CHARN(:), CGE(:), PHIAW(:), TAUWIX(:), TAUWIY(:), TAUWNX(:) + REAL, POINTER :: TAUWNY(:), WHITECAP(:,:), TWS(:) + ! + REAL, POINTER :: SXX(:), SYY(:), SXY(:), TAUOX(:), TAUOY(:), BHD(:), PHIOC(:) + REAL, POINTER :: TUSX(:), TUSY(:), USSX(:), USSY(:), TAUOCX(:), TAUOCY(:), PRMS(:) + REAL, POINTER :: TPMS(:), PHICE(:), TAUICE(:,:) + REAL, POINTER :: P2SMS(:,:), US3D(:,:), USSP(:,:) + ! + REAL, POINTER :: ABA(:), ABD(:), UBA(:), UBD(:), BEDFORMS(:,:), PHIBBL(:), TAUBBL(:,:) + ! + REAL, POINTER :: MSSX(:), MSSY(:), MSSD(:), MSCX(:), MSCY(:), MSCD(:) + ! + REAL, POINTER :: DTDYN(:), FCUT(:), CFLXYMAX(:), CFLTHMAX(:), CFLKMAX(:) + ! + REAL, POINTER :: USERO(:,:) + ! + ! REAL, POINTER :: TAUWX(:), TAUWY(:) + ! + REAL, POINTER :: DDDX(:,:), DDDY(:,:), DCXDX(:,:), DCYDX(:,:), DCXDY(:,:), DCYDY(:,:) + REAL, POINTER :: DCDX(:,:,:), DCDY(:,:,:) #ifdef W3_SMC - REAL, POINTER :: DHDX(:), DHDY(:), DHLMT(:,:) + REAL, POINTER :: DHDX(:), DHDY(:), DHLMT(:,:) #endif -! + ! #ifdef W3_PR1 - INTEGER, POINTER :: IS0(:), IS2(:) - REAL, POINTER :: FACVX(:), FACVY(:) + INTEGER, POINTER :: IS0(:), IS2(:) + REAL, POINTER :: FACVX(:), FACVY(:) #endif -! + ! #ifdef W3_PR2 - INTEGER, POINTER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, & - NACT, NMXY - INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), & - MAPXY(:), MAPTH2(:), MAPWN2(:) + INTEGER, POINTER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, NACT, NMXY + INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), MAPXY(:), MAPTH2(:), MAPWN2(:) #endif -! + ! #ifdef W3_PR3 - INTEGER, POINTER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, & - NACT, NCENT - INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), & - MAPCXY(:), MAPTH2(:), MAPWN2(:) - LOGICAL, POINTER :: MAPTRN(:) + INTEGER, POINTER :: NMX0, NMX1, NMX2, NMY0, NMY1, NMY2, NACT, NCENT + INTEGER, POINTER :: MAPX2(:), MAPY2(:), MAPAXY(:), MAPCXY(:), MAPTH2(:), MAPWN2(:) + LOGICAL, POINTER :: MAPTRN(:) #endif -! - INTEGER, POINTER :: ITER(:,:) -! + ! + INTEGER, POINTER :: ITER(:,:) + ! #ifdef W3_NL1 - INTEGER, POINTER :: NFR, NFRHGH, NFRCHG, NSPECX, NSPECY - INTEGER, POINTER :: IP11(:), IP12(:), IP13(:), IP14(:), & - IM11(:), IM12(:), IM13(:), IM14(:), & - IP21(:), IP22(:), IP23(:), IP24(:), & - IM21(:), IM22(:), IM23(:), IM24(:), & - IC11(:), IC12(:), IC21(:), IC22(:), & - IC31(:), IC32(:), IC41(:), IC42(:), & - IC51(:), IC52(:), IC61(:), IC62(:), & - IC71(:), IC72(:), IC81(:), IC82(:) - REAL, POINTER :: DAL1, DAL2, DAL3, & - AWG1, AWG2, AWG3, AWG4, AWG5, AWG6, & - AWG7, AWG8, SWG1, SWG2, SWG3, SWG4, & - SWG5, SWG6, SWG7, SWG8 - REAL, POINTER :: AF11(:) - LOGICAL, POINTER :: NLINIT -#endif -! - INTEGER, POINTER :: IAPPRO(:) -#ifdef W3_MPI - INTEGER, POINTER :: MPI_COMM_WAVE, MPI_COMM_WCMP, & - WW3_FIELD_VEC, WW3_SPEC_VEC, & - NRQSG1, NRQSG2, IBFLOC, ISPLOC, & - NSPLOC - INTEGER, POINTER :: BSTAT(:), BISPL(:) - INTEGER, POINTER :: IRQSG1(:,:), IRQSG2(:,:) - REAL, POINTER :: GSTORE(:,:), SSTORE(:,:) -#endif - REAL, POINTER :: SPPNT(:,:,:) -! - INTEGER, POINTER :: ITIME, IPASS, IDLAST, NSEALM - REAL, POINTER :: ALPHA(:,:) - LOGICAL, POINTER :: AINIT, AINIT2, FL_ALL, FLCOLD, FLIWND + INTEGER, POINTER :: NFR, NFRHGH, NFRCHG, NSPECX, NSPECY + INTEGER, POINTER :: IP11(:), IP12(:), IP13(:), IP14(:) + INTEGER, POINTER :: IM11(:), IM12(:), IM13(:), IM14(:) + INTEGER, POINTER :: IP21(:), IP22(:), IP23(:), IP24(:) + INTEGER, POINTER :: IM21(:), IM22(:), IM23(:), IM24(:) + INTEGER, POINTER :: IC11(:), IC12(:), IC21(:), IC22(:) + INTEGER, POINTER :: IC31(:), IC32(:), IC41(:), IC42(:) + INTEGER, POINTER :: IC51(:), IC52(:), IC61(:), IC62(:) + INTEGER, POINTER :: IC71(:), IC72(:), IC81(:), IC82(:) + + REAL, POINTER :: DAL1, DAL2, DAL3 + REAL, POINTER :: AWG1, AWG2, AWG3, AWG4, AWG5, AWG6 + REAL, POINTER :: AWG7, AWG8, SWG1, SWG2, SWG3, SWG4 + REAL, POINTER :: SWG5, SWG6, SWG7, SWG8 + REAL, POINTER :: AF11(:) + LOGICAL, POINTER :: NLINIT +#endif + ! + INTEGER, POINTER :: IAPPRO(:) + INTEGER, POINTER :: MPI_COMM_WAVE, MPI_COMM_WCMP, WW3_FIELD_VEC, WW3_SPEC_VEC + INTEGER, POINTER :: NRQSG1, NRQSG2, IBFLOC, ISPLOC, NSPLOC + INTEGER, POINTER :: BSTAT(:), BISPL(:) + INTEGER, POINTER :: IRQSG1(:,:), IRQSG2(:,:) + REAL, POINTER :: GSTORE(:,:), SSTORE(:,:) + REAL, POINTER :: SPPNT(:,:,:) + ! + INTEGER, POINTER :: ITIME, IPASS, IDLAST, NSEALM + REAL, POINTER :: ALPHA(:,:) + LOGICAL, POINTER :: AINIT, AINIT2, FL_ALL, FLCOLD, FLIWND #ifdef W3_MEMCHECK - type(MallInfo_t) :: mallinfos + type(MallInfo_t) :: mallinfos #endif -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3NAUX ( NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 ! -!/ +-----------------------------------+ -!/ -!/ 14-Dec-2004 : Origination. ( version 3.06 ) -!/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ -! 1. Purpose : -! -! Set up the number of grids to be used. -! -! 2. Method : -! -! Use data stored in NGRIDS in W3GDATMD. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Any program that uses this grid structure. -! -! 6. Error messages : -! -! - Error checks on previous setting of variable NGRIDS. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NGRIDS - USE W3SERVMD, ONLY: EXTCDE - USE W3ODATMD, ONLY: IAPROC -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSE, NDST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3NAUX') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) NGRIDS - CALL EXTCDE (1) - END IF -! -! -------------------------------------------------------------------- / -! 2. Set variable and allocate arrays -! - ALLOCATE ( WADATS(NGRIDS), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - NADATA = NGRIDS -! -! -------------------------------------------------------------------- / -! 3. Initialize parameters -! - DO I=1, NGRIDS - WADATS(I)%ITIME = 0 - WADATS(I)%IPASS = 0 - WADATS(I)%IDLAST = 0 - WADATS(I)%NSEALM = 0 - WADATS(I)%FLCOLD = .FALSE. - WADATS(I)%FLIWND = .FALSE. - WADATS(I)%AINIT = .FALSE. - WADATS(I)%AINIT2 = .FALSE. - WADATS(I)%FL_ALL = .FALSE. + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3NAUX ( NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 ! + !/ +-----------------------------------+ + !/ + !/ 14-Dec-2004 : Origination. ( version 3.06 ) + !/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ + ! 1. Purpose : + ! + ! Set up the number of grids to be used. + ! + ! 2. Method : + ! + ! Use data stored in NGRIDS in W3GDATMD. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Any program that uses this grid structure. + ! + ! 6. Error messages : + ! + ! - Error checks on previous setting of variable NGRIDS. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NGRIDS + USE W3SERVMD, ONLY: EXTCDE + USE W3ODATMD, ONLY: IAPROC + USE W3SERVMD, ONLY: STRACE ! W3_S + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDSE, NDST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I + INTEGER, SAVE :: IENT = 0 ! W3_S + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'W3NAUX') + end if + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) NGRIDS + CALL EXTCDE (1) + END IF + ! + ! -------------------------------------------------------------------- / + ! 2. Set variable and allocate arrays + ! + ALLOCATE ( WADATS(NGRIDS), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + NADATA = NGRIDS + ! + ! -------------------------------------------------------------------- / + ! 3. Initialize parameters + ! + DO I=1, NGRIDS + WADATS(I)%ITIME = 0 + WADATS(I)%IPASS = 0 + WADATS(I)%IDLAST = 0 + WADATS(I)%NSEALM = 0 + WADATS(I)%FLCOLD = .FALSE. + WADATS(I)%FLIWND = .FALSE. + WADATS(I)%AINIT = .FALSE. + WADATS(I)%AINIT2 = .FALSE. + WADATS(I)%FL_ALL = .FALSE. #ifdef W3_NL1 - WADATS(I)%NLINIT = .FALSE. -#endif - END DO -! -#ifdef W3_T - WRITE (NDST,9000) NGRIDS -#endif -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3NAUX : NGRIDS NOT YET SET *** '/ & - ' NGRIDS = ',I10/ & - ' RUN W3NMOD FIRST'/) -! -#ifdef W3_T - 9000 FORMAT (' TEST W3NAUX : SETTING UP FOR ',I4,' GRIDS') -#endif -!/ -!/ End of W3NAUX ----------------------------------------------------- / -!/ - END SUBROUTINE W3NAUX -!/ ------------------------------------------------------------------- / - SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 ! -!/ +-----------------------------------+ -!/ -!/ 28-Dec-2004 : Origination. ( version 3.06 ) -!/ 20-Jul-2005 : Adding output fields. ( version 3.07 ) -!/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 28-Mar-2007 : Add partitioned data arrays. ( version 3.11 ) -!/ Add additional undefined arrays. -!/ 22-Feb-2008 ; Modify MAPTH2 declaration. ( version 3.14 ) -!/ 31-Oct-2010 : Added initialization of CX,CY,DW ( version 3.14 ) -!/ 25-Dec-2012 : Memory reduction for outputs. ( version 4.11 ) -!/ 28-Jul-2013 : Bug fix initialization P2SMS. ( version 4.11 ) -!/ 30-Apr-2014 : Memory reduction for group3. ( version 5.00 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 22-Mar-2021 : Adds TAUA, WNMEAN, TAUOC parameters ( version 7.13 ) -!/ -! 1. Purpose : -! -! Initialize an individual data grid at the proper dimensions. -! -! 2. Method : -! -! Allocate directly into the structure array. Note that -! this cannot be done through the pointer alias! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! D_ONLY L.O. I FLag for initializing data arrays only. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOGO Subr. W3IOGOMD Grid output IO routine. -! WW3_SHEL Prog. N/A Wave model driver. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - Check on input parameters. -! - Check on previous allocation. -! -! 7. Remarks : -! -! - W3SETA needs to be called after allocation to point to -! proper allocated arrays. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD, !/DIST -! Shared / distributed memory model -! -! !/PRn Propagation scheme selection. -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY : LPDLIB - USE W3GDATMD, ONLY: NGRIDS, IGRID, W3SETG, NK, NX, NY, NSEA, & - NSEAL, NSPEC, NTH, E3DF, P2MSF, US3DF, & - USSPF, GTYPE, UNGTYPE - USE W3ODATMD, ONLY: IAPROC, NAPROC, NTPROC, NAPFLD, & - NOSWLL, NOEXTR, UNDEF, FLOGRD, FLOGR2 - USE W3IDATMD, ONLY: FLCUR, FLWIND, FLTAUA, FLRHOA - USE W3SERVMD, ONLY: EXTCDE -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST - LOGICAL, INTENT(IN), OPTIONAL :: D_ONLY -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: JGRID, NXXX, NSEAL_tmp -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3DIMA') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! -#ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 0' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif + WADATS(I)%NLINIT = .FALSE. +#endif + END DO + ! + if (w3_t_flag) then + WRITE (NDST,9000) NGRIDS + end if + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3NAUX : NGRIDS NOT YET SET *** '/ & + ' NGRIDS = ',I10/ & + ' RUN W3NMOD FIRST'/) + ! +9000 FORMAT (' TEST W3NAUX : SETTING UP FOR ',I4,' GRIDS') ! W3_T + !/ + !/ End of W3NAUX ----------------------------------------------------- / + !/ + END SUBROUTINE W3NAUX + !/ ------------------------------------------------------------------- / + SUBROUTINE W3DIMA ( IMOD, NDSE, NDST, D_ONLY ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 ! + !/ +-----------------------------------+ + !/ + !/ 28-Dec-2004 : Origination. ( version 3.06 ) + !/ 20-Jul-2005 : Adding output fields. ( version 3.07 ) + !/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 28-Mar-2007 : Add partitioned data arrays. ( version 3.11 ) + !/ Add additional undefined arrays. + !/ 22-Feb-2008 ; Modify MAPTH2 declaration. ( version 3.14 ) + !/ 31-Oct-2010 : Added initialization of CX,CY,DW ( version 3.14 ) + !/ 25-Dec-2012 : Memory reduction for outputs. ( version 4.11 ) + !/ 28-Jul-2013 : Bug fix initialization P2SMS. ( version 4.11 ) + !/ 30-Apr-2014 : Memory reduction for group3. ( version 5.00 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 22-Mar-2021 : Adds TAUA, WNMEAN, TAUOC parameters ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Initialize an individual data grid at the proper dimensions. + ! + ! 2. Method : + ! + ! Allocate directly into the structure array. Note that + ! this cannot be done through the pointer alias! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! D_ONLY L.O. I FLag for initializing data arrays only. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOGO Subr. W3IOGOMD Grid output IO routine. + ! WW3_SHEL Prog. N/A Wave model driver. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - Check on input parameters. + ! - Check on previous allocation. + ! + ! 7. Remarks : + ! + ! - W3SETA needs to be called after allocation to point to + ! proper allocated arrays. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD, !/DIST + ! Shared / distributed memory model + ! + ! !/PRn Propagation scheme selection. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS , ONLY : LPDLIB + USE W3GDATMD , ONLY : NGRIDS, IGRID, W3SETG, NK, NX, NY, NSEA + USE W3GDATMD , ONLY : NSEAL, NSPEC, NTH, E3DF, P2MSF, US3DF + USE W3GDATMD , ONLY : USSPF, GTYPE, UNGTYPE + USE W3ODATMD , ONLY : IAPROC, NAPROC, NTPROC, NAPFLD + USE W3ODATMD , ONLY : NOSWLL, NOEXTR, UNDEF, FLOGRD, FLOGR2 + USE W3IDATMD , ONLY : FLCUR, FLWIND, FLTAUA, FLRHOA + USE W3SERVMD , ONLY : EXTCDE + USE W3SERVMD , ONLY : STRACE ! W3_S + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST + LOGICAL, INTENT(IN), OPTIONAL :: D_ONLY + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: JGRID, NXXX, NSEAL_tmp + INTEGER, SAVE :: IENT = 0 ! W3_S + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'W3DIMA') + end if + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + call print_memcheck(30000+IAPROC, 'memcheck_____:'//' W3DIMA 0') - IF ( PRESENT(D_ONLY) ) THEN - FL_ALL = .NOT. D_ONLY - ELSE - FL_ALL = .TRUE. - END IF -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.1 .OR. IMOD.GT.NADATA ) THEN - WRITE (NDSE,1002) IMOD, NADATA - CALL EXTCDE (2) - END IF -! - IF ( WADATS(IMOD)%AINIT ) THEN - WRITE (NDSE,1003) - CALL EXTCDE (3) - END IF -! -#ifdef W3_T - WRITE (NDST,9000) IMOD -#endif -! - JGRID = IGRID - IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) + IF ( PRESENT(D_ONLY) ) THEN + FL_ALL = .NOT. D_ONLY + ELSE + FL_ALL = .TRUE. + END IF + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.1 .OR. IMOD.GT.NADATA ) THEN + WRITE (NDSE,1002) IMOD, NADATA + CALL EXTCDE (2) + END IF + ! + IF ( WADATS(IMOD)%AINIT ) THEN + WRITE (NDSE,1003) + CALL EXTCDE (3) + END IF + ! + if (w3_t_flag) then + WRITE (NDST,9000) IMOD + end if + ! + JGRID = IGRID + IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) -#ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 1' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif -! -! -------------------------------------------------------------------- / -! 2. Allocate arrays -! Call W3SETA to assure of pointes FLCUR, FLWND, and FLTAUA -! - CALL W3SETA ( IMOD, NDSE, NDST ) + call print_memcheck(30000+IAPROC, 'memcheck_____:'//' W3DIMA 1') + ! + ! -------------------------------------------------------------------- / + ! 2. Allocate arrays + ! Call W3SETA to assure of pointes FLCUR, FLWND, and FLTAUA + ! + CALL W3SETA ( IMOD, NDSE, NDST ) -! -!AR: Check this below more ... - NXXX = NSEALM * NAPROC -! -! Output and input parameteres by output type -! -! 1) Forcing fields (these arrays are always needed) -! - ALLOCATE ( WADATS(IMOD)%DW(0:NSEA) , STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - WADATS(IMOD)%DW(:)=0. -! - ALLOCATE ( WADATS(IMOD)%CX(0:NSEA) , WADATS(IMOD)%CY(0:NSEA) , & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - WADATS(IMOD)%CX(:)=0. - WADATS(IMOD)%CY(:)=0. -! - ALLOCATE ( WADATS(IMOD)%UA(0:NSEA) , WADATS(IMOD)%UD(0:NSEA) , & - WADATS(IMOD)%U10(NSEA) , WADATS(IMOD)%U10D(NSEA) , & - WADATS(IMOD)%AS(0:NSEA) , STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - ALLOCATE ( WADATS(IMOD)%TAUA(0:NSEA) , & - WADATS(IMOD)%TAUADIR(0:NSEA), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - WADATS(IMOD)%TAUA(:) =0. - WADATS(IMOD)%TAUADIR(:)=0. + ! + !AR: Check this below more ... + NXXX = NSEALM * NAPROC + ! + ! Output and input parameteres by output type + ! + ! 1) Forcing fields (these arrays are always needed) + ! + ALLOCATE ( WADATS(IMOD)%DW(0:NSEA) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + WADATS(IMOD)%DW(:)=0. + ! + ALLOCATE ( WADATS(IMOD)%CX(0:NSEA) , WADATS(IMOD)%CY(0:NSEA) , & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + WADATS(IMOD)%CX(:)=0. + WADATS(IMOD)%CY(:)=0. + ! + ALLOCATE ( WADATS(IMOD)%UA(0:NSEA) , WADATS(IMOD)%UD(0:NSEA) , & + WADATS(IMOD)%U10(NSEA) , WADATS(IMOD)%U10D(NSEA) , & + WADATS(IMOD)%AS(0:NSEA) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + ALLOCATE ( WADATS(IMOD)%TAUA(0:NSEA) , & + WADATS(IMOD)%TAUADIR(0:NSEA), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + WADATS(IMOD)%TAUA(:) =0. + WADATS(IMOD)%TAUADIR(:)=0. -#ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 2' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif -! -! Water level WLV stored in W3WDATMD -! Ice concentration ICE stored in W3WDATMD -! Ice floe sizes ICEF and ICEDMAX stored in W3WDATMD -! Iceberg damping BERG stored in W3WDATMD -! -! 2) Standard mean wave parameters -! Here, all short arrays are always allocated to reduce logical -! checks in all computations. The coresponding full size arrays -! are allocated in W3MPIO only as needed to keep the memory -! footprint down. -! - IF (NSEALM .eq. 0) THEN - NSEALM=NSEA - END IF - ALLOCATE ( WADATS(IMOD)%HS (NSEALM), WADATS(IMOD)%WLM (NSEALM), & - WADATS(IMOD)%T02 (NSEALM), WADATS(IMOD)%T0M1(NSEALM), & - WADATS(IMOD)%T01 (NSEALM), WADATS(IMOD)%FP0 (NSEALM), & - WADATS(IMOD)%THM (NSEALM), WADATS(IMOD)%THS (NSEALM), & - WADATS(IMOD)%THP0 (NSEALM), WADATS(IMOD)%FP1 (NSEALM), & - WADATS(IMOD)%THP1 (NSEALM), WADATS(IMOD)%HSIG(NSEALM), & - WADATS(IMOD)%STMAXE (NSEALM), & - WADATS(IMOD)%STMAXD(NSEALM), & - WADATS(IMOD)%HMAXE(NSEALM), WADATS(IMOD)%HMAXD(NSEALM),& - WADATS(IMOD)%HCMAXE(NSEALM), & - WADATS(IMOD)%HCMAXD(NSEALM), WADATS(IMOD)%QP(NSEALM), & - WADATS(IMOD)%WBT(NSEALM), & - WADATS(IMOD)%WNMEAN(NSEALM), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + call print_memcheck(30000+IAPROC, 'memcheck_____:'//' W3DIMA 2') + ! + ! Water level WLV stored in W3WDATMD + ! Ice concentration ICE stored in W3WDATMD + ! Ice floe sizes ICEF and ICEDMAX stored in W3WDATMD + ! Iceberg damping BERG stored in W3WDATMD + ! + ! 2) Standard mean wave parameters + ! Here, all short arrays are always allocated to reduce logical + ! checks in all computations. The coresponding full size arrays + ! are allocated in W3MPIO only as needed to keep the memory + ! footprint down. + ! + IF (NSEALM .eq. 0) THEN + NSEALM=NSEA + END IF + ALLOCATE ( WADATS(IMOD)%HS (NSEALM), WADATS(IMOD)%WLM (NSEALM), & + WADATS(IMOD)%T02 (NSEALM), WADATS(IMOD)%T0M1(NSEALM), & + WADATS(IMOD)%T01 (NSEALM), WADATS(IMOD)%FP0 (NSEALM), & + WADATS(IMOD)%THM (NSEALM), WADATS(IMOD)%THS (NSEALM), & + WADATS(IMOD)%THP0 (NSEALM), WADATS(IMOD)%FP1 (NSEALM), & + WADATS(IMOD)%THP1 (NSEALM), WADATS(IMOD)%HSIG(NSEALM), & + WADATS(IMOD)%STMAXE (NSEALM), & + WADATS(IMOD)%STMAXD(NSEALM), & + WADATS(IMOD)%HMAXE(NSEALM), WADATS(IMOD)%HMAXD(NSEALM),& + WADATS(IMOD)%HCMAXE(NSEALM), & + WADATS(IMOD)%HCMAXD(NSEALM), WADATS(IMOD)%QP(NSEALM), & + WADATS(IMOD)%WBT(NSEALM), & + WADATS(IMOD)%WNMEAN(NSEALM), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #ifdef W3_CESMCOUPLED - ALLOCATE ( WADATS(IMOD)%USSXH(NSEALM) , & - WADATS(IMOD)%USSYH(NSEALM) , & - WADATS(IMOD)%LANGMT(NSEALM) , & - WADATS(IMOD)%LAPROJ(NSEALM) , & - WADATS(IMOD)%LASL(NSEALM) , & - WADATS(IMOD)%LASLPJ(NSEALM) , & - WADATS(IMOD)%ALPHAL(NSEALM) , & - WADATS(IMOD)%ALPHALS(NSEALM) , & - WADATS(IMOD)%LAMULT(NSEALM) , & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -#endif -! - WADATS(IMOD)%HS = UNDEF - WADATS(IMOD)%WLM = UNDEF - WADATS(IMOD)%T02 = UNDEF - WADATS(IMOD)%T0M1 = UNDEF - WADATS(IMOD)%T01 = UNDEF - WADATS(IMOD)%FP0 = UNDEF - WADATS(IMOD)%THM = UNDEF - WADATS(IMOD)%THS = UNDEF - WADATS(IMOD)%THP0 = UNDEF - WADATS(IMOD)%FP1 = UNDEF - WADATS(IMOD)%THP1 = UNDEF - WADATS(IMOD)%HSIG = UNDEF - WADATS(IMOD)%STMAXE = UNDEF - WADATS(IMOD)%STMAXD = UNDEF - WADATS(IMOD)%HMAXE = UNDEF - WADATS(IMOD)%HMAXD = UNDEF - WADATS(IMOD)%HCMAXE = UNDEF - WADATS(IMOD)%HCMAXD = UNDEF - WADATS(IMOD)%QP = UNDEF - WADATS(IMOD)%WBT = UNDEF - WADATS(IMOD)%WNMEAN = UNDEF + ALLOCATE ( WADATS(IMOD)%USSXH(NSEALM) , & + WADATS(IMOD)%USSYH(NSEALM) , & + WADATS(IMOD)%LANGMT(NSEALM) , & + WADATS(IMOD)%LAPROJ(NSEALM) , & + WADATS(IMOD)%LASL(NSEALM) , & + WADATS(IMOD)%LASLPJ(NSEALM) , & + WADATS(IMOD)%ALPHAL(NSEALM) , & + WADATS(IMOD)%ALPHALS(NSEALM) , & + WADATS(IMOD)%LAMULT(NSEALM) , & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif + ! + WADATS(IMOD)%HS = UNDEF + WADATS(IMOD)%WLM = UNDEF + WADATS(IMOD)%T02 = UNDEF + WADATS(IMOD)%T0M1 = UNDEF + WADATS(IMOD)%T01 = UNDEF + WADATS(IMOD)%FP0 = UNDEF + WADATS(IMOD)%THM = UNDEF + WADATS(IMOD)%THS = UNDEF + WADATS(IMOD)%THP0 = UNDEF + WADATS(IMOD)%FP1 = UNDEF + WADATS(IMOD)%THP1 = UNDEF + WADATS(IMOD)%HSIG = UNDEF + WADATS(IMOD)%STMAXE = UNDEF + WADATS(IMOD)%STMAXD = UNDEF + WADATS(IMOD)%HMAXE = UNDEF + WADATS(IMOD)%HMAXD = UNDEF + WADATS(IMOD)%HCMAXE = UNDEF + WADATS(IMOD)%HCMAXD = UNDEF + WADATS(IMOD)%QP = UNDEF + WADATS(IMOD)%WBT = UNDEF + WADATS(IMOD)%WNMEAN = UNDEF -#ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 3' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif -! -! 3) Frequency-dependent standard parameters -! -! For the 3D arrays: the allocation is performed only if these arrays are allowed -! by specific variables defined through the mod_def file -! and read by w3iogr, which is called before W3DIMA. -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before the EF allocation' - WRITE(740+IAPROC,*) 'E3DF=', E3DF(1,1) -#endif - IF ( E3DF(1,1).GT.0 ) THEN -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Now the allocation' -#endif - ALLOCATE(WADATS(IMOD)%EF(NSEALM,E3DF(2,1):E3DF(3,1)), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -#ifdef W3_DEBUGINIT - FLUSH(740+IAPROC) -#endif - IF ( E3DF(1,2).GT.0 ) THEN - ALLOCATE(WADATS(IMOD)%TH1M(NSEALM,E3DF(2,2):E3DF(3,2)), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF - IF ( E3DF(1,3).GT.0 ) THEN - ALLOCATE(WADATS(IMOD)%STH1M(NSEALM,E3DF(2,3):E3DF(3,3)), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF - IF ( E3DF(1,4).GT.0 ) THEN - ALLOCATE(WADATS(IMOD)%TH2M(NSEALM,E3DF(2,4):E3DF(3,4)), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF - IF ( E3DF(1,5).GT.0 ) THEN - ALLOCATE(WADATS(IMOD)%STH2M(NSEALM,E3DF(2,5):E3DF(3,5)), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( E3DF(1,1).GT.0 ) WADATS(IMOD)%EF = UNDEF - IF ( E3DF(1,2).GT.0 ) WADATS(IMOD)%TH1M = UNDEF - IF ( E3DF(1,3).GT.0 ) WADATS(IMOD)%STH1M = UNDEF - IF ( E3DF(1,4).GT.0 ) WADATS(IMOD)%TH2M = UNDEF - IF ( E3DF(1,5).GT.0 ) WADATS(IMOD)%STH2M = UNDEF + call print_memcheck(30000+IAPROC, 'memcheck_____:'//' W3DIMA 3') + ! + ! 3) Frequency-dependent standard parameters + ! + ! For the 3D arrays: the allocation is performed only if these arrays are allowed + ! by specific variables defined through the mod_def file + ! and read by w3iogr, which is called before W3DIMA. + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'Before the EF allocation' + WRITE(740+IAPROC,*) 'E3DF=', E3DF(1,1) + end if + IF ( E3DF(1,1).GT.0 ) THEN + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'Now the allocation' + end if + ALLOCATE(WADATS(IMOD)%EF(NSEALM,E3DF(2,1):E3DF(3,1)), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF -#ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 4' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif + IF ( E3DF(1,2).GT.0 ) THEN + ALLOCATE(WADATS(IMOD)%TH1M(NSEALM,E3DF(2,2):E3DF(3,2)), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + IF ( E3DF(1,3).GT.0 ) THEN + ALLOCATE(WADATS(IMOD)%STH1M(NSEALM,E3DF(2,3):E3DF(3,3)), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + IF ( E3DF(1,4).GT.0 ) THEN + ALLOCATE(WADATS(IMOD)%TH2M(NSEALM,E3DF(2,4):E3DF(3,4)), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + IF ( E3DF(1,5).GT.0 ) THEN + ALLOCATE(WADATS(IMOD)%STH2M(NSEALM,E3DF(2,5):E3DF(3,5)), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( E3DF(1,1).GT.0 ) WADATS(IMOD)%EF = UNDEF + IF ( E3DF(1,2).GT.0 ) WADATS(IMOD)%TH1M = UNDEF + IF ( E3DF(1,3).GT.0 ) WADATS(IMOD)%STH1M = UNDEF + IF ( E3DF(1,4).GT.0 ) WADATS(IMOD)%TH2M = UNDEF + IF ( E3DF(1,5).GT.0 ) WADATS(IMOD)%STH2M = UNDEF -! -! 4) Spectral Partitions parameters -! - ALLOCATE ( WADATS(IMOD)%PHS(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PTP(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PLP(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PDIR(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PSI(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PWS(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PWST(NSEALM), & - WADATS(IMOD)%PNR(NSEALM), & - WADATS(IMOD)%PTHP0(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PQP(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PPE(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PGW(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PSW(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PTM1(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PT1(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PT2(NSEALM,0:NOSWLL), & - WADATS(IMOD)%PEP(NSEALM,0:NOSWLL), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - WADATS(IMOD)%PHS = UNDEF - WADATS(IMOD)%PTP = UNDEF - WADATS(IMOD)%PLP = UNDEF - WADATS(IMOD)%PDIR = UNDEF - WADATS(IMOD)%PSI = UNDEF - WADATS(IMOD)%PWS = UNDEF - WADATS(IMOD)%PWST = UNDEF - WADATS(IMOD)%PNR = UNDEF - WADATS(IMOD)%PTHP0 = UNDEF - WADATS(IMOD)%PQP = UNDEF - WADATS(IMOD)%PPE = UNDEF - WADATS(IMOD)%PGW = UNDEF - WADATS(IMOD)%PSW = UNDEF - WADATS(IMOD)%PTM1 = UNDEF - WADATS(IMOD)%PT1 = UNDEF - WADATS(IMOD)%PT2 = UNDEF - WADATS(IMOD)%PEP = UNDEF -! -! 5) Atmosphere-waves layer -! -! Friction velocity UST and USTDIR in W3WDATMD -! - ALLOCATE ( WADATS(IMOD)%CHARN (NSEALM), & - WADATS(IMOD)%TWS (NSEALM), & - WADATS(IMOD)%CGE (NSEALM), & - WADATS(IMOD)%PHIAW (NSEALM), & - WADATS(IMOD)%TAUWIX (NSEALM), & - WADATS(IMOD)%TAUWIY (NSEALM), & - WADATS(IMOD)%TAUWNX (NSEALM), & - WADATS(IMOD)%TAUWNY (NSEALM), & - WADATS(IMOD)%WHITECAP(NSEALM,4), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - WADATS(IMOD)%CHARN = UNDEF - WADATS(IMOD)%TWS = UNDEF - WADATS(IMOD)%CGE = UNDEF - WADATS(IMOD)%PHIAW = UNDEF - WADATS(IMOD)%TAUWIX = UNDEF - WADATS(IMOD)%TAUWIY = UNDEF - WADATS(IMOD)%TAUWNX = UNDEF - WADATS(IMOD)%TAUWNY = UNDEF - WADATS(IMOD)%WHITECAP = UNDEF + call print_memcheck(30000+IAPROC, 'memcheck_____:'//' W3DIMA 4') -#ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 5' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif + ! + ! 4) Spectral Partitions parameters + ! + ALLOCATE ( WADATS(IMOD)%PHS(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PTP(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PLP(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PDIR(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PSI(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PWS(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PWST(NSEALM), & + WADATS(IMOD)%PNR(NSEALM), & + WADATS(IMOD)%PTHP0(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PQP(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PPE(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PGW(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PSW(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PTM1(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PT1(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PT2(NSEALM,0:NOSWLL), & + WADATS(IMOD)%PEP(NSEALM,0:NOSWLL), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + WADATS(IMOD)%PHS = UNDEF + WADATS(IMOD)%PTP = UNDEF + WADATS(IMOD)%PLP = UNDEF + WADATS(IMOD)%PDIR = UNDEF + WADATS(IMOD)%PSI = UNDEF + WADATS(IMOD)%PWS = UNDEF + WADATS(IMOD)%PWST = UNDEF + WADATS(IMOD)%PNR = UNDEF + WADATS(IMOD)%PTHP0 = UNDEF + WADATS(IMOD)%PQP = UNDEF + WADATS(IMOD)%PPE = UNDEF + WADATS(IMOD)%PGW = UNDEF + WADATS(IMOD)%PSW = UNDEF + WADATS(IMOD)%PTM1 = UNDEF + WADATS(IMOD)%PT1 = UNDEF + WADATS(IMOD)%PT2 = UNDEF + WADATS(IMOD)%PEP = UNDEF + ! + ! 5) Atmosphere-waves layer + ! + ! Friction velocity UST and USTDIR in W3WDATMD + ! + ALLOCATE ( WADATS(IMOD)%CHARN (NSEALM), & + WADATS(IMOD)%TWS (NSEALM), & + WADATS(IMOD)%CGE (NSEALM), & + WADATS(IMOD)%PHIAW (NSEALM), & + WADATS(IMOD)%TAUWIX (NSEALM), & + WADATS(IMOD)%TAUWIY (NSEALM), & + WADATS(IMOD)%TAUWNX (NSEALM), & + WADATS(IMOD)%TAUWNY (NSEALM), & + WADATS(IMOD)%WHITECAP(NSEALM,4), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + WADATS(IMOD)%CHARN = UNDEF + WADATS(IMOD)%TWS = UNDEF + WADATS(IMOD)%CGE = UNDEF + WADATS(IMOD)%PHIAW = UNDEF + WADATS(IMOD)%TAUWIX = UNDEF + WADATS(IMOD)%TAUWIY = UNDEF + WADATS(IMOD)%TAUWNX = UNDEF + WADATS(IMOD)%TAUWNY = UNDEF + WADATS(IMOD)%WHITECAP = UNDEF -! -! 6) Wave-ocean layer -! - ALLOCATE ( WADATS(IMOD)%SXX (NSEALM) , & - WADATS(IMOD)%SYY (NSEALM) , & - WADATS(IMOD)%SXY (NSEALM) , & - WADATS(IMOD)%TAUOX (NSEALM) , & - WADATS(IMOD)%TAUOY (NSEALM) , & - WADATS(IMOD)%BHD (NSEALM) , & - WADATS(IMOD)%PHIOC (NSEALM) , & - WADATS(IMOD)%TUSX (NSEALM) , & - WADATS(IMOD)%TUSY (NSEALM) , & - WADATS(IMOD)%USSX (NSEALM) , & - WADATS(IMOD)%USSY (NSEALM) , & - WADATS(IMOD)%TAUOCX(NSEALM) , & - WADATS(IMOD)%TAUOCY(NSEALM) , & - WADATS(IMOD)%PRMS (NSEALM) , & - WADATS(IMOD)%TPMS (NSEALM) , & - WADATS(IMOD)%PHICE (NSEALM) , & - WADATS(IMOD)%TAUICE(NSEALM,2), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! -! For the 3D arrays: the allocation is performed only if these arrays are allowed -! by specific variables defined through the mod_def file -! and read by w3iogr, which is called before W3DIMA. - IF ( P2MSF(1).GT.0 ) THEN - ALLOCATE(WADATS(IMOD)%P2SMS(NSEALM,P2MSF(2):P2MSF(3)), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF - IF ( US3DF(1).GT.0 ) THEN ! maybe use US3DF(2:3) - ALLOCATE(WADATS(IMOD)%US3D(NSEALM,NK*2), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF - IF ( USSPF(1).GT.0 ) THEN - ALLOCATE(WADATS(IMOD)%USSP(NSEALM,NK*2), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - WADATS(IMOD)%SXX = UNDEF - WADATS(IMOD)%SYY = UNDEF - WADATS(IMOD)%SXY = UNDEF - WADATS(IMOD)%TAUOX = UNDEF - WADATS(IMOD)%TAUOY = UNDEF - WADATS(IMOD)%BHD = UNDEF - WADATS(IMOD)%PHIOC = UNDEF - WADATS(IMOD)%TUSX = UNDEF - WADATS(IMOD)%TUSY = UNDEF - WADATS(IMOD)%USSX = UNDEF - WADATS(IMOD)%USSY = UNDEF - WADATS(IMOD)%TAUOCX = UNDEF - WADATS(IMOD)%TAUOCY = UNDEF - WADATS(IMOD)%PRMS = UNDEF - WADATS(IMOD)%TPMS = UNDEF - WADATS(IMOD)%PHICE = UNDEF - WADATS(IMOD)%TAUICE = UNDEF + call print_memcheck(30000+IAPROC, 'memcheck_____:'//' W3DIMA 5') + + ! + ! 6) Wave-ocean layer + ! + ALLOCATE ( WADATS(IMOD)%SXX (NSEALM) , & + WADATS(IMOD)%SYY (NSEALM) , & + WADATS(IMOD)%SXY (NSEALM) , & + WADATS(IMOD)%TAUOX (NSEALM) , & + WADATS(IMOD)%TAUOY (NSEALM) , & + WADATS(IMOD)%BHD (NSEALM) , & + WADATS(IMOD)%PHIOC (NSEALM) , & + WADATS(IMOD)%TUSX (NSEALM) , & + WADATS(IMOD)%TUSY (NSEALM) , & + WADATS(IMOD)%USSX (NSEALM) , & + WADATS(IMOD)%USSY (NSEALM) , & + WADATS(IMOD)%TAUOCX(NSEALM) , & + WADATS(IMOD)%TAUOCY(NSEALM) , & + WADATS(IMOD)%PRMS (NSEALM) , & + WADATS(IMOD)%TPMS (NSEALM) , & + WADATS(IMOD)%PHICE (NSEALM) , & + WADATS(IMOD)%TAUICE(NSEALM,2), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + ! For the 3D arrays: the allocation is performed only if these arrays are allowed + ! by specific variables defined through the mod_def file + ! and read by w3iogr, which is called before W3DIMA. + IF ( P2MSF(1).GT.0 ) THEN + ALLOCATE(WADATS(IMOD)%P2SMS(NSEALM,P2MSF(2):P2MSF(3)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + IF ( US3DF(1).GT.0 ) THEN ! maybe use US3DF(2:3) + ALLOCATE(WADATS(IMOD)%US3D(NSEALM,NK*2), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + IF ( USSPF(1).GT.0 ) THEN + ALLOCATE(WADATS(IMOD)%USSP(NSEALM,NK*2), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + WADATS(IMOD)%SXX = UNDEF + WADATS(IMOD)%SYY = UNDEF + WADATS(IMOD)%SXY = UNDEF + WADATS(IMOD)%TAUOX = UNDEF + WADATS(IMOD)%TAUOY = UNDEF + WADATS(IMOD)%BHD = UNDEF + WADATS(IMOD)%PHIOC = UNDEF + WADATS(IMOD)%TUSX = UNDEF + WADATS(IMOD)%TUSY = UNDEF + WADATS(IMOD)%USSX = UNDEF + WADATS(IMOD)%USSY = UNDEF + WADATS(IMOD)%TAUOCX = UNDEF + WADATS(IMOD)%TAUOCY = UNDEF + WADATS(IMOD)%PRMS = UNDEF + WADATS(IMOD)%TPMS = UNDEF + WADATS(IMOD)%PHICE = UNDEF + WADATS(IMOD)%TAUICE = UNDEF #ifdef W3_CESMCOUPLED - WADATS(IMOD)%LANGMT = UNDEF + WADATS(IMOD)%LANGMT = UNDEF #endif - IF ( P2MSF(1).GT.0 ) WADATS(IMOD)%P2SMS = UNDEF - IF ( US3DF(1).GT.0 ) WADATS(IMOD)%US3D = UNDEF - IF ( USSPF(1).GT.0 ) WADATS(IMOD)%USSP = UNDEF + IF ( P2MSF(1).GT.0 ) WADATS(IMOD)%P2SMS = UNDEF + IF ( US3DF(1).GT.0 ) WADATS(IMOD)%US3D = UNDEF + IF ( USSPF(1).GT.0 ) WADATS(IMOD)%USSP = UNDEF -#ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 6' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif -! -! 7) Wave-bottom layer -! - ALLOCATE ( WADATS(IMOD)%ABA(NSEALM) , WADATS(IMOD)%ABD(NSEALM) , & - WADATS(IMOD)%UBA(NSEALM) , WADATS(IMOD)%UBD(NSEALM) , & - WADATS(IMOD)%BEDFORMS(NSEALM,3), & - WADATS(IMOD)%PHIBBL (NSEALM) , & - WADATS(IMOD)%TAUBBL (NSEALM,2), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - WADATS(IMOD)%ABA = UNDEF - WADATS(IMOD)%ABD = UNDEF - WADATS(IMOD)%UBA = UNDEF - WADATS(IMOD)%UBD = UNDEF - WADATS(IMOD)%BEDFORMS = UNDEF - WADATS(IMOD)%PHIBBL = UNDEF - WADATS(IMOD)%TAUBBL = UNDEF + call print_memcheck(30000+IAPROC, 'memcheck_____:'//' W3DIMA 6') + ! + ! 7) Wave-bottom layer + ! + ALLOCATE ( WADATS(IMOD)%ABA(NSEALM) , WADATS(IMOD)%ABD(NSEALM) , & + WADATS(IMOD)%UBA(NSEALM) , WADATS(IMOD)%UBD(NSEALM) , & + WADATS(IMOD)%BEDFORMS(NSEALM,3), & + WADATS(IMOD)%PHIBBL (NSEALM) , & + WADATS(IMOD)%TAUBBL (NSEALM,2), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + WADATS(IMOD)%ABA = UNDEF + WADATS(IMOD)%ABD = UNDEF + WADATS(IMOD)%UBA = UNDEF + WADATS(IMOD)%UBD = UNDEF + WADATS(IMOD)%BEDFORMS = UNDEF + WADATS(IMOD)%PHIBBL = UNDEF + WADATS(IMOD)%TAUBBL = UNDEF -#ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 7' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif -! -! 8) Spectrum parameters -! - ALLOCATE ( WADATS(IMOD)%MSSX(NSEALM), WADATS(IMOD)%MSSY(NSEALM), & - WADATS(IMOD)%MSCX(NSEALM), WADATS(IMOD)%MSCY(NSEALM), & - WADATS(IMOD)%MSSD(NSEALM), WADATS(IMOD)%MSCD(NSEALM), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - WADATS(IMOD)%MSSX = UNDEF - WADATS(IMOD)%MSSY = UNDEF - WADATS(IMOD)%MSSD = UNDEF - WADATS(IMOD)%MSCX = UNDEF - WADATS(IMOD)%MSCY = UNDEF - WADATS(IMOD)%MSCD = UNDEF -#ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 8' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif -! -! 9) Numerical diagnostics -! -! - ALLOCATE ( WADATS(IMOD)%DTDYN (NSEALM) , & - WADATS(IMOD)%FCUT (NSEALM) , & - WADATS(IMOD)%CFLXYMAX(NSEALM) , & - WADATS(IMOD)%CFLTHMAX(NSEALM) , & - WADATS(IMOD)%CFLKMAX (NSEALM) , STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - WADATS(IMOD)%DTDYN = UNDEF - WADATS(IMOD)%FCUT = UNDEF - WADATS(IMOD)%CFLXYMAX = UNDEF - WADATS(IMOD)%CFLTHMAX = UNDEF - WADATS(IMOD)%CFLKMAX = UNDEF + call print_memcheck(30000+IAPROC, 'memcheck_____:'//' W3DIMA 7') + ! + ! 8) Spectrum parameters + ! + ALLOCATE ( WADATS(IMOD)%MSSX(NSEALM), WADATS(IMOD)%MSSY(NSEALM), & + WADATS(IMOD)%MSCX(NSEALM), WADATS(IMOD)%MSCY(NSEALM), & + WADATS(IMOD)%MSSD(NSEALM), WADATS(IMOD)%MSCD(NSEALM), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + WADATS(IMOD)%MSSX = UNDEF + WADATS(IMOD)%MSSY = UNDEF + WADATS(IMOD)%MSSD = UNDEF + WADATS(IMOD)%MSCX = UNDEF + WADATS(IMOD)%MSCY = UNDEF + WADATS(IMOD)%MSCD = UNDEF -#ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 9' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif -! -! 10) User defined -! - ALLOCATE ( WADATS(IMOD)%USERO(NSEALM,NOEXTR), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - WADATS(IMOD)%USERO = UNDEF -! - ALLOCATE ( WADATS(IMOD)%WN(0:NK+1,0:NSEA), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + call print_memcheck(30000+IAPROC, 'memcheck_____:'//' W3DIMA 7') + ! + ! 9) Numerical diagnostics + ! + ! + ALLOCATE ( WADATS(IMOD)%DTDYN (NSEALM) , & + WADATS(IMOD)%FCUT (NSEALM) , & + WADATS(IMOD)%CFLXYMAX(NSEALM) , & + WADATS(IMOD)%CFLTHMAX(NSEALM) , & + WADATS(IMOD)%CFLKMAX (NSEALM) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + WADATS(IMOD)%DTDYN = UNDEF + WADATS(IMOD)%FCUT = UNDEF + WADATS(IMOD)%CFLXYMAX = UNDEF + WADATS(IMOD)%CFLTHMAX = UNDEF + WADATS(IMOD)%CFLKMAX = UNDEF + + call print_memcheck(30000+IAPROC, 'memcheck_____:'//' W3DIMA 9') + ! + ! 10) User defined + ! + ALLOCATE ( WADATS(IMOD)%USERO(NSEALM,NOEXTR), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + WADATS(IMOD)%USERO = UNDEF + ! + ALLOCATE ( WADATS(IMOD)%WN(0:NK+1,0:NSEA), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #ifdef W3_IC3 - ALLOCATE (WADATS(IMOD)%IC3WN_R(0:NK+1,0:300), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE (WADATS(IMOD)%IC3WN_I(0:NK+1,0:300), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE (WADATS(IMOD)%IC3WN_R(0:NK+1,0:300), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE (WADATS(IMOD)%IC3WN_I(0:NK+1,0:300), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif -#ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 10' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif -! - IF ( FL_ALL ) THEN -! - ALLOCATE ( WADATS(IMOD)%CG(0:NK+1,0:NSEA), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + call print_memcheck(30000+IAPROC, 'memcheck_____:'//' W3DIMA 10') + ! + IF ( FL_ALL ) THEN + ! + ALLOCATE ( WADATS(IMOD)%CG(0:NK+1,0:NSEA), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #ifdef W3_IC3 - ALLOCATE (WADATS(IMOD)%IC3CG(0:NK+1,0:300), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE (WADATS(IMOD)%IC3CG(0:NK+1,0:300), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif -! - IF ( FLCUR ) THEN - ALLOCATE ( WADATS(IMOD)%CA0(NSEA) , & - WADATS(IMOD)%CAI(NSEA) , & - WADATS(IMOD)%CD0(NSEA) , & - WADATS(IMOD)%CDI(NSEA) , & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( FLWIND ) THEN - ALLOCATE ( WADATS(IMOD)%UA0(NSEA) , & - WADATS(IMOD)%UAI(NSEA) , & - WADATS(IMOD)%UD0(NSEA) , & - WADATS(IMOD)%UDI(NSEA) , & - WADATS(IMOD)%AS0(NSEA) , & - WADATS(IMOD)%ASI(NSEA) , & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( FLTAUA ) THEN - ALLOCATE ( WADATS(IMOD)%MA0(NSEA) , & - WADATS(IMOD)%MAI(NSEA) , & - WADATS(IMOD)%MD0(NSEA) , & - WADATS(IMOD)%MDI(NSEA) , & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( FLRHOA ) THEN - ALLOCATE ( WADATS(IMOD)%RA0(NSEA) , & - WADATS(IMOD)%RAI(NSEA) , & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - ALLOCATE ( WADATS(IMOD)%ATRNX(NY*NX,-1:1) , & - WADATS(IMOD)%ATRNY(NY*NX,-1:1) , STAT=ISTAT ) + ! + IF ( FLCUR ) THEN + ALLOCATE ( WADATS(IMOD)%CA0(NSEA) , & + WADATS(IMOD)%CAI(NSEA) , & + WADATS(IMOD)%CD0(NSEA) , & + WADATS(IMOD)%CDI(NSEA) , & + STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) -! - IF (.NOT. LPDLIB) THEN - ALLOCATE ( WADATS(IMOD)%DDDX(NY,NX) , & - WADATS(IMOD)%DDDY(NY,NX) , & - WADATS(IMOD)%DCDX(0:NK+1,NY,NX) , & - WADATS(IMOD)%DCDY(0:NK+1,NY,NX) , & - WADATS(IMOD)%DCXDX(NY,NX) , & - WADATS(IMOD)%DCYDX(NY,NX) , & - WADATS(IMOD)%DCXDY(NY,NX) , & - WADATS(IMOD)%DCYDY(NY,NX) , STAT=ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%DDDX(1,NSEAL) , & - WADATS(IMOD)%DDDY(1,NSEAL) , & - WADATS(IMOD)%DCDX(0:NK+1,1,NSEAL) , & - WADATS(IMOD)%DCDY(0:NK+1,1,NSEAL) , & - WADATS(IMOD)%DCXDX(1,NSEAL) , & - WADATS(IMOD)%DCYDX(1,NSEAL) , & - WADATS(IMOD)%DCXDY(1,NSEAL) , & - WADATS(IMOD)%DCYDY(1,NSEAL) , & - STAT=ISTAT ) - ENDIF + END IF + ! + IF ( FLWIND ) THEN + ALLOCATE ( WADATS(IMOD)%UA0(NSEA) , & + WADATS(IMOD)%UAI(NSEA) , & + WADATS(IMOD)%UD0(NSEA) , & + WADATS(IMOD)%UDI(NSEA) , & + WADATS(IMOD)%AS0(NSEA) , & + WADATS(IMOD)%ASI(NSEA) , & + STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) - WADATS(IMOD)%DDDX = 0. - WADATS(IMOD)%DDDY = 0. - WADATS(IMOD)%DCDX = 0. - WADATS(IMOD)%DCDY = 0. - WADATS(IMOD)%DCXDX = 0. - WADATS(IMOD)%DCYDX = 0. - WADATS(IMOD)%DCXDY = 0. - WADATS(IMOD)%DCYDY = 0. -! -#ifdef W3_SMC - ALLOCATE ( WADATS(IMOD)%DHDX(NSEA) , & - WADATS(IMOD)%DHDY(NSEA) , & - WADATS(IMOD)%DHLMT(NTH,NSEA) , STAT=ISTAT ) + END IF + ! + IF ( FLTAUA ) THEN + ALLOCATE ( WADATS(IMOD)%MA0(NSEA) , & + WADATS(IMOD)%MAI(NSEA) , & + WADATS(IMOD)%MD0(NSEA) , & + WADATS(IMOD)%MDI(NSEA) , & + STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) -#endif -! - ALLOCATE ( WADATS(IMOD)%ALPHA(NK,NSEAL) , STAT=ISTAT ) + END IF + ! + IF ( FLRHOA ) THEN + ALLOCATE ( WADATS(IMOD)%RA0(NSEA) , & + WADATS(IMOD)%RAI(NSEA) , & + STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) -! + END IF + ! + ALLOCATE ( WADATS(IMOD)%ATRNX(NY*NX,-1:1) , & + WADATS(IMOD)%ATRNY(NY*NX,-1:1) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + IF (.NOT. LPDLIB) THEN + ALLOCATE ( WADATS(IMOD)%DDDX(NY,NX) , & + WADATS(IMOD)%DDDY(NY,NX) , & + WADATS(IMOD)%DCDX(0:NK+1,NY,NX) , & + WADATS(IMOD)%DCDY(0:NK+1,NY,NX) , & + WADATS(IMOD)%DCXDX(NY,NX) , & + WADATS(IMOD)%DCYDX(NY,NX) , & + WADATS(IMOD)%DCXDY(NY,NX) , & + WADATS(IMOD)%DCYDY(NY,NX) , STAT=ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%DDDX(1,NSEAL) , & + WADATS(IMOD)%DDDY(1,NSEAL) , & + WADATS(IMOD)%DCDX(0:NK+1,1,NSEAL) , & + WADATS(IMOD)%DCDY(0:NK+1,1,NSEAL) , & + WADATS(IMOD)%DCXDX(1,NSEAL) , & + WADATS(IMOD)%DCYDX(1,NSEAL) , & + WADATS(IMOD)%DCXDY(1,NSEAL) , & + WADATS(IMOD)%DCYDY(1,NSEAL) , STAT=ISTAT ) + ENDIF + CHECK_ALLOC_STATUS ( ISTAT ) + WADATS(IMOD)%DDDX = 0. + WADATS(IMOD)%DDDY = 0. + WADATS(IMOD)%DCDX = 0. + WADATS(IMOD)%DCDY = 0. + WADATS(IMOD)%DCXDX = 0. + WADATS(IMOD)%DCYDX = 0. + WADATS(IMOD)%DCXDY = 0. + WADATS(IMOD)%DCYDY = 0. + ! +#ifdef W3_SMC + ALLOCATE ( WADATS(IMOD)%DHDX(NSEA) , & + WADATS(IMOD)%DHDY(NSEA) , & + WADATS(IMOD)%DHLMT(NTH,NSEA) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif + ! + ALLOCATE ( WADATS(IMOD)%ALPHA(NK,NSEAL) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! #ifdef W3_PR1 - ALLOCATE ( WADATS(IMOD)%IS0(NSPEC) , & - WADATS(IMOD)%IS2(NSPEC) , & - WADATS(IMOD)%FACVX(NY*NX) , & - WADATS(IMOD)%FACVY(NY*NX) , STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%IS0(NSPEC) , & + WADATS(IMOD)%IS2(NSPEC) , & + WADATS(IMOD)%FACVX(NY*NX) , & + WADATS(IMOD)%FACVY(NY*NX) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif -! + ! #ifdef W3_PR2 - ALLOCATE ( WADATS(IMOD)%MAPX2(NY*NX) , & - WADATS(IMOD)%MAPY2(NY*NX) , & - WADATS(IMOD)%MAPAXY(NY*NX) , & - WADATS(IMOD)%MAPXY(NSEA) , & - WADATS(IMOD)%MAPTH2((NK+2)*NTH) , & - WADATS(IMOD)%MAPWN2(NSPEC+NTH) , STAT=ISTAT ) + ALLOCATE ( WADATS(IMOD)%MAPX2(NY*NX) , & + WADATS(IMOD)%MAPY2(NY*NX) , & + WADATS(IMOD)%MAPAXY(NY*NX) , & + WADATS(IMOD)%MAPXY(NSEA) , & + WADATS(IMOD)%MAPTH2((NK+2)*NTH) , & + WADATS(IMOD)%MAPWN2(NSPEC+NTH) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + WADATS(IMOD)%MAPTH2 = 0 +#endif + ! + IF (GTYPE .EQ. UNGTYPE) THEN + ALLOCATE( WADATS(IMOD)%ITER(NK,NTH), STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) - WADATS(IMOD)%MAPTH2 = 0 -#endif -! - IF (GTYPE .EQ. UNGTYPE) THEN - ALLOCATE( WADATS(IMOD)%ITER(NK,NTH), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! + END IF + ! #ifdef W3_PR3 - ALLOCATE ( WADATS(IMOD)%MAPX2(NY*NX) , & - WADATS(IMOD)%MAPY2(NY*NX) , & - WADATS(IMOD)%MAPAXY(NY*NX) , & - WADATS(IMOD)%MAPCXY(NSEA) , & - WADATS(IMOD)%MAPTH2((NK+2)*NTH) , & - WADATS(IMOD)%MAPWN2(NSPEC+NTH) , & - WADATS(IMOD)%MAPTRN(NY*NX) , STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - WADATS(IMOD)%MAPTH2 = 0 -#endif -! - ALLOCATE ( WADATS(IMOD)%IAPPRO(NSPEC) , & - WADATS(IMOD)%SPPNT(NTH,NK,4), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - END IF -! - WADATS(IMOD)%AINIT = .TRUE. + ALLOCATE ( WADATS(IMOD)%MAPX2(NY*NX) , & + WADATS(IMOD)%MAPY2(NY*NX) , & + WADATS(IMOD)%MAPAXY(NY*NX) , & + WADATS(IMOD)%MAPCXY(NSEA) , & + WADATS(IMOD)%MAPTH2((NK+2)*NTH) , & + WADATS(IMOD)%MAPWN2(NSPEC+NTH) , & + WADATS(IMOD)%MAPTRN(NY*NX) , STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + WADATS(IMOD)%MAPTH2 = 0 +#endif + ! + ALLOCATE ( WADATS(IMOD)%IAPPRO(NSPEC) , & + WADATS(IMOD)%SPPNT(NTH,NK,4), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + END IF + ! + WADATS(IMOD)%AINIT = .TRUE. -#ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 11' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif + call print_memcheck(30000+IAPROC, 'memcheck_____:'//' W3DIMA 11') -! -#ifdef W3_T - WRITE (NDST,9001) -#endif -! -! -------------------------------------------------------------------- / -! 3. Point to allocated arrays -! - CALL W3SETA ( IMOD, NDSE, NDST ) + ! + if (w3_t_flag) then + WRITE (NDST,9001) + end if + ! + ! -------------------------------------------------------------------- / + ! 3. Point to allocated arrays + ! + CALL W3SETA ( IMOD, NDSE, NDST ) -#ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA 12' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif + call print_memcheck(30000+IAPROC, 'memcheck_____:'//' W3DIMA 12') -! -#ifdef W3_T - WRITE (NDST,9002) -#endif -! -! -------------------------------------------------------------------- / -! 4. Update counters in grid -! -#ifdef W3_T - WRITE (NDST,9003) -#endif -! -! -------------------------------------------------------------------- / -! 5. Restore previous grid setting if necessary -! - IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) - -#ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3DIMA END' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3DIMA : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3DIMA : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NADATA = ',I10/) - 1003 FORMAT (/' *** ERROR W3DIMA : ARRAY(S) ALREADY ALLOCATED *** ') -! -#ifdef W3_T - 9000 FORMAT (' TEST W3DIMA : MODEL ',I4) - 9001 FORMAT (' TEST W3DIMA : ARRAYS ALLOCATED') - 9002 FORMAT (' TEST W3DIMA : POINTERS RESET') - 9003 FORMAT (' TEST W3DIMA : DIMENSIONS STORED') -#endif -!/ -!/ End of W3DIMA ----------------------------------------------------- / -!/ - END SUBROUTINE W3DIMA -!/ ------------------------------------------------------------------- / - SUBROUTINE W3XDMA ( IMOD, NDSE, NDST, OUTFLAGS ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 ! -!/ +-----------------------------------+ -!/ -!/ 26-Dec-2012 : Origination. ( version 3.06 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 22-Mar-2021 : Adds WNMEAN, TAUOC parameters ( version 7.13 ) -!/ -! 1. Purpose : -! -! Version of W3DIMX for extended ouput arrays only. -! -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NGRIDS, IGRID, W3SETG, NK, NX, NY, NSEA, & - NSEAL, NSPEC, NTH, E3DF, P2MSF, US3DF, & - USSPF, GTYPE, UNGTYPE - USE W3ODATMD, ONLY: IAPROC, NAPROC, NTPROC, NAPFLD, & - NOSWLL, NOEXTR, UNDEF, FLOGRD, FLOGR2, & - NOGRP, NGRPP - USE W3SERVMD, ONLY: EXTCDE -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST - LOGICAL, INTENT(IN) :: OUTFLAGS(NOGRP,NGRPP) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: JGRID, NXXX, I -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3XDMA') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.1 .OR. IMOD.GT.NADATA ) THEN - WRITE (NDSE,1002) IMOD, NADATA - CALL EXTCDE (2) - END IF -! - IF ( WADATS(IMOD)%AINIT2 ) THEN - WRITE (NDSE,1003) - CALL EXTCDE (3) - END IF -! -#ifdef W3_T - WRITE (NDST,9000) IMOD -#endif -! - JGRID = IGRID - IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) -! -! -------------------------------------------------------------------- / -! 2. Allocate arrays -! - NXXX = NSEALM * NAPROC -! - IF ( OUTFLAGS( 2, 1) ) THEN - ALLOCATE ( WADATS(IMOD)%XHS(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XHS(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 2, 2) ) THEN - ALLOCATE ( WADATS(IMOD)%XWLM(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XWLM(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 2, 3) ) THEN - ALLOCATE ( WADATS(IMOD)%XT02(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XT02(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 2, 4) ) THEN - ALLOCATE ( WADATS(IMOD)%XT0M1(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XT0M1(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 2, 5) ) THEN - ALLOCATE ( WADATS(IMOD)%XT01 (NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XT01 (1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 2, 6) .OR. OUTFLAGS( 2,18) ) THEN - ! TP output shares FP0 internal field with FP - ALLOCATE ( WADATS(IMOD)%XFP0(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XFP0(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 2, 7) ) THEN - ALLOCATE ( WADATS(IMOD)%XTHM(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTHM(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 2, 8) ) THEN - ALLOCATE ( WADATS(IMOD)%XTHS(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTHS(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 2, 9) ) THEN - ALLOCATE ( WADATS(IMOD)%XTHP0(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTHP0(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 2, 10) ) THEN - ALLOCATE ( WADATS(IMOD)%XHSIG(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XHSIG(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 2, 11) ) THEN - ALLOCATE ( WADATS(IMOD)%XSTMAXE(NXXX) ) - ELSE - ALLOCATE ( WADATS(IMOD)%XSTMAXE(1) ) - END IF -! - IF ( OUTFLAGS( 2, 12) ) THEN - ALLOCATE ( WADATS(IMOD)%XSTMAXD(NXXX) ) - ELSE - ALLOCATE ( WADATS(IMOD)%XSTMAXD(1) ) - END IF -! - IF ( OUTFLAGS( 2, 13) ) THEN - ALLOCATE ( WADATS(IMOD)%XHMAXE(NXXX) ) - ELSE - ALLOCATE ( WADATS(IMOD)%XHMAXE(1) ) - END IF -! - IF ( OUTFLAGS( 2, 14) ) THEN - ALLOCATE ( WADATS(IMOD)%XHCMAXE(NXXX) ) - ELSE - ALLOCATE ( WADATS(IMOD)%XHCMAXE(1) ) - END IF -! -! - IF ( OUTFLAGS( 2, 15) ) THEN - ALLOCATE ( WADATS(IMOD)%XHMAXD(NXXX) ) - ELSE - ALLOCATE ( WADATS(IMOD)%XHMAXD(1) ) - END IF -! - IF ( OUTFLAGS( 2, 16) ) THEN - ALLOCATE ( WADATS(IMOD)%XHCMAXD(NXXX) ) - ELSE - ALLOCATE ( WADATS(IMOD)%XHCMAXD(1) ) - END IF -! - IF ( OUTFLAGS( 2, 17) ) THEN - ALLOCATE ( WADATS(IMOD)%XWBT (NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XWBT (1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 2, 19) ) THEN - ALLOCATE ( WADATS(IMOD)%XWNMEAN(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XWNMEAN(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! -! IF ( OUTFLAGS( 2,xx) ) THEN -! ALLOCATE ( WADATS(IMOD)%XFP1(NXXX), STAT=ISTAT ) -! CHECK_ALLOC_STATUS ( ISTAT ) -! ELSE -! ALLOCATE ( WADATS(IMOD)%XFP1(1), STAT=ISTAT ) -! CHECK_ALLOC_STATUS ( ISTAT ) -! END IF -! -! IF ( OUTFLAGS( 2,xx) ) THEN -! ALLOCATE ( WADATS(IMOD)%XTHP1(NXXX), STAT=ISTAT ) -! CHECK_ALLOC_STATUS ( ISTAT ) -! ELSE -! ALLOCATE ( WADATS(IMOD)%XTHP1(1), STAT=ISTAT ) -! CHECK_ALLOC_STATUS ( ISTAT ) -! END IF -! - WADATS(IMOD)%XHS = UNDEF - WADATS(IMOD)%XWLM = UNDEF - WADATS(IMOD)%XT02 = UNDEF - WADATS(IMOD)%XT0M1 = UNDEF - WADATS(IMOD)%XT01 = UNDEF - WADATS(IMOD)%XFP0 = UNDEF - WADATS(IMOD)%XTHM = UNDEF - WADATS(IMOD)%XTHS = UNDEF - WADATS(IMOD)%XTHP0 = UNDEF - WADATS(IMOD)%XHSIG = UNDEF - WADATS(IMOD)%XSTMAXE= UNDEF - WADATS(IMOD)%XSTMAXD= UNDEF - WADATS(IMOD)%XHMAXE = UNDEF - WADATS(IMOD)%XHMAXD = UNDEF - WADATS(IMOD)%XHCMAXE= UNDEF - WADATS(IMOD)%XHCMAXD= UNDEF - WADATS(IMOD)%XWBT = UNDEF - WADATS(IMOD)%XWNMEAN= UNDEF -! WADATS(IMOD)%XFP1 = UNDEF -! WADATS(IMOD)%XTHP1 = UNDEF -! - IF ( OUTFLAGS( 3, 1) ) THEN - ALLOCATE ( WADATS(IMOD)%XEF(NXXX,E3DF(2,1):E3DF(3,1)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XEF(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF + ! + if (w3_t_flag) then + WRITE (NDST,9002) + end if + ! + ! -------------------------------------------------------------------- / + ! 4. Update counters in grid + ! + if (w3_t_flag) then + WRITE (NDST,9003) + end if + ! + ! -------------------------------------------------------------------- / + ! 5. Restore previous grid setting if necessary + ! + IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) - IF ( OUTFLAGS( 3, 2) ) THEN - ALLOCATE ( WADATS(IMOD)%XTH1M(NXXX,E3DF(2,2):E3DF(3,2)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTH1M(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF + call print_memcheck(30000+IAPROC, 'memcheck_____:'//' W3DIMA END') + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3DIMA : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3DIMA : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NADATA = ',I10/) +1003 FORMAT (/' *** ERROR W3DIMA : ARRAY(S) ALREADY ALLOCATED *** ') + ! +9000 FORMAT (' TEST W3DIMA : MODEL ',I4) ! W3_T +9001 FORMAT (' TEST W3DIMA : ARRAYS ALLOCATED') +9002 FORMAT (' TEST W3DIMA : POINTERS RESET') +9003 FORMAT (' TEST W3DIMA : DIMENSIONS STORED') + !/ + !/ End of W3DIMA ----------------------------------------------------- / + !/ + END SUBROUTINE W3DIMA + !/ ------------------------------------------------------------------- / + SUBROUTINE W3XDMA ( IMOD, NDSE, NDST, OUTFLAGS ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 ! + !/ +-----------------------------------+ + !/ + !/ 26-Dec-2012 : Origination. ( version 3.06 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 22-Mar-2021 : Adds WNMEAN, TAUOC parameters ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Version of W3DIMX for extended ouput arrays only. + ! + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NGRIDS, IGRID, W3SETG, NK, NX, NY, NSEA + USE W3GDATMD, ONLY: NSEAL, NSPEC, NTH, E3DF, P2MSF, US3DF + USE W3GDATMD, ONLY: USSPF, GTYPE, UNGTYPE + USE W3ODATMD, ONLY: IAPROC, NAPROC, NTPROC, NAPFLD + USE W3ODATMD, ONLY: NOSWLL, NOEXTR, UNDEF, FLOGRD, FLOGR2, NOGRP, NGRPP + USE W3SERVMD, ONLY: EXTCDE + USE W3SERVMD, ONLY: STRACE ! W3_S + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST + LOGICAL, INTENT(IN) :: OUTFLAGS(NOGRP,NGRPP) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: JGRID, NXXX, I + INTEGER, SAVE :: IENT = 0 ! W3_S + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'W3XDMA') + end if + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.1 .OR. IMOD.GT.NADATA ) THEN + WRITE (NDSE,1002) IMOD, NADATA + CALL EXTCDE (2) + END IF + ! + IF ( WADATS(IMOD)%AINIT2 ) THEN + WRITE (NDSE,1003) + CALL EXTCDE (3) + END IF + ! + if (w3_t_flag) then + WRITE (NDST,9000) IMOD + end if + ! + JGRID = IGRID + IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) + ! + ! -------------------------------------------------------------------- / + ! 2. Allocate arrays + ! + NXXX = NSEALM * NAPROC + ! + IF ( OUTFLAGS( 2, 1) ) THEN + ALLOCATE ( WADATS(IMOD)%XHS(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XHS(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 2, 2) ) THEN + ALLOCATE ( WADATS(IMOD)%XWLM(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XWLM(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 2, 3) ) THEN + ALLOCATE ( WADATS(IMOD)%XT02(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XT02(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 2, 4) ) THEN + ALLOCATE ( WADATS(IMOD)%XT0M1(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XT0M1(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 2, 5) ) THEN + ALLOCATE ( WADATS(IMOD)%XT01 (NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XT01 (1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 2, 6) .OR. OUTFLAGS( 2,18) ) THEN + ! TP output shares FP0 internal field with FP + ALLOCATE ( WADATS(IMOD)%XFP0(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XFP0(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 2, 7) ) THEN + ALLOCATE ( WADATS(IMOD)%XTHM(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTHM(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 2, 8) ) THEN + ALLOCATE ( WADATS(IMOD)%XTHS(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTHS(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 2, 9) ) THEN + ALLOCATE ( WADATS(IMOD)%XTHP0(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTHP0(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 2, 10) ) THEN + ALLOCATE ( WADATS(IMOD)%XHSIG(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XHSIG(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 2, 11) ) THEN + ALLOCATE ( WADATS(IMOD)%XSTMAXE(NXXX) ) + ELSE + ALLOCATE ( WADATS(IMOD)%XSTMAXE(1) ) + END IF + ! + IF ( OUTFLAGS( 2, 12) ) THEN + ALLOCATE ( WADATS(IMOD)%XSTMAXD(NXXX) ) + ELSE + ALLOCATE ( WADATS(IMOD)%XSTMAXD(1) ) + END IF + ! + IF ( OUTFLAGS( 2, 13) ) THEN + ALLOCATE ( WADATS(IMOD)%XHMAXE(NXXX) ) + ELSE + ALLOCATE ( WADATS(IMOD)%XHMAXE(1) ) + END IF + ! + IF ( OUTFLAGS( 2, 14) ) THEN + ALLOCATE ( WADATS(IMOD)%XHCMAXE(NXXX) ) + ELSE + ALLOCATE ( WADATS(IMOD)%XHCMAXE(1) ) + END IF + ! + ! + IF ( OUTFLAGS( 2, 15) ) THEN + ALLOCATE ( WADATS(IMOD)%XHMAXD(NXXX) ) + ELSE + ALLOCATE ( WADATS(IMOD)%XHMAXD(1) ) + END IF + ! + IF ( OUTFLAGS( 2, 16) ) THEN + ALLOCATE ( WADATS(IMOD)%XHCMAXD(NXXX) ) + ELSE + ALLOCATE ( WADATS(IMOD)%XHCMAXD(1) ) + END IF + ! + IF ( OUTFLAGS( 2, 17) ) THEN + ALLOCATE ( WADATS(IMOD)%XWBT (NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XWBT (1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 2, 19) ) THEN + ALLOCATE ( WADATS(IMOD)%XWNMEAN(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XWNMEAN(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + ! IF ( OUTFLAGS( 2,xx) ) THEN + ! ALLOCATE ( WADATS(IMOD)%XFP1(NXXX), STAT=ISTAT ) + ! CHECK_ALLOC_STATUS ( ISTAT ) + ! ELSE + ! ALLOCATE ( WADATS(IMOD)%XFP1(1), STAT=ISTAT ) + ! CHECK_ALLOC_STATUS ( ISTAT ) + ! END IF + ! + ! IF ( OUTFLAGS( 2,xx) ) THEN + ! ALLOCATE ( WADATS(IMOD)%XTHP1(NXXX), STAT=ISTAT ) + ! CHECK_ALLOC_STATUS ( ISTAT ) + ! ELSE + ! ALLOCATE ( WADATS(IMOD)%XTHP1(1), STAT=ISTAT ) + ! CHECK_ALLOC_STATUS ( ISTAT ) + ! END IF + ! + WADATS(IMOD)%XHS = UNDEF + WADATS(IMOD)%XWLM = UNDEF + WADATS(IMOD)%XT02 = UNDEF + WADATS(IMOD)%XT0M1 = UNDEF + WADATS(IMOD)%XT01 = UNDEF + WADATS(IMOD)%XFP0 = UNDEF + WADATS(IMOD)%XTHM = UNDEF + WADATS(IMOD)%XTHS = UNDEF + WADATS(IMOD)%XTHP0 = UNDEF + WADATS(IMOD)%XHSIG = UNDEF + WADATS(IMOD)%XSTMAXE= UNDEF + WADATS(IMOD)%XSTMAXD= UNDEF + WADATS(IMOD)%XHMAXE = UNDEF + WADATS(IMOD)%XHMAXD = UNDEF + WADATS(IMOD)%XHCMAXE= UNDEF + WADATS(IMOD)%XHCMAXD= UNDEF + WADATS(IMOD)%XWBT = UNDEF + WADATS(IMOD)%XWNMEAN= UNDEF + ! WADATS(IMOD)%XFP1 = UNDEF + ! WADATS(IMOD)%XTHP1 = UNDEF + ! + IF ( OUTFLAGS( 3, 1) ) THEN + ALLOCATE ( WADATS(IMOD)%XEF(NXXX,E3DF(2,1):E3DF(3,1)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XEF(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF - IF ( OUTFLAGS( 3, 3) ) THEN - ALLOCATE ( WADATS(IMOD)%XSTH1M(NXXX,E3DF(2,3):E3DF(3,3)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XSTH1M(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF + IF ( OUTFLAGS( 3, 2) ) THEN + ALLOCATE ( WADATS(IMOD)%XTH1M(NXXX,E3DF(2,2):E3DF(3,2)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTH1M(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF - IF ( OUTFLAGS( 3, 4) ) THEN - ALLOCATE ( WADATS(IMOD)%XTH2M(NXXX,E3DF(2,4):E3DF(3,4)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTH2M(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 3, 5) ) THEN - ALLOCATE ( WADATS(IMOD)%XSTH2M(NXXX,E3DF(2,5):E3DF(3,5)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XSTH2M(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - WADATS(IMOD)%XEF = UNDEF - WADATS(IMOD)%XTH1M = UNDEF - WADATS(IMOD)%XSTH1M = UNDEF - WADATS(IMOD)%XTH2M = UNDEF - WADATS(IMOD)%XSTH2M = UNDEF -! - IF ( OUTFLAGS( 4, 1) ) THEN - ALLOCATE ( WADATS(IMOD)%XPHS(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPHS(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4, 2) ) THEN - ALLOCATE ( WADATS(IMOD)%XPTP(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPTP(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4, 3) ) THEN - ALLOCATE ( WADATS(IMOD)%XPLP(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPLP(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4, 4) ) THEN - ALLOCATE ( WADATS(IMOD)%XPDIR(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPDIR(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4, 5) ) THEN - ALLOCATE ( WADATS(IMOD)%XPSI(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPSI(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4, 6) ) THEN - ALLOCATE ( WADATS(IMOD)%XPWS(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPWS(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4, 7) ) THEN - ALLOCATE ( WADATS(IMOD)%XPTHP0(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPTHP0(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4, 8) ) THEN - ALLOCATE ( WADATS(IMOD)%XPQP(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPQP(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4, 9) ) THEN - ALLOCATE ( WADATS(IMOD)%XPPE(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPPE(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4,10) ) THEN - ALLOCATE ( WADATS(IMOD)%XPGW(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPGW(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4,11) ) THEN - ALLOCATE ( WADATS(IMOD)%XPSW(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPSW(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4,12) ) THEN - ALLOCATE ( WADATS(IMOD)%XPTM1(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPTM1(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4,13) ) THEN - ALLOCATE ( WADATS(IMOD)%XPT1(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPT1(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4,14) ) THEN - ALLOCATE ( WADATS(IMOD)%XPT2(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPT2(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4,15) ) THEN - ALLOCATE ( WADATS(IMOD)%XPEP(NXXX,0:NOSWLL), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPEP(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4,16) ) THEN - ALLOCATE ( WADATS(IMOD)%XPWST(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPWST(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 4,17) ) THEN - ALLOCATE ( WADATS(IMOD)%XPNR(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPNR(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - WADATS(IMOD)%XPHS = UNDEF - WADATS(IMOD)%XPTP = UNDEF - WADATS(IMOD)%XPLP = UNDEF - WADATS(IMOD)%XPDIR = UNDEF - WADATS(IMOD)%XPSI = UNDEF - WADATS(IMOD)%XPWS = UNDEF - WADATS(IMOD)%XPWST = UNDEF - WADATS(IMOD)%XPNR = UNDEF - WADATS(IMOD)%XPTHP0 = UNDEF - WADATS(IMOD)%XPQP = UNDEF - WADATS(IMOD)%XPPE = UNDEF - WADATS(IMOD)%XPGW = UNDEF - WADATS(IMOD)%XPSW = UNDEF - WADATS(IMOD)%XPTM1 = UNDEF - WADATS(IMOD)%XPT1 = UNDEF - WADATS(IMOD)%XPT2 = UNDEF - WADATS(IMOD)%XPEP = UNDEF -! - IF ( OUTFLAGS( 5, 2) ) THEN - ALLOCATE ( WADATS(IMOD)%XCHARN(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XCHARN(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 5, 3) ) THEN - ALLOCATE ( WADATS(IMOD)%XCGE(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XCGE(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 5, 4) ) THEN - ALLOCATE ( WADATS(IMOD)%XPHIAW(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPHIAW(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 5, 5) ) THEN - ALLOCATE ( WADATS(IMOD)%XTAUWIX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTAUWIY(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTAUWIX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTAUWIY(1) ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 5, 6) ) THEN - ALLOCATE ( WADATS(IMOD)%XTAUWNX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTAUWNY(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTAUWNX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTAUWNY(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 5, 7) .OR. OUTFLAGS( 5, 8) .OR. & - OUTFLAGS( 5, 9) .OR. OUTFLAGS( 5,10)) THEN - ALLOCATE ( WADATS(IMOD)%XWHITECAP(NXXX,4), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XWHITECAP(1,4), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 5, 11) ) THEN - ALLOCATE ( WADATS(IMOD)%XTWS(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTWS(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - WADATS(IMOD)%XCHARN = UNDEF - WADATS(IMOD)%XTWS = UNDEF - WADATS(IMOD)%XCGE = UNDEF - WADATS(IMOD)%XPHIAW = UNDEF - WADATS(IMOD)%XTAUWIX = UNDEF - WADATS(IMOD)%XTAUWIY = UNDEF - WADATS(IMOD)%XTAUWNX = UNDEF - WADATS(IMOD)%XTAUWNY = UNDEF - WADATS(IMOD)%XWHITECAP = UNDEF -! - IF ( OUTFLAGS( 6, 1) ) THEN - ALLOCATE ( WADATS(IMOD)%XSXX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XSYY(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XSXY(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XSXX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XSYY(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XSXY(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6, 2) ) THEN - ALLOCATE ( WADATS(IMOD)%XTAUOX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTAUOY(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTAUOX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTAUOY(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6, 3) ) THEN - ALLOCATE ( WADATS(IMOD)%XBHD(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XBHD(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6, 4) ) THEN - ALLOCATE ( WADATS(IMOD)%XPHIOC(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPHIOC(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6, 5) ) THEN - ALLOCATE ( WADATS(IMOD)%XTUSX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTUSY(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTUSX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTUSY(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6, 6) ) THEN - ALLOCATE ( WADATS(IMOD)%XUSSX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XUSSY(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XUSSX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XUSSY(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6, 7) ) THEN - ALLOCATE ( WADATS(IMOD)%XPRMS(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTPMS(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPRMS(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTPMS(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6, 8) ) THEN - ALLOCATE ( WADATS(IMOD)%XUS3D(NXXX,2*NK), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XUS3D(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6, 9) ) THEN - ALLOCATE ( WADATS(IMOD)%XP2SMS(NXXX,P2MSF(2):P2MSF(3)), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XP2SMS(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6,10) ) THEN - ALLOCATE ( WADATS(IMOD)%XTAUICE(NXXX,2), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTAUICE(1,2), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6,11) ) THEN - ALLOCATE ( WADATS(IMOD)%XPHICE(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPHICE(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6, 12) ) THEN - ALLOCATE ( WADATS(IMOD)%XUSSP(NXXX,2*NK), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XUSSP(1,1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 6, 13) ) THEN - ALLOCATE ( WADATS(IMOD)%XTAUOCX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTAUOCY(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTAUOCX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XTAUOCY(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! + IF ( OUTFLAGS( 3, 3) ) THEN + ALLOCATE ( WADATS(IMOD)%XSTH1M(NXXX,E3DF(2,3):E3DF(3,3)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XSTH1M(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + + IF ( OUTFLAGS( 3, 4) ) THEN + ALLOCATE ( WADATS(IMOD)%XTH2M(NXXX,E3DF(2,4):E3DF(3,4)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTH2M(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 3, 5) ) THEN + ALLOCATE ( WADATS(IMOD)%XSTH2M(NXXX,E3DF(2,5):E3DF(3,5)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XSTH2M(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + WADATS(IMOD)%XEF = UNDEF + WADATS(IMOD)%XTH1M = UNDEF + WADATS(IMOD)%XSTH1M = UNDEF + WADATS(IMOD)%XTH2M = UNDEF + WADATS(IMOD)%XSTH2M = UNDEF + ! + IF ( OUTFLAGS( 4, 1) ) THEN + ALLOCATE ( WADATS(IMOD)%XPHS(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPHS(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4, 2) ) THEN + ALLOCATE ( WADATS(IMOD)%XPTP(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPTP(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4, 3) ) THEN + ALLOCATE ( WADATS(IMOD)%XPLP(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPLP(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4, 4) ) THEN + ALLOCATE ( WADATS(IMOD)%XPDIR(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPDIR(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4, 5) ) THEN + ALLOCATE ( WADATS(IMOD)%XPSI(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPSI(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4, 6) ) THEN + ALLOCATE ( WADATS(IMOD)%XPWS(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPWS(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4, 7) ) THEN + ALLOCATE ( WADATS(IMOD)%XPTHP0(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPTHP0(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4, 8) ) THEN + ALLOCATE ( WADATS(IMOD)%XPQP(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPQP(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4, 9) ) THEN + ALLOCATE ( WADATS(IMOD)%XPPE(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPPE(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4,10) ) THEN + ALLOCATE ( WADATS(IMOD)%XPGW(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPGW(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4,11) ) THEN + ALLOCATE ( WADATS(IMOD)%XPSW(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPSW(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4,12) ) THEN + ALLOCATE ( WADATS(IMOD)%XPTM1(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPTM1(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4,13) ) THEN + ALLOCATE ( WADATS(IMOD)%XPT1(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPT1(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4,14) ) THEN + ALLOCATE ( WADATS(IMOD)%XPT2(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPT2(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4,15) ) THEN + ALLOCATE ( WADATS(IMOD)%XPEP(NXXX,0:NOSWLL), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPEP(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4,16) ) THEN + ALLOCATE ( WADATS(IMOD)%XPWST(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPWST(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 4,17) ) THEN + ALLOCATE ( WADATS(IMOD)%XPNR(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPNR(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + WADATS(IMOD)%XPHS = UNDEF + WADATS(IMOD)%XPTP = UNDEF + WADATS(IMOD)%XPLP = UNDEF + WADATS(IMOD)%XPDIR = UNDEF + WADATS(IMOD)%XPSI = UNDEF + WADATS(IMOD)%XPWS = UNDEF + WADATS(IMOD)%XPWST = UNDEF + WADATS(IMOD)%XPNR = UNDEF + WADATS(IMOD)%XPTHP0 = UNDEF + WADATS(IMOD)%XPQP = UNDEF + WADATS(IMOD)%XPPE = UNDEF + WADATS(IMOD)%XPGW = UNDEF + WADATS(IMOD)%XPSW = UNDEF + WADATS(IMOD)%XPTM1 = UNDEF + WADATS(IMOD)%XPT1 = UNDEF + WADATS(IMOD)%XPT2 = UNDEF + WADATS(IMOD)%XPEP = UNDEF + ! + IF ( OUTFLAGS( 5, 2) ) THEN + ALLOCATE ( WADATS(IMOD)%XCHARN(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XCHARN(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 5, 3) ) THEN + ALLOCATE ( WADATS(IMOD)%XCGE(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XCGE(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 5, 4) ) THEN + ALLOCATE ( WADATS(IMOD)%XPHIAW(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPHIAW(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 5, 5) ) THEN + ALLOCATE ( WADATS(IMOD)%XTAUWIX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTAUWIY(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTAUWIX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTAUWIY(1) ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 5, 6) ) THEN + ALLOCATE ( WADATS(IMOD)%XTAUWNX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTAUWNY(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTAUWNX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTAUWNY(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 5, 7) .OR. OUTFLAGS( 5, 8) .OR. & + OUTFLAGS( 5, 9) .OR. OUTFLAGS( 5,10)) THEN + ALLOCATE ( WADATS(IMOD)%XWHITECAP(NXXX,4), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XWHITECAP(1,4), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 5, 11) ) THEN + ALLOCATE ( WADATS(IMOD)%XTWS(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTWS(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + WADATS(IMOD)%XCHARN = UNDEF + WADATS(IMOD)%XTWS = UNDEF + WADATS(IMOD)%XCGE = UNDEF + WADATS(IMOD)%XPHIAW = UNDEF + WADATS(IMOD)%XTAUWIX = UNDEF + WADATS(IMOD)%XTAUWIY = UNDEF + WADATS(IMOD)%XTAUWNX = UNDEF + WADATS(IMOD)%XTAUWNY = UNDEF + WADATS(IMOD)%XWHITECAP = UNDEF + ! + IF ( OUTFLAGS( 6, 1) ) THEN + ALLOCATE ( WADATS(IMOD)%XSXX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XSYY(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XSXY(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XSXX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XSYY(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XSXY(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6, 2) ) THEN + ALLOCATE ( WADATS(IMOD)%XTAUOX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTAUOY(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTAUOX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTAUOY(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6, 3) ) THEN + ALLOCATE ( WADATS(IMOD)%XBHD(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XBHD(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6, 4) ) THEN + ALLOCATE ( WADATS(IMOD)%XPHIOC(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPHIOC(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6, 5) ) THEN + ALLOCATE ( WADATS(IMOD)%XTUSX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTUSY(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTUSX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTUSY(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6, 6) ) THEN + ALLOCATE ( WADATS(IMOD)%XUSSX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XUSSY(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XUSSX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XUSSY(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6, 7) ) THEN + ALLOCATE ( WADATS(IMOD)%XPRMS(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTPMS(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPRMS(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTPMS(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6, 8) ) THEN + ALLOCATE ( WADATS(IMOD)%XUS3D(NXXX,2*NK), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XUS3D(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6, 9) ) THEN + ALLOCATE ( WADATS(IMOD)%XP2SMS(NXXX,P2MSF(2):P2MSF(3)), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XP2SMS(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6,10) ) THEN + ALLOCATE ( WADATS(IMOD)%XTAUICE(NXXX,2), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTAUICE(1,2), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6,11) ) THEN + ALLOCATE ( WADATS(IMOD)%XPHICE(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPHICE(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6, 12) ) THEN + ALLOCATE ( WADATS(IMOD)%XUSSP(NXXX,2*NK), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XUSSP(1,1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 6, 13) ) THEN + ALLOCATE ( WADATS(IMOD)%XTAUOCX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTAUOCY(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTAUOCX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XTAUOCY(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! #ifdef W3_CESMCOUPLED - IF ( OUTFLAGS( 6, 14) ) THEN - ALLOCATE ( WADATS(IMOD)%XLANGMT(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XLANGMT(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -#endif -! - WADATS(IMOD)%XSXX = UNDEF - WADATS(IMOD)%XSYY = UNDEF - WADATS(IMOD)%XSXY = UNDEF - WADATS(IMOD)%XTAUOX = UNDEF - WADATS(IMOD)%XTAUOY = UNDEF - WADATS(IMOD)%XBHD = UNDEF - WADATS(IMOD)%XPHIOC = UNDEF - WADATS(IMOD)%XTUSX = UNDEF - WADATS(IMOD)%XTUSY = UNDEF - WADATS(IMOD)%XUSSX = UNDEF - WADATS(IMOD)%XUSSY = UNDEF - WADATS(IMOD)%XPRMS = UNDEF - WADATS(IMOD)%XTPMS = UNDEF - WADATS(IMOD)%XUS3D = UNDEF - WADATS(IMOD)%XP2SMS = UNDEF - WADATS(IMOD)%XPHICE = UNDEF - WADATS(IMOD)%XTAUICE = UNDEF - WADATS(IMOD)%XUSSP = UNDEF - WADATS(IMOD)%XTAUOCX = UNDEF - WADATS(IMOD)%XTAUOCY = UNDEF + IF ( OUTFLAGS( 6, 14) ) THEN + ALLOCATE ( WADATS(IMOD)%XLANGMT(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XLANGMT(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF +#endif + ! + WADATS(IMOD)%XSXX = UNDEF + WADATS(IMOD)%XSYY = UNDEF + WADATS(IMOD)%XSXY = UNDEF + WADATS(IMOD)%XTAUOX = UNDEF + WADATS(IMOD)%XTAUOY = UNDEF + WADATS(IMOD)%XBHD = UNDEF + WADATS(IMOD)%XPHIOC = UNDEF + WADATS(IMOD)%XTUSX = UNDEF + WADATS(IMOD)%XTUSY = UNDEF + WADATS(IMOD)%XUSSX = UNDEF + WADATS(IMOD)%XUSSY = UNDEF + WADATS(IMOD)%XPRMS = UNDEF + WADATS(IMOD)%XTPMS = UNDEF + WADATS(IMOD)%XUS3D = UNDEF + WADATS(IMOD)%XP2SMS = UNDEF + WADATS(IMOD)%XPHICE = UNDEF + WADATS(IMOD)%XTAUICE = UNDEF + WADATS(IMOD)%XUSSP = UNDEF + WADATS(IMOD)%XTAUOCX = UNDEF + WADATS(IMOD)%XTAUOCY = UNDEF #ifdef W3_CESMCOUPLED - WADATS(IMOD)%XLANGMT = UNDEF -#endif -! - IF ( OUTFLAGS( 7, 1) ) THEN - ALLOCATE ( WADATS(IMOD)%XABA(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XABD(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XABA(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XABD(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 7, 2) ) THEN - ALLOCATE ( WADATS(IMOD)%XUBA(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XUBD(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XUBA(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XUBD(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 7, 3) ) THEN - ALLOCATE ( WADATS(IMOD)%XBEDFORMS(NXXX,3), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XBEDFORMS(1,3), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 7, 4) ) THEN - ALLOCATE ( WADATS(IMOD)%XPHIBBL(NXXX), STAT=ISTAT ) + WADATS(IMOD)%XLANGMT = UNDEF +#endif + ! + IF ( OUTFLAGS( 7, 1) ) THEN + ALLOCATE ( WADATS(IMOD)%XABA(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XABD(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XABA(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XABD(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 7, 2) ) THEN + ALLOCATE ( WADATS(IMOD)%XUBA(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XUBD(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XUBA(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XUBD(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 7, 3) ) THEN + ALLOCATE ( WADATS(IMOD)%XBEDFORMS(NXXX,3), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XBEDFORMS(1,3), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 7, 4) ) THEN + ALLOCATE ( WADATS(IMOD)%XPHIBBL(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XPHIBBL(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 7, 5) ) THEN + ALLOCATE ( WADATS(IMOD)%XTAUBBL(NXXX,2), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XTAUBBL(1,2), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + WADATS(IMOD)%XABA = UNDEF + WADATS(IMOD)%XABD = UNDEF + WADATS(IMOD)%XUBA = UNDEF + WADATS(IMOD)%XUBD = UNDEF + WADATS(IMOD)%XBEDFORMS = UNDEF + WADATS(IMOD)%XPHIBBL = UNDEF + WADATS(IMOD)%XTAUBBL = UNDEF + ! + IF ( OUTFLAGS( 8, 1) ) THEN + ALLOCATE ( WADATS(IMOD)%XMSSX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XMSSY(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XMSSX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XMSSY(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 8, 2) ) THEN + ALLOCATE ( WADATS(IMOD)%XMSCX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XMSCY(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XMSCX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( WADATS(IMOD)%XMSCY(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 8, 3) ) THEN + ALLOCATE ( WADATS(IMOD)%XMSSD(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XMSSD(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 8, 4) ) THEN + ALLOCATE ( WADATS(IMOD)%XMSCD(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XMSCD(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 8, 5) ) THEN + ALLOCATE ( WADATS(IMOD)%XQP(NXXX) ) + ELSE + ALLOCATE ( WADATS(IMOD)%XQP(1) ) + END IF + ! + WADATS(IMOD)%XMSSX = UNDEF + WADATS(IMOD)%XMSSY = UNDEF + WADATS(IMOD)%XMSSD = UNDEF + WADATS(IMOD)%XMSCX = UNDEF + WADATS(IMOD)%XMSCY = UNDEF + WADATS(IMOD)%XMSCD = UNDEF + WADATS(IMOD)%XQP(1) = UNDEF + ! + IF ( OUTFLAGS( 9, 1) ) THEN + ALLOCATE ( WADATS(IMOD)%XDTDYN(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XDTDYN(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 9, 2) ) THEN + ALLOCATE ( WADATS(IMOD)%XFCUT(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XFCUT(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 9, 3) ) THEN + ALLOCATE ( WADATS(IMOD)%XCFLXYMAX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XCFLXYMAX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 9, 4) ) THEN + ALLOCATE ( WADATS(IMOD)%XCFLTHMAX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XCFLTHMAX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + IF ( OUTFLAGS( 9, 5) ) THEN + ALLOCATE ( WADATS(IMOD)%XCFLKMAX(NXXX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XCFLKMAX(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + END IF + ! + WADATS(IMOD)%XDTDYN = UNDEF + WADATS(IMOD)%XFCUT = UNDEF + WADATS(IMOD)%XCFLXYMAX = UNDEF + WADATS(IMOD)%XCFLTHMAX = UNDEF + WADATS(IMOD)%XCFLKMAX = UNDEF + ! + DO I=1, NOEXTR + IF ( OUTFLAGS(10, i) ) THEN + ALLOCATE ( WADATS(IMOD)%XUSERO(NXXX,I), STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XPHIBBL(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 7, 5) ) THEN - ALLOCATE ( WADATS(IMOD)%XTAUBBL(NXXX,2), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XTAUBBL(1,2), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - WADATS(IMOD)%XABA = UNDEF - WADATS(IMOD)%XABD = UNDEF - WADATS(IMOD)%XUBA = UNDEF - WADATS(IMOD)%XUBD = UNDEF - WADATS(IMOD)%XBEDFORMS = UNDEF - WADATS(IMOD)%XPHIBBL = UNDEF - WADATS(IMOD)%XTAUBBL = UNDEF -! - IF ( OUTFLAGS( 8, 1) ) THEN - ALLOCATE ( WADATS(IMOD)%XMSSX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XMSSY(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XMSSX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XMSSY(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 8, 2) ) THEN - ALLOCATE ( WADATS(IMOD)%XMSCX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XMSCY(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XMSCX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( WADATS(IMOD)%XMSCY(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 8, 3) ) THEN - ALLOCATE ( WADATS(IMOD)%XMSSD(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XMSSD(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 8, 4) ) THEN - ALLOCATE ( WADATS(IMOD)%XMSCD(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XMSCD(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 8, 5) ) THEN - ALLOCATE ( WADATS(IMOD)%XQP(NXXX) ) - ELSE - ALLOCATE ( WADATS(IMOD)%XQP(1) ) - END IF -! - WADATS(IMOD)%XMSSX = UNDEF - WADATS(IMOD)%XMSSY = UNDEF - WADATS(IMOD)%XMSSD = UNDEF - WADATS(IMOD)%XMSCX = UNDEF - WADATS(IMOD)%XMSCY = UNDEF - WADATS(IMOD)%XMSCD = UNDEF - WADATS(IMOD)%XQP(1) = UNDEF -! - IF ( OUTFLAGS( 9, 1) ) THEN - ALLOCATE ( WADATS(IMOD)%XDTDYN(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XDTDYN(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 9, 2) ) THEN - ALLOCATE ( WADATS(IMOD)%XFCUT(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XFCUT(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 9, 3) ) THEN - ALLOCATE ( WADATS(IMOD)%XCFLXYMAX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XCFLXYMAX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 9, 4) ) THEN - ALLOCATE ( WADATS(IMOD)%XCFLTHMAX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XCFLTHMAX(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - IF ( OUTFLAGS( 9, 5) ) THEN - ALLOCATE ( WADATS(IMOD)%XCFLKMAX(NXXX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XCFLKMAX(1), STAT=ISTAT ) + ELSE + ALLOCATE ( WADATS(IMOD)%XUSERO(1,I), STAT=ISTAT ) CHECK_ALLOC_STATUS ( ISTAT ) - END IF -! - WADATS(IMOD)%XDTDYN = UNDEF - WADATS(IMOD)%XFCUT = UNDEF - WADATS(IMOD)%XCFLXYMAX = UNDEF - WADATS(IMOD)%XCFLTHMAX = UNDEF - WADATS(IMOD)%XCFLKMAX = UNDEF -! - DO I=1, NOEXTR - IF ( OUTFLAGS(10, i) ) THEN - ALLOCATE ( WADATS(IMOD)%XUSERO(NXXX,I), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ELSE - ALLOCATE ( WADATS(IMOD)%XUSERO(1,I), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - END IF - END DO -! - WADATS(IMOD)%XUSERO = UNDEF -! - WADATS(IMOD)%AINIT2 = .TRUE. -! -#ifdef W3_T - WRITE (NDST,9001) - WRITE (NDST,9001) -#endif -! -! -------------------------------------------------------------------- / -! 5. Restore previous grid setting if necessary -! - IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) + END IF + END DO + ! + WADATS(IMOD)%XUSERO = UNDEF + ! + WADATS(IMOD)%AINIT2 = .TRUE. + ! + if (w3_t_flag) then + WRITE (NDST,9001) + WRITE (NDST,9001) + end if + ! + ! -------------------------------------------------------------------- / + ! 5. Restore previous grid setting if necessary + ! + IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST ) -#ifdef W3_MEMCHECK - WRITE(30000+IAPROC,*) 'memcheck_____:', 'W3XDMA' - call getMallocInfo(mallinfos) - call printMallInfo(30000+IAPROC,mallInfos) -#endif -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3XDMA : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3XDMA : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NADATA = ',I10/) - 1003 FORMAT (/' *** ERROR W3XDMA : ARRAY(S) ALREADY ALLOCATED *** ') -! -#ifdef W3_T - 9000 FORMAT (' TEST W3XDMA : MODEL ',I4) - 9001 FORMAT (' TEST W3XDMA : ARRAYS ALLOCATED') - 9002 FORMAT (' TEST W3XDMA : POINTERS RESET') - 9003 FORMAT (' TEST W3XDMA : DIMENSIONS STORED') -#endif -!/ -!/ End of W3XDMA ----------------------------------------------------- / -!/ - END SUBROUTINE W3XDMA -!/ ------------------------------------------------------------------- / - SUBROUTINE W3DMNL ( IMOD, NDSE, NDST, NSP, NSPX ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 | -!/ +-----------------------------------+ -!/ -!/ 24-Dec-2004 : Origination. ( version 3.06 ) -!/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ -! 1. Purpose : -! -! Initialize an individual data grid at the proper dimensions (DIA). -! -! 2. Method : -! -! Allocate directly into the structure array. Note that -! this cannot be done through the pointer alias! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! NSP(X) Int. I Array dimensions. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! INSNL1 Subr. W3SNL1MD Traditional DIA approach to Snl. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - Check on input parameters. -! - Check on previous allocation. -! -! 7. Remarks : -! -! - W3SETA needs to be called after allocation to point to -! proper allocated arrays. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: NGRIDS, IGRID, NK, NX, NY, NSEA, NSEAL, & - NSPEC, NTH, GTYPE, UNGTYPE - USE W3ODATMD, ONLY: NAPROC - USE W3SERVMD, ONLY: EXTCDE -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST, NSP, NSPX -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3DMNL') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.1 .OR. IMOD.GT.NADATA ) THEN - WRITE (NDSE,1002) IMOD, NADATA - CALL EXTCDE (2) - END IF -! + call print_memcheck(30000+IAPROC, 'memcheck_____:'//' W3XDMA') + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3XDMA : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3XDMA : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NADATA = ',I10/) +1003 FORMAT (/' *** ERROR W3XDMA : ARRAY(S) ALREADY ALLOCATED *** ') +9000 FORMAT (' TEST W3XDMA : MODEL ',I4) ! W3_T +9001 FORMAT (' TEST W3XDMA : ARRAYS ALLOCATED') +9002 FORMAT (' TEST W3XDMA : POINTERS RESET') +9003 FORMAT (' TEST W3XDMA : DIMENSIONS STORED') + !/ + !/ End of W3XDMA ----------------------------------------------------- / + !/ + END SUBROUTINE W3XDMA + !/ ------------------------------------------------------------------- / + SUBROUTINE W3DMNL ( IMOD, NDSE, NDST, NSP, NSPX ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 | + !/ +-----------------------------------+ + !/ + !/ 24-Dec-2004 : Origination. ( version 3.06 ) + !/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ + ! 1. Purpose : + ! + ! Initialize an individual data grid at the proper dimensions (DIA). + ! + ! 2. Method : + ! + ! Allocate directly into the structure array. Note that + ! this cannot be done through the pointer alias! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! NSP(X) Int. I Array dimensions. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! INSNL1 Subr. W3SNL1MD Traditional DIA approach to Snl. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - Check on input parameters. + ! - Check on previous allocation. + ! + ! 7. Remarks : + ! + ! - W3SETA needs to be called after allocation to point to + ! proper allocated arrays. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: NGRIDS, IGRID, NK, NX, NY, NSEA, NSEAL + USE W3GDATMD, ONLY: NSPEC, NTH, GTYPE, UNGTYPE + USE W3ODATMD, ONLY: NAPROC + USE W3SERVMD, ONLY: EXTCDE + USE W3SERVMD, ONLY: STRACE ! W3_S + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST, NSP, NSPX + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER, SAVE :: IENT = 0 ! W3_S + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'W3DMNL') + end if + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.1 .OR. IMOD.GT.NADATA ) THEN + WRITE (NDSE,1002) IMOD, NADATA + CALL EXTCDE (2) + END IF + ! #ifdef W3_NL1 - IF ( WADATS(IMOD)%NLINIT ) THEN - WRITE (NDSE,1003) - CALL EXTCDE (3) - END IF -#endif -! -#ifdef W3_T - WRITE (NDST,9000) IMOD -#endif -! -! -------------------------------------------------------------------- / -! 2. Allocate arrays -! + IF ( WADATS(IMOD)%NLINIT ) THEN + WRITE (NDSE,1003) + CALL EXTCDE (3) + END IF +#endif + ! + if (w3_t_flag) then + WRITE (NDST,9000) IMOD + end if + ! + ! -------------------------------------------------------------------- / + ! 2. Allocate arrays + ! #ifdef W3_NL1 - ALLOCATE ( WADATS(IMOD)%IP11(NSPX), & - WADATS(IMOD)%IP12(NSPX), & - WADATS(IMOD)%IP13(NSPX), & - WADATS(IMOD)%IP14(NSPX), & - WADATS(IMOD)%IM11(NSPX), & - WADATS(IMOD)%IM12(NSPX), & - WADATS(IMOD)%IM13(NSPX), & - WADATS(IMOD)%IM14(NSPX), & - WADATS(IMOD)%IP21(NSPX), & - WADATS(IMOD)%IP22(NSPX), & - WADATS(IMOD)%IP23(NSPX), & - WADATS(IMOD)%IP24(NSPX), & - WADATS(IMOD)%IM21(NSPX), & - WADATS(IMOD)%IM22(NSPX), & - WADATS(IMOD)%IM23(NSPX), & - WADATS(IMOD)%IM24(NSPX), & - WADATS(IMOD)%IC11(NSP) , & - WADATS(IMOD)%IC12(NSP) , & - WADATS(IMOD)%IC21(NSP) , & - WADATS(IMOD)%IC22(NSP) , & - WADATS(IMOD)%IC31(NSP) , & - WADATS(IMOD)%IC32(NSP) , & - WADATS(IMOD)%IC41(NSP) , & - WADATS(IMOD)%IC42(NSP) , & - WADATS(IMOD)%IC51(NSP) , & - WADATS(IMOD)%IC52(NSP) , & - WADATS(IMOD)%IC61(NSP) , & - WADATS(IMOD)%IC62(NSP) , & - WADATS(IMOD)%IC71(NSP) , & - WADATS(IMOD)%IC72(NSP) , & - WADATS(IMOD)%IC81(NSP) , & - WADATS(IMOD)%IC82(NSP) , & - WADATS(IMOD)%AF11(NSPX), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -#endif -! + ALLOCATE ( WADATS(IMOD)%IP11(NSPX), & + WADATS(IMOD)%IP12(NSPX), & + WADATS(IMOD)%IP13(NSPX), & + WADATS(IMOD)%IP14(NSPX), & + WADATS(IMOD)%IM11(NSPX), & + WADATS(IMOD)%IM12(NSPX), & + WADATS(IMOD)%IM13(NSPX), & + WADATS(IMOD)%IM14(NSPX), & + WADATS(IMOD)%IP21(NSPX), & + WADATS(IMOD)%IP22(NSPX), & + WADATS(IMOD)%IP23(NSPX), & + WADATS(IMOD)%IP24(NSPX), & + WADATS(IMOD)%IM21(NSPX), & + WADATS(IMOD)%IM22(NSPX), & + WADATS(IMOD)%IM23(NSPX), & + WADATS(IMOD)%IM24(NSPX), & + WADATS(IMOD)%IC11(NSP) , & + WADATS(IMOD)%IC12(NSP) , & + WADATS(IMOD)%IC21(NSP) , & + WADATS(IMOD)%IC22(NSP) , & + WADATS(IMOD)%IC31(NSP) , & + WADATS(IMOD)%IC32(NSP) , & + WADATS(IMOD)%IC41(NSP) , & + WADATS(IMOD)%IC42(NSP) , & + WADATS(IMOD)%IC51(NSP) , & + WADATS(IMOD)%IC52(NSP) , & + WADATS(IMOD)%IC61(NSP) , & + WADATS(IMOD)%IC62(NSP) , & + WADATS(IMOD)%IC71(NSP) , & + WADATS(IMOD)%IC72(NSP) , & + WADATS(IMOD)%IC81(NSP) , & + WADATS(IMOD)%IC82(NSP) , & + WADATS(IMOD)%AF11(NSPX), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif + ! #ifdef W3_NL1 - WADATS(IMOD)%NLINIT = .TRUE. -#endif -! -#ifdef W3_T - WRITE (NDST,9001) -#endif -! -! -------------------------------------------------------------------- / -! 3. Point to allocated arrays -! - CALL W3SETA ( IMOD, NDSE, NDST ) -! -#ifdef W3_T - WRITE (NDST,9002) -#endif -! -! -------------------------------------------------------------------- / -! 4. Update counters in grid -! + WADATS(IMOD)%NLINIT = .TRUE. +#endif + ! + if (w3_t_flag) then + WRITE (NDST,9001) + end if + ! + ! -------------------------------------------------------------------- / + ! 3. Point to allocated arrays + ! + CALL W3SETA ( IMOD, NDSE, NDST ) + ! + if (w3_t_flag) then + WRITE (NDST,9002) + end if + ! + ! -------------------------------------------------------------------- / + ! 4. Update counters in grid + ! #ifdef W3_NL1 - NSPECX = NSPX -#endif -! -#ifdef W3_T - WRITE (NDST,9003) -#endif -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3DMNL : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3DMNL : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NADATA = ',I10/) + NSPECX = NSPX +#endif + ! + if (w3_t_flag) then + WRITE (NDST,9003) + end if + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3DMNL : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3DMNL : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NADATA = ',I10/) #ifdef W3_NL1 - 1003 FORMAT (/' *** ERROR W3DMNL : ARRAY(S) ALREADY ALLOCATED *** ') -#endif -! -#ifdef W3_T - 9000 FORMAT (' TEST W3DMNL : MODEL ',I4) - 9001 FORMAT (' TEST W3DMNL : ARRAYS ALLOCATED') - 9002 FORMAT (' TEST W3DMNL : POINTERS RESET') - 9003 FORMAT (' TEST W3DMNL : DIMENSIONS STORED') -#endif -!/ -!/ End of W3DMNL ----------------------------------------------------- / -!/ - END SUBROUTINE W3DMNL -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SETA ( IMOD, NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 28-Dec-2004 : Origination. ( version 3.06 ) -!/ 04-May-2005 : Adding MPI_COMM_WAVE. ( version 3.07 ) -!/ 20-Jul-2005 : Adding output fields. ( version 3.07 ) -!/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) -!/ 13-Jun-2006 : Splitting STORE in G/SSTORE. ( version 3.09 ) -!/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 28_Mar-2007 : Add partitioned data arrays. ( version 3.11 ) -!/ Add aditional undefined arrays. -!/ 22-Mar-2021 : Adds TAUA, WNMEAN, TAUOC parameters ( version 7.13 ) -!/ -! 1. Purpose : -! -! Select one of the WAVEWATCH III grids / models. -! -! 2. Method : -! -! Point pointers to the proper variables in the proper element of -! the GRIDS array. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation below. -! -! 5. Called by : -! -! Many subroutines in the WAVEWATCH system. -! -! 6. Error messages : -! -! Checks on parameter list IMOD. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/MPI Paralllel model environment. -! -! !/PRn Propagation scheme selection. -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3IDATMD, ONLY: INPUTS - USE W3GDATMD, ONLY: E3DF, P2MSF, US3DF, USSPF, GTYPE, UNGTYPE -! - USE W3SERVMD, ONLY: EXTCDE -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3SETA') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NADATA .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.1 .OR. IMOD.GT.NADATA ) THEN - WRITE (NDSE,1002) IMOD, NADATA - CALL EXTCDE (2) - END IF -! -#ifdef W3_T - WRITE (NDST,9000) IMOD -#endif -! -! -------------------------------------------------------------------- / -! 2. Set model numbers -! - IADATA = IMOD -! -! -------------------------------------------------------------------- / -! 3. Set pointers -! - ITIME => WADATS(IMOD)%ITIME - IPASS => WADATS(IMOD)%IPASS - IDLAST => WADATS(IMOD)%IDLAST - NSEALM => WADATS(IMOD)%NSEALM - FLCOLD => WADATS(IMOD)%FLCOLD - FLIWND => WADATS(IMOD)%FLIWND - AINIT => WADATS(IMOD)%AINIT - AINIT2 => WADATS(IMOD)%AINIT2 - FL_ALL => WADATS(IMOD)%FL_ALL -! +1003 FORMAT (/' *** ERROR W3DMNL : ARRAY(S) ALREADY ALLOCATED *** ') +#endif + ! +9000 FORMAT (' TEST W3DMNL : MODEL ',I4) ! W3_T +9001 FORMAT (' TEST W3DMNL : ARRAYS ALLOCATED') +9002 FORMAT (' TEST W3DMNL : POINTERS RESET') +9003 FORMAT (' TEST W3DMNL : DIMENSIONS STORED') + !/ + !/ End of W3DMNL ----------------------------------------------------- / + !/ + END SUBROUTINE W3DMNL + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SETA ( IMOD, NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 28-Dec-2004 : Origination. ( version 3.06 ) + !/ 04-May-2005 : Adding MPI_COMM_WAVE. ( version 3.07 ) + !/ 20-Jul-2005 : Adding output fields. ( version 3.07 ) + !/ 09-Nov-2005 : Removing soft boundary option. ( version 3.08 ) + !/ 13-Jun-2006 : Splitting STORE in G/SSTORE. ( version 3.09 ) + !/ 04-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 28_Mar-2007 : Add partitioned data arrays. ( version 3.11 ) + !/ Add aditional undefined arrays. + !/ 22-Mar-2021 : Adds TAUA, WNMEAN, TAUOC parameters ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Select one of the WAVEWATCH III grids / models. + ! + ! 2. Method : + ! + ! Point pointers to the proper variables in the proper element of + ! the GRIDS array. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation below. + ! + ! 5. Called by : + ! + ! Many subroutines in the WAVEWATCH system. + ! + ! 6. Error messages : + ! + ! Checks on parameter list IMOD. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/MPI Paralllel model environment. + ! + ! !/PRn Propagation scheme selection. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3IDATMD, ONLY: INPUTS + USE W3GDATMD, ONLY: E3DF, P2MSF, US3DF, USSPF, GTYPE, UNGTYPE + ! + USE W3SERVMD, ONLY: EXTCDE + USE W3SERVMD, ONLY: STRACE ! W3_S + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER, SAVE :: IENT = 0 ! W3_S + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'W3SETA') + end if + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NADATA .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.1 .OR. IMOD.GT.NADATA ) THEN + WRITE (NDSE,1002) IMOD, NADATA + CALL EXTCDE (2) + END IF + ! + if (w3_t_flag) then + WRITE (NDST,9000) IMOD + end if + ! + ! -------------------------------------------------------------------- / + ! 2. Set model numbers + ! + IADATA = IMOD + ! + ! -------------------------------------------------------------------- / + ! 3. Set pointers + ! + ITIME => WADATS(IMOD)%ITIME + IPASS => WADATS(IMOD)%IPASS + IDLAST => WADATS(IMOD)%IDLAST + NSEALM => WADATS(IMOD)%NSEALM + FLCOLD => WADATS(IMOD)%FLCOLD + FLIWND => WADATS(IMOD)%FLIWND + AINIT => WADATS(IMOD)%AINIT + AINIT2 => WADATS(IMOD)%AINIT2 + FL_ALL => WADATS(IMOD)%FL_ALL + ! #ifdef W3_PR2 - NMX0 => WADATS(IMOD)%NMX0 - NMX1 => WADATS(IMOD)%NMX1 - NMX2 => WADATS(IMOD)%NMX2 - NMY0 => WADATS(IMOD)%NMY0 - NMY1 => WADATS(IMOD)%NMY1 - NMY2 => WADATS(IMOD)%NMY2 - NACT => WADATS(IMOD)%NACT - NMXY => WADATS(IMOD)%NMXY -#endif -! + NMX0 => WADATS(IMOD)%NMX0 + NMX1 => WADATS(IMOD)%NMX1 + NMX2 => WADATS(IMOD)%NMX2 + NMY0 => WADATS(IMOD)%NMY0 + NMY1 => WADATS(IMOD)%NMY1 + NMY2 => WADATS(IMOD)%NMY2 + NACT => WADATS(IMOD)%NACT + NMXY => WADATS(IMOD)%NMXY +#endif + ! #ifdef W3_PR3 - NMX0 => WADATS(IMOD)%NMX0 - NMX1 => WADATS(IMOD)%NMX1 - NMX2 => WADATS(IMOD)%NMX2 - NMY0 => WADATS(IMOD)%NMY0 - NMY1 => WADATS(IMOD)%NMY1 - NMY2 => WADATS(IMOD)%NMY2 - NACT => WADATS(IMOD)%NACT - NCENT => WADATS(IMOD)%NCENT -#endif -! + NMX0 => WADATS(IMOD)%NMX0 + NMX1 => WADATS(IMOD)%NMX1 + NMX2 => WADATS(IMOD)%NMX2 + NMY0 => WADATS(IMOD)%NMY0 + NMY1 => WADATS(IMOD)%NMY1 + NMY2 => WADATS(IMOD)%NMY2 + NACT => WADATS(IMOD)%NACT + NCENT => WADATS(IMOD)%NCENT +#endif + ! #ifdef W3_NL1 - NFR => WADATS(IMOD)%NFR - NFRHGH => WADATS(IMOD)%NFRHGH - NFRCHG => WADATS(IMOD)%NFRCHG - NSPECX => WADATS(IMOD)%NSPECX - NSPECY => WADATS(IMOD)%NSPECY - DAL1 => WADATS(IMOD)%DAL1 - DAL2 => WADATS(IMOD)%DAL2 - DAL3 => WADATS(IMOD)%DAL3 - AWG1 => WADATS(IMOD)%AWG1 - AWG2 => WADATS(IMOD)%AWG2 - AWG3 => WADATS(IMOD)%AWG3 - AWG4 => WADATS(IMOD)%AWG4 - AWG5 => WADATS(IMOD)%AWG5 - AWG6 => WADATS(IMOD)%AWG6 - AWG7 => WADATS(IMOD)%AWG7 - AWG8 => WADATS(IMOD)%AWG8 - SWG1 => WADATS(IMOD)%SWG1 - SWG2 => WADATS(IMOD)%SWG2 - SWG3 => WADATS(IMOD)%SWG3 - SWG4 => WADATS(IMOD)%SWG4 - SWG5 => WADATS(IMOD)%SWG5 - SWG6 => WADATS(IMOD)%SWG6 - SWG7 => WADATS(IMOD)%SWG7 - SWG8 => WADATS(IMOD)%SWG8 - NLINIT => WADATS(IMOD)%NLINIT -#endif -! -#ifdef W3_MPI - MPI_COMM_WAVE => WADATS(IMOD)%MPI_COMM_WAVE - MPI_COMM_WCMP => WADATS(IMOD)%MPI_COMM_WCMP - WW3_FIELD_VEC => WADATS(IMOD)%WW3_FIELD_VEC - WW3_SPEC_VEC => WADATS(IMOD)%WW3_SPEC_VEC - NRQSG1 => WADATS(IMOD)%NRQSG1 - NRQSG2 => WADATS(IMOD)%NRQSG2 - IBFLOC => WADATS(IMOD)%IBFLOC - ISPLOC => WADATS(IMOD)%ISPLOC - NSPLOC => WADATS(IMOD)%NSPLOC - BSTAT => WADATS(IMOD)%BSTAT - BISPL => WADATS(IMOD)%BISPL -#endif -! - IF ( AINIT ) THEN -! - DW => WADATS(IMOD)%DW - UA => WADATS(IMOD)%UA - UD => WADATS(IMOD)%UD - U10 => WADATS(IMOD)%U10 - U10D => WADATS(IMOD)%U10D - AS => WADATS(IMOD)%AS - CX => WADATS(IMOD)%CX - CY => WADATS(IMOD)%CY - TAUA => WADATS(IMOD)%TAUA - TAUADIR=> WADATS(IMOD)%TAUADIR -! - HS => WADATS(IMOD)%HS - WLM => WADATS(IMOD)%WLM - T02 => WADATS(IMOD)%T02 - T0M1 => WADATS(IMOD)%T0M1 - T01 => WADATS(IMOD)%T01 - FP0 => WADATS(IMOD)%FP0 - THM => WADATS(IMOD)%THM - THS => WADATS(IMOD)%THS - THP0 => WADATS(IMOD)%THP0 - FP1 => WADATS(IMOD)%FP1 - THP1 => WADATS(IMOD)%THP1 - HSIG => WADATS(IMOD)%HSIG - STMAXE => WADATS(IMOD)%STMAXE - STMAXD => WADATS(IMOD)%STMAXD - HMAXE => WADATS(IMOD)%HMAXE - HMAXD => WADATS(IMOD)%HMAXD - HCMAXE => WADATS(IMOD)%HCMAXE - HCMAXD => WADATS(IMOD)%HCMAXD - QP => WADATS(IMOD)%QP - WBT => WADATS(IMOD)%WBT - WNMEAN => WADATS(IMOD)%WNMEAN -! - EF => WADATS(IMOD)%EF - TH1M => WADATS(IMOD)%TH1M - STH1M => WADATS(IMOD)%STH1M - TH2M => WADATS(IMOD)%TH2M - STH2M => WADATS(IMOD)%STH2M -! - PHS => WADATS(IMOD)%PHS - PTP => WADATS(IMOD)%PTP - PLP => WADATS(IMOD)%PLP - PDIR => WADATS(IMOD)%PDIR - PSI => WADATS(IMOD)%PSI - PWS => WADATS(IMOD)%PWS - PWST => WADATS(IMOD)%PWST - PNR => WADATS(IMOD)%PNR - PTHP0 => WADATS(IMOD)%PTHP0 - PQP => WADATS(IMOD)%PQP - PPE => WADATS(IMOD)%PPE - PGW => WADATS(IMOD)%PGW - PSW => WADATS(IMOD)%PSW - PTM1 => WADATS(IMOD)%PTM1 - PT1 => WADATS(IMOD)%PT1 - PT2 => WADATS(IMOD)%PT2 - PEP => WADATS(IMOD)%PEP -! - CHARN => WADATS(IMOD)%CHARN - TWS => WADATS(IMOD)%TWS - CGE => WADATS(IMOD)%CGE - PHIAW => WADATS(IMOD)%PHIAW - TAUWIX => WADATS(IMOD)%TAUWIX - TAUWIY => WADATS(IMOD)%TAUWIY - TAUWNX => WADATS(IMOD)%TAUWNX - TAUWNY => WADATS(IMOD)%TAUWNY - WHITECAP => WADATS(IMOD)%WHITECAP -! - SXX => WADATS(IMOD)%SXX - SYY => WADATS(IMOD)%SYY - SXY => WADATS(IMOD)%SXY - TAUOX => WADATS(IMOD)%TAUOX - TAUOY => WADATS(IMOD)%TAUOY - BHD => WADATS(IMOD)%BHD - PHIOC => WADATS(IMOD)%PHIOC - TUSX => WADATS(IMOD)%TUSX - TUSY => WADATS(IMOD)%TUSY - USSX => WADATS(IMOD)%USSX - USSY => WADATS(IMOD)%USSY - PRMS => WADATS(IMOD)%PRMS - TPMS => WADATS(IMOD)%TPMS - P2SMS => WADATS(IMOD)%P2SMS - US3D => WADATS(IMOD)%US3D - PHICE => WADATS(IMOD)%PHICE - TAUICE => WADATS(IMOD)%TAUICE - USSP => WADATS(IMOD)%USSP - TAUOCX => WADATS(IMOD)%TAUOCX - TAUOCY => WADATS(IMOD)%TAUOCY -! - ABA => WADATS(IMOD)%ABA - ABD => WADATS(IMOD)%ABD - UBA => WADATS(IMOD)%UBA - UBD => WADATS(IMOD)%UBD - BEDFORMS=> WADATS(IMOD)%BEDFORMS - PHIBBL => WADATS(IMOD)%PHIBBL - TAUBBL => WADATS(IMOD)%TAUBBL -! - MSSX => WADATS(IMOD)%MSSX - MSSY => WADATS(IMOD)%MSSY - MSSD => WADATS(IMOD)%MSSD - MSCX => WADATS(IMOD)%MSCX - MSCY => WADATS(IMOD)%MSCY - MSCD => WADATS(IMOD)%MSCD -! - DTDYN => WADATS(IMOD)%DTDYN - FCUT => WADATS(IMOD)%FCUT - CFLXYMAX => WADATS(IMOD)%CFLXYMAX - CFLTHMAX => WADATS(IMOD)%CFLTHMAX - CFLKMAX => WADATS(IMOD)%CFLKMAX -! - USERO => WADATS(IMOD)%USERO -! - WN => WADATS(IMOD)%WN + NFR => WADATS(IMOD)%NFR + NFRHGH => WADATS(IMOD)%NFRHGH + NFRCHG => WADATS(IMOD)%NFRCHG + NSPECX => WADATS(IMOD)%NSPECX + NSPECY => WADATS(IMOD)%NSPECY + DAL1 => WADATS(IMOD)%DAL1 + DAL2 => WADATS(IMOD)%DAL2 + DAL3 => WADATS(IMOD)%DAL3 + AWG1 => WADATS(IMOD)%AWG1 + AWG2 => WADATS(IMOD)%AWG2 + AWG3 => WADATS(IMOD)%AWG3 + AWG4 => WADATS(IMOD)%AWG4 + AWG5 => WADATS(IMOD)%AWG5 + AWG6 => WADATS(IMOD)%AWG6 + AWG7 => WADATS(IMOD)%AWG7 + AWG8 => WADATS(IMOD)%AWG8 + SWG1 => WADATS(IMOD)%SWG1 + SWG2 => WADATS(IMOD)%SWG2 + SWG3 => WADATS(IMOD)%SWG3 + SWG4 => WADATS(IMOD)%SWG4 + SWG5 => WADATS(IMOD)%SWG5 + SWG6 => WADATS(IMOD)%SWG6 + SWG7 => WADATS(IMOD)%SWG7 + SWG8 => WADATS(IMOD)%SWG8 + NLINIT => WADATS(IMOD)%NLINIT +#endif + ! + if (w3_mpi_flag) then + MPI_COMM_WAVE => WADATS(IMOD)%MPI_COMM_WAVE + MPI_COMM_WCMP => WADATS(IMOD)%MPI_COMM_WCMP + WW3_FIELD_VEC => WADATS(IMOD)%WW3_FIELD_VEC + WW3_SPEC_VEC => WADATS(IMOD)%WW3_SPEC_VEC + NRQSG1 => WADATS(IMOD)%NRQSG1 + NRQSG2 => WADATS(IMOD)%NRQSG2 + IBFLOC => WADATS(IMOD)%IBFLOC + ISPLOC => WADATS(IMOD)%ISPLOC + NSPLOC => WADATS(IMOD)%NSPLOC + BSTAT => WADATS(IMOD)%BSTAT + BISPL => WADATS(IMOD)%BISPL + end if + ! + IF ( AINIT ) THEN + ! + DW => WADATS(IMOD)%DW + UA => WADATS(IMOD)%UA + UD => WADATS(IMOD)%UD + U10 => WADATS(IMOD)%U10 + U10D => WADATS(IMOD)%U10D + AS => WADATS(IMOD)%AS + CX => WADATS(IMOD)%CX + CY => WADATS(IMOD)%CY + TAUA => WADATS(IMOD)%TAUA + TAUADIR=> WADATS(IMOD)%TAUADIR + ! + HS => WADATS(IMOD)%HS + WLM => WADATS(IMOD)%WLM + T02 => WADATS(IMOD)%T02 + T0M1 => WADATS(IMOD)%T0M1 + T01 => WADATS(IMOD)%T01 + FP0 => WADATS(IMOD)%FP0 + THM => WADATS(IMOD)%THM + THS => WADATS(IMOD)%THS + THP0 => WADATS(IMOD)%THP0 + FP1 => WADATS(IMOD)%FP1 + THP1 => WADATS(IMOD)%THP1 + HSIG => WADATS(IMOD)%HSIG + STMAXE => WADATS(IMOD)%STMAXE + STMAXD => WADATS(IMOD)%STMAXD + HMAXE => WADATS(IMOD)%HMAXE + HMAXD => WADATS(IMOD)%HMAXD + HCMAXE => WADATS(IMOD)%HCMAXE + HCMAXD => WADATS(IMOD)%HCMAXD + QP => WADATS(IMOD)%QP + WBT => WADATS(IMOD)%WBT + WNMEAN => WADATS(IMOD)%WNMEAN + ! + EF => WADATS(IMOD)%EF + TH1M => WADATS(IMOD)%TH1M + STH1M => WADATS(IMOD)%STH1M + TH2M => WADATS(IMOD)%TH2M + STH2M => WADATS(IMOD)%STH2M + ! + PHS => WADATS(IMOD)%PHS + PTP => WADATS(IMOD)%PTP + PLP => WADATS(IMOD)%PLP + PDIR => WADATS(IMOD)%PDIR + PSI => WADATS(IMOD)%PSI + PWS => WADATS(IMOD)%PWS + PWST => WADATS(IMOD)%PWST + PNR => WADATS(IMOD)%PNR + PTHP0 => WADATS(IMOD)%PTHP0 + PQP => WADATS(IMOD)%PQP + PPE => WADATS(IMOD)%PPE + PGW => WADATS(IMOD)%PGW + PSW => WADATS(IMOD)%PSW + PTM1 => WADATS(IMOD)%PTM1 + PT1 => WADATS(IMOD)%PT1 + PT2 => WADATS(IMOD)%PT2 + PEP => WADATS(IMOD)%PEP + ! + CHARN => WADATS(IMOD)%CHARN + TWS => WADATS(IMOD)%TWS + CGE => WADATS(IMOD)%CGE + PHIAW => WADATS(IMOD)%PHIAW + TAUWIX => WADATS(IMOD)%TAUWIX + TAUWIY => WADATS(IMOD)%TAUWIY + TAUWNX => WADATS(IMOD)%TAUWNX + TAUWNY => WADATS(IMOD)%TAUWNY + WHITECAP => WADATS(IMOD)%WHITECAP + ! + SXX => WADATS(IMOD)%SXX + SYY => WADATS(IMOD)%SYY + SXY => WADATS(IMOD)%SXY + TAUOX => WADATS(IMOD)%TAUOX + TAUOY => WADATS(IMOD)%TAUOY + BHD => WADATS(IMOD)%BHD + PHIOC => WADATS(IMOD)%PHIOC + TUSX => WADATS(IMOD)%TUSX + TUSY => WADATS(IMOD)%TUSY + USSX => WADATS(IMOD)%USSX + USSY => WADATS(IMOD)%USSY + PRMS => WADATS(IMOD)%PRMS + TPMS => WADATS(IMOD)%TPMS + P2SMS => WADATS(IMOD)%P2SMS + US3D => WADATS(IMOD)%US3D + PHICE => WADATS(IMOD)%PHICE + TAUICE => WADATS(IMOD)%TAUICE + USSP => WADATS(IMOD)%USSP + TAUOCX => WADATS(IMOD)%TAUOCX + TAUOCY => WADATS(IMOD)%TAUOCY + ! + ABA => WADATS(IMOD)%ABA + ABD => WADATS(IMOD)%ABD + UBA => WADATS(IMOD)%UBA + UBD => WADATS(IMOD)%UBD + BEDFORMS=> WADATS(IMOD)%BEDFORMS + PHIBBL => WADATS(IMOD)%PHIBBL + TAUBBL => WADATS(IMOD)%TAUBBL + ! + MSSX => WADATS(IMOD)%MSSX + MSSY => WADATS(IMOD)%MSSY + MSSD => WADATS(IMOD)%MSSD + MSCX => WADATS(IMOD)%MSCX + MSCY => WADATS(IMOD)%MSCY + MSCD => WADATS(IMOD)%MSCD + ! + DTDYN => WADATS(IMOD)%DTDYN + FCUT => WADATS(IMOD)%FCUT + CFLXYMAX => WADATS(IMOD)%CFLXYMAX + CFLTHMAX => WADATS(IMOD)%CFLTHMAX + CFLKMAX => WADATS(IMOD)%CFLKMAX + ! + USERO => WADATS(IMOD)%USERO + ! + WN => WADATS(IMOD)%WN #ifdef W3_CESMCOUPLED - ! USSX and USSY are already set - LANGMT => WADATS(IMOD)%LANGMT - LAPROJ => WADATS(IMOD)%LAPROJ - LASL => WADATS(IMOD)%LASL - LASLPJ => WADATS(IMOD)%LASLPJ - ALPHAL => WADATS(IMOD)%ALPHAL - ALPHALS=> WADATS(IMOD)%ALPHALS - USSXH => WADATS(IMOD)%USSXH - USSYH => WADATS(IMOD)%USSYH - LAMULT => WADATS(IMOD)%LAMULT + ! USSX and USSY are already set + LANGMT => WADATS(IMOD)%LANGMT + LAPROJ => WADATS(IMOD)%LAPROJ + LASL => WADATS(IMOD)%LASL + LASLPJ => WADATS(IMOD)%LASLPJ + ALPHAL => WADATS(IMOD)%ALPHAL + ALPHALS=> WADATS(IMOD)%ALPHALS + USSXH => WADATS(IMOD)%USSXH + USSYH => WADATS(IMOD)%USSYH + LAMULT => WADATS(IMOD)%LAMULT #endif #ifdef W3_IC3 - IC3WN_R=> WADATS(IMOD)%IC3WN_R - IC3WN_I=> WADATS(IMOD)%IC3WN_I + IC3WN_R=> WADATS(IMOD)%IC3WN_R + IC3WN_I=> WADATS(IMOD)%IC3WN_I #endif -! - IF ( FL_ALL ) THEN -! - CG => WADATS(IMOD)%CG + ! + IF ( FL_ALL ) THEN + ! + CG => WADATS(IMOD)%CG #ifdef W3_IC3 - IC3CG => WADATS(IMOD)%IC3CG -#endif -! - ATRNX => WADATS(IMOD)%ATRNX - ATRNY => WADATS(IMOD)%ATRNY -! - DDDX => WADATS(IMOD)%DDDX - DDDY => WADATS(IMOD)%DDDY - DCDX => WADATS(IMOD)%DCDX - DCDY => WADATS(IMOD)%DCDY - DCXDX => WADATS(IMOD)%DCXDX - DCYDX => WADATS(IMOD)%DCYDX - DCXDY => WADATS(IMOD)%DCXDY - DCYDY => WADATS(IMOD)%DCYDY -! + IC3CG => WADATS(IMOD)%IC3CG +#endif + ! + ATRNX => WADATS(IMOD)%ATRNX + ATRNY => WADATS(IMOD)%ATRNY + ! + DDDX => WADATS(IMOD)%DDDX + DDDY => WADATS(IMOD)%DDDY + DCDX => WADATS(IMOD)%DCDX + DCDY => WADATS(IMOD)%DCDY + DCXDX => WADATS(IMOD)%DCXDX + DCYDX => WADATS(IMOD)%DCYDX + DCXDY => WADATS(IMOD)%DCXDY + DCYDY => WADATS(IMOD)%DCYDY + ! #ifdef W3_SMC - DHDX => WADATS(IMOD)%DHDX - DHDY => WADATS(IMOD)%DHDY - DHLMT => WADATS(IMOD)%DHLMT -#endif -! - ALPHA => WADATS(IMOD)%ALPHA -! - IF ( INPUTS(IMOD)%INFLAGS1(2) ) THEN - CA0 => WADATS(IMOD)%CA0 - CAI => WADATS(IMOD)%CAI - CD0 => WADATS(IMOD)%CD0 - CDI => WADATS(IMOD)%CDI - END IF -! - IF ( INPUTS(IMOD)%INFLAGS1(3) ) THEN - UA0 => WADATS(IMOD)%UA0 - UAI => WADATS(IMOD)%UAI - UD0 => WADATS(IMOD)%UD0 - UDI => WADATS(IMOD)%UDI - AS0 => WADATS(IMOD)%AS0 - ASI => WADATS(IMOD)%ASI - END IF -! - IF ( INPUTS(IMOD)%INFLAGS1(5) ) THEN - MA0 => WADATS(IMOD)%MA0 - MAI => WADATS(IMOD)%MAI - MD0 => WADATS(IMOD)%MD0 - MDI => WADATS(IMOD)%MDI - END IF -! - IF ( INPUTS(IMOD)%INFLAGS1(6) ) THEN - RA0 => WADATS(IMOD)%RA0 - RAI => WADATS(IMOD)%RAI - END IF -! + DHDX => WADATS(IMOD)%DHDX + DHDY => WADATS(IMOD)%DHDY + DHLMT => WADATS(IMOD)%DHLMT +#endif + ! + ALPHA => WADATS(IMOD)%ALPHA + ! + IF ( INPUTS(IMOD)%INFLAGS1(2) ) THEN + CA0 => WADATS(IMOD)%CA0 + CAI => WADATS(IMOD)%CAI + CD0 => WADATS(IMOD)%CD0 + CDI => WADATS(IMOD)%CDI + END IF + ! + IF ( INPUTS(IMOD)%INFLAGS1(3) ) THEN + UA0 => WADATS(IMOD)%UA0 + UAI => WADATS(IMOD)%UAI + UD0 => WADATS(IMOD)%UD0 + UDI => WADATS(IMOD)%UDI + AS0 => WADATS(IMOD)%AS0 + ASI => WADATS(IMOD)%ASI + END IF + ! + IF ( INPUTS(IMOD)%INFLAGS1(5) ) THEN + MA0 => WADATS(IMOD)%MA0 + MAI => WADATS(IMOD)%MAI + MD0 => WADATS(IMOD)%MD0 + MDI => WADATS(IMOD)%MDI + END IF + ! + IF ( INPUTS(IMOD)%INFLAGS1(6) ) THEN + RA0 => WADATS(IMOD)%RA0 + RAI => WADATS(IMOD)%RAI + END IF + ! #ifdef W3_PR1 - IS0 => WADATS(IMOD)%IS0 - IS2 => WADATS(IMOD)%IS2 - FACVX => WADATS(IMOD)%FACVX - FACVY => WADATS(IMOD)%FACVY + IS0 => WADATS(IMOD)%IS0 + IS2 => WADATS(IMOD)%IS2 + FACVX => WADATS(IMOD)%FACVX + FACVY => WADATS(IMOD)%FACVY #endif -! + ! #ifdef W3_PR2 - MAPX2 => WADATS(IMOD)%MAPX2 - MAPY2 => WADATS(IMOD)%MAPY2 - MAPAXY => WADATS(IMOD)%MAPAXY - MAPXY => WADATS(IMOD)%MAPXY - MAPTH2 => WADATS(IMOD)%MAPTH2 - MAPWN2 => WADATS(IMOD)%MAPWN2 -#endif -! + MAPX2 => WADATS(IMOD)%MAPX2 + MAPY2 => WADATS(IMOD)%MAPY2 + MAPAXY => WADATS(IMOD)%MAPAXY + MAPXY => WADATS(IMOD)%MAPXY + MAPTH2 => WADATS(IMOD)%MAPTH2 + MAPWN2 => WADATS(IMOD)%MAPWN2 +#endif + ! #ifdef W3_PR3 - MAPX2 => WADATS(IMOD)%MAPX2 - MAPY2 => WADATS(IMOD)%MAPY2 - MAPAXY => WADATS(IMOD)%MAPAXY - MAPCXY => WADATS(IMOD)%MAPCXY - MAPTH2 => WADATS(IMOD)%MAPTH2 - MAPWN2 => WADATS(IMOD)%MAPWN2 - MAPTRN => WADATS(IMOD)%MAPTRN -#endif -! - IF (GTYPE .EQ. UNGTYPE) ITER => WADATS(IMOD)%ITER -! - IAPPRO => WADATS(IMOD)%IAPPRO - SPPNT => WADATS(IMOD)%SPPNT -! - END IF -! - END IF -! + MAPX2 => WADATS(IMOD)%MAPX2 + MAPY2 => WADATS(IMOD)%MAPY2 + MAPAXY => WADATS(IMOD)%MAPAXY + MAPCXY => WADATS(IMOD)%MAPCXY + MAPTH2 => WADATS(IMOD)%MAPTH2 + MAPWN2 => WADATS(IMOD)%MAPWN2 + MAPTRN => WADATS(IMOD)%MAPTRN +#endif + ! + IF (GTYPE .EQ. UNGTYPE) ITER => WADATS(IMOD)%ITER + ! + IAPPRO => WADATS(IMOD)%IAPPRO + SPPNT => WADATS(IMOD)%SPPNT + ! + END IF + ! + END IF + ! #ifdef W3_NL1 - IF ( NLINIT ) THEN - IP11 => WADATS(IMOD)%IP11 - IP12 => WADATS(IMOD)%IP12 - IP13 => WADATS(IMOD)%IP13 - IP14 => WADATS(IMOD)%IP14 - IM11 => WADATS(IMOD)%IM11 - IM12 => WADATS(IMOD)%IM12 - IM13 => WADATS(IMOD)%IM13 - IM14 => WADATS(IMOD)%IM14 - IP21 => WADATS(IMOD)%IP21 - IP22 => WADATS(IMOD)%IP22 - IP23 => WADATS(IMOD)%IP23 - IP24 => WADATS(IMOD)%IP24 - IM21 => WADATS(IMOD)%IM21 - IM22 => WADATS(IMOD)%IM22 - IM23 => WADATS(IMOD)%IM23 - IM24 => WADATS(IMOD)%IM24 - IC11 => WADATS(IMOD)%IC11 - IC12 => WADATS(IMOD)%IC12 - IC21 => WADATS(IMOD)%IC21 - IC22 => WADATS(IMOD)%IC22 - IC31 => WADATS(IMOD)%IC31 - IC32 => WADATS(IMOD)%IC32 - IC41 => WADATS(IMOD)%IC41 - IC42 => WADATS(IMOD)%IC42 - IC51 => WADATS(IMOD)%IC51 - IC52 => WADATS(IMOD)%IC52 - IC61 => WADATS(IMOD)%IC61 - IC62 => WADATS(IMOD)%IC62 - IC71 => WADATS(IMOD)%IC71 - IC72 => WADATS(IMOD)%IC72 - IC81 => WADATS(IMOD)%IC81 - IC82 => WADATS(IMOD)%IC82 - AF11 => WADATS(IMOD)%AF11 - END IF + IF ( NLINIT ) THEN + IP11 => WADATS(IMOD)%IP11 + IP12 => WADATS(IMOD)%IP12 + IP13 => WADATS(IMOD)%IP13 + IP14 => WADATS(IMOD)%IP14 + IM11 => WADATS(IMOD)%IM11 + IM12 => WADATS(IMOD)%IM12 + IM13 => WADATS(IMOD)%IM13 + IM14 => WADATS(IMOD)%IM14 + IP21 => WADATS(IMOD)%IP21 + IP22 => WADATS(IMOD)%IP22 + IP23 => WADATS(IMOD)%IP23 + IP24 => WADATS(IMOD)%IP24 + IM21 => WADATS(IMOD)%IM21 + IM22 => WADATS(IMOD)%IM22 + IM23 => WADATS(IMOD)%IM23 + IM24 => WADATS(IMOD)%IM24 + IC11 => WADATS(IMOD)%IC11 + IC12 => WADATS(IMOD)%IC12 + IC21 => WADATS(IMOD)%IC21 + IC22 => WADATS(IMOD)%IC22 + IC31 => WADATS(IMOD)%IC31 + IC32 => WADATS(IMOD)%IC32 + IC41 => WADATS(IMOD)%IC41 + IC42 => WADATS(IMOD)%IC42 + IC51 => WADATS(IMOD)%IC51 + IC52 => WADATS(IMOD)%IC52 + IC61 => WADATS(IMOD)%IC61 + IC62 => WADATS(IMOD)%IC62 + IC71 => WADATS(IMOD)%IC71 + IC72 => WADATS(IMOD)%IC72 + IC81 => WADATS(IMOD)%IC81 + IC82 => WADATS(IMOD)%IC82 + AF11 => WADATS(IMOD)%AF11 + END IF #endif - #ifdef W3_MPI - IF ( NRQSG1 .NE. 0 ) THEN - IRQSG1 => WADATS(IMOD)%IRQSG1 - IRQSG2 => WADATS(IMOD)%IRQSG2 - END IF + IF ( NRQSG1 .NE. 0 ) THEN + IRQSG1 => WADATS(IMOD)%IRQSG1 + IRQSG2 => WADATS(IMOD)%IRQSG2 + END IF #endif -! + ! #ifdef W3_MPI - GSTORE => WADATS(IMOD)%GSTORE - SSTORE => WADATS(IMOD)%SSTORE -#endif -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3SETA : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3SETA : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NADATA = ',I10/) -! -#ifdef W3_T - 9000 FORMAT (' TEST W3SETA : MODEL ',I4,' SELECTED') -#endif -!/ -!/ End of W3SETA ----------------------------------------------------- / -!/ - END SUBROUTINE W3SETA -!/ ------------------------------------------------------------------- / - SUBROUTINE W3XETA ( IMOD, NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 25-Dec-2012 : Origination. ( version 4.11 ) -!/ 30-Apr-2014 : Add s/th1-2m ( version 5.01 ) -!/ 22-Mar-2021 : Adds WNMEAN, TAUOC parameters ( version 7.13 ) -!/ -! 1. Purpose : -! -! Reduced version of W3SETA to point t expended output arrays. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! - USE W3IDATMD, ONLY: INPUTS - USE W3GDATMD, ONLY: E3DF, P2MSF, US3DF, USSPF, GTYPE, UNGTYPE -! - USE W3SERVMD, ONLY: EXTCDE -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3XETA') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NADATA .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.1 .OR. IMOD.GT.NADATA ) THEN - WRITE (NDSE,1002) IMOD, NADATA - CALL EXTCDE (2) - END IF -! -#ifdef W3_T - WRITE (NDST,9000) IMOD -#endif -! -! -------------------------------------------------------------------- / -! 2. Set model numbers -! - IADATA = IMOD -! -! -------------------------------------------------------------------- / -! 3. Set pointers -! - IF ( AINIT2 ) THEN -! - HS => WADATS(IMOD)%XHS - WLM => WADATS(IMOD)%XWLM - T02 => WADATS(IMOD)%XT02 - T0M1 => WADATS(IMOD)%XT0M1 - T01 => WADATS(IMOD)%XT01 - FP0 => WADATS(IMOD)%XFP0 - THM => WADATS(IMOD)%XTHM - THS => WADATS(IMOD)%XTHS - THP0 => WADATS(IMOD)%XTHP0 - HSIG => WADATS(IMOD)%XHSIG - STMAXE => WADATS(IMOD)%XSTMAXE - STMAXD => WADATS(IMOD)%XSTMAXD - HMAXE => WADATS(IMOD)%XHMAXE - HMAXD => WADATS(IMOD)%XHMAXD - HCMAXE => WADATS(IMOD)%XHCMAXE - HCMAXD => WADATS(IMOD)%XHCMAXD - QP => WADATS(IMOD)%XQP - WBT => WADATS(IMOD)%XWBT - WNMEAN => WADATS(IMOD)%XWNMEAN -! FP1 => WADATS(IMOD)%XFP1 -! THP1 => WADATS(IMOD)%XTHP1 -! - EF => WADATS(IMOD)%XEF - TH1M => WADATS(IMOD)%XTH1M - STH1M => WADATS(IMOD)%XSTH1M - TH2M => WADATS(IMOD)%XTH2M - STH2M => WADATS(IMOD)%XSTH2M -! - PHS => WADATS(IMOD)%XPHS - PTP => WADATS(IMOD)%XPTP - PLP => WADATS(IMOD)%XPLP - PDIR => WADATS(IMOD)%XPDIR - PSI => WADATS(IMOD)%XPSI - PWS => WADATS(IMOD)%XPWS - PWST => WADATS(IMOD)%XPWST - PNR => WADATS(IMOD)%XPNR - PTHP0 => WADATS(IMOD)%XPTHP0 - PQP => WADATS(IMOD)%XPQP - PPE => WADATS(IMOD)%XPPE - PGW => WADATS(IMOD)%XPGW - PSW => WADATS(IMOD)%XPSW - PTM1 => WADATS(IMOD)%XPTM1 - PT1 => WADATS(IMOD)%XPT1 - PT2 => WADATS(IMOD)%XPT2 - PEP => WADATS(IMOD)%XPEP -! - CHARN => WADATS(IMOD)%XCHARN - TWS => WADATS(IMOD)%XTWS - CGE => WADATS(IMOD)%XCGE - PHIAW => WADATS(IMOD)%XPHIAW - TAUWIX => WADATS(IMOD)%XTAUWIX - TAUWIY => WADATS(IMOD)%XTAUWIY - TAUWNX => WADATS(IMOD)%XTAUWNX - TAUWNY => WADATS(IMOD)%XTAUWNY - WHITECAP => WADATS(IMOD)%XWHITECAP -! - SXX => WADATS(IMOD)%XSXX - SYY => WADATS(IMOD)%XSYY - SXY => WADATS(IMOD)%XSXY - TAUOX => WADATS(IMOD)%XTAUOX - TAUOY => WADATS(IMOD)%XTAUOY - BHD => WADATS(IMOD)%XBHD - PHIOC => WADATS(IMOD)%XPHIOC - TUSX => WADATS(IMOD)%XTUSX - TUSY => WADATS(IMOD)%XTUSY - USSX => WADATS(IMOD)%XUSSX - USSY => WADATS(IMOD)%XUSSY - PRMS => WADATS(IMOD)%XPRMS - TPMS => WADATS(IMOD)%XTPMS - P2SMS => WADATS(IMOD)%XP2SMS - US3D => WADATS(IMOD)%XUS3D - PHICE => WADATS(IMOD)%XPHICE - TAUICE => WADATS(IMOD)%XTAUICE - USSP => WADATS(IMOD)%XUSSP - TAUOCX => WADATS(IMOD)%XTAUOCX - TAUOCY => WADATS(IMOD)%XTAUOCY - ABA => WADATS(IMOD)%XABA - ABD => WADATS(IMOD)%XABD - UBA => WADATS(IMOD)%XUBA - UBD => WADATS(IMOD)%XUBD - BEDFORMS=> WADATS(IMOD)%XBEDFORMS - PHIBBL => WADATS(IMOD)%XPHIBBL - TAUBBL => WADATS(IMOD)%XTAUBBL + GSTORE => WADATS(IMOD)%GSTORE + SSTORE => WADATS(IMOD)%SSTORE +#endif + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3SETA : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3SETA : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NADATA = ',I10/) + ! +9000 FORMAT (' TEST W3SETA : MODEL ',I4,' SELECTED') ! W3_T + !/ + !/ End of W3SETA ----------------------------------------------------- / + !/ + END SUBROUTINE W3SETA + !/ ------------------------------------------------------------------- / + SUBROUTINE W3XETA ( IMOD, NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 25-Dec-2012 : Origination. ( version 4.11 ) + !/ 30-Apr-2014 : Add s/th1-2m ( version 5.01 ) + !/ 22-Mar-2021 : Adds WNMEAN, TAUOC parameters ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Reduced version of W3SETA to point t expended output arrays. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3IDATMD, ONLY: INPUTS + USE W3GDATMD, ONLY: E3DF, P2MSF, US3DF, USSPF, GTYPE, UNGTYPE + ! + USE W3SERVMD, ONLY: EXTCDE + USE W3SERVMD, ONLY: STRACE ! W3_S + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER, SAVE :: IENT = 0 ! W3_S + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'W3XETA') + end if + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NADATA .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.1 .OR. IMOD.GT.NADATA ) THEN + WRITE (NDSE,1002) IMOD, NADATA + CALL EXTCDE (2) + END IF + ! + if (w3_t_flag) then + WRITE (NDST,9000) IMOD + end if + ! + ! -------------------------------------------------------------------- / + ! 2. Set model numbers + ! + IADATA = IMOD + ! + ! -------------------------------------------------------------------- / + ! 3. Set pointers + ! + IF ( AINIT2 ) THEN + ! + HS => WADATS(IMOD)%XHS + WLM => WADATS(IMOD)%XWLM + T02 => WADATS(IMOD)%XT02 + T0M1 => WADATS(IMOD)%XT0M1 + T01 => WADATS(IMOD)%XT01 + FP0 => WADATS(IMOD)%XFP0 + THM => WADATS(IMOD)%XTHM + THS => WADATS(IMOD)%XTHS + THP0 => WADATS(IMOD)%XTHP0 + HSIG => WADATS(IMOD)%XHSIG + STMAXE => WADATS(IMOD)%XSTMAXE + STMAXD => WADATS(IMOD)%XSTMAXD + HMAXE => WADATS(IMOD)%XHMAXE + HMAXD => WADATS(IMOD)%XHMAXD + HCMAXE => WADATS(IMOD)%XHCMAXE + HCMAXD => WADATS(IMOD)%XHCMAXD + QP => WADATS(IMOD)%XQP + WBT => WADATS(IMOD)%XWBT + WNMEAN => WADATS(IMOD)%XWNMEAN + ! FP1 => WADATS(IMOD)%XFP1 + ! THP1 => WADATS(IMOD)%XTHP1 + ! + EF => WADATS(IMOD)%XEF + TH1M => WADATS(IMOD)%XTH1M + STH1M => WADATS(IMOD)%XSTH1M + TH2M => WADATS(IMOD)%XTH2M + STH2M => WADATS(IMOD)%XSTH2M + ! + PHS => WADATS(IMOD)%XPHS + PTP => WADATS(IMOD)%XPTP + PLP => WADATS(IMOD)%XPLP + PDIR => WADATS(IMOD)%XPDIR + PSI => WADATS(IMOD)%XPSI + PWS => WADATS(IMOD)%XPWS + PWST => WADATS(IMOD)%XPWST + PNR => WADATS(IMOD)%XPNR + PTHP0 => WADATS(IMOD)%XPTHP0 + PQP => WADATS(IMOD)%XPQP + PPE => WADATS(IMOD)%XPPE + PGW => WADATS(IMOD)%XPGW + PSW => WADATS(IMOD)%XPSW + PTM1 => WADATS(IMOD)%XPTM1 + PT1 => WADATS(IMOD)%XPT1 + PT2 => WADATS(IMOD)%XPT2 + PEP => WADATS(IMOD)%XPEP + ! + CHARN => WADATS(IMOD)%XCHARN + TWS => WADATS(IMOD)%XTWS + CGE => WADATS(IMOD)%XCGE + PHIAW => WADATS(IMOD)%XPHIAW + TAUWIX => WADATS(IMOD)%XTAUWIX + TAUWIY => WADATS(IMOD)%XTAUWIY + TAUWNX => WADATS(IMOD)%XTAUWNX + TAUWNY => WADATS(IMOD)%XTAUWNY + WHITECAP => WADATS(IMOD)%XWHITECAP + ! + SXX => WADATS(IMOD)%XSXX + SYY => WADATS(IMOD)%XSYY + SXY => WADATS(IMOD)%XSXY + TAUOX => WADATS(IMOD)%XTAUOX + TAUOY => WADATS(IMOD)%XTAUOY + BHD => WADATS(IMOD)%XBHD + PHIOC => WADATS(IMOD)%XPHIOC + TUSX => WADATS(IMOD)%XTUSX + TUSY => WADATS(IMOD)%XTUSY + USSX => WADATS(IMOD)%XUSSX + USSY => WADATS(IMOD)%XUSSY + PRMS => WADATS(IMOD)%XPRMS + TPMS => WADATS(IMOD)%XTPMS + P2SMS => WADATS(IMOD)%XP2SMS + US3D => WADATS(IMOD)%XUS3D + PHICE => WADATS(IMOD)%XPHICE + TAUICE => WADATS(IMOD)%XTAUICE + USSP => WADATS(IMOD)%XUSSP + TAUOCX => WADATS(IMOD)%XTAUOCX + TAUOCY => WADATS(IMOD)%XTAUOCY + ABA => WADATS(IMOD)%XABA + ABD => WADATS(IMOD)%XABD + UBA => WADATS(IMOD)%XUBA + UBD => WADATS(IMOD)%XUBD + BEDFORMS=> WADATS(IMOD)%XBEDFORMS + PHIBBL => WADATS(IMOD)%XPHIBBL + TAUBBL => WADATS(IMOD)%XTAUBBL #ifdef W3_CESMCOUPLED - LANGMT => WADATS(IMOD)%XLANGMT -#endif -! - MSSX => WADATS(IMOD)%XMSSX - MSSY => WADATS(IMOD)%XMSSY - MSSD => WADATS(IMOD)%XMSSD - MSCX => WADATS(IMOD)%XMSCX - MSCY => WADATS(IMOD)%XMSCY - MSCD => WADATS(IMOD)%XMSCD -! - DTDYN => WADATS(IMOD)%XDTDYN - FCUT => WADATS(IMOD)%XFCUT - CFLXYMAX => WADATS(IMOD)%XCFLXYMAX - CFLTHMAX => WADATS(IMOD)%XCFLTHMAX - CFLKMAX => WADATS(IMOD)%XCFLKMAX -! - USERO => WADATS(IMOD)%XUSERO -! - END IF -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3XETA : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3XETA : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NADATA = ',I10/) -! -#ifdef W3_T - 9000 FORMAT (' TEST W3XETA : MODEL ',I4,' SELECTED') -#endif -!/ -!/ End of W3XETA ----------------------------------------------------- / -!/ - END SUBROUTINE W3XETA -!/ -!/ End of module W3ADATMD -------------------------------------------- / -!/ - END MODULE W3ADATMD + LANGMT => WADATS(IMOD)%XLANGMT +#endif + ! + MSSX => WADATS(IMOD)%XMSSX + MSSY => WADATS(IMOD)%XMSSY + MSSD => WADATS(IMOD)%XMSSD + MSCX => WADATS(IMOD)%XMSCX + MSCY => WADATS(IMOD)%XMSCY + MSCD => WADATS(IMOD)%XMSCD + ! + DTDYN => WADATS(IMOD)%XDTDYN + FCUT => WADATS(IMOD)%XFCUT + CFLXYMAX => WADATS(IMOD)%XCFLXYMAX + CFLTHMAX => WADATS(IMOD)%XCFLTHMAX + CFLKMAX => WADATS(IMOD)%XCFLKMAX + ! + USERO => WADATS(IMOD)%XUSERO + ! + END IF + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3XETA : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3XETA : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NADATA = ',I10/) + ! +9000 FORMAT (' TEST W3XETA : MODEL ',I4,' SELECTED') ! W3_T + !/ + !/ End of W3XETA ----------------------------------------------------- / + !/ + END SUBROUTINE W3XETA + !/ + !/ End of module W3ADATMD -------------------------------------------- / + !/ +END MODULE W3ADATMD diff --git a/model/src/w3gdatmd.F90 b/model/src/w3gdatmd.F90 index ebfebb20cc..ef8d72637d 100644 --- a/model/src/w3gdatmd.F90 +++ b/model/src/w3gdatmd.F90 @@ -13,3541 +13,3433 @@ #define TEST_W3GDATMD_W3SETREF___disabled !/ !/ ------------------------------------------------------------------- / - MODULE W3GDATMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ ! J. H. Alves ! -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 15-Apr-2020 | -!/ +-----------------------------------+ -!/ -!/ 24-Jun-2005 : Origination. ( version 3.07 ) -!/ 09-Nov-2005 : Remove soft boundary options. ( version 3.08 ) -!/ 23-Jun-2006 : Add data for W3SLN1. ( version 3.09 ) -!/ 18-Jul-2006 : Add input grids. ( version 3.10 ) -!/ 05-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 02-Feb-2007 : Add FLAGST. ( version 3.10 ) -!/ 14-Apr-2007 : Add Miche style limiter. ( version 3.11 ) -!/ ( J. H. Alves ) -!/ 25-Apr-2007 : Adding Battjes-Janssen Sdb. ( version 3.11 ) -!/ ( J. H. Alves ) -!/ 06-Aug-2007 : Fixing SLNP !/SEED bug. ( version 3.13 ) -!/ 18-Sep-2007 : Adding WAM4 source terms. ( version 3.13 ) -!/ ( F. Ardhuin ) -!/ 15-Apr-2008 : Clean up for distribution. ( version 3.14 ) -!/ 27-Jun-2008 : Expand WAM4 variants namelist ( version 3.14 ) -!/ ( F. Ardhuin ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 29-Oct-2010 : Implement unstructured grids ( version 3.14.1 ) -!/ (A. Roland and F. Ardhuin) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 23-Dec-2010 : Fix HPFAC and HQFAC by including the COS(YGRD) -!/ factor with DXDP and DXDQ terms. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 05-Apr-2011 : Implement interations for DTMAX < 1s( version 3.14.1 ) -!/ (F. Ardhuin) -!/ 01-Jul-2011 : Movable bed bottom friction BT4 ( version 4.01 ) -!/ 03-Nov-2011 : Bug fix: GUGINIT initialization ( version 4.04 ) -!/ 29-Nov-2011 : Adding ST6 source term option. ( version 4.04 ) -!/ (S. Zieger) -!/ 14-Mar-2012 : Add PSIC for BT4 ( version 4.04 ) -!/ 12-Jun-2012 : Add /RTD option or rotated grid variables. -!/ (Jian-Guo Li) ( version 4.06 ) -!/ 13-Jul-2012 : Move data structures GMD (SNL3) and nonlinear -!/ filter (SNLS) from 3.15 (HLT). ( version 4.08 ) -!/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) -!/ 12-Dec-2012 : Adding SMC grid. JG_Li ( version 4.09 ) -!/ 16-Sep-2013 : Add Arctic part SMC grid. ( version 4.11 ) -!/ 11-Nov-2013 : SMC and rotated grid incorporated in the main -!/ trunk ( version 4.13 ) -!/ 16-Nov-2013 : Allows reflection on curvi grids ( version 4.14 ) -!/ 26-Jul-2013 : Adding IG waves ( version 4.16 ) -!/ 18-Dec-2013 : Moving FLAGLL into GRID TYPE ( version 4.16 ) -!/ 11-Jun-2014 : Changed reflection for subgrid ( version 5.01 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 21-Aug-2015 : Add SMC FUNO3, FVERG options. JGLi ( version 5.09 ) -!/ 04-May-2016 : Add IICEDISP GB&FA ( version 5.10 ) -!/ 20-Jan-2017 : Update to new W3GSRUMD APIs ( version 6.02 ) -!/ 20-Jan-2017 : Change to preprocessor macros to enable test output. -!/ (T.J. Campbell, NRL) ( version 6.02 ) -!/ 20-Jan-2017 : Change calculation of curvilinear grid metric and -!/ derivatives calculations to use W3GSRUMD:W3CGDM. -!/ (T.J. Campbell, NRL) ( version 6.02 ) -!/ 07-Jan-2018 : Generalizes ICE100WIND to ICESCALES ( version 6.04 ) -!/ 26-Mar-2018 : Add FSWND optional variable. JGLi ( version 6.02 ) -!/ 05-Jun-2018 : Add PDLIB/DEBUGINIT and implcit scheme parameters -!/ for unstructured grids ( version 6.04 ) -!/ 18-Aug-2018 : S_{ice} IC5 (Q. Liu) ( version 6.06 ) -!/ 20-Aug-2018: Extra namelist variables for ST6 ( version 6.06) -!/ (Q. Liu, UoM) -!/ 26-Aug-2018 : UOST (Mentaschi et al. 2015, 2018) ( version 6.06 ) -!/ 27-Aug-2018 : Add BTBETA parameter ( version 6.06 ) -!/ 22-Feb-2020 : Add AIRGB and AIRCMIN ( version 7.06 ) -!/ 15-Apr-2020 : Adds optional opt-out for CFL on BC ( version 7.08 ) -!/ 06-May-2021 : Add SMCTYPE, ARCTC options. JGLi ( version 7.12 ) -!/ 07-Jun-2021 : the GKE module (NL5, Q. Liu) ( version 7.12 ) -!/ -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Define data structures to set up wave model grids and aliases -! to use individual grids transparently. Also includes subroutines -! to manage data structure and pointing to individual models. -! Definition of grids and model set up. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NGRIDS Int. Public Number of grids, initialized at -1 -! to check proper model initialization. -! NAUXGR Int. Public Auxiliary grids. -! IGRID Int. Public Selected spatial grid, init. at -1. -! ISGRD Int. Public Selected spectral grid, init. at -1. -! IPARS Int. Public Selected num. and ph. pars, init. at -1. -! RLGTYPE I.P. Public Named constant for rectilinear grid type -! CLGTYPE I.P. Public Named constant for curvilinear grid type -! UNGTYPE I.P. Public Named constant for Unstructured triangular grid -! SMCTYPE I.P. Public Named constant for unstructured SMC grid type -! FLAGLL Log. Public Flag to indicate coordinate system for all grids -! .TRUE.: Spherical (lon/lat in degrees) -! .FALSE.: Cartesian (meters) -! GRID TYPE Public Data structure defining grid. -! GRIDS GRID Public Array of grids. -! SGRD TYPE Public Data structure defining spectral grid. -! SGRDS GRID Public Array of spectral grids. -! MPAR TYPE Public Data structure with all other model -! parameters. -! MPARS GRID Public Array of MPAR. -! ---------------------------------------------------------------- -! -! All elements of GRID are aliased to pointers with the same -! name. These pointers are defined as : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! GTYPE Int. Public Flag for type of grid -! RLGTYPE: Rectilinear grid -! CLGTYPE: Curvilinear grid -! UNGTYPE: Unstructured triangular grid -! SMCTYPE: Unstructured SMC grid -! RSTYPE Int. Public Integer identifyng restart type -! ICLOSE Int. Public Parameter indicating type of index closure of grid. -! ICLOSE_NONE: No grid closure -! ICLOSE_SMPL: Simple grid closure -! Grid is periodic in the i-index and wraps at -! I=NX+1. In other words, (NX+1,J) => (1,J). -! ICLOSE_TRPL: Tripole grid closure -! Grid is periodic in the i-index and and wraps at -! I=NX+1 and has closure at J=NY+1. In other words, -! (NX+1,J<=NY) => (1,J) and -! (I,NY+1) => (MOD(NX-I+1,NX)+1,NY). The tripole -! closure requires that NX be even. -! NX, NY Int. Public Discrete dimensions of spatial grid. -! NSEA(L) Int. Public Number of sea points (local for MPP). -! NU/VFc Int. Public Number of U/V faces for SMC grid. -! NRLv Int. Public Number of refined levels for SMC grid. -! NGLO Int. Public Number of cells in global part for SMC grid. -! NARC Int. Public Number of cells in Arctic part for SMC grid. -! NBAC Int. Public Number of boundary cells in Arctic part. -! NBGL Int. Public Number of boundary cells in global part. -! NBSMC Int. Public Number of boundary cells for regional SMC grid. -! TRFLAG Int. Public Flag for use of transparencies -! 0: No sub-grid obstacles. -! 1: Obstructions at cell boundaries. -! 2: Obstructions at cell centers. -! 3: Like 1 with continuous ice. -! 4: Like 2 with continuous ice. -! MAPSTA I.A. Public Grid status map. -! MAPST2 I.A. Public Second grid status map. -! MAPxx I.A. Public Storage grid maps. -! IJKCel I.A. Public Cell info array for SMC grid. -! IJKU/VFc I.A. Public U/V-Face arrays for SMC grid. -! NLv* I.A. Public Cell, U/V-Face numbers of refine levels. -! ICLBAC I.A. Public Mapping index for Arctic boundary cells. -! ISMCBP I.A. Public List of SMC grid input boundary cell indexes. -! SX,SY Real Public Spatial (rectilinear) grid increments. -! X0,Y0 Real Public Lower left corner of spatial (rectilinear) grid. -! DTCFL Real Public Maximum CFL time step X-Y propagation. -! DTCFLI Real Public Id. intra-spectral. -! DTMAX Real Public Maximum overall time step. -! DTMIN Real Public Minimum dynamic time step for source -! NITERSEC1 Real Public Number of interations when DTMAX < 1s -! DMIN Real Public Minimum water depth. -! CTMAX Real Public Maximum CFL number for depth refr. -! FICE0/N Real Public Cut-off ice conc. for ice coverage. -! FICEL Real Public Length scale for sea ice damping -! IICEHMIN Real Public Minimum thickness of sea ice -! IICEHDISP Real Public Minimum thickness of sea ice in the dispersion relation before relaxing the conv. criterion -! IICEHFAC Real Public Scale factor for sea ice thickness -! IICEHINIT Real Public Initial value of ice thickness -! ICESCALES R.A. Publ. Scaling coefficient for source terms in the presence of ice -! Default is 1.0, meaning that 100% ice -! concentration result in zero source term -! If set to 0.0, then ice has no direct impact on Sln / Sin / Snl / Sds -! IC3PARS R.A. Public various parameters for use in IC4, handled as -! an array for simplicity -! IC4_KI R.A. Public KI (dissipation rate) values for use in IC4 -! IC4_FC R.A. Public FC (frequency bin separators) for use in IC4 -! PFMOVE Real Public Tunable parameter in GSE correction -! for moving grids. -! GRIDSHIFT Real Public Grid offset for multi-grid w/SCRIP -! CMPRTRCK Log. Public True for traditional compression of track output -! PoLat/Lon R.A. Public Rotated N-Pole standard latitude/longitude. -! AnglD R.A. Public Rotation angle in degree to turn rotated grid -! back to standard grid. JGLi12Jun2012 -! FLAGUNR Log. Public True if rotating directions back to true north -! STEXU Real Public Length-scale (X) for space-time extreme averaging -! STEYU Real Public Length-scale (Y) for space-time extreme averaging -! STEDU Real Public Time-scale for space-time extreme averaging -! ZB R.A. Public Bottom levels on storage grid. -! CLATS(I) R.A. Public (Inverse) cosine of latitude at sea points. -! CTHG0S R.A. Public Constant in great-circle refr. term at sea points. -! TRNX/Y R.A. Public Transparencies in X/Y for sub-grid -! CTRNX/Y R.A. Public Sub-grid transparencies for SMC grid. -! ANGARC R.A. Public Rotation angle in degree for Arctic cells. -! SPCBAC R.A. Public Full 2-D spectra for Arctic boundary cells. -! X/YGRD R.A. Public Spatial grid coordinate arrays. -! SX/SYGRD R.A. Public Spatial grid increment arrays. -! GINIT Log. Public Flag identifying grid initialization. -! FLDRY Log. Public Flag for 'dry' run (IO and data -! processing only). -! FLCx Log. Public Flags for prop. is different spaces. -! FLSOU Log. Public Flag for source term calculation. -! FUNO3 Log. Public Flag for 3rd order UNO3 scheme on SMC grid. -! FVERG Log. Public Flag for 1-2-1 averaging smoothing on SMC grid. -! FSWND Log. Public Flag for sea-point only wind input on SMC grid. -! ARCTC Log. Public Flag to include Arctic polar part on SMC grid. -! FLAGST L.A. Public Flag for source term computations -! for individual grid points. -! IICEDISP Log. Public Flag for use of the ice covered dispertion relation. -! IICESMOOTH Log. Public Flag to smooth the ice covered dispertion relation in broken ice. -! -! -! GNAME C*30 Public Grid name. -! FILEXT C*13 Public Extension of WAVEWATCH III file names -! default in 'ww3'. -! BTBETA Real Public The constant used for separating wind sea -! and swell when we estimate WBT -! ---------------------------------------------------------------- -! -! All elements of SGRD are aliased to pointers with the same -! name. These pointers are defined as : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NK Int. Public Number of discrete wavenumbers. -! NK2 Int. Public Extended wavenumber range. -! NTH Int. Public Number of discrete directions. -! NSPEC Int. Public Number of discrete spectral bins. -! MAPxx I.A. Public Spectral maps. -! DTH Real Public Directional increments (radians). -! XFR Real Public Frequency multiplication factor. -! FR1 Real Public Lowest frequency (Hz) -! FTE Real Public Factor in tail integration energy. -! FTF Real Public Id. frequency. -! FTWN Real Public Id. wavenumber. -! FTTR Real Public Id. wave period. -! FTWL Real Public Id. wave length. -! FACTIn Real Public Factors for obtaining integer cut-off -! frequency. -! FACHFx Real Public Factor for tail. -! TH R.A Public Directions (radians). -! ESIN R.A Public Sine of discrete directions. -! ECOS R.A Public Cosine of discrete directions. -! ES2, ESC, EC2 -! R.A Public Sine and cosine products -! SIG R.A Public Relative frequencies (invariant -! in grid). (rad) -! SIG2 R.A Public Id. for full 2-D spectrum. -! DSIP R.A Public Frequency bandwidths (prop.) (rad) -! DSII R.A Public Frequency bandwidths (int.) (rad) -! DDEN R.A Public DSII * DTH * SIG (for integration -! based on energy) -! DDEN2 R.A Public Idem, full spectrum. -! SINIT Log. Public Flag identifying grid initialization. -! ---------------------------------------------------------------- -! -! The structure MPAR contains all other model parameters for -! numerical methods and physical parameterizations. It contains -! itself several structures as outlined below. -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! PINIT Log. Public Flag identifying initialization. -! NPARS NPAR Public Numerical parameters, -! PROPS PROP Public Parameters propagatrion schemes. -! SFLPS SFLP Public Parameters for flux computation. -! SLNPS SLNP Public Parameters Sln. -! SRCPS SRCP Public Parameters Sin and Sds. -! SNLPS SNLP Public Parameters Snl. -! SBTPS SBTP Public Parameters Sbt. -! SDBPS SDBP Public Parameters Sdb. -! STRPS STRP Public Parameters Str. -! SBSPS SBSP Public Parameters Sbs. -! ---------------------------------------------------------------- -! -! The structure NPAR contains numerical parameters and is aliased -! as above: -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! FACP Real Public Constant in maximum par. change in -! dynamic integration scheme (depends -! upon Xp). -! XREL Real Public Id. relative change. -! XFLT Real Public Id. filter level. -! FXFM Real Public Constant for mean frequency in -! cut-off. (!/ST1) -! FXPM Real Public Id. PM. -! XFT Real Public Constant for cut-off freq. (!/ST2) -! XFC Real Public Id. -! FACSD Real Public Constant in seeding algorithm. -! FHMAX Real Public Hs/depth ratio in limiter (!/MLIM) -! RWINDC Real Public Coefficient for current in relative -! wind (!/RWND) -! WWCOR R.A. Public Wind correction factors (!/WCOR) -! ---------------------------------------------------------------- -! -! The structure PROP contains parameters for the propagation -! schemes and is aliased as above: -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! DTME Real Public Swell age in disp. corr. (!/PR2) -! CLATMN Real Public Id. minimum cosine of lat. (!/PR2) -! DTMS Real Public Swell age in disp. corr. (!/SMC) -! -! WDCG Real Public Factors in width of av. Cg. (!/PR3) -! WDTH Real Public Factors in width of av. Th. (!/PR3) -! ---------------------------------------------------------------- -! -! The structure SFLP contains parameters for the fluxes -! and is aliased as above: -! ---------------------------------------------------------------- -! (!/FLX2) -! NITTIN Int. Public Number of itterations for drag calc. -! CINXSI Real Public Constant in parametric description -! (!/FLX3) -! NITTIN Int. Public Number of itterations for drag calc. -! CAP_ID Int Public Type of cap used. -! CINXSI Real Public Constant in parametric description -! CD_MAX Real Public Cap on Cd. -! (!/FLX4) -! FLX4A0 Real Public Scaling value in parametric description -! ---------------------------------------------------------------- -! -! The structure SLNP contains parameters for the linear input -! source terms and is aliased as above: -! -! ---------------------------------------------------------------- -! (!/LN1) -! SLNC1 Real Public Proportionality and other constants in -! input source term. -! FSPM Real Public Factor for fPM in filter. -! FSHF Real Public Factor for fh in filter. -! ---------------------------------------------------------------- -! -! The structure SRCP contains parameters for the input and dis, -! source terms and is aliased as above: -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! WWNMEANPTAIL R Public Power of tail for WNMEAN calculation -! SSTXFTFTAIL R Public Tail factor for WNMEAN calculation -! (!/ST1) -! SINC1 Real Public Proportionality and other constants in -! input source term. -! SDSC1 Real Public Combined constant in dissipation -! source term. -! (!/ST2) -! ZWIND Real Public Height at which the wind is defined -! of drag. -! FSWELL Real Public Reduction factor of negative input -! for swell. -! SHSTAB, OFSTAB, CCNG, CCPS, FFNG, FFPS -! Real Public Factors in effective wind speed. -! CDSAn Real Public Constants in high-freq. dis. -! SDSALN Real Public Factor for nondimensional 1-D spectrum. -! CDSBn Real Public Constants in parameterization of PHI. -! XFH Real Public Constant for turbulent length scale. -! XFn Real Public Constants in combining low and high -! frequency dissipation. -! (!/ST3) -! ZZWND Real Public Height at which the wind is defined -! AALPHA Real Public Minimum value of charnock parameter -! BBETA Real Public Wind-wave coupling coefficient -! ZZALP Real Public Wave age tuning coefficient in Sin -! TTAUWSHELTER Real Public Sheltering coefficient for short waves -! ZZ0MAX Real Public Maximum value of air-side roughness -! ZZ0RAT Real Public ratio of roughness for mean and -! oscillatory flows -! SSINTHP Real Public Power in cosine of wind input -! SSWELLF R.A. Public Swell damping coefficients -! SSDSCn Real Public Dissipation parameters -! SSDSBR Real Public Threshold in saturation spectrum for Sds -! SSDSP Real Public Power of B(k) in Sds -! WWNMEANP Real Public Power that defines the mean wavenumber -! in Sds -! SSTXFTF, SSTXFTWN Real Public Tail constants -! SSDSC4, Real Public Threshold shift in saturation diss. -! SSDSC5, Real Public Wave-turbulence dissipation factor -! SSDSC6, Real Public dissipation parameter -! DDELTA1 Real Public Low-frequency dissipation coefficient -! in WAM4 -! DDELTA2 Real Public High-frequency dissipation coefficient -! in WAM4 -! SSDSDTH Real Public Maximum angular sector for saturation -! spectrum -! SSDSCOS Real Public Power of cosine in saturation integral -! SSDSISO Int. Public Choice of definition of the isotropic -! saturation -! ---------------------------------------------------------------- -! -! The structure SNLP contains parameters for the nonl. inter. -! source term and is aliased as above: -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! (!/NL1) -! SNLC1 Real Public Scaled proportionality constant. -! LAM Real Public Factor defining quadruplet. -! KDCON Real Public Conversion factor for relative depth. -! KDMN Real Public Minimum relative depth. -! SNLSn Real Public Constants in shallow water factor. -! (!/NL2) -! IQTPE Int. Public Type of depth treatment -! 1 : Deep water -! 2 : Deep water / WAM scaling -! 3 : Finite water depth -! NDPTHS Int. Public Number of depth for which integration -! space needs to be computed. -! NLTAIL Real Public Tail factor for parametric tail. -! DPTHNL R.A. Public Depths corresponding to NDPTHS. -! *** NOTE: This array is not allocated -! in the W3DIMP routine *** -! (!/NL3) -! NFR Int. Public Number of frequencies or wavenumbers -! in discrete spectral space (NFR=>NK). -! NFRMIN Int. Public Minimum discrete frequency in the -! expanded frequency space. -! NFRMAX Int. Public Idem maximum for first part. -! NFRCUT Int. Public Idem maximum for second part. -! NTHMAX Int. Public Extension of directional space. -! NTHEXP Int Public Number of bins in extended dir. space. -! NSPMIN, NSPMAX, NSPMX2 -! Int. Public 1D spectral space range. -! FRQ R.A. Public Expanded frequency range (Hz). -! XSI R.A. Public Expanded frequency range (rad/s). -! NQA Int. Public Number of actual quadruplets. -! QST1 I.A. Public Spectral offsets for compuation of -! quadruplet spectral desnities. -! QST2 R.A. Public Idem weights. -! QST3 R.A. Public Proportionality constants and k factors -! in diagonal strength. -! QST4 I.A. Public Spectral offsets for combining of -! interactions and diagonal. -! QST5 R.A. Public Idem weights for interactions. -! QST6 R.A. Public Idem weights for diagonal. -! SNLNQ Int. Public Number of quadruplet definitions. -! SNLMSC Real Public Tuning power 'deep' scaling. -! SNLNSC Real Public Tuning power 'shallow' scaling. -! SNLSFD Real Public 'Deep' nondimensional filer freq. -! SNLSFS Real Public 'Shallow' nondimensional filer freq. -! SNLL R.A. Public Array with lambda for quadruplet. -! SNLM R.A. Public Array with mu for quadruplet. -! SNLT R.A. Public Array with Dtheta for quadruplet. -! SNLCD R.A. Public Array with Cd for quadruplet. -! SNLCS R.A. Public Array with Cs for quadruplet. -! (!/NL4) -! ITSA Int. Public Integer indicating TSA (1) or FBI (0) -! IALT Int. Public Integer determining alternating looping -! (!/NL5) -! QR5DPT Real Public Water depth for the GKE module -! QR5OML Real Public λ cut off value for quasi-resonant quartets -! QI5DIS Int. Public Method to discretize continuous spectrum -! QI5KEV Int. Public GKE (GS13 or J03) -! QI5NNZ Int. Public # of interactive quadruplets -! QI5IPL Int. Public Interp. method to get C₄ -! QI5PMX Int. Public Phase mixing related parameter -! (!/NLS) -! NTHX Int. Public Expanded discrete direction range. -! NFRX Int. Public Expanded discrete frequency range. -! NSPL-H Int. Public Range of 1D spectrum. -! SNSST R.A. Public Array with interpolation weights. -! CNLSA Real Public a34 in quadruplet definition. -! CNLSC Real Public C in Snl definition. -! CNLSFM Real Public Maximum relative spectral change. -! CNLSC1/3 Real Public Constant in frequency filter. -! ---------------------------------------------------------------- -! -! The structure SBTP contains parameters for the bottom friction -! source term and is aliased as above: -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! SBTC1 Real Public Proportionality constant. (!/BT1) -! SBTCX R.A. Public Parameters for bottom fric. (!/BT4) -! ---------------------------------------------------------------- -! -! The structure SDBP contains parameters for the depth incduced -! breaking source term and is aliased as above: -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! SDBC1 Real Public Proportionality constant. (!/DB1) -! SDBC2 Real Public Hmax/d ratio. (!/DB1) -! FDONLY Log. Public Flag for checking depth only (!/DB1) -! otherwise Miche criterion. -! ---------------------------------------------------------------- -! -! The structure STRP contains parameters for the triad interaction -! source term and is aliased as above: -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! The structure SBSP contains parameters for the bottom scattering -! source term and is aliased as above: -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! The structure SICP contains parameters for arbitrary source -! term and is aliased as above: -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! IS1C1 Real Public Scale factor for icecon. (!/ISx) -! IS1C2 Real Public Offset for ice concentration (!/ISx) -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3NMOD Subr. Public Set number of grids. -! W3DIMX Subr. Public Set dimensions of spatial grid. -! W3DIMS Subr. Public Set dimensions of spectral grid. -! W3SETG Subr. Public Point to selected grid / model. -! W3GNTX Subr. Public Construct grid arrays -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! EXTCDE Subr. W3SERVMD Abort program with exit code. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! - In model versions before 3.06 the parameters in the grid -! structure were stored in the module W3IOGR. -! - No subroutine DIMP is provided, instead, arrays are set -! one-by-one in W3IOGR. -! -! 6. Switches : -! -! See subroutine documentation. -! -! !/PRn Select propagation scheme -! !/SMC UNO2 propagation on SMC grid. -! -! !/LNn Select source terms -! !/STn -! !/NLn -! !/BTn -! !/DBn -! !/TRn -! !/BSn -! !/XXn -! -! !/S Enable subroutine tracing. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -!/ -!/ Required modules -!/ - USE W3GSRUMD -!/ -!/ Specify default accessibility -!/ - PUBLIC -!/ -!/ Module private variable for checking error returns -!/ - INTEGER, PRIVATE :: ISTAT -!/ -!/ Conventional declarations -!/ - INTEGER :: NGRIDS = -1, IGRID = -1, ISGRD = -1, & - IPARS = -1, NAUXGR -! +MODULE W3GDATMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ ! J. H. Alves ! + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 15-Apr-2020 | + !/ +-----------------------------------+ + !/ + !/ 24-Jun-2005 : Origination. ( version 3.07 ) + !/ 09-Nov-2005 : Remove soft boundary options. ( version 3.08 ) + !/ 23-Jun-2006 : Add data for W3SLN1. ( version 3.09 ) + !/ 18-Jul-2006 : Add input grids. ( version 3.10 ) + !/ 05-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 02-Feb-2007 : Add FLAGST. ( version 3.10 ) + !/ 14-Apr-2007 : Add Miche style limiter. ( version 3.11 ) + !/ ( J. H. Alves ) + !/ 25-Apr-2007 : Adding Battjes-Janssen Sdb. ( version 3.11 ) + !/ ( J. H. Alves ) + !/ 06-Aug-2007 : Fixing SLNP !/SEED bug. ( version 3.13 ) + !/ 18-Sep-2007 : Adding WAM4 source terms. ( version 3.13 ) + !/ ( F. Ardhuin ) + !/ 15-Apr-2008 : Clean up for distribution. ( version 3.14 ) + !/ 27-Jun-2008 : Expand WAM4 variants namelist ( version 3.14 ) + !/ ( F. Ardhuin ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 29-Oct-2010 : Implement unstructured grids ( version 3.14.1 ) + !/ (A. Roland and F. Ardhuin) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 23-Dec-2010 : Fix HPFAC and HQFAC by including the COS(YGRD) + !/ factor with DXDP and DXDQ terms. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 05-Apr-2011 : Implement interations for DTMAX < 1s( version 3.14.1 ) + !/ (F. Ardhuin) + !/ 01-Jul-2011 : Movable bed bottom friction BT4 ( version 4.01 ) + !/ 03-Nov-2011 : Bug fix: GUGINIT initialization ( version 4.04 ) + !/ 29-Nov-2011 : Adding ST6 source term option. ( version 4.04 ) + !/ (S. Zieger) + !/ 14-Mar-2012 : Add PSIC for BT4 ( version 4.04 ) + !/ 12-Jun-2012 : Add /RTD option or rotated grid variables. + !/ (Jian-Guo Li) ( version 4.06 ) + !/ 13-Jul-2012 : Move data structures GMD (SNL3) and nonlinear + !/ filter (SNLS) from 3.15 (HLT). ( version 4.08 ) + !/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) + !/ 12-Dec-2012 : Adding SMC grid. JG_Li ( version 4.09 ) + !/ 16-Sep-2013 : Add Arctic part SMC grid. ( version 4.11 ) + !/ 11-Nov-2013 : SMC and rotated grid incorporated in the main + !/ trunk ( version 4.13 ) + !/ 16-Nov-2013 : Allows reflection on curvi grids ( version 4.14 ) + !/ 26-Jul-2013 : Adding IG waves ( version 4.16 ) + !/ 18-Dec-2013 : Moving FLAGLL into GRID TYPE ( version 4.16 ) + !/ 11-Jun-2014 : Changed reflection for subgrid ( version 5.01 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 21-Aug-2015 : Add SMC FUNO3, FVERG options. JGLi ( version 5.09 ) + !/ 04-May-2016 : Add IICEDISP GB&FA ( version 5.10 ) + !/ 20-Jan-2017 : Update to new W3GSRUMD APIs ( version 6.02 ) + !/ 20-Jan-2017 : Change to preprocessor macros to enable test output. + !/ (T.J. Campbell, NRL) ( version 6.02 ) + !/ 20-Jan-2017 : Change calculation of curvilinear grid metric and + !/ derivatives calculations to use W3GSRUMD:W3CGDM. + !/ (T.J. Campbell, NRL) ( version 6.02 ) + !/ 07-Jan-2018 : Generalizes ICE100WIND to ICESCALES ( version 6.04 ) + !/ 26-Mar-2018 : Add FSWND optional variable. JGLi ( version 6.02 ) + !/ 05-Jun-2018 : Add PDLIB/DEBUGINIT and implcit scheme parameters + !/ for unstructured grids ( version 6.04 ) + !/ 18-Aug-2018 : S_{ice} IC5 (Q. Liu) ( version 6.06 ) + !/ 20-Aug-2018: Extra namelist variables for ST6 ( version 6.06) + !/ (Q. Liu, UoM) + !/ 26-Aug-2018 : UOST (Mentaschi et al. 2015, 2018) ( version 6.06 ) + !/ 27-Aug-2018 : Add BTBETA parameter ( version 6.06 ) + !/ 22-Feb-2020 : Add AIRGB and AIRCMIN ( version 7.06 ) + !/ 15-Apr-2020 : Adds optional opt-out for CFL on BC ( version 7.08 ) + !/ 06-May-2021 : Add SMCTYPE, ARCTC options. JGLi ( version 7.12 ) + !/ 07-Jun-2021 : the GKE module (NL5, Q. Liu) ( version 7.12 ) + !/ + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Define data structures to set up wave model grids and aliases + ! to use individual grids transparently. Also includes subroutines + ! to manage data structure and pointing to individual models. + ! Definition of grids and model set up. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NGRIDS Int. Public Number of grids, initialized at -1 + ! to check proper model initialization. + ! NAUXGR Int. Public Auxiliary grids. + ! IGRID Int. Public Selected spatial grid, init. at -1. + ! ISGRD Int. Public Selected spectral grid, init. at -1. + ! IPARS Int. Public Selected num. and ph. pars, init. at -1. + ! RLGTYPE I.P. Public Named constant for rectilinear grid type + ! CLGTYPE I.P. Public Named constant for curvilinear grid type + ! UNGTYPE I.P. Public Named constant for Unstructured triangular grid + ! SMCTYPE I.P. Public Named constant for unstructured SMC grid type + ! FLAGLL Log. Public Flag to indicate coordinate system for all grids + ! .TRUE.: Spherical (lon/lat in degrees) + ! .FALSE.: Cartesian (meters) + ! GRID TYPE Public Data structure defining grid. + ! GRIDS GRID Public Array of grids. + ! SGRD TYPE Public Data structure defining spectral grid. + ! SGRDS GRID Public Array of spectral grids. + ! MPAR TYPE Public Data structure with all other model + ! parameters. + ! MPARS GRID Public Array of MPAR. + ! ---------------------------------------------------------------- + ! + ! All elements of GRID are aliased to pointers with the same + ! name. These pointers are defined as : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! GTYPE Int. Public Flag for type of grid + ! RLGTYPE: Rectilinear grid + ! CLGTYPE: Curvilinear grid + ! UNGTYPE: Unstructured triangular grid + ! SMCTYPE: Unstructured SMC grid + ! RSTYPE Int. Public Integer identifyng restart type + ! ICLOSE Int. Public Parameter indicating type of index closure of grid. + ! ICLOSE_NONE: No grid closure + ! ICLOSE_SMPL: Simple grid closure + ! Grid is periodic in the i-index and wraps at + ! I=NX+1. In other words, (NX+1,J) => (1,J). + ! ICLOSE_TRPL: Tripole grid closure + ! Grid is periodic in the i-index and and wraps at + ! I=NX+1 and has closure at J=NY+1. In other words, + ! (NX+1,J<=NY) => (1,J) and + ! (I,NY+1) => (MOD(NX-I+1,NX)+1,NY). The tripole + ! closure requires that NX be even. + ! NX, NY Int. Public Discrete dimensions of spatial grid. + ! NSEA(L) Int. Public Number of sea points (local for MPP). + ! NU/VFc Int. Public Number of U/V faces for SMC grid. + ! NRLv Int. Public Number of refined levels for SMC grid. + ! NGLO Int. Public Number of cells in global part for SMC grid. + ! NARC Int. Public Number of cells in Arctic part for SMC grid. + ! NBAC Int. Public Number of boundary cells in Arctic part. + ! NBGL Int. Public Number of boundary cells in global part. + ! NBSMC Int. Public Number of boundary cells for regional SMC grid. + ! TRFLAG Int. Public Flag for use of transparencies + ! 0: No sub-grid obstacles. + ! 1: Obstructions at cell boundaries. + ! 2: Obstructions at cell centers. + ! 3: Like 1 with continuous ice. + ! 4: Like 2 with continuous ice. + ! MAPSTA I.A. Public Grid status map. + ! MAPST2 I.A. Public Second grid status map. + ! MAPxx I.A. Public Storage grid maps. + ! IJKCel I.A. Public Cell info array for SMC grid. + ! IJKU/VFc I.A. Public U/V-Face arrays for SMC grid. + ! NLv* I.A. Public Cell, U/V-Face numbers of refine levels. + ! ICLBAC I.A. Public Mapping index for Arctic boundary cells. + ! ISMCBP I.A. Public List of SMC grid input boundary cell indexes. + ! SX,SY Real Public Spatial (rectilinear) grid increments. + ! X0,Y0 Real Public Lower left corner of spatial (rectilinear) grid. + ! DTCFL Real Public Maximum CFL time step X-Y propagation. + ! DTCFLI Real Public Id. intra-spectral. + ! DTMAX Real Public Maximum overall time step. + ! DTMIN Real Public Minimum dynamic time step for source + ! NITERSEC1 Real Public Number of interations when DTMAX < 1s + ! DMIN Real Public Minimum water depth. + ! CTMAX Real Public Maximum CFL number for depth refr. + ! FICE0/N Real Public Cut-off ice conc. for ice coverage. + ! FICEL Real Public Length scale for sea ice damping + ! IICEHMIN Real Public Minimum thickness of sea ice + ! IICEHDISP Real Public Minimum thickness of sea ice in the dispersion relation before relaxing the conv. criterion + ! IICEHFAC Real Public Scale factor for sea ice thickness + ! IICEHINIT Real Public Initial value of ice thickness + ! ICESCALES R.A. Publ. Scaling coefficient for source terms in the presence of ice + ! Default is 1.0, meaning that 100% ice + ! concentration result in zero source term + ! If set to 0.0, then ice has no direct impact on Sln / Sin / Snl / Sds + ! IC3PARS R.A. Public various parameters for use in IC4, handled as + ! an array for simplicity + ! IC4_KI R.A. Public KI (dissipation rate) values for use in IC4 + ! IC4_FC R.A. Public FC (frequency bin separators) for use in IC4 + ! PFMOVE Real Public Tunable parameter in GSE correction + ! for moving grids. + ! GRIDSHIFT Real Public Grid offset for multi-grid w/SCRIP + ! CMPRTRCK Log. Public True for traditional compression of track output + ! PoLat/Lon R.A. Public Rotated N-Pole standard latitude/longitude. + ! AnglD R.A. Public Rotation angle in degree to turn rotated grid + ! back to standard grid. JGLi12Jun2012 + ! FLAGUNR Log. Public True if rotating directions back to true north + ! STEXU Real Public Length-scale (X) for space-time extreme averaging + ! STEYU Real Public Length-scale (Y) for space-time extreme averaging + ! STEDU Real Public Time-scale for space-time extreme averaging + ! ZB R.A. Public Bottom levels on storage grid. + ! CLATS(I) R.A. Public (Inverse) cosine of latitude at sea points. + ! CTHG0S R.A. Public Constant in great-circle refr. term at sea points. + ! TRNX/Y R.A. Public Transparencies in X/Y for sub-grid + ! CTRNX/Y R.A. Public Sub-grid transparencies for SMC grid. + ! ANGARC R.A. Public Rotation angle in degree for Arctic cells. + ! SPCBAC R.A. Public Full 2-D spectra for Arctic boundary cells. + ! X/YGRD R.A. Public Spatial grid coordinate arrays. + ! SX/SYGRD R.A. Public Spatial grid increment arrays. + ! GINIT Log. Public Flag identifying grid initialization. + ! FLDRY Log. Public Flag for 'dry' run (IO and data + ! processing only). + ! FLCx Log. Public Flags for prop. is different spaces. + ! FLSOU Log. Public Flag for source term calculation. + ! FUNO3 Log. Public Flag for 3rd order UNO3 scheme on SMC grid. + ! FVERG Log. Public Flag for 1-2-1 averaging smoothing on SMC grid. + ! FSWND Log. Public Flag for sea-point only wind input on SMC grid. + ! ARCTC Log. Public Flag to include Arctic polar part on SMC grid. + ! FLAGST L.A. Public Flag for source term computations + ! for individual grid points. + ! IICEDISP Log. Public Flag for use of the ice covered dispertion relation. + ! IICESMOOTH Log. Public Flag to smooth the ice covered dispertion relation in broken ice. + ! + ! + ! GNAME C*30 Public Grid name. + ! FILEXT C*13 Public Extension of WAVEWATCH III file names + ! default in 'ww3'. + ! BTBETA Real Public The constant used for separating wind sea + ! and swell when we estimate WBT + ! ---------------------------------------------------------------- + ! + ! All elements of SGRD are aliased to pointers with the same + ! name. These pointers are defined as : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NK Int. Public Number of discrete wavenumbers. + ! NK2 Int. Public Extended wavenumber range. + ! NTH Int. Public Number of discrete directions. + ! NSPEC Int. Public Number of discrete spectral bins. + ! MAPxx I.A. Public Spectral maps. + ! DTH Real Public Directional increments (radians). + ! XFR Real Public Frequency multiplication factor. + ! FR1 Real Public Lowest frequency (Hz) + ! FTE Real Public Factor in tail integration energy. + ! FTF Real Public Id. frequency. + ! FTWN Real Public Id. wavenumber. + ! FTTR Real Public Id. wave period. + ! FTWL Real Public Id. wave length. + ! FACTIn Real Public Factors for obtaining integer cut-off + ! frequency. + ! FACHFx Real Public Factor for tail. + ! TH R.A Public Directions (radians). + ! ESIN R.A Public Sine of discrete directions. + ! ECOS R.A Public Cosine of discrete directions. + ! ES2, ESC, EC2 + ! R.A Public Sine and cosine products + ! SIG R.A Public Relative frequencies (invariant + ! in grid). (rad) + ! SIG2 R.A Public Id. for full 2-D spectrum. + ! DSIP R.A Public Frequency bandwidths (prop.) (rad) + ! DSII R.A Public Frequency bandwidths (int.) (rad) + ! DDEN R.A Public DSII * DTH * SIG (for integration + ! based on energy) + ! DDEN2 R.A Public Idem, full spectrum. + ! SINIT Log. Public Flag identifying grid initialization. + ! ---------------------------------------------------------------- + ! + ! The structure MPAR contains all other model parameters for + ! numerical methods and physical parameterizations. It contains + ! itself several structures as outlined below. + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! PINIT Log. Public Flag identifying initialization. + ! NPARS NPAR Public Numerical parameters, + ! PROPS PROP Public Parameters propagatrion schemes. + ! SFLPS SFLP Public Parameters for flux computation. + ! SLNPS SLNP Public Parameters Sln. + ! SRCPS SRCP Public Parameters Sin and Sds. + ! SNLPS SNLP Public Parameters Snl. + ! SBTPS SBTP Public Parameters Sbt. + ! SDBPS SDBP Public Parameters Sdb. + ! STRPS STRP Public Parameters Str. + ! SBSPS SBSP Public Parameters Sbs. + ! ---------------------------------------------------------------- + ! + ! The structure NPAR contains numerical parameters and is aliased + ! as above: + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! FACP Real Public Constant in maximum par. change in + ! dynamic integration scheme (depends + ! upon Xp). + ! XREL Real Public Id. relative change. + ! XFLT Real Public Id. filter level. + ! FXFM Real Public Constant for mean frequency in + ! cut-off. (!/ST1) + ! FXPM Real Public Id. PM. + ! XFT Real Public Constant for cut-off freq. (!/ST2) + ! XFC Real Public Id. + ! FACSD Real Public Constant in seeding algorithm. + ! FHMAX Real Public Hs/depth ratio in limiter (!/MLIM) + ! RWINDC Real Public Coefficient for current in relative + ! wind (!/RWND) + ! WWCOR R.A. Public Wind correction factors (!/WCOR) + ! ---------------------------------------------------------------- + ! + ! The structure PROP contains parameters for the propagation + ! schemes and is aliased as above: + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! DTME Real Public Swell age in disp. corr. (!/PR2) + ! CLATMN Real Public Id. minimum cosine of lat. (!/PR2) + ! DTMS Real Public Swell age in disp. corr. (!/SMC) + ! + ! WDCG Real Public Factors in width of av. Cg. (!/PR3) + ! WDTH Real Public Factors in width of av. Th. (!/PR3) + ! ---------------------------------------------------------------- + ! + ! The structure SFLP contains parameters for the fluxes + ! and is aliased as above: + ! ---------------------------------------------------------------- + ! (!/FLX2) + ! NITTIN Int. Public Number of itterations for drag calc. + ! CINXSI Real Public Constant in parametric description + ! (!/FLX3) + ! NITTIN Int. Public Number of itterations for drag calc. + ! CAP_ID Int Public Type of cap used. + ! CINXSI Real Public Constant in parametric description + ! CD_MAX Real Public Cap on Cd. + ! (!/FLX4) + ! FLX4A0 Real Public Scaling value in parametric description + ! ---------------------------------------------------------------- + ! + ! The structure SLNP contains parameters for the linear input + ! source terms and is aliased as above: + ! + ! ---------------------------------------------------------------- + ! (!/LN1) + ! SLNC1 Real Public Proportionality and other constants in + ! input source term. + ! FSPM Real Public Factor for fPM in filter. + ! FSHF Real Public Factor for fh in filter. + ! ---------------------------------------------------------------- + ! + ! The structure SRCP contains parameters for the input and dis, + ! source terms and is aliased as above: + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! WWNMEANPTAIL R Public Power of tail for WNMEAN calculation + ! SSTXFTFTAIL R Public Tail factor for WNMEAN calculation + ! (!/ST1) + ! SINC1 Real Public Proportionality and other constants in + ! input source term. + ! SDSC1 Real Public Combined constant in dissipation + ! source term. + ! (!/ST2) + ! ZWIND Real Public Height at which the wind is defined + ! of drag. + ! FSWELL Real Public Reduction factor of negative input + ! for swell. + ! SHSTAB, OFSTAB, CCNG, CCPS, FFNG, FFPS + ! Real Public Factors in effective wind speed. + ! CDSAn Real Public Constants in high-freq. dis. + ! SDSALN Real Public Factor for nondimensional 1-D spectrum. + ! CDSBn Real Public Constants in parameterization of PHI. + ! XFH Real Public Constant for turbulent length scale. + ! XFn Real Public Constants in combining low and high + ! frequency dissipation. + ! (!/ST3) + ! ZZWND Real Public Height at which the wind is defined + ! AALPHA Real Public Minimum value of charnock parameter + ! BBETA Real Public Wind-wave coupling coefficient + ! ZZALP Real Public Wave age tuning coefficient in Sin + ! TTAUWSHELTER Real Public Sheltering coefficient for short waves + ! ZZ0MAX Real Public Maximum value of air-side roughness + ! ZZ0RAT Real Public ratio of roughness for mean and + ! oscillatory flows + ! SSINTHP Real Public Power in cosine of wind input + ! SSWELLF R.A. Public Swell damping coefficients + ! SSDSCn Real Public Dissipation parameters + ! SSDSBR Real Public Threshold in saturation spectrum for Sds + ! SSDSP Real Public Power of B(k) in Sds + ! WWNMEANP Real Public Power that defines the mean wavenumber + ! in Sds + ! SSTXFTF, SSTXFTWN Real Public Tail constants + ! SSDSC4, Real Public Threshold shift in saturation diss. + ! SSDSC5, Real Public Wave-turbulence dissipation factor + ! SSDSC6, Real Public dissipation parameter + ! DDELTA1 Real Public Low-frequency dissipation coefficient + ! in WAM4 + ! DDELTA2 Real Public High-frequency dissipation coefficient + ! in WAM4 + ! SSDSDTH Real Public Maximum angular sector for saturation + ! spectrum + ! SSDSCOS Real Public Power of cosine in saturation integral + ! SSDSISO Int. Public Choice of definition of the isotropic + ! saturation + ! ---------------------------------------------------------------- + ! + ! The structure SNLP contains parameters for the nonl. inter. + ! source term and is aliased as above: + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! (!/NL1) + ! SNLC1 Real Public Scaled proportionality constant. + ! LAM Real Public Factor defining quadruplet. + ! KDCON Real Public Conversion factor for relative depth. + ! KDMN Real Public Minimum relative depth. + ! SNLSn Real Public Constants in shallow water factor. + ! (!/NL2) + ! IQTPE Int. Public Type of depth treatment + ! 1 : Deep water + ! 2 : Deep water / WAM scaling + ! 3 : Finite water depth + ! NDPTHS Int. Public Number of depth for which integration + ! space needs to be computed. + ! NLTAIL Real Public Tail factor for parametric tail. + ! DPTHNL R.A. Public Depths corresponding to NDPTHS. + ! *** NOTE: This array is not allocated + ! in the W3DIMP routine *** + ! (!/NL3) + ! NFR Int. Public Number of frequencies or wavenumbers + ! in discrete spectral space (NFR=>NK). + ! NFRMIN Int. Public Minimum discrete frequency in the + ! expanded frequency space. + ! NFRMAX Int. Public Idem maximum for first part. + ! NFRCUT Int. Public Idem maximum for second part. + ! NTHMAX Int. Public Extension of directional space. + ! NTHEXP Int Public Number of bins in extended dir. space. + ! NSPMIN, NSPMAX, NSPMX2 + ! Int. Public 1D spectral space range. + ! FRQ R.A. Public Expanded frequency range (Hz). + ! XSI R.A. Public Expanded frequency range (rad/s). + ! NQA Int. Public Number of actual quadruplets. + ! QST1 I.A. Public Spectral offsets for compuation of + ! quadruplet spectral desnities. + ! QST2 R.A. Public Idem weights. + ! QST3 R.A. Public Proportionality constants and k factors + ! in diagonal strength. + ! QST4 I.A. Public Spectral offsets for combining of + ! interactions and diagonal. + ! QST5 R.A. Public Idem weights for interactions. + ! QST6 R.A. Public Idem weights for diagonal. + ! SNLNQ Int. Public Number of quadruplet definitions. + ! SNLMSC Real Public Tuning power 'deep' scaling. + ! SNLNSC Real Public Tuning power 'shallow' scaling. + ! SNLSFD Real Public 'Deep' nondimensional filer freq. + ! SNLSFS Real Public 'Shallow' nondimensional filer freq. + ! SNLL R.A. Public Array with lambda for quadruplet. + ! SNLM R.A. Public Array with mu for quadruplet. + ! SNLT R.A. Public Array with Dtheta for quadruplet. + ! SNLCD R.A. Public Array with Cd for quadruplet. + ! SNLCS R.A. Public Array with Cs for quadruplet. + ! (!/NL4) + ! ITSA Int. Public Integer indicating TSA (1) or FBI (0) + ! IALT Int. Public Integer determining alternating looping + ! (!/NL5) + ! QR5DPT Real Public Water depth for the GKE module + ! QR5OML Real Public λ cut off value for quasi-resonant quartets + ! QI5DIS Int. Public Method to discretize continuous spectrum + ! QI5KEV Int. Public GKE (GS13 or J03) + ! QI5NNZ Int. Public # of interactive quadruplets + ! QI5IPL Int. Public Interp. method to get C₄ + ! QI5PMX Int. Public Phase mixing related parameter + ! (!/NLS) + ! NTHX Int. Public Expanded discrete direction range. + ! NFRX Int. Public Expanded discrete frequency range. + ! NSPL-H Int. Public Range of 1D spectrum. + ! SNSST R.A. Public Array with interpolation weights. + ! CNLSA Real Public a34 in quadruplet definition. + ! CNLSC Real Public C in Snl definition. + ! CNLSFM Real Public Maximum relative spectral change. + ! CNLSC1/3 Real Public Constant in frequency filter. + ! ---------------------------------------------------------------- + ! + ! The structure SBTP contains parameters for the bottom friction + ! source term and is aliased as above: + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! SBTC1 Real Public Proportionality constant. (!/BT1) + ! SBTCX R.A. Public Parameters for bottom fric. (!/BT4) + ! ---------------------------------------------------------------- + ! + ! The structure SDBP contains parameters for the depth incduced + ! breaking source term and is aliased as above: + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! SDBC1 Real Public Proportionality constant. (!/DB1) + ! SDBC2 Real Public Hmax/d ratio. (!/DB1) + ! FDONLY Log. Public Flag for checking depth only (!/DB1) + ! otherwise Miche criterion. + ! ---------------------------------------------------------------- + ! + ! The structure STRP contains parameters for the triad interaction + ! source term and is aliased as above: + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! The structure SBSP contains parameters for the bottom scattering + ! source term and is aliased as above: + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! The structure SICP contains parameters for arbitrary source + ! term and is aliased as above: + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! IS1C1 Real Public Scale factor for icecon. (!/ISx) + ! IS1C2 Real Public Offset for ice concentration (!/ISx) + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3NMOD Subr. Public Set number of grids. + ! W3DIMX Subr. Public Set dimensions of spatial grid. + ! W3DIMS Subr. Public Set dimensions of spectral grid. + ! W3SETG Subr. Public Point to selected grid / model. + ! W3GNTX Subr. Public Construct grid arrays + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! EXTCDE Subr. W3SERVMD Abort program with exit code. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! - In model versions before 3.06 the parameters in the grid + ! structure were stored in the module W3IOGR. + ! - No subroutine DIMP is provided, instead, arrays are set + ! one-by-one in W3IOGR. + ! + ! 6. Switches : + ! + ! See subroutine documentation. + ! + ! !/PRn Select propagation scheme + ! !/SMC UNO2 propagation on SMC grid. + ! + ! !/LNn Select source terms + ! !/STn + ! !/NLn + ! !/BTn + ! !/DBn + ! !/TRn + ! !/BSn + ! !/XXn + ! + ! !/S Enable subroutine tracing. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ Required modules + !/ + use wav_shr_flags + USE W3GSRUMD + + ! module default + IMPLICIT NONE + !/ + !/ Specify default accessibility + !/ + PUBLIC + !/ + !/ Module private variable for checking error returns + !/ + INTEGER, PRIVATE :: ISTAT + !/ + !/ Conventional declarations + !/ + INTEGER :: NGRIDS = -1, IGRID = -1, ISGRD = -1, IPARS = -1, NAUXGR + ! #ifdef W3_IC4 - INTEGER, PARAMETER :: NIC4=10 + INTEGER, PARAMETER :: NIC4=10 #endif - INTEGER, PARAMETER :: RLGTYPE = 1 - INTEGER, PARAMETER :: CLGTYPE = 2 - INTEGER, PARAMETER :: UNGTYPE = 3 - INTEGER, PARAMETER :: SMCTYPE = 4 + INTEGER, PARAMETER :: RLGTYPE = 1 + INTEGER, PARAMETER :: CLGTYPE = 2 + INTEGER, PARAMETER :: UNGTYPE = 3 + INTEGER, PARAMETER :: SMCTYPE = 4 - INTEGER, PARAMETER :: ICLOSE_NONE = ICLO_NONE - INTEGER, PARAMETER :: ICLOSE_SMPL = ICLO_SMPL - INTEGER, PARAMETER :: ICLOSE_TRPL = ICLO_TRPL -! -! Dimensions of tables for pre-computing of dissipation -! + INTEGER, PARAMETER :: ICLOSE_NONE = ICLO_NONE + INTEGER, PARAMETER :: ICLOSE_SMPL = ICLO_SMPL + INTEGER, PARAMETER :: ICLOSE_TRPL = ICLO_TRPL + ! + ! Dimensions of tables for pre-computing of dissipation + ! #ifdef W3_ST4 - INTEGER, PARAMETER :: NKHS=2000, NKD=1300 - INTEGER, PARAMETER :: NDTAB=2000 -#endif -!/ -!/ Data structures -!/ -!/ Grid type - TYPE GRID ! this is the geographical grid with all associated parameters - INTEGER :: GTYPE - INTEGER :: RSTYPE = -1 - INTEGER :: ICLOSE - INTEGER :: NX, NY, NSEA, NSEAL, TRFLAG -#ifdef W3_SEC1 - INTEGER :: NITERSEC1 -#endif - INTEGER, POINTER :: MAPSTA(:,:), MAPST2(:,:), & - MAPFS(:,:), MAPSF(:,:) -! + INTEGER, PARAMETER :: NKHS=2000, NKD=1300 + INTEGER, PARAMETER :: NDTAB=2000 +#endif + !/ + !/ Data structures + !/ + !/ Grid type + TYPE GRID ! this is the geographical grid with all associated parameters + INTEGER :: GTYPE + INTEGER :: RSTYPE = -1 + INTEGER :: ICLOSE + INTEGER :: NX, NY, NSEA, NSEAL, TRFLAG + INTEGER :: NITERSEC1 + INTEGER, POINTER :: MAPSTA(:,:), MAPST2(:,:), MAPFS(:,:), MAPSF(:,:) + ! #ifdef W3_SMC - !!Li Cell and face arrays for SMC grid. - INTEGER :: NCel, NUFc, NVFc, NRLv, MRFct - INTEGER :: NGLO, NARC, NBGL, NBAC, NBSMC - INTEGER, POINTER :: NLvCel(:), NLvUFc(:), NLvVFc(:) - INTEGER, POINTER :: IJKCel(:,:), IJKUFc(:,:), IJKVFc(:,:) - INTEGER, POINTER :: ISMCBP(:), ICLBAC(:) - -!/ Data duplicated for better performance - INTEGER, POINTER :: IJKCel3(:), IJKCel4(:), & - IJKVFc5(:), IJKVFc6(:), & - IJKUFc5(:), IJKUFc6(:) -#endif -! - REAL :: SX, SY, X0, Y0, DTCFL, DTCFLI, DTMAX, & - DTMIN, DMIN, CTMAX, FICE0, FICEN, FICEL, & - PFMOVE, STEXU, STEYU, STEDU, IICEHMIN, & - IICEHINIT, ICESCALES(4), IICEHFAC, IICEHDISP, & - IICEDDISP, IICEFDISP, BTBETA, AAIRCMIN, AAIRGB - - REAL(8) :: GRIDSHIFT ! see notes in WMGHGH + !!Li Cell and face arrays for SMC grid. + INTEGER :: NCel, NUFc, NVFc, NRLv, MRFct + INTEGER :: NGLO, NARC, NBGL, NBAC, NBSMC + INTEGER, POINTER :: NLvCel(:), NLvUFc(:), NLvVFc(:) + INTEGER, POINTER :: IJKCel(:,:), IJKUFc(:,:), IJKVFc(:,:) + INTEGER, POINTER :: ISMCBP(:), ICLBAC(:) + !/ Data duplicated for better performance + INTEGER, POINTER :: IJKCel3(:), IJKCel4(:) + INTEGER, POINTER :: IJKVFc5(:), IJKVFc6(:) + INTEGER, POINTER :: IJKUFc5(:), IJKUFc6(:) +#endif + ! + REAL :: SX, SY, X0, Y0, DTCFL, DTCFLI, DTMAX + REAL :: DTMIN, DMIN, CTMAX, FICE0, FICEN, FICEL + REAL :: PFMOVE, STEXU, STEYU, STEDU, IICEHMIN + REAL :: IICEHINIT, ICESCALES(4), IICEHFAC, IICEHDISP + REAL :: IICEDDISP, IICEFDISP, BTBETA, AAIRCMIN, AAIRGB + REAL(8) :: GRIDSHIFT ! see notes in WMGHGH #ifdef W3_RTD - REAL :: PoLat, PoLon ! Rotated N-Pole lat/lon - REAL, POINTER :: AnglD(:) ! Angle in degree - LOGICAL :: FLAGUNR -#endif + REAL :: PoLat, PoLon ! Rotated N-Pole lat/lon + REAL, POINTER :: AnglD(:) ! Angle in degree + LOGICAL :: FLAGUNR +#endif + REAL, POINTER :: ZB(:) ! BOTTOM GRID, DEFINED ON ISEA + REAL, POINTER :: CLATS(:) ! COS(LAT), DEFINED ON SEA POINTS + REAL, POINTER :: CLATIS(:) ! INVERSE OF COS(LAT) DEFINED ON ISEA + REAL, POINTER :: CTHG0S(:) ! TAN(Y)/R, DEFINED ON ISEA - REAL , POINTER :: ZB(:) ! BOTTOM GRID, DEFINED ON ISEA - REAL , POINTER :: CLATS(:) ! COS(LAT), DEFINED ON SEA POINTS - REAL , POINTER :: CLATIS(:) ! INVERSE OF COS(LAT) DEFINED ON ISEA - REAL , POINTER :: CTHG0S(:) ! TAN(Y)/R, DEFINED ON ISEA - - REAL , POINTER :: TRNX(:,:), TRNY(:,:) ! TRANSPARENCY INFORMATION ON IX,IY + REAL, POINTER :: TRNX(:,:), TRNY(:,:) ! TRANSPARENCY INFORMATION ON IX,IY #ifdef W3_SMC - REAL, POINTER :: CTRNX(:), CTRNY(:), CLATF(:) -#endif - REAL , POINTER :: SPCBAC(:,:), ANGARC(:) - DOUBLE PRECISION, POINTER :: XGRD(:,:), YGRD(:,:) ! X AND Y DEFINED ON IX,IY - REAL , POINTER :: DXDP(:,:), DXDQ(:,:) ! DX/DP & DX/DQ DEFINED ON IX,IY - REAL , POINTER :: DYDP(:,:), DYDQ(:,:) ! DY/DP & DY/DQ DEFINED ON IX,IY - REAL , POINTER :: DPDX(:,:), DPDY(:,:) ! DP/DX & DP/DY DEFINED ON IX,IY - REAL , POINTER :: DQDX(:,:), DQDY(:,:) ! DQ/DX & DQ/DY DEFINED ON IX,IY - REAL , POINTER :: GSQRT(:,:) ! SQRT(G) DEFINED ON IX,IY - REAL , POINTER :: HPFAC(:,:) ! H_P = SQRT(G_PP) DEFINED ON IX,IY - REAL , POINTER :: HQFAC(:,:) ! H_Q = SQRT(G_QQ) DEFINED ON IX,IY + REAL, POINTER :: CTRNX(:), CTRNY(:), CLATF(:) +#endif + REAL, POINTER :: SPCBAC(:,:), ANGARC(:) + DOUBLE PRECISION, POINTER :: XGRD(:,:), YGRD(:,:) ! X AND Y DEFINED ON IX,IY + REAL, POINTER :: DXDP(:,:), DXDQ(:,:) ! DX/DP & DX/DQ DEFINED ON IX,IY + REAL, POINTER :: DYDP(:,:), DYDQ(:,:) ! DY/DP & DY/DQ DEFINED ON IX,IY + REAL, POINTER :: DPDX(:,:), DPDY(:,:) ! DP/DX & DP/DY DEFINED ON IX,IY + REAL, POINTER :: DQDX(:,:), DQDY(:,:) ! DQ/DX & DQ/DY DEFINED ON IX,IY + REAL, POINTER :: GSQRT(:,:) ! SQRT(G) DEFINED ON IX,IY + REAL, POINTER :: HPFAC(:,:) ! H_P = SQRT(G_PP) DEFINED ON IX,IY + REAL, POINTER :: HQFAC(:,:) ! H_Q = SQRT(G_QQ) DEFINED ON IX,IY - LOGICAL :: GINIT, FLDRY, FLCX, FLCY, FLCTH, FLCK, FLSOU, IICEDISP,& - IICESMOOTH - LOGICAL :: FLAGLL - LOGICAL :: CMPRTRCK - LOGICAL, POINTER :: FLAGST(:) - CHARACTER(LEN=30):: GNAME - CHARACTER(LEN=13):: FILEXT - LOGICAL :: GUGINIT + LOGICAL :: GINIT, FLDRY, FLCX, FLCY, FLCTH, FLCK, FLSOU, IICEDISP, IICESMOOTH + LOGICAL :: FLAGLL + LOGICAL :: CMPRTRCK + LOGICAL, POINTER :: FLAGST(:) + CHARACTER(LEN=30) :: GNAME + CHARACTER(LEN=13) :: FILEXT + LOGICAL :: GUGINIT #ifdef W3_REF1 - REAL, POINTER :: REFLC(:,:) ! reflection coefficient - INTEGER, POINTER :: REFLD(:,:) ! reflection direction -#endif - INTEGER :: E3DF(3,5), P2MSF(3), US3DF(3), USSPF(2) ! freq. indices for 3D output - REAL :: USSP_WN(25) !Max set to 25 decay scales. -! - TYPE(T_GSU) :: GSU ! Grid search utility object -! - REAL :: FFACBERG ! mutiplicative factor for iceberg mask + REAL, POINTER :: REFLC(:,:) ! reflection coefficient + INTEGER, POINTER :: REFLD(:,:) ! reflection direction +#endif + INTEGER :: E3DF(3,5), P2MSF(3), US3DF(3), USSPF(2) ! freq. indices for 3D output + REAL :: USSP_WN(25) !Max set to 25 decay scales. + ! + TYPE(T_GSU) :: GSU ! Grid search utility object + ! + REAL :: FFACBERG ! mutiplicative factor for iceberg mask #ifdef W3_BT4 - REAL, POINTER :: SED_D50(:), SED_PSIC(:) + REAL, POINTER :: SED_D50(:), SED_PSIC(:) #endif #ifdef W3_REF1 - LOGICAL, POINTER :: RREF(:) - REAL, POINTER :: REFPARS(:) + LOGICAL, POINTER :: RREF(:) + REAL, POINTER :: REFPARS(:) #endif #ifdef W3_IG1 - REAL, POINTER :: IGPARS(:) + REAL, POINTER :: IGPARS(:) #endif #ifdef W3_IC2 - REAL, POINTER :: IC2PARS(:) + REAL, POINTER :: IC2PARS(:) #endif #ifdef W3_IC3 - REAL, POINTER :: IC3PARS(:) + REAL, POINTER :: IC3PARS(:) #endif #ifdef W3_IC4 - INTEGER, POINTER :: IC4PARS(:) - REAL, POINTER :: IC4_KI(:) - REAL, POINTER :: IC4_FC(:) + INTEGER, POINTER :: IC4PARS(:) + REAL, POINTER :: IC4_KI(:) + REAL, POINTER :: IC4_FC(:) #endif #ifdef W3_IC5 - REAL, POINTER :: IC5PARS(:) + REAL, POINTER :: IC5PARS(:) #endif #ifdef W3_IS2 - REAL, POINTER :: IS2PARS(:) + REAL, POINTER :: IS2PARS(:) #endif -! -! unstructured data -! - INTEGER :: NTRI - INTEGER, POINTER :: TRIGP(:,:) + ! + ! unstructured data + ! + INTEGER :: NTRI + INTEGER, POINTER :: TRIGP(:,:) #ifdef W3_PDLIB - INTEGER :: NBND_MAP - INTEGER, POINTER :: INDEX_MAP(:) - INTEGER, POINTER :: MAPSTA_LOC(:) - INTEGER*1, POINTER :: IOBPD_LOC(:,:) - INTEGER*2, POINTER :: IOBP_LOC(:) - INTEGER*1, POINTER :: IOBDP_LOC(:) - INTEGER*1, POINTER :: IOBPA_LOC(:) + INTEGER :: NBND_MAP + INTEGER, POINTER :: INDEX_MAP(:) + INTEGER, POINTER :: MAPSTA_LOC(:) + INTEGER*1, POINTER :: IOBPD_LOC(:,:) + INTEGER*2, POINTER :: IOBP_LOC(:) + INTEGER*1, POINTER :: IOBDP_LOC(:) + INTEGER*1, POINTER :: IOBPA_LOC(:) #endif - REAL(8), POINTER :: LEN(:,:),SI(:), IEN(:,:) + REAL(8), POINTER :: LEN(:,:),SI(:), IEN(:,:) - REAL :: MAXX, MAXY, DXYMAX - REAL, POINTER :: ANGLE(:,:),ANGLE0(:,:) - INTEGER :: COUNTRI,COUNTOT,NNZ, NBEDGE - INTEGER, POINTER :: CCON(:), COUNTCON(:), IE_CELL(:), & - POS_CELL(:), & - IAA(:), JAA(:), POSI(:,:), INDEX_CELL(:), & - I_DIAG(:), JA_IE(:,:,:) - INTEGER*2, POINTER :: IOBP(:) - INTEGER*1, POINTER :: IOBPD(:,:), IOBDP(:), IOBPA(:) - INTEGER, POINTER :: EDGES(:,:), NEIGH(:,:) - REAL(8), POINTER :: TRIA(:) - REAL, POINTER :: CROSSDIFF(:,:) + REAL :: MAXX, MAXY, DXYMAX + REAL, POINTER :: ANGLE(:,:),ANGLE0(:,:) + INTEGER :: COUNTRI,COUNTOT,NNZ, NBEDGE + INTEGER, POINTER :: CCON(:), COUNTCON(:), IE_CELL(:), POS_CELL(:) + INTEGER, POINTER :: IAA(:), JAA(:), POSI(:,:), INDEX_CELL(:) + INTEGER, POINTER :: I_DIAG(:), JA_IE(:,:,:) + INTEGER*2, POINTER :: IOBP(:) + INTEGER*1, POINTER :: IOBPD(:,:), IOBDP(:), IOBPA(:) + INTEGER, POINTER :: EDGES(:,:), NEIGH(:,:) + REAL(8), POINTER :: TRIA(:) + REAL, POINTER :: CROSSDIFF(:,:) #ifdef W3_UOST - CHARACTER(LEN=256) :: UOSTFILELOCAL, UOSTFILESHADOW - LOGICAL, ALLOCATABLE :: UOST_LCL_OBSTRUCTED(:,:), UOST_SHD_OBSTRUCTED(:,:) - INTEGER*1, ALLOCATABLE :: UOSTLOCALALPHA(:,:,:,:), UOSTLOCALBETA(:,:,:,:) - INTEGER*1, ALLOCATABLE :: UOSTSHADOWALPHA(:,:,:,:), UOSTSHADOWBETA(:,:,:,:) - REAL*4, ALLOCATABLE :: UOSTCELLSIZE(:,:,:) - REAL :: UOSTABMULTFACTOR = 100 - REAL :: UOSTCELLSIZEFACTOR = 1000 - REAL :: UOSTLOCALFACTOR = 1 - REAL :: UOSTSHADOWFACTOR = 1 - LOGICAL :: UOSTENABLED = .true. + CHARACTER(LEN=256) :: UOSTFILELOCAL, UOSTFILESHADOW + LOGICAL, ALLOCATABLE :: UOST_LCL_OBSTRUCTED(:,:), UOST_SHD_OBSTRUCTED(:,:) + INTEGER*1, ALLOCATABLE :: UOSTLOCALALPHA(:,:,:,:), UOSTLOCALBETA(:,:,:,:) + INTEGER*1, ALLOCATABLE :: UOSTSHADOWALPHA(:,:,:,:), UOSTSHADOWBETA(:,:,:,:) + REAL*4, ALLOCATABLE :: UOSTCELLSIZE(:,:,:) + REAL :: UOSTABMULTFACTOR = 100 + REAL :: UOSTCELLSIZEFACTOR = 1000 + REAL :: UOSTLOCALFACTOR = 1 + REAL :: UOSTSHADOWFACTOR = 1 + LOGICAL :: UOSTENABLED = .true. #endif - END TYPE GRID -! - TYPE SGRD ! this is the spectral grid with all parameters that vary with freq. and direction - INTEGER :: NK=0, NK2=0, NTH=0, NSPEC=0 - INTEGER, POINTER :: MAPWN(:), MAPTH(:) - REAL :: DTH=0., XFR=0., FR1=0., FTE=0., FTF=0., FTWN=0., FTTR=0., & - FTWL=0., FACTI1=0., FACTI2=0., FACHFA=0., FACHFE=0. - REAL, POINTER :: TH(:), ESIN(:), ECOS(:), ES2(:), & - ESC(:), EC2(:), SIG(:), SIG2(:), & - DSIP(:), DSII(:), DDEN(:), DDEN2(:) - LOGICAL :: SINIT=.FALSE. - END TYPE SGRD -! - TYPE NPAR - REAL :: FACP, XREL, XFLT, FXFM, FXPM, & - XFT, XFC, FACSD, FHMAX + END TYPE GRID + ! + TYPE SGRD ! this is the spectral grid with all parameters that vary with freq. and direction + INTEGER :: NK=0, NK2=0, NTH=0, NSPEC=0 + INTEGER, POINTER :: MAPWN(:), MAPTH(:) + REAL :: DTH=0., XFR=0., FR1=0., FTE=0., FTF=0., FTWN=0., FTTR=0. + REAL :: FTWL=0., FACTI1=0., FACTI2=0., FACHFA=0., FACHFE=0. + REAL, POINTER :: TH(:), ESIN(:), ECOS(:), ES2(:), ESC(:), EC2(:), SIG(:), SIG2(:) + REAL, POINTER :: DSIP(:), DSII(:), DDEN(:), DDEN2(:) + LOGICAL :: SINIT=.FALSE. + END TYPE SGRD + ! + TYPE NPAR + REAL :: FACP, XREL, XFLT, FXFM, FXPM, XFT, XFC, FACSD, FHMAX #ifdef W3_RWND - REAL :: RWINDC + REAL :: RWINDC #endif #ifdef W3_WCOR - REAL :: WWCOR(2) + REAL :: WWCOR(2) #endif - END TYPE NPAR -! - TYPE PROP + END TYPE NPAR + ! + TYPE PROP #ifdef W3_PR0 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_PR1 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_PR2 - REAL :: DTME, CLATMN + REAL :: DTME, CLATMN #endif #ifdef W3_PR3 - REAL :: WDCG, WDTH + REAL :: WDCG, WDTH #endif #ifdef W3_SMC - REAL :: DTMS, Refran - LOGICAL :: FUNO3, FVERG, FSWND, ARCTC + REAL :: DTMS, Refran + LOGICAL :: FUNO3, FVERG, FSWND, ARCTC #endif - END TYPE PROP -! - TYPE FLDP - REAL :: DUMMY + END TYPE PROP + ! + TYPE FLDP + REAL :: DUMMY #ifdef W3_FLD1 - INTEGER :: Tail_ID - REAL :: Tail_Lev, TAIL_TRAN1, TAIL_TRAN2 + INTEGER :: Tail_ID + REAL :: Tail_Lev, TAIL_TRAN1, TAIL_TRAN2 #endif #ifdef W3_FLD2 - INTEGER :: Tail_ID - REAL :: Tail_Lev, TAIL_TRAN1, TAIL_TRAN2 + INTEGER :: Tail_ID + REAL :: Tail_Lev, TAIL_TRAN1, TAIL_TRAN2 #endif - END TYPE FLDP - TYPE SFLP + END TYPE FLDP + TYPE SFLP #ifdef W3_FLX0 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_FLX1 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_FLX2 - INTEGER :: NITTIN - REAL :: CINXSI + INTEGER :: NITTIN + REAL :: CINXSI #endif #ifdef W3_FLX3 - INTEGER :: NITTIN, CAP_ID - REAL :: CINXSI, CD_MAX + INTEGER :: NITTIN, CAP_ID + REAL :: CINXSI, CD_MAX #endif #ifdef W3_FLX4 - REAL :: FLX4A0 + REAL :: FLX4A0 #endif - END TYPE SFLP -! - TYPE SLNP + END TYPE SFLP + ! + TYPE SLNP #ifdef W3_SEED - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_LN0 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_LN1 - REAL :: SLNC1, FSPM, FSHF + REAL :: SLNC1, FSPM, FSHF #endif - END TYPE SLNP -! - TYPE SRCP - REAL :: WWNMEANPTAIL, SSTXFTFTAIL + END TYPE SLNP + ! + TYPE SRCP + REAL :: WWNMEANPTAIL, SSTXFTFTAIL #ifdef W3_ST1 - REAL :: SINC1, SDSC1 + REAL :: SINC1, SDSC1 #endif #ifdef W3_ST2 - REAL :: ZWIND, FSWELL, SHSTAB, & - OFSTAB, CCNG, CCPS, FFNG, FFPS, & - CDSA0, CDSA1, CDSA2, SDSALN, & - CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, & - XFH, XF1, XF2 + REAL :: ZWIND, FSWELL, SHSTAB, OFSTAB, CCNG, CCPS, FFNG, FFPS + REAL :: CDSA0, CDSA1, CDSA2, SDSALN + REAL :: CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, XFH, XF1, XF2 #endif #ifdef W3_ST3 - INTEGER :: SSDSISO, SSDSBRFDF - REAL :: AALPHA, BBETA, ZZ0MAX, ZZ0RAT, ZZALP,& - SSINTHP, TTAUWSHELTER, SSWELLF(1:6), & - SSDSC1, SSDSC2, SSDSC3, SSDSBR, & - SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, & - FFXPM, FFXFM, & - SSDSC4, SSDSC5, SSDSC6, DDELTA1, & - DDELTA2, ZZWND -#endif -! + INTEGER :: SSDSISO, SSDSBRFDF + REAL :: AALPHA, BBETA, ZZ0MAX, ZZ0RAT, ZZALP + REAL :: SSINTHP, TTAUWSHELTER, SSWELLF(1:6) + REAL :: SSDSC1, SSDSC2, SSDSC3, SSDSBR + REAL :: SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, FFXPM, FFXFM + REAL :: SSDSC4, SSDSC5, SSDSC6, DDELTA1, DDELTA2, ZZWND +#endif + ! #ifdef W3_ST4 - INTEGER :: SSWELLFPAR, SSDSISO, SSDSBRFDF - INTEGER, POINTER :: IKTAB(:,:), SATINDICES(:,:) - REAL, POINTER :: DCKI(:,:), SATWEIGHTS(:,:),CUMULW(:,:),QBI(:,:) - REAL :: AALPHA, BBETA, ZZ0MAX, ZZ0RAT, ZZALP,& - SSINTHP, TTAUWSHELTER, SSWELLF(1:7), & - SSDSC(1:21), SSDSBR, & - SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, & - FFXPM, FFXFM, FFXFA, & - SSDSBRF1, SSDSBRF2, SSDSBINT,SSDSBCK,& - SSDSHCK, SSDSABK, SSDSPBK, SSINBR - REAL :: ZZWND - REAL :: SSDSCOS, SSDSDTH, SSDSBT, SSDSBM(0:4) -#endif -! + INTEGER :: SSWELLFPAR, SSDSISO, SSDSBRFDF + INTEGER, POINTER :: IKTAB(:,:), SATINDICES(:,:) + REAL, POINTER :: DCKI(:,:), SATWEIGHTS(:,:),CUMULW(:,:),QBI(:,:) + REAL :: AALPHA, BBETA, ZZ0MAX, ZZ0RAT, ZZALP + REAL :: SSINTHP, TTAUWSHELTER, SSWELLF(1:7), SSDSC(1:21), SSDSBR + REAL :: SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, FFXPM, FFXFM, FFXFA + REAL :: SSDSBRF1, SSDSBRF2, SSDSBINT,SSDSBCK, SSDSHCK, SSDSABK, SSDSPBK + REAL :: SSINBR, ZZWND + REAL :: SSDSCOS, SSDSDTH, SSDSBT, SSDSBM(0:4) +#endif + ! #ifdef W3_ST6 - REAL :: SIN6A0, SDS6A1, SDS6A2, SWL6B1, & - SIN6WS, SIN6FC - INTEGER :: SDS6P1, SDS6P2 - LOGICAL :: SDS6ET, SWL6S6, SWL6CSTB1 -#endif - END TYPE SRCP -! - TYPE SNLP + REAL :: SIN6A0, SDS6A1, SDS6A2, SWL6B1, SIN6WS, SIN6FC + INTEGER :: SDS6P1, SDS6P2 + LOGICAL :: SDS6ET, SWL6S6, SWL6CSTB1 +#endif + END TYPE SRCP + ! + TYPE SNLP #ifdef W3_NL0 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_NL1 - REAL :: SNLC1, LAM, KDCON, KDMN, & - SNLS1, SNLS2, SNLS3 + REAL :: SNLC1, LAM, KDCON, KDMN, SNLS1, SNLS2, SNLS3 #endif #ifdef W3_NL2 - INTEGER :: IQTPE, NDPTHS - REAL :: NLTAIL - REAL, POINTER :: DPTHNL(:) + INTEGER :: IQTPE, NDPTHS + REAL :: NLTAIL + REAL, POINTER :: DPTHNL(:) #endif #ifdef W3_NL3 - INTEGER :: NFRMIN, NFRMAX, NFRCUT, NTHMAX, & - NTHEXP, NSPMIN, NSPMAX, NSPMX2, & - NQA, SNLNQ - INTEGER, POINTER :: QST1(:,:,:), QST4(:,:,:) - REAL :: SNLMSC, SNLNSC, SNLSFD, SNLSFS - REAL, POINTER :: FRQ(:), XSI(:), & - QST2(:,:,:), QST3(:,:,:), & - QST5(:,:,:), QST6(:,:,:), & - SNLL(:), SNLM(:), SNLT(:), & - SNLCD(:), SNLCS(:) + INTEGER :: NFRMIN, NFRMAX, NFRCUT, NTHMAX, NTHEXP, NSPMIN, NSPMAX, NSPMX2 + INTEGER :: NQA, SNLNQ + INTEGER, POINTER :: QST1(:,:,:), QST4(:,:,:) + REAL :: SNLMSC, SNLNSC, SNLSFD, SNLSFS + REAL, POINTER :: FRQ(:), XSI(:), QST2(:,:,:), QST3(:,:,:), QST5(:,:,:), QST6(:,:,:) + REAL, POINTER :: SNLL(:), SNLM(:), SNLT(:), SNLCD(:), SNLCS(:) #endif #ifdef W3_NL4 - INTEGER :: ITSA, IALT + INTEGER :: ITSA, IALT #endif #ifdef W3_NL5 - REAL :: QR5DPT, QR5OML - INTEGER :: QI5DIS, QI5KEV, QI5IPL, QI5PMX - INTEGER(KIND=8) :: QI5NNZ + REAL :: QR5DPT, QR5OML + INTEGER :: QI5DIS, QI5KEV, QI5IPL, QI5PMX + INTEGER(KIND=8) :: QI5NNZ #endif #ifdef W3_NLS - INTEGER :: NTHX, NFRX, NSPL, NSPH - REAL :: CNLSA, CNLSC, CNLSFM, & - CNLSC1, CNLSC2, CNLSC3 - REAL, POINTER :: SNSST(:,:) + INTEGER :: NTHX, NFRX, NSPL, NSPH + REAL :: CNLSA, CNLSC, CNLSFM, CNLSC1, CNLSC2, CNLSC3 + REAL, POINTER :: SNSST(:,:) #endif - END TYPE SNLP -! - TYPE SBTP + END TYPE SNLP + ! + TYPE SBTP #ifdef W3_BT0 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_BT1 - REAL :: SBTC1 + REAL :: SBTC1 #endif #ifdef W3_BT4 - REAL :: SBTCX(10) + REAL :: SBTCX(10) #endif #ifdef W3_BT8 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_BT9 - REAL :: DUMMY + REAL :: DUMMY #endif - END TYPE SBTP -! - TYPE SDBP + END TYPE SBTP + ! + TYPE SDBP #ifdef W3_DB0 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_DB1 - REAL :: SDBC1, SDBC2 - LOGICAL :: FDONLY - REAL :: SDBSC + REAL :: SDBC1, SDBC2 + LOGICAL :: FDONLY + REAL :: SDBSC #endif - END TYPE SDBP + END TYPE SDBP #ifdef W3_UOST - TYPE UOSTP - CHARACTER(LEN=256) :: UOSTFILELOCAL, UOSTFILESHADOW - REAL :: UOSTFACTORLOCAL, UOSTFACTORSHADOW - END TYPE UOSTP + TYPE UOSTP + CHARACTER(LEN=256) :: UOSTFILELOCAL, UOSTFILESHADOW + REAL :: UOSTFACTORLOCAL, UOSTFACTORSHADOW + END TYPE UOSTP #endif -! - TYPE STRP + ! + TYPE STRP #ifdef W3_TR0 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_TR1 - REAL :: DUMMY + REAL :: DUMMY #endif - END TYPE STRP -! - TYPE SBSP + END TYPE STRP + ! + TYPE SBSP #ifdef W3_BS0 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_BS1 - REAL :: DUMMY + REAL :: DUMMY #endif - END TYPE SBSP -! - TYPE SICP + END TYPE SBSP + ! + TYPE SICP #ifdef W3_IS0 - REAL :: DUMMY + REAL :: DUMMY #endif #ifdef W3_IS1 - REAL :: IS1C1, IS1C2 + REAL :: IS1C1, IS1C2 #endif #ifdef W3_IS2 - REAL :: IS2C1, IS2C2 -#endif - END TYPE SICP - -! specific type for unstructured scheme - TYPE SCHM - LOGICAL :: FSN = .FALSE. - LOGICAL :: FSPSI = .FALSE. - LOGICAL :: FSFCT = .FALSE. - LOGICAL :: FSNIMP = .FALSE. - LOGICAL :: FSTOTALIMP = .FALSE. - LOGICAL :: FSTOTALEXP = .FALSE. - LOGICAL :: FSREFRACTION = .FALSE. - LOGICAL :: FSFREQSHIFT = .FALSE. - LOGICAL :: FSSOURCE = .FALSE. - LOGICAL :: FSBCCFL = .FALSE. - LOGICAL :: DO_CHANGE_WLV - REAL(8) :: SOLVERTHR_STP - REAL(8) :: CRIT_DEP_STP - LOGICAL :: B_JGS_TERMINATE_MAXITER - LOGICAL :: B_JGS_TERMINATE_DIFFERENCE - LOGICAL :: B_JGS_TERMINATE_NORM - LOGICAL :: B_JGS_LIMITER - LOGICAL :: B_JGS_USE_JACOBI - LOGICAL :: B_JGS_BLOCK_GAUSS_SEIDEL - INTEGER :: B_JGS_MAXITER - REAL*8 :: B_JGS_PMIN - REAL*8 :: B_JGS_DIFF_THR - REAL*8 :: B_JGS_NORM_THR - INTEGER :: B_JGS_NLEVEL - LOGICAL :: B_JGS_SOURCE_NONLINEAR - END TYPE SCHM -! -! - TYPE MPAR - LOGICAL :: PINIT - TYPE(NPAR) :: NPARS - TYPE(PROP) :: PROPS - TYPE(FLDP) :: FLDPS - TYPE(SFLP) :: SFLPS - TYPE(SLNP) :: SLNPS - TYPE(SRCP) :: SRCPS - TYPE(SNLP) :: SNLPS - TYPE(SBTP) :: SBTPS - TYPE(SDBP) :: SDBPS -#ifdef W3_UOST - TYPE(UOSTP) :: UOSTPS + REAL :: IS2C1, IS2C2 #endif - TYPE(STRP) :: STRPS - TYPE(SBSP) :: SBSPS - TYPE(SICP) :: SICPS - TYPE(SCHM) :: SCHMS - END TYPE MPAR -!/ -!/ Data storage -!/ - TYPE(GRID), TARGET, ALLOCATABLE :: GRIDS(:) - TYPE(SGRD), TARGET, ALLOCATABLE :: SGRDS(:) - TYPE(MPAR), TARGET, ALLOCATABLE :: MPARS(:) -!/ -!/ Data aliases for structure GRID(S) -!/ - INTEGER, POINTER :: GTYPE - INTEGER, POINTER :: RSTYPE - INTEGER, POINTER :: ICLOSE - INTEGER, POINTER :: NX, NY, NSEA, NSEAL, TRFLAG - INTEGER, POINTER :: E3DF(:,:), P2MSF(:), US3DF(:), USSPF(:) - REAL, POINTER :: USSP_WN(:) + END TYPE SICP + + ! specific type for unstructured scheme + TYPE SCHM + LOGICAL :: FSN = .FALSE. + LOGICAL :: FSPSI = .FALSE. + LOGICAL :: FSFCT = .FALSE. + LOGICAL :: FSNIMP = .FALSE. + LOGICAL :: FSTOTALIMP = .FALSE. + LOGICAL :: FSTOTALEXP = .FALSE. + LOGICAL :: FSREFRACTION = .FALSE. + LOGICAL :: FSFREQSHIFT = .FALSE. + LOGICAL :: FSSOURCE = .FALSE. + LOGICAL :: FSBCCFL = .FALSE. + LOGICAL :: DO_CHANGE_WLV + REAL(8) :: SOLVERTHR_STP + REAL(8) :: CRIT_DEP_STP + LOGICAL :: B_JGS_TERMINATE_MAXITER + LOGICAL :: B_JGS_TERMINATE_DIFFERENCE + LOGICAL :: B_JGS_TERMINATE_NORM + LOGICAL :: B_JGS_LIMITER + LOGICAL :: B_JGS_USE_JACOBI + LOGICAL :: B_JGS_BLOCK_GAUSS_SEIDEL + INTEGER :: B_JGS_MAXITER + REAL*8 :: B_JGS_PMIN + REAL*8 :: B_JGS_DIFF_THR + REAL*8 :: B_JGS_NORM_THR + INTEGER :: B_JGS_NLEVEL + LOGICAL :: B_JGS_SOURCE_NONLINEAR + END TYPE SCHM + ! + TYPE MPAR + LOGICAL :: PINIT + TYPE(NPAR) :: NPARS + TYPE(PROP) :: PROPS + TYPE(FLDP) :: FLDPS + TYPE(SFLP) :: SFLPS + TYPE(SLNP) :: SLNPS + TYPE(SRCP) :: SRCPS + TYPE(SNLP) :: SNLPS + TYPE(SBTP) :: SBTPS + TYPE(SDBP) :: SDBPS +#ifdef W3_UOST + TYPE(UOSTP) :: UOSTPS +#endif + TYPE(STRP) :: STRPS + TYPE(SBSP) :: SBSPS + TYPE(SICP) :: SICPS + TYPE(SCHM) :: SCHMS + END TYPE MPAR + !/ + !/ Data storage + !/ + TYPE(GRID), TARGET, ALLOCATABLE :: GRIDS(:) + TYPE(SGRD), TARGET, ALLOCATABLE :: SGRDS(:) + TYPE(MPAR), TARGET, ALLOCATABLE :: MPARS(:) + !/ + !/ Data aliases for structure GRID(S) + !/ + INTEGER, POINTER :: GTYPE + INTEGER, POINTER :: RSTYPE + INTEGER, POINTER :: ICLOSE + INTEGER, POINTER :: NX, NY, NSEA, NSEAL, TRFLAG + INTEGER, POINTER :: E3DF(:,:), P2MSF(:), US3DF(:), USSPF(:) + REAL, POINTER :: USSP_WN(:) #ifdef W3_REF1 - REAL, POINTER :: REFLC(:,:) - INTEGER, POINTER :: REFLD(:,:) -#endif - INTEGER, POINTER :: NBEDGE - INTEGER, POINTER :: EDGES(:,:), NEIGH(:,:) -! -! Variables for unstructured grids -! - INTEGER, POINTER :: NTRI,COUNTRI,COUNTOT,NNZ - INTEGER :: optionCall = 3 ! take care all other options are basically wrong - INTEGER, POINTER :: TRIGP(:,:) + REAL, POINTER :: REFLC(:,:) + INTEGER, POINTER :: REFLD(:,:) +#endif + INTEGER, POINTER :: NBEDGE + INTEGER, POINTER :: EDGES(:,:), NEIGH(:,:) + ! + ! Variables for unstructured grids + ! + INTEGER, POINTER :: NTRI,COUNTRI,COUNTOT,NNZ + INTEGER :: optionCall = 3 ! take care all other options are basically wrong + INTEGER, POINTER :: TRIGP(:,:) #ifdef W3_PDLIB - INTEGER, POINTER :: NBND_MAP - INTEGER, POINTER :: INDEX_MAP(:) - INTEGER, POINTER :: MAPSTA_LOC(:) - INTEGER*1, POINTER :: IOBPD_LOC(:,:) - INTEGER*2, POINTER :: IOBP_LOC(:) - INTEGER*1, POINTER :: IOBDP_LOC(:) - INTEGER*1, POINTER :: IOBPA_LOC(:) + INTEGER, POINTER :: NBND_MAP + INTEGER, POINTER :: INDEX_MAP(:) + INTEGER, POINTER :: MAPSTA_LOC(:) + INTEGER*1, POINTER :: IOBPD_LOC(:,:) + INTEGER*2, POINTER :: IOBP_LOC(:) + INTEGER*1, POINTER :: IOBDP_LOC(:) + INTEGER*1, POINTER :: IOBPA_LOC(:) #endif - REAL(8), POINTER :: IEN(:,:), LEN(:,:), SI(:) - REAL, POINTER :: ANGLE(:,:),ANGLE0(:,:) - INTEGER, POINTER :: CCON(:), COUNTCON(:), IE_CELL(:), & - POS_CELL(:), & - IAA(:), JAA(:), POSI(:,:), & - I_DIAG(:), JA_IE(:,:,:), & - INDEX_CELL(:) - INTEGER*2, POINTER :: IOBP(:) - INTEGER*1, POINTER :: IOBPD(:,:), IOBDP(:), IOBPA(:) - REAL(8), POINTER :: TRIA(:) - REAL, POINTER :: CROSSDIFF(:,:) - REAL,POINTER :: MAXX, MAXY, DXYMAX - LOGICAL, POINTER :: GUGINIT -! - REAL, POINTER :: FFACBERG + REAL(8), POINTER :: IEN(:,:), LEN(:,:), SI(:) + REAL, POINTER :: ANGLE(:,:),ANGLE0(:,:) + INTEGER, POINTER :: CCON(:), COUNTCON(:), IE_CELL(:), POS_CELL(:), IAA(:), JAA(:) + INTEGER, POINTER :: POSI(:,:), I_DIAG(:), JA_IE(:,:,:), INDEX_CELL(:) + INTEGER*2, POINTER :: IOBP(:) + INTEGER*1, POINTER :: IOBPD(:,:), IOBDP(:), IOBPA(:) + REAL(8), POINTER :: TRIA(:) + REAL, POINTER :: CROSSDIFF(:,:) + REAL, POINTER :: MAXX, MAXY, DXYMAX + LOGICAL, POINTER :: GUGINIT + ! + REAL, POINTER :: FFACBERG #ifdef W3_REF1 - LOGICAL, POINTER :: RREF(:) - REAL, POINTER :: REFPARS(:) + LOGICAL, POINTER :: RREF(:) + REAL, POINTER :: REFPARS(:) #endif #ifdef W3_IG1 - REAL, POINTER :: IGPARS(:) + REAL, POINTER :: IGPARS(:) #endif #ifdef W3_IC2 - REAL, POINTER :: IC2PARS(:) + REAL, POINTER :: IC2PARS(:) #endif #ifdef W3_IC3 - REAL, POINTER :: IC3PARS(:) + REAL, POINTER :: IC3PARS(:) #endif #ifdef W3_IC4 - INTEGER, POINTER :: IC4PARS(:) - REAL, POINTER :: IC4_KI(:) - REAL, POINTER :: IC4_FC(:) + INTEGER, POINTER :: IC4PARS(:) + REAL, POINTER :: IC4_KI(:) + REAL, POINTER :: IC4_FC(:) #endif #ifdef W3_IC5 - REAL, POINTER :: IC5PARS(:) + REAL, POINTER :: IC5PARS(:) #endif #ifdef W3_IS2 - REAL, POINTER :: IS2PARS(:) + REAL, POINTER :: IS2PARS(:) #endif - INTEGER, POINTER :: MAPSTA(:,:), MAPST2(:,:), & - MAPFS(:,:), MAPSF(:,:) -! + INTEGER, POINTER :: MAPSTA(:,:), MAPST2(:,:), MAPFS(:,:), MAPSF(:,:) + ! #ifdef W3_SMC - INTEGER, POINTER :: NCel, NUFc, NVFc, NRLv, MRFct - INTEGER, POINTER :: NGLO, NARC, NBGL, NBAC, NBSMC - INTEGER, POINTER :: NLvCel(:), NLvUFc(:), NLvVFc(:) - INTEGER, POINTER :: IJKCel(:,:), IJKUFc(:,:), IJKVFc(:,:) - INTEGER, POINTER :: ISMCBP(:), ICLBAC(:) + INTEGER, POINTER :: NCel, NUFc, NVFc, NRLv, MRFct + INTEGER, POINTER :: NGLO, NARC, NBGL, NBAC, NBSMC + INTEGER, POINTER :: NLvCel(:), NLvUFc(:), NLvVFc(:) + INTEGER, POINTER :: IJKCel(:,:), IJKUFc(:,:), IJKVFc(:,:) + INTEGER, POINTER :: ISMCBP(:), ICLBAC(:) + !/ Data duplicated for better performance + INTEGER, POINTER :: IJKCel3(:), IJKCel4(:) + INTEGER, POINTER :: IJKVFc5(:), IJKVFc6(:) + INTEGER, POINTER :: IJKUFc5(:), IJKUFc6(:) +#endif + ! + INTEGER, POINTER :: NITERSEC1 + REAL, POINTER :: SX, SY, X0, Y0, DTCFL, DTCFLI, DTMAX, DTMIN, DMIN, CTMAX, FICE0, FICEN + REAL, POINTER :: FICEL, PFMOVE, STEXU, STEYU, STEDU, IICEHMIN, IICEHINIT, ICESCALES(:) + REAL, POINTER :: IICEHFAC, IICEHDISP, IICEDDISP, IICEFDISP, BTBETA, AAIRCMIN, AAIRGB + REAL(8),POINTER :: GRIDSHIFT ! see notes in WMGHGH -!/ Data duplicated for better performance - INTEGER, POINTER :: IJKCel3(:), IJKCel4(:), & - IJKVFc5(:), IJKVFc6(:), & - IJKUFc5(:), IJKUFc6(:) -!/ -#endif -! -#ifdef W3_SEC1 - INTEGER, POINTER :: NITERSEC1 -#endif - REAL, POINTER :: SX, SY, X0, Y0, DTCFL, DTCFLI, DTMAX, & - DTMIN, DMIN, CTMAX, FICE0, FICEN, & - FICEL, PFMOVE, STEXU, STEYU, STEDU, & - IICEHMIN, IICEHINIT, ICESCALES(:), & - IICEHFAC, IICEHDISP, IICEDDISP, IICEFDISP, & - BTBETA, AAIRCMIN, AAIRGB - REAL(8),POINTER :: GRIDSHIFT ! see notes in WMGHGH #ifdef W3_RTD - REAL, POINTER :: PoLat, PoLon - REAL, POINTER :: AnglD(:) - LOGICAL, POINTER :: FLAGUNR -#endif - REAL , POINTER :: ZB(:) - REAL , POINTER :: CLATS(:) - REAL , POINTER :: CLATIS(:) ! INVERSE OF COS(LAT) DEFINED ON ISEA - REAL , POINTER :: CTHG0S(:) ! TAN(Y)/R, DEFINED ON ISEA + REAL, POINTER :: PoLat, PoLon + REAL, POINTER :: AnglD(:) + LOGICAL, POINTER :: FLAGUNR +#endif + REAL, POINTER :: ZB(:) + REAL, POINTER :: CLATS(:) + REAL, POINTER :: CLATIS(:) ! INVERSE OF COS(LAT) DEFINED ON ISEA + REAL, POINTER :: CTHG0S(:) ! TAN(Y)/R, DEFINED ON ISEA - REAL , POINTER :: TRNX(:,:), TRNY(:,:) ! TRANSPARENCY INFORMATION ON IX,IY + REAL, POINTER :: TRNX(:,:), TRNY(:,:) ! TRANSPARENCY INFORMATION ON IX,IY #ifdef W3_SMC - REAL, POINTER :: CTRNX(:), CTRNY(:), CLATF(:) -#endif - REAL , POINTER :: SPCBAC(:,:), ANGARC(:) - DOUBLE PRECISION, POINTER :: XGRD(:,:), YGRD(:,:) ! X AND Y DEFINED ON IX,IY - REAL , POINTER :: DXDP(:,:), DXDQ(:,:) ! DX/DP & DX/DQ DEFINED ON IX,IY - REAL , POINTER :: DYDP(:,:), DYDQ(:,:) ! DY/DP & DY/DQ DEFINED ON IX,IY - REAL , POINTER :: DPDX(:,:), DPDY(:,:) ! DP/DX & DP/DY DEFINED ON IX,IY - REAL , POINTER :: DQDX(:,:), DQDY(:,:) ! DQ/DX & DQ/DY DEFINED ON IX,IY - REAL , POINTER :: GSQRT(:,:) ! SQRT(G) DEFINED ON IX,IY - REAL , POINTER :: HPFAC(:,:) ! H_P = SQRT(G_PP) DEFINED ON IX,IY - REAL , POINTER :: HQFAC(:,:) ! H_Q = SQRT(G_QQ) DEFINED ON IX,IY + REAL, POINTER :: CTRNX(:), CTRNY(:), CLATF(:) +#endif + REAL, POINTER :: SPCBAC(:,:), ANGARC(:) + DOUBLE PRECISION, POINTER :: XGRD(:,:), YGRD(:,:) ! X AND Y DEFINED ON IX,IY + REAL, POINTER :: DXDP(:,:), DXDQ(:,:) ! DX/DP & DX/DQ DEFINED ON IX,IY + REAL, POINTER :: DYDP(:,:), DYDQ(:,:) ! DY/DP & DY/DQ DEFINED ON IX,IY + REAL, POINTER :: DPDX(:,:), DPDY(:,:) ! DP/DX & DP/DY DEFINED ON IX,IY + REAL, POINTER :: DQDX(:,:), DQDY(:,:) ! DQ/DX & DQ/DY DEFINED ON IX,IY + REAL, POINTER :: GSQRT(:,:) ! SQRT(G) DEFINED ON IX,IY + REAL, POINTER :: HPFAC(:,:) ! H_P = SQRT(G_PP) DEFINED ON IX,IY + REAL, POINTER :: HQFAC(:,:) ! H_Q = SQRT(G_QQ) DEFINED ON IX,IY #ifdef W3_BT4 - REAL, POINTER :: SED_D50(:), SED_PSIC(:) + REAL, POINTER :: SED_D50(:), SED_PSIC(:) #endif - LOGICAL, POINTER :: GINIT, FLDRY, FLCX, FLCY, FLCTH, FLCK, FLSOU, IICEDISP,& - IICESMOOTH - LOGICAL, POINTER :: FLAGLL - LOGICAL, POINTER :: CMPRTRCK - LOGICAL, POINTER :: FLAGST(:) + LOGICAL, POINTER :: GINIT, FLDRY, FLCX, FLCY, FLCTH, FLCK, FLSOU, IICEDISP, IICESMOOTH + LOGICAL, POINTER :: FLAGLL + LOGICAL, POINTER :: CMPRTRCK + LOGICAL, POINTER :: FLAGST(:) - CHARACTER(LEN=30), POINTER :: GNAME - CHARACTER(LEN=13), POINTER :: FILEXT + CHARACTER(LEN=30), POINTER :: GNAME + CHARACTER(LEN=13), POINTER :: FILEXT - TYPE(T_GSU), POINTER :: GSU ! Grid search utility object -!/ -!/ Data aliasses for structure SGRD(S) -!/ - INTEGER, POINTER :: NK, NK2, NTH, NSPEC - INTEGER, POINTER :: MAPWN(:), MAPTH(:) - REAL, POINTER :: DTH, XFR, FR1, FTE, FTF, FTWN, FTTR, & - FTWL, FACTI1, FACTI2, FACHFA, FACHFE - REAL, POINTER :: TH(:), ESIN(:), ECOS(:), ES2(:), & - ESC(:), EC2(:), SIG(:), SIG2(:), & - DSIP(:), DSII(:), DDEN(:), DDEN2(:) - LOGICAL, POINTER :: SINIT -!/ -!/ Data aliasses for structure MPAR(S) -!/ - LOGICAL, POINTER :: PINIT -!/ -!/ Data aliasses for structure NPAR(S) -!/ - REAL, POINTER :: FACP, XREL, XFLT, FXFM, FXPM, & - XFT, XFC, FACSD, FHMAX + TYPE(T_GSU), POINTER :: GSU ! Grid search utility object + !/ + !/ Data aliasses for structure SGRD(S) + !/ + INTEGER, POINTER :: NK, NK2, NTH, NSPEC + INTEGER, POINTER :: MAPWN(:), MAPTH(:) + REAL, POINTER :: DTH, XFR, FR1, FTE, FTF, FTWN, FTTR, FTWL, FACTI1, FACTI2, FACHFA, FACHFE + REAL, POINTER :: TH(:), ESIN(:), ECOS(:), ES2(:), ESC(:), EC2(:), SIG(:), SIG2(:) + REAL, POINTER :: DSIP(:), DSII(:), DDEN(:), DDEN2(:) + LOGICAL, POINTER :: SINIT + !/ + !/ Data aliasses for structure MPAR(S) + !/ + LOGICAL, POINTER :: PINIT + !/ + !/ Data aliasses for structure NPAR(S) + !/ + REAL, POINTER :: FACP, XREL, XFLT, FXFM, FXPM, XFT, XFC, FACSD, FHMAX #ifdef W3_RWND - REAL, POINTER :: RWINDC + REAL, POINTER :: RWINDC #endif #ifdef W3_WCOR - REAL, POINTER :: WWCOR(:) + REAL, POINTER :: WWCOR(:) #endif -!/ -!/ Data aliasses for structure PROP(S) -!/ + !/ + !/ Data aliasses for structure PROP(S) + !/ #ifdef W3_PR2 - REAL, POINTER :: DTME, CLATMN + REAL, POINTER :: DTME, CLATMN #endif #ifdef W3_PR3 - REAL, POINTER :: WDCG, WDTH + REAL, POINTER :: WDCG, WDTH #endif #ifdef W3_SMC - REAL, POINTER :: DTMS, Refran - LOGICAL, POINTER :: FUNO3, FVERG, FSWND, ARCTC + REAL, POINTER :: DTMS, Refran + LOGICAL, POINTER :: FUNO3, FVERG, FSWND, ARCTC #endif -!/ -!/ Data aliasses for structure FLDP(S) -!/ + !/ + !/ Data aliasses for structure FLDP(S) + !/ #ifdef W3_FLD1 - INTEGER, POINTER :: TAIL_ID - REAL, POINTER :: TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 + INTEGER, POINTER :: TAIL_ID + REAL, POINTER :: TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 #endif #ifdef W3_FLD2 - INTEGER, POINTER :: TAIL_ID - REAL, POINTER :: TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 + INTEGER, POINTER :: TAIL_ID + REAL, POINTER :: TAIL_LEV, TAIL_TRAN1, TAIL_TRAN2 #endif -!/ -!/ Data aliasses for structure SFLP(S) -!/ + !/ + !/ Data aliasses for structure SFLP(S) + !/ #ifdef W3_FLX2 - INTEGER, POINTER :: NITTIN - REAL, POINTER :: CINXSI + INTEGER, POINTER :: NITTIN + REAL, POINTER :: CINXSI #endif #ifdef W3_FLX3 - INTEGER, POINTER :: NITTIN, CAP_ID - REAL, POINTER :: CINXSI, CD_MAX + INTEGER, POINTER :: NITTIN, CAP_ID + REAL, POINTER :: CINXSI, CD_MAX #endif #ifdef W3_FLX4 - REAL, POINTER :: FLX4A0 + REAL, POINTER :: FLX4A0 #endif -!/ -!/ Data aliasses for structure SLNP(S) -!/ + !/ + !/ Data aliasses for structure SLNP(S) + !/ #ifdef W3_LN1 - REAL, POINTER :: SLNC1, FSPM, FSHF + REAL, POINTER :: SLNC1, FSPM, FSHF #endif -!/ -!/ Data aliasses for structure SRCP(S) -!/ + !/ + !/ Data aliasses for structure SRCP(S) + !/ #ifdef W3_ST1 - REAL, POINTER :: SINC1, SDSC1 + REAL, POINTER :: SINC1, SDSC1 #endif #ifdef W3_ST2 - REAL, POINTER :: ZWIND, FSWELL, SHSTAB, & - OFSTAB, CCNG, CCPS, FFNG, FFPS, & - CDSA0, CDSA1, CDSA2, SDSALN, & - CDSB0, CDSB1, CDSB2, CDSB3, FPIMIN, & - XFH, XF1, XF2 + REAL, POINTER :: ZWIND, FSWELL, SHSTAB, OFSTAB, CCNG, CCPS, FFNG, FFPS + REAL, POINTER :: CDSA0, CDSA1, CDSA2, SDSALN, CDSB0, CDSB1, CDSB2, CDSB3 + REAL, POINTER :: FPIMIN, XFH, XF1, XF2 #endif #ifdef W3_ST3 - REAL, POINTER :: ZZWND, AALPHA, BBETA, ZZ0MAX, ZZ0RAT,& - ZZALP, FFXFM, FFXPM, & - SSINTHP, TTAUWSHELTER, SSWELLF(:), & - SSDSC1, SSDSC2, SSDSC3, SSDSBR, & - SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, & - SSDSC4, SSDSC5, SSDSC6, SSDSBT, & - DDELTA1, DDELTA2, & - SSDSCOS, SSDSDTH, SSDSBM(:) + REAL, POINTER :: ZZWND, AALPHA, BBETA, ZZ0MAX, ZZ0RAT, ZZALP, FFXFM, FFXPM + REAL, POINTER :: SSINTHP, TTAUWSHELTER, SSWELLF(:), SSDSC1, SSDSC2, SSDSC3, SSDSBR + REAL, POINTER :: SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, SSDSC4, SSDSC5, SSDSC6, SSDSBT + REAL, POINTER :: DDELTA1, DDELTA2, SSDSCOS, SSDSDTH, SSDSBM(:) #endif #ifdef W3_ST4 - INTEGER, POINTER :: SSWELLFPAR, SSDSISO,SSDSBRFDF, & - IKTAB(:,:), SATINDICES(:,:),SSDSDIK - REAL, POINTER :: DCKI(:,:), SATWEIGHTS(:,:),CUMULW(:,:),QBI(:,:) - REAL, POINTER :: ZZWND, AALPHA, BBETA, ZZ0MAX, ZZ0RAT,& - ZZALP, FFXFA, & - FFXFM, FFXPM, SSDSBRF1, SSDSBRF2, & - SSDSBINT, SSDSBCK, SSDSHCK, SSDSABK, & - SSDSPBK, SSINBR,SSINTHP,TTAUWSHELTER,& - SSWELLF(:), SSDSC(:), SSDSBR, & - SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, & - SSDSBT, SSDSCOS, SSDSDTH, SSDSBM(:) + INTEGER, POINTER :: SSWELLFPAR, SSDSISO,SSDSBRFDF, IKTAB(:,:), SATINDICES(:,:),SSDSDIK + REAL, POINTER :: DCKI(:,:), SATWEIGHTS(:,:),CUMULW(:,:),QBI(:,:) + REAL, POINTER :: ZZWND, AALPHA, BBETA, ZZ0MAX, ZZ0RAT, ZZALP, FFXFA + REAL, POINTER :: FFXFM, FFXPM, SSDSBRF1, SSDSBRF2, SSDSBINT, SSDSBCK, SSDSHCK, SSDSABK + REAL, POINTER :: SSDSPBK, SSINBR,SSINTHP,TTAUWSHELTER, SSWELLF(:), SSDSC(:), SSDSBR + REAL, POINTER :: SSDSP, WWNMEANP, SSTXFTF, SSTXFTWN, SSDSBT, SSDSCOS, SSDSDTH, SSDSBM(:) #endif #ifdef W3_ST6 - REAL, POINTER :: SIN6A0, SDS6A1, SDS6A2, SWL6B1, & - SIN6WS, SIN6FC - INTEGER, POINTER :: SDS6P1, SDS6P2 - LOGICAL, POINTER :: SDS6ET, SWL6S6, SWL6CSTB1 -#endif - REAL, POINTER :: WWNMEANPTAIL, SSTXFTFTAIL -!/ -!/ Data aliasses for structure SNLP(S) -!/ + REAL, POINTER :: SIN6A0, SDS6A1, SDS6A2, SWL6B1, SIN6WS, SIN6FC + INTEGER, POINTER :: SDS6P1, SDS6P2 + LOGICAL, POINTER :: SDS6ET, SWL6S6, SWL6CSTB1 +#endif + REAL, POINTER :: WWNMEANPTAIL, SSTXFTFTAIL + !/ + !/ Data aliasses for structure SNLP(S) + !/ #ifdef W3_NL1 - REAL, POINTER :: SNLC1, LAM, KDCON, KDMN, & - SNLS1, SNLS2, SNLS3 + REAL, POINTER :: SNLC1, LAM, KDCON, KDMN, SNLS1, SNLS2, SNLS3 #endif #ifdef W3_NL2 - INTEGER, POINTER :: IQTPE, NDPTHS - REAL, POINTER :: NLTAIL - REAL, POINTER :: DPTHNL(:) + INTEGER, POINTER :: IQTPE, NDPTHS + REAL, POINTER :: NLTAIL + REAL, POINTER :: DPTHNL(:) #endif #ifdef W3_NL3 - INTEGER, POINTER :: NFRMIN, NFRMAX, NFRCUT, NTHMAX, & - NTHEXP, NSPMIN, NSPMAX, NSPMX2, & - NQA, SNLNQ - INTEGER, POINTER :: QST1(:,:,:), QST4(:,:,:) - REAL, POINTER :: SNLMSC, SNLNSC, SNLSFD, SNLSFS - REAL, POINTER :: FRQ(:), XSI(:), & - QST2(:,:,:), QST3(:,:,:), & - QST5(:,:,:), QST6(:,:,:), & - SNLL(:), SNLM(:), SNLT(:), & - SNLCD(:), SNLCS(:) + INTEGER, POINTER :: NFRMIN, NFRMAX, NFRCUT, NTHMAX, NTHEXP, NSPMIN, NSPMAX, NSPMX2, NQA, SNLNQ + INTEGER, POINTER :: QST1(:,:,:), QST4(:,:,:) + REAL, POINTER :: SNLMSC, SNLNSC, SNLSFD, SNLSFS + REAL, POINTER :: FRQ(:), XSI(:), QST2(:,:,:), QST3(:,:,:), QST5(:,:,:), QST6(:,:,:) + REAL, POINTER :: SNLL(:), SNLM(:), SNLT(:), SNLCD(:), SNLCS(:) #endif #ifdef W3_NL4 - INTEGER, POINTER :: ITSA, IALT + INTEGER, POINTER :: ITSA, IALT #endif #ifdef W3_NL5 - REAL, POINTER :: QR5DPT, QR5OML - INTEGER, POINTER :: QI5DIS, QI5KEV, QI5IPL, QI5PMX - INTEGER(KIND=8), POINTER:: QI5NNZ + REAL, POINTER :: QR5DPT, QR5OML + INTEGER, POINTER :: QI5DIS, QI5KEV, QI5IPL, QI5PMX + INTEGER(KIND=8), POINTER :: QI5NNZ #endif #ifdef W3_NLS - INTEGER, POINTER :: NTHX, NFRX, NSPL, NSPH - REAL, POINTER :: CNLSA, CNLSC, CNLSFM, & - CNLSC1, CNLSC2, CNLSC3, SNSST(:,:) + INTEGER, POINTER :: NTHX, NFRX, NSPL, NSPH + REAL, POINTER :: CNLSA, CNLSC, CNLSFM, CNLSC1, CNLSC2, CNLSC3, SNSST(:,:) #endif -!/ -!/ Data aliasses for structure SBTP(S) -!/ + !/ + !/ Data aliasses for structure SBTP(S) + !/ #ifdef W3_BT1 - REAL, POINTER :: SBTC1 + REAL, POINTER :: SBTC1 #endif #ifdef W3_BT4 - REAL, POINTER :: SBTCX(:) + REAL, POINTER :: SBTCX(:) #endif -!/ -!/ Data aliasses for structure SDBP(S) -!/ + !/ + !/ Data aliasses for structure SDBP(S) + !/ #ifdef W3_DB1 - REAL, POINTER :: SDBC1, SDBC2 - LOGICAL, POINTER :: FDONLY - REAL, POINTER :: SDBSC + REAL, POINTER :: SDBC1, SDBC2 + LOGICAL, POINTER :: FDONLY + REAL, POINTER :: SDBSC #endif -!/ + !/ #ifdef W3_UOST -!/ Data aliases for structure UOSTP(S) - CHARACTER(LEN=:), POINTER :: UOSTFILELOCAL, UOSTFILESHADOW - REAL, POINTER :: UOSTFACTORLOCAL, UOSTFACTORSHADOW -#endif -!/ -!/ Data aliasing for structure SCHM(S) - LOGICAL, POINTER :: FSN,FSPSI,FSFCT,FSNIMP,FSTOTALIMP,FSTOTALEXP - LOGICAL, POINTER :: FSREFRACTION, FSFREQSHIFT, FSSOURCE, FSBCCFL - LOGICAL, POINTER :: DO_CHANGE_WLV - REAL(8), POINTER :: SOLVERTHR_STP - REAL(8), POINTER :: CRIT_DEP_STP - LOGICAL, POINTER :: B_JGS_TERMINATE_MAXITER - LOGICAL, POINTER :: B_JGS_TERMINATE_DIFFERENCE - LOGICAL, POINTER :: B_JGS_TERMINATE_NORM - LOGICAL, POINTER :: B_JGS_LIMITER - LOGICAL, POINTER :: B_JGS_USE_JACOBI - LOGICAL, POINTER :: B_JGS_BLOCK_GAUSS_SEIDEL - INTEGER, POINTER :: B_JGS_MAXITER - REAL(8), POINTER :: B_JGS_PMIN - REAL(8), POINTER :: B_JGS_DIFF_THR - REAL(8), POINTER :: B_JGS_NORM_THR - INTEGER, POINTER :: B_JGS_NLEVEL - LOGICAL, POINTER :: B_JGS_SOURCE_NONLINEAR -!/ -!/ Data aliasing for structure SICP(S) + !/ Data aliases for structure UOSTP(S) + CHARACTER(LEN=:), POINTER :: UOSTFILELOCAL, UOSTFILESHADOW + REAL, POINTER :: UOSTFACTORLOCAL, UOSTFACTORSHADOW +#endif + !/ + !/ Data aliasing for structure SCHM(S) + LOGICAL, POINTER :: FSN,FSPSI,FSFCT,FSNIMP,FSTOTALIMP,FSTOTALEXP + LOGICAL, POINTER :: FSREFRACTION, FSFREQSHIFT, FSSOURCE, FSBCCFL + LOGICAL, POINTER :: DO_CHANGE_WLV + REAL(8), POINTER :: SOLVERTHR_STP + REAL(8), POINTER :: CRIT_DEP_STP + LOGICAL, POINTER :: B_JGS_TERMINATE_MAXITER + LOGICAL, POINTER :: B_JGS_TERMINATE_DIFFERENCE + LOGICAL, POINTER :: B_JGS_TERMINATE_NORM + LOGICAL, POINTER :: B_JGS_LIMITER + LOGICAL, POINTER :: B_JGS_USE_JACOBI + LOGICAL, POINTER :: B_JGS_BLOCK_GAUSS_SEIDEL + INTEGER, POINTER :: B_JGS_MAXITER + REAL(8), POINTER :: B_JGS_PMIN + REAL(8), POINTER :: B_JGS_DIFF_THR + REAL(8), POINTER :: B_JGS_NORM_THR + INTEGER, POINTER :: B_JGS_NLEVEL + LOGICAL, POINTER :: B_JGS_SOURCE_NONLINEAR + !/ + !/ Data aliasing for structure SICP(S) #ifdef W3_IS1 - REAL, POINTER :: IS1C1, IS1C2 -#endif -!/ - - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3NMOD ( NUMBER, NDSE, NDST, NAUX ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 ! -!/ +-----------------------------------+ -!/ -!/ 24-Feb-2004 : Origination. ( version 3.06 ) -!/ 18-Jul-2006 : Add input grids. ( version 3.10 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ -! 1. Purpose : -! -! Set up the number of grids to be used. -! -! 2. Method : -! -! Store in NGRIDS and allocate GRIDS. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NUMBER Int. I Number of grids to be used. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! NAUX Int. I Number of auxiliary grids to be used. -! Grids -NAUX:NUBMER are defined, optional -! parameters. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Any program that uses this grid structure. -! -! 6. Error messages : -! -! - Error checks on previous setting of variable. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY: EXTCDE -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NUMBER, NDSE, NDST - INTEGER, INTENT(IN), OPTIONAL :: NAUX -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: I, NLOW -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3NMOD') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .NE. -1 ) THEN - WRITE (NDSE,1001) NGRIDS - CALL EXTCDE (1) - END IF -! - IF ( NUMBER .LT. 1 ) THEN - WRITE (NDSE,1002) NUMBER - CALL EXTCDE (2) - END IF -! - IF ( PRESENT(NAUX) ) THEN - NLOW = -NAUX - ELSE - NLOW = 1 - END IF -! - IF ( NLOW .GT. 1 ) THEN - WRITE (NDSE,1003) -NLOW - CALL EXTCDE (3) - END IF -! -! -------------------------------------------------------------------- / -! 1. Set variable and allocate arrays -! - NGRIDS = NUMBER - NAUXGR = - NLOW - ALLOCATE ( GRIDS(NLOW:NUMBER), & - SGRDS(NLOW:NUMBER), & - MPARS(NLOW:NUMBER), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! -! -------------------------------------------------------------------- / -! 2. Initialize GINIT and SINIT -! - DO I=NLOW, NUMBER - GRIDS(I)%GINIT = .FALSE. - GRIDS(I)%GUGINIT = .FALSE. - SGRDS(I)%SINIT = .FALSE. - MPARS(I)%PINIT = .FALSE. + REAL, POINTER :: IS1C1, IS1C2 +#endif + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3NMOD ( NUMBER, NDSE, NDST, NAUX ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 ! + !/ +-----------------------------------+ + !/ + !/ 24-Feb-2004 : Origination. ( version 3.06 ) + !/ 18-Jul-2006 : Add input grids. ( version 3.10 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ + ! 1. Purpose : + ! + ! Set up the number of grids to be used. + ! + ! 2. Method : + ! + ! Store in NGRIDS and allocate GRIDS. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NUMBER Int. I Number of grids to be used. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! NAUX Int. I Number of auxiliary grids to be used. + ! Grids -NAUX:NUBMER are defined, optional + ! parameters. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Any program that uses this grid structure. + ! + ! 6. Error messages : + ! + ! - Error checks on previous setting of variable. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: EXTCDE + USE W3SERVMD, ONLY: STRACE ! W3_S + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NUMBER, NDSE, NDST + INTEGER, INTENT(IN), OPTIONAL :: NAUX + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: I, NLOW + INTEGER, SAVE :: IENT = 0 ! ! W3_S + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'W3NMOD') ! W3_S + end if + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .NE. -1 ) THEN + WRITE (NDSE,1001) NGRIDS + CALL EXTCDE (1) + END IF + ! + IF ( NUMBER .LT. 1 ) THEN + WRITE (NDSE,1002) NUMBER + CALL EXTCDE (2) + END IF + ! + IF ( PRESENT(NAUX) ) THEN + NLOW = -NAUX + ELSE + NLOW = 1 + END IF + ! + IF ( NLOW .GT. 1 ) THEN + WRITE (NDSE,1003) -NLOW + CALL EXTCDE (3) + END IF + ! + ! -------------------------------------------------------------------- / + ! 1. Set variable and allocate arrays + ! + NGRIDS = NUMBER + NAUXGR = - NLOW + ALLOCATE ( GRIDS(NLOW:NUMBER), & + SGRDS(NLOW:NUMBER), & + MPARS(NLOW:NUMBER), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + ! -------------------------------------------------------------------- / + ! 2. Initialize GINIT and SINIT + ! + DO I=NLOW, NUMBER + GRIDS(I)%GINIT = .FALSE. + GRIDS(I)%GUGINIT = .FALSE. + SGRDS(I)%SINIT = .FALSE. + MPARS(I)%PINIT = .FALSE. #ifdef W3_NL2 - MPARS(I)%SNLPS%NDPTHS = 0 + MPARS(I)%SNLPS%NDPTHS = 0 #endif - END DO + END DO #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3NMOD) - WRITE (NDST,9000) NLOW, NGRIDS -#endif -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3NMOD : GRIDS ALREADY INITIALIZED *** '/ & - ' NGRIDS = ',I10/) - 1002 FORMAT (/' *** ERROR W3NMOD : ILLEGAL NUMBER OF GRIDS *** '/ & - ' NUMBER = ',I10/) - 1003 FORMAT (/' *** ERROR W3NMOD : ILLEGAL NUMBER OF AUX GRIDS *** '/& - ' NUMBER = ',I10/) + WRITE (NDST,9000) NLOW, NGRIDS +#endif + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3NMOD : GRIDS ALREADY INITIALIZED *** '/ & + ' NGRIDS = ',I10/) +1002 FORMAT (/' *** ERROR W3NMOD : ILLEGAL NUMBER OF GRIDS *** '/ & + ' NUMBER = ',I10/) +1003 FORMAT (/' *** ERROR W3NMOD : ILLEGAL NUMBER OF AUX GRIDS *** '/& + ' NUMBER = ',I10/) #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3NMOD) - 9000 FORMAT (' TEST W3NMOD : SETTING UP FOR GRIDS ',I3, & - ' THROUGH ',I3) -#endif -!/ -!/ End of W3NMOD ----------------------------------------------------- / -!/ - END SUBROUTINE W3NMOD -!/ ------------------------------------------------------------------- / - SUBROUTINE W3DIMX ( IMOD, MX, MY, MSEA, NDSE, NDST & +9000 FORMAT (' TEST W3NMOD : SETTING UP FOR GRIDS ',I3, & + ' THROUGH ',I3) +#endif + !/ + !/ End of W3NMOD ----------------------------------------------------- / + !/ + END SUBROUTINE W3NMOD + !/ ------------------------------------------------------------------- / + SUBROUTINE W3DIMX ( IMOD, MX, MY, MSEA, NDSE, NDST & #ifdef W3_SMC - , MCel, MUFc, MVFc, MRLv, MBSMC & - , MARC, MBAC, MSPEC & + , MCel, MUFc, MVFc, MRLv, MBSMC & + , MARC, MBAC, MSPEC & #endif - ) + ) #ifdef W3_SMC - !!Li A few dimensional numbers for SMC grid. -#endif -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 | -!/ +-----------------------------------+ -!/ -!/ 24-Jun-2005 : Origination. ( version 3.07 ) -!/ 18-Jul-2006 : Add input grids. ( version 3.10 ) -!/ 05-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 02-Feb-2007 : Add FLAGST. ( version 3.10 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement unstructured grids ( version 3.14.1) -!/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ -! 1. Purpose : -! -! Initialize an individual spatial grid at the proper dimensions. -! -! 2. Method : -! -! Allocate directly into the structure array GRIDS. Note that -! this cannot be done through the pointer alias! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! MX, MY, MSEA Like NX, NY, NSEA in data structure. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOGR Subr. W3IOGRMD Model definition file IO program. -! WW3_GRID Prog. N/A Model set up program. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - Check on input parameters. -! - Check on previous allocation. -! -! 7. Remarks : -! -! - Grid dimensions apre passed through parameter list and then -! locally stored to assure consistency between allocation and -! data in structure. -! - W3SETG needs to be called after allocation to point to -! proper allocated arrays. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY: EXTCDE -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, MX, MY, MSEA, NDSE, NDST + !!Li A few dimensional numbers for SMC grid. +#endif + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 | + !/ +-----------------------------------+ + !/ + !/ 24-Jun-2005 : Origination. ( version 3.07 ) + !/ 18-Jul-2006 : Add input grids. ( version 3.10 ) + !/ 05-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 02-Feb-2007 : Add FLAGST. ( version 3.10 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement unstructured grids ( version 3.14.1) + !/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ + ! 1. Purpose : + ! + ! Initialize an individual spatial grid at the proper dimensions. + ! + ! 2. Method : + ! + ! Allocate directly into the structure array GRIDS. Note that + ! this cannot be done through the pointer alias! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! MX, MY, MSEA Like NX, NY, NSEA in data structure. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOGR Subr. W3IOGRMD Model definition file IO program. + ! WW3_GRID Prog. N/A Model set up program. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - Check on input parameters. + ! - Check on previous allocation. + ! + ! 7. Remarks : + ! + ! - Grid dimensions apre passed through parameter list and then + ! locally stored to assure consistency between allocation and + ! data in structure. + ! - W3SETG needs to be called after allocation to point to + ! proper allocated arrays. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: EXTCDE + USE W3SERVMD, ONLY: STRACE ! W3_S + ! + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, MX, MY, MSEA, NDSE, NDST #ifdef W3_SMC - INTEGER, INTENT(IN) :: MCel, MUFc, MVFc, MRLv, MBSMC - INTEGER, INTENT(IN) :: MARC, MBAC, MSPEC + INTEGER, INTENT(IN) :: MCel, MUFc, MVFc, MRLv, MBSMC + INTEGER, INTENT(IN) :: MARC, MBAC, MSPEC #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ #ifdef W3_SMC - INTEGER :: IARC, IBAC, IBSMC -#endif -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER :: IARC, IBAC, IBSMC #endif -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3DIMX') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NGRIDS ) THEN - WRITE (NDSE,1002) IMOD, -NAUXGR, NGRIDS - CALL EXTCDE (2) - END IF -! - IF ( MX.LT.3 .OR. (MY.LT.3.AND.GTYPE.NE.UNGTYPE) .OR. MSEA.LT.1 ) THEN - WRITE (NDSE,1003) MX, MY, MSEA, GTYPE - CALL EXTCDE (3) - END IF -! - IF ( GRIDS(IMOD)%GINIT ) THEN - WRITE (NDSE,1004) - CALL EXTCDE (4) - END IF + + INTEGER, SAVE :: IENT = 0 ! W3_S + + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'W3DIMX') ! W3_S + end if + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NGRIDS ) THEN + WRITE (NDSE,1002) IMOD, -NAUXGR, NGRIDS + CALL EXTCDE (2) + END IF + ! + IF ( MX.LT.3 .OR. (MY.LT.3.AND.GTYPE.NE.UNGTYPE) .OR. MSEA.LT.1 ) THEN + WRITE (NDSE,1003) MX, MY, MSEA, GTYPE + CALL EXTCDE (3) + END IF + ! + IF ( GRIDS(IMOD)%GINIT ) THEN + WRITE (NDSE,1004) + CALL EXTCDE (4) + END IF #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMX) - WRITE (NDST,9000) IMOD, MX, MY, MSEA -#endif -! -! -------------------------------------------------------------------- / -! 2. Allocate arrays -! -! NB: Some array start at 0 because MAPFS(IY,IX)=0 for missing points -! - IF (GTYPE .NE. UNGTYPE) THEN - ALLOCATE ( GRIDS(IMOD)%ZB(MSEA), & - GRIDS(IMOD)%XGRD(MY,MX), & - GRIDS(IMOD)%YGRD(MY,MX), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ENDIF + WRITE (NDST,9000) IMOD, MX, MY, MSEA +#endif + ! + ! -------------------------------------------------------------------- / + ! 2. Allocate arrays + ! + ! NB: Some array start at 0 because MAPFS(IY,IX)=0 for missing points + ! + IF (GTYPE .NE. UNGTYPE) THEN + ALLOCATE ( GRIDS(IMOD)%ZB(MSEA), & + GRIDS(IMOD)%XGRD(MY,MX), & + GRIDS(IMOD)%YGRD(MY,MX), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ENDIF - ALLOCATE ( GRIDS(IMOD)%MAPSTA(MY,MX), & - GRIDS(IMOD)%MAPST2(MY,MX), & - GRIDS(IMOD)%MAPFS(MY,MX), & - GRIDS(IMOD)%MAPSF(MSEA,3), & - GRIDS(IMOD)%FLAGST(MSEA), & + ALLOCATE ( GRIDS(IMOD)%MAPSTA(MY,MX), & + GRIDS(IMOD)%MAPST2(MY,MX), & + GRIDS(IMOD)%MAPFS(MY,MX), & + GRIDS(IMOD)%MAPSF(MSEA,3), & + GRIDS(IMOD)%FLAGST(MSEA), & #ifdef W3_RTD - GRIDS(IMOD)%AnglD(MSEA), & -#endif - GRIDS(IMOD)%CLATS(0:MSEA), & - GRIDS(IMOD)%CLATIS(0:MSEA), & - GRIDS(IMOD)%CTHG0S(0:MSEA), & - GRIDS(IMOD)%TRNX(MY,MX), & - GRIDS(IMOD)%TRNY(MY,MX), & - GRIDS(IMOD)%DXDP(MY,MX), & - GRIDS(IMOD)%DXDQ(MY,MX), & - GRIDS(IMOD)%DYDP(MY,MX), & - GRIDS(IMOD)%DYDQ(MY,MX), & - GRIDS(IMOD)%DPDX(MY,MX), & - GRIDS(IMOD)%DPDY(MY,MX), & - GRIDS(IMOD)%DQDX(MY,MX), & - GRIDS(IMOD)%DQDY(MY,MX), & - GRIDS(IMOD)%GSQRT(MY,MX), & - GRIDS(IMOD)%HPFAC(MY,MX), & - GRIDS(IMOD)%HQFAC(MY,MX), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -!!/DEBUGINIT WRITE(740+IAPROC,*) 'After alocation of MAPST2, MY=', MY, ' MX=', MX -!!/DEBUGINIT FLUSH(740+IAPROC) + GRIDS(IMOD)%AnglD(MSEA), & +#endif + GRIDS(IMOD)%CLATS(0:MSEA), & + GRIDS(IMOD)%CLATIS(0:MSEA), & + GRIDS(IMOD)%CTHG0S(0:MSEA), & + GRIDS(IMOD)%TRNX(MY,MX), & + GRIDS(IMOD)%TRNY(MY,MX), & + GRIDS(IMOD)%DXDP(MY,MX), & + GRIDS(IMOD)%DXDQ(MY,MX), & + GRIDS(IMOD)%DYDP(MY,MX), & + GRIDS(IMOD)%DYDQ(MY,MX), & + GRIDS(IMOD)%DPDX(MY,MX), & + GRIDS(IMOD)%DPDY(MY,MX), & + GRIDS(IMOD)%DQDX(MY,MX), & + GRIDS(IMOD)%DQDY(MY,MX), & + GRIDS(IMOD)%GSQRT(MY,MX), & + GRIDS(IMOD)%HPFAC(MY,MX), & + GRIDS(IMOD)%HQFAC(MY,MX), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + !!/DEBUGINIT WRITE(740+IAPROC,*) 'After alocation of MAPST2, MY=', MY, ' MX=', MX + !!/DEBUGINIT FLUSH(740+IAPROC) #ifdef W3_BT4 ALLOCATE ( GRIDS(IMOD)%SED_D50(0:MSEA), & - GRIDS(IMOD)%SED_PSIC(0:MSEA),& - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + GRIDS(IMOD)%SED_PSIC(0:MSEA),& + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif -! + ! #ifdef W3_SMC - ALLOCATE ( GRIDS(IMOD)%NLvCel(0:MRLv), & - GRIDS(IMOD)%NLvUFc(0:MRLv), & - GRIDS(IMOD)%NLvVFc(0:MRLv), & - GRIDS(IMOD)%IJKCel(5, -9:MCel), & - GRIDS(IMOD)%IJKUFc(7,MUFc), & - GRIDS(IMOD)%IJKVFc(8,MVFc), & - GRIDS(IMOD)%CTRNX(-9:MCel), & - GRIDS(IMOD)%CTRNY(-9:MCel), & - GRIDS(IMOD)%CLATF(MVFc), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - - ALLOCATE ( GRIDS(IMOD)%IJKCel3(-9:MCel), & - GRIDS(IMOD)%IJKCel4(-9:MCel), & - GRIDS(IMOD)%IJKVFc5(MVFc), & - GRIDS(IMOD)%IJKVFc6(MVFc), & - GRIDS(IMOD)%IJKUFc5(MUFc), & - GRIDS(IMOD)%IJKUFc6(MUFc), & - STAT=ISTAT) -#endif -! + ALLOCATE ( GRIDS(IMOD)%NLvCel(0:MRLv), & + GRIDS(IMOD)%NLvUFc(0:MRLv), & + GRIDS(IMOD)%NLvVFc(0:MRLv), & + GRIDS(IMOD)%IJKCel(5, -9:MCel), & + GRIDS(IMOD)%IJKUFc(7,MUFc), & + GRIDS(IMOD)%IJKVFc(8,MVFc), & + GRIDS(IMOD)%CTRNX(-9:MCel), & + GRIDS(IMOD)%CTRNY(-9:MCel), & + GRIDS(IMOD)%CLATF(MVFc), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( GRIDS(IMOD)%IJKCel3(-9:MCel), & + GRIDS(IMOD)%IJKCel4(-9:MCel), & + GRIDS(IMOD)%IJKVFc5(MVFc), & + GRIDS(IMOD)%IJKVFc6(MVFc), & + GRIDS(IMOD)%IJKUFc5(MUFc), & + GRIDS(IMOD)%IJKUFc6(MUFc), & + STAT=ISTAT) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif + ! #ifdef W3_SMC - !! Arctic part related variables, declare minimum 1 element. - IARC = MARC - IF( MARC .LE. 1 ) IARC = 1 - IBAC = MBAC - IF( MBAC .LE. 1 ) IBAC = 1 - IBSMC = MBSMC - IF( MBSMC .LE. 1 ) IBSMC = 1 - ALLOCATE ( GRIDS(IMOD)%ICLBAC(IBAC), & - GRIDS(IMOD)%ANGARC(IARC), & - GRIDS(IMOD)%SPCBAC(MSPEC,IBAC), & - GRIDS(IMOD)%ISMCBP(IBSMC), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -#endif -! + !! Arctic part related variables, declare minimum 1 element. + IARC = MARC + IF( MARC .LE. 1 ) IARC = 1 + IBAC = MBAC + IF( MBAC .LE. 1 ) IBAC = 1 + IBSMC = MBSMC + IF( MBSMC .LE. 1 ) IBSMC = 1 + ALLOCATE ( GRIDS(IMOD)%ICLBAC(IBAC), & + GRIDS(IMOD)%ANGARC(IARC), & + GRIDS(IMOD)%SPCBAC(MSPEC,IBAC), & + GRIDS(IMOD)%ISMCBP(IBSMC), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif + ! #ifdef W3_SMC - !! All SMC grid related varialbes are initialised in case SMC - !! switch is selected but SMCTYPE is not used. JGLi08Mar2021 - GRIDS(IMOD)%NLvCel(:) = 0 - GRIDS(IMOD)%NLvUFc(:) = 0 - GRIDS(IMOD)%NLvVFc(:) = 0 - GRIDS(IMOD)%ISMCBP(:) = 0 - GRIDS(IMOD)%ICLBAC(:) = 0 - GRIDS(IMOD)%IJKCel(:,:) = 0 - GRIDS(IMOD)%IJKUFc(:,:) = 0 - GRIDS(IMOD)%IJKVFc(:,:) = 0 - GRIDS(IMOD)%CTRNX(:) = 0.0 - GRIDS(IMOD)%CTRNY(:) = 0.0 - GRIDS(IMOD)%CLATF(:) = 0.0 - GRIDS(IMOD)%ANGARC(:) = 0.0 -#endif -! - GRIDS(IMOD)%FLAGST = .TRUE. - GRIDS(IMOD)%GINIT = .TRUE. - GRIDS(IMOD)%MAPSF(:,3)=0. - GRIDS(IMOD)%CLATS(0)=1. - GRIDS(IMOD)%CLATIS(0)=1. - GRIDS(IMOD)%CTHG0S(0)=1. -! + !! All SMC grid related varialbes are initialised in case SMC + !! switch is selected but SMCTYPE is not used. JGLi08Mar2021 + GRIDS(IMOD)%NLvCel(:) = 0 + GRIDS(IMOD)%NLvUFc(:) = 0 + GRIDS(IMOD)%NLvVFc(:) = 0 + GRIDS(IMOD)%ISMCBP(:) = 0 + GRIDS(IMOD)%ICLBAC(:) = 0 + GRIDS(IMOD)%IJKCel(:,:) = 0 + GRIDS(IMOD)%IJKUFc(:,:) = 0 + GRIDS(IMOD)%IJKVFc(:,:) = 0 + GRIDS(IMOD)%CTRNX(:) = 0.0 + GRIDS(IMOD)%CTRNY(:) = 0.0 + GRIDS(IMOD)%CLATF(:) = 0.0 + GRIDS(IMOD)%ANGARC(:) = 0.0 +#endif + ! + GRIDS(IMOD)%FLAGST = .TRUE. + GRIDS(IMOD)%GINIT = .TRUE. + GRIDS(IMOD)%MAPSF(:,3)=0. + GRIDS(IMOD)%CLATS(0)=1. + GRIDS(IMOD)%CLATIS(0)=1. + GRIDS(IMOD)%CTHG0S(0)=1. + ! #ifdef W3_REF1 - ALLOCATE ( GRIDS(IMOD)%RREF(4), & - GRIDS(IMOD)%REFPARS(10), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( GRIDS(IMOD)%RREF(4), & + GRIDS(IMOD)%REFPARS(10), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif -! + ! #ifdef W3_REF1 - GRIDS(IMOD)%RREF(:)=.FALSE. - GRIDS(IMOD)%REFPARS(:)=0. + GRIDS(IMOD)%RREF(:)=.FALSE. + GRIDS(IMOD)%REFPARS(:)=0. #endif -! + ! #ifdef W3_REF1 -! Memory footprint can be reduced by defining REFLC and REFLD only over nodes -! where reflection can occur. - ALLOCATE ( GRIDS(IMOD)%REFLC(4,0:NSEA), & - GRIDS(IMOD)%REFLD(6,0:NSEA), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ! Memory footprint can be reduced by defining REFLC and REFLD only over nodes + ! where reflection can occur. + ALLOCATE ( GRIDS(IMOD)%REFLC(4,0:NSEA), & + GRIDS(IMOD)%REFLD(6,0:NSEA), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif #ifdef W3_IG1 - ALLOCATE ( GRIDS(IMOD)%IGPARS(12), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( GRIDS(IMOD)%IGPARS(12), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif #ifdef W3_IC2 - ALLOCATE ( GRIDS(IMOD)%IC2PARS(9), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( GRIDS(IMOD)%IC2PARS(9), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif #ifdef W3_IC3 - ALLOCATE ( GRIDS(IMOD)%IC3PARS(16), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( GRIDS(IMOD)%IC3PARS(16), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif #ifdef W3_IC4 - ALLOCATE ( GRIDS(IMOD)%IC4PARS(1), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( GRIDS(IMOD)%IC4_KI(NIC4), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - ALLOCATE ( GRIDS(IMOD)%IC4_FC(NIC4), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( GRIDS(IMOD)%IC4PARS(1), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( GRIDS(IMOD)%IC4_KI(NIC4), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( GRIDS(IMOD)%IC4_FC(NIC4), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif #ifdef W3_IC5 - ALLOCATE ( GRIDS(IMOD)%IC5PARS(9), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( GRIDS(IMOD)%IC5PARS(9), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif #ifdef W3_IS2 - ALLOCATE ( GRIDS(IMOD)%IS2PARS(24), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) + ALLOCATE ( GRIDS(IMOD)%IS2PARS(24), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) #endif #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMX) - WRITE (NDST,9001) + WRITE (NDST,9001) #endif -! + ! #ifdef W3_REF1 - GRIDS(IMOD)%REFLC(1:4,0:NSEA)=0. - GRIDS(IMOD)%REFLD(:,:)=0 + GRIDS(IMOD)%REFLC(1:4,0:NSEA)=0. + GRIDS(IMOD)%REFLD(:,:)=0 #endif #ifdef W3_IG1 - GRIDS(IMOD)%IGPARS(:)=0. + GRIDS(IMOD)%IGPARS(:)=0. #endif #ifdef W3_IC2 - GRIDS(IMOD)%IC2PARS(:)=0. + GRIDS(IMOD)%IC2PARS(:)=0. #endif #ifdef W3_IS2 - GRIDS(IMOD)%IS2PARS(:)=0. -#endif -! -! -------------------------------------------------------------------- / -! 2. Update counters in grid -! - GRIDS(IMOD)%NX = MX - GRIDS(IMOD)%NY = MY - GRIDS(IMOD)%NSEA = MSEA + GRIDS(IMOD)%IS2PARS(:)=0. +#endif + ! + ! -------------------------------------------------------------------- / + ! 2. Update counters in grid + ! + GRIDS(IMOD)%NX = MX + GRIDS(IMOD)%NY = MY + GRIDS(IMOD)%NSEA = MSEA #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMX) - WRITE (NDST,9002) + WRITE (NDST,9002) #endif -! -! -------------------------------------------------------------------- / -! 3. Point to allocated arrays -! - CALL W3SETG ( IMOD, NDSE, NDST ) + ! + ! -------------------------------------------------------------------- / + ! 3. Point to allocated arrays + ! + CALL W3SETG ( IMOD, NDSE, NDST ) #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMX) - WRITE (NDST,9003) -#endif -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3DIMX : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3DIMX : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NAUXGR = ',I10/ & - ' NGRIDS = ',I10/) - 1003 FORMAT (/' *** ERROR W3DIMX : ILLEGAL GRID DIMENSION(S) *** '/ & - ' INPUT = ',4I10 /) - 1004 FORMAT (/' *** ERROR W3DIMX : ARRAY(S) ALREADY ALLOCATED *** ') -#if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMX) - 9000 FORMAT (' TEST W3DIMX : MODEL ',I4,' DIM. AT ',2I5,I7) - 9001 FORMAT (' TEST W3DIMX : ARRAYS ALLOCATED') - 9002 FORMAT (' TEST W3DIMX : DIMENSIONS STORED') - 9003 FORMAT (' TEST W3DIMX : POINTERS RESET') -#endif -!/ -!/ End of W3DIMX ----------------------------------------------------- / -!/ - END SUBROUTINE W3DIMX -!/ ------------------------------------------------------------------- / - SUBROUTINE W3DIMS ( IMOD, MK, MTH, NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 ! -!/ +-----------------------------------+ -!/ -!/ 19-Feb-2004 : Origination. ( version 3.06 ) -!/ 18-Jul-2006 : Add input grids. ( version 3.10 ) -!/ 05-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ -! 1. Purpose : -! -! Initialize an individual spatial grid at the proper dimensions. -! -! 2. Method : -! -! Allocate directly into the structure array GRIDS. Note that -! this cannot be done through the pointer alias! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! MK,MTH Int. I Spectral dimensions. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOGR Subr. W3IOGRMD Model definition file IO program. -! WW3_GRID Prog. N/A Model set up program. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - Check on input parameters. -! - Check on previous allocation. -! -! 7. Remarks : -! -! - Grid dimensions apre passed through parameter list and then -! locally stored to assure consistency between allocation and -! data in structure. -! - W3SETG needs to be called after allocation to point to -! proper allocated arrays. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY: EXTCDE + WRITE (NDST,9003) +#endif + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3DIMX : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3DIMX : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NAUXGR = ',I10/ & + ' NGRIDS = ',I10/) +1003 FORMAT (/' *** ERROR W3DIMX : ILLEGAL GRID DIMENSION(S) *** '/ & + ' INPUT = ',4I10 /) +1004 FORMAT (/' *** ERROR W3DIMX : ARRAY(S) ALREADY ALLOCATED *** ') +9000 FORMAT (' TEST W3DIMX : MODEL ',I4,' DIM. AT ',2I5,I7) +9001 FORMAT (' TEST W3DIMX : ARRAYS ALLOCATED') +9002 FORMAT (' TEST W3DIMX : DIMENSIONS STORED') +9003 FORMAT (' TEST W3DIMX : POINTERS RESET') + !/ + !/ End of W3DIMX ----------------------------------------------------- / + !/ + END SUBROUTINE W3DIMX + !/ ------------------------------------------------------------------- / + SUBROUTINE W3DIMS ( IMOD, MK, MTH, NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 ! + !/ +-----------------------------------+ + !/ + !/ 19-Feb-2004 : Origination. ( version 3.06 ) + !/ 18-Jul-2006 : Add input grids. ( version 3.10 ) + !/ 05-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ + ! 1. Purpose : + ! + ! Initialize an individual spatial grid at the proper dimensions. + ! + ! 2. Method : + ! + ! Allocate directly into the structure array GRIDS. Note that + ! this cannot be done through the pointer alias! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! MK,MTH Int. I Spectral dimensions. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOGR Subr. W3IOGRMD Model definition file IO program. + ! WW3_GRID Prog. N/A Model set up program. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - Check on input parameters. + ! - Check on previous allocation. + ! + ! 7. Remarks : + ! + ! - Grid dimensions apre passed through parameter list and then + ! locally stored to assure consistency between allocation and + ! data in structure. + ! - W3SETG needs to be called after allocation to point to + ! proper allocated arrays. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: EXTCDE + USE W3SERVMD, ONLY: STRACE #ifdef W3_ST4 - USE CONSTANTS, ONLY: RADE -#endif -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, MK, MTH, NDSE, NDST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER, SAVE :: MK2, MSPEC + USE CONSTANTS, ONLY: RADE +#endif + ! + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, MK, MTH, NDSE, NDST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER, SAVE :: MK2, MSPEC #ifdef W3_ST4 - INTEGER :: SDSNTH -#endif -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3DIMS') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NGRIDS ) THEN - WRITE (NDSE,1002) IMOD, -NAUXGR, NGRIDS - CALL EXTCDE (2) - END IF -! - IF ( MK.LT.3 .OR. MTH.LT.4 ) THEN - WRITE (NDSE,1003) MK, MTH - CALL EXTCDE (3) - END IF -! - IF ( SGRDS(IMOD)%SINIT ) THEN - WRITE (NDSE,1004) - CALL EXTCDE (4) - END IF -! - MK2 = MK + 2 - MSPEC = MK * MTH + INTEGER :: SDSNTH +#endif + INTEGER, SAVE :: IENT = 0 + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'W3DIMS') + end if + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NGRIDS ) THEN + WRITE (NDSE,1002) IMOD, -NAUXGR, NGRIDS + CALL EXTCDE (2) + END IF + ! + IF ( MK.LT.3 .OR. MTH.LT.4 ) THEN + WRITE (NDSE,1003) MK, MTH + CALL EXTCDE (3) + END IF + ! + IF ( SGRDS(IMOD)%SINIT ) THEN + WRITE (NDSE,1004) + CALL EXTCDE (4) + END IF + ! + MK2 = MK + 2 + MSPEC = MK * MTH #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMS) - WRITE (NDST,9000) IMOD, MTH, MK, MK2, MSPEC -#endif -! -! -------------------------------------------------------------------- / -! 2. Allocate arrays -! - ALLOCATE ( SGRDS(IMOD)%MAPWN(MSPEC+MTH), & - SGRDS(IMOD)%MAPTH(MSPEC+MTH), & - SGRDS(IMOD)%TH(MTH), & - SGRDS(IMOD)%ESIN(MSPEC+MTH), & - SGRDS(IMOD)%ECOS(MSPEC+MTH), & - SGRDS(IMOD)%ES2(MSPEC+MTH), & - SGRDS(IMOD)%ESC(MSPEC+MTH), & - SGRDS(IMOD)%EC2(MSPEC+MTH), & - SGRDS(IMOD)%SIG(0:MK+1), & - SGRDS(IMOD)%SIG2(MSPEC), & - SGRDS(IMOD)%DSIP(0:MK+1), & - SGRDS(IMOD)%DSII(MK), & - SGRDS(IMOD)%DDEN(MK), & - SGRDS(IMOD)%DDEN2(MSPEC), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - SGRDS(IMOD)%MAPWN(:)=0. - SGRDS(IMOD)%MAPTH(:)=0. - SGRDS(IMOD)%TH(:)=0. - SGRDS(IMOD)%ESIN(:)=0. - SGRDS(IMOD)%ECOS(:)=0. - SGRDS(IMOD)%ES2(:)=0. - SGRDS(IMOD)%ESC(:)=0. - SGRDS(IMOD)%EC2(:)=0. - SGRDS(IMOD)%SIG(:)=0. - SGRDS(IMOD)%SIG2(:)=0. - SGRDS(IMOD)%DSIP(:)=0. - SGRDS(IMOD)%DSII(:)=0. - SGRDS(IMOD)%DDEN(:)=0. - SGRDS(IMOD)%DDEN2(:)=0. + WRITE (NDST,9000) IMOD, MTH, MK, MK2, MSPEC +#endif + ! + ! -------------------------------------------------------------------- / + ! 2. Allocate arrays + ! + ALLOCATE ( SGRDS(IMOD)%MAPWN(MSPEC+MTH), & + SGRDS(IMOD)%MAPTH(MSPEC+MTH), & + SGRDS(IMOD)%TH(MTH), & + SGRDS(IMOD)%ESIN(MSPEC+MTH), & + SGRDS(IMOD)%ECOS(MSPEC+MTH), & + SGRDS(IMOD)%ES2(MSPEC+MTH), & + SGRDS(IMOD)%ESC(MSPEC+MTH), & + SGRDS(IMOD)%EC2(MSPEC+MTH), & + SGRDS(IMOD)%SIG(0:MK+1), & + SGRDS(IMOD)%SIG2(MSPEC), & + SGRDS(IMOD)%DSIP(0:MK+1), & + SGRDS(IMOD)%DSII(MK), & + SGRDS(IMOD)%DDEN(MK), & + SGRDS(IMOD)%DDEN2(MSPEC), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + SGRDS(IMOD)%MAPWN(:)=0. + SGRDS(IMOD)%MAPTH(:)=0. + SGRDS(IMOD)%TH(:)=0. + SGRDS(IMOD)%ESIN(:)=0. + SGRDS(IMOD)%ECOS(:)=0. + SGRDS(IMOD)%ES2(:)=0. + SGRDS(IMOD)%ESC(:)=0. + SGRDS(IMOD)%EC2(:)=0. + SGRDS(IMOD)%SIG(:)=0. + SGRDS(IMOD)%SIG2(:)=0. + SGRDS(IMOD)%DSIP(:)=0. + SGRDS(IMOD)%DSII(:)=0. + SGRDS(IMOD)%DDEN(:)=0. + SGRDS(IMOD)%DDEN2(:)=0. #ifdef W3_ST4 - ALLOCATE ( MPARS(IMOD)%SRCPS%IKTAB(MK,NDTAB), & - MPARS(IMOD)%SRCPS%DCKI(NKHS,NKD), & - MPARS(IMOD)%SRCPS%QBI(NKHS,NKD), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) - SDSNTH = MTH/2-1 !MIN(NINT(SSDSDTH/(DTH*RADE)),MTH/2-1) - ALLOCATE( MPARS(IMOD)%SRCPS%SATINDICES(2*SDSNTH+1,MTH), & - MPARS(IMOD)%SRCPS%SATWEIGHTS(2*SDSNTH+1,MTH), & - MPARS(IMOD)%SRCPS%CUMULW(MSPEC,MSPEC), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -#endif -! - SGRDS(IMOD)%SINIT = .TRUE. + ALLOCATE ( MPARS(IMOD)%SRCPS%IKTAB(MK,NDTAB), & + MPARS(IMOD)%SRCPS%DCKI(NKHS,NKD), & + MPARS(IMOD)%SRCPS%QBI(NKHS,NKD), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + SDSNTH = MTH/2-1 !MIN(NINT(SSDSDTH/(DTH*RADE)),MTH/2-1) + ALLOCATE( MPARS(IMOD)%SRCPS%SATINDICES(2*SDSNTH+1,MTH), & + MPARS(IMOD)%SRCPS%SATWEIGHTS(2*SDSNTH+1,MTH), & + MPARS(IMOD)%SRCPS%CUMULW(MSPEC,MSPEC), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif + ! + SGRDS(IMOD)%SINIT = .TRUE. #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMS) - WRITE (NDST,9001) + WRITE (NDST,9001) #endif -! -! -------------------------------------------------------------------- / -! 3. Point to allocated arrays -! - CALL W3SETG ( IMOD, NDSE, NDST ) + ! + ! -------------------------------------------------------------------- / + ! 3. Point to allocated arrays + ! + CALL W3SETG ( IMOD, NDSE, NDST ) #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMS) - WRITE (NDST,9002) -#endif -! -! -------------------------------------------------------------------- / -! 4. Update counters in grid -! - NK = MK - NK2 = MK + 2 - NTH = MTH - NSPEC = MK * MTH + WRITE (NDST,9002) +#endif + ! + ! -------------------------------------------------------------------- / + ! 4. Update counters in grid + ! + NK = MK + NK2 = MK + 2 + NTH = MTH + NSPEC = MK * MTH #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMS) - WRITE (NDST,9003) -#endif -! - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3DIMS : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3DIMS : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NAUXGR = ',I10/ & - ' NGRIDS = ',I10/) - 1003 FORMAT (/' *** ERROR W3DIMS : ILLEGAL GRID DIMENSION(S) *** '/ & - ' INPUT = ',4I10/) - 1004 FORMAT (/' *** ERROR W3DIMS : ARRAY(S) ALREADY ALLOCATED *** ') -#if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMS) - 9000 FORMAT (' TEST W3DIMS : MODEL ',I4,' DIM. AT ',3I5,I7) - 9001 FORMAT (' TEST W3DIMS : ARRAYS ALLOCATED') - 9002 FORMAT (' TEST W3DIMS : POINTERS RESET') - 9003 FORMAT (' TEST W3DIMS : DIMENSIONS STORED') -#endif -!/ -!/ End of W3DIMS ----------------------------------------------------- / -!/ - END SUBROUTINE W3DIMS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SETG ( IMOD, NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ ! J. H. Alves ! -!/ | FORTRAN 90 | -!/ | Last update : 03-Sep-2012 | -!/ +-----------------------------------+ -!/ -!/ 24-Jun-2005 : Origination. ( version 3.07 ) -!/ 09-Nov-2005 : Remove soft boundary options. ( version 3.08 ) -!/ 23-Jun-2006 : Add data for W3SLN1. ( version 3.09 ) -!/ 18-Jul-2006 : Add input grids. ( version 3.10 ) -!/ 05-Oct-2006 : Add filter to array pointers. ( version 3.10 ) -!/ 02-Feb-2007 : Add FLAGST. ( version 3.10 ) -!/ 14-Apr-2007 : Add Miche style limiter. ( version 3.11 ) -!/ ( J. H. Alves ) -!/ 25-Apr-2007 : Adding Battjes-Janssen Sdb. ( version 3.11 ) -!/ ( J. H. Alves ) -!/ 18-Sep-2007 : Adding WAM4 source terms. ( version 3.13 ) -!/ ( F. Ardhuin ) -!/ 27-Jun-2008 : Expand WAM4 variants namelist ( version 3.14 ) -!/ ( F. Ardhuin ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 13-Jul-2012 : Move data structures GMD (SNL3) and nonlinear -!/ filter (SNLS) from 3.15 (HLT). ( version 4.08 ) -!/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) -!/ -! 1. Purpose : -! -! Select one of the WAVEWATCH III grids / models. -! -! 2. Method : -! -! Point pointers to the proper variables in the proper element of -! the GRIDS array. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Many subroutines in eth WAVEWATCH system. -! -! 6. Error messages : -! -! Checks on parameter list IMOD. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/PRn Select propagation scheme -! -! !/STn Select source terms -! !/NLn -! !/BTn -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY: EXTCDE -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3SETG') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NGRIDS ) THEN - WRITE (NDSE,1002) IMOD, -NAUXGR, NGRIDS - CALL EXTCDE (2) - END IF + WRITE (NDST,9003) +#endif + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3DIMS : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3DIMS : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NAUXGR = ',I10/ & + ' NGRIDS = ',I10/) +1003 FORMAT (/' *** ERROR W3DIMS : ILLEGAL GRID DIMENSION(S) *** '/ & + ' INPUT = ',4I10/) +1004 FORMAT (/' *** ERROR W3DIMS : ARRAY(S) ALREADY ALLOCATED *** ') +9000 FORMAT (' TEST W3DIMS : MODEL ',I4,' DIM. AT ',3I5,I7) +9001 FORMAT (' TEST W3DIMS : ARRAYS ALLOCATED') +9002 FORMAT (' TEST W3DIMS : POINTERS RESET') +9003 FORMAT (' TEST W3DIMS : DIMENSIONS STORED') + !/ + !/ End of W3DIMS ----------------------------------------------------- / + !/ + END SUBROUTINE W3DIMS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SETG ( IMOD, NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ ! J. H. Alves ! + !/ | FORTRAN 90 | + !/ | Last update : 03-Sep-2012 | + !/ +-----------------------------------+ + !/ + !/ 24-Jun-2005 : Origination. ( version 3.07 ) + !/ 09-Nov-2005 : Remove soft boundary options. ( version 3.08 ) + !/ 23-Jun-2006 : Add data for W3SLN1. ( version 3.09 ) + !/ 18-Jul-2006 : Add input grids. ( version 3.10 ) + !/ 05-Oct-2006 : Add filter to array pointers. ( version 3.10 ) + !/ 02-Feb-2007 : Add FLAGST. ( version 3.10 ) + !/ 14-Apr-2007 : Add Miche style limiter. ( version 3.11 ) + !/ ( J. H. Alves ) + !/ 25-Apr-2007 : Adding Battjes-Janssen Sdb. ( version 3.11 ) + !/ ( J. H. Alves ) + !/ 18-Sep-2007 : Adding WAM4 source terms. ( version 3.13 ) + !/ ( F. Ardhuin ) + !/ 27-Jun-2008 : Expand WAM4 variants namelist ( version 3.14 ) + !/ ( F. Ardhuin ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 13-Jul-2012 : Move data structures GMD (SNL3) and nonlinear + !/ filter (SNLS) from 3.15 (HLT). ( version 4.08 ) + !/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) + !/ + ! 1. Purpose : + ! + ! Select one of the WAVEWATCH III grids / models. + ! + ! 2. Method : + ! + ! Point pointers to the proper variables in the proper element of + ! the GRIDS array. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Many subroutines in eth WAVEWATCH system. + ! + ! 6. Error messages : + ! + ! Checks on parameter list IMOD. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/PRn Select propagation scheme + ! + ! !/STn Select source terms + ! !/NLn + ! !/BTn + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: EXTCDE + USE W3SERVMD, ONLY: STRACE ! W3_S + ! + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER, SAVE :: IENT = 0 ! only for W3_S + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'W3SETG') + end if + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NGRIDS ) THEN + WRITE (NDSE,1002) IMOD, -NAUXGR, NGRIDS + CALL EXTCDE (2) + END IF #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3SETG) - WRITE (NDST,9000) IMOD -#endif -! -! -------------------------------------------------------------------- / -! 2. Set model numbers -! - IGRID = IMOD - ISGRD = IMOD - IPARS = IMOD -! -! -------------------------------------------------------------------- / -! 3. Set pointers in structure GRID -! - GTYPE => GRIDS(IMOD)%GTYPE - RSTYPE => GRIDS(IMOD)%RSTYPE - ICLOSE => GRIDS(IMOD)%ICLOSE -! - NX => GRIDS(IMOD)%NX - NY => GRIDS(IMOD)%NY - NSEA => GRIDS(IMOD)%NSEA - NSEAL => GRIDS(IMOD)%NSEAL - TRFLAG => GRIDS(IMOD)%TRFLAG - FLAGLL => GRIDS(IMOD)%FLAGLL -! + WRITE (NDST,9000) IMOD +#endif + ! + ! -------------------------------------------------------------------- / + ! 2. Set model numbers + ! + IGRID = IMOD + ISGRD = IMOD + IPARS = IMOD + ! + ! -------------------------------------------------------------------- / + ! 3. Set pointers in structure GRID + ! + GTYPE => GRIDS(IMOD)%GTYPE + RSTYPE => GRIDS(IMOD)%RSTYPE + ICLOSE => GRIDS(IMOD)%ICLOSE + ! + NX => GRIDS(IMOD)%NX + NY => GRIDS(IMOD)%NY + NSEA => GRIDS(IMOD)%NSEA + NSEAL => GRIDS(IMOD)%NSEAL + TRFLAG => GRIDS(IMOD)%TRFLAG + FLAGLL => GRIDS(IMOD)%FLAGLL + ! #ifdef W3_SMC - NCel => GRIDS(IMOD)%NCel - NUFc => GRIDS(IMOD)%NUFc - NVFc => GRIDS(IMOD)%NVFc - NRLv => GRIDS(IMOD)%NRLv - MRFct => GRIDS(IMOD)%MRFct + NCel => GRIDS(IMOD)%NCel + NUFc => GRIDS(IMOD)%NUFc + NVFc => GRIDS(IMOD)%NVFc + NRLv => GRIDS(IMOD)%NRLv + MRFct => GRIDS(IMOD)%MRFct #endif -! + ! #ifdef W3_SMC - NGLO => GRIDS(IMOD)%NGLO - NARC => GRIDS(IMOD)%NARC - NBGL => GRIDS(IMOD)%NBGL - NBAC => GRIDS(IMOD)%NBAC - NBSMC => GRIDS(IMOD)%NBSMC -#endif -! - E3DF => GRIDS(IMOD)%E3DF - P2MSF => GRIDS(IMOD)%P2MSF - US3DF => GRIDS(IMOD)%US3DF - USSPF => GRIDS(IMOD)%USSPF - USSP_WN => GRIDS(IMOD)%USSP_WN + NGLO => GRIDS(IMOD)%NGLO + NARC => GRIDS(IMOD)%NARC + NBGL => GRIDS(IMOD)%NBGL + NBAC => GRIDS(IMOD)%NBAC + NBSMC => GRIDS(IMOD)%NBSMC +#endif + ! + E3DF => GRIDS(IMOD)%E3DF + P2MSF => GRIDS(IMOD)%P2MSF + US3DF => GRIDS(IMOD)%US3DF + USSPF => GRIDS(IMOD)%USSPF + USSP_WN => GRIDS(IMOD)%USSP_WN #ifdef W3_REF1 - REFLC => GRIDS(IMOD)%REFLC - REFLD => GRIDS(IMOD)%REFLD + REFLC => GRIDS(IMOD)%REFLC + REFLD => GRIDS(IMOD)%REFLD #endif - FFACBERG => GRIDS(IMOD)%FFACBERG + FFACBERG => GRIDS(IMOD)%FFACBERG #ifdef W3_REF1 - RREF => GRIDS(IMOD)%RREF - REFPARS=> GRIDS(IMOD)%REFPARS + RREF => GRIDS(IMOD)%RREF + REFPARS=> GRIDS(IMOD)%REFPARS #endif #ifdef W3_IG1 - IGPARS => GRIDS(IMOD)%IGPARS + IGPARS => GRIDS(IMOD)%IGPARS #endif #ifdef W3_IC2 - IC2PARS => GRIDS(IMOD)%IC2PARS + IC2PARS => GRIDS(IMOD)%IC2PARS #endif #ifdef W3_IC3 - IC3PARS => GRIDS(IMOD)%IC3PARS + IC3PARS => GRIDS(IMOD)%IC3PARS #endif #ifdef W3_IC4 - IC4PARS => GRIDS(IMOD)%IC4PARS - IC4_KI => GRIDS(IMOD)%IC4_KI - IC4_FC => GRIDS(IMOD)%IC4_FC + IC4PARS => GRIDS(IMOD)%IC4PARS + IC4_KI => GRIDS(IMOD)%IC4_KI + IC4_FC => GRIDS(IMOD)%IC4_FC #endif #ifdef W3_IC5 - IC5PARS => GRIDS(IMOD)%IC5PARS + IC5PARS => GRIDS(IMOD)%IC5PARS #endif #ifdef W3_IS2 - IS2PARS => GRIDS(IMOD)%IS2PARS -#endif - SX => GRIDS(IMOD)%SX - SY => GRIDS(IMOD)%SY - X0 => GRIDS(IMOD)%X0 - Y0 => GRIDS(IMOD)%Y0 -! - DTCFL => GRIDS(IMOD)%DTCFL - DTCFLI => GRIDS(IMOD)%DTCFLI - DTMAX => GRIDS(IMOD)%DTMAX - DTMIN => GRIDS(IMOD)%DTMIN - DMIN => GRIDS(IMOD)%DMIN -#ifdef W3_SEC1 - NITERSEC1 => GRIDS(IMOD)%NITERSEC1 -#endif - CTMAX => GRIDS(IMOD)%CTMAX - FICE0 => GRIDS(IMOD)%FICE0 - GRIDSHIFT => GRIDS(IMOD)%GRIDSHIFT - CMPRTRCK => GRIDS(IMOD)%CMPRTRCK + IS2PARS => GRIDS(IMOD)%IS2PARS +#endif + SX => GRIDS(IMOD)%SX + SY => GRIDS(IMOD)%SY + X0 => GRIDS(IMOD)%X0 + Y0 => GRIDS(IMOD)%Y0 + ! + DTCFL => GRIDS(IMOD)%DTCFL + DTCFLI => GRIDS(IMOD)%DTCFLI + DTMAX => GRIDS(IMOD)%DTMAX + DTMIN => GRIDS(IMOD)%DTMIN + DMIN => GRIDS(IMOD)%DMIN + if (w3_sec1_flag) then + NITERSEC1 => GRIDS(IMOD)%NITERSEC1 + end if + CTMAX => GRIDS(IMOD)%CTMAX + FICE0 => GRIDS(IMOD)%FICE0 + GRIDSHIFT => GRIDS(IMOD)%GRIDSHIFT + CMPRTRCK => GRIDS(IMOD)%CMPRTRCK #ifdef W3_RTD - PoLat => GRIDS(IMOD)%PoLat - PoLon => GRIDS(IMOD)%PoLon - FLAGUNR => GRIDS(IMOD)%FLAGUNR -#endif - FICEN => GRIDS(IMOD)%FICEN - FICEL => GRIDS(IMOD)%FICEL - IICEHMIN => GRIDS(IMOD)%IICEHMIN - IICEHDISP => GRIDS(IMOD)%IICEHDISP - IICEFDISP => GRIDS(IMOD)%IICEFDISP - IICEDDISP => GRIDS(IMOD)%IICEDDISP - IICEHFAC => GRIDS(IMOD)%IICEHFAC - IICEHINIT => GRIDS(IMOD)%IICEHINIT - ICESCALES => GRIDS(IMOD)%ICESCALES - PFMOVE => GRIDS(IMOD)%PFMOVE - STEXU => GRIDS(IMOD)%STEXU - STEYU => GRIDS(IMOD)%STEYU - STEDU => GRIDS(IMOD)%STEDU - BTBETA => GRIDS(IMOD)%BTBETA - AAIRGB => GRIDS(IMOD)%AAIRGB - AAIRCMIN => GRIDS(IMOD)%AAIRCMIN -! - GINIT => GRIDS(IMOD)%GINIT - GUGINIT => GRIDS(IMOD)%GUGINIT - FLDRY => GRIDS(IMOD)%FLDRY - FLCX => GRIDS(IMOD)%FLCX - FLCY => GRIDS(IMOD)%FLCY - FLCTH => GRIDS(IMOD)%FLCTH - FLCK => GRIDS(IMOD)%FLCK - FLSOU => GRIDS(IMOD)%FLSOU - IICEDISP => GRIDS(IMOD)%IICEDISP - IICESMOOTH => GRIDS(IMOD)%IICESMOOTH -! - GNAME => GRIDS(IMOD)%GNAME - FILEXT => GRIDS(IMOD)%FILEXT - TRIGP => GRIDS(IMOD)%TRIGP - NTRI => GRIDS(IMOD)%NTRI - COUNTRI => GRIDS(IMOD)%COUNTRI - SI => GRIDS(IMOD)%SI - COUNTOT => GRIDS(IMOD)%COUNTOT - IEN => GRIDS(IMOD)%IEN - LEN => GRIDS(IMOD)%LEN - ANGLE => GRIDS(IMOD)%ANGLE - ANGLE0 => GRIDS(IMOD)%ANGLE0 - CCON => GRIDS(IMOD)%CCON - COUNTCON => GRIDS(IMOD)%COUNTCON - INDEX_CELL => GRIDS(IMOD)%INDEX_CELL - IE_CELL => GRIDS(IMOD)%IE_CELL - POS_CELL => GRIDS(IMOD)%POS_CELL - IOBP => GRIDS(IMOD)%IOBP - IAA => GRIDS(IMOD)%IAA - JAA => GRIDS(IMOD)%JAA - POSI => GRIDS(IMOD)%POSI - I_DIAG => GRIDS(IMOD)%I_DIAG - JA_IE => GRIDS(IMOD)%JA_IE - NBEDGE => GRIDS(IMOD)%NBEDGE - EDGES => GRIDS(IMOD)%EDGES - NEIGH => GRIDS(IMOD)%NEIGH - NNZ => GRIDS(IMOD)%NNZ - IOBPD => GRIDS(IMOD)%IOBPD - IOBDP => GRIDS(IMOD)%IOBDP - IOBPA => GRIDS(IMOD)%IOBPA - TRIA => GRIDS(IMOD)%TRIA - CROSSDIFF => GRIDS(IMOD)%CROSSDIFF - MAXX => GRIDS(IMOD)%MAXX - MAXY => GRIDS(IMOD)%MAXY - DXYMAX => GRIDS(IMOD)%DXYMAX - XGRD => GRIDS(IMOD)%XGRD - YGRD => GRIDS(IMOD)%YGRD - ZB => GRIDS(IMOD)%ZB -! - IF ( GINIT ) THEN -! - MAPSTA => GRIDS(IMOD)%MAPSTA - MAPST2 => GRIDS(IMOD)%MAPST2 - MAPFS => GRIDS(IMOD)%MAPFS - MAPSF => GRIDS(IMOD)%MAPSF - FLAGST => GRIDS(IMOD)%FLAGST -! + PoLat => GRIDS(IMOD)%PoLat + PoLon => GRIDS(IMOD)%PoLon + FLAGUNR => GRIDS(IMOD)%FLAGUNR +#endif + FICEN => GRIDS(IMOD)%FICEN + FICEL => GRIDS(IMOD)%FICEL + IICEHMIN => GRIDS(IMOD)%IICEHMIN + IICEHDISP => GRIDS(IMOD)%IICEHDISP + IICEFDISP => GRIDS(IMOD)%IICEFDISP + IICEDDISP => GRIDS(IMOD)%IICEDDISP + IICEHFAC => GRIDS(IMOD)%IICEHFAC + IICEHINIT => GRIDS(IMOD)%IICEHINIT + ICESCALES => GRIDS(IMOD)%ICESCALES + PFMOVE => GRIDS(IMOD)%PFMOVE + STEXU => GRIDS(IMOD)%STEXU + STEYU => GRIDS(IMOD)%STEYU + STEDU => GRIDS(IMOD)%STEDU + BTBETA => GRIDS(IMOD)%BTBETA + AAIRGB => GRIDS(IMOD)%AAIRGB + AAIRCMIN => GRIDS(IMOD)%AAIRCMIN + ! + GINIT => GRIDS(IMOD)%GINIT + GUGINIT => GRIDS(IMOD)%GUGINIT + FLDRY => GRIDS(IMOD)%FLDRY + FLCX => GRIDS(IMOD)%FLCX + FLCY => GRIDS(IMOD)%FLCY + FLCTH => GRIDS(IMOD)%FLCTH + FLCK => GRIDS(IMOD)%FLCK + FLSOU => GRIDS(IMOD)%FLSOU + IICEDISP => GRIDS(IMOD)%IICEDISP + IICESMOOTH => GRIDS(IMOD)%IICESMOOTH + ! + GNAME => GRIDS(IMOD)%GNAME + FILEXT => GRIDS(IMOD)%FILEXT + TRIGP => GRIDS(IMOD)%TRIGP + NTRI => GRIDS(IMOD)%NTRI + COUNTRI => GRIDS(IMOD)%COUNTRI + SI => GRIDS(IMOD)%SI + COUNTOT => GRIDS(IMOD)%COUNTOT + IEN => GRIDS(IMOD)%IEN + LEN => GRIDS(IMOD)%LEN + ANGLE => GRIDS(IMOD)%ANGLE + ANGLE0 => GRIDS(IMOD)%ANGLE0 + CCON => GRIDS(IMOD)%CCON + COUNTCON => GRIDS(IMOD)%COUNTCON + INDEX_CELL => GRIDS(IMOD)%INDEX_CELL + IE_CELL => GRIDS(IMOD)%IE_CELL + POS_CELL => GRIDS(IMOD)%POS_CELL + IOBP => GRIDS(IMOD)%IOBP + IAA => GRIDS(IMOD)%IAA + JAA => GRIDS(IMOD)%JAA + POSI => GRIDS(IMOD)%POSI + I_DIAG => GRIDS(IMOD)%I_DIAG + JA_IE => GRIDS(IMOD)%JA_IE + NBEDGE => GRIDS(IMOD)%NBEDGE + EDGES => GRIDS(IMOD)%EDGES + NEIGH => GRIDS(IMOD)%NEIGH + NNZ => GRIDS(IMOD)%NNZ + IOBPD => GRIDS(IMOD)%IOBPD + IOBDP => GRIDS(IMOD)%IOBDP + IOBPA => GRIDS(IMOD)%IOBPA + TRIA => GRIDS(IMOD)%TRIA + CROSSDIFF => GRIDS(IMOD)%CROSSDIFF + MAXX => GRIDS(IMOD)%MAXX + MAXY => GRIDS(IMOD)%MAXY + DXYMAX => GRIDS(IMOD)%DXYMAX + XGRD => GRIDS(IMOD)%XGRD + YGRD => GRIDS(IMOD)%YGRD + ZB => GRIDS(IMOD)%ZB + ! + IF ( GINIT ) THEN + ! + MAPSTA => GRIDS(IMOD)%MAPSTA + MAPST2 => GRIDS(IMOD)%MAPST2 + MAPFS => GRIDS(IMOD)%MAPFS + MAPSF => GRIDS(IMOD)%MAPSF + FLAGST => GRIDS(IMOD)%FLAGST + ! #ifdef W3_RTD - AnglD => GRIDS(IMOD)%AnglD -#endif - CLATS => GRIDS(IMOD)%CLATS - CLATIS => GRIDS(IMOD)%CLATIS - CTHG0S => GRIDS(IMOD)%CTHG0S - TRNX => GRIDS(IMOD)%TRNX - TRNY => GRIDS(IMOD)%TRNY -! - DXDP => GRIDS(IMOD)%DXDP - DXDQ => GRIDS(IMOD)%DXDQ - DYDP => GRIDS(IMOD)%DYDP - DYDQ => GRIDS(IMOD)%DYDQ - DPDX => GRIDS(IMOD)%DPDX - DPDY => GRIDS(IMOD)%DPDY - DQDX => GRIDS(IMOD)%DQDX - DQDY => GRIDS(IMOD)%DQDY - GSQRT => GRIDS(IMOD)%GSQRT - HPFAC => GRIDS(IMOD)%HPFAC - HQFAC => GRIDS(IMOD)%HQFAC -! + AnglD => GRIDS(IMOD)%AnglD +#endif + CLATS => GRIDS(IMOD)%CLATS + CLATIS => GRIDS(IMOD)%CLATIS + CTHG0S => GRIDS(IMOD)%CTHG0S + TRNX => GRIDS(IMOD)%TRNX + TRNY => GRIDS(IMOD)%TRNY + ! + DXDP => GRIDS(IMOD)%DXDP + DXDQ => GRIDS(IMOD)%DXDQ + DYDP => GRIDS(IMOD)%DYDP + DYDQ => GRIDS(IMOD)%DYDQ + DPDX => GRIDS(IMOD)%DPDX + DPDY => GRIDS(IMOD)%DPDY + DQDX => GRIDS(IMOD)%DQDX + DQDY => GRIDS(IMOD)%DQDY + GSQRT => GRIDS(IMOD)%GSQRT + HPFAC => GRIDS(IMOD)%HPFAC + HQFAC => GRIDS(IMOD)%HQFAC + ! #ifdef W3_BT4 - SED_D50 => GRIDS(IMOD)%SED_D50 - SED_PSIC => GRIDS(IMOD)%SED_PSIC + SED_D50 => GRIDS(IMOD)%SED_D50 + SED_PSIC => GRIDS(IMOD)%SED_PSIC #endif -! + ! #ifdef W3_SMC - NLvCel => GRIDS(IMOD)%NLvCel - NLvUFc => GRIDS(IMOD)%NLvUFc - NLvVFc => GRIDS(IMOD)%NLvVFc - IJKCel => GRIDS(IMOD)%IJKCel - IJKUFc => GRIDS(IMOD)%IJKUFc - IJKVFc => GRIDS(IMOD)%IJKVFc - ISMCBP => GRIDS(IMOD)%ISMCBP - CTRNX => GRIDS(IMOD)%CTRNX - CTRNY => GRIDS(IMOD)%CTRNY - CLATF => GRIDS(IMOD)%CLATF - - IJKCel3 => GRIDS(IMOD)%IJKCel3 - IJKCel4 => GRIDS(IMOD)%IJKCel4 - IJKVFc5 => GRIDS(IMOD)%IJKVFc5 - IJKVFc6 => GRIDS(IMOD)%IJKVFc6 - IJKUFc5 => GRIDS(IMOD)%IJKUFc5 - IJKUFc6 => GRIDS(IMOD)%IJKUFc6 + NLvCel => GRIDS(IMOD)%NLvCel + NLvUFc => GRIDS(IMOD)%NLvUFc + NLvVFc => GRIDS(IMOD)%NLvVFc + IJKCel => GRIDS(IMOD)%IJKCel + IJKUFc => GRIDS(IMOD)%IJKUFc + IJKVFc => GRIDS(IMOD)%IJKVFc + ISMCBP => GRIDS(IMOD)%ISMCBP + CTRNX => GRIDS(IMOD)%CTRNX + CTRNY => GRIDS(IMOD)%CTRNY + CLATF => GRIDS(IMOD)%CLATF -#endif -! + IJKCel3 => GRIDS(IMOD)%IJKCel3 + IJKCel4 => GRIDS(IMOD)%IJKCel4 + IJKVFc5 => GRIDS(IMOD)%IJKVFc5 + IJKVFc6 => GRIDS(IMOD)%IJKVFc6 + IJKUFc5 => GRIDS(IMOD)%IJKUFc5 + IJKUFc6 => GRIDS(IMOD)%IJKUFc6 +#endif + ! #ifdef W3_SMC - ICLBAC => GRIDS(IMOD)%ICLBAC - ANGARC => GRIDS(IMOD)%ANGARC - SPCBAC => GRIDS(IMOD)%SPCBAC -#endif -! - GSU => GRIDS(IMOD)%GSU -! - END IF -! -! -------------------------------------------------------------------- / -! 4. Set pointers in structure SGRD -! - NK => SGRDS(IMOD)%NK - NK2 => SGRDS(IMOD)%NK2 - NTH => SGRDS(IMOD)%NTH - NSPEC => SGRDS(IMOD)%NSPEC -! - DTH => SGRDS(IMOD)%DTH - XFR => SGRDS(IMOD)%XFR - FR1 => SGRDS(IMOD)%FR1 - FTE => SGRDS(IMOD)%FTE - FTF => SGRDS(IMOD)%FTF - FTWN => SGRDS(IMOD)%FTWN - FTTR => SGRDS(IMOD)%FTTR - FTWL => SGRDS(IMOD)%FTWL - FACTI1 => SGRDS(IMOD)%FACTI1 - FACTI2 => SGRDS(IMOD)%FACTI2 - FACHFA => SGRDS(IMOD)%FACHFA - FACHFE => SGRDS(IMOD)%FACHFE -! - SINIT => SGRDS(IMOD)%SINIT -! - IF ( SINIT ) THEN -! - MAPWN => SGRDS(IMOD)%MAPWN - MAPTH => SGRDS(IMOD)%MAPTH -! - TH => SGRDS(IMOD)%TH - ESIN => SGRDS(IMOD)%ESIN - ECOS => SGRDS(IMOD)%ECOS - ES2 => SGRDS(IMOD)%ES2 - ESC => SGRDS(IMOD)%ESC - EC2 => SGRDS(IMOD)%EC2 - SIG => SGRDS(IMOD)%SIG - SIG2 => SGRDS(IMOD)%SIG2 - DSIP => SGRDS(IMOD)%DSIP - DSII => SGRDS(IMOD)%DSII - DDEN => SGRDS(IMOD)%DDEN - DDEN2 => SGRDS(IMOD)%DDEN2 -! - END IF -! -! -------------------------------------------------------------------- / -! 5. Set pointers in structure MPAR -! - PINIT => MPARS(IMOD)%PINIT -! -! Structure NPARS -! - FACP => MPARS(IMOD)%NPARS%FACP - XREL => MPARS(IMOD)%NPARS%XREL - XFLT => MPARS(IMOD)%NPARS%XFLT - FXFM => MPARS(IMOD)%NPARS%FXFM - FXPM => MPARS(IMOD)%NPARS%FXPM - XFT => MPARS(IMOD)%NPARS%XFT - XFC => MPARS(IMOD)%NPARS%XFC - FACSD => MPARS(IMOD)%NPARS%FACSD - FHMAX => MPARS(IMOD)%NPARS%FHMAX + ICLBAC => GRIDS(IMOD)%ICLBAC + ANGARC => GRIDS(IMOD)%ANGARC + SPCBAC => GRIDS(IMOD)%SPCBAC +#endif + ! + GSU => GRIDS(IMOD)%GSU + ! + END IF + ! + ! -------------------------------------------------------------------- / + ! 4. Set pointers in structure SGRD + ! + NK => SGRDS(IMOD)%NK + NK2 => SGRDS(IMOD)%NK2 + NTH => SGRDS(IMOD)%NTH + NSPEC => SGRDS(IMOD)%NSPEC + ! + DTH => SGRDS(IMOD)%DTH + XFR => SGRDS(IMOD)%XFR + FR1 => SGRDS(IMOD)%FR1 + FTE => SGRDS(IMOD)%FTE + FTF => SGRDS(IMOD)%FTF + FTWN => SGRDS(IMOD)%FTWN + FTTR => SGRDS(IMOD)%FTTR + FTWL => SGRDS(IMOD)%FTWL + FACTI1 => SGRDS(IMOD)%FACTI1 + FACTI2 => SGRDS(IMOD)%FACTI2 + FACHFA => SGRDS(IMOD)%FACHFA + FACHFE => SGRDS(IMOD)%FACHFE + ! + SINIT => SGRDS(IMOD)%SINIT + ! + IF ( SINIT ) THEN + ! + MAPWN => SGRDS(IMOD)%MAPWN + MAPTH => SGRDS(IMOD)%MAPTH + ! + TH => SGRDS(IMOD)%TH + ESIN => SGRDS(IMOD)%ESIN + ECOS => SGRDS(IMOD)%ECOS + ES2 => SGRDS(IMOD)%ES2 + ESC => SGRDS(IMOD)%ESC + EC2 => SGRDS(IMOD)%EC2 + SIG => SGRDS(IMOD)%SIG + SIG2 => SGRDS(IMOD)%SIG2 + DSIP => SGRDS(IMOD)%DSIP + DSII => SGRDS(IMOD)%DSII + DDEN => SGRDS(IMOD)%DDEN + DDEN2 => SGRDS(IMOD)%DDEN2 + ! + END IF + ! + ! -------------------------------------------------------------------- / + ! 5. Set pointers in structure MPAR + ! + PINIT => MPARS(IMOD)%PINIT + ! + ! Structure NPARS + ! + FACP => MPARS(IMOD)%NPARS%FACP + XREL => MPARS(IMOD)%NPARS%XREL + XFLT => MPARS(IMOD)%NPARS%XFLT + FXFM => MPARS(IMOD)%NPARS%FXFM + FXPM => MPARS(IMOD)%NPARS%FXPM + XFT => MPARS(IMOD)%NPARS%XFT + XFC => MPARS(IMOD)%NPARS%XFC + FACSD => MPARS(IMOD)%NPARS%FACSD + FHMAX => MPARS(IMOD)%NPARS%FHMAX #ifdef W3_RWND RWINDC => MPARS(IMOD)%NPARS%RWINDC #endif #ifdef W3_WCOR WWCOR => MPARS(IMOD)%NPARS%WWCOR #endif -! -! Structure PROPS -! + ! + ! Structure PROPS + ! #ifdef W3_PR2 - DTME => MPARS(IMOD)%PROPS%DTME - CLATMN => MPARS(IMOD)%PROPS%CLATMN + DTME => MPARS(IMOD)%PROPS%DTME + CLATMN => MPARS(IMOD)%PROPS%CLATMN #endif #ifdef W3_PR3 - WDCG => MPARS(IMOD)%PROPS%WDCG - WDTH => MPARS(IMOD)%PROPS%WDTH + WDCG => MPARS(IMOD)%PROPS%WDCG + WDTH => MPARS(IMOD)%PROPS%WDTH #endif #ifdef W3_SMC - DTMS => MPARS(IMOD)%PROPS%DTMS - Refran => MPARS(IMOD)%PROPS%Refran - FUNO3 => MPARS(IMOD)%PROPS%FUNO3 - FVERG => MPARS(IMOD)%PROPS%FVERG - FSWND => MPARS(IMOD)%PROPS%FSWND - ARCTC => MPARS(IMOD)%PROPS%ARCTC -#endif -! -! Structure FLDP -! + DTMS => MPARS(IMOD)%PROPS%DTMS + Refran => MPARS(IMOD)%PROPS%Refran + FUNO3 => MPARS(IMOD)%PROPS%FUNO3 + FVERG => MPARS(IMOD)%PROPS%FVERG + FSWND => MPARS(IMOD)%PROPS%FSWND + ARCTC => MPARS(IMOD)%PROPS%ARCTC +#endif + ! + ! Structure FLDP + ! #ifdef W3_FLD1 - TAIL_ID => MPARS(IMOD)%FLDPS%TAIL_ID - TAIL_LEV => MPARS(IMOD)%FLDPS%TAIL_LEV - TAIL_TRAN1 => MPARS(IMOD)%FLDPS%TAIL_TRAN1 - TAIL_TRAN2 => MPARS(IMOD)%FLDPS%TAIL_TRAN2 + TAIL_ID => MPARS(IMOD)%FLDPS%TAIL_ID + TAIL_LEV => MPARS(IMOD)%FLDPS%TAIL_LEV + TAIL_TRAN1 => MPARS(IMOD)%FLDPS%TAIL_TRAN1 + TAIL_TRAN2 => MPARS(IMOD)%FLDPS%TAIL_TRAN2 #endif #ifdef W3_FLD2 - TAIL_ID => MPARS(IMOD)%FLDPS%TAIL_ID - TAIL_LEV => MPARS(IMOD)%FLDPS%TAIL_LEV - TAIL_TRAN1 => MPARS(IMOD)%FLDPS%TAIL_TRAN1 - TAIL_TRAN2 => MPARS(IMOD)%FLDPS%TAIL_TRAN2 -#endif -! -! Structure SFLPS -! + TAIL_ID => MPARS(IMOD)%FLDPS%TAIL_ID + TAIL_LEV => MPARS(IMOD)%FLDPS%TAIL_LEV + TAIL_TRAN1 => MPARS(IMOD)%FLDPS%TAIL_TRAN1 + TAIL_TRAN2 => MPARS(IMOD)%FLDPS%TAIL_TRAN2 +#endif + ! + ! Structure SFLPS + ! #ifdef W3_FLX2 - NITTIN => MPARS(IMOD)%SFLPS%NITTIN - CINXSI => MPARS(IMOD)%SFLPS%CINXSI + NITTIN => MPARS(IMOD)%SFLPS%NITTIN + CINXSI => MPARS(IMOD)%SFLPS%CINXSI #endif #ifdef W3_FLX3 - NITTIN => MPARS(IMOD)%SFLPS%NITTIN - CAP_ID => MPARS(IMOD)%SFLPS%CAP_ID - CINXSI => MPARS(IMOD)%SFLPS%CINXSI - CD_MAX => MPARS(IMOD)%SFLPS%CD_MAX + NITTIN => MPARS(IMOD)%SFLPS%NITTIN + CAP_ID => MPARS(IMOD)%SFLPS%CAP_ID + CINXSI => MPARS(IMOD)%SFLPS%CINXSI + CD_MAX => MPARS(IMOD)%SFLPS%CD_MAX #endif #ifdef W3_FLX4 - FLX4A0 => MPARS(IMOD)%SFLPS%FLX4A0 + FLX4A0 => MPARS(IMOD)%SFLPS%FLX4A0 #endif -! -! Structure SLNPS -! + ! + ! Structure SLNPS + ! #ifdef W3_LN1 - SLNC1 => MPARS(IMOD)%SLNPS%SLNC1 - FSPM => MPARS(IMOD)%SLNPS%FSPM - FSHF => MPARS(IMOD)%SLNPS%FSHF -#endif -! -! Structure SRCPS -! - WWNMEANPTAIL=> MPARS(IMOD)%SRCPS%WWNMEANPTAIL - SSTXFTFTAIL => MPARS(IMOD)%SRCPS%SSTXFTFTAIL + SLNC1 => MPARS(IMOD)%SLNPS%SLNC1 + FSPM => MPARS(IMOD)%SLNPS%FSPM + FSHF => MPARS(IMOD)%SLNPS%FSHF +#endif + ! + ! Structure SRCPS + ! + WWNMEANPTAIL=> MPARS(IMOD)%SRCPS%WWNMEANPTAIL + SSTXFTFTAIL => MPARS(IMOD)%SRCPS%SSTXFTFTAIL #ifdef W3_ST1 - SINC1 => MPARS(IMOD)%SRCPS%SINC1 - SDSC1 => MPARS(IMOD)%SRCPS%SDSC1 + SINC1 => MPARS(IMOD)%SRCPS%SINC1 + SDSC1 => MPARS(IMOD)%SRCPS%SDSC1 #endif #ifdef W3_ST2 - ZWIND => MPARS(IMOD)%SRCPS%ZWIND - FSWELL => MPARS(IMOD)%SRCPS%FSWELL - SHSTAB => MPARS(IMOD)%SRCPS%SHSTAB - OFSTAB => MPARS(IMOD)%SRCPS%OFSTAB - CCNG => MPARS(IMOD)%SRCPS%CCNG - CCPS => MPARS(IMOD)%SRCPS%CCPS - FFNG => MPARS(IMOD)%SRCPS%FFNG - FFPS => MPARS(IMOD)%SRCPS%FFPS - CDSA0 => MPARS(IMOD)%SRCPS%CDSA0 - CDSA1 => MPARS(IMOD)%SRCPS%CDSA1 - CDSA2 => MPARS(IMOD)%SRCPS%CDSA2 - SDSALN => MPARS(IMOD)%SRCPS%SDSALN - CDSB0 => MPARS(IMOD)%SRCPS%CDSB0 - CDSB1 => MPARS(IMOD)%SRCPS%CDSB1 - CDSB2 => MPARS(IMOD)%SRCPS%CDSB2 - CDSB3 => MPARS(IMOD)%SRCPS%CDSB3 - FPIMIN => MPARS(IMOD)%SRCPS%FPIMIN - XFH => MPARS(IMOD)%SRCPS%XFH - XF1 => MPARS(IMOD)%SRCPS%XF1 - XF2 => MPARS(IMOD)%SRCPS%XF2 -#endif -! + ZWIND => MPARS(IMOD)%SRCPS%ZWIND + FSWELL => MPARS(IMOD)%SRCPS%FSWELL + SHSTAB => MPARS(IMOD)%SRCPS%SHSTAB + OFSTAB => MPARS(IMOD)%SRCPS%OFSTAB + CCNG => MPARS(IMOD)%SRCPS%CCNG + CCPS => MPARS(IMOD)%SRCPS%CCPS + FFNG => MPARS(IMOD)%SRCPS%FFNG + FFPS => MPARS(IMOD)%SRCPS%FFPS + CDSA0 => MPARS(IMOD)%SRCPS%CDSA0 + CDSA1 => MPARS(IMOD)%SRCPS%CDSA1 + CDSA2 => MPARS(IMOD)%SRCPS%CDSA2 + SDSALN => MPARS(IMOD)%SRCPS%SDSALN + CDSB0 => MPARS(IMOD)%SRCPS%CDSB0 + CDSB1 => MPARS(IMOD)%SRCPS%CDSB1 + CDSB2 => MPARS(IMOD)%SRCPS%CDSB2 + CDSB3 => MPARS(IMOD)%SRCPS%CDSB3 + FPIMIN => MPARS(IMOD)%SRCPS%FPIMIN + XFH => MPARS(IMOD)%SRCPS%XFH + XF1 => MPARS(IMOD)%SRCPS%XF1 + XF2 => MPARS(IMOD)%SRCPS%XF2 +#endif + ! #ifdef W3_ST3 - ZZWND => MPARS(IMOD)%SRCPS%ZZWND - AALPHA => MPARS(IMOD)%SRCPS%AALPHA - BBETA => MPARS(IMOD)%SRCPS%BBETA - SSINTHP => MPARS(IMOD)%SRCPS%SSINTHP - ZZ0MAX => MPARS(IMOD)%SRCPS%ZZ0MAX - ZZ0RAT => MPARS(IMOD)%SRCPS%ZZ0RAT - ZZALP => MPARS(IMOD)%SRCPS%ZZALP - TTAUWSHELTER => MPARS(IMOD)%SRCPS%TTAUWSHELTER - SSWELLF => MPARS(IMOD)%SRCPS%SSWELLF - SSDSC1 => MPARS(IMOD)%SRCPS%SSDSC1 - WWNMEANP => MPARS(IMOD)%SRCPS%WWNMEANP - FFXFM => MPARS(IMOD)%SRCPS%FFXFM - FFXPM => MPARS(IMOD)%SRCPS%FFXPM - DDELTA1 => MPARS(IMOD)%SRCPS%DDELTA1 - DDELTA2 => MPARS(IMOD)%SRCPS%DDELTA2 - SSTXFTF => MPARS(IMOD)%SRCPS%SSTXFTF - SSTXFTWN => MPARS(IMOD)%SRCPS%SSTXFTWN -#endif -! + ZZWND => MPARS(IMOD)%SRCPS%ZZWND + AALPHA => MPARS(IMOD)%SRCPS%AALPHA + BBETA => MPARS(IMOD)%SRCPS%BBETA + SSINTHP => MPARS(IMOD)%SRCPS%SSINTHP + ZZ0MAX => MPARS(IMOD)%SRCPS%ZZ0MAX + ZZ0RAT => MPARS(IMOD)%SRCPS%ZZ0RAT + ZZALP => MPARS(IMOD)%SRCPS%ZZALP + TTAUWSHELTER => MPARS(IMOD)%SRCPS%TTAUWSHELTER + SSWELLF => MPARS(IMOD)%SRCPS%SSWELLF + SSDSC1 => MPARS(IMOD)%SRCPS%SSDSC1 + WWNMEANP => MPARS(IMOD)%SRCPS%WWNMEANP + FFXFM => MPARS(IMOD)%SRCPS%FFXFM + FFXPM => MPARS(IMOD)%SRCPS%FFXPM + DDELTA1 => MPARS(IMOD)%SRCPS%DDELTA1 + DDELTA2 => MPARS(IMOD)%SRCPS%DDELTA2 + SSTXFTF => MPARS(IMOD)%SRCPS%SSTXFTF + SSTXFTWN => MPARS(IMOD)%SRCPS%SSTXFTWN +#endif + ! #ifdef W3_ST4 - ZZWND => MPARS(IMOD)%SRCPS%ZZWND - AALPHA => MPARS(IMOD)%SRCPS%AALPHA - BBETA => MPARS(IMOD)%SRCPS%BBETA - SSINTHP => MPARS(IMOD)%SRCPS%SSINTHP - ZZ0MAX => MPARS(IMOD)%SRCPS%ZZ0MAX - ZZ0RAT => MPARS(IMOD)%SRCPS%ZZ0RAT - ZZALP => MPARS(IMOD)%SRCPS%ZZALP - TTAUWSHELTER => MPARS(IMOD)%SRCPS%TTAUWSHELTER - SSWELLFPAR => MPARS(IMOD)%SRCPS%SSWELLFPAR - SSWELLF => MPARS(IMOD)%SRCPS%SSWELLF - SSDSC => MPARS(IMOD)%SRCPS%SSDSC - SSDSBR => MPARS(IMOD)%SRCPS%SSDSBR - SSDSBT => MPARS(IMOD)%SRCPS%SSDSBT - SSDSBRF1 => MPARS(IMOD)%SRCPS%SSDSBRF1 - SSDSBRF2 => MPARS(IMOD)%SRCPS%SSDSBRF2 - SSDSBRFDF => MPARS(IMOD)%SRCPS%SSDSBRFDF - SSDSBM => MPARS(IMOD)%SRCPS%SSDSBM - SSDSBCK => MPARS(IMOD)%SRCPS%SSDSBCK - SSDSABK => MPARS(IMOD)%SRCPS%SSDSABK - SSDSPBK => MPARS(IMOD)%SRCPS%SSDSPBK - SSDSHCK => MPARS(IMOD)%SRCPS%SSDSHCK - SSDSBINT => MPARS(IMOD)%SRCPS%SSDSBINT - SSDSP => MPARS(IMOD)%SRCPS%SSDSP - WWNMEANP => MPARS(IMOD)%SRCPS%WWNMEANP - FFXFM => MPARS(IMOD)%SRCPS%FFXFM - FFXFA => MPARS(IMOD)%SRCPS%FFXFA - FFXPM => MPARS(IMOD)%SRCPS%FFXPM - SSDSDTH => MPARS(IMOD)%SRCPS%SSDSDTH - SSTXFTF => MPARS(IMOD)%SRCPS%SSTXFTF - SSTXFTWN => MPARS(IMOD)%SRCPS%SSTXFTWN - SSDSCOS => MPARS(IMOD)%SRCPS%SSDSCOS - SSDSISO => MPARS(IMOD)%SRCPS%SSDSISO - IKTAB => MPARS(IMOD)%SRCPS%IKTAB - DCKI => MPARS(IMOD)%SRCPS%DCKI - QBI => MPARS(IMOD)%SRCPS%QBI - CUMULW => MPARS(IMOD)%SRCPS%CUMULW - SATINDICES => MPARS(IMOD)%SRCPS%SATINDICES - SATWEIGHTS => MPARS(IMOD)%SRCPS%SATWEIGHTS - SSINBR => MPARS(IMOD)%SRCPS%SSINBR -#endif -! + ZZWND => MPARS(IMOD)%SRCPS%ZZWND + AALPHA => MPARS(IMOD)%SRCPS%AALPHA + BBETA => MPARS(IMOD)%SRCPS%BBETA + SSINTHP => MPARS(IMOD)%SRCPS%SSINTHP + ZZ0MAX => MPARS(IMOD)%SRCPS%ZZ0MAX + ZZ0RAT => MPARS(IMOD)%SRCPS%ZZ0RAT + ZZALP => MPARS(IMOD)%SRCPS%ZZALP + TTAUWSHELTER => MPARS(IMOD)%SRCPS%TTAUWSHELTER + SSWELLFPAR => MPARS(IMOD)%SRCPS%SSWELLFPAR + SSWELLF => MPARS(IMOD)%SRCPS%SSWELLF + SSDSC => MPARS(IMOD)%SRCPS%SSDSC + SSDSBR => MPARS(IMOD)%SRCPS%SSDSBR + SSDSBT => MPARS(IMOD)%SRCPS%SSDSBT + SSDSBRF1 => MPARS(IMOD)%SRCPS%SSDSBRF1 + SSDSBRF2 => MPARS(IMOD)%SRCPS%SSDSBRF2 + SSDSBRFDF => MPARS(IMOD)%SRCPS%SSDSBRFDF + SSDSBM => MPARS(IMOD)%SRCPS%SSDSBM + SSDSBCK => MPARS(IMOD)%SRCPS%SSDSBCK + SSDSABK => MPARS(IMOD)%SRCPS%SSDSABK + SSDSPBK => MPARS(IMOD)%SRCPS%SSDSPBK + SSDSHCK => MPARS(IMOD)%SRCPS%SSDSHCK + SSDSBINT => MPARS(IMOD)%SRCPS%SSDSBINT + SSDSP => MPARS(IMOD)%SRCPS%SSDSP + WWNMEANP => MPARS(IMOD)%SRCPS%WWNMEANP + FFXFM => MPARS(IMOD)%SRCPS%FFXFM + FFXFA => MPARS(IMOD)%SRCPS%FFXFA + FFXPM => MPARS(IMOD)%SRCPS%FFXPM + SSDSDTH => MPARS(IMOD)%SRCPS%SSDSDTH + SSTXFTF => MPARS(IMOD)%SRCPS%SSTXFTF + SSTXFTWN => MPARS(IMOD)%SRCPS%SSTXFTWN + SSDSCOS => MPARS(IMOD)%SRCPS%SSDSCOS + SSDSISO => MPARS(IMOD)%SRCPS%SSDSISO + IKTAB => MPARS(IMOD)%SRCPS%IKTAB + DCKI => MPARS(IMOD)%SRCPS%DCKI + QBI => MPARS(IMOD)%SRCPS%QBI + CUMULW => MPARS(IMOD)%SRCPS%CUMULW + SATINDICES => MPARS(IMOD)%SRCPS%SATINDICES + SATWEIGHTS => MPARS(IMOD)%SRCPS%SATWEIGHTS + SSINBR => MPARS(IMOD)%SRCPS%SSINBR +#endif + ! #ifdef W3_ST6 - SIN6A0 => MPARS(IMOD)%SRCPS%SIN6A0 - SIN6WS => MPARS(IMOD)%SRCPS%SIN6WS - SIN6FC => MPARS(IMOD)%SRCPS%SIN6FC - SDS6ET => MPARS(IMOD)%SRCPS%SDS6ET - SDS6A1 => MPARS(IMOD)%SRCPS%SDS6A1 - SDS6P1 => MPARS(IMOD)%SRCPS%SDS6P1 - SDS6A2 => MPARS(IMOD)%SRCPS%SDS6A2 - SDS6P2 => MPARS(IMOD)%SRCPS%SDS6P2 - SWL6S6 => MPARS(IMOD)%SRCPS%SWL6S6 - SWL6B1 => MPARS(IMOD)%SRCPS%SWL6B1 - SWL6CSTB1 => MPARS(IMOD)%SRCPS%SWL6CSTB1 -#endif -! -! Structure SRNLS -! + SIN6A0 => MPARS(IMOD)%SRCPS%SIN6A0 + SIN6WS => MPARS(IMOD)%SRCPS%SIN6WS + SIN6FC => MPARS(IMOD)%SRCPS%SIN6FC + SDS6ET => MPARS(IMOD)%SRCPS%SDS6ET + SDS6A1 => MPARS(IMOD)%SRCPS%SDS6A1 + SDS6P1 => MPARS(IMOD)%SRCPS%SDS6P1 + SDS6A2 => MPARS(IMOD)%SRCPS%SDS6A2 + SDS6P2 => MPARS(IMOD)%SRCPS%SDS6P2 + SWL6S6 => MPARS(IMOD)%SRCPS%SWL6S6 + SWL6B1 => MPARS(IMOD)%SRCPS%SWL6B1 + SWL6CSTB1 => MPARS(IMOD)%SRCPS%SWL6CSTB1 +#endif + ! + ! Structure SRNLS + ! #ifdef W3_NL1 - SNLC1 => MPARS(IMOD)%SNLPS%SNLC1 - LAM => MPARS(IMOD)%SNLPS%LAM - KDCON => MPARS(IMOD)%SNLPS%KDCON - KDMN => MPARS(IMOD)%SNLPS%KDMN - SNLS1 => MPARS(IMOD)%SNLPS%SNLS1 - SNLS2 => MPARS(IMOD)%SNLPS%SNLS2 - SNLS3 => MPARS(IMOD)%SNLPS%SNLS3 + SNLC1 => MPARS(IMOD)%SNLPS%SNLC1 + LAM => MPARS(IMOD)%SNLPS%LAM + KDCON => MPARS(IMOD)%SNLPS%KDCON + KDMN => MPARS(IMOD)%SNLPS%KDMN + SNLS1 => MPARS(IMOD)%SNLPS%SNLS1 + SNLS2 => MPARS(IMOD)%SNLPS%SNLS2 + SNLS3 => MPARS(IMOD)%SNLPS%SNLS3 #endif #ifdef W3_NL2 - IQTPE => MPARS(IMOD)%SNLPS%IQTPE - NDPTHS => MPARS(IMOD)%SNLPS%NDPTHS - NLTAIL => MPARS(IMOD)%SNLPS%NLTAIL - IF ( NDPTHS .NE. 0 ) DPTHNL => MPARS(IMOD)%SNLPS%DPTHNL + IQTPE => MPARS(IMOD)%SNLPS%IQTPE + NDPTHS => MPARS(IMOD)%SNLPS%NDPTHS + NLTAIL => MPARS(IMOD)%SNLPS%NLTAIL + IF ( NDPTHS .NE. 0 ) DPTHNL => MPARS(IMOD)%SNLPS%DPTHNL #endif #ifdef W3_NL3 - NFRMIN => MPARS(IMOD)%SNLPS%NFRMIN - NFRMAX => MPARS(IMOD)%SNLPS%NFRMAX - NFRCUT => MPARS(IMOD)%SNLPS%NFRCUT - NTHMAX => MPARS(IMOD)%SNLPS%NTHMAX - NTHEXP => MPARS(IMOD)%SNLPS%NTHEXP - NSPMIN => MPARS(IMOD)%SNLPS%NSPMIN - NSPMAX => MPARS(IMOD)%SNLPS%NSPMAX - NSPMX2 => MPARS(IMOD)%SNLPS%NSPMX2 - FRQ => MPARS(IMOD)%SNLPS%FRQ - XSI => MPARS(IMOD)%SNLPS%XSI - NQA => MPARS(IMOD)%SNLPS%NQA - QST1 => MPARS(IMOD)%SNLPS%QST1 - QST2 => MPARS(IMOD)%SNLPS%QST2 - QST3 => MPARS(IMOD)%SNLPS%QST3 - QST4 => MPARS(IMOD)%SNLPS%QST4 - QST5 => MPARS(IMOD)%SNLPS%QST5 - QST6 => MPARS(IMOD)%SNLPS%QST6 - SNLNQ => MPARS(IMOD)%SNLPS%SNLNQ - SNLMSC => MPARS(IMOD)%SNLPS%SNLMSC - SNLNSC => MPARS(IMOD)%SNLPS%SNLNSC - SNLSFD => MPARS(IMOD)%SNLPS%SNLSFD - SNLSFS => MPARS(IMOD)%SNLPS%SNLSFS - SNLL => MPARS(IMOD)%SNLPS%SNLL - SNLM => MPARS(IMOD)%SNLPS%SNLM - SNLT => MPARS(IMOD)%SNLPS%SNLT - SNLCD => MPARS(IMOD)%SNLPS%SNLCD - SNLCS => MPARS(IMOD)%SNLPS%SNLCS + NFRMIN => MPARS(IMOD)%SNLPS%NFRMIN + NFRMAX => MPARS(IMOD)%SNLPS%NFRMAX + NFRCUT => MPARS(IMOD)%SNLPS%NFRCUT + NTHMAX => MPARS(IMOD)%SNLPS%NTHMAX + NTHEXP => MPARS(IMOD)%SNLPS%NTHEXP + NSPMIN => MPARS(IMOD)%SNLPS%NSPMIN + NSPMAX => MPARS(IMOD)%SNLPS%NSPMAX + NSPMX2 => MPARS(IMOD)%SNLPS%NSPMX2 + FRQ => MPARS(IMOD)%SNLPS%FRQ + XSI => MPARS(IMOD)%SNLPS%XSI + NQA => MPARS(IMOD)%SNLPS%NQA + QST1 => MPARS(IMOD)%SNLPS%QST1 + QST2 => MPARS(IMOD)%SNLPS%QST2 + QST3 => MPARS(IMOD)%SNLPS%QST3 + QST4 => MPARS(IMOD)%SNLPS%QST4 + QST5 => MPARS(IMOD)%SNLPS%QST5 + QST6 => MPARS(IMOD)%SNLPS%QST6 + SNLNQ => MPARS(IMOD)%SNLPS%SNLNQ + SNLMSC => MPARS(IMOD)%SNLPS%SNLMSC + SNLNSC => MPARS(IMOD)%SNLPS%SNLNSC + SNLSFD => MPARS(IMOD)%SNLPS%SNLSFD + SNLSFS => MPARS(IMOD)%SNLPS%SNLSFS + SNLL => MPARS(IMOD)%SNLPS%SNLL + SNLM => MPARS(IMOD)%SNLPS%SNLM + SNLT => MPARS(IMOD)%SNLPS%SNLT + SNLCD => MPARS(IMOD)%SNLPS%SNLCD + SNLCS => MPARS(IMOD)%SNLPS%SNLCS #endif #ifdef W3_NL4 - ITSA => MPARS(IMOD)%SNLPS%ITSA - IALT => MPARS(IMOD)%SNLPS%IALT + ITSA => MPARS(IMOD)%SNLPS%ITSA + IALT => MPARS(IMOD)%SNLPS%IALT #endif #ifdef W3_NL5 - QR5DPT => MPARS(IMOD)%SNLPS%QR5DPT - QR5OML => MPARS(IMOD)%SNLPS%QR5OML - QI5DIS => MPARS(IMOD)%SNLPS%QI5DIS - QI5KEV => MPARS(IMOD)%SNLPS%QI5KEV - QI5NNZ => MPARS(IMOD)%SNLPS%QI5NNZ - QI5IPL => MPARS(IMOD)%SNLPS%QI5IPL - QI5PMX => MPARS(IMOD)%SNLPS%QI5PMX + QR5DPT => MPARS(IMOD)%SNLPS%QR5DPT + QR5OML => MPARS(IMOD)%SNLPS%QR5OML + QI5DIS => MPARS(IMOD)%SNLPS%QI5DIS + QI5KEV => MPARS(IMOD)%SNLPS%QI5KEV + QI5NNZ => MPARS(IMOD)%SNLPS%QI5NNZ + QI5IPL => MPARS(IMOD)%SNLPS%QI5IPL + QI5PMX => MPARS(IMOD)%SNLPS%QI5PMX #endif #ifdef W3_NLS - NTHX => MPARS(IMOD)%SNLPS%NTHX - NFRX => MPARS(IMOD)%SNLPS%NFRX - NSPL => MPARS(IMOD)%SNLPS%NSPL - NSPH => MPARS(IMOD)%SNLPS%NSPH - SNSST => MPARS(IMOD)%SNLPS%SNSST - CNLSA => MPARS(IMOD)%SNLPS%CNLSA - CNLSC => MPARS(IMOD)%SNLPS%CNLSC - CNLSFM => MPARS(IMOD)%SNLPS%CNLSFM - CNLSC1 => MPARS(IMOD)%SNLPS%CNLSC1 - CNLSC2 => MPARS(IMOD)%SNLPS%CNLSC2 - CNLSC3 => MPARS(IMOD)%SNLPS%CNLSC3 -#endif -! -! Structure SBTPS -! + NTHX => MPARS(IMOD)%SNLPS%NTHX + NFRX => MPARS(IMOD)%SNLPS%NFRX + NSPL => MPARS(IMOD)%SNLPS%NSPL + NSPH => MPARS(IMOD)%SNLPS%NSPH + SNSST => MPARS(IMOD)%SNLPS%SNSST + CNLSA => MPARS(IMOD)%SNLPS%CNLSA + CNLSC => MPARS(IMOD)%SNLPS%CNLSC + CNLSFM => MPARS(IMOD)%SNLPS%CNLSFM + CNLSC1 => MPARS(IMOD)%SNLPS%CNLSC1 + CNLSC2 => MPARS(IMOD)%SNLPS%CNLSC2 + CNLSC3 => MPARS(IMOD)%SNLPS%CNLSC3 +#endif + ! + ! Structure SBTPS + ! #ifdef W3_BT1 - SBTC1 => MPARS(IMOD)%SBTPS%SBTC1 + SBTC1 => MPARS(IMOD)%SBTPS%SBTC1 #endif #ifdef W3_BT4 - SBTCX => MPARS(IMOD)%SBTPS%SBTCX + SBTCX => MPARS(IMOD)%SBTPS%SBTCX #endif -! -! Structure SDBPS -! + ! + ! Structure SDBPS + ! #ifdef W3_DB1 - SDBC1 => MPARS(IMOD)%SDBPS%SDBC1 - SDBC2 => MPARS(IMOD)%SDBPS%SDBC2 - FDONLY => MPARS(IMOD)%SDBPS%FDONLY - SDBSC => MPARS(IMOD)%SDBPS%SDBSC + SDBC1 => MPARS(IMOD)%SDBPS%SDBC1 + SDBC2 => MPARS(IMOD)%SDBPS%SDBC2 + FDONLY => MPARS(IMOD)%SDBPS%FDONLY + SDBSC => MPARS(IMOD)%SDBPS%SDBSC #endif -! -! + ! + ! #ifdef W3_UOST - UOSTFILELOCAL => MPARS(IMOD)%UOSTPS%UOSTFILELOCAL - UOSTFILESHADOW => MPARS(IMOD)%UOSTPS%UOSTFILESHADOW - UOSTFACTORLOCAL => MPARS(IMOD)%UOSTPS%UOSTFACTORLOCAL - UOSTFACTORSHADOW => MPARS(IMOD)%UOSTPS%UOSTFACTORSHADOW -#endif -! -! Structure SICPS -! + UOSTFILELOCAL => MPARS(IMOD)%UOSTPS%UOSTFILELOCAL + UOSTFILESHADOW => MPARS(IMOD)%UOSTPS%UOSTFILESHADOW + UOSTFACTORLOCAL => MPARS(IMOD)%UOSTPS%UOSTFACTORLOCAL + UOSTFACTORSHADOW => MPARS(IMOD)%UOSTPS%UOSTFACTORSHADOW +#endif + ! + ! Structure SICPS + ! #ifdef W3_IS1 - IS1C1 => MPARS(IMOD)%SICPS%IS1C1 - IS1C2 => MPARS(IMOD)%SICPS%IS1C2 -#endif -! -! Structure SCHM - FSBCCFL => MPARS(IMOD)%SCHMS%FSBCCFL - FSN => MPARS(IMOD)%SCHMS%FSN - FSPSI => MPARS(IMOD)%SCHMS%FSPSI - FSFCT => MPARS(IMOD)%SCHMS%FSFCT - FSNIMP => MPARS(IMOD)%SCHMS%FSNIMP - FSTOTALIMP => MPARS(IMOD)%SCHMS%FSTOTALIMP - FSTOTALEXP => MPARS(IMOD)%SCHMS%FSTOTALEXP - FSREFRACTION => MPARS(IMOD)%SCHMS%FSREFRACTION - FSFREQSHIFT => MPARS(IMOD)%SCHMS%FSFREQSHIFT - FSSOURCE => MPARS(IMOD)%SCHMS%FSSOURCE - DO_CHANGE_WLV => MPARS(IMOD)%SCHMS%DO_CHANGE_WLV - SOLVERTHR_STP => MPARS(IMOD)%SCHMS%SOLVERTHR_STP - CRIT_DEP_STP => MPARS(IMOD)%SCHMS%CRIT_DEP_STP - B_JGS_TERMINATE_MAXITER => MPARS(IMOD)%SCHMS%B_JGS_TERMINATE_MAXITER - B_JGS_TERMINATE_DIFFERENCE => MPARS(IMOD)%SCHMS%B_JGS_TERMINATE_DIFFERENCE - B_JGS_TERMINATE_NORM => MPARS(IMOD)%SCHMS%B_JGS_TERMINATE_NORM - B_JGS_LIMITER => MPARS(IMOD)%SCHMS%B_JGS_LIMITER - B_JGS_USE_JACOBI => MPARS(IMOD)%SCHMS%B_JGS_USE_JACOBI - B_JGS_BLOCK_GAUSS_SEIDEL => MPARS(IMOD)%SCHMS%B_JGS_BLOCK_GAUSS_SEIDEL - B_JGS_MAXITER => MPARS(IMOD)%SCHMS%B_JGS_MAXITER - B_JGS_PMIN => MPARS(IMOD)%SCHMS%B_JGS_PMIN - B_JGS_DIFF_THR => MPARS(IMOD)%SCHMS%B_JGS_DIFF_THR - B_JGS_NORM_THR => MPARS(IMOD)%SCHMS%B_JGS_NORM_THR - B_JGS_NLEVEL => MPARS(IMOD)%SCHMS%B_JGS_NLEVEL - B_JGS_SOURCE_NONLINEAR => MPARS(IMOD)%SCHMS%B_JGS_SOURCE_NONLINEAR - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3SETG : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3SETG : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NAUXGR = ',I10/ & - ' NGRIDS = ',I10/) -#if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3SETG) - 9000 FORMAT (' TEST W3SETG : GRID/MODEL ',I4,' SELECTED') -#endif -!/ -!/ End of W3SETG ----------------------------------------------------- / -!/ - END SUBROUTINE W3SETG -!/ ------------------------------------------------------------------- / - SUBROUTINE W3GNTX ( IMOD, NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | T. J. Campbell | -!/ | FORTRAN 90 | -!/ | Last update : 20-Jul-2011 | -!/ +-----------------------------------+ -!/ -!/ 30-Oct-2009 : Origination. ( version 3.13 ) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 23-Dec-2010 : Fix HPFAC and HQFAC by including the COS(YGRD) -!/ factor with DXDP and DXDQ terms. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 20-Jul-2011 : HPFAC and HQFAC are now calculated using W3DIST. -!/ Result should be very similar except near pole. -!/ Due to precision issues, HPFAC and HQFAC revert -!/ to SX and SY in case of regular grids. -!/ (W. E. Rogers, NRL) ( version 3.14 ) -!/ 20-Jan-2017 : Update to new W3GSRUMD APIs ( version 6.02 ) -!/ 20-Jan-2017 : Change calculation of curvilinear grid metric and -!/ derivatives calculations to use W3GSRUMD:W3CGDM. -!/ (T.J. Campbell, NRL) ( version 6.02 ) -!/ -! 1. Purpose : -! -! Construct required spatial grid quantities for curvilinear grids. -! -! 2. Method : -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Any program that uses this grid structure. -! -! 6. Error messages : -! -! - Check on previous initialization of grids. -! -! 7. Remarks : -! -! 8. Structure : -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY: EXTCDE -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, NDSE, NDST -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER, PARAMETER :: NFD = 4 - LOGICAL, PARAMETER :: PTILED = .FALSE. - LOGICAL, PARAMETER :: QTILED = .FALSE. - LOGICAL, PARAMETER :: IJG = .FALSE. - LOGICAL, PARAMETER :: SPHERE = .FALSE. - INTEGER :: PRANGE(2), QRANGE(2) - INTEGER :: LBI(2), UBI(2), LBO(2), UBO(2), ISTAT - REAL , ALLOCATABLE :: COSA(:,:) -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3GNTX') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NGRIDS ) THEN - WRITE (NDSE,1002) IMOD, -NAUXGR, NGRIDS - CALL EXTCDE (2) - END IF -! - SELECT CASE ( GRIDS(IMOD)%GTYPE ) - CASE ( RLGTYPE ) - CASE ( CLGTYPE ) - CASE ( SMCTYPE ) - CASE DEFAULT - WRITE (NDSE,1003) GRIDS(IMOD)%GTYPE - CALL EXTCDE (3) - END SELECT -#if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3GNTX) - WRITE (NDST,9000) IMOD -#endif -! -! -------------------------------------------------------------------- / -! 2. Create grid search utility object -! - GRIDS(IMOD)%GSU = W3GSUC( IJG, FLAGLL, GRIDS(IMOD)%ICLOSE, & - GRIDS(IMOD)%XGRD, GRIDS(IMOD)%YGRD ) -#if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3GNTX) - CALL W3GSUP(GRIDS(IMOD)%GSU, NDST) - WRITE (NDST,9001) -#endif -! -! -------------------------------------------------------------------- / -! 3. Reset grid pointers -! - CALL W3SETG ( IMOD, NDSE, NDST ) + IS1C1 => MPARS(IMOD)%SICPS%IS1C1 + IS1C2 => MPARS(IMOD)%SICPS%IS1C2 +#endif + ! + ! Structure SCHM + FSBCCFL => MPARS(IMOD)%SCHMS%FSBCCFL + FSN => MPARS(IMOD)%SCHMS%FSN + FSPSI => MPARS(IMOD)%SCHMS%FSPSI + FSFCT => MPARS(IMOD)%SCHMS%FSFCT + FSNIMP => MPARS(IMOD)%SCHMS%FSNIMP + FSTOTALIMP => MPARS(IMOD)%SCHMS%FSTOTALIMP + FSTOTALEXP => MPARS(IMOD)%SCHMS%FSTOTALEXP + FSREFRACTION => MPARS(IMOD)%SCHMS%FSREFRACTION + FSFREQSHIFT => MPARS(IMOD)%SCHMS%FSFREQSHIFT + FSSOURCE => MPARS(IMOD)%SCHMS%FSSOURCE + DO_CHANGE_WLV => MPARS(IMOD)%SCHMS%DO_CHANGE_WLV + SOLVERTHR_STP => MPARS(IMOD)%SCHMS%SOLVERTHR_STP + CRIT_DEP_STP => MPARS(IMOD)%SCHMS%CRIT_DEP_STP + B_JGS_TERMINATE_MAXITER => MPARS(IMOD)%SCHMS%B_JGS_TERMINATE_MAXITER + B_JGS_TERMINATE_DIFFERENCE => MPARS(IMOD)%SCHMS%B_JGS_TERMINATE_DIFFERENCE + B_JGS_TERMINATE_NORM => MPARS(IMOD)%SCHMS%B_JGS_TERMINATE_NORM + B_JGS_LIMITER => MPARS(IMOD)%SCHMS%B_JGS_LIMITER + B_JGS_USE_JACOBI => MPARS(IMOD)%SCHMS%B_JGS_USE_JACOBI + B_JGS_BLOCK_GAUSS_SEIDEL => MPARS(IMOD)%SCHMS%B_JGS_BLOCK_GAUSS_SEIDEL + B_JGS_MAXITER => MPARS(IMOD)%SCHMS%B_JGS_MAXITER + B_JGS_PMIN => MPARS(IMOD)%SCHMS%B_JGS_PMIN + B_JGS_DIFF_THR => MPARS(IMOD)%SCHMS%B_JGS_DIFF_THR + B_JGS_NORM_THR => MPARS(IMOD)%SCHMS%B_JGS_NORM_THR + B_JGS_NLEVEL => MPARS(IMOD)%SCHMS%B_JGS_NLEVEL + B_JGS_SOURCE_NONLINEAR => MPARS(IMOD)%SCHMS%B_JGS_SOURCE_NONLINEAR + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3SETG : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3SETG : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NAUXGR = ',I10/ & + ' NGRIDS = ',I10/) +9000 FORMAT (' TEST W3SETG : GRID/MODEL ',I4,' SELECTED') + !/ + !/ End of W3SETG ----------------------------------------------------- / + !/ + END SUBROUTINE W3SETG + !/ ------------------------------------------------------------------- / + SUBROUTINE W3GNTX ( IMOD, NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | T. J. Campbell | + !/ | FORTRAN 90 | + !/ | Last update : 20-Jul-2011 | + !/ +-----------------------------------+ + !/ + !/ 30-Oct-2009 : Origination. ( version 3.13 ) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 23-Dec-2010 : Fix HPFAC and HQFAC by including the COS(YGRD) + !/ factor with DXDP and DXDQ terms. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 20-Jul-2011 : HPFAC and HQFAC are now calculated using W3DIST. + !/ Result should be very similar except near pole. + !/ Due to precision issues, HPFAC and HQFAC revert + !/ to SX and SY in case of regular grids. + !/ (W. E. Rogers, NRL) ( version 3.14 ) + !/ 20-Jan-2017 : Update to new W3GSRUMD APIs ( version 6.02 ) + !/ 20-Jan-2017 : Change calculation of curvilinear grid metric and + !/ derivatives calculations to use W3GSRUMD:W3CGDM. + !/ (T.J. Campbell, NRL) ( version 6.02 ) + !/ + ! 1. Purpose : + ! + ! Construct required spatial grid quantities for curvilinear grids. + ! + ! 2. Method : + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Any program that uses this grid structure. + ! + ! 6. Error messages : + ! + ! - Check on previous initialization of grids. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: EXTCDE + USE W3SERVMD, ONLY: STRACE ! W3_S + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, NDSE, NDST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER, PARAMETER :: NFD = 4 + LOGICAL, PARAMETER :: PTILED = .FALSE. + LOGICAL, PARAMETER :: QTILED = .FALSE. + LOGICAL, PARAMETER :: IJG = .FALSE. + LOGICAL, PARAMETER :: SPHERE = .FALSE. + INTEGER :: PRANGE(2), QRANGE(2) + INTEGER :: LBI(2), UBI(2), LBO(2), UBO(2), ISTAT + REAL , ALLOCATABLE :: COSA(:,:) + INTEGER, SAVE :: IENT = 0 ! W3_S + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'W3GNTX') + end if + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NGRIDS ) THEN + WRITE (NDSE,1002) IMOD, -NAUXGR, NGRIDS + CALL EXTCDE (2) + END IF + ! + SELECT CASE ( GRIDS(IMOD)%GTYPE ) + CASE ( RLGTYPE ) + CASE ( CLGTYPE ) + CASE ( SMCTYPE ) + CASE DEFAULT + WRITE (NDSE,1003) GRIDS(IMOD)%GTYPE + CALL EXTCDE (3) + END SELECT #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3GNTX) - WRITE (NDST,9002) -#endif -! -! -------------------------------------------------------------------- / -! 4. Construct curvilinear grid derivatives and metric -! Note that in the case of lon/lat grids, these quantities do not -! include the spherical coordinate metric (SPHERE=.FALSE.). -! + WRITE (NDST,9000) IMOD +#endif + ! + ! -------------------------------------------------------------------- / + ! 2. Create grid search utility object + ! + GRIDS(IMOD)%GSU = W3GSUC( IJG, FLAGLL, GRIDS(IMOD)%ICLOSE, & + GRIDS(IMOD)%XGRD, GRIDS(IMOD)%YGRD ) #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3GNTX) - ALLOCATE ( COSA(NY,NX), STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -#endif - PRANGE = (/ 1,NX/) - QRANGE = (/ 1,NY/) - LBI = (/ 1, 1/) - UBI = (/NY,NX/) - LBO = (/ 1, 1/) - UBO = (/NY,NX/) - SELECT CASE ( GTYPE ) -!!Li SMC grid shares the settings with rectilinear grid. JGLi12Oct2020 - CASE ( RLGTYPE, SMCTYPE ) - CALL W3CGDM( IJG, FLAGLL, ICLOSE, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, LBO, UBO, REAL(XGRD), REAL(YGRD), & - NFD=NFD, SPHERE=SPHERE, DX=SX, DY=SY, & - DXDP=DXDP, DYDP=DYDP, DXDQ=DXDQ, DYDQ=DYDQ, & - DPDX=DPDX, DPDY=DPDY, DQDX=DQDX, DQDY=DQDY, & - HPFC=HPFAC, HQFC=HQFAC, GSQR=GSQRT, & + CALL W3GSUP(GRIDS(IMOD)%GSU, NDST) + WRITE (NDST,9001) +#endif + ! + ! -------------------------------------------------------------------- / + ! 3. Reset grid pointers + ! + CALL W3SETG ( IMOD, NDSE, NDST ) #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3GNTX) - COSA=COSA, & -#endif - RC=ISTAT ) - IF ( ISTAT.NE.0 ) THEN - WRITE (NDSE,1004) GTYPE - CALL EXTCDE (4) - END IF - CASE ( CLGTYPE ) - CALL W3CGDM( IJG, FLAGLL, ICLOSE, PTILED, QTILED, & - PRANGE, QRANGE, LBI, UBI, LBO, UBO, REAL(XGRD), REAL(YGRD), & - NFD=NFD, SPHERE=SPHERE, & - DXDP=DXDP, DYDP=DYDP, DXDQ=DXDQ, DYDQ=DYDQ, & - DPDX=DPDX, DPDY=DPDY, DQDX=DQDX, DQDY=DQDY, & - HPFC=HPFAC, HQFC=HQFAC, GSQR=GSQRT, & + WRITE (NDST,9002) +#endif + ! + ! -------------------------------------------------------------------- / + ! 4. Construct curvilinear grid derivatives and metric + ! Note that in the case of lon/lat grids, these quantities do not + ! include the spherical coordinate metric (SPHERE=.FALSE.). + ! #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3GNTX) - COSA=COSA, & -#endif - RC=ISTAT ) - IF ( ISTAT.NE.0 ) THEN - WRITE (NDSE,1004) GTYPE - CALL EXTCDE (4) - END IF - END SELECT -! + ALLOCATE ( COSA(NY,NX), STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) +#endif + PRANGE = (/ 1,NX/) + QRANGE = (/ 1,NY/) + LBI = (/ 1, 1/) + UBI = (/NY,NX/) + LBO = (/ 1, 1/) + UBO = (/NY,NX/) + SELECT CASE ( GTYPE ) + !!Li SMC grid shares the settings with rectilinear grid. JGLi12Oct2020 + CASE ( RLGTYPE, SMCTYPE ) + CALL W3CGDM( IJG, FLAGLL, ICLOSE, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, LBO, UBO, REAL(XGRD), REAL(YGRD), & + NFD=NFD, SPHERE=SPHERE, DX=SX, DY=SY, & + DXDP=DXDP, DYDP=DYDP, DXDQ=DXDQ, DYDQ=DYDQ, & + DPDX=DPDX, DPDY=DPDY, DQDX=DQDX, DQDY=DQDY, & + HPFC=HPFAC, HQFC=HQFAC, GSQR=GSQRT, & #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3GNTX) - WRITE(NDST,'(A,2E14.6)')'HPFAC MIN/MAX:',MINVAL(HPFAC),MAXVAL(HPFAC) - WRITE(NDST,'(A,2E14.6)')'HQFAC MIN/MAX:',MINVAL(HQFAC),MAXVAL(HQFAC) - WRITE(NDST,'(A,2E14.6)')'GSQRT MIN/MAX:',MINVAL(GSQRT),MAXVAL(GSQRT) - WRITE(NDST,'(A,2E14.6)')'DXDP MIN/MAX:',MINVAL(DXDP),MAXVAL(DXDP) - WRITE(NDST,'(A,2E14.6)')'DYDP MIN/MAX:',MINVAL(DYDP),MAXVAL(DYDP) - WRITE(NDST,'(A,2E14.6)')'DXDQ MIN/MAX:',MINVAL(DXDQ),MAXVAL(DXDQ) - WRITE(NDST,'(A,2E14.6)')'DYDQ MIN/MAX:',MINVAL(DYDQ),MAXVAL(DYDQ) - WRITE(NDST,'(A,2E14.6)')'DPDX MIN/MAX:',MINVAL(DPDX),MAXVAL(DPDX) - WRITE(NDST,'(A,2E14.6)')'DPDY MIN/MAX:',MINVAL(DPDY),MAXVAL(DPDY) - WRITE(NDST,'(A,2E14.6)')'DQDX MIN/MAX:',MINVAL(DQDX),MAXVAL(DQDX) - WRITE(NDST,'(A,2E14.6)')'DQDY MIN/MAX:',MINVAL(DQDY),MAXVAL(DQDY) - WRITE(NDST,'(A,2E14.6)')'COSA MIN/MAX:',MINVAL(COSA),MAXVAL(COSA) - WRITE (NDST,9003) - DEALLOCATE ( COSA, STAT=ISTAT ) - CHECK_DEALLOC_STATUS ( ISTAT ) -#endif -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3GNTX : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3GNTX : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NAUXGR = ',I10/ & - ' NGRIDS = ',I10/) - 1003 FORMAT (/' *** ERROR W3GNTX : UNSUPPORTED TYPE OF GRID *** '/ & - ' GTYPE = ',I10/) - 1004 FORMAT (/' *** ERROR W3GNTX : ERROR OCCURED IN W3CGDM *** '/ & - ' GTYPE = ',I10/) -! -#if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3GNTX) - 9000 FORMAT (' TEST W3GNTX : MODEL ',I4) - 9001 FORMAT (' TEST W3GNTX : SEARCH OBJECT CREATED') - 9002 FORMAT (' TEST W3GNTX : POINTERS RESET') - 9003 FORMAT (' TEST W3GNTX : GRID ARRAYS CONSTRUCTED') + COSA=COSA, & #endif -!/ -!/ End of W3GNTX ----------------------------------------------------- / -!/ - END SUBROUTINE W3GNTX -!/ ------------------------------------------------------------------- / - SUBROUTINE W3DIMUG ( IMOD, MTRI, MX, COUNTOTA, NNZ, NDSE, NDST ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH-III NOAA/NCEP | -!/ | F.ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 15-Mar-2007 ! -!/ +-----------------------------------+ -!/ -!/ 15-Mar-2007 : Origination. ( version 3.14 ) -!/ 11-May-2015 : Updates to 2-ways nestings for UG ( version 5.08 ) -!/ -! 1. Purpose : -! -! Initialize an individual spatial grid at the proper dimensions. -! -! 2. Method : -! -! Allocate directly into the structure array GRIDS. Note that -! this cannot be done through the pointer alias! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number to point to. -! NDSE Int. I Error output unit number. -! NDST Int. I Test output unit number. -! MX, MTRI, MSEA Like NX, NTRI, NSEA in data structure. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3IOGR Subr. W3IOGRMD Model definition file IO program. -! WW3_GRID Prog. N/A Model set up program. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! - Check on input parameters. -! - Check on previous allocation. -! -! 7. Remarks : -! -! - Grid dimensions apre passed through parameter list and then -! locally stored to assure consistency between allocation and -! data in structure. -! - W3SETG needs to be called after allocation to point to -! proper allocated arrays. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3SERVMD, ONLY: EXTCDE -#ifdef W3_MEMCHECK - USE MallocInfo_m -#endif -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - IMPLICIT NONE -! -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, MTRI, MX, COUNTOTA, NNZ, NDSE, NDST -#ifdef W3_MEMCHECK - type(MallInfo_t) :: mallinfos -#endif - INTEGER :: IAPROC = 1 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 + RC=ISTAT ) + IF ( ISTAT.NE.0 ) THEN + WRITE (NDSE,1004) GTYPE + CALL EXTCDE (4) + END IF + CASE ( CLGTYPE ) + CALL W3CGDM( IJG, FLAGLL, ICLOSE, PTILED, QTILED, & + PRANGE, QRANGE, LBI, UBI, LBO, UBO, REAL(XGRD), REAL(YGRD), & + NFD=NFD, SPHERE=SPHERE, & + DXDP=DXDP, DYDP=DYDP, DXDQ=DXDQ, DYDQ=DYDQ, & + DPDX=DPDX, DPDY=DPDY, DQDX=DQDX, DQDY=DQDY, & + HPFC=HPFAC, HQFC=HQFAC, GSQR=GSQRT, & +#if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3GNTX) + COSA=COSA, & #endif -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3DIMUG') -#endif -! -! -------------------------------------------------------------------- / -! 1. Test input and module status -! - IF ( NGRIDS .EQ. -1 ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -! - IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NGRIDS ) THEN - WRITE (NDSE,1002) IMOD, NGRIDS - CALL EXTCDE (2) - END IF - IF ( GRIDS(IMOD)%GUGINIT ) THEN - WRITE (NDSE,1004) - CALL EXTCDE (4) - END IF -! -#if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMUG) - WRITE (NDST,9000) IMOD, MX, MTRI -#endif -! -! -------------------------------------------------------------------- / -! 2. Allocate arrays -! - ALLOCATE ( GRIDS(IMOD)%TRIGP(3,MTRI), & - GRIDS(IMOD)%SI(MX), & - GRIDS(IMOD)%XGRD(1,MX), & - GRIDS(IMOD)%YGRD(1,MX), & - GRIDS(IMOD)%ZB(MX), & - GRIDS(IMOD)%TRIA(MTRI), & - GRIDS(IMOD)%CROSSDIFF(6,MTRI), & - GRIDS(IMOD)%IEN(MTRI,6), & - GRIDS(IMOD)%LEN(MTRI,3), & - GRIDS(IMOD)%ANGLE(MTRI,3), & - GRIDS(IMOD)%ANGLE0(MTRI,3), & - GRIDS(IMOD)%CCON(MX), & - GRIDS(IMOD)%COUNTCON(MX), & - GRIDS(IMOD)%INDEX_CELL(MX+1), & - GRIDS(IMOD)%IE_CELL(COUNTOTA), & - GRIDS(IMOD)%POS_CELL(COUNTOTA), & - GRIDS(IMOD)%IAA(NX+1), & - GRIDS(IMOD)%JAA(NNZ), & - GRIDS(IMOD)%POSI(3,COUNTOTA), & - GRIDS(IMOD)%I_DIAG(NX), & - GRIDS(IMOD)%JA_IE(3,3,MTRI), & - GRIDS(IMOD)%IOBP(MX), & - GRIDS(IMOD)%IOBPD(NTH,MX), & - GRIDS(IMOD)%IOBDP(MX), & - GRIDS(IMOD)%IOBPA(MX), & - STAT=ISTAT ) - CHECK_ALLOC_STATUS ( ISTAT ) -! - GRIDS(IMOD)%IOBP(:)=1 + RC=ISTAT ) + IF ( ISTAT.NE.0 ) THEN + WRITE (NDSE,1004) GTYPE + CALL EXTCDE (4) + END IF + END SELECT + ! +#if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3GNTX) + WRITE(NDST,'(A,2E14.6)')'HPFAC MIN/MAX:',MINVAL(HPFAC),MAXVAL(HPFAC) + WRITE(NDST,'(A,2E14.6)')'HQFAC MIN/MAX:',MINVAL(HQFAC),MAXVAL(HQFAC) + WRITE(NDST,'(A,2E14.6)')'GSQRT MIN/MAX:',MINVAL(GSQRT),MAXVAL(GSQRT) + WRITE(NDST,'(A,2E14.6)')'DXDP MIN/MAX:',MINVAL(DXDP),MAXVAL(DXDP) + WRITE(NDST,'(A,2E14.6)')'DYDP MIN/MAX:',MINVAL(DYDP),MAXVAL(DYDP) + WRITE(NDST,'(A,2E14.6)')'DXDQ MIN/MAX:',MINVAL(DXDQ),MAXVAL(DXDQ) + WRITE(NDST,'(A,2E14.6)')'DYDQ MIN/MAX:',MINVAL(DYDQ),MAXVAL(DYDQ) + WRITE(NDST,'(A,2E14.6)')'DPDX MIN/MAX:',MINVAL(DPDX),MAXVAL(DPDX) + WRITE(NDST,'(A,2E14.6)')'DPDY MIN/MAX:',MINVAL(DPDY),MAXVAL(DPDY) + WRITE(NDST,'(A,2E14.6)')'DQDX MIN/MAX:',MINVAL(DQDX),MAXVAL(DQDX) + WRITE(NDST,'(A,2E14.6)')'DQDY MIN/MAX:',MINVAL(DQDY),MAXVAL(DQDY) + WRITE(NDST,'(A,2E14.6)')'COSA MIN/MAX:',MINVAL(COSA),MAXVAL(COSA) + WRITE (NDST,9003) + DEALLOCATE ( COSA, STAT=ISTAT ) + CHECK_DEALLOC_STATUS ( ISTAT ) +#endif + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3GNTX : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3GNTX : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NAUXGR = ',I10/ & + ' NGRIDS = ',I10/) +1003 FORMAT (/' *** ERROR W3GNTX : UNSUPPORTED TYPE OF GRID *** '/ & + ' GTYPE = ',I10/) +1004 FORMAT (/' *** ERROR W3GNTX : ERROR OCCURED IN W3CGDM *** '/ & + ' GTYPE = ',I10/) +9000 FORMAT (' TEST W3GNTX : MODEL ',I4) +9001 FORMAT (' TEST W3GNTX : SEARCH OBJECT CREATED') +9002 FORMAT (' TEST W3GNTX : POINTERS RESET') +9003 FORMAT (' TEST W3GNTX : GRID ARRAYS CONSTRUCTED') + !/ + !/ End of W3GNTX ----------------------------------------------------- / + !/ + END SUBROUTINE W3GNTX + !/ ------------------------------------------------------------------- / + SUBROUTINE W3DIMUG ( IMOD, MTRI, MX, COUNTOTA, NNZ, NDSE, NDST ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH-III NOAA/NCEP | + !/ | F.ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 15-Mar-2007 ! + !/ +-----------------------------------+ + !/ + !/ 15-Mar-2007 : Origination. ( version 3.14 ) + !/ 11-May-2015 : Updates to 2-ways nestings for UG ( version 5.08 ) + !/ + ! 1. Purpose : + ! + ! Initialize an individual spatial grid at the proper dimensions. + ! + ! 2. Method : + ! + ! Allocate directly into the structure array GRIDS. Note that + ! this cannot be done through the pointer alias! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number to point to. + ! NDSE Int. I Error output unit number. + ! NDST Int. I Test output unit number. + ! MX, MTRI, MSEA Like NX, NTRI, NSEA in data structure. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3IOGR Subr. W3IOGRMD Model definition file IO program. + ! WW3_GRID Prog. N/A Model set up program. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! - Check on input parameters. + ! - Check on previous allocation. + ! + ! 7. Remarks : + ! + ! - Grid dimensions apre passed through parameter list and then + ! locally stored to assure consistency between allocation and + ! data in structure. + ! - W3SETG needs to be called after allocation to point to + ! proper allocated arrays. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: EXTCDE + USE W3SERVMD, ONLY: STRACE + ! + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD, MTRI, MX, COUNTOTA, NNZ, NDSE, NDST + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IAPROC = 1 + INTEGER, SAVE :: IENT = 0 ! W3_S + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'W3DIMUG') ! W3_S + end if + ! + ! -------------------------------------------------------------------- / + ! 1. Test input and module status + ! + IF ( NGRIDS .EQ. -1 ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NGRIDS ) THEN + WRITE (NDSE,1002) IMOD, NGRIDS + CALL EXTCDE (2) + END IF + IF ( GRIDS(IMOD)%GUGINIT ) THEN + WRITE (NDSE,1004) + CALL EXTCDE (4) + END IF + ! #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMUG) - WRITE (NDST,9001) -#endif -! -!some segmentation troubles can appear, they are related with the allocation of -!normal(1st dimension) and the nesting of the triangulated grid. -! -------------------------------------------------------------------- / -! 3. Point to allocated arrays -! - CALL W3SETG ( IMOD, NDSE, NDST ) + WRITE (NDST,9000) IMOD, MX, MTRI +#endif + ! + ! -------------------------------------------------------------------- / + ! 2. Allocate arrays + ! + ALLOCATE ( GRIDS(IMOD)%TRIGP(3,MTRI), & + GRIDS(IMOD)%SI(MX), & + GRIDS(IMOD)%XGRD(1,MX), & + GRIDS(IMOD)%YGRD(1,MX), & + GRIDS(IMOD)%ZB(MX), & + GRIDS(IMOD)%TRIA(MTRI), & + GRIDS(IMOD)%CROSSDIFF(6,MTRI), & + GRIDS(IMOD)%IEN(MTRI,6), & + GRIDS(IMOD)%LEN(MTRI,3), & + GRIDS(IMOD)%ANGLE(MTRI,3), & + GRIDS(IMOD)%ANGLE0(MTRI,3), & + GRIDS(IMOD)%CCON(MX), & + GRIDS(IMOD)%COUNTCON(MX), & + GRIDS(IMOD)%INDEX_CELL(MX+1), & + GRIDS(IMOD)%IE_CELL(COUNTOTA), & + GRIDS(IMOD)%POS_CELL(COUNTOTA), & + GRIDS(IMOD)%IAA(NX+1), & + GRIDS(IMOD)%JAA(NNZ), & + GRIDS(IMOD)%POSI(3,COUNTOTA), & + GRIDS(IMOD)%I_DIAG(NX), & + GRIDS(IMOD)%JA_IE(3,3,MTRI), & + GRIDS(IMOD)%IOBP(MX), & + GRIDS(IMOD)%IOBPD(NTH,MX), & + GRIDS(IMOD)%IOBDP(MX), & + GRIDS(IMOD)%IOBPA(MX), & + STAT=ISTAT ) + CHECK_ALLOC_STATUS ( ISTAT ) + ! + GRIDS(IMOD)%IOBP(:)=1 #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMUG) - WRITE (NDST,9002) -#endif -! -! -------------------------------------------------------------------- / -! 4. Update counters in grid -! Note that in the case of lon/lat grids, these quantities do not -! include the spherical coordinate metric (SPHERE=.FALSE.). -! - NTRI = MTRI - COUNTOT=COUNTOTA - GRIDS(IMOD)%GUGINIT = .TRUE. + WRITE (NDST,9001) +#endif + ! + !some segmentation troubles can appear, they are related with the allocation of + !normal(1st dimension) and the nesting of the triangulated grid. + ! -------------------------------------------------------------------- / + ! 3. Point to allocated arrays + ! + CALL W3SETG ( IMOD, NDSE, NDST ) #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMUG) - WRITE (NDST,9003) -#endif - RETURN -! -! Formats -! - 1001 FORMAT (/' *** ERROR W3DIMUG : GRIDS NOT INITIALIZED *** '/ & - ' RUN W3NMOD FIRST '/) - 1002 FORMAT (/' *** ERROR W3DIMUG : ILLEGAL MODEL NUMBER *** '/ & - ' IMOD = ',I10/ & - ' NGRIDS = ',I10/) - 1004 FORMAT (/' *** ERROR W3DIMUG : ARRAY(S) ALREADY ALLOCATED *** ') + WRITE (NDST,9002) +#endif + ! + ! -------------------------------------------------------------------- / + ! 4. Update counters in grid + ! Note that in the case of lon/lat grids, these quantities do not + ! include the spherical coordinate metric (SPHERE=.FALSE.). + ! + NTRI = MTRI + COUNTOT=COUNTOTA + GRIDS(IMOD)%GUGINIT = .TRUE. #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3DIMUG) - 9000 FORMAT (' TEST W3DIMUG: MODEL ',I4,' DIM. AT ',2I5,I7) - 9001 FORMAT (' TEST W3DIMUG : ARRAYS ALLOCATED') - 9002 FORMAT (' TEST W3DIMUG : POINTERS RESET') - 9003 FORMAT (' TEST W3DIMUG : DIMENSIONS STORED') -#endif -!/ -!/ End of W3DIMUG ----------------------------------------------------- / -!/ - END SUBROUTINE W3DIMUG -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SETREF -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 13-Nov-2013 | -!/ +-----------------------------------+ -!/ -!/ 13-Nov-2013 : Origination. ( version 4.13 ) -!/ -! 1. Purpose : -! -! Update reflection directions at shoreline. -! -! 2. Method : -! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! None -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! WW3_GRID Prog. WW3_GRID Grid preprocessor -! W3ULEV Subr. W3UPDTMD Water level update -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -#ifdef W3_S - USE W3SERVMD, ONLY : STRACE -#endif -! - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER :: ISEA, IX, IY, IXY, IXN, IXP, IYN, IYP - INTEGER :: J, K, NEIGH1(0:7) - INTEGER :: ILEV, NLEV -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif + WRITE (NDST,9003) +#endif + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3DIMUG : GRIDS NOT INITIALIZED *** '/ & + ' RUN W3NMOD FIRST '/) +1002 FORMAT (/' *** ERROR W3DIMUG : ILLEGAL MODEL NUMBER *** '/ & + ' IMOD = ',I10/ & + ' NGRIDS = ',I10/) +1004 FORMAT (/' *** ERROR W3DIMUG : ARRAY(S) ALREADY ALLOCATED *** ') +9000 FORMAT (' TEST W3DIMUG: MODEL ',I4,' DIM. AT ',2I5,I7) +9001 FORMAT (' TEST W3DIMUG : ARRAYS ALLOCATED') +9002 FORMAT (' TEST W3DIMUG : POINTERS RESET') +9003 FORMAT (' TEST W3DIMUG : DIMENSIONS STORED') + !/ + !/ End of W3DIMUG ----------------------------------------------------- / + !/ + END SUBROUTINE W3DIMUG + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SETREF + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 13-Nov-2013 | + !/ +-----------------------------------+ + !/ + !/ 13-Nov-2013 : Origination. ( version 4.13 ) + !/ + ! 1. Purpose : + ! + ! Update reflection directions at shoreline. + ! + ! 2. Method : + ! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! None + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! WW3_GRID Prog. WW3_GRID Grid preprocessor + ! W3ULEV Subr. W3UPDTMD Water level update + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + USE W3SERVMD, ONLY : STRACE ! W3_S + ! + !/ + !/ ------------------------------------------------------------------- / + !/ + INTEGER :: ISEA, IX, IY, IXY, IXN, IXP, IYN, IYP + INTEGER :: J, K, NEIGH1(0:7) + INTEGER :: ILEV, NLEV + INTEGER, SAVE :: IENT = 0 ! W3_S - REAL :: TRIX(NY*NX), TRIY(NY*NX), DX, DY, & - COSAVG, SINAVG, THAVG, ANGLES(0:7), CLAT -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3SETREF') -#endif -! -! 1. Preparations --------------------------------------------------- * -! + REAL :: TRIX(NY*NX), TRIY(NY*NX), DX, DY, & + COSAVG, SINAVG, THAVG, ANGLES(0:7), CLAT + !/ + !/ ------------------------------------------------------------------- / + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'W3SETREF') + end if + ! + ! 1. Preparations --------------------------------------------------- * + ! #ifdef W3_REF1 - IF (REFPARS(2).GT.0) RREF(2)=.TRUE. - IF (REFPARS(3).GT.0) RREF(3)=.TRUE. - IF (REFPARS(4).GT.0) RREF(4)=.TRUE. + IF (REFPARS(2).GT.0) RREF(2)=.TRUE. + IF (REFPARS(3).GT.0) RREF(3)=.TRUE. + IF (REFPARS(4).GT.0) RREF(4)=.TRUE. #endif -! + ! #ifdef W3_REF1 - DO IY=2, NY-1 - DO IX=2, NX-1 + DO IY=2, NY-1 + DO IX=2, NX-1 IF (REFPARS(1).GT.0) RREF(1)=.TRUE. -!No reflection from artificial island on pole. + !No reflection from artificial island on pole. IF (FLAGLL.AND.(YGRD(IY,IX).GT.85)) RREF(1)=.FALSE. IF (MAPSTA(IY,IX).GT.0) THEN -! -! Prepares for reflection from subgrid islands -! - IF (RREF(2)) & - REFLC(2,MAPFS(IY,IX))= MAX((1. - TRNX(IY,IX)),(1.-TRNY(IY,IX))) -! -! Prepares for iceberg reflections -! - IF (RREF(4)) & - REFLC(4,MAPFS(IY,IX))= 1. -! -! resolved shoreline reflection -! - IF (RREF(1)) THEN - REFLC(1, MAPFS(IY,IX)) = 0. - REFLD(1:6,MAPFS(IY,IX)) = 0 -! -! Search for neighboring coastline. 3 2 1 -! around X. These are the neighbors of X: 4 X 0 -! 5 6 7 -! -! - NEIGH1(0)=8*MAPST2(IY,IX+1)+MAPSTA(IY,IX+1) - NEIGH1(1:3)=8*MAPST2(IY+1,IX+1:IX-1:-1)+MAPSTA(IY+1,IX+1:IX-1:-1) - NEIGH1(4)=8*MAPST2(IY,IX-1)+MAPSTA(IY,IX-1) - NEIGH1(5:7)=8*MAPST2(IY-1,IX-1:IX+1)+MAPSTA(IY-1,IX-1:IX+1) -! -! if one of the surrounding points is land: determines directions ... -! - IF (MINVAL(ABS(NEIGH1)).EQ.0) THEN - IF ( FLAGLL ) THEN - CLAT = COS(YGRD(IY,IX)*DERA) - ELSE - CLAT = 1. - END IF - ANGLES(0)= ATAN2(DYDP(IY,IX),DXDP(IY,IX)*CLAT) - ANGLES(1)= ATAN2(DYDP(IY,IX)+DYDQ(IY,IX),(DXDP(IY,IX)+DXDQ(IY,IX))*CLAT) - ANGLES(2)= ATAN2(DYDQ(IY,IX),DXDQ(IY,IX)*CLAT) - ANGLES(3)= ATAN2(DYDQ(IY,IX)-DYDP(IY,IX),(DXDQ(IY,IX)-DXDP(IY,IX))*CLAT) - ANGLES(4:7)= ANGLES(0:3)+PI - IF ((NEIGH1(0).GE.1).AND.(NEIGH1(4).GE.1)) THEN - REFLD(3,MAPFS(IY,IX))=0 - ELSE - IF ((NEIGH1(0).GE.1).OR.(NEIGH1(4).GE.1)) REFLD(3,MAPFS(IY,IX))=1 - END IF - IF ((NEIGH1(2).EQ.1).AND.(NEIGH1(6).GE.1)) THEN - REFLD(4,MAPFS(IY,IX))=0 - ELSE - IF ((NEIGH1(2).GE.1).OR.(NEIGH1(6).GE.1)) REFLD(4,MAPFS(IY,IX))=1 - END IF -! -! Looks for a locally straight coast in all 8 orientations -! - J=0 - REFLD(1,MAPFS(IY,IX))=0 - COSAVG=0 - SINAVG=0 -! Shore angle is corrected for grid rotation in w3ref1md.ftn with REFLD(5:6,MAPFS(IY,IX)) - REFLD(5,MAPFS(IY,IX))= MOD(NTH+NINT(ANGLES(0)/TPI*NTH),NTH) - REFLD(6,MAPFS(IY,IX))= MOD(NTH+NINT((ANGLES(2)/TPI-0.25)*NTH),NTH) + ! + ! Prepares for reflection from subgrid islands + ! + IF (RREF(2)) & + REFLC(2,MAPFS(IY,IX))= MAX((1. - TRNX(IY,IX)),(1.-TRNY(IY,IX))) + ! + ! Prepares for iceberg reflections + ! + IF (RREF(4)) & + REFLC(4,MAPFS(IY,IX))= 1. + ! + ! resolved shoreline reflection + ! + IF (RREF(1)) THEN + REFLC(1, MAPFS(IY,IX)) = 0. + REFLD(1:6,MAPFS(IY,IX)) = 0 + ! + ! Search for neighboring coastline. 3 2 1 + ! around X. These are the neighbors of X: 4 X 0 + ! 5 6 7 + ! + ! + NEIGH1(0)=8*MAPST2(IY,IX+1)+MAPSTA(IY,IX+1) + NEIGH1(1:3)=8*MAPST2(IY+1,IX+1:IX-1:-1)+MAPSTA(IY+1,IX+1:IX-1:-1) + NEIGH1(4)=8*MAPST2(IY,IX-1)+MAPSTA(IY,IX-1) + NEIGH1(5:7)=8*MAPST2(IY-1,IX-1:IX+1)+MAPSTA(IY-1,IX-1:IX+1) + ! + ! if one of the surrounding points is land: determines directions ... + ! + IF (MINVAL(ABS(NEIGH1)).EQ.0) THEN + IF ( FLAGLL ) THEN + CLAT = COS(YGRD(IY,IX)*DERA) + ELSE + CLAT = 1. + END IF + ANGLES(0)= ATAN2(DYDP(IY,IX),DXDP(IY,IX)*CLAT) + ANGLES(1)= ATAN2(DYDP(IY,IX)+DYDQ(IY,IX),(DXDP(IY,IX)+DXDQ(IY,IX))*CLAT) + ANGLES(2)= ATAN2(DYDQ(IY,IX),DXDQ(IY,IX)*CLAT) + ANGLES(3)= ATAN2(DYDQ(IY,IX)-DYDP(IY,IX),(DXDQ(IY,IX)-DXDP(IY,IX))*CLAT) + ANGLES(4:7)= ANGLES(0:3)+PI + IF ((NEIGH1(0).GE.1).AND.(NEIGH1(4).GE.1)) THEN + REFLD(3,MAPFS(IY,IX))=0 + ELSE + IF ((NEIGH1(0).GE.1).OR.(NEIGH1(4).GE.1)) REFLD(3,MAPFS(IY,IX))=1 + END IF + IF ((NEIGH1(2).EQ.1).AND.(NEIGH1(6).GE.1)) THEN + REFLD(4,MAPFS(IY,IX))=0 + ELSE + IF ((NEIGH1(2).GE.1).OR.(NEIGH1(6).GE.1)) REFLD(4,MAPFS(IY,IX))=1 + END IF + ! + ! Looks for a locally straight coast in all 8 orientations + ! + J=0 + REFLD(1,MAPFS(IY,IX))=0 + COSAVG=0 + SINAVG=0 + ! Shore angle is corrected for grid rotation in w3ref1md.ftn with REFLD(5:6,MAPFS(IY,IX)) + REFLD(5,MAPFS(IY,IX))= MOD(NTH+NINT(ANGLES(0)/TPI*NTH),NTH) + REFLD(6,MAPFS(IY,IX))= MOD(NTH+NINT((ANGLES(2)/TPI-0.25)*NTH),NTH) #endif #ifdef W3_REFT - IF (IY.EQ.4) THEN + IF (IY.EQ.4) THEN WRITE(6,*) 'POINT (IX,IY):',IX,IY - WRITE(6,*) 'REFT:',NEIGH1(3),NEIGH1(2), NEIGH1(1) - WRITE(6,*) 'REFT:',NEIGH1(4),1, NEIGH1(0) + WRITE(6,*) 'REFT:',NEIGH1(3),NEIGH1(2), NEIGH1(1) + WRITE(6,*) 'REFT:',NEIGH1(4),1, NEIGH1(0) WRITE(6,*) 'REFT:',NEIGH1(5:7) - WRITE(6,*) 'ANG:',ANGLES(3)*RADE,ANGLES(2)*RADE, ANGLES(1)*RADE + WRITE(6,*) 'ANG:',ANGLES(3)*RADE,ANGLES(2)*RADE, ANGLES(1)*RADE WRITE(6,*) 'ANG:',ANGLES(4)*RADE,1, ANGLES(0) *RADE WRITE(6,*) 'ANG:',ANGLES(5:7)*RADE WRITE(6,*) 'REFT:',XGRD(IY+1,IX-1:IX+1), YGRD(IY+1,IX-1:IX+1) WRITE(6,*) 'REFT:',XGRD(IY,IX-1:IX+1) , YGRD(IY,IX-1:IX+1) WRITE(6,*) 'REFT:',XGRD(IY-1,IX-1:IX+1), YGRD(IY-1,IX-1:IX+1) WRITE(6,*) 'REFLD:',REFLD(3:6,MAPFS(IY,IX)) - ENDIF + ENDIF #endif #ifdef W3_REF1 - DO K=0,7 - IF (NEIGH1(K).EQ.0.AND.NEIGH1(MOD(K+7,8)).EQ.0 & - .AND.NEIGH1(MOD(K+1,8)).EQ.0 & - .AND.NEIGH1(MOD(K+4,8)).NE.0) THEN - REFLC(1,MAPFS(IY,IX))= REFPARS(1) -! -! Defines direction index for specular reflection (normal to coast) -! -! for example, if we have this layout 1 1 0 -! (NB: 1 is sea, 0 is land) 1 X 0 -! 1 1 0 -! -! then there is only a coastline detection for K=0, giving J=1 -! and the final result will be REFLD(1,MAPFS(IY,IX))=1 -! Namely, the direction TH(REFLD) is the direction pointing INTO the coast -! - REFLD(2,MAPFS(IY,IX))= 2 - COSAVG=COSAVG+COS(ANGLES(K)) !ECOS(1+(K*NTH)/8) - SINAVG=SINAVG+SIN(ANGLES(K)) !ESIN(1+(K*NTH)/8) - J=J+1 - ENDIF - END DO - IF (J.GT.0) THEN - IF (J.GT.1) REFLD(2,MAPFS(IY,IX))= 1 - THAVG=ATAN2(SINAVG,COSAVG) + DO K=0,7 + IF (NEIGH1(K).EQ.0.AND.NEIGH1(MOD(K+7,8)).EQ.0 & + .AND.NEIGH1(MOD(K+1,8)).EQ.0 & + .AND.NEIGH1(MOD(K+4,8)).NE.0) THEN + REFLC(1,MAPFS(IY,IX))= REFPARS(1) + ! + ! Defines direction index for specular reflection (normal to coast) + ! + ! for example, if we have this layout 1 1 0 + ! (NB: 1 is sea, 0 is land) 1 X 0 + ! 1 1 0 + ! + ! then there is only a coastline detection for K=0, giving J=1 + ! and the final result will be REFLD(1,MAPFS(IY,IX))=1 + ! Namely, the direction TH(REFLD) is the direction pointing INTO the coast + ! + REFLD(2,MAPFS(IY,IX))= 2 + COSAVG=COSAVG+COS(ANGLES(K)) !ECOS(1+(K*NTH)/8) + SINAVG=SINAVG+SIN(ANGLES(K)) !ESIN(1+(K*NTH)/8) + J=J+1 + ENDIF + END DO + IF (J.GT.0) THEN + IF (J.GT.1) REFLD(2,MAPFS(IY,IX))= 1 + THAVG=ATAN2(SINAVG,COSAVG) #endif #if defined(TEST_W3GDATMD) || defined(TEST_W3GDATMD_W3SETREF) #ifdef W3_REF1 - !WRITE (6,*) 'COASTAL REFLECTION:',IX,IY, & - !SINAVG,COSAVG,THAVG/TPI,NINT(THAVG/TPI*NTH),MOD(NTH+NINT(THAVG/TPI*NTH),NTH) + !WRITE (6,*) 'COASTAL REFLECTION:',IX,IY, & + !SINAVG,COSAVG,THAVG/TPI,NINT(THAVG/TPI*NTH),MOD(NTH+NINT(THAVG/TPI*NTH),NTH) #endif #endif #ifdef W3_REF1 - REFLD(1,MAPFS(IY,IX))=1+MOD(NTH+NINT(THAVG/TPI*NTH),NTH) - ELSE + REFLD(1,MAPFS(IY,IX))=1+MOD(NTH+NINT(THAVG/TPI*NTH),NTH) + ELSE -! 1 1 1 -! Looks for mild corners like 1 1 1 -! 1 0 0 - DO K=0,7 - IF (NEIGH1(K).EQ.0.AND.NEIGH1(MOD(K+1,8)).EQ.0 & - .AND.NEIGH1(MOD(K+4,8)).NE.0) THEN - REFLC(1,MAPFS(IY,IX))= REFPARS(1) - REFLD(1,MAPFS(IY,IX))= 1+MOD((K*NTH+(K+1)*NTH)/16,NTH) - REFLD(2,MAPFS(IY,IX))= 1 - ENDIF - END DO -! 1 1 1 1 1 1 -! Looks for sharp corners like 1 1 1 but not diagonals like 1 1 1 -! 1 0 1 1 1 0 - IF (REFLC(1,MAPFS(IY,IX)).LE.0) THEN - DO K=0,7,2 - IF ( NEIGH1(K).EQ.0.AND.NEIGH1(MOD(K+4,8)).NE.0) THEN - REFLC(1,MAPFS(IY,IX))= REFPARS(1) - REFLD(1,MAPFS(IY,IX))= 1+(K*NTH)/8 - REFLD(2,MAPFS(IY,IX))= 0 - !WRITE(6,*) 'NEIGH3:',IX,IY,K,NEIGH1,K*(NTH/8) - END IF + ! 1 1 1 + ! Looks for mild corners like 1 1 1 + ! 1 0 0 + DO K=0,7 + IF (NEIGH1(K).EQ.0.AND.NEIGH1(MOD(K+1,8)).EQ.0 & + .AND.NEIGH1(MOD(K+4,8)).NE.0) THEN + REFLC(1,MAPFS(IY,IX))= REFPARS(1) + REFLD(1,MAPFS(IY,IX))= 1+MOD((K*NTH+(K+1)*NTH)/16,NTH) + REFLD(2,MAPFS(IY,IX))= 1 + ENDIF END DO - END IF - END IF -! End of test if surrounding point is land + ! 1 1 1 1 1 1 + ! Looks for sharp corners like 1 1 1 but not diagonals like 1 1 1 + ! 1 0 1 1 1 0 + IF (REFLC(1,MAPFS(IY,IX)).LE.0) THEN + DO K=0,7,2 + IF ( NEIGH1(K).EQ.0.AND.NEIGH1(MOD(K+4,8)).NE.0) THEN + REFLC(1,MAPFS(IY,IX))= REFPARS(1) + REFLD(1,MAPFS(IY,IX))= 1+(K*NTH)/8 + REFLD(2,MAPFS(IY,IX))= 0 + !WRITE(6,*) 'NEIGH3:',IX,IY,K,NEIGH1,K*(NTH/8) + END IF + END DO + END IF + END IF + ! End of test if surrounding point is land END IF #endif #ifdef W3_REFT - IF (REFLC(1,MAPFS(IY,IX)).GT.0) THEN - WRITE (6,*) 'COAST DIRECTION AT POINT:',IX,IY,' IS ', & - REFLD(:,MAPFS(IY,IX)),TH(REFLD(1,MAPFS(IY,IX)))*360/TPI - ENDIF + IF (REFLC(1,MAPFS(IY,IX)).GT.0) THEN + WRITE (6,*) 'COAST DIRECTION AT POINT:',IX,IY,' IS ', & + REFLD(:,MAPFS(IY,IX)),TH(REFLD(1,MAPFS(IY,IX)))*360/TPI + ENDIF #endif #ifdef W3_REF1 -! End of test if local point is sea - END IF - END IF - END DO - END DO -#endif -! - RETURN -! -! Formats -! -!/ -!/ End of W3SETREF ----------------------------------------------------- / -!/ - END SUBROUTINE W3SETREF - -!/ -!/ End of module W3GDATMD -------------------------------------------- / -!/ - END MODULE W3GDATMD + ! End of test if local point is sea + END IF + END IF + END DO + END DO +#endif + ! + RETURN + ! + ! Formats + ! + !/ + !/ End of W3SETREF ----------------------------------------------------- / + !/ + END SUBROUTINE W3SETREF + + !/ + !/ End of module W3GDATMD -------------------------------------------- / + !/ +END MODULE W3GDATMD diff --git a/model/src/w3initmd.F90 b/model/src/w3initmd.F90 index b19f2bc66c..5a2aa57137 100644 --- a/model/src/w3initmd.F90 +++ b/model/src/w3initmd.F90 @@ -1,7189 +1,5694 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3INITMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 28-Dec-2004 : Origination (out of W3WAVEMD). ( version 3.06 ) -!/ Multiple grid version. -!/ 03-Jan-2005 : Add US2x to MPI communication. ( version 3.06 ) -!/ 04-Jan-2005 : Add grid output flags to W3INIT. ( version 3.06 ) -!/ 07-Feb-2005 : Combined vs. separate test output. ( version 3.07 ) -!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) -!/ 21-Jul-2005 : Add output fields. ( version 3.07 ) -!/ 09-Nov-2005 : Drying out of points added. ( version 3.08 ) -!/ 13-Jun-2006 : Splitting STORE in G/SSTORE. ( version 3.09 ) -!/ 26-Jun-2006 : adding wiring for output type 6. ( version 3.09 ) -!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) -!/ 02-Aug-2006 : Adding W3MPIP. ( version 3.10 ) -!/ 02-Nov-2006 : Adding partitioning options. ( version 3.10 ) -!/ 11-Jan-2007 : Updating IAPPRO computation. ( version 3.10 ) -!/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) -!/ Add user-defined field data. -!/ 01-May-2007 : Move O7a output to W3IOPP. ( version 3.11 ) -!/ 08-May-2007 : Starting from calm as an option. ( version 3.11 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) -!/ 29-Feb-2008 : Add NEC compiler directives. ( version 3.13 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 23-Jul-2009 : Implement unstructured grids ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 02-Sep.2012 : Set up for > 999 test files. ( version 4.10 ) -!/ Reset UST initialization. -!/ 03-Sep-2012 : Switch test file on/off (TSTOUT) ( version 4.10 ) -!/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) -!/ 30-Sep-2012 : Implemetation of tidal constituents ( version 4.09 ) -!/ 07-Dec-2012 : Initialize UST non-zero. ( version 4.11 ) -!/ 12-Dec-2012 : Changes for SMC grid. JG_Li ( version 4.11 ) -!/ 26-Dec-2012 : Modify field output MPI for new ( version 4.11 ) -!/ structure and smaller memory footprint. -!/ 02-Jul-2013 : Bug fix MPI_FLOAT -> MPI_REAL. ( version 4.11 ) -!/ 10-Oct-2013 : CG and WN values at DMIN for ISEA=0 ( version 4.12 ) -!/ 14-Nov-2013 : Remove UST(DIR) initialization. ( version 4.13 ) -!/ 15-Dec-2013 : Adds fluxes to ice ( version 5.01 ) -!/ 01-May-2017 : Adds directional MSS parameters ( version 6.04 ) -!/ 05-Jun-2018 : Adds PDLIB/MEMCHECK/DEBUG ( version 6.04 ) -!/ 21-Aug-2018 : Add WBT parameter ( version 6.06 ) -!/ 26-Aug-2018 : UOST (Mentaschi et al. 2015, 2018) ( version 6.06 ) -!/ 25-Sep-2020 : Extra fields for coupling restart ( version 7.10 ) -!/ 22-Mar-2021 : Extra coupling fields ( version 7.13 ) -!/ 22-Jun-2021 : GKE NL5 (Q. Liu) ( version 7.13 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -!/ Note: Changes in version numbers not logged above. -!/ -! 1. Purpose : -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! CRITOS R.P. Public Critical percentage of resources used -! for output to trigger warning. -! WWVER C*10 Public Model version number. -! SWITCHES C*256 Public switches taken from bin/switch -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3INIT Subr. Public Wave model initialization. -! W3MPII Subr. Public Initialize MPI data transpose. -! W3MPIO Subr. Public Initialize MPI output gathering. -! W3MPIP Subr. Public Initialize MPI point output gathering. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! See subroutine documentation. -! -! 5. Remarks : -! -! 6. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! !/MPI Id. -! -! !/S Enable subroutine tracing. -! !/Tn Enable test output. -! !/MPIT Enable test output (MPI). -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -!/ - REAL, PARAMETER :: CRITOS = 15. - CHARACTER(LEN=10), PARAMETER :: WWVER = '7.14 ' - CHARACTER(LEN=512), PARAMETER :: SWITCHES = & - __WW3_SWITCHES__ -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT & - , FLGRD, & - FLGR2, FLGD, FLG2, NPT, XPT, YPT, PNAMES, & - IPRT, PRTFRM, MPI_COMM, FLAGSTIDEIN) +MODULE W3INITMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 28-Dec-2004 : Origination (out of W3WAVEMD). ( version 3.06 ) + !/ Multiple grid version. + !/ 03-Jan-2005 : Add US2x to MPI communication. ( version 3.06 ) + !/ 04-Jan-2005 : Add grid output flags to W3INIT. ( version 3.06 ) + !/ 07-Feb-2005 : Combined vs. separate test output. ( version 3.07 ) + !/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) + !/ 21-Jul-2005 : Add output fields. ( version 3.07 ) + !/ 09-Nov-2005 : Drying out of points added. ( version 3.08 ) + !/ 13-Jun-2006 : Splitting STORE in G/SSTORE. ( version 3.09 ) + !/ 26-Jun-2006 : adding wiring for output type 6. ( version 3.09 ) + !/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) + !/ 02-Aug-2006 : Adding W3MPIP. ( version 3.10 ) + !/ 02-Nov-2006 : Adding partitioning options. ( version 3.10 ) + !/ 11-Jan-2007 : Updating IAPPRO computation. ( version 3.10 ) + !/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) + !/ Add user-defined field data. + !/ 01-May-2007 : Move O7a output to W3IOPP. ( version 3.11 ) + !/ 08-May-2007 : Starting from calm as an option. ( version 3.11 ) + !/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) + !/ 29-Feb-2008 : Add NEC compiler directives. ( version 3.13 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 23-Jul-2009 : Implement unstructured grids ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 02-Sep.2012 : Set up for > 999 test files. ( version 4.10 ) + !/ Reset UST initialization. + !/ 03-Sep-2012 : Switch test file on/off (TSTOUT) ( version 4.10 ) + !/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) + !/ 30-Sep-2012 : Implemetation of tidal constituents ( version 4.09 ) + !/ 07-Dec-2012 : Initialize UST non-zero. ( version 4.11 ) + !/ 12-Dec-2012 : Changes for SMC grid. JG_Li ( version 4.11 ) + !/ 26-Dec-2012 : Modify field output MPI for new ( version 4.11 ) + !/ structure and smaller memory footprint. + !/ 02-Jul-2013 : Bug fix MPI_FLOAT -> MPI_REAL. ( version 4.11 ) + !/ 10-Oct-2013 : CG and WN values at DMIN for ISEA=0 ( version 4.12 ) + !/ 14-Nov-2013 : Remove UST(DIR) initialization. ( version 4.13 ) + !/ 15-Dec-2013 : Adds fluxes to ice ( version 5.01 ) + !/ 01-May-2017 : Adds directional MSS parameters ( version 6.04 ) + !/ 05-Jun-2018 : Adds PDLIB/MEMCHECK/DEBUG ( version 6.04 ) + !/ 21-Aug-2018 : Add WBT parameter ( version 6.06 ) + !/ 26-Aug-2018 : UOST (Mentaschi et al. 2015, 2018) ( version 6.06 ) + !/ 25-Sep-2020 : Extra fields for coupling restart ( version 7.10 ) + !/ 22-Mar-2021 : Extra coupling fields ( version 7.13 ) + !/ 22-Jun-2021 : GKE NL5 (Q. Liu) ( version 7.13 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + !/ Note: Changes in version numbers not logged above. + !/ + ! 1. Purpose : + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! CRITOS R.P. Public Critical percentage of resources used + ! for output to trigger warning. + ! WWVER C*10 Public Model version number. + ! SWITCHES C*256 Public switches taken from bin/switch + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3INIT Subr. Public Wave model initialization. + ! W3MPII Subr. Public Initialize MPI data transpose. + ! W3MPIO Subr. Public Initialize MPI output gathering. + ! W3MPIP Subr. Public Initialize MPI point output gathering. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! See subroutine documentation. + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! !/MPI Id. + ! + ! !/S Enable subroutine tracing. + ! !/Tn Enable test output. + ! !/MPIT Enable test output (MPI). + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + use wav_shr_flags -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 03-Sep-2012 | -!/ +-----------------------------------+ -!/ -!/ 17-Mar-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Major changes to logistics. -!/ 14-Feb-2000 : Exact-NL added. ( version 2.01 ) -!/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) -!/ 24-Jan-2002 : Zero time step for data ass. ( version 2.17 ) -!/ 18-Feb-2002 : Point output diagnostics added. ( version 2.18 ) -!/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) -!/ 20-Aug-2003 : Output server options added. ( version 3.04 ) -!/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ Taken out of W3WAVE. -!/ 04-Jan-2005 : Add grid output flags to par list. ( version 3.06 ) -!/ 07-Feb-2005 : Combined vs. separate test output. ( version 3.07 ) -!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) -!/ 09-Nov-2005 : Drying out of points added. ( version 3.08 ) -!/ 26-Jun-2006 : adding wiring for output type 6. ( version 3.09 ) -!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 02-Aug-2006 : Adding W3MPIP. ( version 3.10 ) -!/ 02-Nov-2006 : Adding partitioning options. ( version 3.10 ) -!/ 11-Jan-2007 : Updating IAPPRO computation. ( version 3.10 ) -!/ 01-May-2007 : Move O7a output to W3IOPP. ( version 3.11 ) -!/ 08-May-2007 : Starting from calm as an option. ( version 3.11 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 -!/ 13-Sep-2009 : Add coupling option ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 29-Oct-2010 : Implement unstructured grids ( version 3.14.1 ) -!/ (A. Roland and F. Ardhuin) -!/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to -!/ specify index closure for a grid. ( version 3.14 ) -!/ (T. J. Campbell, NRL) -!/ 02-Sep.2012 : Set up for > 999 test files. ( version 4.10 ) -!/ 03-Sep-2012 : Switch test file on/off (TSTOUT) ( version 4.10 ) -!/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) -!/ -! 1. Purpose : -! -! Initialize WAVEWATCH III. -! -! 2. Method : -! -! Initialize data structure and wave fields from data files. -! Initialize grid from local and instantaneous data. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number. -! FEXT Char I Extension of data files. -! MDS I.A. I Array with dataset numbers (see below), -! saved as NDS in W3ODATMD. -! 1: General output unit number ("log file"). -! 2: Error output unit number. -! 3: Test output unit number. -! 4: "screen", i.e., direct output location, -! can be the screen or the output file of -! the shell. -! 5: Model definition file unit number. -! 6: Restart file unit number. -! 7: Grid output file unit number. -! 8: Point output file unit number. -! 9: Input boundary data file unit number. -! 10: Output boundary data file unit number -! (first). -! 11: Track information file unit number. -! 12: Track output file unit number. -! MTRACE I.A. I Array with subroutine tracing information. -! 1: Output unit number for trace. -! 2: Maximum number of trace prints. -! ODAT I.A. I Output data, five parameters per output type -! 1-5 Data for OTYPE = 1; gridded fields. -! 1 YYYMMDD for first output. -! 2 HHMMSS for first output. -! 3 Output interval in seconds. -! 4 YYYMMDD for last output. -! 5 HHMMSS for last output. -! 6-10 Id. for OTYPE = 2; point output. -! 11-15 Id. for OTYPE = 3; track point output. -! 16-20 Id. for OTYPE = 4; restart files. -! 21-25 Id. for OTYPE = 5; boundary data. -! 31-35 Id. for OTYPE = 7; coupling data. -! 36-40 Id. for OTYPE = 8; second restart file -! FLGRD L.A. I Flags for gridded output. -! FLGR2 L.A. I Flags for coupling output. -! NPT Int. I Number of output points -! X/YPT R.A. I Coordinates of output points. -! PNAMES C.A. I Output point names. -! IPRT I.A. I Partitioning grid info. -! PRTFRM I.A. I Partitioning format flag. -! MPI_COMM Int. I MPI communicator to be used for model. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETG Subr. W3GDATMD Point to data structure. -! W3SETW Subr. W3WDATMD Point to data structure. -! W3DIMW Subr. Id. Set array sizes in data structure. -! W3SETA Subr. W3ADATMD Point to data structure. -! W3DIMA Subr. Id. Set array sizes in data structure. -! W3SETI Subr. W3IDATMD Point to data structure. -! W3DIMI Subr. Id. Set array sizes in data structure. -! W3SETO Subr. W3ODATMD Point to data structure. -! W3DMO5 Subr. Id. Set array sizes in data structure. -! ITRACE Subr. W3SERVMD Subroutine tracing initialization. -! STRACE Subr. Id. Subroutine tracing. -! EXTCDE Subr. Id. Program abort. -! WWDATE Subr. Id. System date. -! WWTIME Subr. Id. System time. -! DSEC21 Func. W3TIMEMD Compute time difference. -! TICK21 Func. Id. Advance the clock. -! STME21 Func. Id. Print the time readable. -! PRTBLK Func. W3ARRYMD Print plot of array. -! W3IOGR Subr. W3IOGRMD Read/write model definition file. -! W3IORS Subr. W3IORSMD Read/write restart file. -! W3IOPP Subr. W3IOPOMD Preprocess point output. -! CALL MPI_COMM_SIZE, CALL MPI_COMM_RANK -! Subr. mpif.h Standard MPI routines. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Any program shell or integrated model which uses WAVEWATCH III. -! -! 6. Error messages : -! -! On opening of log file only. Other error messages are generated -! by W3IOGR and W3IORS. -! -! 7. Remarks : -! -! - The log file is called 'log.FEXT', where FEXT is passed to -! the routine. -! - The test output file is called 'test.FEXT' in shared memory -! version or testNNN.FEXT in distributed memory version. -! - A water level and ice coverage are transferred with the -! restart file. To assure consistency within the model, the -! water level and ice coverage are re-evaluated at the 0th -! time step in the actual wave model routine. -! - When running regtests in cases where disk is non-local -! (i.e. NFS used), there can be a huge improvment in compute -! time by using /var/tmp/ for log files. -! See commented line at "OPEN (MDS(1),FILE=..." -! -! 8. Structure : -! -! ---------------------------------------------------- -! 1. Set-up of idata structures and I/O. -! a Point to proper data structures. -! b Number of processors and processor number. -! c Open files. -! d Dataset unit numbers -! e Subroutine tracing -! f Initial and test outputs -! 2. Model definition. -! a Read model definition file ( W3IOGR ) -! b Save MAPSTA. -! c MPP preparation -! 3. Model initialization. -! a Read restart file. ( W3IORS ) -! b Compare grid and restart MAPSTA. -! c Initialize with winds if requested (set flag). -! d Initialize calm conditions if requested. -! e Preparations for prop. scheme. -! 4. Set-up output times. -! a Unpack ODAT. -! b Check if output available. -! c Get first time per output and overall. -! d Prepare point output ( W3IOPP ) -! 5. Define wavenumber grid. -! a Calculate depth. -! b Fill wavenumber and group velocity arrays. -! 6. Initialize arrays. -! 7. Write info to log file. -! 8. Final MPI set up ( W3MPII , W3MPIO , W3MPIP ) -! ---------------------------------------------------- -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! !/MPI Id. -! -! !/S Enable subroutine tracing. -! !/Tn Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS + ! module default + IMPLICIT NONE + ! + PUBLIC + !/ + REAL, PARAMETER :: CRITOS = 15. + CHARACTER(LEN=10), PARAMETER :: WWVER = '7.14 ' + CHARACTER(LEN=512), PARAMETER :: SWITCHES = & + __WW3_SWITCHES__ + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3INIT ( IMOD, IsMulti, FEXT, MDS, MTRACE, ODAT , FLGRD, & + FLGR2, FLGD, FLG2, NPT, XPT, YPT, PNAMES, & + IPRT, PRTFRM, MPI_COMM, FLAGSTIDEIN) + + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 03-Sep-2012 | + !/ +-----------------------------------+ + !/ + !/ 17-Mar-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) + !/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Major changes to logistics. + !/ 14-Feb-2000 : Exact-NL added. ( version 2.01 ) + !/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) + !/ 24-Jan-2002 : Zero time step for data ass. ( version 2.17 ) + !/ 18-Feb-2002 : Point output diagnostics added. ( version 2.18 ) + !/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) + !/ 20-Aug-2003 : Output server options added. ( version 3.04 ) + !/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ Taken out of W3WAVE. + !/ 04-Jan-2005 : Add grid output flags to par list. ( version 3.06 ) + !/ 07-Feb-2005 : Combined vs. separate test output. ( version 3.07 ) + !/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) + !/ 09-Nov-2005 : Drying out of points added. ( version 3.08 ) + !/ 26-Jun-2006 : adding wiring for output type 6. ( version 3.09 ) + !/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 02-Aug-2006 : Adding W3MPIP. ( version 3.10 ) + !/ 02-Nov-2006 : Adding partitioning options. ( version 3.10 ) + !/ 11-Jan-2007 : Updating IAPPRO computation. ( version 3.10 ) + !/ 01-May-2007 : Move O7a output to W3IOPP. ( version 3.11 ) + !/ 08-May-2007 : Starting from calm as an option. ( version 3.11 ) + !/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 + !/ 13-Sep-2009 : Add coupling option ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 29-Oct-2010 : Implement unstructured grids ( version 3.14.1 ) + !/ (A. Roland and F. Ardhuin) + !/ 06-Dec-2010 : Change from GLOBAL (logical) to ICLOSE (integer) to + !/ specify index closure for a grid. ( version 3.14 ) + !/ (T. J. Campbell, NRL) + !/ 02-Sep.2012 : Set up for > 999 test files. ( version 4.10 ) + !/ 03-Sep-2012 : Switch test file on/off (TSTOUT) ( version 4.10 ) + !/ 03-Sep-2012 : Clean up of UG grids ( version 4.08 ) + !/ + ! 1. Purpose : + ! + ! Initialize WAVEWATCH III. + ! + ! 2. Method : + ! + ! Initialize data structure and wave fields from data files. + ! Initialize grid from local and instantaneous data. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number. + ! FEXT Char I Extension of data files. + ! MDS I.A. I Array with dataset numbers (see below), + ! saved as NDS in W3ODATMD. + ! 1: General output unit number ("log file"). + ! 2: Error output unit number. + ! 3: Test output unit number. + ! 4: "screen", i.e., direct output location, + ! can be the screen or the output file of + ! the shell. + ! 5: Model definition file unit number. + ! 6: Restart file unit number. + ! 7: Grid output file unit number. + ! 8: Point output file unit number. + ! 9: Input boundary data file unit number. + ! 10: Output boundary data file unit number + ! (first). + ! 11: Track information file unit number. + ! 12: Track output file unit number. + ! MTRACE I.A. I Array with subroutine tracing information. + ! 1: Output unit number for trace. + ! 2: Maximum number of trace prints. + ! ODAT I.A. I Output data, five parameters per output type + ! 1-5 Data for OTYPE = 1; gridded fields. + ! 1 YYYMMDD for first output. + ! 2 HHMMSS for first output. + ! 3 Output interval in seconds. + ! 4 YYYMMDD for last output. + ! 5 HHMMSS for last output. + ! 6-10 Id. for OTYPE = 2; point output. + ! 11-15 Id. for OTYPE = 3; track point output. + ! 16-20 Id. for OTYPE = 4; restart files. + ! 21-25 Id. for OTYPE = 5; boundary data. + ! 31-35 Id. for OTYPE = 7; coupling data. + ! 36-40 Id. for OTYPE = 8; second restart file + ! FLGRD L.A. I Flags for gridded output. + ! FLGR2 L.A. I Flags for coupling output. + ! NPT Int. I Number of output points + ! X/YPT R.A. I Coordinates of output points. + ! PNAMES C.A. I Output point names. + ! IPRT I.A. I Partitioning grid info. + ! PRTFRM I.A. I Partitioning format flag. + ! MPI_COMM Int. I MPI communicator to be used for model. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETG Subr. W3GDATMD Point to data structure. + ! W3SETW Subr. W3WDATMD Point to data structure. + ! W3DIMW Subr. Id. Set array sizes in data structure. + ! W3SETA Subr. W3ADATMD Point to data structure. + ! W3DIMA Subr. Id. Set array sizes in data structure. + ! W3SETI Subr. W3IDATMD Point to data structure. + ! W3DIMI Subr. Id. Set array sizes in data structure. + ! W3SETO Subr. W3ODATMD Point to data structure. + ! W3DMO5 Subr. Id. Set array sizes in data structure. + ! ITRACE Subr. W3SERVMD Subroutine tracing initialization. + ! STRACE Subr. Id. Subroutine tracing. + ! EXTCDE Subr. Id. Program abort. + ! WWDATE Subr. Id. System date. + ! WWTIME Subr. Id. System time. + ! DSEC21 Func. W3TIMEMD Compute time difference. + ! TICK21 Func. Id. Advance the clock. + ! STME21 Func. Id. Print the time readable. + ! PRTBLK Func. W3ARRYMD Print plot of array. + ! W3IOGR Subr. W3IOGRMD Read/write model definition file. + ! W3IORS Subr. W3IORSMD Read/write restart file. + ! W3IOPP Subr. W3IOPOMD Preprocess point output. + ! CALL MPI_COMM_SIZE, CALL MPI_COMM_RANK + ! Subr. mpif.h Standard MPI routines. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Any program shell or integrated model which uses WAVEWATCH III. + ! + ! 6. Error messages : + ! + ! On opening of log file only. Other error messages are generated + ! by W3IOGR and W3IORS. + ! + ! 7. Remarks : + ! + ! - The log file is called 'log.FEXT', where FEXT is passed to + ! the routine. + ! - The test output file is called 'test.FEXT' in shared memory + ! version or testNNN.FEXT in distributed memory version. + ! - A water level and ice coverage are transferred with the + ! restart file. To assure consistency within the model, the + ! water level and ice coverage are re-evaluated at the 0th + ! time step in the actual wave model routine. + ! - When running regtests in cases where disk is non-local + ! (i.e. NFS used), there can be a huge improvment in compute + ! time by using /var/tmp/ for log files. + ! See commented line at "OPEN (MDS(1),FILE=..." + ! + ! 8. Structure : + ! + ! ---------------------------------------------------- + ! 1. Set-up of idata structures and I/O. + ! a Point to proper data structures. + ! b Number of processors and processor number. + ! c Open files. + ! d Dataset unit numbers + ! e Subroutine tracing + ! f Initial and test outputs + ! 2. Model definition. + ! a Read model definition file ( W3IOGR ) + ! b Save MAPSTA. + ! c MPP preparation + ! 3. Model initialization. + ! a Read restart file. ( W3IORS ) + ! b Compare grid and restart MAPSTA. + ! c Initialize with winds if requested (set flag). + ! d Initialize calm conditions if requested. + ! e Preparations for prop. scheme. + ! 4. Set-up output times. + ! a Unpack ODAT. + ! b Check if output available. + ! c Get first time per output and overall. + ! d Prepare point output ( W3IOPP ) + ! 5. Define wavenumber grid. + ! a Calculate depth. + ! b Fill wavenumber and group velocity arrays. + ! 6. Initialize arrays. + ! 7. Write info to log file. + ! 8. Final MPI set up ( W3MPII , W3MPIO , W3MPIP ) + ! ---------------------------------------------------- + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! !/MPI Id. + ! + ! !/S Enable subroutine tracing. + ! !/Tn Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS #ifdef W3_MEMCHECK - USE MallocInfo_m + USE MallocInfo_m #endif -!/ - USE W3GDATMD, ONLY: W3SETG, RSTYPE - USE W3WDATMD, ONLY: W3SETW, W3DIMW - USE W3ADATMD, ONLY: W3SETA, W3DIMA + !/ + USE W3GDATMD, ONLY: W3SETG, RSTYPE + USE W3WDATMD, ONLY: W3SETW, W3DIMW + USE W3ADATMD, ONLY: W3SETA, W3DIMA #ifdef W3_MEMCHECK - USE W3ADATMD, ONLY: MALLINFOS -#endif - USE W3IDATMD, ONLY: W3SETI, W3DIMI - USE W3ODATMD, ONLY: W3SETO, W3DMO5 - USE W3IOGOMD, ONLY: W3FLGRDUPDT - USE W3IOGRMD, ONLY: W3IOGR - USE W3IORSMD, ONLY: W3IORS - USE W3IOPOMD, ONLY: W3IOPP - USE W3SERVMD, ONLY: ITRACE, EXTCDE, WWDATE, WWTIME -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif - USE W3TIMEMD, ONLY: DSEC21, TICK21, STME21 - USE W3ARRYMD, ONLY: PRTBLK -!/ - USE W3GDATMD, ONLY: NX, NY, NSEA, NSEAL, MAPSTA, MAPST2, MAPFS, & - MAPSF, FLAGLL, & - ICLOSE, ZB, TRNX, TRNY, DMIN, DTCFL, DTMAX, & - FLCK, NK, NTH, NSPEC, SIG, GNAME + USE W3ADATMD, ONLY: MALLINFOS +#endif + USE W3IDATMD, ONLY: W3SETI, W3DIMI + USE W3ODATMD, ONLY: W3SETO, W3DMO5 + USE W3IOGOMD, ONLY: W3FLGRDUPDT + USE W3IOGRMD, ONLY: W3IOGR + USE W3IORSMD, ONLY: W3IORS + USE W3IOPOMD, ONLY: W3IOPP + USE W3SERVMD, ONLY: ITRACE, EXTCDE, WWDATE, WWTIME + USE W3SERVMD, ONLY: STRACE + USE W3TIMEMD, ONLY: DSEC21, TICK21, STME21 + USE W3ARRYMD, ONLY: PRTBLK + !/ + USE W3GDATMD, ONLY: NX, NY, NSEA, NSEAL, MAPSTA, MAPST2, MAPFS + USE W3GDATMD, ONLY: MAPSF, FLAGLL, ICLOSE, ZB, TRNX, TRNY, DMIN, DTCFL, DTMAX + USE W3GDATMD, ONLY: FLCK, NK, NTH, NSPEC, SIG, GNAME #ifdef W3_PDLIB - USE W3GDATMD, ONLY : FLCTH -#endif - USE W3WDATMD, ONLY: TIME, TLEV, TICE, TRHO, WLV, UST, USTDIR, VA - USE W3ODATMD, ONLY: NDSO, NDSE, NDST, SCREEN, NDS, NTPROC, & - NAPROC, IAPROC, NAPLOG, NAPOUT, NAPERR, & - NAPFLD, NAPPNT, NAPTRK, NAPRST, NAPBPT, & - NAPPRT, TOFRST, DTOUT, TONEXT, TOLAST, & - FLOUT, FLOGRD, FLBPO, NOPTS, PTNME, & - PTLOC, IPTINT, PTIFAC, UNDEF, IDOUT, FLBPI, & - OUTPTS, FNMPRE, IX0, IXN, IXS, IY0, IYN, & - IYS, FLFORM, IOSTYP, UNIPTS, UPPROC, NOTYPE,& - FLOGR2, NOGRP, NGRPP, FLOGD, FLOG2 + USE W3GDATMD, ONLY : FLCTH +#endif + USE W3WDATMD, ONLY: TIME, TLEV, TICE, TRHO, WLV, UST, USTDIR, VA + USE W3ODATMD, ONLY: NDSO, NDSE, NDST, SCREEN, NDS, NTPROC + USE W3ODATMD, ONLY: NAPROC, IAPROC, NAPLOG, NAPOUT, NAPERR + USE W3ODATMD, ONLY: NAPFLD, NAPPNT, NAPTRK, NAPRST, NAPBPT + USE W3ODATMD, ONLY: NAPPRT, TOFRST, DTOUT, TONEXT, TOLAST + USE W3ODATMD, ONLY: FLOUT, FLOGRD, FLBPO, NOPTS, PTNME + USE W3ODATMD, ONLY: PTLOC, IPTINT, PTIFAC, UNDEF, IDOUT, FLBPI + USE W3ODATMD, ONLY: OUTPTS, FNMPRE, IX0, IXN, IXS, IY0, IYN + USE W3ODATMD, ONLY: IYS, FLFORM, IOSTYP, UNIPTS, UPPROC, NOTYPE + USE W3ODATMD, ONLY: FLOGR2, NOGRP, NGRPP, FLOGD, FLOG2 #ifdef W3_NL5 - USE W3ODATMD, ONLY: TOSNL5 + USE W3ODATMD, ONLY: TOSNL5 #endif - USE W3ADATMD, ONLY: NSEALM, IAPPRO, FLCOLD, FLIWND, DW, CG, WN, & - UA, UD, U10, U10D, AS + USE W3ADATMD, ONLY: NSEALM, IAPPRO, FLCOLD, FLIWND, DW, CG, WN, UA, UD, U10, U10D, AS #ifdef W3_MPI - USE W3ADATMD, ONLY: MPI_COMM_WAVE, MPI_COMM_WCMP -#endif - USE W3IDATMD, ONLY: FLLEV, FLCUR, FLWIND, FLICE, FLTAUA, FLRHOA,& - FLMDN, FLMTH, FLMVS, FLIC1, FLIC2, FLIC3, & - FLIC4, FLIC5 - USE W3DISPMD, ONLY: WAVNU1, WAVNU3 - USE W3PARALL, ONLY: SET_UP_NSEAL_NSEALM -#ifdef W3_PDLIB - USE W3PARALL, ONLY: SYNCHRONIZE_IPGL_ETC_ARRAY, ISEA_TO_JSEA - use yowNodepool, only: npa - use yowRankModule, only : rank + USE W3ADATMD, ONLY: MPI_COMM_WAVE, MPI_COMM_WCMP #endif - USE W3GDATMD, ONLY: GTYPE, UNGTYPE + USE W3IDATMD, ONLY: FLLEV, FLCUR, FLWIND, FLICE, FLTAUA, FLRHOA + USE W3IDATMD, ONLY: FLMDN, FLMTH, FLMVS, FLIC1, FLIC2, FLIC3, FLIC4, FLIC5 + USE W3DISPMD, ONLY: WAVNU1, WAVNU3 + USE W3PARALL, ONLY: SET_UP_NSEAL_NSEALM #ifdef W3_PDLIB - USE PDLIB_W3PROFSMD, ONLY : PDLIB_MAPSTA_INIT, SET_IOBDP_PDLIB, PDLIB_IOBP_INIT, SET_IOBPA_PDLIB - USE PDLIB_W3PROFSMD, ONLY : BLOCK_SOLVER_INIT, PDLIB_INIT, DEALLOCATE_PDLIB_GLOBAL - use yowDatapool, only: istatus -#endif -#ifdef W3_SETUP - USE W3WAVSET, ONLY : PREPARATION_FD_SCHEME - USE W3WDATMD, ONLY: ZETA_SETUP - USE W3GDATMD, ONLY : DO_CHANGE_WLV -#endif - USE W3TRIAMD, ONLY: NVECTRI, AREA_SI, COORDMAX, SPATIAL_GRID - USE W3GDATMD, ONLY: FSN,FSPSI,FSFCT,FSNIMP, FSTOTALIMP, FSTOTALEXP, XGRD, YGRD - USE W3GDATMD, ONLY: FSREFRACTION, FSFREQSHIFT - USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC, INIT_GET_ISEA -#ifdef W3_TIMINGS - USE W3PARALL, ONLY: PRINT_MY_TIME + USE W3PARALL, ONLY: SYNCHRONIZE_IPGL_ETC_ARRAY, ISEA_TO_JSEA + use yowNodepool, only: npa + use yowRankModule, only: rank #endif + USE W3GDATMD, ONLY: GTYPE, UNGTYPE #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - USE PDLIB_W3PROFSMD, ONLY: ALL_VA_INTEGRAL_PRINT, TEST_MPI_STATUS -#endif -#ifdef W3_DEBUGINIT + USE PDLIB_W3PROFSMD, ONLY: PDLIB_MAPSTA_INIT, SET_IOBDP_PDLIB, PDLIB_IOBP_INIT, SET_IOBPA_PDLIB + USE PDLIB_W3PROFSMD, ONLY: BLOCK_SOLVER_INIT, PDLIB_INIT, DEALLOCATE_PDLIB_GLOBAL + use yowDatapool, only: istatus + USE PDLIB_W3PROFSMD, ONLY: ALL_VA_INTEGRAL_PRINT, TEST_MPI_STATUS USE PDLIB_W3PROFSMD, ONLY: PRINT_WN_STATISTIC #endif -#endif +#ifdef W3_SETUP + USE W3WAVSET, ONLY: PREPARATION_FD_SCHEME + USE W3WDATMD, ONLY: ZETA_SETUP + USE W3GDATMD, ONLY: DO_CHANGE_WLV +#endif + USE W3TRIAMD, ONLY: NVECTRI, AREA_SI, COORDMAX, SPATIAL_GRID + USE W3GDATMD, ONLY: FSN,FSPSI,FSFCT,FSNIMP, FSTOTALIMP, FSTOTALEXP, XGRD, YGRD + USE W3GDATMD, ONLY: FSREFRACTION, FSFREQSHIFT + USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC, INIT_GET_ISEA + USE W3PARALL, ONLY: PRINT_MY_TIME #ifdef W3_UOST - USE W3UOSTMD, ONLY: UOST_SETGRID -#endif -!/ - IMPLICIT NONE -! -#ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD, MDS(13), MTRACE(2), & - ODAT(40),NPT, IPRT(6),& - MPI_COMM - LOGICAL, INTENT(IN) :: IsMulti - REAL, INTENT(INOUT) :: XPT(NPT), YPT(NPT) - LOGICAL, INTENT(INOUT) :: FLGRD(NOGRP,NGRPP), FLGD(NOGRP),& - FLGR2(NOGRP,NGRPP), FLG2(NOGRP),& - PRTFRM - CHARACTER, INTENT(IN) :: FEXT*(*) - CHARACTER(LEN=40), INTENT(IN) :: PNAMES(NPT) - LOGICAL, INTENT(IN), OPTIONAL :: FLAGSTIDEIN(4) - INTEGER :: NSEALout, NSEALMout -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - integer :: IRANK, I, ISTAT - INTEGER :: IE, IFL, IFT, IERR, NTTOT, NTLOC, & - NTTARG, IK, IP, ITH, IX, IY, & - J, J0, TOUT(2), TLST(2), ISEA, IS, & - K, I1, I2, JSEA, NTTMAX -#ifdef W3_DIST - INTEGER :: ISTEP, ISP, IW -#endif -#ifdef W3_MPI - INTEGER :: IERR_MPI, BGROUP, LGROUP -#endif -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -#ifdef W3_T - INTEGER :: NX0, NXN - INTEGER, ALLOCATABLE :: MAPOUT(:,:) -#endif -#ifdef W3_MPI - INTEGER, ALLOCATABLE :: TMPRNK(:) -#endif - INTEGER, ALLOCATABLE :: NT(:), MAPTST(:,:) -#ifdef W3_T - INTEGER, SAVE :: NXS = 49 -#endif - REAL :: DTTST, DEPTH, FRACOS - REAL :: FACTOR - REAL :: WLVeff -#ifdef W3_T - REAL, ALLOCATABLE :: XOUT(:,:) -#endif - LOGICAL :: OPENED - CHARACTER(LEN=8) :: STTIME - CHARACTER(LEN=10) :: STDATE - INTEGER :: ISPROC -#ifdef W3_DIST - CHARACTER(LEN=12) :: FORMAT -#endif - CHARACTER(LEN=23) :: DTME21 - CHARACTER(LEN=30) :: LFILE, TFILE -#ifdef W3_PDLIB - INTEGER :: IScal(1), IPROC -#endif -!/ -!/ ------------------------------------------------------------------- / -! -! 1. Set-up of data structures and I/O ----------------------------- / -! 1.a Point to proper data structures. -! -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 1") + USE W3UOSTMD, ONLY: UOST_SETGRID +#endif + ! +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER , INTENT(IN) :: IMOD, MDS(13), MTRACE(2) + INTEGER , INTENT(IN) :: ODAT(40),NPT, IPRT(6) + INTEGER , INTENT(IN) :: MPI_COMM + LOGICAL , INTENT(IN) :: IsMulti + REAL , INTENT(INOUT) :: XPT(NPT), YPT(NPT) + LOGICAL , INTENT(INOUT) :: FLGRD(NOGRP,NGRPP), FLGD(NOGRP) + LOGICAL , INTENT(INOUT) :: FLGR2(NOGRP,NGRPP), FLG2(NOGRP) + LOGICAL , INTENT(INOUT) :: PRTFRM + CHARACTER(LEN=*) , INTENT(IN) :: FEXT + CHARACTER(LEN=40) , INTENT(IN) :: PNAMES(NPT) + LOGICAL , INTENT(IN), OPTIONAL :: FLAGSTIDEIN(4) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NSEALout, NSEALMout + integer :: IRANK, I, ISTAT + INTEGER :: IE, IFL, IFT, IERR, NTTOT, NTLOC + INTEGER :: NTTARG, IK, IP, ITH, IX, IY + INTEGER :: J, J0, TOUT(2), TLST(2), ISEA, IS + INTEGER :: K, I1, I2, JSEA, NTTMAX + INTEGER :: ISTEP, ISP, IW ! W3_DIST + INTEGER :: IERR_MPI, BGROUP, LGROUP ! W3_MPI + INTEGER, SAVE :: IENT = 0 ! W3_S + INTEGER :: NX0, NXN ! W3_T + INTEGER, ALLOCATABLE :: MAPOUT(:,:) ! W3_T + INTEGER, ALLOCATABLE :: TMPRNK(:) ! W3_MPI + INTEGER, ALLOCATABLE :: NT(:), MAPTST(:,:) + INTEGER, SAVE :: NXS = 49 ! W3_T + REAL :: DTTST, DEPTH, FRACOS + REAL :: FACTOR + REAL :: WLVeff + REAL, ALLOCATABLE :: XOUT(:,:) ! W3_T + LOGICAL :: OPENED + CHARACTER(LEN=8) :: STTIME + CHARACTER(LEN=10) :: STDATE + INTEGER :: ISPROC + CHARACTER(LEN=12) :: FORMAT ! W3_DIST + CHARACTER(LEN=23) :: DTME21 + CHARACTER(LEN=30) :: LFILE, TFILE + INTEGER :: IScal(1), IPROC ! W3_PDLIB + !/ + !/ ------------------------------------------------------------------- / + ! + ! 1. Set-up of data structures and I/O ----------------------------- / + ! 1.a Point to proper data structures. + ! + !!/DEBUGMPI CALL TEST_MPI_STATUS("Case 1") -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 1' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 1') - CALL W3SETO ( IMOD, MDS(2), MDS(3) ) + CALL W3SETO ( IMOD, MDS(2), MDS(3) ) -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 1a' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 1a') - CALL W3SETG ( IMOD, MDS(2), MDS(3) ) + CALL W3SETG ( IMOD, MDS(2), MDS(3) ) -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 1b' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 1b') - CALL W3SETW ( IMOD, MDS(2), MDS(3) ) + CALL W3SETW ( IMOD, MDS(2), MDS(3) ) -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 1c' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 1c') - CALL W3SETA ( IMOD, MDS(2), MDS(3) ) + CALL W3SETA ( IMOD, MDS(2), MDS(3) ) -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 1d' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 1d') - CALL W3SETI ( IMOD, MDS(2), MDS(3) ) + CALL W3SETI ( IMOD, MDS(2), MDS(3) ) #ifdef W3_UOST - CALL UOST_SETGRID(IMOD) -#endif -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Beginning of W3INIT' - WRITE(740+IAPROC,*) ' FLGR2(10,1)=', FLGR2(10,1) - WRITE(740+IAPROC,*) ' FLGR2(10,2)=', FLGR2(10,2) - FLUSH(740+IAPROC) -#endif -#ifdef W3_TIMINGS + CALL UOST_SETGRID(IMOD) +#endif + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'Beginning of W3INIT' + WRITE(740+IAPROC,*) ' FLGR2(10,1)=', FLGR2(10,1) + WRITE(740+IAPROC,*) ' FLGR2(10,2)=', FLGR2(10,2) + end if + if (w3_timings_flag) then CALL PRINT_MY_TIME("Case 2") -#endif - - -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 1e' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif -! -! -! 1.b Number of processors and processor number. -! Overwrite some initializations from W3ODATMD. -! -! ******************************************************* -! *** NOTE : OUTPUT PROCESSOR ASSIGNMENT NEEDS TO BE *** -! *** CONSISTENT WITH ASSIGNMENT IN WMINIT. *** -! ******************************************************* -! + end if + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 1e') + ! + ! + ! 1.b Number of processors and processor number. + ! Overwrite some initializations from W3ODATMD. + ! + ! ******************************************************* + ! *** NOTE : OUTPUT PROCESSOR ASSIGNMENT NEEDS TO BE *** + ! *** CONSISTENT WITH ASSIGNMENT IN WMINIT. *** + ! ******************************************************* + ! #ifdef W3_SHRD - NTPROC = 1 - NAPROC = 1 - IAPROC = 1 - IOSTYP = 1 -#endif -! -#ifdef W3_MPI - MPI_COMM_WAVE = MPI_COMM - CALL MPI_COMM_SIZE ( MPI_COMM_WAVE, NTPROC, IERR_MPI ) - NAPROC = NTPROC - CALL MPI_COMM_RANK ( MPI_COMM_WAVE, IAPROC, IERR_MPI ) - IAPROC = IAPROC + 1 -#endif -! -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 3") - IF ( IOSTYP .LE. 1 ) THEN -! - NAPFLD = MAX(1,NAPROC-1) - NAPPNT = MAX(1,NAPROC-2) - NAPTRK = MAX(1,NAPROC-5) - NAPRST = NAPROC - NAPBPT = MAX(1,NAPROC-3) - NAPPRT = MAX(1,NAPROC-4) -! - ELSE -! - NAPPNT = NAPROC - IF ( UNIPTS .AND. UPPROC ) NAPROC = MAX(1,NTPROC - 1) - NAPFLD = NAPROC - NAPRST = NAPROC - NAPBPT = NAPROC - NAPTRK = NAPROC - NAPPRT = NAPROC -! - IF ( IOSTYP .EQ. 2 ) THEN - NAPROC = MAX(1,NAPROC-1) - ELSE IF ( IOSTYP .EQ. 3 ) THEN -! -! For field or coupling output -! - IF ( ODAT( 3).GT.0 .OR. ODAT(33).GT.0 ) THEN - NAPFLD = NAPROC - NAPROC = MAX(1,NAPROC-1) - END IF - IF ( ODAT(13).GT.0 ) THEN - NAPTRK = NAPROC - NAPROC = MAX(1,NAPROC-1) - END IF - IF ( ODAT(28).GT.0 ) THEN - NAPPRT = NAPROC - NAPROC = MAX(1,NAPROC-1) - END IF - IF ( ODAT( 8).GT.0 ) NAPPNT = NAPROC - IF ( ODAT(18).GT.0 ) NAPRST = NAPROC - IF ( ODAT(23).GT.0 ) NAPBPT = NAPROC - IF ( ( ODAT( 8).GT.0 .OR. ODAT(18).GT.0 .OR. & - ODAT(23).GT.0 ) ) NAPROC = MAX(1,NAPROC-1) - END IF - END IF -! -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 4") - FRACOS = 100. * REAL(NTPROC-NAPROC) / REAL(NTPROC) - IF ( FRACOS.GT.CRITOS .AND. IAPROC.EQ.NAPERR ) & - WRITE (NDSE,8002) FRACOS -! -#ifdef W3_MPI - IF ( NAPROC .EQ. NTPROC ) THEN - MPI_COMM_WCMP = MPI_COMM_WAVE - ELSE - CALL MPI_COMM_GROUP ( MPI_COMM_WAVE, BGROUP, IERR_MPI ) - ALLOCATE ( TMPRNK(NAPROC) ) - DO J=1, NAPROC - TMPRNK(J) = J - 1 - END DO - CALL MPI_GROUP_INCL ( BGROUP, NAPROC, TMPRNK, LGROUP, & - IERR_MPI ) - CALL MPI_COMM_CREATE ( MPI_COMM_WAVE, LGROUP, & - MPI_COMM_WCMP, IERR_MPI ) - CALL MPI_GROUP_FREE ( LGROUP, IERR_MPI ) - CALL MPI_GROUP_FREE ( BGROUP, IERR_MPI ) - DEALLOCATE ( TMPRNK ) - END IF + NTPROC = 1 + NAPROC = 1 + IAPROC = 1 + IOSTYP = 1 +#endif + ! +#ifdef W3_MPI + MPI_COMM_WAVE = MPI_COMM + CALL MPI_COMM_SIZE ( MPI_COMM_WAVE, NTPROC, IERR_MPI ) + NAPROC = NTPROC + CALL MPI_COMM_RANK ( MPI_COMM_WAVE, IAPROC, IERR_MPI ) + IAPROC = IAPROC + 1 +#endif + ! + !!/DEBUGMPI CALL TEST_MPI_STATUS("Case 3") + IF ( IOSTYP .LE. 1 ) THEN + ! + NAPFLD = MAX(1,NAPROC-1) + NAPPNT = MAX(1,NAPROC-2) + NAPTRK = MAX(1,NAPROC-5) + NAPRST = NAPROC + NAPBPT = MAX(1,NAPROC-3) + NAPPRT = MAX(1,NAPROC-4) + ! + ELSE + ! + NAPPNT = NAPROC + IF ( UNIPTS .AND. UPPROC ) NAPROC = MAX(1,NTPROC - 1) + NAPFLD = NAPROC + NAPRST = NAPROC + NAPBPT = NAPROC + NAPTRK = NAPROC + NAPPRT = NAPROC + ! + IF ( IOSTYP .EQ. 2 ) THEN + NAPROC = MAX(1,NAPROC-1) + ELSE IF ( IOSTYP .EQ. 3 ) THEN + ! + ! For field or coupling output + ! + IF ( ODAT( 3).GT.0 .OR. ODAT(33).GT.0 ) THEN + NAPFLD = NAPROC + NAPROC = MAX(1,NAPROC-1) + END IF + IF ( ODAT(13).GT.0 ) THEN + NAPTRK = NAPROC + NAPROC = MAX(1,NAPROC-1) + END IF + IF ( ODAT(28).GT.0 ) THEN + NAPPRT = NAPROC + NAPROC = MAX(1,NAPROC-1) + END IF + IF ( ODAT( 8).GT.0 ) NAPPNT = NAPROC + IF ( ODAT(18).GT.0 ) NAPRST = NAPROC + IF ( ODAT(23).GT.0 ) NAPBPT = NAPROC + IF ( ( ODAT( 8).GT.0 .OR. ODAT(18).GT.0 .OR. & + ODAT(23).GT.0 ) ) NAPROC = MAX(1,NAPROC-1) + END IF + END IF + ! + !!/DEBUGMPI CALL TEST_MPI_STATUS("Case 4") + FRACOS = 100. * REAL(NTPROC-NAPROC) / REAL(NTPROC) + IF ( FRACOS.GT.CRITOS .AND. IAPROC.EQ.NAPERR ) WRITE (NDSE,8002) FRACOS + ! +#ifdef W3_MPI + IF ( NAPROC .EQ. NTPROC ) THEN + MPI_COMM_WCMP = MPI_COMM_WAVE + ELSE + CALL MPI_COMM_GROUP ( MPI_COMM_WAVE, BGROUP, IERR_MPI ) + ALLOCATE ( TMPRNK(NAPROC) ) + DO J=1, NAPROC + TMPRNK(J) = J - 1 + END DO + CALL MPI_GROUP_INCL ( BGROUP, NAPROC, TMPRNK, LGROUP, & + IERR_MPI ) + CALL MPI_COMM_CREATE ( MPI_COMM_WAVE, LGROUP, & + MPI_COMM_WCMP, IERR_MPI ) + CALL MPI_GROUP_FREE ( LGROUP, IERR_MPI ) + CALL MPI_GROUP_FREE ( BGROUP, IERR_MPI ) + DEALLOCATE ( TMPRNK ) + END IF #endif !!!/PDLIB CALL W3SETG(IMOD, NDSE, NDST) -! - LPDLIB = .FALSE. + ! + LPDLIB = .FALSE. #ifdef W3_PDLIB LPDLIB = .TRUE. #endif - IF (FSTOTALIMP .and. .NOT. LPDLIB) THEN - WRITE(NDSE,*) 'IMPTOTAL is selected' - WRITE(NDSE,*) 'But PDLIB is not' - STOP 'Stop, case 1' - ELSE IF (FSTOTALEXP .and. .NOT. LPDLIB) THEN - WRITE(NDSE,*) 'EXPTOTAL is selected' - WRITE(NDSE,*) 'But PDLIB is not' - STOP 'Stop, case 1' - END IF -! -! 1.c Open files without unpacking MDS ,,, -! - IE = LEN_TRIM(FEXT) - LFILE = 'log.' // FEXT(:IE) - IFL = LEN_TRIM(LFILE) -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 5") + IF (FSTOTALIMP .and. .NOT. LPDLIB) THEN + WRITE(NDSE,*) 'IMPTOTAL is selected' + WRITE(NDSE,*) 'But PDLIB is not' + STOP 'Stop, case 1' + ELSE IF (FSTOTALEXP .and. .NOT. LPDLIB) THEN + WRITE(NDSE,*) 'EXPTOTAL is selected' + WRITE(NDSE,*) 'But PDLIB is not' + STOP 'Stop, case 1' + END IF + ! + ! 1.c Open files without unpacking MDS ,,, + ! + IE = LEN_TRIM(FEXT) + LFILE = 'log.' // FEXT(:IE) + IFL = LEN_TRIM(LFILE) + !!/DEBUGMPI CALL TEST_MPI_STATUS("Case 5") #ifdef W3_SHRD - TFILE = 'test.' // FEXT(:IE) + TFILE = 'test.' // FEXT(:IE) #endif #ifdef W3_DIST - IW = 1 + INT ( LOG10 ( REAL(NAPROC) + 0.5 ) ) - IW = MAX ( 3 , MIN ( 9 , IW ) ) - WRITE (FORMAT,'(A5,I1.1,A1,I1.1,A4)') & - '(A4,I', IW, '.', IW, ',2A)' - WRITE (TFILE,FORMAT) 'test', & - OUTPTS(IMOD)%IAPROC, '.', FEXT(:IE) -#endif - IFT = LEN_TRIM(TFILE) - J = LEN_TRIM(FNMPRE) -! + IW = 1 + INT ( LOG10 ( REAL(NAPROC) + 0.5 ) ) + IW = MAX ( 3 , MIN ( 9 , IW ) ) + WRITE (FORMAT,'(A5,I1.1,A1,I1.1,A4)') & + '(A4,I', IW, '.', IW, ',2A)' + WRITE (TFILE,FORMAT) 'test', & + OUTPTS(IMOD)%IAPROC, '.', FEXT(:IE) +#endif + IFT = LEN_TRIM(TFILE) + J = LEN_TRIM(FNMPRE) + ! -#ifndef W3_CESMCOUPLED -#ifdef W3_DEBUGINIT - IF ( OUTPTS(IMOD)%IAPROC .EQ. OUTPTS(IMOD)%NAPLOG ) & - WRITE(*,*) '1: w3initmd f=', TRIM(FNMPRE(:J)//LFILE(:IFL)) -#endif - 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) -#ifdef W3_DEBUGINIT - WRITE(*,*) '2: w3initmd f=', TRIM(FNMPRE(:J)//TFILE(:IFT)) -#endif - IF ( .NOT. OPENED ) OPEN & - (MDS(3),FILE=FNMPRE(:J)//TFILE(:IFT),ERR=889,IOSTAT=IERR) - END IF -! -! 1.d Dataset unit numbers -! -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 6") - NDS = MDS - NDSO = NDS(1) - NDSE = NDS(2) - NDST = NDS(3) - SCREEN = NDS(4) -! -! 1.e Subroutine tracing -! - CALL ITRACE ( MTRACE(1), MTRACE(2) ) -! -! 1.f Initial and test outputs -! -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif -! -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 7") + if (.not. w3_cesmcoupled_flag) then + if (w3_debuginit_flag) then + IF ( OUTPTS(IMOD)%IAPROC .EQ. OUTPTS(IMOD)%NAPLOG ) then + WRITE(*,*) '1: w3initmd f=', TRIM(FNMPRE(:J)//LFILE(:IFL)) + end IF + end if + IF ( OUTPTS(IMOD)%IAPROC .EQ. OUTPTS(IMOD)%NAPLOG ) then + OPEN (MDS(1),FILE=FNMPRE(:J)//LFILE(:IFL),ERR=888,IOSTAT=IERR) + end IF + end if + ! + IF ( MDS(3).NE.MDS(1) .AND. MDS(3).NE.MDS(4) .AND. TSTOUT ) THEN + INQUIRE (MDS(3),OPENED=OPENED) + if (w3_debuginit_flag) then + WRITE(*,*) '2: w3initmd f=', TRIM(FNMPRE(:J)//TFILE(:IFT)) + end if + IF ( .NOT. OPENED ) then + OPEN (MDS(3),FILE=FNMPRE(:J)//TFILE(:IFT),ERR=889,IOSTAT=IERR) + end IF + END IF + ! + ! 1.d Dataset unit numbers + ! + !!/DEBUGMPI CALL TEST_MPI_STATUS("Case 6") + NDS = MDS + NDSO = NDS(1) + NDSE = NDS(2) + NDST = NDS(3) + SCREEN = NDS(4) + ! + ! 1.e Subroutine tracing + ! + CALL ITRACE ( MTRACE(1), MTRACE(2) ) + ! + ! 1.f Initial and test outputs + ! + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 2') + ! + !!/DEBUGMPI CALL TEST_MPI_STATUS("Case 7") - IF ( IAPROC .EQ. NAPLOG ) THEN - CALL WWDATE ( STDATE ) - CALL WWTIME ( STTIME ) - WRITE (NDSO,900) WWVER, STDATE, STTIME - END IF + IF ( IAPROC .EQ. NAPLOG ) THEN + CALL WWDATE ( STDATE ) + CALL WWTIME ( STTIME ) + WRITE (NDSO,900) WWVER, STDATE, STTIME + END IF -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2a' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif -! -#ifdef W3_S - CALL STRACE (IENT, 'W3INIT') -#endif -#ifdef W3_T - WRITE(NDST,9000) IMOD, FEXT(:IE) - WRITE (NDST,9001) NTPROC, NAPROC, IAPROC, NAPLOG, NAPOUT, & - NAPERR, NAPFLD, NAPPNT, NAPTRK, NAPRST, NAPBPT, NAPPRT - WRITE (NDST,9002) NDSO, NDSE, NDST, SCREEN - WRITE (NDST,9003) LFILE(:IFL), TFILE(:IFT) -#endif -! -! 2. Model defintition ---------------------------------------------- / -! 2.a Read model defintition file -! -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 8") - CALL W3IOGR ( 'READ', NDS(5), IMOD, FEXT ) - IF (GTYPE .eq. UNGTYPE) THEN - CALL SPATIAL_GRID - CALL NVECTRI - CALL COORDMAX + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 2a') + + if (w3_s_flag) then + CALL STRACE (IENT, 'W3INIT') + end if + if (w3_t_flag) then + WRITE(NDST,9000) IMOD, FEXT(:IE) + WRITE (NDST,9001) NTPROC, NAPROC, IAPROC, NAPLOG, NAPOUT, & + NAPERR, NAPFLD, NAPPNT, NAPTRK, NAPRST, NAPBPT, NAPPRT + WRITE (NDST,9002) NDSO, NDSE, NDST, SCREEN + WRITE (NDST,9003) LFILE(:IFL), TFILE(:IFT) + end if + ! + ! 2. Model definition ---------------------------------------------- / + ! 2.a Read model definition file + ! + !!/DEBUGMPI CALL TEST_MPI_STATUS("Case 8") + CALL W3IOGR ( 'READ', NDS(5), IMOD, FEXT ) + IF (GTYPE .eq. UNGTYPE) THEN + CALL SPATIAL_GRID + CALL NVECTRI + CALL COORDMAX #ifdef W3_PDLIB - IF(.false.) THEN + IF(.false.) THEN #endif - CALL AREA_SI(1) + CALL AREA_SI(1) #ifdef W3_PDLIB - ENDIF -#endif - ENDIF -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2b' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) + ENDIF #endif + ENDIF + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 2b') #ifdef W3_PDLIB IF (GTYPE .ne. UNGTYPE) THEN #endif #ifdef W3_SETUP - CALL PREPARATION_FD_SCHEME(IMOD) + CALL PREPARATION_FD_SCHEME(IMOD) #endif #ifdef W3_PDLIB ELSE #endif #ifdef W3_PDLIB -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before PDLIB_INIT' -#endif + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'Before PDLIB_INIT' + end if #endif #ifdef W3_PDLIB - CALL PDLIB_INIT(IMOD) + CALL PDLIB_INIT(IMOD) #endif - -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2c' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif - + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 2c') #ifdef W3_PDLIB -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'After set up of NSEAL, NSEALM=', NSEALM - WRITE(740+IAPROC,*) 'After PDLIB_INIT' - WRITE(740+IAPROC,*) 'allocated(ISEA_TO_JSEA)=', allocated(ISEA_TO_JSEA) - FLUSH(740+IAPROC) -#endif -#endif - -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After PDLIB_INIT") -#endif + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'After set up of NSEAL, NSEALM=', NSEALM + WRITE(740+IAPROC,*) 'After PDLIB_INIT' + WRITE(740+IAPROC,*) 'allocated(ISEA_TO_JSEA)=', allocated(ISEA_TO_JSEA) + end if +#endif + if (w3_timings_flag) then + CALL PRINT_MY_TIME("After PDLIB_INIT") + end if #ifdef W3_PDLIB - CALL SYNCHRONIZE_IPGL_ETC_ARRAY(IMOD, IsMulti) -#endif - -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2cc' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) + CALL SYNCHRONIZE_IPGL_ETC_ARRAY(IMOD, IsMulti) #endif + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 2cc') #ifdef W3_PDLIB END IF #endif + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 2d') + ! Update of output parameter flags based on mod_def parameters (for 3D arrays) + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'Before W3FLGRDUPDT' + end if -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2d' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif - -! Update of output parameter flags based on mod_def parameters (for 3D arrays) - -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before W3FLGRDUPDT' - FLUSH(740+IAPROC) -#endif - - CALL W3FLGRDUPDT ( NDSO, NDSE, FLGRD, FLGR2, FLGD, FLG2 ) + CALL W3FLGRDUPDT ( NDSO, NDSE, FLGRD, FLGR2, FLGD, FLG2 ) -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 9") -#ifdef W3_TIMINGS + !/DEBUGMPI CALL TEST_MPI_STATUS("Case 9") + if (w3_timings_flag) then CALL PRINT_MY_TIME("After W3FLGRDUPDT") -#endif + end if - IF ( FLAGLL ) THEN - FACTOR = 1. - ELSE - FACTOR = 1.E-3 - END IF - IF ( IAPROC .EQ. NAPLOG ) WRITE (NDSO,920) -! -! 2.b Save MAPSTA -! - ALLOCATE ( MAPTST(NY,NX) ) - MAPTST = MAPSTA + IF ( FLAGLL ) THEN + FACTOR = 1. + ELSE + FACTOR = 1.E-3 + END IF + IF ( IAPROC .EQ. NAPLOG ) WRITE (NDSO,920) + ! + ! 2.b Save MAPSTA + ! + ALLOCATE ( MAPTST(NY,NX) ) + MAPTST = MAPSTA -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2e' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif -! -! -! 2.c MPP preparation -! 2.c.1 Set simple counters and variables -! -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 10") - CALL SET_UP_NSEAL_NSEALM(NSEALout, NSEALMout) - NSEAL = NSEALout - NSEALM = NSEALMout + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 2e') + ! + ! 2.c MPP preparation + ! 2.c.1 Set simple counters and variables + ! + !!/DEBUGMPI CALL TEST_MPI_STATUS("Case 10") + CALL SET_UP_NSEAL_NSEALM(NSEALout, NSEALMout) + NSEAL = NSEALout + NSEALM = NSEALMout -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2f' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif -! -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'After set up of NSEAL, NSEAL=', NSEAL - WRITE(740+IAPROC,*) 'After set up of NSEAL, NSEALM=', NSEALM - WRITE(740+IAPROC,*) 'NSEA=', NSEA, ' NSPEC=', NSPEC - FLUSH(740+IAPROC) -#endif + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 2f') + ! + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'After set up of NSEAL, NSEAL=', NSEAL + WRITE(740+IAPROC,*) 'After set up of NSEAL, NSEALM=', NSEALM + WRITE(740+IAPROC,*) 'NSEA=', NSEA, ' NSPEC=', NSPEC + end if #ifdef W3_DEBUGMPI - CALL TEST_MPI_STATUS("Case 11") + CALL TEST_MPI_STATUS("Case 11") #endif #ifdef W3_DIST - IF ( NSEA .LT. NAPROC ) GOTO 820 - IF ((LPDLIB .eqv. .FALSE.).or.(GTYPE .NE. UNGTYPE)) THEN - IF ( NSPEC .LT. NAPROC ) GOTO 821 - END IF + IF ( NSEA .LT. NAPROC ) GOTO 820 + IF ((LPDLIB .eqv. .FALSE.).or.(GTYPE .NE. UNGTYPE)) THEN + IF ( NSPEC .LT. NAPROC ) GOTO 821 + END IF #endif -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before PDLIB related allocations' - FLUSH(740+IAPROC) -#endif + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'Before PDLIB related allocations' + end if #ifdef W3_PDLIB - IF ((IAPROC .LE. NAPROC).and.(GTYPE .eq. UNGTYPE)) THEN -#endif + IF ((IAPROC .LE. NAPROC).and.(GTYPE .eq. UNGTYPE)) THEN -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'After test 1' - FLUSH(740+IAPROC) - WRITE(740+IAPROC,*) 'Before BLOCK_SOLVER_INIT' - FLUSH(740+IAPROC) -#endif + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'After test 1' + WRITE(740+IAPROC,*) 'Before BLOCK_SOLVER_INIT' + end if -#ifdef W3_PDLIB - CALL BLOCK_SOLVER_INIT(IMOD) - CALL PDLIB_IOBP_INIT(IMOD) - CALL SET_IOBPA_PDLIB -#endif + CALL BLOCK_SOLVER_INIT(IMOD) + CALL PDLIB_IOBP_INIT(IMOD) + CALL SET_IOBPA_PDLIB -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'After BLOCK_SOLVER_INIT' - FLUSH(740+IAPROC) -#endif + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'After BLOCK_SOLVER_INIT' + end if -#ifdef W3_PDLIB - ELSE IF (FSTOTALEXP) THEN -!AR: To do here the blocksolver ... - ENDIF -#endif + ELSE IF (FSTOTALEXP) THEN + !AR: To do here the blocksolver ... + ENDIF -#ifdef W3_TIMINGS + if (w3_timings_flag) then CALL PRINT_MY_TIME("After BLOCK_SOLVER_INIT") -#endif + end if -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2g' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) #endif + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 2g') #ifdef W3_DEBUGMPI - CALL TEST_MPI_STATUS("Case 12") -#endif -! -! -! 2.c.2 Allocate arrays -! - IF ( IAPROC .LE. NAPROC ) THEN -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Calling W3DIMW at W3INIT, case 1' - FLUSH(740+IAPROC) -#endif - CALL W3DIMW ( IMOD, NDSE, NDST ) -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2h' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif - ELSE -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Calling W3DIMW at W3INIT, case 2' - FLUSH(740+IAPROC) -#endif - CALL W3DIMW ( IMOD, NDSE, NDST, .FALSE. ) -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2i' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif - END IF -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) ' 1: NSEAL=', NSEAL - WRITE(740+IAPROC,*) ' maxval(UST)=', maxval(UST) - FLUSH(740+IAPROC) -#endif -#ifdef W3_TIMINGS + CALL TEST_MPI_STATUS("Case 12") +#endif + ! + ! + ! 2.c.2 Allocate arrays + ! + IF ( IAPROC .LE. NAPROC ) THEN + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'Calling W3DIMW at W3INIT, case 1' + end if + CALL W3DIMW ( IMOD, NDSE, NDST ) + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 2h') + ELSE + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'Calling W3DIMW at W3INIT, case 2' + end if + CALL W3DIMW ( IMOD, NDSE, NDST, .FALSE. ) + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 2i') + END IF + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) ' 1: NSEAL=', NSEAL + WRITE(740+IAPROC,*) ' maxval(UST)=', maxval(UST) + end if + if (w3_timings_flag) then CALL PRINT_MY_TIME("After W3DIMW") -#endif - CALL W3DIMA ( IMOD, NDSE, NDST ) -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 2j' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif - CALL W3DIMI ( IMOD, NDSE, NDST , FLAGSTIDEIN ) -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 13") -#ifdef W3_TIMINGS + end if + CALL W3DIMA ( IMOD, NDSE, NDST ) + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 2j') + CALL W3DIMI ( IMOD, NDSE, NDST , FLAGSTIDEIN ) + !/DEBUGMPI CALL TEST_MPI_STATUS("Case 13") + if (w3_timings_flag) then CALL PRINT_MY_TIME("After W3DIMI") -#endif + end if -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 3' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif -! -! 2.c.3 Calculated expected number of prop. calls per processor -! - NTTOT = 0 - DO IK=1, NK - NTLOC = 1 + INT(DTMAX/(DTCFL*SIG(IK)/SIG(1))-0.001) - NTTOT = NTTOT + NTLOC*NTH - END DO - NTTARG = 1 + (NTTOT-1)/NAPROC - NTTARG = NTTARG + INT(DTMAX/(DTCFL*SIG(NK)/SIG(1))-0.001) - NTTMAX = NTTARG + 5 -! -! 2.c.4 Initialize IAPPRO -! - IAPPRO = 1 - ALLOCATE ( NT(NSPEC) ) - NT = NTTOT + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 3') + ! + ! 2.c.3 Calculated expected number of prop. calls per processor + ! + NTTOT = 0 + DO IK=1, NK + NTLOC = 1 + INT(DTMAX/(DTCFL*SIG(IK)/SIG(1))-0.001) + NTTOT = NTTOT + NTLOC*NTH + END DO + NTTARG = 1 + (NTTOT-1)/NAPROC + NTTARG = NTTARG + INT(DTMAX/(DTCFL*SIG(NK)/SIG(1))-0.001) + NTTMAX = NTTARG + 5 + ! + ! 2.c.4 Initialize IAPPRO + ! + IAPPRO = 1 + ALLOCATE ( NT(NSPEC) ) + NT = NTTOT #ifdef W3_DIST IF ((LPDLIB .eqv. .FALSE.).or.(GTYPE .NE. UNGTYPE)) THEN -#endif -! -#ifdef W3_DIST - DO -#endif -! -! 2.c.5 First sweep filling IAPPRO -! -#ifdef W3_DIST - DO IP=1, NAPROC - ISTEP = IP - ISP = 0 - NT(IP) = 0 - DO J=1, 1+NSPEC/NAPROC - ISP = ISP + ISTEP - IF ( MOD(J,2) .EQ. 1 ) THEN - ISTEP = 2*(NAPROC-IP) + 1 - ELSE - ISTEP = 2*IP - 1 - END IF - IF ( ISP .LE. NSPEC ) THEN - IK = 1 + (ISP-1)/NTH - NTLOC = 1 + INT(DTMAX/(DTCFL*SIG(IK)/SIG(1))-0.001) - IF ( NT(IP)+NTLOC .LE. NTTARG ) THEN - IAPPRO(ISP) = IP - NT(IP) = NT(IP) + NTLOC - ELSE - IAPPRO(ISP) = -1 - END IF - END IF - END DO + DO + ! + ! 2.c.5 First sweep filling IAPPRO + ! + DO IP=1, NAPROC + ISTEP = IP + ISP = 0 + NT(IP) = 0 + DO J=1, 1+NSPEC/NAPROC + ISP = ISP + ISTEP + IF ( MOD(J,2) .EQ. 1 ) THEN + ISTEP = 2*(NAPROC-IP) + 1 + ELSE + ISTEP = 2*IP - 1 + END IF + IF ( ISP .LE. NSPEC ) THEN + IK = 1 + (ISP-1)/NTH + NTLOC = 1 + INT(DTMAX/(DTCFL*SIG(IK)/SIG(1))-0.001) + IF ( NT(IP)+NTLOC .LE. NTTARG ) THEN + IAPPRO(ISP) = IP + NT(IP) = NT(IP) + NTLOC + ELSE + IAPPRO(ISP) = -1 + END IF + END IF + END DO END DO -#endif -! -! 2.c.6 Second sweep filling IAPPRO -! -#ifdef W3_DIST - DO IP=1, NAPROC - IF ( NT(IP) .LT. NTTARG ) THEN - DO ISP=1, NSPEC - IF ( IAPPRO(ISP) .EQ. -1 ) THEN - IK = 1 + (ISP-1)/NTH - NTLOC = 1 + INT(DTMAX/(DTCFL*SIG(IK)/SIG(1))-0.001) - IF ( NT(IP)+NTLOC .LE. NTTARG ) THEN - IAPPRO(ISP) = IP - NT(IP) = NT(IP) + NTLOC - END IF - END IF + ! + ! 2.c.6 Second sweep filling IAPPRO + ! + DO IP=1, NAPROC + IF ( NT(IP) .LT. NTTARG ) THEN + DO ISP=1, NSPEC + IF ( IAPPRO(ISP) .EQ. -1 ) THEN + IK = 1 + (ISP-1)/NTH + NTLOC = 1 + INT(DTMAX/(DTCFL*SIG(IK)/SIG(1))-0.001) + IF ( NT(IP)+NTLOC .LE. NTTARG ) THEN + IAPPRO(ISP) = IP + NT(IP) = NT(IP) + NTLOC + END IF + END IF END DO - END IF + END IF END DO -#endif -! -! 2.c.7 Check if all served -! -#ifdef W3_DIST - IF ( MINVAL(IAPPRO(1:NSPEC)) .GT. 0 ) THEN - EXIT + ! + ! 2.c.7 Check if all served + ! + IF ( MINVAL(IAPPRO(1:NSPEC)) .GT. 0 ) THEN + EXIT ELSE - NTTARG = NTTARG + 1 - IF ( NTTARG .GE. NTTMAX ) EXIT - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8028) + NTTARG = NTTARG + 1 + IF ( NTTARG .GE. NTTMAX ) EXIT + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8028) END IF + ! + END DO + END IF #endif -! -#ifdef W3_DIST - END DO - END IF -#endif -! -!!/DEBUGMPI CALL TEST_MPI_STATUS("Case 14") -#ifdef W3_TIMINGS + + !/DEBUGMPI CALL TEST_MPI_STATUS("Case 14") + if (w3_timings_flag) then CALL PRINT_MY_TIME("After Case 14") -#endif -! 2.c.8 Test output -! -#ifdef W3_T - WRITE (NDST,9020) - DO IP=1, NAPROC - WRITE (NDST,9021) IP, NT(IP), NTTARG - END DO -#endif -! -#ifdef W3_T - WRITE (NDST,9025) - DO IK=NK, 1, -1 - WRITE (NDST,9026) IK, (IAPPRO(ITH+(IK-1)*NTH),ITH=1,MIN(24,NTH)) - IF ( NTH .GT. 24 ) WRITE (NDST,9027) & - (IAPPRO(ITH+(IK-1)*NTH),ITH=25,NTH) - END DO -#endif -! -! 2.c.9 Test if any spectral points are left out -! + end if + ! + ! 2.c.8 Test output + ! + if (w3_t_flag) then + WRITE (NDST,9020) + DO IP=1, NAPROC + WRITE (NDST,9021) IP, NT(IP), NTTARG + END DO + WRITE (NDST,9025) + DO IK=NK, 1, -1 + WRITE (NDST,9026) IK, (IAPPRO(ITH+(IK-1)*NTH),ITH=1,MIN(24,NTH)) + IF ( NTH .GT. 24 ) WRITE (NDST,9027) & + (IAPPRO(ITH+(IK-1)*NTH),ITH=25,NTH) + END DO + end if + ! + ! 2.c.9 Test if any spectral points are left out + ! #ifdef W3_DIST IF ((LPDLIB .eqv. .FALSE.).or.(GTYPE .NE. UNGTYPE)) THEN - DO ISP=1, NSPEC - IF ( IAPPRO(ISP) .EQ. -1. ) GOTO 829 - END DO + DO ISP=1, NSPEC + IF ( IAPPRO(ISP) .EQ. -1. ) GOTO 829 + END DO END IF #endif -! -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 4' - FLUSH(740+IAPROC) -#endif - DEALLOCATE ( NT ) -! -! 3. Model initialization ------------------------------------------- / -! 3.a Read restart file -! - VA(:,:) = 0. + ! + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 4' + end if + DEALLOCATE ( NT ) + ! + ! 3. Model initialization ------------------------------------------- / + ! 3.a Read restart file + ! + VA(:,:) = 0. #ifdef W3_DEBUGMPI - CALL TEST_MPI_STATUS("Case 15") -#endif -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 4.0' - WRITE(740+IAPROC,*) ' 1: min/max/sum(VA)=', minval(VA), maxval(VA), sum(VA) - WRITE(740+IAPROC,*) ' 1: NSEAL=', NSEAL - FLUSH(740+IAPROC) + CALL TEST_MPI_STATUS("Case 15") #endif + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 4.0' + WRITE(740+IAPROC,*) ' 1: min/max/sum(VA)=', minval(VA), maxval(VA), sum(VA) + WRITE(740+IAPROC,*) ' 1: NSEAL=', NSEAL + end if #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before W3IORS call") -#endif -#endif -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) ' After ALL_VA_INTEGRAL_PRINT' - FLUSH(740+IAPROC) -#endif -#ifdef W3_TIMINGS + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before W3IORS call") + end if +#endif + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) ' After ALL_VA_INTEGRAL_PRINT' + end if + if (w3_timings_flag) then CALL PRINT_MY_TIME("Before W3IORS") -#endif - CALL W3IORS ( 'READ', NDS(6), SIG(NK), IMOD) -#ifdef W3_TIMINGS + end if + ! + CALL W3IORS ( 'READ', NDS(6), SIG(NK), IMOD) + ! + if (w3_timings_flag) then CALL PRINT_MY_TIME("After W3IORS") -#endif -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 3a' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif + end if + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 3a') -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) ' 2: min/max/sum(VA)=', minval(VA), maxval(VA), sum(VA) - WRITE(740+IAPROC,*) ' 2: NSEAL=', NSEAL - FLUSH(740+IAPROC) -#endif + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) ' 2: min/max/sum(VA)=', minval(VA), maxval(VA), sum(VA) + WRITE(740+IAPROC,*) ' 2: NSEAL=', NSEAL + end if #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After W3IORS call") -#endif -#endif -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 4.1' - WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA) - FLUSH(740+IAPROC) -#endif - FLCOLD = RSTYPE.LE.1 .OR. RSTYPE.EQ.4 - IF ( IAPROC .EQ. NAPLOG ) THEN - IF (RSTYPE.EQ.0) THEN - WRITE (NDSO,930) 'cold start (idealized).' - ELSE IF ( RSTYPE .EQ. 1 ) THEN - WRITE (NDSO,930) 'cold start (wind).' - ELSE IF ( RSTYPE .EQ. 4 ) THEN - WRITE (NDSO,930) 'cold start (calm).' - ELSE - WRITE (NDSO,930) 'full restart.' - END IF - END IF -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 4.2' - FLUSH(740+IAPROC) -#endif + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After W3IORS call") + end if +#endif + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 4.1' + WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA) + end if + FLCOLD = RSTYPE.LE.1 .OR. RSTYPE.EQ.4 + IF ( IAPROC .EQ. NAPLOG ) THEN + IF (RSTYPE.EQ.0) THEN + WRITE (NDSO,930) 'cold start (idealized).' + ELSE IF ( RSTYPE .EQ. 1 ) THEN + WRITE (NDSO,930) 'cold start (wind).' + ELSE IF ( RSTYPE .EQ. 4 ) THEN + WRITE (NDSO,930) 'cold start (calm).' + ELSE + WRITE (NDSO,930) 'full restart.' + END IF + END IF + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 4.2' + end if #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 4.2") + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 4.2") + end if #endif -#endif -#ifdef W3_TIMINGS + if (w3_timings_flag) then CALL PRINT_MY_TIME("After restart inits") -#endif - -! -! 3.b Compare MAPSTA from grid and restart -! - DO IX=1, NX - DO IY=1, NY + end if + ! + ! 3.b Compare MAPSTA from grid and restart + ! + DO IX=1, NX + DO IY=1, NY IF ( ABS(MAPSTA(IY,IX)).EQ.2 .OR. & ABS(MAPTST(IY,IX)).EQ.2 ) THEN - MAPSTA(IY,IX) = SIGN ( MAPTST(IY,IX) , MAPSTA(IY,IX) ) - END IF - END DO - END DO + MAPSTA(IY,IX) = SIGN ( MAPTST(IY,IX) , MAPSTA(IY,IX) ) + END IF + END DO + END DO -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 3b' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif -! -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 4.3' - FLUSH(740+IAPROC) -#endif + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 3b') + ! + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 4.3' + end if #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 4.3") + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 4.3") + end if #endif -#endif -! -! 3.b2 Set MAPSTA associated to PDLIB -! + ! + ! 3.b2 Set MAPSTA associated to PDLIB + ! #ifdef W3_PDLIB - IF (GTYPE .eq. UNGTYPE) THEN - CALL PDLIB_MAPSTA_INIT(IMOD) - END IF -#endif -! -! 3.c Initialization from wind fields -! - FLIWND = RSTYPE.EQ.1 -#ifdef W3_T - IF ( FLIWND ) WRITE (NDST,9030) -#endif -! -! 3.d Initialization with calm conditions -! -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 5' - FLUSH(740+IAPROC) + IF (GTYPE .eq. UNGTYPE) THEN + CALL PDLIB_MAPSTA_INIT(IMOD) + END IF #endif + ! + ! 3.c Initialization from wind fields + ! + FLIWND = RSTYPE.EQ.1 + if (w3_t_flag) then + IF ( FLIWND ) WRITE (NDST,9030) + end if + ! + ! 3.d Initialization with calm conditions + ! + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 5' + end if #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 5") + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 5") + end if #endif -#endif - IF ( RSTYPE .EQ. 4 ) THEN - VA(:,:) = 0. -#ifdef W3_T + IF ( RSTYPE .EQ. 4 ) THEN + VA(:,:) = 0. + if (w3_t_flag) then WRITE (NDST,9031) -#endif - END IF + end if + END IF -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 4' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif -! -! 3.e Prepare propagation scheme -! - IF ( .NOT. FLCUR ) FLCK = .FALSE. + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 4') + ! + ! 3.e Prepare propagation scheme + ! + IF ( .NOT. FLCUR ) FLCK = .FALSE. #ifdef W3_PDLIB -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3INIT definition of FSREFR and FRFREQ' - WRITE(740+IAPROC,*) 'FSTOTALIMP=', FSTOTALIMP - WRITE(740+IAPROC,*) 'FSREFRACTION=', FSREFRACTION - WRITE(740+IAPROC,*) 'FSFREQSHIFT=', FSFREQSHIFT - WRITE(740+IAPROC,*) 'Before FLCTH=', FLCTH, 'FLCK=', FLCK -#endif - IF (FSTOTALIMP .and. FSREFRACTION) THEN - FLCTH = .FALSE. - END IF - IF (FSTOTALIMP .and. FSFREQSHIFT) THEN - FLCK = .FALSE. - END IF -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) ' After FLCTH=', FLCTH, 'FLCK=', FLCK -#endif -#endif -! -! 4. Set-up output times -------------------------------------------- * -! 4.a Unpack ODAT -! - DO J=1, NOTYPE - J0 = (J-1)*5 - TONEXT(1,J) = ODAT(J0+1) - TONEXT(2,J) = ODAT(J0+2) - DTOUT ( J) = REAL ( ODAT(J0+3) ) - TOLAST(1,J) = ODAT(J0+4) - TOLAST(2,J) = ODAT(J0+5) - END DO -! -! J=8, second stream of restart files - J=8 - J0 = (J-1)*5 - IF(ODAT(J0+1) .NE. 0) THEN - TONEXT(1,J) = ODAT(J0+1) - TONEXT(2,J) = ODAT(J0+2) - DTOUT ( J) = REAL ( ODAT(J0+3) ) - TOLAST(1,J) = ODAT(J0+4) - TOLAST(2,J) = ODAT(J0+5) - FLOUT(8) = .TRUE. - ELSE - FLOUT(8) = .FALSE. - END IF -! -! 4.b Check if output available -! - FLOUT(1) = .FALSE. - FLOGRD = FLGRD - FLOGD = FLGD - DO J=1, NOGRP - DO K=1, NGRPP + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3INIT definition of FSREFR and FRFREQ' + WRITE(740+IAPROC,*) 'FSTOTALIMP=', FSTOTALIMP + WRITE(740+IAPROC,*) 'FSREFRACTION=', FSREFRACTION + WRITE(740+IAPROC,*) 'FSFREQSHIFT=', FSFREQSHIFT + WRITE(740+IAPROC,*) 'Before FLCTH=', FLCTH, 'FLCK=', FLCK + end if + IF (FSTOTALIMP .and. FSREFRACTION) THEN + FLCTH = .FALSE. + END IF + IF (FSTOTALIMP .and. FSFREQSHIFT) THEN + FLCK = .FALSE. + END IF + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) ' After FLCTH=', FLCTH, 'FLCK=', FLCK + end if +#endif + ! + ! 4. Set-up output times -------------------------------------------- * + ! 4.a Unpack ODAT + ! + DO J=1, NOTYPE + J0 = (J-1)*5 + TONEXT(1,J) = ODAT(J0+1) + TONEXT(2,J) = ODAT(J0+2) + DTOUT ( J) = REAL ( ODAT(J0+3) ) + TOLAST(1,J) = ODAT(J0+4) + TOLAST(2,J) = ODAT(J0+5) + END DO + ! + ! J=8, second stream of restart files + J=8 + J0 = (J-1)*5 + IF(ODAT(J0+1) .NE. 0) THEN + TONEXT(1,J) = ODAT(J0+1) + TONEXT(2,J) = ODAT(J0+2) + DTOUT ( J) = REAL ( ODAT(J0+3) ) + TOLAST(1,J) = ODAT(J0+4) + TOLAST(2,J) = ODAT(J0+5) + FLOUT(8) = .TRUE. + ELSE + FLOUT(8) = .FALSE. + END IF + ! + ! 4.b Check if output available + ! + FLOUT(1) = .FALSE. + FLOGRD = FLGRD + FLOGD = FLGD + DO J=1, NOGRP + DO K=1, NGRPP FLOUT(1) = FLOUT(1) .OR. FLOGRD(J,K) - END DO - END DO -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 6' - FLUSH(740+IAPROC) -#endif + END DO + END DO + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 6' + end if #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 6") -#endif -#endif -! - FLOUT(7) = .FALSE. - FLOGR2 = FLGR2 - FLOG2 = FLG2 - DO J=1, NOGRP - DO K=1, NGRPP + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 6") + end if +#endif + ! + FLOUT(7) = .FALSE. + FLOGR2 = FLGR2 + FLOG2 = FLG2 + DO J=1, NOGRP + DO K=1, NGRPP FLOUT(7) = FLOUT(7) .OR. FLOGR2(J,K) - END DO - END DO -! - FLOUT(2) = NPT .GT. 0 -! - FLOUT(3) = .TRUE. -! - FLOUT(4) = .TRUE. -! - FLOUT(5) = FLBPO - IF ( FLBPO ) THEN - CALL W3DMO5 ( IMOD, NDSE, NDST, 4 ) - ELSE - DTOUT(5) = 0. - END IF -! - IX0 = MAX ( 1, IPRT(1) ) - IXN = MIN ( NX, IPRT(2) ) - IXS = MAX ( 1, IPRT(3) ) - IY0 = MAX ( 1, IPRT(4) ) - IYN = MIN ( NY, IPRT(5) ) - IYS = MAX ( 1, IPRT(6) ) - FLFORM = PRTFRM - FLOUT(6) = IX0.LE.IXN .AND. IY0.LE.IYN -! -! 4.c Get first time per output and overall. -! - TOFRST(1) = -1 - TOFRST(2) = 0 -! -! WRITE(*,*) 'We set NOTYPE=0 just for DEBUGGING' -! NOTYPE=0 ! ONLY FOR DEBUGGING PURPOSE -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 7' - FLUSH(740+IAPROC) -#endif + END DO + END DO + ! + FLOUT(2) = NPT .GT. 0 + ! + FLOUT(3) = .TRUE. + ! + FLOUT(4) = .TRUE. + ! + FLOUT(5) = FLBPO + IF ( FLBPO ) THEN + CALL W3DMO5 ( IMOD, NDSE, NDST, 4 ) + ELSE + DTOUT(5) = 0. + END IF + ! + IX0 = MAX ( 1, IPRT(1) ) + IXN = MIN ( NX, IPRT(2) ) + IXS = MAX ( 1, IPRT(3) ) + IY0 = MAX ( 1, IPRT(4) ) + IYN = MIN ( NY, IPRT(5) ) + IYS = MAX ( 1, IPRT(6) ) + FLFORM = PRTFRM + FLOUT(6) = IX0.LE.IXN .AND. IY0.LE.IYN + ! + ! 4.c Get first time per output and overall. + ! + TOFRST(1) = -1 + TOFRST(2) = 0 + ! + ! WRITE(*,*) 'We set NOTYPE=0 just for DEBUGGING' + ! NOTYPE=0 ! ONLY FOR DEBUGGING PURPOSE + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 7' + end if #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 7") -#endif -#endif -#ifdef W3_DEBUGINIT - WRITE(*,*) 'Starting the NOTYPE loop, takes time' -#endif -#ifdef W3_TIMINGS + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 7") + end if +#endif + if (w3_debuginit_flag) then + WRITE(*,*) 'Starting the NOTYPE loop, takes time' + end if + if (w3_timings_flag) then CALL PRINT_MY_TIME("Before NOTYPE loop") -#endif - DO J=1, NOTYPE -! -! ... check time step -! - DTOUT(J) = MAX ( 0. , DTOUT(J) ) - FLOUT(J) = FLOUT(J) .AND. ( DTOUT(J) .GT. 0.5 ) -! -! ... get first time -! - IF ( FLOUT(J) ) THEN + end if + DO J=1, NOTYPE + ! + ! ... check time step + ! + DTOUT(J) = MAX ( 0. , DTOUT(J) ) + FLOUT(J) = FLOUT(J) .AND. ( DTOUT(J) .GT. 0.5 ) + ! + ! ... get first time + ! + IF ( FLOUT(J) ) THEN #ifdef W3_NL5 - IF (J .EQ. 2) TOSNL5 = TONEXT(:, 2) -#endif - TOUT = TONEXT(:,J) - TLST = TOLAST(:,J) -! - DO - DTTST = DSEC21 ( TIME , TOUT ) - IF ( ( J.NE.4 .AND. DTTST.LT.0. ) .OR. & - ( J.EQ.4 .AND. DTTST.LE.0. ) ) THEN - CALL TICK21 ( TOUT, DTOUT(J) ) - ELSE - EXIT + IF (J .EQ. 2) TOSNL5 = TONEXT(:, 2) +#endif + TOUT = TONEXT(:,J) + TLST = TOLAST(:,J) + ! + DO + DTTST = DSEC21 ( TIME , TOUT ) + IF ( ( J.NE.4 .AND. DTTST.LT.0. ) .OR. & + ( J.EQ.4 .AND. DTTST.LE.0. ) ) THEN + CALL TICK21 ( TOUT, DTOUT(J) ) + ELSE + EXIT + END IF + END DO + ! + ! ... reset first time + ! + TONEXT(:,J) = TOUT + ! + ! ... check last time + ! + DTTST = DSEC21 ( TOUT , TLST ) + IF ( DTTST.LT.0.) FLOUT(J) = .FALSE. + ! + ! ... check overall first time + ! + IF ( FLOUT(J) ) THEN + IF ( TOFRST(1).EQ.-1 ) THEN + TOFRST = TOUT + ELSE + DTTST = DSEC21 ( TOUT , TOFRST ) + IF ( DTTST.GT.0.) THEN + TOFRST = TOUT END IF - END DO -! -! ... reset first time -! - TONEXT(:,J) = TOUT -! -! ... check last time -! - DTTST = DSEC21 ( TOUT , TLST ) - IF ( DTTST.LT.0.) FLOUT(J) = .FALSE. -! -! ... check overall first time -! - IF ( FLOUT(J) ) THEN - IF ( TOFRST(1).EQ.-1 ) THEN - TOFRST = TOUT - ELSE - DTTST = DSEC21 ( TOUT , TOFRST ) - IF ( DTTST.GT.0.) THEN - TOFRST = TOUT - END IF - END IF - END IF -! + END IF END IF -! - END DO -! -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 5' -#endif -! -! J=8, second stream of restart files -! - J=8 -! -! ... check time step -! - DTOUT(J) = MAX ( 0. , DTOUT(J) ) - FLOUT(J) = FLOUT(J) .AND. ( DTOUT(J) .GT. 0.5 ) -! -! ... get first time -! - IF ( FLOUT(J) ) THEN - TOUT = TONEXT(:,J) - TLST = TOLAST(:,J) -! - DO - DTTST = DSEC21 ( TIME , TOUT ) - IF ( ( J.NE.4 .AND. DTTST.LT.0. ) .OR. & - ( J.EQ.4 .AND. DTTST.LE.0. ) ) THEN - CALL TICK21 ( TOUT, DTOUT(J) ) - ELSE - EXIT - END IF - END DO -! -! ... reset first time -! - TONEXT(:,J) = TOUT -! -! ... check last time -! - DTTST = DSEC21 ( TOUT , TLST ) - IF ( DTTST.LT.0.) FLOUT(J) = .FALSE. -! -! ... check overall first time -! - IF ( FLOUT(J) ) THEN - IF ( TOFRST(1).EQ.-1 ) THEN - TOFRST = TOUT - ELSE - DTTST = DSEC21 ( TOUT , TOFRST ) - IF ( DTTST.GT.0.) THEN - TOFRST = TOUT - END IF - END IF - END IF -! + ! + END IF ! IF (FLOUT(J)) + ! + END DO ! DO J=1, NOTYPE + ! + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 5') + ! + ! J=8, second stream of restart files + ! + J=8 + ! + ! ... check time step + ! + DTOUT(J) = MAX ( 0. , DTOUT(J) ) + FLOUT(J) = FLOUT(J) .AND. ( DTOUT(J) .GT. 0.5 ) + ! + ! ... get first time + ! + IF ( FLOUT(J) ) THEN + TOUT = TONEXT(:,J) + TLST = TOLAST(:,J) + ! + DO + DTTST = DSEC21 ( TIME , TOUT ) + IF ( ( J.NE.4 .AND. DTTST.LT.0. ) .OR. & + ( J.EQ.4 .AND. DTTST.LE.0. ) ) THEN + CALL TICK21 ( TOUT, DTOUT(J) ) + ELSE + EXIT END IF -! END J=8 -! -#ifdef W3_MEMCHECK - WRITE(740+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 5' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif + END DO + ! + ! ... reset first time + ! + TONEXT(:,J) = TOUT + ! + ! ... check last time + ! + DTTST = DSEC21 ( TOUT , TLST ) + IF ( DTTST.LT.0.) FLOUT(J) = .FALSE. + ! + ! ... check overall first time + ! + IF ( FLOUT(J) ) THEN + IF ( TOFRST(1).EQ.-1 ) THEN + TOFRST = TOUT + ELSE + DTTST = DSEC21 ( TOUT , TOFRST ) + IF ( DTTST.GT.0.) THEN + TOFRST = TOUT + END IF + END IF + END IF + ! + END IF + ! END J=8 + ! + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 5') -#ifdef W3_DEBUGINIT - WRITE(*,*) 'Ending the NOTYPE loop, takes time' -#endif -#ifdef W3_TIMINGS + if (w3_debuginit_flag) then + WRITE(*,*)'Ending the NOTYPE loop, takes time' + end if + if (w3_timings_flag) then CALL PRINT_MY_TIME("After NOTYPE loop") -#endif -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 8' - FLUSH(740+IAPROC) -#endif + end if + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 8' + end if #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.1") -#endif -#endif -! -! 4.d Preprocessing for point output. -! - IF ( FLOUT(2) ) CALL W3IOPP ( NPT, XPT, YPT, PNAMES, IMOD ) + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.1") + end if +#endif + ! + ! 4.d Preprocessing for point output. + ! + IF ( FLOUT(2) ) CALL W3IOPP ( NPT, XPT, YPT, PNAMES, IMOD ) #ifdef W3_PDLIB - CALL DEALLOCATE_PDLIB_GLOBAL(IMOD) -#endif -! -#ifdef W3_T - WRITE (NDST,9040) - DO J=1, 5 - WRITE (NDST,9041) TONEXT(1,J),TONEXT(2,J),DTOUT(J),FLOUT(J) - END DO - WRITE (NDST,9042) - WRITE (NDST,9043) TOFRST -#endif -! -! 5. Define wavenumber grid ----------------------------------------- * -! 5.a Calculate depth -! -#ifdef W3_T - ALLOCATE ( MAPOUT(NX,NY), XOUT(NX,NY) ) - XOUT = -1. -#endif -! - MAPTST = MOD(MAPST2/2,2) - MAPST2 = MAPST2 - 2*MAPTST + CALL DEALLOCATE_PDLIB_GLOBAL(IMOD) +#endif + ! + if (w3_t_flag) then + WRITE (NDST,9040) + DO J=1, 5 + WRITE (NDST,9041) TONEXT(1,J),TONEXT(2,J),DTOUT(J),FLOUT(J) + END DO + WRITE (NDST,9042) + WRITE (NDST,9043) TOFRST + end if + ! + ! 5. Define wavenumber grid ----------------------------------------- * + ! 5.a Calculate depth + ! + if (w3_t_flag) then + ALLOCATE ( MAPOUT(NX,NY), XOUT(NX,NY) ) + XOUT = -1. + end if + ! + MAPTST = MOD(MAPST2/2,2) + MAPST2 = MAPST2 - 2*MAPTST #ifdef W3_PDLIB -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before INIT_GET_JSEA_ISPROC call' - WRITE(740+IAPROC,*) 'allocated(ISEA_TO_JSEA)=', allocated(ISEA_TO_JSEA) - WRITE(740+IAPROC,*) 'NAPROC=', NAPROC - FLUSH(740+IAPROC) -#endif -#endif - -! -!Li For multi-resolution SMC grid, these 1-NX and 1-NY nested loops -!Li may miss the refined cells as they are not 1-1 corresponding to -!Li the (Nx,NY) regular grid. The loop is now modified to run over -!Li full NSEA points. JGLi24Jan2012 -!Li DO IY=1, NY -!Li DO IX=1, NX -!Li ISEA = MAPFS(IY,IX) -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'Debugging the SETUP / WLV' -#endif - DO ISEA=1, NSEA -#ifdef W3_DEBUGSTP - WRITE(740+IAPROC,*) 'ISEA/WLV/ZB=', ISEA, WLV(ISEA), ZB(ISEA) -#endif - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) -#ifdef W3_T - MAPOUT(IX,IY) = MAPSTA(IY,IX) -#endif -!Li IF ( ISEA .NE. 0) THEN - WLVeff=WLV(ISEA) + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'Before INIT_GET_JSEA_ISPROC call' + WRITE(740+IAPROC,*) 'allocated(ISEA_TO_JSEA)=', allocated(ISEA_TO_JSEA) + WRITE(740+IAPROC,*) 'NAPROC=', NAPROC + end if +#endif + ! + !Li For multi-resolution SMC grid, these 1-NX and 1-NY nested loops + !Li may miss the refined cells as they are not 1-1 corresponding to + !Li the (Nx,NY) regular grid. The loop is now modified to run over + !Li full NSEA points. JGLi24Jan2012 + !Li DO IY=1, NY + !Li DO IX=1, NX + !Li ISEA = MAPFS(IY,IX) + if (w3_debugstp_flag) then + WRITE(740+IAPROC,*) 'Debugging the SETUP / WLV' + end if + ! + DO ISEA=1, NSEA + if (w3_debugstp_flag) then + WRITE(740+IAPROC,*) 'ISEA/WLV/ZB=', ISEA, WLV(ISEA), ZB(ISEA) + end if + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + if (w3_t_flag) then + MAPOUT(IX,IY) = MAPSTA(IY,IX) + end if + !Li IF ( ISEA .NE. 0) THEN + WLVeff=WLV(ISEA) #ifdef W3_SETUP IF (DO_CHANGE_WLV) THEN - WLVeff=WLVeff + ZETA_SETUP(ISEA) + WLVeff=WLVeff + ZETA_SETUP(ISEA) END IF #endif - DW(ISEA) = MAX ( 0. , WLVeff-ZB(ISEA) ) -#ifdef W3_T - XOUT(IX,IY) = DW(ISEA) -#endif - IF ( WLVeff-ZB(ISEA) .LE.0. ) THEN - MAPTST(IY,IX) = 1 - MAPSTA(IY,IX) = -ABS(MAPSTA(IY,IX)) -!!/DEBUGINIT WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' JSEA=', JSEA -!!/DEBUGINIT WRITE(740+IAPROC,*) 'NSEA=', NSEA, ' NSEAL=', NSEAL -!!/DEBUGINIT WRITE(740+IAPROC,*) 'IAPROC=', IAPROC, ' ISPROC=', ISPROC -!!/DEBUGINIT FLUSH(740+IAPROC) - END IF -!Li END IF - END DO -!Li END DO - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - WLVeff=WLV(ISEA) + DW(ISEA) = MAX ( 0. , WLVeff-ZB(ISEA) ) + if (w3_t_flag) then + XOUT(IX,IY) = DW(ISEA) + end if + IF ( WLVeff-ZB(ISEA) .LE.0. ) THEN + MAPTST(IY,IX) = 1 + MAPSTA(IY,IX) = -ABS(MAPSTA(IY,IX)) + !!/DEBUGINIT WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' JSEA=', JSEA + !!/DEBUGINIT WRITE(740+IAPROC,*) 'NSEA=', NSEA, ' NSEAL=', NSEAL + !!/DEBUGINIT WRITE(740+IAPROC,*) 'IAPROC=', IAPROC, ' ISPROC=', ISPROC + END IF + !Li END IF + END DO + !Li END DO + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + WLVeff=WLV(ISEA) #ifdef W3_SETUP IF (DO_CHANGE_WLV) THEN - WLVeff=WLVeff + ZETA_SETUP(ISEA) + WLVeff=WLVeff + ZETA_SETUP(ISEA) END IF #endif - DW(ISEA) = MAX ( 0. , WLVeff-ZB(ISEA) ) - IF ( WLVeff-ZB(ISEA) .LE.0. ) THEN -!!/DEBUGINIT WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' JSEA=', JSEA -!!/DEBUGINIT WRITE(740+IAPROC,*) 'NSEA=', NSEA, ' NSEAL=', NSEAL -!!/DEBUGINIT WRITE(740+IAPROC,*) 'IAPROC=', IAPROC, ' ISPROC=', ISPROC -!!/DEBUGINIT FLUSH(740+IAPROC) + DW(ISEA) = MAX ( 0. , WLVeff-ZB(ISEA) ) + IF ( WLVeff-ZB(ISEA) .LE.0. ) THEN + !!/DEBUGINIT WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' JSEA=', JSEA + !!/DEBUGINIT WRITE(740+IAPROC,*) 'NSEA=', NSEA, ' NSEAL=', NSEAL + !!/DEBUGINIT WRITE(740+IAPROC,*) 'IAPROC=', IAPROC, ' ISPROC=', ISPROC VA(:,JSEA) = 0. - END IF - END DO -! + END IF + END DO + ! #ifdef W3_PDLIB - IF ( IAPROC .LE. NAPROC ) THEN - CALL SET_IOBDP_PDLIB - ENDIF + IF ( IAPROC .LE. NAPROC ) THEN + CALL SET_IOBDP_PDLIB + ENDIF #endif -! -#ifdef W3_DEBUGSTP - FLUSH(740+IAPROC) -#endif -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9' - FLUSH(740+IAPROC) -#endif + ! + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9' + end if #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.2") -#endif + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.2") + end if #endif -! -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.1' - WRITE(740+IAPROC,*) ' allocated(MAPTST)=', allocated(MAPTST) - WRITE(740+IAPROC,*) 'NY=', NY, ' NX=', NX - FLUSH(740+IAPROC) -#endif - MAPST2 = MAPST2 + 2*MAPTST -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.2' - FLUSH(740+IAPROC) -#endif -! - DEALLOCATE ( MAPTST ) -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.3' - FLUSH(740+IAPROC) -#endif + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.1' + WRITE(740+IAPROC,*) ' allocated(MAPTST)=', allocated(MAPTST) + WRITE(740+IAPROC,*) 'NY=', NY, ' NX=', NX + end if + MAPST2 = MAPST2 + 2*MAPTST + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.2' + end if + ! + DEALLOCATE ( MAPTST ) + ! + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.3' + end if -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 6' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif -! -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.4' - FLUSH(740+IAPROC) -#endif -#ifdef W3_T - WRITE (NDST,9050) - NX0 = 1 - DO - NXN = MIN ( NX0+NXS-1 , NX ) - CALL PRTBLK (NDST, NX, NY, NX, XOUT, MAPOUT, 0, 0., & - NX0, NXN, 1, 1, NY, 1, 'Depth', 'm') - IF ( NXN .NE. NX ) THEN - NX0 = NX0 + NXS + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 6') + ! + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.4' + end if + if (w3_t_flag) then + WRITE (NDST,9050) + NX0 = 1 + DO + NXN = MIN ( NX0+NXS-1 , NX ) + CALL PRTBLK (NDST, NX, NY, NX, XOUT, MAPOUT, 0, 0., & + NX0, NXN, 1, 1, NY, 1, 'Depth', 'm') + IF ( NXN .NE. NX ) THEN + NX0 = NX0 + NXS ELSE - EXIT + EXIT END IF - END DO - DEALLOCATE ( MAPOUT, XOUT ) -#endif -#ifdef W3_TIMINGS + END DO + DEALLOCATE ( MAPOUT, XOUT ) + end if + if (w3_timings_flag) then CALL PRINT_MY_TIME("Before section 5.b") -#endif -! -! 5.b Fill wavenumber and group velocity arrays. -! -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.5' - FLUSH(740+IAPROC) -#endif - DO IS=0, NSEA -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'IS=', IS - FLUSH(740+IAPROC) -#endif - IF (IS.GT.0) THEN + end if + ! + ! 5.b Fill wavenumber and group velocity arrays. + ! + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.5' + end if + DO IS=0, NSEA + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'IS=', IS + end if + IF (IS.GT.0) THEN DEPTH = MAX ( DMIN , DW(IS) ) - ELSE + ELSE DEPTH = DMIN - END IF -! -#ifdef W3_T1 - WRITE (NDST,9051) IS, DEPTH -#endif -! - DO IK=0, NK+1 -! -! Calculate wavenumbers and group velocities. + END IF + ! + if (w3_t1_flag) then + WRITE (NDST,9051) IS, DEPTH + end if + ! + DO IK=0, NK+1 + ! + ! Calculate wavenumbers and group velocities. CALL WAVNU1(SIG(IK),DEPTH,WN(IK,IS),CG(IK,IS)) -! -#ifdef W3_T1 - WRITE (NDST,9052) IK, TPI/SIG(IK), WN(IK,IS), CG(IK,IS) -#endif -! - END DO - END DO + ! + if (w3_t1_flag) then + WRITE (NDST,9052) IK, TPI/SIG(IK), WN(IK,IS), CG(IK,IS) + end if + ! + END DO + END DO -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.6' - FLUSH(740+IAPROC) -#endif -! -! 6. Initialize arrays ---------------------------------------------- / -! Some initialized in W3IORS -! - UA = 0. - UD = 0. - U10 = 0. - U10D = 0. -! - AS = UNDEF -! - AS (0) = 0. - DW (0) = 0. -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.7' - FLUSH(740+IAPROC) -#endif -! -! 7. Write info to log file ----------------------------------------- / -! - IF ( IAPROC .EQ. NAPLOG ) THEN -! - WRITE (NDSO,970) GNAME - IF ( FLLEV ) WRITE (NDSO,971) 'Prescribed' - IF (.NOT. FLLEV ) WRITE (NDSO,971) 'No' - IF ( FLCUR ) WRITE (NDSO,972) 'Prescribed' - IF (.NOT. FLCUR ) WRITE (NDSO,972) 'No' - IF ( FLWIND ) WRITE (NDSO,973) 'Prescribed' - IF (.NOT. FLWIND) WRITE (NDSO,973) 'No' - IF ( FLICE ) WRITE (NDSO,974) 'Prescribed' - IF (.NOT. FLICE ) WRITE (NDSO,974) 'No' - IF ( FLTAUA ) WRITE (NDSO,988) 'Prescribed' - IF (.NOT. FLTAUA) WRITE (NDSO,988) 'No' - IF ( FLRHOA ) WRITE (NDSO,989) 'Prescribed' - IF (.NOT. FLRHOA) WRITE (NDSO,989) 'No' -! - IF ( FLMDN ) WRITE (NDSO,9972) 'Prescribed' - IF (.NOT. FLMDN ) WRITE (NDSO,9972) 'No' - IF ( FLMTH ) WRITE (NDSO,9971) 'Prescribed' - IF (.NOT. FLMTH ) WRITE (NDSO,9971) 'No' - IF ( FLMVS ) WRITE (NDSO,9970) 'Prescribed' - IF (.NOT. FLMVS ) WRITE (NDSO,9970) 'No' + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.6' + end if + ! + ! 6. Initialize arrays ---------------------------------------------- / + ! Some initialized in W3IORS + ! + UA = 0. + UD = 0. + U10 = 0. + U10D = 0. + ! + AS = UNDEF + ! + AS (0) = 0. + DW (0) = 0. + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.7' + end if + ! + ! 7. Write info to log file ----------------------------------------- / + ! + IF ( IAPROC .EQ. NAPLOG ) THEN + ! + WRITE (NDSO,970) GNAME + IF ( FLLEV ) WRITE (NDSO,971) 'Prescribed' + IF (.NOT. FLLEV ) WRITE (NDSO,971) 'No' + IF ( FLCUR ) WRITE (NDSO,972) 'Prescribed' + IF (.NOT. FLCUR ) WRITE (NDSO,972) 'No' + IF ( FLWIND ) WRITE (NDSO,973) 'Prescribed' + IF (.NOT. FLWIND) WRITE (NDSO,973) 'No' + IF ( FLICE ) WRITE (NDSO,974) 'Prescribed' + IF (.NOT. FLICE ) WRITE (NDSO,974) 'No' + IF ( FLTAUA ) WRITE (NDSO,988) 'Prescribed' + IF (.NOT. FLTAUA) WRITE (NDSO,988) 'No' + IF ( FLRHOA ) WRITE (NDSO,989) 'Prescribed' + IF (.NOT. FLRHOA) WRITE (NDSO,989) 'No' + ! + IF ( FLMDN ) WRITE (NDSO,9972) 'Prescribed' + IF (.NOT. FLMDN ) WRITE (NDSO,9972) 'No' + IF ( FLMTH ) WRITE (NDSO,9971) 'Prescribed' + IF (.NOT. FLMTH ) WRITE (NDSO,9971) 'No' + IF ( FLMVS ) WRITE (NDSO,9970) 'Prescribed' + IF (.NOT. FLMVS ) WRITE (NDSO,9970) 'No' - IF ( FLIC1 ) WRITE (NDSO,9973) 'Prescribed' - IF (.NOT. FLIC1 ) WRITE (NDSO,9973) 'No' - IF ( FLIC2 ) WRITE (NDSO,9974) 'Prescribed' - IF (.NOT. FLIC2 ) WRITE (NDSO,9974) 'No' - IF ( FLIC3 ) WRITE (NDSO,9975) 'Prescribed' - IF (.NOT. FLIC3 ) WRITE (NDSO,9975) 'No' - IF ( FLIC4 ) WRITE (NDSO,9976) 'Prescribed' - IF (.NOT. FLIC4 ) WRITE (NDSO,9976) 'No' - IF ( FLIC5 ) WRITE (NDSO,9977) 'Prescribed' - IF (.NOT. FLIC5 ) WRITE (NDSO,9977) 'No' + IF ( FLIC1 ) WRITE (NDSO,9973) 'Prescribed' + IF (.NOT. FLIC1 ) WRITE (NDSO,9973) 'No' + IF ( FLIC2 ) WRITE (NDSO,9974) 'Prescribed' + IF (.NOT. FLIC2 ) WRITE (NDSO,9974) 'No' + IF ( FLIC3 ) WRITE (NDSO,9975) 'Prescribed' + IF (.NOT. FLIC3 ) WRITE (NDSO,9975) 'No' + IF ( FLIC4 ) WRITE (NDSO,9976) 'Prescribed' + IF (.NOT. FLIC4 ) WRITE (NDSO,9976) 'No' + IF ( FLIC5 ) WRITE (NDSO,9977) 'Prescribed' + IF (.NOT. FLIC5 ) WRITE (NDSO,9977) 'No' - IF ( FLOUT(1) ) THEN - WRITE (NDSO,975) - DO J=1,NOGRP - DO K=1,NGRPP + IF ( FLOUT(1) ) THEN + WRITE (NDSO,975) + DO J=1,NOGRP + DO K=1,NGRPP IF ( FLOGRD(J,K) ) WRITE (NDSO,976) IDOUT(J,K) - END DO - END DO - END IF -! - IF ( FLOUT(7) ) THEN - WRITE (NDSO,987) - DO J=1,NOGRP - DO K=1,NGRPP + END DO + END DO + END IF + ! + IF ( FLOUT(7) ) THEN + WRITE (NDSO,987) + DO J=1,NOGRP + DO K=1,NGRPP IF ( FLOGR2(J,K) ) WRITE (NDSO,976) IDOUT(J,K) - END DO - END DO - END IF -! - IF ( FLOUT(2) ) THEN - WRITE (NDSO,977) NOPTS - IF ( NOPTS .EQ. 0 ) THEN - WRITE (NDSO,978) + END DO + END DO + END IF + ! + IF ( FLOUT(2) ) THEN + WRITE (NDSO,977) NOPTS + IF ( NOPTS .EQ. 0 ) THEN + WRITE (NDSO,978) + ELSE + IF ( FLAGLL ) THEN + WRITE (NDSO,979) + ELSE + WRITE (NDSO,985) + END IF + DO IP=1, NOPTS + IF ( FLAGLL ) THEN + WRITE (NDSO,980) IP, FACTOR*PTLOC(1,IP), & + FACTOR*PTLOC(2,IP), PTNME(IP) ELSE - IF ( FLAGLL ) THEN - WRITE (NDSO,979) - ELSE - WRITE (NDSO,985) - END IF - DO IP=1, NOPTS - IF ( FLAGLL ) THEN - WRITE (NDSO,980) IP, FACTOR*PTLOC(1,IP), & - FACTOR*PTLOC(2,IP), PTNME(IP) - ELSE - WRITE (NDSO,986) IP, FACTOR*PTLOC(1,IP), & - FACTOR*PTLOC(2,IP), PTNME(IP) - END IF - END DO + WRITE (NDSO,986) IP, FACTOR*PTLOC(1,IP), & + FACTOR*PTLOC(2,IP), PTNME(IP) END IF - END IF -! - CALL STME21 ( TIME , DTME21 ) - WRITE (NDSO,981) DTME21 - IF (FLLEV) THEN - CALL STME21 ( TLEV , DTME21 ) - WRITE (NDSO,982) DTME21 - END IF - IF (FLICE) THEN - CALL STME21 ( TICE , DTME21 ) - WRITE (NDSO,983) DTME21 - END IF - IF (FLRHOA) THEN - CALL STME21 ( TRHO , DTME21 ) - WRITE (NDSO,990) DTME21 - END IF -! - WRITE (NDSO,984) -! - END IF -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.8' - FLUSH(740+IAPROC) -#endif -! - IF ( NOPTS .EQ. 0 ) FLOUT(2) = .FALSE. + END DO + END IF + END IF + ! + CALL STME21 ( TIME , DTME21 ) + WRITE (NDSO,981) DTME21 + IF (FLLEV) THEN + CALL STME21 ( TLEV , DTME21 ) + WRITE (NDSO,982) DTME21 + END IF + IF (FLICE) THEN + CALL STME21 ( TICE , DTME21 ) + WRITE (NDSO,983) DTME21 + END IF + IF (FLRHOA) THEN + CALL STME21 ( TRHO , DTME21 ) + WRITE (NDSO,990) DTME21 + END IF + ! + WRITE (NDSO,984) + ! + END IF + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.8' + end if + ! + IF ( NOPTS .EQ. 0 ) FLOUT(2) = .FALSE. -#ifdef W3_MEMCHECK - WRITE(10000+IAPROC,*) 'memcheck_____:', 'WW3_INIT SECTION 7 - After allocation of group velocities' - call getMallocInfo(mallinfos) - call printMallInfo(10000+IAPROC,mallInfos) -#endif -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.9' - FLUSH(740+IAPROC) -#endif -! -! Boundary set up for the directions -! + call print_memcheck(10000+IAPROC, 'memcheck_____:'//' WW3_INIT SECTION 7 - After allocation of group velocities') + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.9' + end if + ! + ! Boundary set up for the directions + ! #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.3") -#endif -#endif -!!/PDLIB CALL VA_SETUP_IOBPD -#ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.4") -#endif -#endif -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.10' - FLUSH(740+IAPROC) -#endif -! -! 8. Final MPI set up ----------------------------------------------- / -! -#ifdef W3_MPI - CALL W3MPII ( IMOD ) -#endif -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'After W3MPII' - FLUSH(740+IAPROC) + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.3") + end if + !/PDLIB CALL VA_SETUP_IOBPD + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3INIT, step 8.4") + end if +#endif + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3INIT, aft BLOCK_SOLVER_INIT, step 9.10' + end if + ! + ! 8. Final MPI set up ----------------------------------------------- / + ! +#ifdef W3_MPI + CALL W3MPII ( IMOD ) + ! + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'After W3MPII' + end if + ! + CALL W3MPIO ( IMOD ) + ! + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'After W3MPIO' + end if + ! + IF ( FLOUT(2) ) CALL W3MPIP ( IMOD ) + ! + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'After W3MPIP' + end if + ! #endif -#ifdef W3_MPI - CALL W3MPIO ( IMOD ) -#endif -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'After W3MPIO' - FLUSH(740+IAPROC) -#endif -#ifdef W3_MPI - IF ( FLOUT(2) ) CALL W3MPIP ( IMOD ) -#endif -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'After W3MPIP' - FLUSH(740+IAPROC) -#endif -! #ifdef W3_PDLIB -#ifdef W3_DEBUGINIT - CALL PRINT_WN_STATISTIC("W3INIT leaving") + if (w3_debuginit_flag) then + CALL PRINT_WN_STATISTIC("W3INIT leaving") + end if #endif -#endif -#ifdef W3_TIMINGS + if (w3_timings_flag) then CALL PRINT_MY_TIME("Leaving W3INIT") -#endif - RETURN -! -! Escape locations read errors : -! + end if + RETURN + ! + ! Escape locations read errors : + ! #ifdef W3_DIST - 820 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8020) NSEA, NAPROC - CALL EXTCDE ( 820 ) -#endif -! -#ifdef W3_DIST - 821 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8021) NSPEC, NAPROC - CALL EXTCDE ( 821 ) -#endif -! -#ifdef W3_DIST - 829 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8029) - CALL EXTCDE ( 829 ) +820 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8020) NSEA, NAPROC + CALL EXTCDE ( 820 ) + ! + ! W3_DIST +821 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8021) NSPEC, NAPROC + CALL EXTCDE ( 821 ) + ! + ! W3_DIST +829 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8029) + CALL EXTCDE ( 829 ) #endif -! - 888 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8000) IERR - CALL EXTCDE ( 1 ) -! - 889 CONTINUE -! === no process number filtering for test file !!! === - WRITE (NDSE,8001) IERR - CALL EXTCDE ( 2 ) -! -! Formats -! - 900 FORMAT ( ' WAVEWATCH III log file ', & - ' version ',A/ & - ' ==================================', & - '==================================='/ & - 50X,'date : ',A10/50X,'time : ',A8) - 920 FORMAT (/' Model definition file read.') - 930 FORMAT ( ' Restart file read; ',A) -! - 970 FORMAT (/' Grid name : ',A) - 971 FORMAT (/' ',A,' water levels.') - 972 FORMAT ( ' ',A,' curents.') - 973 FORMAT ( ' ',A,' winds.') - 974 FORMAT ( ' ',A,' ice fields.') - 988 FORMAT ( ' ',A,' momentum') - 989 FORMAT ( ' ',A,' air density') - 9972 FORMAT( ' ',A,' mud density.') - 9971 FORMAT( ' ',A,' mud thickness.') - 9970 FORMAT( ' ',A,' mud viscosity.') - 9973 FORMAT( ' ',A,' ice parameter 1') - 9974 FORMAT( ' ',A,' ice parameter 2') - 9975 FORMAT( ' ',A,' ice parameter 3') - 9976 FORMAT( ' ',A,' ice parameter 4') - 9977 FORMAT( ' ',A,' ice parameter 5') - -! - 975 FORMAT (/' Gridded output fields : '/ & - '--------------------------------------------------') - 976 FORMAT ( ' ',A) -! - 977 FORMAT (/' Point output requested for',I6,' points : '/ & - '------------------------------------------') - 978 FORMAT (/' Point output disabled') - 979 FORMAT & - (/' point | longitude | latitude | name '/ & - ' --------|-------------|-------------|----------------') - 985 FORMAT & - (/' point | X | Y | name '/ & - ' --------|-------------|-------------|----------------') - 980 FORMAT ( 5X,I5,' |',2(F10.2,' |'),2X,A) - 986 FORMAT ( 5X,I5,' |',2(F8.1,'E3 |'),2X,A) -! - 981 FORMAT (/' Initial time : ',A) - 982 FORMAT ( ' Water level time : ',A) - 983 FORMAT ( ' Ice field time : ',A) - 990 FORMAT ( ' Air density time : ',A) -! - 984 FORMAT (// & - 37X,' | input | output |'/ & - 37X,' |-----------------------|------------------|'/ & - 2X,' step | pass | date time |', & - ' b w l c t r i i1 i5 d | g p t r b f c r2 |'/ & - 2X,'--------|------|---------------------|', & - '-----------------------|------------------|'/ & - 2X,'--------+------+---------------------+', & - '---------------------------+--------------+') - 987 FORMAT (/' Coupling output fields : '/ & - '--------------------------------------------------') -! - 8000 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & - ' ERROR IN OPENING LOG FILE'/ & - ' IOSTAT =',I5/) - 8001 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & - ' ERROR IN OPENING TEST FILE'/ & - ' IOSTAT =',I5/) - 8002 FORMAT (/' *** WAVEWATCH III WARNING IN W3INIT : '/ & - ' SIGNIFICANT PART OF RESOURCES RESERVED FOR', & - ' OUTPUT :',F6.1,'%'/) -#ifdef W3_DIST - 8020 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & - ' NUMBER OF SEA POINTS LESS THAN NUMBER OF PROC.'/ & - ' NSEA, NAPROC =',2I8/) - 8021 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & - ' NUMBER OF SPECTRAL POINTS LESS THAN NUMBER OF PROC.'/ & - ' NSPEC, NAPROC =',2I8/) - 8028 FORMAT (/' *** WAVEWATCH III WARNING IN W3INIT : '/ & - ' INCREASING TARGET IN MPP PROPAGATION MAP.'/ & - ' IMBALANCE BETWEEN OVERALL AND CFL TIME STEPS'/) - 8029 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & - ' SOMETHING WRONG WITH MPP PROPAGATION MAP.'/ & - ' CALL HENDRIK !!!'/) -#endif -! -#ifdef W3_T - 9000 FORMAT ( 'TEST W3INIT: MOD. NR. AND FILE EXT.: ',I4,' [',A,']') - 9001 FORMAT ( ' NR. OF PROCESSORS : ',3I4/ & - ' ASSIGNED PROCESSORS ',9I4) - 9002 FORMAT ( ' DATA SET NUMBERS : ',4I4) - 9003 FORMAT ( ' LOG FILE : [',A,']'/ & - ' TEST FILE : [',A,']') -#endif -! -#ifdef W3_T - 9020 FORMAT (' TEST W3INIT : IP, NTTOT, NTTARG :') - 9021 FORMAT ( ' ',3I8) - 9025 FORMAT (' TEST W3INIT : MPP PROPAGATION MAP SPECTRAL COMP.') - 9026 FORMAT (4X,I4,2X,24I4) - 9027 FORMAT (10X,24I4) -#endif -! -#ifdef W3_T - 9030 FORMAT (' TEST W3INIT : INITIALIZATION USING WINDS, ', & - 'PERFORMED IN W3WAVE') - 9031 FORMAT (' TEST W3INIT : STARTING FROM CALM CONDITIONS') -#endif -! -#ifdef W3_T - 9040 FORMAT (' TEST W3INIT : OUTPUT DATA, FIRST TIME, STEP, FLAG') - 9041 FORMAT (' ',I9.8,I7.6,F8.1,3X,L1) - 9042 FORMAT (' TEST W3INIT : FIRST TIME :') - 9043 FORMAT (' ',I9.8,I7.6) -#endif -! -#ifdef W3_T - 9050 FORMAT (' TEST W3INIT : INITIAL DEPTHS') -#endif -#ifdef W3_T1 - 9051 FORMAT (' TEST W3INIT : ISEA =',I6,' DEPTH =',F7.1, & - ' IK, T, K, CG :') - 9052 FORMAT (' ',I3,F8.2,F8.4,F8.2) -#endif -!/ -!/ End of W3INIT ----------------------------------------------------- / -!/ - END SUBROUTINE W3INIT -!/ ------------------------------------------------------------------- / - SUBROUTINE W3MPII ( IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 11-May-2007 | -!/ +-----------------------------------+ -!/ -!/ 04-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ Taken out of W3WAVE. -!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) -!/ 13-Jun-2006 : Splitting STORE in G/SSTORE. ( version 3.09 ) -!/ 11-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ -! 1. Purpose : -! -! Perform initializations for MPI version of model. -! Data transpose only. -! -! 2. Method : -! -! Some derived data types are defined. All communiction in -! W3GATH, W3SCAT and W3WAVE are initialized so that all -! communication can be performed with single MPI_STARTALL, -! MPI_TESTALL and MPI_WAITALL calls. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! -! MPI_TYPE_VECTOR, MPI_TYPE_COMMIT -! Subr. mpif.h MPI derived data type routines. -! -! MPI_SEND_INIT, MPI_RECV_INIT -! Subr. mpif.h MPI persistent communication calls. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3INIT Subr. W3INITMD Wave model initialization routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - Basic MPP set up partially performed in W3INIT. -! - Each processor has to be able to send out individual error -! messages in this routine ! -! - No testing on IMOD, since only called by W3INIT. -! - In version 3.09 STORE was split into a send and receive -! buffer, to avoid/reduce possible conflicts between the FORTRAN -! and MPI standards when a gather is posted in a given buffer -! right after a send is completed. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! !/MPI MPI communication calls. -! -! !/S Subroutine tracing, -! !/T Test output, general. -! !/MPIT Test output, MPI communications details. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE W3GDATMD, ONLY: NSEA - USE W3ADATMD, ONLY: NSEALM - USE W3GDATMD, ONLY: GTYPE, UNGTYPE - USE CONSTANTS, ONLY: LPDLIB -#ifdef W3_MPI - USE W3GDATMD, ONLY: NSPEC - USE W3WDATMD, ONLY: VA - USE W3ADATMD, ONLY: MPI_COMM_WAVE, WW3_FIELD_VEC, & - WW3_SPEC_VEC, IAPPRO, WADATS, & - NRQSG1, IRQSG1, NRQSG2, IRQSG2, & - GSTORE, SSTORE, MPIBUF, BSTAT, & - BISPL, ISPLOC, IBFLOC, NSPLOC -#endif - USE W3ODATMD, ONLY: NDST, NAPROC, IAPROC -!/ - IMPLICIT NONE -! -#ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: NXXXX -#ifdef W3_MPI - INTEGER :: IERR_MPI, ISP, IH, ITARG, & - IERR1, IERR2, IP -#endif -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3MPII') -#endif -! -! 1. Set up derived data types -------------------------------------- / -! -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3MPII, step 1' - FLUSH(740+IAPROC) -#endif - NXXXX = NSEALM * NAPROC -! -#ifdef W3_MPI - CALL MPI_TYPE_VECTOR ( NSEALM, 1, NAPROC, MPI_REAL, & - WW3_FIELD_VEC, IERR_MPI ) -#endif -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3MPII, step 1' - FLUSH(740+IAPROC) -#endif -#ifdef W3_MPI - CALL MPI_TYPE_VECTOR ( NSEALM, 1, NSPEC, MPI_REAL, & - WW3_SPEC_VEC, IERR_MPI ) -#endif -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3MPII, step 1' - FLUSH(740+IAPROC) -#endif -#ifdef W3_MPI - CALL MPI_TYPE_COMMIT ( WW3_FIELD_VEC, IERR_MPI ) -#endif -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3MPII, step 1' - FLUSH(740+IAPROC) -#endif -#ifdef W3_MPI - CALL MPI_TYPE_COMMIT ( WW3_SPEC_VEC, IERR_MPI ) -#endif -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3MPII, step 1' - FLUSH(740+IAPROC) -#endif -! -#ifdef W3_MPIT - WRITE (NDST,9010) WW3_FIELD_VEC, WW3_SPEC_VEC -#endif -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3MPII, step 1' - FLUSH(740+IAPROC) -#endif -! -#ifdef W3_MPI - IF( IAPROC .GT. NAPROC ) THEN - NSPLOC = 0 - NRQSG1 = 0 - NRQSG2 = 0 -#endif -#ifdef W3_MPIT + ! +888 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,8000) IERR + CALL EXTCDE ( 1 ) + ! +889 CONTINUE + ! === no process number filtering for test file !!! === + WRITE (NDSE,8001) IERR + CALL EXTCDE ( 2 ) + ! + ! Formats + ! +900 FORMAT ( ' WAVEWATCH III log file ', & + ' version ',A/ & + ' ==================================', & + '==================================='/ & + 50X,'date : ',A10/50X,'time : ',A8) +920 FORMAT (/' Model definition file read.') +930 FORMAT ( ' Restart file read; ',A) +970 FORMAT (/' Grid name : ',A) +971 FORMAT (/' ',A,' water levels.') +972 FORMAT ( ' ',A,' curents.') +973 FORMAT ( ' ',A,' winds.') +974 FORMAT ( ' ',A,' ice fields.') +988 FORMAT ( ' ',A,' momentum') +989 FORMAT ( ' ',A,' air density') +9972 FORMAT( ' ',A,' mud density.') +9971 FORMAT( ' ',A,' mud thickness.') +9970 FORMAT( ' ',A,' mud viscosity.') +9973 FORMAT( ' ',A,' ice parameter 1') +9974 FORMAT( ' ',A,' ice parameter 2') +9975 FORMAT( ' ',A,' ice parameter 3') +9976 FORMAT( ' ',A,' ice parameter 4') +9977 FORMAT( ' ',A,' ice parameter 5') + ! +975 FORMAT (/ ' Gridded output fields : '/ & + '--------------------------------------------------') +976 FORMAT ( ' ',A) + ! +977 FORMAT (/' Point output requested for',I6,' points : '/ & + '------------------------------------------') +978 FORMAT (/' Point output disabled') +979 FORMAT & + (/' point | longitude | latitude | name '/ & + ' --------|-------------|-------------|----------------') +985 FORMAT & + (/' point | X | Y | name '/ & + ' --------|-------------|-------------|----------------') +980 FORMAT ( 5X,I5,' |',2(F10.2,' |'),2X,A) +986 FORMAT ( 5X,I5,' |',2(F8.1,'E3 |'),2X,A) + ! +981 FORMAT (/' Initial time : ',A) +982 FORMAT ( ' Water level time : ',A) +983 FORMAT ( ' Ice field time : ',A) +990 FORMAT ( ' Air density time : ',A) + ! +984 FORMAT (// & + 37X,' | input | output |'/ & + 37X,' |-----------------------|------------------|'/ & + 2X,' step | pass | date time |', & + ' b w l c t r i i1 i5 d | g p t r b f c r2 |'/ & + 2X,'--------|------|---------------------|', & + '-----------------------|------------------|'/ & + 2X,'--------+------+---------------------+', & + '---------------------------+--------------+') +987 FORMAT (/' Coupling output fields : '/ & + '--------------------------------------------------') + ! +8000 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & + ' ERROR IN OPENING LOG FILE'/ & + ' IOSTAT =',I5/) +8001 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & + ' ERROR IN OPENING TEST FILE'/ & + ' IOSTAT =',I5/) +8002 FORMAT (/' *** WAVEWATCH III WARNING IN W3INIT : '/ & + ' SIGNIFICANT PART OF RESOURCES RESERVED FOR', & + ' OUTPUT :',F6.1,'%'/) +8020 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & + ' NUMBER OF SEA POINTS LESS THAN NUMBER OF PROC.'/ & + ' NSEA, NAPROC =',2I8/) +8021 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & + ' NUMBER OF SPECTRAL POINTS LESS THAN NUMBER OF PROC.'/ & + ' NSPEC, NAPROC =',2I8/) +8028 FORMAT (/' *** WAVEWATCH III WARNING IN W3INIT : '/ & + ' INCREASING TARGET IN MPP PROPAGATION MAP.'/ & + ' IMBALANCE BETWEEN OVERALL AND CFL TIME STEPS'/) +8029 FORMAT (/' *** WAVEWATCH III ERROR IN W3INIT : '/ & + ' SOMETHING WRONG WITH MPP PROPAGATION MAP.'/ & + ' CALL HENDRIK !!!'/) +9000 FORMAT ( ' TEST W3INIT: MOD. NR. AND FILE EXT.: ',I4,' [',A,']') +9001 FORMAT ( ' NR. OF PROCESSORS : ',3I4/ & + ' ASSIGNED PROCESSORS ',9I4) +9002 FORMAT ( ' DATA SET NUMBERS : ',4I4) +9003 FORMAT ( ' LOG FILE : [',A,']'/ & + ' TEST FILE : [',A,']') +9020 FORMAT ( ' TEST W3INIT : IP, NTTOT, NTTARG :') +9021 FORMAT ( ' ',3I8) +9025 FORMAT ( ' TEST W3INIT : MPP PROPAGATION MAP SPECTRAL COMP.') +9026 FORMAT (4X,I4,2X,24I4) +9027 FORMAT (10X,24I4) +9030 FORMAT (' TEST W3INIT : INITIALIZATION USING WINDS, ', & + 'PERFORMED IN W3WAVE') +9031 FORMAT (' TEST W3INIT : STARTING FROM CALM CONDITIONS') +9040 FORMAT (' TEST W3INIT : OUTPUT DATA, FIRST TIME, STEP, FLAG') +9041 FORMAT (' ',I9.8,I7.6,F8.1,3X,L1) +9042 FORMAT (' TEST W3INIT : FIRST TIME :') +9043 FORMAT (' ',I9.8,I7.6) +9050 FORMAT (' TEST W3INIT : INITIAL DEPTHS') +9051 FORMAT (' TEST W3INIT : ISEA =',I6,' DEPTH =',F7.1, & + ' IK, T, K, CG :') +9052 FORMAT (' ',I3,F8.2,F8.4,F8.2) + !/ + !/ End of W3INIT ----------------------------------------------------- / + !/ + END SUBROUTINE W3INIT + !/ ------------------------------------------------------------------- / + SUBROUTINE W3MPII ( IMOD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 11-May-2007 | + !/ +-----------------------------------+ + !/ + !/ 04-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) + !/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ Taken out of W3WAVE. + !/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) + !/ 13-Jun-2006 : Splitting STORE in G/SSTORE. ( version 3.09 ) + !/ 11-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ + ! 1. Purpose : + ! + ! Perform initializations for MPI version of model. + ! Data transpose only. + ! + ! 2. Method : + ! + ! Some derived data types are defined. All communiction in + ! W3GATH, W3SCAT and W3WAVE are initialized so that all + ! communication can be performed with single MPI_STARTALL, + ! MPI_TESTALL and MPI_WAITALL calls. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! + ! MPI_TYPE_VECTOR, MPI_TYPE_COMMIT + ! Subr. mpif.h MPI derived data type routines. + ! + ! MPI_SEND_INIT, MPI_RECV_INIT + ! Subr. mpif.h MPI persistent communication calls. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3INIT Subr. W3INITMD Wave model initialization routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - Basic MPP set up partially performed in W3INIT. + ! - Each processor has to be able to send out individual error + ! messages in this routine ! + ! - No testing on IMOD, since only called by W3INIT. + ! - In version 3.09 STORE was split into a send and receive + ! buffer, to avoid/reduce possible conflicts between the FORTRAN + ! and MPI standards when a gather is posted in a given buffer + ! right after a send is completed. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! !/MPI MPI communication calls. + ! + ! !/S Subroutine tracing, + ! !/T Test output, general. + ! !/MPIT Test output, MPI communications details. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3SERVMD, ONLY: STRACE ! W3_S + USE W3GDATMD, ONLY: NSEA + USE W3ADATMD, ONLY: NSEALM + USE W3GDATMD, ONLY: GTYPE, UNGTYPE + USE CONSTANTS, ONLY: LPDLIB + USE W3GDATMD, ONLY: NSPEC ! W3_MPI + USE W3WDATMD, ONLY: VA ! W3_MPI + USE W3ADATMD, ONLY: MPI_COMM_WAVE, WW3_FIELD_VEC ! W3_MPI + USE W3ADATMD, ONLY: WW3_SPEC_VEC, IAPPRO, WADATS ! W3_MPI + USE W3ADATMD, ONLY: NRQSG1, IRQSG1, NRQSG2, IRQSG2 ! W3_MPI + USE W3ADATMD, ONLY: GSTORE, SSTORE, MPIBUF, BSTAT ! W3_MPI + USE W3ADATMD, ONLY: BISPL, ISPLOC, IBFLOC, NSPLOC ! W3_MPI + USE W3ODATMD, ONLY: NDST, NAPROC, IAPROC ! W3_MPI + !/ + ! +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: NXXXX + INTEGER :: IERR_MPI, ISP, IH, ITARG, IERR1, IERR2, IP ! W3_MPI + INTEGER :: IENT = 0 ! W3_S + !/ + !/ ------------------------------------------------------------------- / + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'W3MPII') + end if + ! + ! 1. Set up derived data types -------------------------------------- / + ! + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3MPII, step 1' + end if + NXXXX = NSEALM * NAPROC + ! +#ifdef W3_MPI + CALL MPI_TYPE_VECTOR ( NSEALM, 1, NAPROC, MPI_REAL, WW3_FIELD_VEC, IERR_MPI ) + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3MPII, step 1' + end if + CALL MPI_TYPE_VECTOR ( NSEALM, 1, NSPEC, MPI_REAL, WW3_SPEC_VEC, IERR_MPI ) + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3MPII, step 1' + end if + CALL MPI_TYPE_COMMIT ( WW3_FIELD_VEC, IERR_MPI ) + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3MPII, step 1' + end if + CALL MPI_TYPE_COMMIT ( WW3_SPEC_VEC, IERR_MPI ) + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3MPII, step 1' + end if + ! + if (w3_mpit_flag) then + WRITE (NDST,9010) WW3_FIELD_VEC, WW3_SPEC_VEC + end if + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3MPII, step 1' + end if + IF( IAPROC .GT. NAPROC ) THEN + NSPLOC = 0 + NRQSG1 = 0 + NRQSG2 = 0 + if (w3_mpit_flag) then WRITE (NDST,9011) + end if + RETURN + END IF #endif -#ifdef W3_MPI - RETURN - END IF -#endif -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3MPII, step 1' - FLUSH(740+IAPROC) -#endif -! -! 2. Set up scatters and gathers for W3WAVE ------------------------- / -! ( persistent communication calls ) -! + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3MPII, step 1' + end if + ! + ! 2. Set up scatters and gathers for W3WAVE ------------------------- / + ! ( persistent communication calls ) + ! #ifdef W3_DIST - IF ((LPDLIB .eqv. .FALSE.).or.(GTYPE .NE. UNGTYPE)) THEN -#endif -#ifdef W3_MPI - NSPLOC = 0 - DO ISP=1, NSPEC - IF ( IAPPRO(ISP) .EQ. IAPROC ) NSPLOC = NSPLOC + 1 - END DO -#endif -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3MPII, step 1' - FLUSH(740+IAPROC) + IF ((LPDLIB .eqv. .FALSE.).or.(GTYPE .NE. UNGTYPE)) THEN #endif -! #ifdef W3_MPI - NRQSG1 = NSPEC - NSPLOC - ALLOCATE ( WADATS(IMOD)%IRQSG1(MAX(1,NRQSG1),2) ) - IRQSG1 => WADATS(IMOD)%IRQSG1 - IH = 0 -#endif -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3MPII, step 1' - FLUSH(740+IAPROC) -#endif -! -#ifdef W3_MPIT - WRITE (NDST,9021) -#endif -#ifdef W3_DEBUGINIT + NSPLOC = 0 + DO ISP=1, NSPEC + IF ( IAPPRO(ISP) .EQ. IAPROC ) NSPLOC = NSPLOC + 1 + END DO + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3MPII, step 1' + end if + NRQSG1 = NSPEC - NSPLOC + ALLOCATE ( WADATS(IMOD)%IRQSG1(MAX(1,NRQSG1),2) ) + IRQSG1 => WADATS(IMOD)%IRQSG1 + IH = 0 + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3MPII, step 1' + end if + if (w3_mpit_flag) then + WRITE (NDST,9021) + end if + if (w3_debuginit_flag) then WRITE(*,*) 'Before VA MPI_SEND/RECV_INIT inits' -#endif -#ifdef W3_MPI - DO ISP=1, NSPEC - IF ( IAPPRO(ISP) .NE. IAPROC ) THEN - ITARG = IAPPRO(ISP) - 1 - IH = IH + 1 - CALL MPI_SEND_INIT ( VA(ISP,1), 1, WW3_SPEC_VEC, & - ITARG, ISP, MPI_COMM_WAVE, IRQSG1(IH,1), IERR1 ) - CALL MPI_RECV_INIT ( VA(ISP,1), 1, WW3_SPEC_VEC, & - ITARG, ISP, MPI_COMM_WAVE, IRQSG1(IH,2), IERR2 ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9022) IH, ISP, ITARG+1, & - IRQSG1(IH,1), IERR1, IRQSG1(IH,2), IERR2 -#endif -#ifdef W3_MPI + end if + DO ISP=1, NSPEC + IF ( IAPPRO(ISP) .NE. IAPROC ) THEN + ITARG = IAPPRO(ISP) - 1 + IH = IH + 1 + CALL MPI_SEND_INIT ( VA(ISP,1), 1, WW3_SPEC_VEC, ITARG, ISP, MPI_COMM_WAVE, IRQSG1(IH,1), IERR1 ) + CALL MPI_RECV_INIT ( VA(ISP,1), 1, WW3_SPEC_VEC, ITARG, ISP, MPI_COMM_WAVE, IRQSG1(IH,2), IERR2 ) + if (w3_mpit_flag) then + WRITE (NDST,9022) IH, ISP, ITARG+1, IRQSG1(IH,1), IERR1, IRQSG1(IH,2), IERR2 + end if END IF - END DO -#endif -#ifdef W3_DEBUGINIT - WRITE(*,*) 'After VA MPI_SEND/RECV_INIT inits' -#endif -#ifdef W3_MPIT - WRITE (NDST,9023) - WRITE (NDST,9020) NRQSG1 -#endif -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3MPII, step 1' - FLUSH(740+IAPROC) -#endif -! -! 3. Set up scatters and gathers for W3SCAT and W3GATH -------------- / -! Also set up buffering of data. -! -#ifdef W3_MPI - NRQSG2 = MAX( 1 , NAPROC-1 ) - ALLOCATE ( WADATS(IMOD)%IRQSG2(NRQSG2*NSPLOC,2), & - WADATS(IMOD)%GSTORE(NAPROC*NSEALM,MPIBUF), & - WADATS(IMOD)%SSTORE(NAPROC*NSEALM,MPIBUF) ) - NRQSG2 = NAPROC - 1 -#endif -! -#ifdef W3_MPI - IRQSG2 => WADATS(IMOD)%IRQSG2 - GSTORE => WADATS(IMOD)%GSTORE - SSTORE => WADATS(IMOD)%SSTORE -#endif -! -#ifdef W3_MPI - IH = 0 - ISPLOC = 0 - IBFLOC = 0 - WADATS(IMOD)%GSTORE = 0. - WADATS(IMOD)%SSTORE = 0. -#endif -! -! 3.a Loop over local spectral components -! -#ifdef W3_MPIT - WRITE (NDST,9031) -#endif -! -#ifdef W3_MPI - DO ISP=1, NSPEC - IF ( IAPPRO(ISP) .EQ. IAPROC ) THEN -#endif -! -#ifdef W3_MPI - ISPLOC = ISPLOC + 1 - IBFLOC = IBFLOC + 1 - IF ( IBFLOC .GT. MPIBUF ) IBFLOC = 1 -#endif -! -! 3.b Loop over non-local processes -! -#ifdef W3_MPI - DO IP=1, NAPROC - IF ( IP .NE. IAPROC ) THEN -#endif -! -#ifdef W3_MPI - ITARG = IP - 1 - IH = IH + 1 -#endif -! -#ifdef W3_MPI - CALL MPI_RECV_INIT & - ( WADATS(IMOD)%GSTORE(IP,IBFLOC), 1, & - WW3_FIELD_VEC, ITARG, ISP, MPI_COMM_WAVE, & - IRQSG2(IH,1), IERR2 ) - CALL MPI_SEND_INIT & - ( WADATS(IMOD)%SSTORE(IP,IBFLOC), 1, & - WW3_FIELD_VEC, ITARG, ISP, MPI_COMM_WAVE, & - IRQSG2(IH,2), IERR2 ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9032) IH, ISP, ITARG+1, IBFLOC, & - IRQSG2(IH,1), IERR1, IRQSG2(IH,2), IERR2 -#endif -! -! ... End of loops -! -#ifdef W3_MPI + END DO + if (w3_debuginit_flag) then + WRITE(*,*) 'After VA MPI_SEND/RECV_INIT inits' + end if + if (w3_mpit_flag) then + WRITE (NDST,9023) + WRITE (NDST,9020) NRQSG1 + end if + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3MPII, step 1' + end if + ! + ! 3. Set up scatters and gathers for W3SCAT and W3GATH -------------- / + ! Also set up buffering of data. + ! + NRQSG2 = MAX( 1 , NAPROC-1 ) + ALLOCATE ( WADATS(IMOD)%IRQSG2(NRQSG2*NSPLOC,2), & + WADATS(IMOD)%GSTORE(NAPROC*NSEALM,MPIBUF), & + WADATS(IMOD)%SSTORE(NAPROC*NSEALM,MPIBUF) ) + NRQSG2 = NAPROC - 1 + ! + IRQSG2 => WADATS(IMOD)%IRQSG2 + GSTORE => WADATS(IMOD)%GSTORE + SSTORE => WADATS(IMOD)%SSTORE + ! + IH = 0 + ISPLOC = 0 + IBFLOC = 0 + WADATS(IMOD)%GSTORE = 0. + WADATS(IMOD)%SSTORE = 0. + ! + ! 3.a Loop over local spectral components + ! + if (w3_mpit_flag) then + WRITE (NDST,9031) + end if + ! + DO ISP=1, NSPEC + IF ( IAPPRO(ISP) .EQ. IAPROC ) THEN + ! + ISPLOC = ISPLOC + 1 + IBFLOC = IBFLOC + 1 + IF ( IBFLOC .GT. MPIBUF ) IBFLOC = 1 + ! + ! 3.b Loop over non-local processes + ! + DO IP=1, NAPROC + IF ( IP .NE. IAPROC ) THEN + ! + ITARG = IP - 1 + IH = IH + 1 + CALL MPI_RECV_INIT ( WADATS(IMOD)%GSTORE(IP,IBFLOC), 1, & + WW3_FIELD_VEC, ITARG, ISP, MPI_COMM_WAVE, IRQSG2(IH,1), IERR2 ) + CALL MPI_SEND_INIT ( WADATS(IMOD)%SSTORE(IP,IBFLOC), 1, & + WW3_FIELD_VEC, ITARG, ISP, MPI_COMM_WAVE, IRQSG2(IH,2), IERR2 ) + if (w3_mpit_flag) then + WRITE (NDST,9032) IH, ISP, ITARG+1, IBFLOC, & + IRQSG2(IH,1), IERR1, IRQSG2(IH,2), IERR2 + end if + ! + ! ... End of loops + ! END IF - END DO -#endif -! -#ifdef W3_MPI + END DO END IF - END DO -#endif -! -#ifdef W3_MPIT - WRITE (NDST,9033) - WRITE (NDST,9030) NSPLOC, NRQSG2, IH -#endif -! -! 4. Initialize buffer management ----------------------------------- / -! -#ifdef W3_MPI - BSTAT = 0 - BISPL = 0 - ISPLOC = 0 - IBFLOC = 0 + END DO + ! + if (w3_mpit_flag) then + WRITE (NDST,9033) + WRITE (NDST,9030) NSPLOC, NRQSG2, IH + end if + ! + ! 4. Initialize buffer management ----------------------------------- / + ! + BSTAT = 0 + BISPL = 0 + ISPLOC = 0 + IBFLOC = 0 #endif -! #ifdef W3_DIST - END IF -#endif - RETURN -! -! Format statements -! -#ifdef W3_MPIT - 9010 FORMAT ( ' TEST W3MPII: DATA TYPES DEFINED'/ & - ' WW3_FIELD_VEC : ',I10/ & - ' WW3_SPEC_VEC : ',I10) - 9011 FORMAT ( ' TEST W3MPII: NO COMPUTATIONS ON THIS NODE') -#endif -! -#ifdef W3_MPIT - 9020 FORMAT ( ' TEST W3MPII: W3WAVE COMM. SET UP FINISHED'/ & - ' NRQSG1 : ',I10) - 9021 FORMAT (/' TEST W3MPII: COMMUNICATION CALLS FOR W3WAVE '/ & - ' +------+------+------+--------------+--------------+'/ & - ' | IH | ISP | TARG | SCATTER | GATHER |'/ & - ' | | | | handle err | handle err |'/ & - ' +------+------+------+--------------+--------------+') - 9022 FORMAT ( ' |',3(I5,' |'),2(I9,I4,' |')) - 9023 FORMAT ( & - ' +------+------+------+--------------+--------------+'/) -#endif -! -#ifdef W3_MPIT - 9030 FORMAT ( ' TEST W3MPII: GATH/SCAT COMM. SET UP FINISHED'/ & - ' NSPLOC : ',I10/ & - ' NRQSG2 : ',I10/ & - ' TOTAL REQ. : ',I10/) - 9031 FORMAT (/' TEST W3MPII: COMM. CALLS FOR W3GATH/W3SCAT '/ & - ' +------+------+------+------+--------------+', & - '--------------+'/ & - ' | IH | ISP | TARG | IBFR | GATHER |', & - ' SCATTER |'/ & - ' | | | | | handle err |', & - ' handle err |'/ & - ' +------+------+------+------+--------------+', & - '--------------+') - 9032 FORMAT ( ' |',4(I5,' |'),2(I9,I4,' |')) - 9033 FORMAT ( ' +------+------+------+------+--------------+', & - '--------------+'/) -#endif -!/ -!/ End of W3MPII ----------------------------------------------------- / -!/ - END SUBROUTINE W3MPII -!/ ------------------------------------------------------------------- / - SUBROUTINE W3MPIO ( IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 11-Nov-2015 | -!/ +-----------------------------------+ -!/ -!/ 17-Mar-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 11-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 20-Aug-2003 : Output server options added. ( version 3.04 ) -!/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ Taken out of W3WAVE. -!/ 03-Jan-2005 : Add US2x to MPI communication. ( version 3.06 ) -!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) -!/ 21-Jul-2005 : Add output fields. ( version 3.07 ) -!/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) -!/ 02-Aug-2006 : W3MPIP split off. ( version 3.10 ) -!/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) -!/ Add user-defined field data. -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) -!/ 25-Dec-2012 : Modify field output MPI for new ( version 4.11 ) -!/ structure and smaller memory footprint. -!/ 02-Jul-2013 : Bug fix MPI_FLOAT -> MPI_REAL. ( version 4.11 ) -!/ 11-Nov-2015 : Added ICEF ( version 5.08 ) -!/ -! 1. Purpose : -! -! Prepare MPI persistent communication needed for WAVEWATCH I/O -! routines. -! -! 2. Method : -! -! Create handles as needed. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3XDMA Subr. W3ADATMD Dimension expanded output arrays. -! W3SETA Subr. " Set pointers for output arrays -! STRACE Subr. W3SERVMD Subroutine tracing. -! -! MPI_SEND_INIT, MPI_RECV_INIT -! Subr. mpif.h MPI persistent communication calls. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3INIT Subr. W3INITMD Wave model initialization routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! - The communication as set up in W3MPII uses tags with number -! ranging from 1 through NSPEC. New and unique tags for IO -! related communication are assigned here dynamically. -! - No testing on IMOD, since only called by W3INIT. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI MPI communication calls. -! -! !/S Enable subroutine tracing. -! !/MPIT Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! -#ifdef W3_MPI - USE W3ADATMD, ONLY: W3XDMA, W3SETA, W3XETA - USE W3IORSMD, ONLY: OARST -#endif - USE W3SERVMD, ONLY: EXTCDE -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ - USE W3GDATMD, ONLY: NSEA - USE W3ADATMD, ONLY: NSEALM -#ifdef W3_MPI - USE W3GDATMD, ONLY: NX, NSPEC, MAPFS, E3DF, P2MSF, US3DF, USSPF - USE W3WDATMD, ONLY: VA, UST, USTDIR, ASF, FPIS, ICEF - USE W3ADATMD, ONLY: MPI_COMM_WAVE, WW3_FIELD_VEC - USE W3ADATMD, ONLY: HS, WLM, T02 + END IF #endif + RETURN + ! + ! Formats + ! +9010 FORMAT (' TEST W3MPII: DATA TYPES DEFINED'/ & + ' WW3_FIELD_VEC : ',I10/ & + ' WW3_SPEC_VEC : ',I10) +9011 FORMAT (' TEST W3MPII: NO COMPUTATIONS ON THIS NODE') +9020 FORMAT (' TEST W3MPII: W3WAVE COMM. SET UP FINISHED'/ & + ' NRQSG1 : ',I10) +9021 FORMAT (/' TEST W3MPII: COMMUNICATION CALLS FOR W3WAVE '/ & + ' +------+------+------+--------------+--------------+'/ & + ' | IH | ISP | TARG | SCATTER | GATHER |'/ & + ' | | | | handle err | handle err |'/ & + ' +------+------+------+--------------+--------------+') +9022 FORMAT ( ' |',3(I5,' |'),2(I9,I4,' |')) +9023 FORMAT ( & + ' +------+------+------+--------------+--------------+'/) +9030 FORMAT (' TEST W3MPII: GATH/SCAT COMM. SET UP FINISHED'/ & + ' NSPLOC : ',I10/ & + ' NRQSG2 : ',I10/ & + ' TOTAL REQ. : ',I10/) +9031 FORMAT (/' TEST W3MPII: COMM. CALLS FOR W3GATH/W3SCAT '/ & + ' +------+------+------+------+--------------+', & + '--------------+'/ & + ' | IH | ISP | TARG | IBFR | GATHER |', & + ' SCATTER |'/ & + ' | | | | | handle err |', & + ' handle err |'/ & + ' +------+------+------+------+--------------+', & + '--------------+') +9032 FORMAT ( ' |',4(I5,' |'),2(I9,I4,' |')) +9033 FORMAT ( ' +------+------+------+------+--------------+', & + '--------------+'/) + !/ + !/ End of W3MPII ----------------------------------------------------- / + !/ + END SUBROUTINE W3MPII + !/ ------------------------------------------------------------------- / + SUBROUTINE W3MPIO ( IMOD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 11-Nov-2015 | + !/ +-----------------------------------+ + !/ + !/ 17-Mar-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) + !/ 11-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 20-Aug-2003 : Output server options added. ( version 3.04 ) + !/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ Taken out of W3WAVE. + !/ 03-Jan-2005 : Add US2x to MPI communication. ( version 3.06 ) + !/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) + !/ 21-Jul-2005 : Add output fields. ( version 3.07 ) + !/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) + !/ 02-Aug-2006 : W3MPIP split off. ( version 3.10 ) + !/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) + !/ Add user-defined field data. + !/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 21-Jun-2007 : Dedicated output processes. ( version 3.11 ) + !/ 25-Dec-2012 : Modify field output MPI for new ( version 4.11 ) + !/ structure and smaller memory footprint. + !/ 02-Jul-2013 : Bug fix MPI_FLOAT -> MPI_REAL. ( version 4.11 ) + !/ 11-Nov-2015 : Added ICEF ( version 5.08 ) + !/ + ! 1. Purpose : + ! + ! Prepare MPI persistent communication needed for WAVEWATCH I/O + ! routines. + ! + ! 2. Method : + ! + ! Create handles as needed. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3XDMA Subr. W3ADATMD Dimension expanded output arrays. + ! W3SETA Subr. " Set pointers for output arrays + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! + ! MPI_SEND_INIT, MPI_RECV_INIT + ! Subr. mpif.h MPI persistent communication calls. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3INIT Subr. W3INITMD Wave model initialization routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - The communication as set up in W3MPII uses tags with number + ! ranging from 1 through NSPEC. New and unique tags for IO + ! related communication are assigned here dynamically. + ! - No testing on IMOD, since only called by W3INIT. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI MPI communication calls. + ! + ! !/S Enable subroutine tracing. + ! !/MPIT Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3SERVMD, ONLY: EXTCDE + USE W3SERVMD, ONLY: STRACE ! W3_S + !/ + USE W3GDATMD, ONLY: NSEA + USE W3ADATMD, ONLY: NSEALM +#ifdef W3_MPI + USE W3ADATMD, ONLY: W3XDMA, W3SETA, W3XETA ! W3_MPI + USE W3IORSMD, ONLY: OARST ! W3_MPI + USE W3GDATMD, ONLY: NX, NSPEC, MAPFS, E3DF, P2MSF, US3DF, USSPF ! W3_MPI + USE W3WDATMD, ONLY: VA, UST, USTDIR, ASF, FPIS, ICEF ! W3_MPI + USE W3ADATMD, ONLY: MPI_COMM_WAVE, WW3_FIELD_VEC ! W3_MPI + USE W3ADATMD, ONLY: HS, WLM, T02 ! W3_MPI -#ifdef W3_MPI - USE W3ADATMD, ONLY: T0M1, THM, THS, FP0, THP0, FP1, THP1, & - DTDYN, FCUT, SPPNT, ABA, ABD, UBA, UBD,& - SXX, SYY, SXY, USERO, PHS, PTP, PLP, & - PDIR, PSI, PWS, PWST, PNR, PHIAW, PHIOC,& - TUSX, TUSY, TAUWIX, TAUWIY, TAUOX, & - TAUOY, USSX, USSY, MSSX, MSSY, MSSD, & - MSCX, MSCY, MSCD, PRMS, TPMS, CHARN, & - TWS, TAUWNX, TAUWNY, BHD, CGE, & - CFLXYMAX, CFLTHMAX, CFLKMAX, WHITECAP, & - BEDFORMS, PHIBBL, TAUBBL, T01, & - P2SMS, US3D, EF, TH1M, STH1M, TH2M, & - STH2M, HSIG, PHICE, TAUICE, USSP, & - STMAXE, STMAXD, HMAXE, HCMAXE, HMAXD, & - HCMAXD, QP, PTHP0, PQP, PPE, PGW, PSW, & - PTM1, PT1, PT2, PEP, WBT, CX, CY, & - TAUOCX, TAUOCY, WNMEAN -#endif + USE W3ADATMD, ONLY: T0M1, THM, THS, FP0, THP0, FP1, THP1 ! W3_MPI + USE W3ADATMD, ONLY: DTDYN, FCUT, SPPNT, ABA, ABD, UBA, UBD ! W3_MPI + USE W3ADATMD, ONLY: SXX, SYY, SXY, USERO, PHS, PTP, PLP ! W3_MPI + USE W3ADATMD, ONLY: PDIR, PSI, PWS, PWST, PNR, PHIAW, PHIOC ! W3_MPI + USE W3ADATMD, ONLY: TUSX, TUSY, TAUWIX, TAUWIY, TAUOX ! W3_MPI + USE W3ADATMD, ONLY: TAUOY, USSX, USSY, MSSX, MSSY, MSSD ! W3_MPI + USE W3ADATMD, ONLY: MSCX, MSCY, MSCD, PRMS, TPMS, CHARN ! W3_MPI + USE W3ADATMD, ONLY: TWS, TAUWNX, TAUWNY, BHD, CGE ! W3_MPI + USE W3ADATMD, ONLY: CFLXYMAX, CFLTHMAX, CFLKMAX, WHITECAP ! W3_MPI + USE W3ADATMD, ONLY: BEDFORMS, PHIBBL, TAUBBL, T01 ! W3_MPI + USE W3ADATMD, ONLY: P2SMS, US3D, EF, TH1M, STH1M, TH2M ! W3_MPI + USE W3ADATMD, ONLY: STH2M, HSIG, PHICE, TAUICE, USSP ! W3_MPI + USE W3ADATMD, ONLY: STMAXE, STMAXD, HMAXE, HCMAXE, HMAXD ! W3_MPI + USE W3ADATMD, ONLY: HCMAXD, QP, PTHP0, PQP, PPE, PGW, PSW ! W3_MPI + USE W3ADATMD, ONLY: PTM1, PT1, PT2, PEP, WBT, CX, CY ! W3_MPI + USE W3ADATMD, ONLY: TAUOCX, TAUOCY, WNMEAN ! W3_MPI -#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, & - NAPFLD, NAPPNT, NAPRST, NAPBPT, NAPTRK,& - NOGRP, NGRPP, NOGE, FLOGRR - USE W3ODATMD, ONLY: OUTPTS, NRQGO, NRQGO2, IRQGO, IRQGO2, & - FLOGRD, NRQPO, NRQPO2, IRQPO1, IRQPO2, & - NOPTS, IPTINT, NRQRS, IRQRS, NBLKRS, & - RSBLKS, IRQRSS, VAAUX, NRQBP, NRQBP2, & - IRQBP1, IRQBP2, NFBPO, NBO2, ISBPO, & - ABPOS, NRQTR, IRQTR, IT0PNT, IT0TRK, & - IT0PRT, NOSWLL, NOEXTR, NDSE, IOSTYP, & - FLOGR2 - USE W3PARALL, ONLY : INIT_GET_JSEA_ISPROC -#endif - USE W3GDATMD, ONLY: GTYPE, UNGTYPE - USE CONSTANTS, ONLY: LPDLIB -!/ - IMPLICIT NONE -! -#ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -#ifdef W3_MPI - INTEGER :: IK, IFJ - INTEGER :: IH, IT0, IROOT, IT, IERR, I0, & - IFROM, IX(4), IY(4), IS(4), & - IP(4), I, J, JSEA, ITARG, IB, & - JSEA0, JSEAN, NSEAB, IBOFF, & - ISEA, ISPROC, K, NRQMAX -#endif -#ifdef W3_S - INTEGER, SAVE :: IENT -#endif -#ifdef W3_MPI - LOGICAL :: FLGRDALL(NOGRP,NGRPP) - LOGICAL :: FLGRDARST(NOGRP,NGRPP) -#endif -#ifdef W3_MPIT - CHARACTER(LEN=5) :: STRING -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3MPIO') -#endif -! -! 1. Set-up for W3IOGO ---------------------------------------------- / -! -#ifdef W3_MPI - DO J=1, NOGRP - DO K=1, NGRPP + USE W3GDATMD, ONLY: NK ! W3_MPI + USE W3ODATMD, ONLY: NDST, IAPROC, NAPROC, NTPROC, FLOUT ! W3_MPI + USE W3ODATMD, ONLY: NAPFLD, NAPPNT, NAPRST, NAPBPT, NAPTRK ! W3_MPI + USE W3ODATMD, ONLY: NOGRP, NGRPP, NOGE, FLOGRR ! W3_MPI + USE W3ODATMD, ONLY: OUTPTS, NRQGO, NRQGO2, IRQGO, IRQGO2 ! W3_MPI + USE W3ODATMD, ONLY: FLOGRD, NRQPO, NRQPO2, IRQPO1, IRQPO2 ! W3_MPI + USE W3ODATMD, ONLY: NOPTS, IPTINT, NRQRS, IRQRS, NBLKRS ! W3_MPI + USE W3ODATMD, ONLY: RSBLKS, IRQRSS, VAAUX, NRQBP, NRQBP2 ! W3_MPI + USE W3ODATMD, ONLY: IRQBP1, IRQBP2, NFBPO, NBO2, ISBPO ! W3_MPI + USE W3ODATMD, ONLY: ABPOS, NRQTR, IRQTR, IT0PNT, IT0TRK ! W3_MPI + USE W3ODATMD, ONLY: IT0PRT, NOSWLL, NOEXTR, NDSE, IOSTYP ! W3_MPI + USE W3ODATMD, ONLY: FLOGR2 ! W3_MPI + USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC ! W3_MPI +#ifdef W3_CESMCOUPLED + USE W3ADATMD, ONLY: LANGMT, LAPROJ, ALPHAL, LASL, LASLPJ, ALPHALS, LAMULT +#endif +#endif + USE W3GDATMD, ONLY: GTYPE, UNGTYPE + USE CONSTANTS, ONLY: LPDLIB + !/ + ! +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ +#ifdef W3_MPI + INTEGER :: IK, IFJ ! W3_MPI + INTEGER :: IH, IT0, IROOT, IT, IERR, I0 ! W3_MPI + INTEGER :: IFROM, IX(4), IY(4), IS(4) ! W3_MPI + INTEGER :: IP(4), I, J, JSEA, ITARG, IB ! W3_MPI + INTEGER :: JSEA0, JSEAN, NSEAB, IBOFF ! W3_MPI + INTEGER :: ISEA, ISPROC, K, NRQMAX ! W3_MPI + LOGICAL :: FLGRDALL(NOGRP,NGRPP) ! W3_MPI + LOGICAL :: FLGRDARST(NOGRP,NGRPP) ! W3_MPI +#endif + INTEGER :: IENT ! W3_S + CHARACTER(LEN=5) :: STRING ! W3_MPIT + !/ + !/ ------------------------------------------------------------------- / + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'W3MPIO') + end if + ! + ! 1. Set-up for W3IOGO ---------------------------------------------- / + ! +#ifdef W3_MPI + DO J=1, NOGRP + DO K=1, NGRPP FLGRDALL (J,K) = (FLOGRD(J,K) .OR. FLOGR2(J,K)) FLGRDARST(J,K) = (FLGRDALL(J,K) .OR. FLOGRR(J,K)) - END DO - END DO -#endif -! -#ifdef W3_MPI - NRQGO = 0 - NRQGO2 = 0 - IT0 = NSPEC - IROOT = NAPFLD - 1 -#endif -! -! -#ifdef W3_MPI - IF ((FLOUT(1) .OR. FLOUT(7)).and.(.not. LPDLIB .or. & - (GTYPE .ne. UNGTYPE).or. .TRUE.)) THEN -#endif -! -! NRQMAX is the maximum number of output fields that require MPI communication, -! aimed to gather field values stored in each processor into one processor in -! charge of model output; for each of such fields, this routine requires one -! call to MPI_SEND_INIT and MPI_RECV_INIT storing the communication request -! handles in the vectors IRQGO and IRQGO2 respectively. -! NRQMAX is calculated as the sum of all fields described before (Hs) -! + 2 or 3 component fields (CUR) + 3 component fields + extra fields -! For group 1 fields except ICEF, all processors contain information on all -! grid points because they are input fields, and therefore this MPI -! communication is not necessary and they do not contribute to NRQMAX. -! -#ifdef W3_MPI - ! Calculation of NRQMAX splitted by output groups and field type - ! scalar 2-comp 3-comp - NRQMAX = 1 + 0 + 0 + & ! group 1 - 18 + 0 + 0 + & ! group 2 - 0 + 0 + 0 + & ! group 3 (extra contributions below) - 2+(NOGE(4)-2)*(NOSWLL+1) + 0 + 0 + & ! group 4 - 11 + 3 + 1 + & ! group 5 - 12 + 7 + 1 + & ! group 6 (extra contributions below) - 5 + 4 + 1 + & ! group 7 - 5 + 2 + 0 + & ! group 8 - 5 + 0 + 0 + & ! group 9 - NOEXTR + 0 + 0 ! group 10 + END DO + END DO + ! + NRQGO = 0 + NRQGO2 = 0 + IT0 = NSPEC + IROOT = NAPFLD - 1 + ! + ! + IF ((FLOUT(1) .OR. FLOUT(7)).and.(.not. LPDLIB .or. & + (GTYPE .ne. UNGTYPE).or. .TRUE.)) THEN + ! + ! NRQMAX is the maximum number of output fields that require MPI communication, + ! aimed to gather field values stored in each processor into one processor in + ! charge of model output; for each of such fields, this routine requires one + ! call to MPI_SEND_INIT and MPI_RECV_INIT storing the communication request + ! handles in the vectors IRQGO and IRQGO2 respectively. + ! NRQMAX is calculated as the sum of all fields described before (Hs) + ! + 2 or 3 component fields (CUR) + 3 component fields + extra fields + ! For group 1 fields except ICEF, all processors contain information on all + ! grid points because they are input fields, and therefore this MPI + ! communication is not necessary and they do not contribute to NRQMAX. + ! + ! Calculation of NRQMAX splitted by output groups and field type + ! scalar 2-comp 3-comp + NRQMAX = 1 + 0 + 0 + & ! group 1 + 18 + 0 + 0 + & ! group 2 + 0 + 0 + 0 + & ! group 3 (extra contributions below) + 2+(NOGE(4)-2)*(NOSWLL+1) + 0 + 0 + & ! group 4 + 11 + 3 + 1 + & ! group 5 + 12 + 7 + 1 + & ! group 6 (extra contributions below) + 5 + 4 + 1 + & ! group 7 + 5 + 2 + 0 + & ! group 8 + 5 + 0 + 0 + & ! group 9 + NOEXTR + 0 + 0 ! group 10 - ! Extra contributions to NRQMAX from group 3 - DO IFJ=1,5 - IF ( FLGRDALL( 3,IFJ)) NRQMAX = NRQMAX + & - E3DF(3,IFJ) - E3DF(2,IFJ) + 1 - END DO - ! Extra contributions to NRQMAX from group 6 - IF ( FLGRDALL( 6,9)) NRQMAX = NRQMAX + & - P2MSF(3) - P2MSF(2) + 1 - IF ( FLGRDALL( 6, 8) ) NRQMAX = NRQMAX + 2*NK - IF ( FLGRDALL( 6,12) ) NRQMAX = NRQMAX + 2*NK -#endif -! -#ifdef W3_MPI - IF ( NRQMAX .GT. 0 ) THEN - ALLOCATE ( OUTPTS(IMOD)%OUT1%IRQGO(NRQMAX) ) - ALLOCATE ( OUTPTS(IMOD)%OUT1%IRQGO2(NRQMAX*NAPROC) ) - END IF - IRQGO => OUTPTS(IMOD)%OUT1%IRQGO - IRQGO2 => OUTPTS(IMOD)%OUT1%IRQGO2 -#endif -! -! 1.a Sends of fields -! -#ifdef W3_MPI - IH = 0 -#endif -! -#ifdef W3_MPI - IF ( IAPROC .LE. NAPROC ) THEN - IT = IT0 -#endif -#ifdef W3_MPIT - WRITE (NDST,9010) '(SEND)' -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 1, 12) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (ICEF (IAPROC), 1, WW3_FIELD_VEC, & - IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 1/09', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (HS (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (WLM (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/02', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (T02 (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/03', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (T0M1 (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/04', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (T01 (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/05', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 6) .OR. FLGRDALL( 2,18) ) THEN - ! TP output shares FP0 internal field with FP - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (FP0 (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/06', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 7) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (THM (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/07', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 8) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (THS (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/09', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 9) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (THP0 (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/09', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 10) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (HSIG (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/10', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 11) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (STMAXE (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/11', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 12) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (STMAXD (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/12', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 13) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (HMAXE (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/13', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 14) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (HCMAXE (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/14', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 15) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (HMAXD (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/15', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 16) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (HCMAXD (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/16', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 17) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (WBT (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/17', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 19) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (WNMEAN(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/19', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 3, 1) ) THEN - DO IK=E3DF(2,1),E3DF(3,1) - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (EF(1,IK),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, 'EF', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 3, 2) ) THEN - DO IK=E3DF(2,2),E3DF(3,2) - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TH1M(1,IK),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, 'TH1M', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 3, 3) ) THEN - DO IK=E3DF(2,3),E3DF(3,3) - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (STH1M(1,IK),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, 'STH1M', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 3, 4) ) THEN - DO IK=E3DF(2,4),E3DF(3,4) - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TH2M(1,IK),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, 'TH2M', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 3, 5) ) THEN - DO IK=E3DF(2,5),E3DF(3,5) - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (STH2M(1,IK),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, 'STH2M', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4, 1) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PHS(1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4, 2) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PTP(1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/02', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4, 3) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PLP(1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/03', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4, 4) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PDIR(1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/04', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4, 5) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PSI(1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/05', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4, 6) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PWS(1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/06', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4, 7) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PTHP0(1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/07', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4, 8) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PQP (1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/08', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4, 9) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PPE (1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/09', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,10) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PGW (1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/10', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,11) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PSW (1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/11', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,12) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PTM1(1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/12', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,13) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PT1 (1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/13', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,14) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PT2 (1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/14', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,15) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PEP (1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/15', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,16) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PWST (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/16', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,17) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PNR (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/17', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (UST (IAPROC), 1, WW3_FIELD_VEC, & - IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (USTDIR(IAPROC), 1, WW3_FIELD_VEC, & - IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (ASF (IAPROC), 1, WW3_FIELD_VEC, & - IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (CHARN(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/02', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (CGE (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/03', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PHIAW(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/04', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUWIX(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/05', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUWIY(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/05', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 6) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUWNX(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/06', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUWNY(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/06', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 7) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (WHITECAP(1,1),NSEALM , MPI_REAL, IROOT,& - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/07', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 8) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (WHITECAP(1,2),NSEALM , MPI_REAL, IROOT,& - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/08', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 9) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (WHITECAP(1,3),NSEALM , MPI_REAL, IROOT,& - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/09', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5,10) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (WHITECAP(1,4),NSEALM , MPI_REAL, IROOT,& - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/10', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 11) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TWS(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/11', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (SXX (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (SYY (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (SXY (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUOX (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/02', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUOY (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/02', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (BHD(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/03', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PHIOC (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/04', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TUSX (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/05', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TUSY (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/05', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 6) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (USSX (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/06', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (USSY (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/06', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 7) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PRMS (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/07', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TPMS (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/07', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 8) ) THEN - DO IK=1,2*NK - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (US3D(1,IK),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, 'US3D ', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 9) ) THEN - DO K=P2MSF(2),P2MSF(3) - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (P2SMS(1,K),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, 'P2SMS', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6,10) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUICE (1,1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/10', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUICE (1,2),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/10', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6,11) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PHICE (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/11', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif - -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 12) ) THEN - DO IK=1,2*NK - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (USSP(1,IK),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, 'USSP ', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif - -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 13) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUOCX(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/13', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUOCY(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/13', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_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 -! -#ifdef W3_MPI - IF ( FLGRDALL( 7, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (ABA (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (ABD (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 7, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (UBA (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/02', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (UBD (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/02', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 7, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (BEDFORMS(1,1),NSEALM , MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/03', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (BEDFORMS(1,2),NSEALM , MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/03', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (BEDFORMS(1,3),NSEALM , MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/03', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 7, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (PHIBBL(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/04', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 7, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUBBL(1,1),NSEALM , MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/05', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (TAUBBL(1,2),NSEALM , MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/05', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 8, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (MSSX (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (MSSY (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 8, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (MSCX (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/02', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (MSCY (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/02', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 8, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (MSSD (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/03', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 8, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (MSCD (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/04', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 8, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (QP (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/05', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 9, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (DTDYN(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 9/01', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 9, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (FCUT (1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 9/02', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 9, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (CFLXYMAX(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 9/03', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 9, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (CFLTHMAX(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 9/04', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 9, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (CFLKMAX(1),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 9/05', IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - DO I=1, NOEXTR - IF ( FLGRDALL(10, I) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_SEND_INIT (USERO(1,I),NSEALM , MPI_REAL, IROOT, & - IT, MPI_COMM_WAVE, IRQGO(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (STRING,'(A3,I2.2)') '10/', I - WRITE (NDST,9011) IH, STRING, IROOT, IT, IRQGO(IH), IERR -#endif -#ifdef W3_MPI - END IF - END DO -#endif -! -#ifdef W3_MPI - NRQGO = IH -#endif -#ifdef W3_MPIT - WRITE (NDST,9012) - WRITE (NDST,9013) NRQGO, NRQMAX -#endif -! -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( NRQGO .GT. NRQMAX ) THEN - WRITE (NDSE,1010) NRQGO, NRQMAX - CALL EXTCDE (10) - END IF -#endif -! -#ifdef W3_MPI - IF ( IAPROC .EQ. NAPFLD ) THEN -#endif -! -! 1.b Setting up expanded arrays -! -#ifdef W3_MPI - IF (NAPFLD .EQ. NAPRST) THEN - CALL W3XDMA ( IMOD, NDSE, NDST, FLGRDARST ) - ELSE - CALL W3XDMA ( IMOD, NDSE, NDST, FLGRDALL ) - ENDIF -#endif -! -! 1.c Receives of fields -! -#ifdef W3_MPI - CALL W3XETA ( IMOD, NDSE, NDST ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9010) '(RECV)' -#endif -! -#ifdef W3_MPI - IH = 0 -#endif -! -#ifdef W3_MPI - DO I0=1, NAPROC - IT = IT0 - IFROM = I0 - 1 -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 1, 12) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (ICEF (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 1/09', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (HS (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/01', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (WLM (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/02', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (T02 (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/03', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (T0M1 (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/04', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (T01(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/05', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 6) .OR. FLGRDALL( 2,18) ) THEN - ! TP output shares FP0 internal field with FP - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (FP0 (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/06', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 7) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (THM (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/07', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 8) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (THS (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/08', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 9) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (THP0 (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/09', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 10) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (HSIG (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/10', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 11) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (STMAXE (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/11', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 12) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (STMAXD(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/12', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 13) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (HMAXE (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/13', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 14) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (HCMAXE(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/14', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 15) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (HMAXD (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/15', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 16) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (HCMAXD(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/16', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 17) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (WBT(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/17', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 2, 19) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (WNMEAN(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 2/19', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 3, 1) ) THEN - DO IK=E3DF(2,1),E3DF(3,1) - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (EF(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, 'EF', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 3, 2) ) THEN - DO IK=E3DF(2,2),E3DF(3,2) - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TH1M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, 'TH1M', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 3, 3) ) THEN - DO IK=E3DF(2,3),E3DF(3,3) - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (STH1M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, 'STH1M', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 3, 4) ) THEN - DO IK=E3DF(2,4),E3DF(3,4) - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TH2M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, 'TH2M', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 3, 5) ) THEN - DO IK=E3DF(2,5),E3DF(3,5) - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (STH2M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, 'STH2M', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4, 1) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PHS(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/01', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4, 2) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PTP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/02', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4, 3) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PLP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/03', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4, 4) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PDIR(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/04', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4, 5) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PSI(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/05', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4, 6) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PWS(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/06', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4, 7) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PTHP0(I0,K),1,WW3_FIELD_VEC, IFROM, IT,& - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/07', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4, 8) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PQP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/08', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4, 9) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PPE(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/09', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,10) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PGW(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/10', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,11) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PSW(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/11', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,12) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PTM1(I0,K),1,WW3_FIELD_VEC, IFROM, IT,& - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/12', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,13) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PT1(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/13', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,14) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PT2(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/14', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,15) ) THEN - DO K=0, NOSWLL - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PEP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/15', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,16) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PWST (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/16', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 4,17) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PNR (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 4/17', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (UST (I0), 1, WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/01', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (USTDIR(I0), 1, WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/01', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (ASF (I0), 1, WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/01', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (CHARN(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/02', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (CGE (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/03', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PHIAW(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/04', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUWIX(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/05', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUWIY(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/05', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 6) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUWNX(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/06', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUWNY(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/06', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 7) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (WHITECAP(I0,1),1,WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/07', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 8) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (WHITECAP(I0,2),1,WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/08', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5, 9) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (WHITECAP(I0,3),1,WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/09', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5,10) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (WHITECAP(I0,4),1,WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/10', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 5,11) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TWS(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 5/11', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (SXX (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/01', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (SYY (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/01', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (SXY (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/01', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUOX (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/02', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUOY (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/02', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (BHD(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/03', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PHIOC (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/04', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TUSX (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/05', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TUSY (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/05', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 6) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (USSX (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/06', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (USSY (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/06', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 7) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PRMS (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/07', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TPMS (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/07', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 8) ) THEN - DO IK=1,2*NK - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (US3D(I0,IK),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, 'US3D ', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 9) ) THEN - DO K=P2MSF(2),P2MSF(3) - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (P2SMS(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, 'P3SMS', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6,10) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUICE (I0,1),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/10', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUICE (I0,2),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/10', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6,11) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PHICE (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/11', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 12) ) THEN - DO IK=1,2*NK - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (USSP(I0,IK),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, 'USSP ', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END DO - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 6, 13) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUOCX(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 6/13', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUOCY(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#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 -! -#ifdef W3_MPI - IF ( FLGRDALL( 7, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (ABA (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/01', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (ABD (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/01', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 7, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (UBA (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/02', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (UBD (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/02', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 7, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (BEDFORMS(I0,1),1,WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/03', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (BEDFORMS(I0,2),1,WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/03', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (BEDFORMS(I0,3),1,WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/03', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 7, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (PHIBBL(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/04', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 7, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUBBL(I0,1),1,WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/05', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (TAUBBL(I0,2),1,WW3_FIELD_VEC, IFROM, & - IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 7/05', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 8, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (MSSX (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/01', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (MSSY (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/01', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 8, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (MSCX (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/02', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (MSCY (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/02', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 8, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (MSSD (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/03', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 8, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (MSCD (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/04', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 8, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (QP (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 8/05', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 9, 1) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (DTDYN(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 9/01', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 9, 2) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (FCUT (I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 9/02', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 9, 3) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (CFLXYMAX(I0),1,WW3_FIELD_VEC, IFROM, IT,& - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 9/03', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 9, 4) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (CFLTHMAX(I0),1,WW3_FIELD_VEC, IFROM, IT,& - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 9/04', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLGRDALL( 9, 5) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (CFLKMAX(I0),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH, ' 9/05', IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - DO I=1, NOEXTR - !WRITE(740+IAPROC,*) 'SECOND : I=', I, ' / ', NOEXTR, ' val=', FLGRDALL(10, I) - IF ( FLGRDALL(10, I) ) THEN - IH = IH + 1 - IT = IT + 1 - CALL MPI_RECV_INIT (USERO(I0,I),1,WW3_FIELD_VEC, IFROM, IT, & - MPI_COMM_WAVE, IRQGO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (STRING,'(A3,I2.2)') '10/', I - WRITE (NDST,9011) IH, STRING, IFROM, IT, IRQGO2(IH), IERR -#endif -#ifdef W3_MPI - END IF - END DO -#endif -! -#ifdef W3_MPI - END DO -#endif -! -#ifdef W3_MPI - NRQGO2 = IH -#endif -#ifdef W3_MPIT - WRITE (NDST,9012) - WRITE (NDST,9014) NRQGO2, NRQMAX*NAPROC -#endif -! -#ifdef W3_MPI - CALL W3SETA ( IMOD, NDSE, NDST ) -#endif -! -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( NRQGO2 .GT. NRQMAX*NAPROC ) THEN - WRITE (NDSE,1011) NRQGO2, NRQMAX*NAPROC - CALL EXTCDE (11) - END IF -#endif -! -#ifdef W3_MPI - END IF -#endif -! -! 2. Set-up for W3IORS ---------------------------------------------- / -! 2.a General preparations -! -#ifdef W3_MPI - NRQRS = 0 - IH = 0 - IROOT = NAPRST - 1 -#endif -! -#ifdef W3_MPI - IF ( FLOUT(4) .OR. FLOUT(8) ) THEN - IF (OARST) THEN - ALLOCATE ( OUTPTS(IMOD)%OUT4%IRQRS(34*NAPROC) ) + ! Extra contributions to NRQMAX from group 3 + DO IFJ=1,5 + IF ( FLGRDALL( 3,IFJ)) NRQMAX = NRQMAX + & + E3DF(3,IFJ) - E3DF(2,IFJ) + 1 + END DO + ! Extra contributions to NRQMAX from group 6 + IF ( FLGRDALL( 6,9)) NRQMAX = NRQMAX + & + P2MSF(3) - P2MSF(2) + 1 + IF ( FLGRDALL( 6, 8) ) NRQMAX = NRQMAX + 2*NK + IF ( FLGRDALL( 6,12) ) NRQMAX = NRQMAX + 2*NK + ! + IF ( NRQMAX .GT. 0 ) THEN + ALLOCATE ( OUTPTS(IMOD)%OUT1%IRQGO(NRQMAX) ) + ALLOCATE ( OUTPTS(IMOD)%OUT1%IRQGO2(NRQMAX*NAPROC) ) + END IF + IRQGO => OUTPTS(IMOD)%OUT1%IRQGO + IRQGO2 => OUTPTS(IMOD)%OUT1%IRQGO2 + ! + ! 1.a Sends of fields + ! + IH = 0 + ! + IF ( IAPROC .LE. NAPROC ) THEN + IT = IT0 + if (w3_mpit_flag) then + WRITE (NDST,9010) '(SEND)' + end if + ! + IF ( FLGRDALL( 1, 12) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (ICEF (IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 1/09', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (HS (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/01', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (WLM (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/02', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (T02 (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/03', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (T0M1 (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/04', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (T01 (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/05', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 6) .OR. FLGRDALL( 2,18) ) THEN + ! TP output shares FP0 internal field with FP + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (FP0 (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/06', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 7) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (THM (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/07', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 8) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (THS (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/09', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 9) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (THP0 (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/09', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 10) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (HSIG (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/10', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 11) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (STMAXE (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/11', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 12) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (STMAXD (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/12', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 13) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (HMAXE (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/13', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 14) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (HCMAXE (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/14', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 15) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (HMAXD (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/15', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 16) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (HCMAXD (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/16', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 17) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (WBT (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/17', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 19) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (WNMEAN(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/19', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 3, 1) ) THEN + DO IK=E3DF(2,1),E3DF(3,1) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (EF(1,IK),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, 'EF', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 3, 2) ) THEN + DO IK=E3DF(2,2),E3DF(3,2) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TH1M(1,IK),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, 'TH1M', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 3, 3) ) THEN + DO IK=E3DF(2,3),E3DF(3,3) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (STH1M(1,IK),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, 'STH1M', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 3, 4) ) THEN + DO IK=E3DF(2,4),E3DF(3,4) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TH2M(1,IK),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, 'TH2M', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 3, 5) ) THEN + DO IK=E3DF(2,5),E3DF(3,5) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (STH2M(1,IK),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, 'STH2M', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4, 1) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PHS(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/01', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4, 2) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PTP(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/02', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4, 3) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PLP(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/03', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4, 4) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PDIR(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/04', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4, 5) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PSI(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/05', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4, 6) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PWS(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/06', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4, 7) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PTHP0(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/07', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4, 8) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PQP (1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/08', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4, 9) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PPE (1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/09', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4,10) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PGW (1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/10', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4,11) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PSW (1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/11', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4,12) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PTM1(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/12', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + ! + IF ( FLGRDALL( 4,13) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PT1 (1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/13', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4,14) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PT2 (1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/14', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4,15) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PEP (1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/15', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4,16) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PWST (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/16', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 4,17) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PNR (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/17', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 5, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (UST (IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/01', IROOT, IT, IRQGO(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (USTDIR(IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/01', IROOT, IT, IRQGO(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (ASF (IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/01', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 5, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (CHARN(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/02', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 5, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (CGE (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/03', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 5, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PHIAW(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/04', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 5, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUWIX(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/05', IROOT, IT, IRQGO(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUWIY(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/05', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 5, 6) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUWNX(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/06', IROOT, IT, IRQGO(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUWNY(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/06', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 5, 7) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (WHITECAP(1,1),NSEALM , MPI_REAL, IROOT,& + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/07', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 5, 8) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (WHITECAP(1,2),NSEALM , MPI_REAL, IROOT,& + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/08', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 5, 9) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (WHITECAP(1,3),NSEALM , MPI_REAL, IROOT,& + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/09', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 5,10) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (WHITECAP(1,4),NSEALM , MPI_REAL, IROOT,& + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/10', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 5, 11) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TWS(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/11', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 6, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (SXX (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/01', IROOT, IT, IRQGO(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (SYY (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/01', IROOT, IT, IRQGO(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (SXY (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/01', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 6, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUOX (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/02', IROOT, IT, IRQGO(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUOY (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/02', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 6, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (BHD(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/03', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 6, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PHIOC (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/04', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 6, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TUSX (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/05', IROOT, IT, IRQGO(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TUSY (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/05', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 6, 6) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (USSX (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/06', IROOT, IT, IRQGO(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (USSY (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/06', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 6, 7) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PRMS (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/07', IROOT, IT, IRQGO(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TPMS (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/07', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 6, 8) ) THEN + DO IK=1,2*NK + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (US3D(1,IK),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, 'US3D ', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 6, 9) ) THEN + DO K=P2MSF(2),P2MSF(3) + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (P2SMS(1,K),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, 'P2SMS', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 6,10) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUICE (1,1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/10', IROOT, IT, IRQGO(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUICE (1,2),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/10', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 6,11) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PHICE (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/11', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 6, 12) ) THEN + DO IK=1,2*NK + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (USSP(1,IK),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, 'USSP ', IROOT, IT, IRQGO(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 6, 13) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUOCX(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/13', IROOT, IT, IRQGO(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUOCY(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/13', IROOT, IT, IRQGO(IH), IERR + end if + END IF +#ifdef W3_CESMCOUPLED + IF ( FLGRDALL( 6, 14) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (LANGMT(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + END IF + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/14', IROOT, IT, IRQGO(IH), IERR + end if +#endif + ! + IF ( FLGRDALL( 7, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (ABA (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 7/01', IROOT, IT, IRQGO(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (ABD (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 7/01', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 7, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (UBA (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 7/02', IROOT, IT, IRQGO(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (UBD (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 7/02', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 7, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (BEDFORMS(1,1),NSEALM , MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 7/03', IROOT, IT, IRQGO(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (BEDFORMS(1,2),NSEALM , MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 7/03', IROOT, IT, IRQGO(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (BEDFORMS(1,3),NSEALM , MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 7/03', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 7, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (PHIBBL(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 7/04', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 7, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUBBL(1,1),NSEALM , MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 7/05', IROOT, IT, IRQGO(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (TAUBBL(1,2),NSEALM , MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 7/05', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 8, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (MSSX (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 8/01', IROOT, IT, IRQGO(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (MSSY (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 8/01', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 8, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (MSCX (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 8/02', IROOT, IT, IRQGO(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (MSCY (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 8/02', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 8, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (MSSD (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 8/03', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 8, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (MSCD (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 8/04', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 8, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (QP (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 8/05', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 9, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (DTDYN(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 9/01', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 9, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (FCUT (1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 9/02', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 9, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (CFLXYMAX(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 9/03', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 9, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (CFLTHMAX(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 9/04', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 9, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (CFLKMAX(1),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 9/05', IROOT, IT, IRQGO(IH), IERR + end if + END IF + ! + DO I=1, NOEXTR + IF ( FLGRDALL(10, I) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_SEND_INIT (USERO(1,I),NSEALM , MPI_REAL, IROOT, & + IT, MPI_COMM_WAVE, IRQGO(IH), IERR) + if (w3_mpit_flag) then + WRITE (STRING,'(A3,I2.2)') '10/', I + WRITE (NDST,9011) IH, STRING, IROOT, IT, IRQGO(IH), IERR + end if + END IF + END DO + ! + NRQGO = IH + if (w3_mpit_flag) then + WRITE (NDST,9012) + WRITE (NDST,9013) NRQGO, NRQMAX + end if + ! + END IF + ! + IF ( NRQGO .GT. NRQMAX ) THEN + WRITE (NDSE,1010) NRQGO, NRQMAX + CALL EXTCDE (10) + END IF + ! + IF ( IAPROC .EQ. NAPFLD ) THEN + ! + ! 1.b Setting up expanded arrays + ! + IF (NAPFLD .EQ. NAPRST) THEN + CALL W3XDMA ( IMOD, NDSE, NDST, FLGRDARST ) ELSE - ALLOCATE ( OUTPTS(IMOD)%OUT4%IRQRS(3*NAPROC) ) + CALL W3XDMA ( IMOD, NDSE, NDST, FLGRDALL ) ENDIF - IRQRS => OUTPTS(IMOD)%OUT4%IRQRS -#endif -! -! 2.b Fields at end of file (always) -! -#ifdef W3_MPIT - WRITE (NDST,9020) -#endif -! -#ifdef W3_MPI - IF ( IAPROC.NE.NAPRST .AND. IAPROC.LE.NAPROC ) THEN -#endif -! -#ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 1 - CALL MPI_SEND_INIT (UST (IAPROC), 1, WW3_FIELD_VEC, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S U*', IROOT, IT, IRQRS(IH), IERR -#endif -! -#ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 2 - CALL MPI_SEND_INIT (USTDIR(IAPROC), 1, WW3_FIELD_VEC, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S UD', IROOT, IT, IRQRS(IH), IERR -#endif -! -#ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 3 - CALL MPI_SEND_INIT (FPIS(IAPROC), 1, WW3_FIELD_VEC, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S FP', IROOT, IT, IRQRS(IH), IERR -#endif -! -#ifdef W3_MPI - ELSE IF ( IAPROC .EQ. NAPRST ) THEN - DO I0=1, NAPROC - IFROM = I0 - 1 - IF ( I0 .NE. IAPROC ) THEN -#endif -! -#ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 1 - CALL MPI_RECV_INIT (UST (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R U*', IFROM, IT, IRQRS(IH), IERR -#endif -! -#ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 2 - CALL MPI_RECV_INIT (USTDIR(I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R UD', IFROM, IT, IRQRS(IH), IERR -#endif -! -#ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 3 - CALL MPI_RECV_INIT (FPIS(I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R FP', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF - END DO - END IF -#endif -! -#ifdef W3_MPI - IF (OARST) THEN - IF ( FLOGRR( 1, 2) ) THEN + ! + ! 1.c Receives of fields + ! + CALL W3XETA ( IMOD, NDSE, NDST ) + if (w3_mpit_flag) then + WRITE (NDST,9010) '(RECV)' + end if + ! + IH = 0 + ! + DO I0=1, NAPROC + IT = IT0 + IFROM = I0 - 1 + ! + IF ( FLGRDALL( 1, 12) ) THEN IH = IH + 1 - IT = IT0 + 4 - CALL MPI_SEND_INIT (CX(IAPROC), 1, WW3_FIELD_VEC, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S CX', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI + IT = IT + 1 + CALL MPI_RECV_INIT (ICEF (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 1/09', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 1) ) THEN IH = IH + 1 - IT = IT0 + 5 - CALL MPI_SEND_INIT (CY(IAPROC), 1, WW3_FIELD_VEC, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S CY', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 1, 12) ) THEN + IT = IT + 1 + CALL MPI_RECV_INIT (HS (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/01', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 2) ) THEN IH = IH + 1 - IT = IT0 + 6 - CALL MPI_SEND_INIT (ICEF(IAPROC), 1, WW3_FIELD_VEC, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S IF', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 2, 1) ) THEN + IT = IT + 1 + CALL MPI_RECV_INIT (WLM (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/02', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 3) ) THEN IH = IH + 1 - IT = IT0 + 7 - CALL MPI_SEND_INIT (HS (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S HS', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 2, 2) ) THEN + IT = IT + 1 + CALL MPI_RECV_INIT (T02 (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/03', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 4) ) THEN IH = IH + 1 - IT = IT0 + 8 - CALL MPI_SEND_INIT (WLM (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S WL', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 2, 4) ) THEN + IT = IT + 1 + CALL MPI_RECV_INIT (T0M1 (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/04', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 5) ) THEN IH = IH + 1 - IT = IT0 + 9 - CALL MPI_SEND_INIT (T0M1(1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S T0', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - ENDIF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 2, 5) ) THEN + IT = IT + 1 + CALL MPI_RECV_INIT (T01(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/05', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 6) .OR. FLGRDALL( 2,18) ) THEN + ! TP output shares FP0 internal field with FP IH = IH + 1 - IT = IT0 + 10 - CALL MPI_SEND_INIT (T01 (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S T1', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - ENDIF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 2, 6) ) THEN + IT = IT + 1 + CALL MPI_RECV_INIT (FP0 (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/06', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 7) ) THEN IH = IH + 1 - IT = IT0 + 11 - CALL MPI_SEND_INIT (FP0 (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S FP', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 2, 7) ) THEN + IT = IT + 1 + CALL MPI_RECV_INIT (THM (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/07', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 8) ) THEN IH = IH + 1 - IT = IT0 + 12 - CALL MPI_SEND_INIT (THM (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S TH', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 2, 19) ) THEN + IT = IT + 1 + CALL MPI_RECV_INIT (THS (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/08', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 9) ) THEN IH = IH + 1 - IT = IT0 + 13 - CALL MPI_SEND_INIT (WNMEAN(1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S WM', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 5, 2) ) THEN + IT = IT + 1 + CALL MPI_RECV_INIT (THP0 (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/09', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 10) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (HSIG (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/10', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 11) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (STMAXE (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/11', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 12) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (STMAXD(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/12', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 13) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (HMAXE (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/13', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 14) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (HCMAXE(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/14', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 15) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (HMAXD (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/15', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 16) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (HCMAXD(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/16', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 17) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (WBT(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/17', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 2, 19) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (WNMEAN(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 2/19', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 3, 1) ) THEN + DO IK=E3DF(2,1),E3DF(3,1) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (EF(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, 'EF', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 3, 2) ) THEN + DO IK=E3DF(2,2),E3DF(3,2) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TH1M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, 'TH1M', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 3, 3) ) THEN + DO IK=E3DF(2,3),E3DF(3,3) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (STH1M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, 'STH1M', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 3, 4) ) THEN + DO IK=E3DF(2,4),E3DF(3,4) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TH2M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, 'TH2M', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 3, 5) ) THEN + DO IK=E3DF(2,5),E3DF(3,5) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (STH2M(I0,IK),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, 'STH2M', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4, 1) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PHS(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/01', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4, 2) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PTP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/02', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4, 3) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PLP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/03', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4, 4) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PDIR(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/04', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4, 5) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PSI(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/05', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4, 6) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PWS(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/06', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4, 7) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PTHP0(I0,K),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/07', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4, 8) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PQP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/08', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4, 9) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PPE(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/09', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4,10) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PGW(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/10', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4,11) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PSW(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/11', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4,12) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PTM1(I0,K),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/12', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4,13) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PT1(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/13', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4,14) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PT2(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/14', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4,15) ) THEN + DO K=0, NOSWLL + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PEP(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/15', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 4,16) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PWST (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/16', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 4,17) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PNR (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 4/17', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 5, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (UST (I0), 1, WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/01', IFROM, IT, IRQGO2(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (USTDIR(I0), 1, WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/01', IFROM, IT, IRQGO2(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (ASF (I0), 1, WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/01', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 5, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (CHARN(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/02', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 5, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (CGE (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/03', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 5, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PHIAW(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/04', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 5, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUWIX(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/05', IFROM, IT, IRQGO2(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUWIY(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/05', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 5, 6) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUWNX(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/06', IFROM, IT, IRQGO2(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUWNY(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/06', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 5, 7) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (WHITECAP(I0,1),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/07', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 5, 8) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (WHITECAP(I0,2),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/08', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 5, 9) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (WHITECAP(I0,3),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/09', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 5,10) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (WHITECAP(I0,4),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/10', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 5,11) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TWS(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 5/11', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 6, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (SXX (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/01', IFROM, IT, IRQGO2(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (SYY (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/01', IFROM, IT, IRQGO2(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (SXY (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/01', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 6, 2) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUOX (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/02', IFROM, IT, IRQGO2(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUOY (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/02', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 6, 3) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (BHD(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/03', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 6, 4) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PHIOC (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/04', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 6, 5) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TUSX (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/05', IFROM, IT, IRQGO2(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TUSY (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/05', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 6, 6) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (USSX (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/06', IFROM, IT, IRQGO2(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (USSY (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/06', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 6, 7) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PRMS (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/07', IFROM, IT, IRQGO2(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TPMS (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/07', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 6, 8) ) THEN + DO IK=1,2*NK + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (US3D(I0,IK),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, 'US3D ', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 6, 9) ) THEN + DO K=P2MSF(2),P2MSF(3) + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (P2SMS(I0,K),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, 'P3SMS', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 6,10) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUICE (I0,1),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/10', IFROM, IT, IRQGO2(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUICE (I0,2),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/10', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 6,11) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (PHICE (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/11', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 6, 12) ) THEN + DO IK=1,2*NK + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (USSP(I0,IK),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, 'USSP ', IFROM, IT, IRQGO2(IH), IERR + end if + END DO + END IF + ! + IF ( FLGRDALL( 6, 13) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUOCX(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/13', IFROM, IT, IRQGO2(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (TAUOCY(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/13', IFROM, IT, IRQGO2(IH), IERR + end if + END IF +#ifdef W3_CESMCOUPLED + IF ( FLGRDALL( 6, 14) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (LANGMT(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR) + END IF + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 6/14', IFROM, IT, IRQGO2(IH), IERR + endif +#endif + ! + IF ( FLGRDALL( 7, 1) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (ABA (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 7/01', IFROM, IT, IRQGO2(IH), IERR + end if + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (ABD (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 7/01', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 7, 2) ) THEN IH = IH + 1 - IT = IT0 + 14 - CALL MPI_SEND_INIT (CHARN(1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S CH', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - ENDIF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 5, 5) ) THEN + IT = IT + 1 + CALL MPI_RECV_INIT (UBA (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 7/02', IFROM, IT, IRQGO2(IH), IERR + end if IH = IH + 1 - IT = IT0 + 15 - CALL MPI_SEND_INIT (TAUWIX(1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S WX', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI + IT = IT + 1 + CALL MPI_RECV_INIT (UBD (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 7/02', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 7, 3) ) THEN IH = IH + 1 - IT = IT0 + 16 - CALL MPI_SEND_INIT (TAUWIY(1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S WY', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 5, 11) ) THEN + IT = IT + 1 + CALL MPI_RECV_INIT (BEDFORMS(I0,1),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 7/03', IFROM, IT, IRQGO2(IH), IERR + end if IH = IH + 1 - IT = IT0 + 17 - CALL MPI_SEND_INIT (TWS (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S TS', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 6, 2) ) THEN + IT = IT + 1 + CALL MPI_RECV_INIT (BEDFORMS(I0,2),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 7/03', IFROM, IT, IRQGO2(IH), IERR + end if IH = IH + 1 - IT = IT0 + 18 - CALL MPI_SEND_INIT (TAUOX(1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S OX', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI + IT = IT + 1 + CALL MPI_RECV_INIT (BEDFORMS(I0,3),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 7/03', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 7, 4) ) THEN IH = IH + 1 - IT = IT0 + 19 - CALL MPI_SEND_INIT (TAUOY(1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S OY', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 6, 3) ) THEN + IT = IT + 1 + CALL MPI_RECV_INIT (PHIBBL(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 7/04', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 7, 5) ) THEN IH = IH + 1 - IT = IT0 + 20 - CALL MPI_SEND_INIT (BHD (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S BH', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 6, 4) ) THEN + IT = IT + 1 + CALL MPI_RECV_INIT (TAUBBL(I0,1),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 7/05', IFROM, IT, IRQGO2(IH), IERR + end if IH = IH + 1 - IT = IT0 + 21 - CALL MPI_SEND_INIT (PHIOC(1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S PH', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 6, 5) ) THEN + IT = IT + 1 + CALL MPI_RECV_INIT (TAUBBL(I0,2),1,WW3_FIELD_VEC, IFROM, & + IT, MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 7/05', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 8, 1) ) THEN IH = IH + 1 - IT = IT0 + 22 - CALL MPI_SEND_INIT (TUSX (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S UX', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI + IT = IT + 1 + CALL MPI_RECV_INIT (MSSX (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 8/01', IFROM, IT, IRQGO2(IH), IERR + end if IH = IH + 1 - IT = IT0 + 23 - CALL MPI_SEND_INIT (TUSY (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S UY', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 6, 6) ) THEN + IT = IT + 1 + CALL MPI_RECV_INIT (MSSY (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 8/01', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 8, 2) ) THEN IH = IH + 1 - IT = IT0 + 24 - CALL MPI_SEND_INIT (USSX (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S SX', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI + IT = IT + 1 + CALL MPI_RECV_INIT (MSCX (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 8/02', IFROM, IT, IRQGO2(IH), IERR + end if IH = IH + 1 - IT = IT0 + 25 - CALL MPI_SEND_INIT (USSY (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S SY', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 6,10) ) THEN + IT = IT + 1 + CALL MPI_RECV_INIT (MSCY (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 8/02', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 8, 3) ) THEN IH = IH + 1 - IT = IT0 + 26 - CALL MPI_SEND_INIT (TAUICE(1,1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S I1', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI + IT = IT + 1 + CALL MPI_RECV_INIT (MSSD (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 8/03', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 8, 4) ) THEN IH = IH + 1 - IT = IT0 + 27 - CALL MPI_SEND_INIT (TAUICE(1,2), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S I2', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 6,13) ) THEN + IT = IT + 1 + CALL MPI_RECV_INIT (MSCD (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 8/04', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 8, 5) ) THEN IH = IH + 1 - IT = IT0 + 28 - CALL MPI_SEND_INIT (TAUOCX(1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S TX', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI + IT = IT + 1 + CALL MPI_RECV_INIT (QP (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 8/05', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 9, 1) ) THEN IH = IH + 1 - IT = IT0 + 29 - CALL MPI_SEND_INIT (TAUOCY(1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S TY', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 7, 2) ) THEN + IT = IT + 1 + CALL MPI_RECV_INIT (DTDYN(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 9/01', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 9, 2) ) THEN IH = IH + 1 - IT = IT0 + 30 - CALL MPI_SEND_INIT (UBA (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S BA', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI + IT = IT + 1 + CALL MPI_RECV_INIT (FCUT (I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 9/02', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 9, 3) ) THEN IH = IH + 1 - IT = IT0 + 31 - CALL MPI_SEND_INIT (UBD (1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S BD', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 7, 4) ) THEN + IT = IT + 1 + CALL MPI_RECV_INIT (CFLXYMAX(I0),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 9/03', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 9, 4) ) THEN IH = IH + 1 - IT = IT0 + 32 - CALL MPI_SEND_INIT (PHIBBL(1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S PB', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 7, 5) ) THEN + IT = IT + 1 + CALL MPI_RECV_INIT (CFLTHMAX(I0),1,WW3_FIELD_VEC, IFROM, IT,& + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 9/04', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + IF ( FLGRDALL( 9, 5) ) THEN IH = IH + 1 - IT = IT0 + 33 - CALL MPI_SEND_INIT (TAUBBL(1,1), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S T1', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI + IT = IT + 1 + CALL MPI_RECV_INIT (CFLKMAX(I0),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH, ' 9/05', IFROM, IT, IRQGO2(IH), IERR + end if + END IF + ! + DO I=1, NOEXTR + !WRITE(740+IAPROC,*) 'SECOND : I=', I, ' / ', NOEXTR, ' val=', FLGRDALL(10, I) + IF ( FLGRDALL(10, I) ) THEN + IH = IH + 1 + IT = IT + 1 + CALL MPI_RECV_INIT (USERO(I0,I),1,WW3_FIELD_VEC, IFROM, IT, & + MPI_COMM_WAVE, IRQGO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (STRING,'(A3,I2.2)') '10/', I + WRITE (NDST,9011) IH, STRING, IFROM, IT, IRQGO2(IH), IERR + end if + END IF + END DO + ! + END DO + ! + NRQGO2 = IH + if (w3_mpit_flag) then + WRITE (NDST,9012) + WRITE (NDST,9014) NRQGO2, NRQMAX*NAPROC + end if + ! + CALL W3SETA ( IMOD, NDSE, NDST ) + ! + END IF + ! + IF ( NRQGO2 .GT. NRQMAX*NAPROC ) THEN + WRITE (NDSE,1011) NRQGO2, NRQMAX*NAPROC + CALL EXTCDE (11) + END IF + ! + END IF + ! + ! 2. Set-up for W3IORS ---------------------------------------------- / + ! 2.a General preparations + ! + NRQRS = 0 + IH = 0 + IROOT = NAPRST - 1 + ! + IF ( FLOUT(4) .OR. FLOUT(8) ) THEN + IF (OARST) THEN + ALLOCATE ( OUTPTS(IMOD)%OUT4%IRQRS(34*NAPROC) ) + ELSE + ALLOCATE ( OUTPTS(IMOD)%OUT4%IRQRS(3*NAPROC) ) + ENDIF + IRQRS => OUTPTS(IMOD)%OUT4%IRQRS + ! + ! 2.b Fields at end of file (always) + ! + if (w3_mpit_flag) then + WRITE (NDST,9020) + end if + ! + IF ( IAPROC.NE.NAPRST .AND. IAPROC.LE.NAPROC ) THEN + ! + IH = IH + 1 + IT = IT0 + 1 + CALL MPI_SEND_INIT (UST (IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S U*', IROOT, IT, IRQRS(IH), IERR + end if + ! + IH = IH + 1 + IT = IT0 + 2 + CALL MPI_SEND_INIT (USTDIR(IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S UD', IROOT, IT, IRQRS(IH), IERR + end if + ! + IH = IH + 1 + IT = IT0 + 3 + CALL MPI_SEND_INIT (FPIS(IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S FP', IROOT, IT, IRQRS(IH), IERR + end if + ! + ELSE IF ( IAPROC .EQ. NAPRST ) THEN + DO I0=1, NAPROC + IFROM = I0 - 1 + IF ( I0 .NE. IAPROC ) THEN + ! IH = IH + 1 - IT = IT0 + 34 - CALL MPI_SEND_INIT (TAUBBL(1,2), NSEALM, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'S T2', IROOT, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( IAPROC .EQ. NAPRST ) THEN - IF (NAPRST .NE. NAPFLD) CALL W3XDMA ( IMOD, NDSE, NDST, FLOGRR ) - CALL W3XETA ( IMOD, NDSE, NDST ) -#endif -! -#ifdef W3_MPI - DO I0=1, NAPROC - IFROM = I0 - 1 - IF ( FLOGRR( 1, 2) ) THEN - IH = IH + 1 - IT = IT0 + 4 - CALL MPI_RECV_INIT (CX (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R CX', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - IH = IT0 + 5 - IT = IT + 1 - CALL MPI_RECV_INIT (CY (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R CY', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 1, 12) ) THEN - IH = IH + 1 - IT = IT0 + 6 - CALL MPI_RECV_INIT (ICEF (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R IF', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 2, 1) ) THEN - IH = IH + 1 - IT = IT0 + 7 - CALL MPI_RECV_INIT (HS (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R HS', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 2, 2) ) THEN - IH = IH + 1 - IT = IT0 + 8 - CALL MPI_RECV_INIT (WLM (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R WL', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 2, 4) ) THEN - IH = IH + 1 - IT = IT0 + 9 - CALL MPI_RECV_INIT (T0M1(I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R T0', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - ENDIF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 2, 5) ) THEN - IH = IH + 1 - IT = IT0 + 10 - CALL MPI_RECV_INIT (T01 (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R T1', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - ENDIF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 2, 6) ) THEN - IH = IH + 1 - IT = IT0 + 11 - CALL MPI_RECV_INIT (FP0 (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R FP', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 2, 7) ) THEN - IH = IH + 1 - IT = IT0 + 12 - CALL MPI_RECV_INIT (THM (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R TH', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 2, 19) ) THEN - IH = IH + 1 - IT = IT0 + 13 - CALL MPI_RECV_INIT (WNMEAN(I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R WM', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 5, 2) ) THEN - IH = IH + 1 - IT = IT0 + 14 - CALL MPI_RECV_INIT (CHARN(I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R CH', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - ENDIF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 5, 5) ) THEN - IH = IH + 1 - IT = IT0 + 15 - CALL MPI_RECV_INIT (TAUWIX(I0),1,WW3_FIELD_VEC,& - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R WX', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 16 - CALL MPI_RECV_INIT (TAUWIY(I0),1,WW3_FIELD_VEC,& - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R WY', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 5,11) ) THEN - IH = IH + 1 - IT = IT0 + 17 - CALL MPI_RECV_INIT (TWS (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R TS', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 6, 2) ) THEN - IH = IH + 1 - IT = IT0 + 18 - CALL MPI_RECV_INIT (TAUOX(I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R OX', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 19 - CALL MPI_RECV_INIT (TAUOY(I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R OY', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 6, 3) ) THEN - IH = IH + 1 - IT = IT0 + 20 - CALL MPI_RECV_INIT (BHD (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R BH', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 6, 4) ) THEN - IH = IH + 1 - IT = IT0 + 21 - CALL MPI_RECV_INIT (PHIOC(I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R PH', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 6, 5) ) THEN - IH = IH + 1 - IT = IT0 + 22 - CALL MPI_RECV_INIT (TUSX (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R UX', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 23 - CALL MPI_RECV_INIT (TUSY (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R UY', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 6, 6) ) THEN - IH = IH + 1 - IT = IT0 + 24 - CALL MPI_RECV_INIT (USSX (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R SX', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 25 - CALL MPI_RECV_INIT (USSY (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R SY', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 6,10) ) THEN - IH = IH + 1 - IT = IT0 + 26 - CALL MPI_RECV_INIT (TAUICE(I0,1),1,WW3_FIELD_VEC,& - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R I1', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 27 - CALL MPI_RECV_INIT (TAUICE(I0,2),1,WW3_FIELD_VEC,& - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R I2', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 6,13) ) THEN - IH = IH + 1 - IT = IT0 + 28 - CALL MPI_RECV_INIT (TAUOCX(I0),1,WW3_FIELD_VEC,& - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R SX', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 29 - CALL MPI_RECV_INIT (TAUOCY(I0),1,WW3_FIELD_VEC,& - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R SY', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 7, 2) ) THEN - IH = IH + 1 - IT = IT0 + 30 - CALL MPI_RECV_INIT (UBA (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R BA', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 31 - CALL MPI_RECV_INIT (UBD (I0),1,WW3_FIELD_VEC, & - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R BD', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 7, 4) ) THEN - IH = IH + 1 - IT = IT0 + 32 - CALL MPI_RECV_INIT (PHIBBL(I0),1,WW3_FIELD_VEC,& - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R PB', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IF ( FLOGRR( 7, 5) ) THEN - IH = IH + 1 - IT = IT0 + 33 - CALL MPI_RECV_INIT (TAUBBL(I0,1),1,WW3_FIELD_VEC,& - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R T1', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 34 - CALL MPI_RECV_INIT (TAUBBL(I0,2),1,WW3_FIELD_VEC,& - IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9021) IH, 'R T2', IFROM, IT, IRQRS(IH), IERR -#endif -#ifdef W3_MPI - END IF - END DO -#endif -! -#ifdef W3_MPI - CALL W3SETA ( IMOD, NDSE, NDST ) - END IF + IT = IT0 + 1 + CALL MPI_RECV_INIT (UST (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R U*', IFROM, IT, IRQRS(IH), IERR + end if + ! + IH = IH + 1 + IT = IT0 + 2 + CALL MPI_RECV_INIT (USTDIR(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R UD', IFROM, IT, IRQRS(IH), IERR + end if + ! + IH = IH + 1 + IT = IT0 + 3 + CALL MPI_RECV_INIT (FPIS(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R FP', IFROM, IT, IRQRS(IH), IERR + end if + END IF + END DO + END IF + ! + IF (OARST) THEN + IF ( FLOGRR( 1, 2) ) THEN + IH = IH + 1 + IT = IT0 + 4 + CALL MPI_SEND_INIT (CX(IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S CX', IROOT, IT, IRQRS(IH), IERR + end if + IH = IH + 1 + IT = IT0 + 5 + CALL MPI_SEND_INIT (CY(IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S CY', IROOT, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 1, 12) ) THEN + IH = IH + 1 + IT = IT0 + 6 + CALL MPI_SEND_INIT (ICEF(IAPROC), 1, WW3_FIELD_VEC, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S IF', IROOT, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 2, 1) ) THEN + IH = IH + 1 + IT = IT0 + 7 + CALL MPI_SEND_INIT (HS (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S HS', IROOT, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 2, 2) ) THEN + IH = IH + 1 + IT = IT0 + 8 + CALL MPI_SEND_INIT (WLM (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S WL', IROOT, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 2, 4) ) THEN + IH = IH + 1 + IT = IT0 + 9 + CALL MPI_SEND_INIT (T0M1(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S T0', IROOT, IT, IRQRS(IH), IERR + end if + ENDIF + ! + IF ( FLOGRR( 2, 5) ) THEN + IH = IH + 1 + IT = IT0 + 10 + CALL MPI_SEND_INIT (T01 (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S T1', IROOT, IT, IRQRS(IH), IERR + end if + ENDIF + ! + IF ( FLOGRR( 2, 6) ) THEN + IH = IH + 1 + IT = IT0 + 11 + CALL MPI_SEND_INIT (FP0 (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S FP', IROOT, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 2, 7) ) THEN + IH = IH + 1 + IT = IT0 + 12 + CALL MPI_SEND_INIT (THM (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S TH', IROOT, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 2, 19) ) THEN + IH = IH + 1 + IT = IT0 + 13 + CALL MPI_SEND_INIT (WNMEAN(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S WM', IROOT, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 5, 2) ) THEN + IH = IH + 1 + IT = IT0 + 14 + CALL MPI_SEND_INIT (CHARN(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S CH', IROOT, IT, IRQRS(IH), IERR + end if + ENDIF + ! + IF ( FLOGRR( 5, 5) ) THEN + IH = IH + 1 + IT = IT0 + 15 + CALL MPI_SEND_INIT (TAUWIX(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S WX', IROOT, IT, IRQRS(IH), IERR + end if + IH = IH + 1 + IT = IT0 + 16 + CALL MPI_SEND_INIT (TAUWIY(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S WY', IROOT, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 5, 11) ) THEN + IH = IH + 1 + IT = IT0 + 17 + CALL MPI_SEND_INIT (TWS (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S TS', IROOT, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 6, 2) ) THEN + IH = IH + 1 + IT = IT0 + 18 + CALL MPI_SEND_INIT (TAUOX(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S OX', IROOT, IT, IRQRS(IH), IERR + end if + IH = IH + 1 + IT = IT0 + 19 + CALL MPI_SEND_INIT (TAUOY(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S OY', IROOT, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 6, 3) ) THEN + IH = IH + 1 + IT = IT0 + 20 + CALL MPI_SEND_INIT (BHD (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S BH', IROOT, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 6, 4) ) THEN + IH = IH + 1 + IT = IT0 + 21 + CALL MPI_SEND_INIT (PHIOC(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S PH', IROOT, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 6, 5) ) THEN + IH = IH + 1 + IT = IT0 + 22 + CALL MPI_SEND_INIT (TUSX (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S UX', IROOT, IT, IRQRS(IH), IERR + end if + IH = IH + 1 + IT = IT0 + 23 + CALL MPI_SEND_INIT (TUSY (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S UY', IROOT, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 6, 6) ) THEN + IH = IH + 1 + IT = IT0 + 24 + CALL MPI_SEND_INIT (USSX (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S SX', IROOT, IT, IRQRS(IH), IERR + end if + IH = IH + 1 + IT = IT0 + 25 + CALL MPI_SEND_INIT (USSY (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S SY', IROOT, IT, IRQRS(IH), IERR + end if END IF -#endif -! -#ifdef W3_MPI - NRQRS = IH - IF (OARST) THEN - IT0 = IT0 + 34 - ELSE - IT0 = IT0 + 3 - ENDIF -#endif -! -#ifdef W3_MPIT + ! + IF ( FLOGRR( 6,10) ) THEN + IH = IH + 1 + IT = IT0 + 26 + CALL MPI_SEND_INIT (TAUICE(1,1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S I1', IROOT, IT, IRQRS(IH), IERR + end if + IH = IH + 1 + IT = IT0 + 27 + CALL MPI_SEND_INIT (TAUICE(1,2), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S I2', IROOT, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 6,13) ) THEN + IH = IH + 1 + IT = IT0 + 28 + CALL MPI_SEND_INIT (TAUOCX(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S TX', IROOT, IT, IRQRS(IH), IERR + end if + IH = IH + 1 + IT = IT0 + 29 + CALL MPI_SEND_INIT (TAUOCY(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S TY', IROOT, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 7, 2) ) THEN + IH = IH + 1 + IT = IT0 + 30 + CALL MPI_SEND_INIT (UBA (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S BA', IROOT, IT, IRQRS(IH), IERR + end if + IH = IH + 1 + IT = IT0 + 31 + CALL MPI_SEND_INIT (UBD (1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S BD', IROOT, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 7, 4) ) THEN + IH = IH + 1 + IT = IT0 + 32 + CALL MPI_SEND_INIT (PHIBBL(1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S PB', IROOT, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 7, 5) ) THEN + IH = IH + 1 + IT = IT0 + 33 + CALL MPI_SEND_INIT (TAUBBL(1,1), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S T1', IROOT, IT, IRQRS(IH), IERR + end if + IH = IH + 1 + IT = IT0 + 34 + CALL MPI_SEND_INIT (TAUBBL(1,2), NSEALM, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQRS(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'S T2', IROOT, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( IAPROC .EQ. NAPRST ) THEN + IF (NAPRST .NE. NAPFLD) CALL W3XDMA ( IMOD, NDSE, NDST, FLOGRR ) + CALL W3XETA ( IMOD, NDSE, NDST ) + ! + DO I0=1, NAPROC + IFROM = I0 - 1 + IF ( FLOGRR( 1, 2) ) THEN + IH = IH + 1 + IT = IT0 + 4 + CALL MPI_RECV_INIT (CX (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R CX', IFROM, IT, IRQRS(IH), IERR + end if + IH = IT0 + 5 + IT = IT + 1 + CALL MPI_RECV_INIT (CY (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R CY', IFROM, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 1, 12) ) THEN + IH = IH + 1 + IT = IT0 + 6 + CALL MPI_RECV_INIT (ICEF (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R IF', IFROM, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 2, 1) ) THEN + IH = IH + 1 + IT = IT0 + 7 + CALL MPI_RECV_INIT (HS (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R HS', IFROM, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 2, 2) ) THEN + IH = IH + 1 + IT = IT0 + 8 + CALL MPI_RECV_INIT (WLM (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R WL', IFROM, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 2, 4) ) THEN + IH = IH + 1 + IT = IT0 + 9 + CALL MPI_RECV_INIT (T0M1(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R T0', IFROM, IT, IRQRS(IH), IERR + end if + ENDIF + ! + IF ( FLOGRR( 2, 5) ) THEN + IH = IH + 1 + IT = IT0 + 10 + CALL MPI_RECV_INIT (T01 (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R T1', IFROM, IT, IRQRS(IH), IERR + end if + ENDIF + ! + IF ( FLOGRR( 2, 6) ) THEN + IH = IH + 1 + IT = IT0 + 11 + CALL MPI_RECV_INIT (FP0 (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R FP', IFROM, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 2, 7) ) THEN + IH = IH + 1 + IT = IT0 + 12 + CALL MPI_RECV_INIT (THM (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R TH', IFROM, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 2, 19) ) THEN + IH = IH + 1 + IT = IT0 + 13 + CALL MPI_RECV_INIT (WNMEAN(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R WM', IFROM, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 5, 2) ) THEN + IH = IH + 1 + IT = IT0 + 14 + CALL MPI_RECV_INIT (CHARN(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R CH', IFROM, IT, IRQRS(IH), IERR + end if + ENDIF + ! + IF ( FLOGRR( 5, 5) ) THEN + IH = IH + 1 + IT = IT0 + 15 + CALL MPI_RECV_INIT (TAUWIX(I0),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R WX', IFROM, IT, IRQRS(IH), IERR + end if + IH = IH + 1 + IT = IT0 + 16 + CALL MPI_RECV_INIT (TAUWIY(I0),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R WY', IFROM, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 5,11) ) THEN + IH = IH + 1 + IT = IT0 + 17 + CALL MPI_RECV_INIT (TWS (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R TS', IFROM, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 6, 2) ) THEN + IH = IH + 1 + IT = IT0 + 18 + CALL MPI_RECV_INIT (TAUOX(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R OX', IFROM, IT, IRQRS(IH), IERR + end if + IH = IH + 1 + IT = IT0 + 19 + CALL MPI_RECV_INIT (TAUOY(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R OY', IFROM, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 6, 3) ) THEN + IH = IH + 1 + IT = IT0 + 20 + CALL MPI_RECV_INIT (BHD (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R BH', IFROM, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 6, 4) ) THEN + IH = IH + 1 + IT = IT0 + 21 + CALL MPI_RECV_INIT (PHIOC(I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R PH', IFROM, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 6, 5) ) THEN + IH = IH + 1 + IT = IT0 + 22 + CALL MPI_RECV_INIT (TUSX (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R UX', IFROM, IT, IRQRS(IH), IERR + end if + IH = IH + 1 + IT = IT0 + 23 + CALL MPI_RECV_INIT (TUSY (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R UY', IFROM, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 6, 6) ) THEN + IH = IH + 1 + IT = IT0 + 24 + CALL MPI_RECV_INIT (USSX (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R SX', IFROM, IT, IRQRS(IH), IERR + end if + IH = IH + 1 + IT = IT0 + 25 + CALL MPI_RECV_INIT (USSY (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R SY', IFROM, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 6,10) ) THEN + IH = IH + 1 + IT = IT0 + 26 + CALL MPI_RECV_INIT (TAUICE(I0,1),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R I1', IFROM, IT, IRQRS(IH), IERR + end if + IH = IH + 1 + IT = IT0 + 27 + CALL MPI_RECV_INIT (TAUICE(I0,2),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R I2', IFROM, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 6,13) ) THEN + IH = IH + 1 + IT = IT0 + 28 + CALL MPI_RECV_INIT (TAUOCX(I0),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R SX', IFROM, IT, IRQRS(IH), IERR + end if + IH = IH + 1 + IT = IT0 + 29 + CALL MPI_RECV_INIT (TAUOCY(I0),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R SY', IFROM, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 7, 2) ) THEN + IH = IH + 1 + IT = IT0 + 30 + CALL MPI_RECV_INIT (UBA (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R BA', IFROM, IT, IRQRS(IH), IERR + end if + IH = IH + 1 + IT = IT0 + 31 + CALL MPI_RECV_INIT (UBD (I0),1,WW3_FIELD_VEC, & + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R BD', IFROM, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 7, 4) ) THEN + IH = IH + 1 + IT = IT0 + 32 + CALL MPI_RECV_INIT (PHIBBL(I0),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R PB', IFROM, IT, IRQRS(IH), IERR + end if + END IF + ! + IF ( FLOGRR( 7, 5) ) THEN + IH = IH + 1 + IT = IT0 + 33 + CALL MPI_RECV_INIT (TAUBBL(I0,1),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R T1', IFROM, IT, IRQRS(IH), IERR + end if + IH = IH + 1 + IT = IT0 + 34 + CALL MPI_RECV_INIT (TAUBBL(I0,2),1,WW3_FIELD_VEC,& + IFROM, IT, MPI_COMM_WAVE, IRQRS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9021) IH, 'R T2', IFROM, IT, IRQRS(IH), IERR + end if + END IF + END DO + ! + CALL W3SETA ( IMOD, NDSE, NDST ) + END IF + END IF + ! + NRQRS = IH + IF (OARST) THEN + IT0 = IT0 + 34 + ELSE + IT0 = IT0 + 3 + ENDIF + ! + if (w3_mpit_flag) then WRITE (NDST,9022) WRITE (NDST,9023) NRQRS -#endif -! -! 2.c Data server mode -! -#ifdef W3_MPI - IF ( IOSTYP .GT. 0 ) THEN -#endif -! -#ifdef W3_MPI - NBLKRS = 10 - RSBLKS = MAX ( 5 , NSEALM/NBLKRS ) - IF ( NBLKRS*RSBLKS .LT. NSEALM ) RSBLKS = RSBLKS + 1 - NBLKRS = 1 + (NSEALM-1)/RSBLKS -#endif -! -#ifdef W3_MPIT - WRITE (NDST,9025) RSBLKS, NBLKRS -#endif -#ifdef W3_MPI - IH = 0 -#endif -! -#ifdef W3_MPI - IF ((.NOT. LPDLIB).OR.(GTYPE .NE. UNGTYPE)) THEN - IF ( IAPROC .NE. NAPRST ) THEN -#endif -! -#ifdef W3_MPI - ALLOCATE ( OUTPTS(IMOD)%OUT4%IRQRSS(NBLKRS) ) - IRQRSS => OUTPTS(IMOD)%OUT4%IRQRSS -#endif -! -#ifdef W3_MPI - DO IB=1, NBLKRS - IH = IH + 1 - IT = IT0 + 3 + IB - JSEA0 = 1 + (IB-1)*RSBLKS - JSEAN = MIN ( NSEALM , IB*RSBLKS ) - NSEAB = 1 + JSEAN - JSEA0 - CALL MPI_SEND_INIT (VA(1,JSEA0), NSPEC*NSEAB,& - MPI_REAL, IROOT, IT, MPI_COMM_WAVE, & - IRQRSS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9026) IH, 'S', IB, IROOT, IT, & + end if + ! + ! 2.c Data server mode + ! + IF ( IOSTYP .GT. 0 ) THEN + ! + NBLKRS = 10 + RSBLKS = MAX ( 5 , NSEALM/NBLKRS ) + IF ( NBLKRS*RSBLKS .LT. NSEALM ) RSBLKS = RSBLKS + 1 + NBLKRS = 1 + (NSEALM-1)/RSBLKS + ! + if (w3_mpit_flag) then + WRITE (NDST,9025) RSBLKS, NBLKRS + end if + IH = 0 + ! + IF ((.NOT. LPDLIB).OR.(GTYPE .NE. UNGTYPE)) THEN + IF ( IAPROC .NE. NAPRST ) THEN + ! + ALLOCATE ( OUTPTS(IMOD)%OUT4%IRQRSS(NBLKRS) ) + IRQRSS => OUTPTS(IMOD)%OUT4%IRQRSS + ! + DO IB=1, NBLKRS + IH = IH + 1 + IT = IT0 + 3 + IB + JSEA0 = 1 + (IB-1)*RSBLKS + JSEAN = MIN ( NSEALM , IB*RSBLKS ) + NSEAB = 1 + JSEAN - JSEA0 + CALL MPI_SEND_INIT (VA(1,JSEA0), NSPEC*NSEAB,& + MPI_REAL, IROOT, IT, MPI_COMM_WAVE, & + IRQRSS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9026) IH, 'S', IB, IROOT, IT, & IRQRSS(IH), IERR, NSEAB -#endif -#ifdef W3_MPI - END DO -#endif -! -#ifdef W3_MPI - ELSE -#endif -! -#ifdef W3_MPI - ALLOCATE & - ( OUTPTS(IMOD)%OUT4%IRQRSS(NAPROC*NBLKRS) , & - OUTPTS(IMOD)%OUT4%VAAUX(NSPEC,2*RSBLKS,NAPROC) ) -#endif -! -#ifdef W3_MPI - IRQRSS => OUTPTS(IMOD)%OUT4%IRQRSS - VAAUX => OUTPTS(IMOD)%OUT4%VAAUX - DO IB=1, NBLKRS - IT = IT0 + 3 + IB - JSEA0 = 1 + (IB-1)*RSBLKS - JSEAN = MIN ( NSEALM , IB*RSBLKS ) - NSEAB = 1 + JSEAN - JSEA0 - DO I0=1, NAPROC + end if + END DO + ! + ELSE + ! + ALLOCATE & + ( OUTPTS(IMOD)%OUT4%IRQRSS(NAPROC*NBLKRS) , & + OUTPTS(IMOD)%OUT4%VAAUX(NSPEC,2*RSBLKS,NAPROC) ) + ! + IRQRSS => OUTPTS(IMOD)%OUT4%IRQRSS + VAAUX => OUTPTS(IMOD)%OUT4%VAAUX + DO IB=1, NBLKRS + IT = IT0 + 3 + IB + JSEA0 = 1 + (IB-1)*RSBLKS + JSEAN = MIN ( NSEALM , IB*RSBLKS ) + NSEAB = 1 + JSEAN - JSEA0 + DO I0=1, NAPROC IF ( I0 .NE. NAPRST ) THEN - IH = IH + 1 - IFROM = I0 - 1 - IBOFF = MOD(IB-1,2)*RSBLKS - CALL MPI_RECV_INIT (VAAUX(1,1+IBOFF,I0),& - NSPEC*NSEAB, MPI_REAL, IFROM, IT, & - MPI_COMM_WAVE, IRQRSS(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9026) IH, 'R', IB, IFROM, & + IH = IH + 1 + IFROM = I0 - 1 + IBOFF = MOD(IB-1,2)*RSBLKS + CALL MPI_RECV_INIT (VAAUX(1,1+IBOFF,I0),& + NSPEC*NSEAB, MPI_REAL, IFROM, IT, & + MPI_COMM_WAVE, IRQRSS(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9026) IH, 'R', IB, IFROM, & IT, IRQRSS(IH), IERR, NSEAB -#endif -#ifdef W3_MPI - END IF - END DO - END DO -#endif -! -#ifdef W3_MPI - END IF - END IF -#endif -! -#ifdef W3_MPIT - WRITE (NDST,9027) - WRITE (NDST,9028) IH -#endif -#ifdef W3_MPI - IT0 = IT0 + NBLKRS -#endif -! -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - END IF -#endif -! -! 3. Set-up for W3IOBC ( SENDs ) ------------------------------------ / -! -#ifdef W3_MPI - NRQBP = 0 - NRQBP2 = 0 - IH = 0 - IT = IT0 - IROOT = NAPBPT - 1 -#endif -! -#ifdef W3_MPI - IF ( FLOUT(5) ) THEN - ALLOCATE ( OUTPTS(IMOD)%OUT5%IRQBP1(NBO2(NFBPO)), & - OUTPTS(IMOD)%OUT5%IRQBP2(NBO2(NFBPO)) ) - IRQBP1 => OUTPTS(IMOD)%OUT5%IRQBP1 - IRQBP2 => OUTPTS(IMOD)%OUT5%IRQBP2 -#endif -! -! 3.a Loops over files and points -! -#ifdef W3_MPIT + end if + END IF + END DO + END DO + ! + END IF + END IF + ! + if (w3_mpit_flag) then + WRITE (NDST,9027) + WRITE (NDST,9028) IH + end if + IT0 = IT0 + NBLKRS + ! + END IF + ! + END IF + ! + ! 3. Set-up for W3IOBC ( SENDs ) ------------------------------------ / + ! + NRQBP = 0 + NRQBP2 = 0 + IH = 0 + IT = IT0 + IROOT = NAPBPT - 1 + ! + IF ( FLOUT(5) ) THEN + ALLOCATE ( OUTPTS(IMOD)%OUT5%IRQBP1(NBO2(NFBPO)), & + OUTPTS(IMOD)%OUT5%IRQBP2(NBO2(NFBPO)) ) + IRQBP1 => OUTPTS(IMOD)%OUT5%IRQBP1 + IRQBP2 => OUTPTS(IMOD)%OUT5%IRQBP2 + ! + ! 3.a Loops over files and points + ! + if (w3_mpit_flag) then WRITE (NDST,9030) 'MPI_SEND_INIT' -#endif -! -#ifdef W3_MPI - DO J=1, NFBPO - DO I=NBO2(J-1)+1, NBO2(J) -#endif -! -#ifdef W3_MPI - IT = IT + 1 -#endif -! -! 3.b Residence processor of point -! -#ifdef W3_MPI - ISEA = ISBPO(I) - CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) -#endif -! -! 3.c If stored locally, send data -! -#ifdef W3_MPI - IF ( IAPROC .EQ. ISPROC ) THEN - IH = IH + 1 - CALL MPI_SEND_INIT (VA(1,JSEA),NSPEC,MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQBP1(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9031) IH, I, J, IROOT, IT, IRQBP1(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - END DO - END DO -#endif -! -! ... End of loops 4.a -! -#ifdef W3_MPI - NRQBP = IH -#endif -! -#ifdef W3_MPIT + end if + ! + DO J=1, NFBPO + DO I=NBO2(J-1)+1, NBO2(J) + ! + IT = IT + 1 + ! + ! 3.b Residence processor of point + ! + ISEA = ISBPO(I) + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) + ! + ! 3.c If stored locally, send data + ! + IF ( IAPROC .EQ. ISPROC ) THEN + IH = IH + 1 + CALL MPI_SEND_INIT (VA(1,JSEA),NSPEC,MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQBP1(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9031) IH, I, J, IROOT, IT, IRQBP1(IH), IERR + end if + END IF + ! + END DO + END DO + ! + ! ... End of loops 4.a + ! + NRQBP = IH + ! + if (w3_mpit_flag) then WRITE (NDST,9032) WRITE (NDST,9033) NRQBP -#endif -! -! 3.d Set-up for W3IOBC ( RECVs ) ------------------------------------ / -! -#ifdef W3_MPI - IF ( IAPROC .EQ. NAPBPT ) THEN -#endif -! -#ifdef W3_MPI - IH = 0 - IT = IT0 -#endif -! -! 3.e Loops over files and points -! -#ifdef W3_MPIT - WRITE (NDST,9030) 'MPI_RECV_INIT' -#endif -! -#ifdef W3_MPI - DO J=1, NFBPO - DO I=NBO2(J-1)+1, NBO2(J) -#endif -! -! 3.f Residence processor of point -! -#ifdef W3_MPI - ISEA = ISBPO(I) - CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) -#endif -! -! 3.g Receive in correct array -! -#ifdef W3_MPI - IH = IH + 1 - IT = IT + 1 - ITARG = ISPROC - 1 - CALL MPI_RECV_INIT (ABPOS(1,IH),NSPEC,MPI_REAL,& - ITARG, IT, MPI_COMM_WAVE, IRQBP2(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9031) IH, I, J, ITARG, IT, IRQBP2(IH), IERR -#endif -! -#ifdef W3_MPI - END DO - END DO -#endif -! -#ifdef W3_MPI - NRQBP2 = IH -#endif -! -! ... End of loops 4.e -! -#ifdef W3_MPIT - WRITE (NDST,9032) - WRITE (NDST,9033) NRQBP2 -#endif -! -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - IT0 = IT0 + NBO2(NFBPO) -#endif -! -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPIT - WRITE (NDST,*) -#endif -! -! 4. Set-up for W3IOTR ---------------------------------------------- / -! -#ifdef W3_MPI - IH = 0 - IROOT = NAPTRK - 1 -#endif -! -#ifdef W3_MPI - IF ( FLOUT(3) ) THEN -#endif -! -! 4.a U* -! -#ifdef W3_MPIT + end if + ! + ! 3.d Set-up for W3IOBC ( RECVs ) ------------------------------------ / + ! + IF ( IAPROC .EQ. NAPBPT ) THEN + ! + IH = 0 + IT = IT0 + ! + ! 3.e Loops over files and points + ! + if (w3_mpit_flag) then + WRITE (NDST,9030) 'MPI_RECV_INIT' + end if + ! + DO J=1, NFBPO + DO I=NBO2(J-1)+1, NBO2(J) + ! + ! 3.f Residence processor of point + ! + ISEA = ISBPO(I) + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) + ! + ! 3.g Receive in correct array + ! + IH = IH + 1 + IT = IT + 1 + ITARG = ISPROC - 1 + CALL MPI_RECV_INIT (ABPOS(1,IH),NSPEC,MPI_REAL,& + ITARG, IT, MPI_COMM_WAVE, IRQBP2(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9031) IH, I, J, ITARG, IT, IRQBP2(IH), IERR + end if + ! + END DO + END DO + ! + NRQBP2 = IH + ! + ! ... End of loops 4.e + ! + if (w3_mpit_flag) then + WRITE (NDST,9032) + WRITE (NDST,9033) NRQBP2 + end if + ! + END IF + ! + IT0 = IT0 + NBO2(NFBPO) + ! + END IF + ! + if (w3_mpit_flag) then + WRITE (NDST,*) + end if + ! + ! 4. Set-up for W3IOTR ---------------------------------------------- / + ! + IH = 0 + IROOT = NAPTRK - 1 + ! + IF ( FLOUT(3) ) THEN + ! + ! 4.a U* + ! + if (w3_mpit_flag) then WRITE (NDST,9040) -#endif -! -#ifdef W3_MPI - IF ( IAPROC .NE. NAPTRK ) THEN - ALLOCATE ( OUTPTS(IMOD)%OUT3%IRQTR(2) ) - IRQTR => OUTPTS(IMOD)%OUT3%IRQTR - IH = IH + 1 - IT = IT0 + 1 - CALL MPI_SEND_INIT (UST (IAPROC),1,WW3_FIELD_VEC,& - IROOT, IT, MPI_COMM_WAVE, IRQTR(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9041) IH, 'S U*', IROOT, IT, IRQTR(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 2 - CALL MPI_SEND_INIT (USTDIR(IAPROC),1,WW3_FIELD_VEC,& - IROOT, IT, MPI_COMM_WAVE, IRQTR(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9041) IH, 'S U*', IROOT, IT, IRQTR(IH), IERR -#endif -#ifdef W3_MPI - ELSE - ALLOCATE ( OUTPTS(IMOD)%OUT3%IRQTR(2*NAPROC) ) - IRQTR => OUTPTS(IMOD)%OUT3%IRQTR - DO I0=1, NAPROC - IFROM = I0 - 1 - IF ( I0 .NE. IAPROC ) THEN - IH = IH + 1 - IT = IT0 + 1 - CALL MPI_RECV_INIT(UST (I0),1,WW3_FIELD_VEC,& - IFROM,IT,MPI_COMM_WAVE, IRQTR(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9041) IH, 'R U*', IFROM, IT, IRQTR(IH), IERR -#endif -#ifdef W3_MPI - IH = IH + 1 - IT = IT0 + 2 - CALL MPI_RECV_INIT(USTDIR(I0),1,WW3_FIELD_VEC,& - IFROM,IT,MPI_COMM_WAVE, IRQTR(IH), IERR) -#endif -#ifdef W3_MPIT - WRITE (NDST,9041) IH, 'R U*', IFROM, IT, IRQTR(IH), IERR -#endif -#ifdef W3_MPI - END IF - END DO - END IF -#endif -! -#ifdef W3_MPI - NRQTR = IH - IT0 = IT0 + 2 -#endif -! -#ifdef W3_MPIT + end if + ! + IF ( IAPROC .NE. NAPTRK ) THEN + ALLOCATE ( OUTPTS(IMOD)%OUT3%IRQTR(2) ) + IRQTR => OUTPTS(IMOD)%OUT3%IRQTR + IH = IH + 1 + IT = IT0 + 1 + CALL MPI_SEND_INIT (UST (IAPROC),1,WW3_FIELD_VEC,& + IROOT, IT, MPI_COMM_WAVE, IRQTR(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9041) IH, 'S U*', IROOT, IT, IRQTR(IH), IERR + end if + IH = IH + 1 + IT = IT0 + 2 + CALL MPI_SEND_INIT (USTDIR(IAPROC),1,WW3_FIELD_VEC,& + IROOT, IT, MPI_COMM_WAVE, IRQTR(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9041) IH, 'S U*', IROOT, IT, IRQTR(IH), IERR + end if + ELSE + ALLOCATE ( OUTPTS(IMOD)%OUT3%IRQTR(2*NAPROC) ) + IRQTR => OUTPTS(IMOD)%OUT3%IRQTR + DO I0=1, NAPROC + IFROM = I0 - 1 + IF ( I0 .NE. IAPROC ) THEN + IH = IH + 1 + IT = IT0 + 1 + CALL MPI_RECV_INIT(UST (I0),1,WW3_FIELD_VEC,& + IFROM,IT,MPI_COMM_WAVE, IRQTR(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9041) IH, 'R U*', IFROM, IT, IRQTR(IH), IERR + end if + IH = IH + 1 + IT = IT0 + 2 + CALL MPI_RECV_INIT(USTDIR(I0),1,WW3_FIELD_VEC,& + IFROM,IT,MPI_COMM_WAVE, IRQTR(IH), IERR) + if (w3_mpit_flag) then + WRITE (NDST,9041) IH, 'R U*', IFROM, IT, IRQTR(IH), IERR + end if + END IF + END DO + END IF + ! + NRQTR = IH + IT0 = IT0 + 2 + ! + if (w3_mpit_flag) then WRITE (NDST,9042) WRITE (NDST,9043) NRQTR -#endif -! -#ifdef W3_MPI - END IF -#endif -! -! 5. Set-up remaining counters -------------------------------------- / -! -#ifdef W3_MPI - IT0PRT = IT0 - IT0PNT = IT0PRT + 2*NAPROC - IT0TRK = IT0PNT + 5000 -#endif -! - RETURN -! -! Formats : -! -#ifdef W3_MPI - 1010 FORMAT (/' *** ERROR W3MPIO : ARRAY IRQGO TOO SMALL *** '/) - 1011 FORMAT (/' *** ERROR W3MPIO : ARRAY IRQGO2 TOO SMALL *** '/) -#endif -! -#ifdef W3_MPIT - 9010 FORMAT (/' TEST W3MPIO: COMMUNICATION CALLS FOR W3IOGO ',A/ & - ' +------+-------+------+------+--------------+'/ & - ' | IH | ID | TARG | TAG | handle err |'/ & - ' +------+-------+------+------+--------------+') - 9011 FORMAT ( ' |',I5,' | ',A5,' |',2(I5,' |'),I9,I4,' |') - 9012 FORMAT ( ' +------+-------+------+------+--------------+') - 9013 FORMAT ( ' TEST W3MPIO: NRQGO :',2I10) - 9014 FORMAT ( ' TEST W3MPIO: NRQGO2:',2I10) -#endif -! -#ifdef W3_MPIT - 9020 FORMAT (/' TEST W3MPIO: COMM. CALLS FOR W3IORS (F)'/ & - ' +------+------+------+------+--------------+'/ & - ' | IH | ID | TARG | TAG | handle err |'/ & - ' +------+------+------+------+--------------+') - 9021 FORMAT ( ' |',I5,' | ',A4,' |',2(I5,' |'),I9,I4,' |') - 9022 FORMAT ( ' +------+------+------+------+--------------+') - 9023 FORMAT ( ' TEST W3MPIO: NRQRS :',I10) -#endif -! -#ifdef W3_MPIT - 9025 FORMAT (/' TEST W3MPIO: COMM. CALLS FOR W3IORS (S)'/ & - ' BLOCK SIZE / BLOCKS : ',2I6/ & - ' +------+------+------+------+--------------+---------+'/ & - ' | IH | ID | TARG | TAG | handle err | spectra |'/ & - ' +------+------+------+------+--------------+---------+') - 9026 FORMAT ( & - ' |',I5,' | ',A1,I3,' |',2(I5,' |'),I9,I4,' |',I8,' |') - 9027 FORMAT ( & - ' +------+------+------+------+--------------+---------+') - 9028 FORMAT ( ' TEST W3MPIO: IHMAX :',I10) -#endif -! -#ifdef W3_MPIT - 9030 FORMAT (/' TEST W3MPIO: ',A,' CALLS FOR W3IOBC'/ & - ' +------+------+---+------+------+--------------+'/ & - ' | IH | IPT | F | TARG | TAG | handle err |'/ & - ' +------+------+---+------+------+--------------+') - 9031 FORMAT ( ' |',2(I5,' |'),I2,' |',2(I5,' |'),I9,I4,' |') - 9032 FORMAT ( & - ' +------+------+---+------+------+--------------+') - 9033 FORMAT ( ' TEST W3MPIO: NRQBC :',I10) - 9034 FORMAT ( ' TEST W3MPIO: TOTAL :',I10) -#endif -! -#ifdef W3_MPIT - 9040 FORMAT (/' TEST W3MPIO: COMMUNICATION CALLS FOR W3IOTR'/ & - ' +------+------+------+------+--------------+'/ & - ' | IH | ID | TARG | TAG | handle err |'/ & - ' +------+------+------+------+--------------+') - 9041 FORMAT ( ' |',I5,' | ',A4,' |',2(I5,' |'),I9,I4,' |') - 9042 FORMAT ( & - ' +------+------+------+------+--------------+') - 9043 FORMAT ( ' TEST W3MPIO: NRQTR :',I10) -#endif -!/ -!/ End of W3MPIO ----------------------------------------------------- / -!/ - END SUBROUTINE W3MPIO -!/ ------------------------------------------------------------------- / - SUBROUTINE W3MPIP ( IMOD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 30-Oct-2009 | -!/ +-----------------------------------+ -!/ -!/ 02-Aug-2006 : Origination. ( version 3.10 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ -! 1. Purpose : -! -! Prepare MPI persistent communication needed for WAVEWATCH I/O -! routines. -! -! 2. Method : -! -! Create handles as needed. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! -! MPI_SEND_INIT, MPI_RECV_INIT -! Subr. mpif.h MPI persistent communication calls. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3INIT Subr. W3INITMD Wave model initialization routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/MPI MPI communication calls. -! -! !/S Enable subroutine tracing. -! !/MPIT Enable test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -#ifdef W3_MPI - USE W3SERVMD, ONLY: EXTCDE -#endif -!/ -#ifdef W3_MPI - USE W3GDATMD, ONLY: NX, NY, NSPEC, MAPFS - USE W3WDATMD, ONLY: VA - USE W3ADATMD, ONLY: MPI_COMM_WAVE, SPPNT - USE W3ODATMD, ONLY: NDST, NDSE, IAPROC, NAPROC, NAPPNT, FLOUT - USE W3ODATMD, ONLY: OUTPTS, NRQPO, NRQPO2, IRQPO1, IRQPO2, & - NOPTS, IPTINT, IT0PNT, IT0TRK, O2IRQI - USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC -#endif -!/ - IMPLICIT NONE -! -#ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IMOD -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -#ifdef W3_MPI - INTEGER :: IH, IROOT, I, J, IT, IT0, JSEA, & - IERR, ITARG, IX(4), IY(4), & - K, IS(4), IP(4) -#endif - INTEGER :: itout -#ifdef W3_S - INTEGER, SAVE :: IENT -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3MPIP') -#endif -! -#ifdef W3_MPI - IF ( O2IRQI ) THEN - WRITE (NDSE,1001) - CALL EXTCDE (1) - END IF -#endif -! -! 1. Set-up for W3IOPE/O ( SENDs ) ---------------------------------- / -! -#ifdef W3_MPI - NRQPO = 0 - NRQPO2 = 0 - IH = 0 - IT0 = IT0PNT - IROOT = NAPPNT - 1 -#endif -! -#ifdef W3_MPI - ALLOCATE ( OUTPTS(IMOD)%OUT2%IRQPO1(4*NOPTS), & - OUTPTS(IMOD)%OUT2%IRQPO2(4*NOPTS) ) - IRQPO1 => OUTPTS(IMOD)%OUT2%IRQPO1 - IRQPO2 => OUTPTS(IMOD)%OUT2%IRQPO2 - O2IRQI = .TRUE. -#endif -! -! 1.a Loop over output locations -! -#ifdef W3_MPIT - WRITE (NDST,9010) 'MPI_SEND_INIT' -#endif -! -#ifdef W3_MPI - DO I=1, NOPTS - DO K=1,4 + end if + ! + END IF + ! + ! 5. Set-up remaining counters -------------------------------------- / + ! + IT0PRT = IT0 + IT0PNT = IT0PRT + 2*NAPROC + IT0TRK = IT0PNT + 5000 +#endif + ! + RETURN + ! + ! Formats + ! +1010 FORMAT (/' *** ERROR W3MPIO : ARRAY IRQGO TOO SMALL *** '/) +1011 FORMAT (/' *** ERROR W3MPIO : ARRAY IRQGO2 TOO SMALL *** '/) +9010 FORMAT (/' TEST W3MPIO: COMMUNICATION CALLS FOR W3IOGO ',A/ & + ' +------+-------+------+------+--------------+'/ & + ' | IH | ID | TARG | TAG | handle err |'/ & + ' +------+-------+------+------+--------------+') +9011 FORMAT ( ' |',I5,' | ',A5,' |',2(I5,' |'),I9,I4,' |') +9012 FORMAT ( ' +------+-------+------+------+--------------+') +9013 FORMAT ( ' TEST W3MPIO: NRQGO :',2I10) +9014 FORMAT ( ' TEST W3MPIO: NRQGO2:',2I10) +9020 FORMAT (/' TEST W3MPIO: COMM. CALLS FOR W3IORS (F)'/ & + ' +------+------+------+------+--------------+'/ & + ' | IH | ID | TARG | TAG | handle err |'/ & + ' +------+------+------+------+--------------+') +9021 FORMAT ( ' |',I5,' | ',A4,' |',2(I5,' |'),I9,I4,' |') +9022 FORMAT ( ' +------+------+------+------+--------------+') +9023 FORMAT ( ' TEST W3MPIO: NRQRS :',I10) +9025 FORMAT (/' TEST W3MPIO: COMM. CALLS FOR W3IORS (S)'/ & + ' BLOCK SIZE / BLOCKS : ',2I6/ & + ' +------+------+------+------+--------------+---------+'/ & + ' | IH | ID | TARG | TAG | handle err | spectra |'/ & + ' +------+------+------+------+--------------+---------+') +9026 FORMAT ( & + ' |',I5,' | ',A1,I3,' |',2(I5,' |'),I9,I4,' |',I8,' |') +9027 FORMAT ( & + ' +------+------+------+------+--------------+---------+') +9028 FORMAT ( ' TEST W3MPIO: IHMAX :',I10) +9030 FORMAT (/' TEST W3MPIO: ',A,' CALLS FOR W3IOBC'/ & + ' +------+------+---+------+------+--------------+'/ & + ' | IH | IPT | F | TARG | TAG | handle err |'/ & + ' +------+------+---+------+------+--------------+') +9031 FORMAT ( ' |',2(I5,' |'),I2,' |',2(I5,' |'),I9,I4,' |') +9032 FORMAT ( & + ' +------+------+---+------+------+--------------+') +9033 FORMAT ( ' TEST W3MPIO: NRQBC :',I10) +9034 FORMAT ( ' TEST W3MPIO: TOTAL :',I10) +9040 FORMAT (/' TEST W3MPIO: COMMUNICATION CALLS FOR W3IOTR'/ & + ' +------+------+------+------+--------------+'/ & + ' | IH | ID | TARG | TAG | handle err |'/ & + ' +------+------+------+------+--------------+') +9041 FORMAT ( ' |',I5,' | ',A4,' |',2(I5,' |'),I9,I4,' |') +9042 FORMAT ( & + ' +------+------+------+------+--------------+') +9043 FORMAT ( ' TEST W3MPIO: NRQTR :',I10) + !/ + !/ End of W3MPIO ----------------------------------------------------- / + !/ + END SUBROUTINE W3MPIO + !/ ------------------------------------------------------------------- / + SUBROUTINE W3MPIP ( IMOD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 30-Oct-2009 | + !/ +-----------------------------------+ + !/ + !/ 02-Aug-2006 : Origination. ( version 3.10 ) + !/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ + ! 1. Purpose : + ! + ! Prepare MPI persistent communication needed for WAVEWATCH I/O + ! routines. + ! + ! 2. Method : + ! + ! Create handles as needed. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! + ! MPI_SEND_INIT, MPI_RECV_INIT + ! Subr. mpif.h MPI persistent communication calls. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3INIT Subr. W3INITMD Wave model initialization routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/MPI MPI communication calls. + ! + ! !/S Enable subroutine tracing. + ! !/MPIT Enable test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: STRACE ! W3_S +#ifdef W3_MPI + USE W3SERVMD, ONLY: EXTCDE ! W3_MPI + USE W3GDATMD, ONLY: NX, NY, NSPEC, MAPFS ! W3_MPI + USE W3WDATMD, ONLY: VA ! W3_MPI + USE W3ADATMD, ONLY: MPI_COMM_WAVE, SPPNT ! W3_MPI + USE W3ODATMD, ONLY: NDST, NDSE, IAPROC, NAPROC, NAPPNT, FLOUT ! W3_MPI + USE W3ODATMD, ONLY: OUTPTS, NRQPO, NRQPO2, IRQPO1, IRQPO2 ! W3_MPI + USE W3ODATMD, ONLY: NOPTS, IPTINT, IT0PNT, IT0TRK, O2IRQI ! W3_MPI + USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC ! W3_MPI +#endif + !/ + ! +#ifdef W3_MPI + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IMOD + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IH, IROOT, I, J, IT, IT0, JSEA ! W3_MPI + INTEGER :: IERR, ITARG, IX(4), IY(4) ! W3_MPI + INTEGER :: K, IS(4), IP(4) ! W3_MPI + INTEGER :: itout + INTEGER :: IENT ! W3_S + !/ + !/ ------------------------------------------------------------------- / + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'W3MPIP') + end if + ! +#ifdef W3_MPI + IF ( O2IRQI ) THEN + WRITE (NDSE,1001) + CALL EXTCDE (1) + END IF + ! + ! 1. Set-up for W3IOPE/O ( SENDs ) ---------------------------------- / + ! + NRQPO = 0 + NRQPO2 = 0 + IH = 0 + IT0 = IT0PNT + IROOT = NAPPNT - 1 + ! + ALLOCATE ( OUTPTS(IMOD)%OUT2%IRQPO1(4*NOPTS), & + OUTPTS(IMOD)%OUT2%IRQPO2(4*NOPTS) ) + IRQPO1 => OUTPTS(IMOD)%OUT2%IRQPO1 + IRQPO2 => OUTPTS(IMOD)%OUT2%IRQPO2 + O2IRQI = .TRUE. + ! + ! 1.a Loop over output locations + ! + if (w3_mpit_flag) then + WRITE (NDST,9010) 'MPI_SEND_INIT' + end if + ! + DO I=1, NOPTS + DO K=1,4 IX(K)=IPTINT(1,K,I) IY(K)=IPTINT(2,K,I) - END DO -#endif -! 1.b Loop over corner points -! -#ifdef W3_MPI - DO J=1, 4 -#endif -! -#ifdef W3_MPI + END DO + ! 1.b Loop over corner points + ! + DO J=1, 4 + ! IT = IT0 + (I-1)*4 + J IS(J) = MAPFS (IY(J),IX(J)) IF ( IS(J) .EQ. 0 ) THEN - JSEA = 0 - IP(J) = NAPPNT - ELSE - CALL INIT_GET_JSEA_ISPROC(IS(J), JSEA, IP(J)) - END IF -#endif -! -! 1.c Send if point is stored here -! -#ifdef W3_MPI + JSEA = 0 + IP(J) = NAPPNT + ELSE + CALL INIT_GET_JSEA_ISPROC(IS(J), JSEA, IP(J)) + END IF + ! + ! 1.c Send if point is stored here + ! IF ( IP(J) .EQ. IAPROC ) THEN - IH = IH + 1 - CALL MPI_SEND_INIT ( VA(1,JSEA), NSPEC, MPI_REAL, & - IROOT, IT, MPI_COMM_WAVE, IRQPO1(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH,I,J, IROOT,IT, IRQPO1(IH), IERR -#endif -#ifdef W3_MPI - END IF -#endif -! -! ... End of loop 1.b -! -#ifdef W3_MPI - END DO -#endif -! -! ... End of loop 1.a -! -#ifdef W3_MPI - END DO -#endif -! -#ifdef W3_MPI - NRQPO = IH -#endif -! -#ifdef W3_MPIT - WRITE (NDST,9012) - WRITE (NDST,9013) NRQPO -#endif -! -! 1.d Set-up for W3IOPE/O ( RECVs ) ---------------------------------- / -! -#ifdef W3_MPI - IF ( IAPROC .EQ. NAPPNT ) THEN -#endif -! -#ifdef W3_MPI - IH = 0 -#endif -! -! 2.e Loop over output locations -! -#ifdef W3_MPIT + IH = IH + 1 + CALL MPI_SEND_INIT ( VA(1,JSEA), NSPEC, MPI_REAL, & + IROOT, IT, MPI_COMM_WAVE, IRQPO1(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH,I,J, IROOT,IT, IRQPO1(IH), IERR + end if + END IF + ! + ! ... End of loop 1.b + ! + END DO + ! + ! ... End of loop 1.a + ! + END DO + ! + NRQPO = IH + ! + if (w3_mpit_flag) then + WRITE (NDST,9012) + WRITE (NDST,9013) NRQPO + end if + ! + ! 1.d Set-up for W3IOPE/O ( RECVs ) ---------------------------------- / + ! + IF ( IAPROC .EQ. NAPPNT ) THEN + ! + IH = 0 + ! + ! 2.e Loop over output locations + ! + if (w3_mpit_flag) then WRITE (NDST,9010) 'MPI_RECV_INIT' -#endif -! -#ifdef W3_MPI - DO I=1, NOPTS - DO K=1,4 - IX(K)=IPTINT(1,K,I) - IY(K)=IPTINT(2,K,I) - END DO -#endif -! -#ifdef W3_MPI - DO J=1, 4 -#endif -! -#ifdef W3_MPI - IT = IT0 + (I-1)*4 + J - IS(J) = MAPFS (IY(J),IX(J)) - IF ( IS(J) .EQ. 0 ) THEN - JSEA = 0 - IP(J) = NAPPNT - ELSE - CALL INIT_GET_JSEA_ISPROC(IS(J), JSEA, IP(J)) - END IF -#endif -! -! 1.g Receive in correct array -! -#ifdef W3_MPI - IH = IH + 1 - ITARG = IP(J) - 1 - CALL MPI_RECV_INIT ( SPPNT(1,1,J), NSPEC, MPI_REAL, & - ITARG, IT, MPI_COMM_WAVE, IRQPO2(IH), IERR ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9011) IH,I,J, ITARG,IT, IRQPO2(IH), IERR -#endif -! -! ... End of loop 1.f -! -#ifdef W3_MPI - END DO -#endif -! -! ... End of loop 1.e -! -#ifdef W3_MPI - END DO -#endif -! -#ifdef W3_MPI - NRQPO2 = NOPTS*4 -#endif -! -#ifdef W3_MPIT + end if + ! + DO I=1, NOPTS + DO K=1,4 + IX(K)=IPTINT(1,K,I) + IY(K)=IPTINT(2,K,I) + END DO + ! + DO J=1, 4 + ! + IT = IT0 + (I-1)*4 + J + IS(J) = MAPFS (IY(J),IX(J)) + IF ( IS(J) .EQ. 0 ) THEN + JSEA = 0 + IP(J) = NAPPNT + ELSE + CALL INIT_GET_JSEA_ISPROC(IS(J), JSEA, IP(J)) + END IF + ! + ! 1.g Receive in correct array + ! + IH = IH + 1 + ITARG = IP(J) - 1 + CALL MPI_RECV_INIT ( SPPNT(1,1,J), NSPEC, MPI_REAL, & + ITARG, IT, MPI_COMM_WAVE, IRQPO2(IH), IERR ) + if (w3_mpit_flag) then + WRITE (NDST,9011) IH,I,J, ITARG,IT, IRQPO2(IH), IERR + end if + ! + ! ... End of loop 1.f + ! + END DO + ! + ! ... End of loop 1.e + ! + END DO + ! + NRQPO2 = NOPTS*4 + ! + if (w3_mpit_flag) then WRITE (NDST,9012) WRITE (NDST,9014) NRQPO2 -#endif -! -#ifdef W3_MPI - END IF -#endif -! -! -#ifdef W3_MPI - IT0 = IT0 + 8*NOPTS -#endif -! -! 1.h Base tag number for track output -! -#ifdef W3_MPI - IT0TRK = IT0 -#endif -! - RETURN -! -! Formats : -! -#ifdef W3_MPI - 1001 FORMAT (/' *** ERROR W3MPIP : ARRAYS ALREADY ALLOCATED *** '/) -#endif -! -#ifdef W3_MPIT - 9010 FORMAT (/' TEST W3MPIP: ',A,' CALLS FOR W3IOPO'/ & - ' +------+------+---+------+------+--------------+'/ & - ' | IH | IPT | J | TARG | TAG | handle err |'/ & - ' +------+------+---+------+------+--------------+') - 9011 FORMAT ( ' |',2(I5,' |'),I2,' |',2(I5,' |'),I9,I4,' |') - 9012 FORMAT ( & - ' +------+------+---+------+------+--------------+') - 9013 FORMAT ( ' TEST W3MPIP: NRQPO :',I10) - 9014 FORMAT ( ' TEST W3MPIP: TOTAL :',I10) -#endif -!/ -!/ End of W3MPIP ----------------------------------------------------- / -!/ - END SUBROUTINE W3MPIP -!/ -!/ End of module W3INITMD -------------------------------------------- / -!/ - END MODULE W3INITMD + end if + ! + END IF + ! + ! + IT0 = IT0 + 8*NOPTS + ! + ! 1.h Base tag number for track output + ! + IT0TRK = IT0 +#endif + ! + RETURN + ! + ! Formats + ! +1001 FORMAT (/' *** ERROR W3MPIP : ARRAYS ALREADY ALLOCATED *** '/) +9010 FORMAT (/' TEST W3MPIP: ',A,' CALLS FOR W3IOPO'/ & + ' +------+------+---+------+------+--------------+'/ & + ' | IH | IPT | J | TARG | TAG | handle err |'/ & + ' +------+------+---+------+------+--------------+') +9011 FORMAT ( ' |',2(I5,' |'),I2,' |',2(I5,' |'),I9,I4,' |') +9012 FORMAT ( & + ' +------+------+---+------+------+--------------+') +9013 FORMAT ( ' TEST W3MPIP: NRQPO :',I10) +9014 FORMAT ( ' TEST W3MPIP: TOTAL :',I10) + !/ + !/ End of W3MPIP ----------------------------------------------------- / + !/ + END SUBROUTINE W3MPIP + !/ + !/ End of module W3INITMD -------------------------------------------- / + !/ +END MODULE W3INITMD diff --git a/model/src/w3iogomd.F90 b/model/src/w3iogomd.F90 index 84fe9f9c01..d4a2bd5638 100644 --- a/model/src/w3iogomd.F90 +++ b/model/src/w3iogomd.F90 @@ -134,6 +134,8 @@ MODULE W3IOGOMD #ifdef W3_S USE W3SERVMD, ONLY : STRACE #endif + !module default + IMPLICIT NONE !/ PUBLIC CHARACTER(LEN=1024) :: FLDOUT @@ -207,8 +209,6 @@ SUBROUTINE W3FLGRDUPDT ( NDSO, NDSEN, FLGRD, FLGR2, FLGD, FLG2 ) #ifdef W3_S USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -362,7 +362,6 @@ SUBROUTINE W3READFLGRD ( NDSI , NDSO, NDSS, NDSEN, COMSTR, & USE W3SERVMD, ONLY: STRACE #endif ! - IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -597,7 +596,6 @@ SUBROUTINE W3FLGRDFLAG ( NDSO, NDSS, NDSEN, FLDOUT, & USE W3SERVMD, ONLY: STRACE #endif ! - IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -716,7 +714,6 @@ SUBROUTINE W3FLDTOIJ(FLD, I, J, IAPROC, NAPOUT, NDSEN) ! !/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY: US3DF, USSPF - IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Local parameters @@ -1241,7 +1238,6 @@ SUBROUTINE W3OUTG ( A, FLPART, FLOUTG, FLOUTG2 ) #endif ! USE W3PARALL, ONLY : INIT_GET_ISEA - IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -2783,8 +2779,9 @@ SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) #ifdef W3_S USE W3SERVMD, ONLY: STRACE #endif + use w3timemd , only: set_user_timestring + use w3odatmd , only: use_user_histname, user_histfname ! - IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -2812,6 +2809,8 @@ SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) #endif CHARACTER(LEN=30) :: IDTST, TNAME CHARACTER(LEN=10) :: VERTST + CHARACTER(len=512) :: FNAME + character(len=16) :: user_timestring !YYYY-MM-DD-SSSSS !/ !/ ------------------------------------------------------------------- / !/ @@ -2861,21 +2860,33 @@ SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) ! ( IPASS = 1 ) ! IF ( IPASS.EQ.1 .AND. OFILES(1) .EQ. 0) THEN - I = LEN_TRIM(FILEXT) - J = LEN_TRIM(FNMPRE) + I = LEN_TRIM(FILEXT) + J = LEN_TRIM(FNMPRE) + + if (use_user_histname) then + if (len_trim(user_histfname) == 0 ) then + call extcde (60, MSG="user history filename requested"// & + " but not provided") + end if + call set_user_timestring(time,user_timestring) + fname = trim(user_histfname)//trim(user_timestring) + else + fname = 'out_grd.'//FILEXT(:I) + end if + ! #ifdef W3_T - WRITE (NDST,9001) FNMPRE(:J)//'out_grd.'//FILEXT(:I) + WRITE (NDST,9001) FNMPRE(:J)//trim(fname) #endif - IF ( WRITE ) THEN - OPEN (NDSOG,FILE=FNMPRE(:J)//'out_grd.'//FILEXT(:I), & - form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR) - ELSE - OPEN (NDSOG,FILE=FNMPRE(:J)//'out_grd.'//FILEXT(:I), & - form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR,STATUS='OLD') - END IF + IF ( WRITE ) THEN + OPEN (NDSOG,FILE=FNMPRE(:J)//trim(fname), & + form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR) + ELSE + OPEN (NDSOG,FILE=FNMPRE(:J)//trim(fname), & + form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR,STATUS='OLD') + END IF ! - REWIND ( NDSOG ) + REWIND ( NDSOG ) ! ! test info --------------------------------------------------------- * ! ( IPASS = 1 ) @@ -2935,19 +2946,31 @@ SUBROUTINE W3IOGO ( INXOUT, NDSOG, IOTST, IMOD ) IF ( IPASS.GE.1 .AND. OFILES(1) .EQ. 1) THEN I = LEN_TRIM(FILEXT) J = LEN_TRIM(FNMPRE) + + if (use_user_histname) then + if (len_trim(user_histfname) == 0 ) then + call extcde (60, MSG="user history filename requested"// & + " but not provided") + end if + call set_user_timestring(time,user_timestring) + fname = trim(user_histfname)//trim(user_timestring) + else ! ! Create TIMETAG for file name using YYYYMMDD.HHMMS prefix - WRITE(TIMETAG,"(i8.8,'.'i6.6)")TIME(1),TIME(2) + WRITE(TIMETAG,"(i8.8,'.'i6.6)")TIME(1),TIME(2) #ifdef W3_T - WRITE (NDST,9001) FNMPRE(:J)//TIMETAG//'.out_grd.'//FILEXT(:I) + WRITE (NDST,9001) FNMPRE(:J)//TIMETAG//'.out_grd.'//FILEXT(:I) #endif + fname = TIMETAG//'.out_grd.'//FILEXT(:I) + end if + IF ( WRITE ) THEN - OPEN (NDSOG,FILE=FNMPRE(:J)//TIMETAG//'.out_grd.' & - //FILEXT(:I),form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR) + OPEN (NDSOG,FILE=FNMPRE(:J)//trim(fname), & + form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR) ELSE OPEN (NDSOG,FILE=FNMPRE(:J)//'out_grd.'//FILEXT(:I), & form='UNFORMATTED', convert=file_endian,ERR=800,IOSTAT=IERR,STATUS='OLD') - END IF + END IF ! REWIND ( NDSOG ) ! @@ -4052,7 +4075,6 @@ SUBROUTINE CALC_U3STOKES ( A , USS_SWITCH ) USE W3SERVMD, ONLY: STRACE #endif ! - IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -4277,7 +4299,6 @@ SUBROUTINE CALC_WBT (A) USE W3SERVMD, ONLY: STRACE #endif ! - IMPLICIT NONE ! !/ ------------------------------------------------------------------- / !/ Parameter list diff --git a/model/src/w3iogoncdmd.F90 b/model/src/w3iogoncdmd.F90 index 53d0c0b2a0..a164151bad 100644 --- a/model/src/w3iogoncdmd.F90 +++ b/model/src/w3iogoncdmd.F90 @@ -6,760 +6,503 @@ !> @date 01-05-2022 #include "w3macros.h" -module W3IOGONCDMD +module w3iogoncdmd + use w3gdatmd , only : nk, nx, ny, mapsf, mapsta, nsea + use w3odatmd , only : noswll, undef + use w3odatmd , only : nds, iaproc, napout + use netcdf + + implicit none + + private + + public :: w3iogoncd + + ! used/reused in module + + integer :: isea, ierr, ncid, varid + integer :: len_s, len_m, len_p, len_k + character(len=1024) :: fname + + real, allocatable, target :: var3ds(:,:,:) + real, allocatable, target :: var3dm(:,:,:) + real, allocatable, target :: var3dp(:,:,:) + real, allocatable, target :: var3dk(:,:,:) + + real, pointer :: var3d(:,:,:) + + !=============================================================================== 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 + subroutine w3iogoncd () + + use w3odatmd , only : fnmpre + use w3gdatmd , only : filext + use w3servmd , only : extcde + use w3wdatmd , only : w3setw, w3dimw, time, wlv, ice, icef, iceh, berg, ust, ustdir, asf, rhoair + use w3gdatmd , only : xgrd, ygrd + use w3gdatmd , only : e3df, p2msf, us3df, usspf, w3setg + use w3odatmd , only : nogrp, ngrpp, idout, ndst, ndse, noswll, w3seto + use w3adatmd , only : w3seta, w3dima, w3xeta + use w3adatmd , only : ainit, dw, ua, ud, as, cx, cy, wn, taua, tauadir + use w3adatmd , only : hs, wlm, t02, t0m1, t01, fp0, thm, ths, thp0, wbt, wnmean + use w3adatmd , only : 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, tauocx, tauocy #ifdef W3_CESMCOUPLED - USE W3ADATMD, ONLY: LANGMT + 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 + use wav_grdout , only : varatts, outvars + use w3timemd , only : set_user_timestring + use w3odatmd , only : time_origin, calendar_name, elapsed_secs + use w3odatmd , only : use_user_histname, user_histfname - ! ------------------------------------------------------------- - ! Allocate fields needed for write - ! ------------------------------------------------------------- + ! local variables + integer :: igrd + integer ,target :: dimid3(3) + integer ,target :: dimid4(4) + integer ,pointer :: dimid(:) + character(len=12) :: vname + character(len=16) :: user_timestring !YYYY-MM-DD-SSSSS + + integer :: n, xtid, ytid, stid, mtid, ptid, ktid, timid, varid + logical :: s_axis = .false., m_axis = .false., p_axis = .false., k_axis = .false. + + !------------------------------------------------------------------------------- + + 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 ( 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 + ! create the netcdf file ! ------------------------------------------------------------- - 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') + + if (use_user_histname) then + if (len_trim(user_histfname) == 0 ) then + call extcde (60, msg="user history filename requested but not provided") + end if + call set_user_timestring(time,user_timestring) + fname = trim(user_histfname)//trim(user_timestring)//'.nc' else - ierr = nf90_open(trim(fname),nf90_write,ncid) - call handle_err(ierr,'open') - endif + write(fname,'(a,i8.8,a1,i6.6,a)')trim(fnmpre),time(1),'.',time(2),'.out_grd.'//trim(filext)//'.nc' + end if - ! ------------------------------------------------------------- - ! Initialization - ! ------------------------------------------------------------- + len_s = noswll + 1 ! 0:noswll + len_m = p2msf(3)-p2msf(2) + 1 ! ? + len_p = usspf(2) ! partitions + len_k = e3df(3,1) - e3df(2,1) + 1 ! frequencies - 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' + ! define the dimensions required for the requested gridded fields + do n = 1,size(outvars) + if (outvars(n)%validout) then + if(trim(outvars(n)%dims) == 's')s_axis = .true. + if(trim(outvars(n)%dims) == 'm')m_axis = .true. + if(trim(outvars(n)%dims) == 'p')p_axis = .true. + if(trim(outvars(n)%dims) == 'k')k_axis = .true. + end if + end do + + ! allocate arrays if needed + if (s_axis) allocate(var3ds(1:nx,1:ny,len_s)) + if (m_axis) allocate(var3dm(1:nx,1:ny,len_m)) + if (p_axis) allocate(var3dp(1:nx,1:ny,len_p)) + if (k_axis) allocate(var3dk(1:nx,1:ny,len_k)) + + ! create the netcdf file + ierr = nf90_create(trim(fname), nf90_clobber, ncid) + call handle_err(ierr, 'nf90_create') + ierr = nf90_def_dim(ncid, 'nx', nx, xtid) + ierr = nf90_def_dim(ncid, 'ny', ny, ytid) + ierr = nf90_def_dim(ncid, 'time', nf90_unlimited, timid) + + if (s_axis) ierr = nf90_def_dim(ncid, 'noswll', len_s, stid) + if (m_axis) ierr = nf90_def_dim(ncid, 'nm' , len_m, mtid) + if (p_axis) ierr = nf90_def_dim(ncid, 'np' , len_p, ptid) + if (k_axis) ierr = nf90_def_dim(ncid, 'freq' , len_k, ktid) + + ! define the time variable + ierr = nf90_def_var(ncid, 'time', nf90_double, timid, 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') + + ! define the spatial axis variables (lat,lon) + ierr = nf90_def_var(ncid, 'lon', nf90_double, (/xtid,ytid/), varid) + call handle_err(ierr,'def_lonvar') + ierr = nf90_put_att(ncid, varid, 'units', 'degrees_east') + ierr = nf90_def_var(ncid, 'lat', nf90_double, (/xtid,ytid/), varid) + call handle_err(ierr,'def_latvar') + ierr = nf90_put_att(ncid, varid, 'units', 'degrees_north') + + ! define the variables + dimid3(1:2) = (/xtid, ytid/) + dimid4(1:2) = (/xtid, ytid/) + do n = 1,size(outvars) + if (trim(outvars(n)%dims) == 's') then + dimid4(3:4) = (/stid, timid/) + dimid => dimid4 + else if (trim(outvars(n)%dims) == 'm') then + dimid4(3:4) = (/mtid, timid/) + dimid => dimid4 + else if (trim(outvars(n)%dims) == 'p') then + dimid4(3:4) = (/ptid, timid/) + dimid => dimid4 + else if (trim(outvars(n)%dims) == 'k') then + dimid4(3:4) = (/ktid, timid/) + dimid => dimid4 + else + dimid3(3) = timid + dimid => dimid3 + end if + + ierr = nf90_def_var(ncid, trim(outvars(n)%var_name), nf90_float, dimid, varid) + call handle_err(ierr, 'define variable '//trim((outvars(n)%var_name))) + ierr = nf90_put_att(ncid, varid, 'units' , trim(outvars(n)%unit_name)) + ierr = nf90_put_att(ncid, varid, 'long_name' , trim(outvars(n)%long_name)) + ierr = nf90_put_att(ncid, varid, '_FillValue', undef) + end do + ! end variable definitions + ierr = nf90_enddef(ncid) + call handle_err(ierr, 'end variable definition') + + ! write the time and spatial axis values (lat,lon,time) + ierr = nf90_inq_varid(ncid, 'lat', varid) + call handle_err(ierr, 'inquire variable lat ') + ierr = nf90_put_var(ncid, varid, transpose(ygrd)) + call handle_err(ierr, 'put lat') + + ierr = nf90_inq_varid(ncid, 'lon', varid) + call handle_err(ierr, 'inquire variable lon ') + ierr = nf90_put_var(ncid, varid, transpose(xgrd)) + call handle_err(ierr, 'put lon') + + ierr = nf90_inq_varid(ncid, 'time', varid) + call handle_err(ierr, 'inquire variable time ') + ierr = nf90_put_var(ncid, varid, elapsed_secs) + call handle_err(ierr, 'put time') + ! close the file + ierr = nf90_close(ncid) + + ! write the requested variables + do n = 1,size(outvars) + vname = trim(outvars(n)%var_name) + if (trim(outvars(n)%dims) == 's') then + var3d => var3ds + ! Group 4 + if(vname .eq. 'PHS') call write_var3d(vname, phs (1:nsea,0:noswll) ) + if(vname .eq. 'PTP') call write_var3d(vname, ptp (1:nsea,0:noswll) ) + if(vname .eq. 'PLP') call write_var3d(vname, plp (1:nsea,0:noswll) ) + if(vname .eq. 'PDIR') call write_var3d(vname, pdir (1:nsea,0:noswll) ) + if(vname .eq. 'PSI') call write_var3d(vname, psi (1:nsea,0:noswll) ) + if(vname .eq. 'PWS') call write_var3d(vname, pws (1:nsea,0:noswll) ) + if(vname .eq. 'PDP') call write_var3d(vname, pthp0 (1:nsea,0:noswll) ) + if(vname .eq. 'PQP') call write_var3d(vname, pqp (1:nsea,0:noswll) ) + if(vname .eq. 'PPE') call write_var3d(vname, ppe (1:nsea,0:noswll) ) + if(vname .eq. 'PGW') call write_var3d(vname, pgw (1:nsea,0:noswll) ) + if(vname .eq. 'PSW') call write_var3d(vname, psw (1:nsea,0:noswll) ) + if(vname .eq. 'PTM1') call write_var3d(vname, ptm1 (1:nsea,0:noswll) ) + if(vname .eq. 'PT1') call write_var3d(vname, pt1 (1:nsea,0:noswll) ) + if(vname .eq. 'PT2') call write_var3d(vname, pt2 (1:nsea,0:noswll) ) + if(vname .eq. 'PEP') call write_var3d(vname, pep (1:nsea,0:noswll) ) + + else if (trim(outvars(n)%dims) == 'm') then ! m axis + var3d => var3dm + ! Group 6 + if (vname .eq. 'P2SMS') call write_var3d(vname, p2sms (1:nsea,p2msf(2):p2msf(3)) ) + + else if (trim(outvars(n)%dims) == 'p') then ! partition axis + var3d => var3dp + ! Group 6 + if (vname .eq. 'USSPX') call write_var3d(vname, ussp (1:nsea, 1:usspf(2)) ) + if (vname .eq. 'USSPY') call write_var3d(vname, ussp (1:nsea,nk+1:nk+usspf(2)) ) + + else if (trim(outvars(n)%dims) == 'k') then ! freq axis + var3d => var3dk + ! Group 3 + if(vname .eq. 'EF') call write_var3d(vname, ef (1:nsea,e3df(2,1):e3df(3,1)) ) + if(vname .eq. 'TH1M') call write_var3d(vname, ef (1:nsea,e3df(2,2):e3df(3,2)) ) + if(vname .eq. 'STH1M') call write_var3d(vname, ef (1:nsea,e3df(2,3):e3df(3,3)) ) + if(vname .eq. 'TH2M') call write_var3d(vname, ef (1:nsea,e3df(2,4):e3df(3,4)) ) + if(vname .eq. 'STH2M') call write_var3d(vname, ef (1:nsea,e3df(2,5):e3df(3,5)) ) + !TODO: wn has reversed indices (1:nk, 1:nsea) + ! Group 6 + if (vname .eq. 'US3DX') call write_var3d(vname, us3d (1:nsea, us3df(2):us3df(3)) ) + if (vname .eq. 'US3DY') call write_var3d(vname, us3d (1:nsea,nk+us3df(2):nk+us3df(3)) ) + + else + ! Group 1 + if (vname .eq. 'DW') call write_var2d(vname, dw (1:nsea), init0='false') + if (vname .eq. 'CX') call write_var2d(vname, cx (1:nsea), init0='false') + if (vname .eq. 'CY') call write_var2d(vname, cy (1:nsea), init0='false') + if (vname .eq. 'UAX') call write_var2d(vname, ua (1:nsea), dir=cos(ud(1:nsea)), init0='false') + if (vname .eq. 'UAY') call write_var2d(vname, ua (1:nsea), dir=sin(ud(1:nsea)), init0='false') + if (vname .eq. 'AS') call write_var2d(vname, as (1:nsea), init0='false') + if (vname .eq. 'WLV') call write_var2d(vname, wlv (1:nsea), init0='false') + if (vname .eq. 'ICE') call write_var2d(vname, ice (1:nsea), init0='false') + if (vname .eq. 'BERG') call write_var2d(vname, berg (1:nsea), init0='false') + if (vname .eq. 'TAUX') call write_var2d(vname, taua (1:nsea), dir=cos(tauadir(1:nsea)), init0='false') + if (vname .eq. 'TAUY') call write_var2d(vname, taua (1:nsea), dir=sin(tauadir(1:nsea)), init0='false') + if (vname .eq. 'RHOAIR') call write_var2d(vname, rhoair (1:nsea), init0='false') + if (vname .eq. 'ICEH') call write_var2d(vname, iceh (1:nsea), init0='false') + if (vname .eq. 'ICEF') call write_var2d(vname, icef (1:nsea), init0='false') + + ! Group 2 + if (vname .eq. 'HS') call write_var2d(vname, hs (1:nsea) ) + if (vname .eq. 'WLM') call write_var2d(vname, wlm (1:nsea) ) + if (vname .eq. 'T02') call write_var2d(vname, t02 (1:nsea) ) + if (vname .eq. 'T0M1') call write_var2d(vname, t0m1 (1:nsea) ) + if (vname .eq. 'T01') call write_var2d(vname, t01 (1:nsea) ) + if (vname .eq. 'FP0') call write_var2d(vname, fp0 (1:nsea) ) + if (vname .eq. 'THM') call write_var2d(vname, thm (1:nsea) ) + if (vname .eq. 'THS') call write_var2d(vname, ths (1:nsea) ) + if (vname .eq. 'THP0') call write_var2d(vname, thp0 (1:nsea) ) + if (vname .eq. 'HSIG') call write_var2d(vname, hsig (1:nsea) ) + if (vname .eq. 'STMAXE') call write_var2d(vname, stmaxe (1:nsea) ) + if (vname .eq. 'STMAXD') call write_var2d(vname, stmaxd (1:nsea) ) + if (vname .eq. 'HMAXE') call write_var2d(vname, hmaxe (1:nsea) ) + if (vname .eq. 'HCMAXE') call write_var2d(vname, hcmaxe (1:nsea) ) + if (vname .eq. 'HMAXD') call write_var2d(vname, hmaxd (1:nsea) ) + if (vname .eq. 'HCMAXD') call write_var2d(vname, hcmaxd (1:nsea) ) + if (vname .eq. 'WBT') call write_var2d(vname, wbt (1:nsea) ) + if (vname .eq. 'WNMEAN') call write_var2d(vname, wnmean (1:nsea), init0='false') + + ! Group 4 + if(vname .eq. 'PWST') call write_var2d(vname, pwst (1:nsea) ) + if(vname .eq. 'PNR') call write_var2d(vname, pnr (1:nsea) ) + + ! Group 5 + if (vname .eq. 'USTX') call write_var2d(vname, ust (1:nsea)*asf(1:nsea), dir=cos(ustdir(1:nsea)), usemask='true') + if (vname .eq. 'USTY') call write_var2d(vname, ust (1:nsea)*asf(1:nsea), dir=sin(ustdir(1:nsea)), usemask='true') + if (vname .eq. 'CHA') call write_var2d(vname, charn (1:nsea) ) + if (vname .eq. 'CGE') call write_var2d(vname, cge (1:nsea) ) + if (vname .eq. 'PHIAW') call write_var2d(vname, phiaw (1:nsea), init2='true') + if (vname .eq. 'TAUWIX') call write_var2d(vname, tauwix (1:nsea), init2='true') + if (vname .eq. 'TAUWIY') call write_var2d(vname, tauwiy (1:nsea), init2='true') + if (vname .eq. 'TAUWNX') call write_var2d(vname, tauwnx (1:nsea), init2='true') + if (vname .eq. 'TAUWNY') call write_var2d(vname, tauwny (1:nsea), init2='true') + if (vname .eq. 'WCC') call write_var2d(vname, whitecap (1:nsea,1), init2='true') + if (vname .eq. 'WCF') call write_var2d(vname, whitecap (1:nsea,2), init2='true') + if (vname .eq. 'WCH') call write_var2d(vname, whitecap (1:nsea,3), init2='true') + if (vname .eq. 'WCM') call write_var2d(vname, whitecap (1:nsea,4), init2='true') + if (vname .eq. 'TWS') call write_var2d(vname, tws (1:nsea) ) + + ! Group 6 + if (vname .eq. 'SXX') call write_var2d(vname, sxx (1:nsea) ) + if (vname .eq. 'SYY') call write_var2d(vname, syy (1:nsea) ) + if (vname .eq. 'SXY') call write_var2d(vname, sxy (1:nsea) ) + if (vname .eq. 'TAUOX') call write_var2d(vname, tauox (1:nsea), init2='true') + if (vname .eq. 'TAUOY') call write_var2d(vname, tauoy (1:nsea), init2='true') + if (vname .eq. 'BHD') call write_var2d(vname, bhd (1:nsea) ) + if (vname .eq. 'PHIOC') call write_var2d(vname, phioc (1:nsea), init2='true') + if (vname .eq. 'TUSX') call write_var2d(vname, tusx (1:nsea) ) + if (vname .eq. 'TUSY') call write_var2d(vname, tusy (1:nsea) ) + if (vname .eq. 'USSX') call write_var2d(vname, ussx (1:nsea) ) + if (vname .eq. 'USSY') call write_var2d(vname, ussy (1:nsea) ) + if (vname .eq. 'PRMS') call write_var2d(vname, prms (1:nsea) ) + if (vname .eq. 'TPMS') call write_var2d(vname, tpms (1:nsea) ) + if (vname .eq. 'TAUICEX') call write_var2d(vname, tauice (1:nsea,1) ) + if (vname .eq. 'TAUICEY') call write_var2d(vname, tauice (1:nsea,2) ) + if (vname .eq. 'PHICE') call write_var2d(vname, phice (1:nsea) ) + if (vname .eq. 'TAUOCX') call write_var2d(vname, tauocx (1:nsea) ) + if (vname .eq. 'TAUOCY') call write_var2d(vname, tauocy (1:nsea) ) #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)' + if (vname .eq. 'LANGMT') call write_var2d(vname, langmt (1:nsea) ) #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 + ! Group 7 + if (vname .eq. 'ABAX') call write_var2d(vname, aba (1:nsea), dir=cos(abd(1:nsea)) ) + if (vname .eq. 'ABAY') call write_var2d(vname, aba (1:nsea), dir=sin(abd(1:nsea)) ) + if (vname .eq. 'UBAX') call write_var2d(vname, uba (1:nsea), dir=cos(ubd(1:nsea)) ) + if (vname .eq. 'UBAY') call write_var2d(vname, uba (1:nsea), dir=sin(ubd(1:nsea)) ) + if (vname .eq. 'BED') call write_var2d(vname, bedforms (1:nsea,1), init2='true') + if (vname .eq. 'RIPPLEX') call write_var2d(vname, bedforms (1:nsea,2), init2='true') + if (vname .eq. 'RIPPLEY') call write_var2d(vname, bedforms (1:nsea,3), init2='true') + if (vname .eq. 'PHIBBL') call write_var2d(vname, phibbl (1:nsea), init2='true') + if (vname .eq. 'TAUBBLX') call write_var2d(vname, taubbl (1:nsea,1), init2='true') + if (vname .eq. 'TAUBBLY') call write_var2d(vname, taubbl (1:nsea,2), init2='true') + + ! Group 8 + if (vname .eq. 'MSSX') call write_var2d(vname, mssx (1:nsea) ) + if (vname .eq. 'MSSY') call write_var2d(vname, mssy (1:nsea) ) + if (vname .eq. 'MSCX') call write_var2d(vname, mscx (1:nsea) ) + if (vname .eq. 'MSCY') call write_var2d(vname, mscy (1:nsea) ) + !TODO: remaining variables have inconsistency between shel_inp listing and iogo code + + ! Group 9 + if (vname .eq. 'DTDYN') call write_var2d(vname, dtdyn (1:nsea) ) + if (vname .eq. 'FCUT') call write_var2d(vname, fcut (1:nsea) ) + if (vname .eq.'CFLXYMAX') call write_var2d(vname, cflxymax (1:nsea) ) + if (vname .eq.'CFLTHMAX') call write_var2d(vname, cflthmax (1:nsea) ) + if (vname .eq. 'CFLKMAX') call write_var2d(vname, cflkmax (1:nsea) ) + + ! Group 10 + end if + end do - ! 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) + if (s_axis) deallocate(var3ds) + if (m_axis) deallocate(var3dm) + if (p_axis) deallocate(var3dp) + if (k_axis) deallocate(var3dk) ! Flush the buffers for write - call W3SETA ( IGRD, NDSE, NDST ) + call w3seta ( igrd, ndse, ndst ) - end subroutine W3IOGONCD + end subroutine w3iogoncd -!/ ------------------------------------------------------------------- / - subroutine hist_filename(fname) + !=============================================================================== + subroutine write_var2d(vname, var, dir, usemask, init0, init2) + ! write (nsea) array as (nx,ny) + ! if dir is present, write x or y component of (nsea) array as (nx,ny) + ! if mask is present and true, use mapsta=1 to mask values + ! if init0 is present and false, do not initialize values + ! for mapsta<0. this prevents group 1 variables being set undef over + ! ice. if init2 is present and true, apply a second initialization to + ! a subset of variables for where mapsta==2 - USE WAV_SHR_MOD , ONLY : CASENAME, INST_SUFFIX - USE W3WDATMD , ONLY : TIME - USE W3ODATMD , ONLY : NDS, IAPROC, NAPOUT + character(len=*), intent(in) :: vname + real , intent(in) :: var(:) + real, optional , intent(in) :: dir(:) + character(len=*), optional, intent(in) :: usemask + character(len=*), optional, intent(in) :: init0 + character(len=*), optional, intent(in) :: init2 - implicit none + ! local variables + real, dimension(nx,ny) :: var2d + logical :: lmask, linit0, linit2 + real :: varloc - ! input/output variables - character(len=*), intent(out) :: fname + lmask = .false. + if (present(usemask)) then + lmask = (trim(usemask) == "true") + end if + linit0 = .true. + if (present(init0)) then + linit0 = (trim(init0) == "true") + end if + linit2 = .false. + if (present(init2)) then + linit2 = (trim(init2) == "true") + end if + + ! DEBUG + ! write(nds(1),'(a)')' writing variable ' //trim(vname)//' to history file '//trim(fname) + + var2d = undef + do isea = 1,nsea + + ! initialization + varloc = var(isea) + if (linit0) then + if (mapsta(mapsf(isea,2),mapsf(isea,1)) < 0) varloc = undef + end if + if (linit2) then + if (mapsta(mapsf(isea,2),mapsf(isea,1)) == 2) varloc = undef + end if + + if (present(dir)) then + if (varloc .ne. undef) then + if (lmask) then + if (mapsta(mapsf(isea,2),mapsf(isea,1)) == 1) then + var2d(mapsf(isea,1),mapsf(isea,2)) = varloc*dir(isea) + end if + else + var2d(mapsf(isea,1),mapsf(isea,2)) = varloc*dir(isea) + end if + end if + else + var2d(mapsf(isea,1),mapsf(isea,2)) = varloc + end if + end do + + ierr = nf90_open(trim(fname), nf90_write, ncid) + call handle_err(ierr, 'open '//trim(fname)//' for writing') + ierr = nf90_inq_varid(ncid, trim(vname), varid) + call handle_err(ierr, 'inquire variable '//trim(vname)) + ierr = nf90_put_var(ncid, varid, var2d) + call handle_err(ierr, 'put variable '//trim(vname)) + ierr = nf90_close(ncid) + + end subroutine write_var2d + + !=============================================================================== + subroutine write_var3d(vname, var, init2) + ! write (nsea,:) array as (nx,ny,:) + ! if init2 is present and true, apply a second initialization to + ! a subset of variables for where mapsta==2 + + character(len=*), intent(in) :: vname + real , intent(in) :: var(:,:) + character(len=*), optional, intent(in) :: init2 ! 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 + real, allocatable, dimension(:) :: varloc + logical :: linit2 + integer :: lb, ub + + linit2 = .false. + if (present(init2)) then + linit2 = (trim(init2) == "true") + end if + + lb = lbound(var,2) + ub = ubound(var,2) + allocate(varloc(lb:ub)) + + ! DEBUG + ! write(nds(1),'(a,2i6)')' writing variable ' //trim(vname)//' to history file ' & + ! //trim(fname)//' with bounds ',lb,ub - if (iaproc == napout) then - write(nds(1),'(a)') 'w3iogomdncd: writing history '//trim(fname) - end if + var3d = undef + do isea = 1,nsea + ! initialization + varloc(:) = var(isea,:) + if (mapsta(mapsf(isea,2),mapsf(isea,1)) < 0) varloc(:) = undef + if (linit2) then + if (mapsta(mapsf(isea,2),mapsf(isea,1)) == 2) varloc(:) = undef + end if + var3d(mapsf(isea,1),mapsf(isea,2),:) = varloc(:) + end do - end subroutine hist_filename + ierr = nf90_open(trim(fname), nf90_write, ncid) + call handle_err(ierr, 'open '//trim(fname)//' for writing') + ierr = nf90_inq_varid(ncid, trim(vname), varid) + call handle_err(ierr, 'inquire variable '//trim(vname)) + ierr = nf90_put_var(ncid, varid, var3d) + call handle_err(ierr, 'put variable '//trim(vname)) + ierr = nf90_close(ncid) -!/ ------------------------------------------------------------------- / - SUBROUTINE HANDLE_ERR(IERR,STRING) - USE W3ODATMD, ONLY: NDSE - USE W3SERVMD, ONLY: EXTCDE - USE NETCDF + deallocate(varloc) + end subroutine write_var3d - IMPLICIT NONE + !=============================================================================== + subroutine handle_err(ierr,string) + use w3odatmd , only : ndse + use w3servmd , only : extcde ! input/output variables - integer ,intent(in) :: ierr - character(len=*),intent(in) :: string + 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 + 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 +end module w3iogoncdmd diff --git a/model/src/w3iorsmd.F90 b/model/src/w3iorsmd.F90 index 1f2815dda8..8e89a52369 100644 --- a/model/src/w3iorsmd.F90 +++ b/model/src/w3iorsmd.F90 @@ -1,1711 +1,1674 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3IORSMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 2003 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ See subroutine for update log. -!/ -! 1. Purpose : -! -! Read/write restart files. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! VERINI C*10 Private Restart file version number. -! IDSTR C*26 Private Restart file UD string. -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3IORS Subr. Public Read/write restart files. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETO, W3SETG, W3SETW, W3DIMW -! Subr. W3xDATMD Manage data structures. -! STRACE Subr. W3SERVMD Subroutine tracing. (!/S) -! EXTCDE Subr. W3SERVMD Abort program with exit code. -! MPI_STARTALL, MPI_WAITALL (!/MPI) -! Subr. MPI persistent communication routines -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! See also routine. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -!/ - ! Add fields needed for OASIS coupling in restart - LOGICAL :: OARST -!/ -!/ Private parameter statements (ID strings) -!/ - CHARACTER(LEN=10), PARAMETER, PRIVATE :: VERINI = '2021-05-28' - CHARACTER(LEN=26), PARAMETER, PRIVATE :: & - IDSTR = 'WAVEWATCH III RESTART FILE' -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 12-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) -!/ 27-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 30-Apr-2002 : Add ice for transparencies. ( version 2.20 ) -!/ 13-Nov-2002 : Add stress as vector. ( version 3.00 ) -!/ 19-Aug-2003 : Output server options added. ( version 3.04 ) -!/ 09-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 24-Jun-2005 : Adding MAPST2. ( version 3.07 ) -!/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) -!/ 05-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) -!/ 08-May-2007 : Starting from calm as an option. ( version 3.11 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 22-Jun-2007 : Dedicated output processes. ( version 3.11 ) -!/ 15-Apr-2008 : Clean up for distribution. ( version 3.14 ) -!/ 21-Apr-2008 : Remove PGI bug internal files. ( version 3.14 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Output file name with 3 digit id. ( version 3.14 ) -!/ (W. E. Rogers, NRL) -!/ 14-Nov-2013 : Remove cold start init. UST(DIR). ( version 4.13 ) -!/ 31-May-2016 : Optimize restart file size for un- ( version 5.10 ) -!/ structured grid and restart read. -!/ (M. Ward, NCI, S. Zieger, BOM) -!/ 10-Mar-2017 : File access mode changed to 'STREAM'( version 6.02 ) -!/ (S. Zieger, BOM) -!/ 09-Aug-2017 : Bug fix for MPI restart read issue ( version 6.02 ) -!/ (T. Campbell, NRL) -!/ 05-Jun-2018 : Add PDLIB/TIMINGS/DEBUGIO ( version 6.04 ) -!/ DEBUGINIT/MPI -!/ 19-Dec-2019 : Optional second stream of ( version 7.00 ) -!/ restart files -!/ (Roberto Padilla-Hernandez & J.H. Alves) -!/ 25-Sep-2020 : Extra fields for coupled restart ( version 7.10 ) -!/ 22-Mar-2021 : Add new coupling fields in restart ( version 7.13 ) -!/ 18-May-2021 : Read by default all extra restart ( version 7.13 ) -!/ -!/ Copyright 2009-2013 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! Reads/writes restart files. -! -! 2. Method : -! -! The file is opened within the routine, the name is pre-defined -! and the unit number is given in the parameter list. The restart -! file is written using UNFORMATTED write statements. The routine -! generates new names when called more than once. File names are : -! -! restart000.FILEXT -! restart001.FILEXT -! restart002.FILEXT etc. -! -! Optionally, a second stream of restart files is generated given -! a secondary stride definad by an additional start/end time line -! triggered by an optional argument added to the end of the stan- -! dard restart request line (a sixth argument flag set to T). File -! names include a time-tag prefix: -! -! YYYYMMDD.HHMMSS.restart.FILEXT -! -! The file to be read thus always is unnumbered, whereas all -! written files are automatically numbered. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! INXOUT C*(*) I Test string for read/write, valid are: -! 'READ' Reading of a restart file. -! 'HOT' Writing a full restart from the model. -! 'COLD' Writing a cold start file. -! 'WIND' Initialize fields using first wind -! field. -! 'CALM' Starting from calm conditions. -! NDSR Int. I/O File unit number. -! DUMFPI Real I Dummy values for FPIS for cold start. -! RSTYPE Int. O Type of input field, -! 0 : cold start, -! 1 : cold start with fetch-limited spectra, -! 2 : full restart, -! 3 : for writing file. -! 4 : starting from calm. -! IMOD Int. I Optional grid number, defaults to 1. -! FLRSTRT LOGIC I OTIONAL TRUE: A second request for restart files -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3INIT Subr. W3INITMD Wave model initialization routine. -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! WW3_STRT Prog. N/A Initial conditions program. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! Tests on INXOUT, file status and on array dimensions. -! -! 7. Remarks : -! -! - MAPSTA is dumped as it contains information on inactive points. -! Note that the original MAPSTA is dumped in the model def. file -! for use in the initial conditions (and output) programs. -! - Note that MAPSTA and MAPST2 data is combinded in the file. -! - The depth is recalculated in a write to avoid floating point -! errors in W3STRT. -! - Fields and field info read by all, written by las processor -! only. -! - The MPP version of the model will perform a gather here to -! maximize hiding of communication with IO. -! -! 8. Structure : -! -! +---------------------------------------------------------------+ -! | initialisations | -! | test INXOUT | -! | open file | -! +---------------------------------------------------------------| -! | WRITE ? | -! | Y N | -! |-------------------------------|-------------------------------| -! | Write identifiers and | Write identifiers and | -! | dimensions. | dimensions. | -! | | Check ident. and dimensions. | -! +-------------------------------+-------------------------------| -! | Full restart ? | -! | Y N | -! |-------------------------------|-------------------------------| -! | read/write/test time | | -! +-------------------------------+-------------------------------| -! | WRITE ? | -! | Y N | -! |-------------------------------|-------------------------------| -! | TYPE = 'WIND' ? | TYPE = 'WIND' ? | -! | Y N | Y N | -! |---------------|---------------|---------------|---------------| -! | close file | write spectra | gen. fetch-l. | read spectra | -! | RETURN | | spectra. | | -! |---------------+---------------+---------------+---------------| -! | WRITE ? | -! | Y N | -! |-------------------------------|-------------------------------| -! | TYPE = 'FULL' ? | TYPE = 'FULL' ? | -! | Y N | Y N | -! |---------------|---------------|---------------|---------------| -! | write level & | ( prep. level | read level & | initalize l.& | -! | (ice) map & | for test | (ice) map.& | times | -! | times | output ) | times | ( no ice ) | -! +---------------+---------------+---------------+-------------- + -! -! 9. Switches : -! -! !/SEED Linear input / seeding option. -! !/LNx -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! !/MPI Id. -! -! !/S Enable subroutine tracing. -! !/T Enable test output -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE W3GDATMD, ONLY: W3SETG, W3SETREF, RSTYPE - USE W3ODATMD, ONLY: W3SETO - USE W3ADATMD, ONLY: W3SETA, W3XETA, NSEALM - USE W3ADATMD, ONLY: CX, CY, HS, WLM, T0M1, T01, FP0, THM, CHARN,& - TAUWIX, TAUWIY, TWS, TAUOX, TAUOY, BHD, & - PHIOC, TUSX, TUSY, USSX, USSY, TAUICE, & - UBA, UBD, PHIBBL, TAUBBL, TAUOCX, TAUOCY, & - WNMEAN -!/ - USE W3GDATMD, ONLY: NX, NY, NSEA, NSEAL, NSPEC, MAPSTA, MAPST2, & - GNAME, FILEXT, GTYPE, UNGTYPE - USE W3TRIAMD, ONLY: SET_UG_IOBP - USE W3WDATMD +MODULE W3IORSMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 2003 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ See subroutine for update log. + !/ + ! 1. Purpose : + ! + ! Read/write restart files. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! VERINI C*10 Private Restart file version number. + ! IDSTR C*26 Private Restart file UD string. + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3IORS Subr. Public Read/write restart files. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETO, W3SETG, W3SETW, W3DIMW + ! Subr. W3xDATMD Manage data structures. + ! STRACE Subr. W3SERVMD Subroutine tracing. (!/S) + ! EXTCDE Subr. W3SERVMD Abort program with exit code. + ! MPI_STARTALL, MPI_WAITALL (!/MPI) + ! Subr. MPI persistent communication routines + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! See also routine. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + + !module default + IMPLICIT NONE + + PUBLIC + !/ + ! Add fields needed for OASIS coupling in restart + LOGICAL :: OARST + !/ + !/ Private parameter statements (ID strings) + !/ + CHARACTER(LEN=10), PARAMETER, PRIVATE :: VERINI = '2021-05-28' + CHARACTER(LEN=26), PARAMETER, PRIVATE :: & + IDSTR = 'WAVEWATCH III RESTART FILE' + !/ +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE W3IORS ( INXOUT, NDSR, DUMFPI, IMOD, FLRSTRT ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 12-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) + !/ 27-Dec-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 30-Apr-2002 : Add ice for transparencies. ( version 2.20 ) + !/ 13-Nov-2002 : Add stress as vector. ( version 3.00 ) + !/ 19-Aug-2003 : Output server options added. ( version 3.04 ) + !/ 09-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 24-Jun-2005 : Adding MAPST2. ( version 3.07 ) + !/ 27-Jun-2006 : Adding file name preamble. ( version 3.09 ) + !/ 05-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) + !/ 08-May-2007 : Starting from calm as an option. ( version 3.11 ) + !/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 22-Jun-2007 : Dedicated output processes. ( version 3.11 ) + !/ 15-Apr-2008 : Clean up for distribution. ( version 3.14 ) + !/ 21-Apr-2008 : Remove PGI bug internal files. ( version 3.14 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Output file name with 3 digit id. ( version 3.14 ) + !/ (W. E. Rogers, NRL) + !/ 14-Nov-2013 : Remove cold start init. UST(DIR). ( version 4.13 ) + !/ 31-May-2016 : Optimize restart file size for un- ( version 5.10 ) + !/ structured grid and restart read. + !/ (M. Ward, NCI, S. Zieger, BOM) + !/ 10-Mar-2017 : File access mode changed to 'STREAM'( version 6.02 ) + !/ (S. Zieger, BOM) + !/ 09-Aug-2017 : Bug fix for MPI restart read issue ( version 6.02 ) + !/ (T. Campbell, NRL) + !/ 05-Jun-2018 : Add PDLIB/TIMINGS/DEBUGIO ( version 6.04 ) + !/ DEBUGINIT/MPI + !/ 19-Dec-2019 : Optional second stream of ( version 7.00 ) + !/ restart files + !/ (Roberto Padilla-Hernandez & J.H. Alves) + !/ 25-Sep-2020 : Extra fields for coupled restart ( version 7.10 ) + !/ 22-Mar-2021 : Add new coupling fields in restart ( version 7.13 ) + !/ 18-May-2021 : Read by default all extra restart ( version 7.13 ) + !/ + !/ Copyright 2009-2013 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! Reads/writes restart files. + ! + ! 2. Method : + ! + ! The file is opened within the routine, the name is pre-defined + ! and the unit number is given in the parameter list. The restart + ! file is written using UNFORMATTED write statements. The routine + ! generates new names when called more than once. File names are : + ! + ! restart000.FILEXT + ! restart001.FILEXT + ! restart002.FILEXT etc. + ! + ! Optionally, a second stream of restart files is generated given + ! a secondary stride definad by an additional start/end time line + ! triggered by an optional argument added to the end of the stan- + ! dard restart request line (a sixth argument flag set to T). File + ! names include a time-tag prefix: + ! + ! YYYYMMDD.HHMMSS.restart.FILEXT + ! + ! The file to be read thus always is unnumbered, whereas all + ! written files are automatically numbered. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! INXOUT C*(*) I Test string for read/write, valid are: + ! 'READ' Reading of a restart file. + ! 'HOT' Writing a full restart from the model. + ! 'COLD' Writing a cold start file. + ! 'WIND' Initialize fields using first wind + ! field. + ! 'CALM' Starting from calm conditions. + ! NDSR Int. I/O File unit number. + ! DUMFPI Real I Dummy values for FPIS for cold start. + ! RSTYPE Int. O Type of input field, + ! 0 : cold start, + ! 1 : cold start with fetch-limited spectra, + ! 2 : full restart, + ! 3 : for writing file. + ! 4 : starting from calm. + ! IMOD Int. I Optional grid number, defaults to 1. + ! FLRSTRT LOGIC I OTIONAL TRUE: A second request for restart files + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3INIT Subr. W3INITMD Wave model initialization routine. + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! WW3_STRT Prog. N/A Initial conditions program. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! Tests on INXOUT, file status and on array dimensions. + ! + ! 7. Remarks : + ! + ! - MAPSTA is dumped as it contains information on inactive points. + ! Note that the original MAPSTA is dumped in the model def. file + ! for use in the initial conditions (and output) programs. + ! - Note that MAPSTA and MAPST2 data is combinded in the file. + ! - The depth is recalculated in a write to avoid floating point + ! errors in W3STRT. + ! - Fields and field info read by all, written by las processor + ! only. + ! - The MPP version of the model will perform a gather here to + ! maximize hiding of communication with IO. + ! + ! 8. Structure : + ! + ! +---------------------------------------------------------------+ + ! | initialisations | + ! | test INXOUT | + ! | open file | + ! +---------------------------------------------------------------| + ! | WRITE ? | + ! | Y N | + ! |-------------------------------|-------------------------------| + ! | Write identifiers and | Write identifiers and | + ! | dimensions. | dimensions. | + ! | | Check ident. and dimensions. | + ! +-------------------------------+-------------------------------| + ! | Full restart ? | + ! | Y N | + ! |-------------------------------|-------------------------------| + ! | read/write/test time | | + ! +-------------------------------+-------------------------------| + ! | WRITE ? | + ! | Y N | + ! |-------------------------------|-------------------------------| + ! | TYPE = 'WIND' ? | TYPE = 'WIND' ? | + ! | Y N | Y N | + ! |---------------|---------------|---------------|---------------| + ! | close file | write spectra | gen. fetch-l. | read spectra | + ! | RETURN | | spectra. | | + ! |---------------+---------------+---------------+---------------| + ! | WRITE ? | + ! | Y N | + ! |-------------------------------|-------------------------------| + ! | TYPE = 'FULL' ? | TYPE = 'FULL' ? | + ! | Y N | Y N | + ! |---------------|---------------|---------------|---------------| + ! | write level & | ( prep. level | read level & | initalize l.& | + ! | (ice) map & | for test | (ice) map.& | times | + ! | times | output ) | times | ( no ice ) | + ! +---------------+---------------+---------------+-------------- + + ! + ! 9. Switches : + ! + ! !/SEED Linear input / seeding option. + ! !/LNx + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! !/MPI Id. + ! + ! !/S Enable subroutine tracing. + ! !/T Enable test output + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD, ONLY: W3SETG, W3SETREF, RSTYPE + USE W3ODATMD, ONLY: W3SETO + USE W3WDATMD, only : W3SETW, W3DIMW + USE W3ADATMD, ONLY: W3SETA, W3XETA, NSEALM + USE W3ADATMD, ONLY: CX, CY, HS, WLM, T0M1, T01, FP0, THM, CHARN,& + TAUWIX, TAUWIY, TWS, TAUOX, TAUOY, BHD, & + PHIOC, TUSX, TUSY, USSX, USSY, TAUICE, & + UBA, UBD, PHIBBL, TAUBBL, TAUOCX, TAUOCY, & + WNMEAN + !/ + USE W3GDATMD, ONLY: NX, NY, NSEA, NSEAL, NSPEC, MAPSTA, MAPST2, & + GNAME, FILEXT, GTYPE, UNGTYPE + USE W3TRIAMD, ONLY: SET_UG_IOBP + USE W3WDATMD, only : DINIT, VA, TIME, TLEV, TICE, TRHO, ICE, UST + USE W3WDATMD, only : USTDIR, ASF, FPIS, ICEF, TIC1, TIC5, WLV #ifdef W3_WRST - USE W3IDATMD, ONLY: WXN, WYN, W3SETI - USE W3IDATMD, ONLY: WXNwrst, WYNwrst + USE W3IDATMD, ONLY: WXN, WYN, W3SETI + USE W3IDATMD, ONLY: WXNwrst, WYNwrst #endif - USE W3ODATMD, ONLY: NDSE, NDST, IAPROC, NAPROC, NAPERR, NAPRST, & - IFILE => IFILE4, FNMPRE, NTPROC, IOSTYP, & - FLOGRR, NOGRP, NGRPP, SCREEN + USE W3ODATMD, ONLY: NDSE, NDST, IAPROC, NAPROC, NAPERR, NAPRST, & + IFILE => IFILE4, FNMPRE, NTPROC, IOSTYP, & + FLOGRR, NOGRP, NGRPP, SCREEN #ifdef W3_MPI - USE W3ODATMD, ONLY: NRQRS, NBLKRS, RSBLKS, IRQRS, IRQRSS, & - VAAUX - USE W3ADATMD, ONLY: MPI_COMM_WCMP -#endif -!/ - USE W3SERVMD, ONLY: EXTCDE - USE CONSTANTS, only: LPDLIB, file_endian - USE W3PARALL, ONLY: INIT_GET_ISEA, INIT_GET_JSEA_ISPROC - USE W3GDATMD, ONLY: NK, NTH + USE W3ODATMD, ONLY: NRQRS, NBLKRS, RSBLKS, IRQRS, IRQRSS, & + VAAUX + USE W3ADATMD, ONLY: MPI_COMM_WCMP +#endif + !/ + USE W3SERVMD, ONLY: EXTCDE + USE CONSTANTS, only: LPDLIB, file_endian + USE W3PARALL, ONLY: INIT_GET_ISEA, INIT_GET_JSEA_ISPROC + USE W3GDATMD, ONLY: NK, NTH #ifdef W3_TIMINGS - USE W3PARALL, ONLY: PRINT_MY_TIME -#endif -#ifdef W3_CESMCOUPLED - USE W3ADATMD , ONLY : LAMULT - USE WAV_SHR_MOD, ONLY : RUNTYPE + USE W3PARALL, ONLY: PRINT_MY_TIME #endif + USE w3odatmd, ONLY : RUNTYPE, INITFILE !!!!!/PDLIB USE PDLIB_FIELD_VEC!, only : UNST_PDLIB_READ_FROM_FILE, UNST_PDLIB_WRITE_TO_FILE #ifdef W3_PDLIB USE PDLIB_FIELD_VEC #endif #ifdef W3_S - USE W3SERVMD, ONLY: STRACE + USE W3SERVMD, ONLY: STRACE #endif -! - IMPLICIT NONE -! + ! + use w3timemd, only: set_user_timestring + use w3odatmd, only: use_user_restname, user_restfname, ndso + ! #ifdef W3_MPI - INCLUDE "mpif.h" -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER :: NDSR -! INTEGER, INTENT(IN) :: NDSR - INTEGER, INTENT(IN), OPTIONAL :: IMOD - REAL, INTENT(INOUT) :: DUMFPI - CHARACTER, INTENT(IN) :: INXOUT*(*) - LOGICAL, INTENT(IN),OPTIONAL :: FLRSTRT -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER, PARAMETER :: LRB = 4 -! - INTEGER :: IGRD, I, J, LRECL, NSIZE, IERR, & - NSEAT, MSPEC, TTIME(2), ISEA, JSEA, & - NREC, NPART, IPART, IX, IY, IXL, IP, & - NPRTX2, NPRTY2, IYL, ITMP - INTEGER, ALLOCATABLE :: MAPTMP(:,:) + INCLUDE "mpif.h" +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER :: NDSR + ! INTEGER, INTENT(IN) :: NDSR + INTEGER, INTENT(IN), OPTIONAL :: IMOD + REAL, INTENT(INOUT) :: DUMFPI + CHARACTER, INTENT(IN) :: INXOUT*(*) + LOGICAL, INTENT(IN),OPTIONAL :: FLRSTRT + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER, PARAMETER :: LRB = 4 + ! + INTEGER :: IGRD, I, J, LRECL, NSIZE, IERR, & + NSEAT, MSPEC, TTIME(2), ISEA, JSEA, & + NREC, NPART, IPART, IX, IY, IXL, IP, & + NPRTX2, NPRTY2, IYL, ITMP + INTEGER, ALLOCATABLE :: MAPTMP(:,:) #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + INTEGER, SAVE :: IENT = 0 #endif #ifdef W3_MPI - INTEGER :: IERR_MPI, IH, IB, ISEA0, ISEAN, & - NRQ, NSEAL_MIN + INTEGER :: IERR_MPI, IH, IB, ISEA0, ISEAN, & + NRQ, NSEAL_MIN #endif - INTEGER(KIND=8) :: RPOS + INTEGER(KIND=8) :: RPOS #ifdef W3_MPI - INTEGER, ALLOCATABLE :: STAT1(:,:), STAT2(:,:) - REAL, ALLOCATABLE :: VGBUFF(:), VLBUFF(:) + INTEGER, ALLOCATABLE :: STAT1(:,:), STAT2(:,:) + REAL, ALLOCATABLE :: VGBUFF(:), VLBUFF(:) #endif - REAL(KIND=LRB), ALLOCATABLE :: WRITEBUFF(:), TMP(:), TMP2(:) + REAL(KIND=LRB), ALLOCATABLE :: WRITEBUFF(:), TMP(:), TMP2(:) - LOGICAL :: WRITE, IOSFLG - LOGICAL :: FLOGOA(NOGRP,NGRPP) - LOGICAL :: NDSROPN - CHARACTER(LEN=4) :: TYPE - CHARACTER(LEN=10) :: VERTST -#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 -!/ -!/ ------------------------------------------------------------------- / -!/ + LOGICAL :: WRITE, IOSFLG + LOGICAL :: FLOGOA(NOGRP,NGRPP) + LOGICAL :: NDSROPN + CHARACTER(LEN=4) :: TYPE + CHARACTER(LEN=10) :: VERTST + CHARACTER(LEN=512) :: FNAME + CHARACTER(LEN=26) :: IDTST + CHARACTER(LEN=30) :: TNAME + CHARACTER(LEN=15) :: TIMETAG + character(len=16) :: user_timestring !YYYY-MM-DD-SSSSS + logical :: exists + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_S - CALL STRACE (IENT, 'W3IORS') -#endif -! -! -! Constant NDSR for using mpiifort in ZEUS ... paralell runs crashing -! because compiler doesn't accept reciclyng of UNIT for FORMATTED or -! UNFORMATTED files in OPEN -! -! NDSR = 525 + CALL STRACE (IENT, 'W3IORS') +#endif + ! + ! + ! Constant NDSR for using mpiifort in ZEUS ... paralell runs crashing + ! because compiler doesn't accept reciclyng of UNIT for FORMATTED or + ! UNFORMATTED files in OPEN + ! + ! NDSR = 525 #ifdef W3_DEBUGIO - WRITE(740+IAPROC,*) 'Beginning of W3IORS subroutine' - WRITE(740+IAPROC,*) 'W3IORS, step 1' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Beginning of W3IORS subroutine' + WRITE(740+IAPROC,*) 'W3IORS, step 1' + FLUSH(740+IAPROC) #endif - IOSFLG = IOSTYP .GT. 0 -! -! test parameter list input ------------------------------------------ * -! - IF ( PRESENT(IMOD) ) THEN - IGRD = IMOD - ELSE - IGRD = 1 - END IF -! - CALL W3SETO ( IGRD, NDSE, NDST ) - CALL W3SETG ( IGRD, NDSE, NDST ) - CALL W3SETW ( IGRD, NDSE, NDST ) + IOSFLG = IOSTYP .GT. 0 + ! + ! test parameter list input ------------------------------------------ * + ! + IF ( PRESENT(IMOD) ) THEN + IGRD = IMOD + ELSE + IGRD = 1 + END IF + ! + CALL W3SETO ( IGRD, NDSE, NDST ) + CALL W3SETG ( IGRD, NDSE, NDST ) + CALL W3SETW ( IGRD, NDSE, NDST ) #ifdef W3_WRST - CALL W3SETI ( IGRD, NDSE, NDST ) -#endif -! - IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'HOT' .AND. & - INXOUT.NE.'COLD' .AND. INXOUT.NE.'WIND' .AND. & - INXOUT.NE.'CALM' ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,900) INXOUT - CALL EXTCDE ( 1 ) - END IF -! - WRITE = INXOUT .NE. 'READ' - IF ( INXOUT .EQ. 'HOT' ) THEN - TYPE = 'FULL' - ELSE - TYPE = INXOUT - END IF -! + CALL W3SETI ( IGRD, NDSE, NDST ) +#endif + ! + IF (INXOUT.NE.'READ' .AND. INXOUT.NE.'HOT' .AND. & + INXOUT.NE.'COLD' .AND. INXOUT.NE.'WIND' .AND. & + INXOUT.NE.'CALM' ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,900) INXOUT + CALL EXTCDE ( 1 ) + END IF + ! + WRITE = INXOUT .NE. 'READ' + IF ( INXOUT .EQ. 'HOT' ) THEN + TYPE = 'FULL' + ELSE + TYPE = INXOUT + END IF + ! #ifdef W3_T - WRITE (NDST,9000) INXOUT, WRITE, NTPROC, NAPROC, IAPROC, NAPRST + WRITE (NDST,9000) INXOUT, WRITE, NTPROC, NAPROC, IAPROC, NAPRST #endif -! -! initializations ---------------------------------------------------- * -! + ! + ! initializations ---------------------------------------------------- * + ! #ifdef W3_DEBUGIO - WRITE(740+IAPROC,*) 'W3IORS, step 2' - FLUSH(740+IAPROC) -#endif - IF ( .NOT.DINIT ) THEN - IF ( IAPROC .LE. NAPROC ) THEN - CALL W3DIMW ( IMOD, NDSE, NDST ) - ELSE - CALL W3DIMW ( IMOD, NDSE, NDST, .FALSE. ) - END IF - END IF + WRITE(740+IAPROC,*) 'W3IORS, step 2' + FLUSH(740+IAPROC) +#endif + IF ( .NOT.DINIT ) THEN + IF ( IAPROC .LE. NAPROC ) THEN + CALL W3DIMW ( IMOD, NDSE, NDST ) + ELSE + CALL W3DIMW ( IMOD, NDSE, NDST, .FALSE. ) + END IF + END IF #ifdef W3_DEBUGIO - WRITE(740+IAPROC,*) 'W3IORS, step 3' - FLUSH(740+IAPROC) -#endif -! - IF ( IAPROC .LE. NAPROC ) VA(:,0) = 0. -! - LRECL = MAX ( LRB*NSPEC , & - LRB*(6+(25/LRB)+(9/LRB)+(29/LRB)+(3/LRB)) ) - NSIZE = LRECL / LRB + WRITE(740+IAPROC,*) 'W3IORS, step 3' + FLUSH(740+IAPROC) +#endif + ! + IF ( IAPROC .LE. NAPROC ) VA(:,0) = 0. + ! + LRECL = MAX ( LRB*NSPEC , & + LRB*(6+(25/LRB)+(9/LRB)+(29/LRB)+(3/LRB)) ) + NSIZE = LRECL / LRB #ifdef W3_DEBUGIO - WRITE(740+IAPROC,*) 'W3IORS, LRECL=', LRECL, ' NSIZE=', NSIZE - FLUSH(740+IAPROC) -#endif -! --- Allocate buffer array with zeros (used to -! fill bytes up to size LRECL). --- - ALLOCATE(WRITEBUFF(NSIZE)) - WRITEBUFF(:) = 0. -! -! Allocate memory to receive fields needed for coupling - IF (OARST) THEN - ALLOCATE(TMP(NSEA)) - ALLOCATE(TMP2(NSEA)) - ENDIF -! -! open file ---------------------------------------------------------- * -! -#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') + WRITE(740+IAPROC,*) 'W3IORS, LRECL=', LRECL, ' NSIZE=', NSIZE + FLUSH(740+IAPROC) +#endif + ! --- Allocate buffer array with zeros (used to + ! fill bytes up to size LRECL). --- + ALLOCATE(WRITEBUFF(NSIZE)) + WRITEBUFF(:) = 0. + ! + ! Allocate memory to receive fields needed for coupling + IF (OARST) THEN + ALLOCATE(TMP(NSEA)) + ALLOCATE(TMP2(NSEA)) + ENDIF + ! + ! open file ---------------------------------------------------------- * + ! + if (use_user_restname) then + ierr = -99 + if (.not. write) then + if (runtype == 'initial') then + if (len_trim(initfile) == 0) then + ! no IC file, use startup option + goto 800 + else + ! IC file exists - use it + fname = trim(initfile) + end if + else + call set_user_timestring(time,user_timestring) + fname = trim(user_restfname)//trim(user_timestring) + inquire( file=trim(fname), exist=exists) + if (.not. exists) then + call extcde (60, msg="required initial/restart file " // trim(fname) // " does not exist") + end if + end if + else + call set_user_timestring(time,user_timestring) + fname = trim(user_restfname)//trim(user_timestring) + end if + ! write out filename + if (iaproc == naprst) then + if (write) then + write (ndso,'(a)') 'WW3: writing restart file '//trim(fname) + else + write (ndso,'(a)') 'WW3: reading initial/restart file '//trim(fname) + end if + end if + if ( write ) then + if ( .not.iosflg .or. iaproc.eq.naprst ) & + open (ndsr,file=trim(fname), form='unformatted', convert=file_endian, & + access='stream',err=800,iostat=ierr) + else ! read + open (ndsr, file=trim(fname), form='unformatted', convert=file_endian, & + access='stream',err=800,iostat=ierr, & + status='old',action='read') + end if + else + I = LEN_TRIM(FILEXT) + J = LEN_TRIM(FNMPRE) + ! + !CHECKPOINT RESTART FILE + ITMP=0 + 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 -#else - I = LEN_TRIM(FILEXT) - J = LEN_TRIM(FNMPRE) -! -!CHECKPOINT RESTART FILE - ITMP=0 - 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 - IF(ITMP.NE.1)THEN ! FNAME is not set above, so do it here - IF ( IFILE.EQ.0 ) THEN - FNAME = 'restart.'//FILEXT(:I) - ELSE - FNAME = 'restartNNN.'//FILEXT(:I) - IF ( WRITE .AND. IAPROC.EQ.NAPRST ) & - WRITE (FNAME(8:10),'(I3.3)') IFILE - END IF - END IF - IFILE = IFILE + 1 -! + IF(ITMP.NE.1)THEN ! FNAME is not set above, so do it here + IF ( IFILE.EQ.0 ) THEN + FNAME = 'restart.'//FILEXT(:I) + ELSE + FNAME = 'restartNNN.'//FILEXT(:I) + IF ( WRITE .AND. IAPROC.EQ.NAPRST ) & + WRITE (FNAME(8:10),'(I3.3)') IFILE + END IF + END IF + IFILE = IFILE + 1 + ! #ifdef W3_T - WRITE (NDST,9001) FNAME, LRECL + WRITE (NDST,9001) trim(FNAME), LRECL #endif -! + ! - IF(NDST.EQ.NDSR)THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE(NDSE,'(A,I8)')'UNIT NUMBERS OF RESTART FILE AND '& - //'TEST OUTPUT ARE THE SAME : ',NDST - CALL EXTCDE ( 15 ) - ENDIF + IF(NDST.EQ.NDSR)THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE(NDSE,'(A,I8)')'UNIT NUMBERS OF RESTART FILE AND '& + //'TEST OUTPUT ARE THE SAME : ',NDST + CALL EXTCDE ( 15 ) + ENDIF #ifdef W3_DEBUGIO - WRITE(740+IAPROC,*) 'W3IORS, step 4' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'W3IORS, step 4' + FLUSH(740+IAPROC) #endif - IF ( WRITE ) THEN + IF ( WRITE ) THEN IF ( .NOT.IOSFLG .OR. IAPROC.EQ.NAPRST ) & - OPEN (NDSR,FILE=FNMPRE(:J)//FNAME,form='UNFORMATTED', convert=file_endian, & - ACCESS='STREAM',ERR=800,IOSTAT=IERR) - ELSE - OPEN (NDSR,FILE=FNMPRE(:J)//FNAME,form='UNFORMATTED', convert=file_endian, & - ACCESS='STREAM',ERR=800,IOSTAT=IERR, & - STATUS='OLD',ACTION='READ') - END IF -#endif -! -! test info ---------------------------------------------------------- * -! - IF ( WRITE ) THEN -! - IF ( IAPROC .EQ. NAPRST ) THEN -! Because data has mixed data types we do not know how many -! bytes remain to fill up to LRECL. --- -! --- Make the entire record zero --- - WRITEBUFF(:) = 0. - WRITE (NDSR,POS=1) WRITEBUFF -! --- Replace zeros with data --- - WRITE (NDSR,POS=1) IDSTR, VERINI, GNAME, TYPE, NSEA, & - NSPEC, FLOGRR - END IF - RSTYPE = 3 -! - ELSE - READ (NDSR,POS=1,ERR=802,IOSTAT=IERR) & + OPEN (NDSR,FILE=FNMPRE(:J)//trim(FNAME),form='UNFORMATTED', convert=file_endian, & + ACCESS='STREAM',ERR=800,IOSTAT=IERR) + ELSE + OPEN (NDSR,FILE=FNMPRE(:J)//trim(FNAME),form='UNFORMATTED', convert=file_endian, & + ACCESS='STREAM',ERR=800,IOSTAT=IERR, & + STATUS='OLD',ACTION='READ') + END IF + end if + ! + ! test info ---------------------------------------------------------- * + ! + IF ( WRITE ) THEN + ! + IF ( IAPROC .EQ. NAPRST ) THEN + ! Because data has mixed data types we do not know how many + ! bytes remain to fill up to LRECL. --- + ! --- Make the entire record zero --- + WRITEBUFF(:) = 0. + WRITE (NDSR,POS=1) WRITEBUFF + ! --- Replace zeros with data --- + WRITE (NDSR,POS=1) IDSTR, VERINI, GNAME, TYPE, NSEA, & + NSPEC, FLOGRR + END IF + RSTYPE = 3 + ! + ELSE + READ (NDSR,POS=1,ERR=802,IOSTAT=IERR) & IDTST, VERTST, TNAME, TYPE, NSEAT, MSPEC, FLOGOA -! - IF ( IDTST .NE. IDSTR ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,901) IDTST, IDSTR - CALL EXTCDE ( 10 ) - END IF - IF ( VERTST .NE. VERINI ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,902) VERTST, VERINI - CALL EXTCDE ( 11 ) - END IF - IF ( TNAME .NE. GNAME ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,903) TNAME, GNAME - END IF - IF (TYPE.NE.'FULL' .AND. TYPE.NE.'COLD' .AND. & - TYPE.NE.'WIND' .AND. TYPE.NE.'CALM' ) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,904) TYPE - CALL EXTCDE ( 12 ) - END IF - IF (NSEAT.NE.NSEA .OR. NSPEC.NE.MSPEC) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,905) MSPEC, NSEAT, NSPEC, NSEA - CALL EXTCDE ( 13 ) - END IF - IF (TYPE.EQ.'FULL') THEN - RSTYPE = 2 - ELSE IF (TYPE.EQ.'WIND') THEN - RSTYPE = 1 - ELSE IF (TYPE.EQ.'CALM') THEN - RSTYPE = 4 - ELSE - RSTYPE = 0 - END IF + ! + IF ( IDTST .NE. IDSTR ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,901) IDTST, IDSTR + CALL EXTCDE ( 10 ) + END IF + IF ( VERTST .NE. VERINI ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,902) VERTST, VERINI + CALL EXTCDE ( 11 ) + END IF + IF ( TNAME .NE. GNAME ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,903) TNAME, GNAME + END IF + IF (TYPE.NE.'FULL' .AND. TYPE.NE.'COLD' .AND. & + TYPE.NE.'WIND' .AND. TYPE.NE.'CALM' ) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,904) TYPE + CALL EXTCDE ( 12 ) + END IF + IF (NSEAT.NE.NSEA .OR. NSPEC.NE.MSPEC) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,905) MSPEC, NSEAT, NSPEC, NSEA + CALL EXTCDE ( 13 ) + END IF + IF (TYPE.EQ.'FULL') THEN + RSTYPE = 2 + ELSE IF (TYPE.EQ.'WIND') THEN + RSTYPE = 1 + ELSE IF (TYPE.EQ.'CALM') THEN + RSTYPE = 4 + ELSE + RSTYPE = 0 + END IF - IF (.NOT. WRITE .AND. OARST .AND. IAPROC .EQ. NAPROC) THEN - DO I=1, NOGRP - DO J=1, NGRPP + IF (.NOT. WRITE .AND. OARST .AND. IAPROC .EQ. NAPROC) THEN + DO I=1, NOGRP + DO J=1, NGRPP IF (FLOGRR(I,J) .AND. .NOT. FLOGOA(I,J)) THEN - WRITE(SCREEN,1000) I, J + WRITE(SCREEN,1000) I, J ENDIF - ENDDO - ENDDO - ENDIF -! - END IF -! - 100 CONTINUE -! + ENDDO + ENDDO + ENDIF + ! + END IF + ! +100 CONTINUE + ! #ifdef W3_T - WRITE (NDST,9002) IDSTR, VERINI, GNAME, TYPE, & - NSEA, NSEAL, NSPEC + WRITE (NDST,9002) IDSTR, VERINI, GNAME, TYPE, & + NSEA, NSEAL, NSPEC #endif -! -! TIME if required --------------------------------------------------- * -! + ! + ! TIME if required --------------------------------------------------- * + ! #ifdef W3_DEBUGIO - WRITE(740+IAPROC,*) 'W3IORS, step 5' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'W3IORS, step 5' + FLUSH(740+IAPROC) #endif - IF (TYPE.EQ.'FULL') THEN - RPOS = 1_8 + LRECL*(2-1_8) - IF ( WRITE ) THEN - IF ( IAPROC .EQ. NAPRST ) THEN - WRITEBUFF(:) = 0. - WRITE (NDSR,POS=RPOS) WRITEBUFF - WRITE (NDSR,POS=RPOS) TIME - END IF - ELSE - READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) TTIME + IF (TYPE.EQ.'FULL') THEN + RPOS = 1_8 + LRECL*(2-1_8) + IF ( WRITE ) THEN + IF ( IAPROC .EQ. NAPRST ) THEN + WRITEBUFF(:) = 0. + WRITE (NDSR,POS=RPOS) WRITEBUFF + WRITE (NDSR,POS=RPOS) TIME + END IF + ELSE + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) TTIME #ifdef W3_CESMCOUPLED - if (runtype == 'branch' .or. runtype == 'continue') then - IF (TIME(1).NE.TTIME(1) .OR. TIME(2).NE.TTIME(2)) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,906) TTIME, TIME - CALL EXTCDE ( 20 ) - END IF - end if + if (runtype == 'branch' .or. runtype == 'continue') then + IF (TIME(1).NE.TTIME(1) .OR. TIME(2).NE.TTIME(2)) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,906) TTIME, TIME + CALL EXTCDE ( 20 ) + END IF + end if #else - IF (TIME(1).NE.TTIME(1) .OR. TIME(2).NE.TTIME(2)) THEN - IF ( IAPROC .EQ. NAPERR ) & - WRITE (NDSE,906) TTIME, TIME - CALL EXTCDE ( 20 ) - END IF + IF (TIME(1).NE.TTIME(1) .OR. TIME(2).NE.TTIME(2)) THEN + IF ( IAPROC .EQ. NAPERR ) & + WRITE (NDSE,906) TTIME, TIME + CALL EXTCDE ( 20 ) + END IF #endif - END IF -! + END IF + ! #ifdef W3_T - WRITE (NDST,9003) TIME - ELSE - WRITE (NDST,9004) -#endif -! - END IF -! -! Spectra ------------------------------------------------------------ * -! ( Bail out if write for TYPE.EQ.'WIND' ) -! + WRITE (NDST,9003) TIME + ELSE + WRITE (NDST,9004) +#endif + ! + END IF + ! + ! Spectra ------------------------------------------------------------ * + ! ( Bail out if write for TYPE.EQ.'WIND' ) + ! #ifdef W3_DEBUGIO - WRITE(740+IAPROC,*) 'W3IORS, step 6' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'W3IORS, step 6' + FLUSH(740+IAPROC) #endif - IF ( WRITE ) THEN + IF ( WRITE ) THEN #ifdef W3_DEBUGIO - WRITE(740+IAPROC,*) 'W3IORS, Matching WRITE statement' - FLUSH(740+IAPROC) - WRITE(740+IAPROC,*) 'W3IORS, TYPE=', TYPE, ' IOSFLG=', IOSFLG - WRITE(740+IAPROC,*) 'W3IORS, NAPROC=', NAPROC, ' NAPRST=', NAPRST - FLUSH(740+IAPROC) -#endif - IF ( TYPE.EQ.'WIND' .OR. TYPE.EQ.'CALM' ) THEN - IF ( .NOT.IOSFLG .OR. IAPROC.EQ.NAPRST ) THEN - CLOSE ( NDSR ) - END IF + WRITE(740+IAPROC,*) 'W3IORS, Matching WRITE statement' + FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'W3IORS, TYPE=', TYPE, ' IOSFLG=', IOSFLG + WRITE(740+IAPROC,*) 'W3IORS, NAPROC=', NAPROC, ' NAPRST=', NAPRST + FLUSH(740+IAPROC) +#endif + IF ( TYPE.EQ.'WIND' .OR. TYPE.EQ.'CALM' ) THEN + IF ( .NOT.IOSFLG .OR. IAPROC.EQ.NAPRST ) THEN + CLOSE ( NDSR ) + END IF #ifdef W3_T - WRITE (NDST,9005) TYPE -#endif - ! Clean up file handles and allocated arrays - INQUIRE (UNIT=NDSR, OPENED=NDSROPN) - IF (NDSROPN) CLOSE(NDSR) - IF (ALLOCATED(WRITEBUFF)) DEALLOCATE(WRITEBUFF) - IF (ALLOCATED(TMP)) DEALLOCATE(TMP) - IF (ALLOCATED(TMP2)) DEALLOCATE(TMP2) + WRITE (NDST,9005) TYPE +#endif + ! Clean up file handles and allocated arrays + INQUIRE (UNIT=NDSR, OPENED=NDSROPN) + IF (NDSROPN) CLOSE(NDSR) + IF (ALLOCATED(WRITEBUFF)) DEALLOCATE(WRITEBUFF) + IF (ALLOCATED(TMP)) DEALLOCATE(TMP) + IF (ALLOCATED(TMP2)) DEALLOCATE(TMP2) - RETURN - ELSE IF ( IAPROC.LE.NAPROC .OR. IAPROC.EQ. NAPRST ) THEN + RETURN + ELSE IF ( IAPROC.LE.NAPROC .OR. IAPROC.EQ. NAPRST ) THEN #ifdef W3_DEBUGIO - WRITE(740+IAPROC,*) 'W3IORS, Need to match 1' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'W3IORS, Need to match 1' + FLUSH(740+IAPROC) #endif -! -! Original non-server version writing of spectra -! - IF ( .NOT.IOSFLG .OR. (NAPROC.EQ.1.AND.NAPRST.EQ.1) ) THEN + ! + ! Original non-server version writing of spectra + ! + IF ( .NOT.IOSFLG .OR. (NAPROC.EQ.1.AND.NAPRST.EQ.1) ) THEN #ifdef W3_DEBUGIO - WRITE(740+IAPROC,*) 'W3IORS, Need to match 2' - FLUSH(740+IAPROC) -#endif - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - NREC = ISEA + 2 - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITEBUFF(:) = 0. - WRITEBUFF(1:NSPEC) = VA(1:NSPEC,JSEA) - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF - END DO -! -! I/O server version writing of spectra ( !/MPI ) -! + WRITE(740+IAPROC,*) 'W3IORS, Need to match 2' + FLUSH(740+IAPROC) +#endif + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + NREC = ISEA + 2 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITEBUFF(:) = 0. + WRITEBUFF(1:NSPEC) = VA(1:NSPEC,JSEA) + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF + END DO + ! + ! I/O server version writing of spectra ( !/MPI ) + ! #ifdef W3_MPI - ELSE + ELSE #endif -! + ! #ifdef W3_DEBUGIO - WRITE(740+IAPROC,*) 'W3IORS, Before test for UNST_PDLIB_WRITE_TO_FILE' - WRITE(740+IAPROC,*) 'W3IORS, GTPYPE=', GTYPE, ' UNGTYPE=', UNGTYPE - WRITE(740+IAPROC,*) 'W3IORS, PDLIB=', LPDLIB - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'W3IORS, Before test for UNST_PDLIB_WRITE_TO_FILE' + WRITE(740+IAPROC,*) 'W3IORS, GTPYPE=', GTYPE, ' UNGTYPE=', UNGTYPE + WRITE(740+IAPROC,*) 'W3IORS, PDLIB=', LPDLIB + FLUSH(740+IAPROC) #endif #ifdef W3_MPI - IF (LPDLIB .and. (GTYPE.eq.UNGTYPE)) THEN + IF (LPDLIB .and. (GTYPE.eq.UNGTYPE)) THEN #endif #ifdef W3_DEBUGIO - WRITE(740+IAPROC,*) 'W3IORS, Directly before call for UNST_PDLIB_WRITE_TO_FILE, NDSR=', NDSR - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'W3IORS, Directly before call for UNST_PDLIB_WRITE_TO_FILE, NDSR=', NDSR + FLUSH(740+IAPROC) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Before UNST_PDLIB_WRITE_TO_FILE") + CALL PRINT_MY_TIME("Before UNST_PDLIB_WRITE_TO_FILE") #endif #ifdef W3_PDLIB - CALL UNST_PDLIB_WRITE_TO_FILE(NDSR) + CALL UNST_PDLIB_WRITE_TO_FILE(NDSR) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After UNST_PDLIB_WRITE_TO_FILE") + CALL PRINT_MY_TIME("After UNST_PDLIB_WRITE_TO_FILE") #endif #ifdef W3_MPI - ELSE + ELSE #endif #ifdef W3_MPI - IF ( IAPROC .NE. NAPRST ) THEN - NRQ = 1 - ELSE IF ( NAPRST .LE. NAPROC ) THEN - NRQ = NAPROC - 1 - ELSE - NRQ = NAPROC - END IF -#endif -! + IF ( IAPROC .NE. NAPRST ) THEN + NRQ = 1 + ELSE IF ( NAPRST .LE. NAPROC ) THEN + NRQ = NAPROC - 1 + ELSE + NRQ = NAPROC + END IF +#endif + ! #ifdef W3_MPI - ALLOCATE ( STAT1(MPI_STATUS_SIZE,NRQ) ) - IF ( IAPROC .EQ. NAPRST ) CALL MPI_STARTALL & - ( NRQ, IRQRSS, IERR_MPI ) + ALLOCATE ( STAT1(MPI_STATUS_SIZE,NRQ) ) + IF ( IAPROC .EQ. NAPRST ) CALL MPI_STARTALL & + ( NRQ, IRQRSS, IERR_MPI ) #endif -! + ! #ifdef W3_MPI - DO IB=1, NBLKRS - ISEA0 = 1 + (IB-1)*RSBLKS*NAPROC - ISEAN = MIN ( NSEA , IB*RSBLKS*NAPROC ) + DO IB=1, NBLKRS + ISEA0 = 1 + (IB-1)*RSBLKS*NAPROC + ISEAN = MIN ( NSEA , IB*RSBLKS*NAPROC ) #endif -! + ! #ifdef W3_MPI - IF ( IAPROC .EQ. NAPRST ) THEN + IF ( IAPROC .EQ. NAPRST ) THEN #endif -! + ! #ifdef W3_MPI - IH = 1 + NRQ * (IB-1) - CALL MPI_WAITALL & + IH = 1 + NRQ * (IB-1) + CALL MPI_WAITALL & ( NRQ, IRQRSS(IH), STAT1, IERR_MPI ) - IF ( IB .LT. NBLKRS ) THEN - IH = 1 + NRQ * IB - CALL MPI_STARTALL & - ( NRQ, IRQRSS(IH), IERR_MPI ) - END IF + IF ( IB .LT. NBLKRS ) THEN + IH = 1 + NRQ * IB + CALL MPI_STARTALL & + ( NRQ, IRQRSS(IH), IERR_MPI ) + END IF #endif -! + ! #ifdef W3_MPI - DO ISEA=ISEA0, ISEAN - NREC = ISEA + 2 - CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, IP) - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITEBUFF(:) = 0. - IF ( IP .EQ. NAPRST ) THEN - WRITEBUFF(1:NSPEC) = VA(1:NSPEC,JSEA) - ELSE - JSEA = JSEA - 2*((IB-1)/2)*RSBLKS - WRITEBUFF(1:NSPEC) = VAAUX(1:NSPEC,JSEA,IP) - END IF - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - WRITEBUFF - END DO -#endif -! + DO ISEA=ISEA0, ISEAN + NREC = ISEA + 2 + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, IP) + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITEBUFF(:) = 0. + IF ( IP .EQ. NAPRST ) THEN + WRITEBUFF(1:NSPEC) = VA(1:NSPEC,JSEA) + ELSE + JSEA = JSEA - 2*((IB-1)/2)*RSBLKS + WRITEBUFF(1:NSPEC) = VAAUX(1:NSPEC,JSEA,IP) + END IF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + WRITEBUFF + END DO +#endif + ! #ifdef W3_MPI - ELSE + ELSE #endif -! + ! #ifdef W3_MPI - CALL MPI_STARTALL & + CALL MPI_STARTALL & ( 1, IRQRSS(IB), IERR_MPI ) - CALL MPI_WAITALL & + CALL MPI_WAITALL & ( 1, IRQRSS(IB), STAT1, IERR_MPI ) #endif -! + ! #ifdef W3_MPI - END IF - END DO + END IF + END DO #endif -! + ! #ifdef W3_MPI - DEALLOCATE ( STAT1 ) - END IF + DEALLOCATE ( STAT1 ) + END IF #endif -! - END IF -! - END IF - ELSE + ! + END IF + ! + END IF + ELSE #ifdef W3_DEBUGIO - WRITE(740+IAPROC,*) 'W3IORS, step 7' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'W3IORS, step 7' + FLUSH(740+IAPROC) #endif -! -! Reading spectra -! - IF ( TYPE.EQ.'WIND' .OR. TYPE.EQ.'CALM' ) THEN + ! + ! Reading spectra + ! + IF ( TYPE.EQ.'WIND' .OR. TYPE.EQ.'CALM' ) THEN #ifdef W3_T - WRITE (NDST,9020) TYPE + WRITE (NDST,9020) TYPE #endif - ELSE - IF (LPDLIB .and. (GTYPE.eq.UNGTYPE)) THEN + ELSE + IF (LPDLIB .and. (GTYPE.eq.UNGTYPE)) THEN #ifdef W3_PDLIB #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before call to UNST_PDLIB_READ_FROM_FILE' - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) 'Before call to UNST_PDLIB_READ_FROM_FILE' + FLUSH(740+IAPROC) #endif #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Before UNST_PDLIB_READ_FROM_FILE") + CALL PRINT_MY_TIME("Before UNST_PDLIB_READ_FROM_FILE") #endif #ifdef W3_PDLIB - CALL UNST_PDLIB_READ_FROM_FILE(NDSR) + CALL UNST_PDLIB_READ_FROM_FILE(NDSR) #endif #ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After UNST_PDLIB_READ_FROM_FILE") + CALL PRINT_MY_TIME("After UNST_PDLIB_READ_FROM_FILE") #endif #ifdef W3_PDLIB #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) ' After call to UNST_PDLIB_READ_FROM_FILE' - WRITE(740+IAPROC,*) ' min/max(VA)=', minval(VA), maxval(VA) - DO JSEA=1,NSEAL - WRITE(740+IAPROC,*) ' JSEA=', JSEA, ' sum(VA)=', sum(VA(:,JSEA)) - END DO - FLUSH(740+IAPROC) + WRITE(740+IAPROC,*) ' After call to UNST_PDLIB_READ_FROM_FILE' + WRITE(740+IAPROC,*) ' min/max(VA)=', minval(VA), maxval(VA) + DO JSEA=1,NSEAL + WRITE(740+IAPROC,*) ' JSEA=', JSEA, ' sum(VA)=', sum(VA(:,JSEA)) + END DO + FLUSH(740+IAPROC) #endif #endif - ELSE + ELSE #ifdef W3_MPI - NSEAL_MIN = 1 + (NSEA-NAPROC)/NAPROC - IF ( NAPROC.GT.1 ) THEN -!/ ----------- Large number of small-sized record reads will tend ---- * -!/ to perform badly on most file systems. We read this part -!/ using streams and scatter the results using MPI. -!/ ( M. WARD, NCI ) -! -! Begin computational proc. only section ---------------- * - IF ( IAPROC.LE.NAPROC ) THEN -! -! Main loop --------------------------------------------- * - ALLOCATE( VGBUFF( NSIZE * NAPROC ) ) - ALLOCATE( VLBUFF( NSIZE ) ) -! - DO JSEA = 1, NSEAL_MIN -! Read NAPROC records into buffer VGBUFF. ------------- * - IF ( IAPROC .EQ. NAPROC ) THEN - RPOS = 1_8 + (2 + (JSEA - 1_8) * NAPROC) * LRECL - READ(NDSR, POS=RPOS,ERR=802,IOSTAT=IERR) VGBUFF(:) - ELSE - VGBUFF(:) = 0. + NSEAL_MIN = 1 + (NSEA-NAPROC)/NAPROC + IF ( NAPROC.GT.1 ) THEN + !/ ----------- Large number of small-sized record reads will tend ---- * + !/ to perform badly on most file systems. We read this part + !/ using streams and scatter the results using MPI. + !/ ( M. WARD, NCI ) + ! + ! Begin computational proc. only section ---------------- * + IF ( IAPROC.LE.NAPROC ) THEN + ! + ! Main loop --------------------------------------------- * + ALLOCATE( VGBUFF( NSIZE * NAPROC ) ) + ALLOCATE( VLBUFF( NSIZE ) ) + ! + DO JSEA = 1, NSEAL_MIN + ! Read NAPROC records into buffer VGBUFF. ------------- * + IF ( IAPROC .EQ. NAPROC ) THEN + RPOS = 1_8 + (2 + (JSEA - 1_8) * NAPROC) * LRECL + READ(NDSR, POS=RPOS,ERR=802,IOSTAT=IERR) VGBUFF(:) + ELSE + VGBUFF(:) = 0. + END IF + ! Distribute one record to each rank. + CALL MPI_SCATTER(VGBUFF, NSIZE, MPI_REAL, & + VLBUFF, NSIZE, MPI_REAL, & + NAPROC-1, MPI_COMM_WCMP, IERR ) + ! Transfer the spectral content of VLBUFF to VA. ------ * + VA(1:NSPEC,JSEA) = VLBUFF(1:NSPEC) + END DO + ! + ! Include remainder values (switch to record format) ---- * + JSEA = NSEAL_MIN + 1 + IF ( JSEA.EQ.NSEAL ) THEN + ISEA = IAPROC + (JSEA - 1) * NAPROC + NREC = ISEA + 2 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR, POS=RPOS, ERR=802, IOSTAT=IERR) & + (VA(I,JSEA), I=1,NSPEC) END IF -! Distribute one record to each rank. - CALL MPI_SCATTER(VGBUFF, NSIZE, MPI_REAL, & - VLBUFF, NSIZE, MPI_REAL, & - NAPROC-1, MPI_COMM_WCMP, IERR ) -! Transfer the spectral content of VLBUFF to VA. ------ * - VA(1:NSPEC,JSEA) = VLBUFF(1:NSPEC) - END DO -! -! Include remainder values (switch to record format) ---- * - JSEA = NSEAL_MIN + 1 - IF ( JSEA.EQ.NSEAL ) THEN - ISEA = IAPROC + (JSEA - 1) * NAPROC - NREC = ISEA + 2 - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDSR, POS=RPOS, ERR=802, IOSTAT=IERR) & - (VA(I,JSEA), I=1,NSPEC) - END IF -! - DEALLOCATE( VGBUFF ) - DEALLOCATE( VLBUFF ) -! -! End computational proc. only section ------------------ * - END IF -! - ELSE -#endif - VA = 0. - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - NREC = ISEA + 2 - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & - (VA(I,JSEA),I=1,NSPEC) + ! + DEALLOCATE( VGBUFF ) + DEALLOCATE( VLBUFF ) + ! + ! End computational proc. only section ------------------ * + END IF + ! + ELSE +#endif + VA = 0. + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + NREC = ISEA + 2 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & + (VA(I,JSEA),I=1,NSPEC) ENDDO #ifdef W3_MPI - END IF + END IF #endif - END IF END IF - END IF + END IF + END IF - VA = MAX(0.,VA) -! + VA = MAX(0.,VA) + ! #ifdef W3_T - WRITE (NDST,9006) -#endif -! -! Water level etc. if required --------------------------------------- * -! ( For cold start write test output and cold start initialize -! water levels. Note that MAPSTA overwrites the one read from the -! model definition file, so that it need not be initialized. ) -! - NREC = NSEA + 3 - NPART = 1 + (NSEA-1)/NSIZE - NPRTX2 = 1 + (NX-1)/NSIZE - NPRTY2 = 1 + (NY-1)/NSIZE -! + WRITE (NDST,9006) +#endif + ! + ! Water level etc. if required --------------------------------------- * + ! ( For cold start write test output and cold start initialize + ! water levels. Note that MAPSTA overwrites the one read from the + ! model definition file, so that it need not be initialized. ) + ! + NREC = NSEA + 3 + NPART = 1 + (NSEA-1)/NSIZE + NPRTX2 = 1 + (NX-1)/NSIZE + NPRTY2 = 1 + (NY-1)/NSIZE + ! #ifdef W3_DEBUGIO - WRITE(740+IAPROC,*) 'W3IORS, step 8' - FLUSH(740+IAPROC) -#endif - IF ( WRITE ) THEN -! - IF (TYPE.EQ.'FULL') THEN -! - IF ( IAPROC .EQ. NAPRST ) THEN -! + WRITE(740+IAPROC,*) 'W3IORS, step 8' + FLUSH(740+IAPROC) +#endif + IF ( WRITE ) THEN + ! + IF (TYPE.EQ.'FULL') THEN + ! + IF ( IAPROC .EQ. NAPRST ) THEN + ! #ifdef W3_MPI - ALLOCATE ( STAT2(MPI_STATUS_SIZE,NRQRS) ) - CALL MPI_WAITALL & - ( NRQRS, IRQRS , STAT2, IERR_MPI ) - DEALLOCATE ( STAT2 ) -#endif -! - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITEBUFF(:) = 0. - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - TLEV, TICE, TRHO - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - (WLV(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - (ICE(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO + ALLOCATE ( STAT2(MPI_STATUS_SIZE,NRQRS) ) + CALL MPI_WAITALL & + ( NRQRS, IRQRS , STAT2, IERR_MPI ) + DEALLOCATE ( STAT2 ) +#endif + ! + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITEBUFF(:) = 0. + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + TLEV, TICE, TRHO + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + (WLV(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + (ICE(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO #ifdef W3_WRST - ! The WRST switch saves the values of wind in the - ! restart file and then uses the wind for the first - ! time step here. This is needed when coupling with - ! an atm model that does not have 10m wind speeds at - ! initialization. If there is no restart, wind is zero + ! The WRST switch saves the values of wind in the + ! restart file and then uses the wind for the first + ! time step here. This is needed when coupling with + ! an atm model that does not have 10m wind speeds at + ! initialization. If there is no restart, wind is zero #endif #ifdef W3_WRST - DO IX=1, NX - DO IPART=1,NPRTY2 - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - (WXN(IX,IYL),IYL=1+(IPART-1)*NSIZE, & - MIN(NY,IPART*NSIZE)) - END DO - END DO - DO IX=1, NX - DO IPART=1,NPRTY2 - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - (WYN(IX,IYL),IYL=1+(IPART-1)*NSIZE, & - MIN(NY,IPART*NSIZE)) - END DO - END DO -#endif - ALLOCATE ( MAPTMP(NY,NX) ) - MAPTMP = MAPSTA + 8*MAPST2 - DO IY=1, NY - DO IPART=1,NPRTX2 - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - WRITEBUFF - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - (MAPTMP(IY,IXL),IXL=1+(IPART-1)*NSIZE, & - MIN(NX,IPART*NSIZE)) - END DO - END DO - DEALLOCATE ( MAPTMP ) - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - (UST(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - (USTDIR(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - (ASF(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF - WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & - (FPIS(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO - IF (OARST) THEN -#ifdef W3_MPI - CALL W3XETA ( IGRD, NDSE, NDST ) -#endif -! - IF ( FLOGRR(1,2) ) THEN - WRITE(NDSR,ERR=803,IOSTAT=IERR) CX(1:NSEA) - WRITE(NDSR,ERR=803,IOSTAT=IERR) CY(1:NSEA) - ENDIF - IF ( FLOGRR(1,12) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) ICEF(1:NSEA) - IF ( FLOGRR(2,1) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) HS(1:NSEA) - IF ( FLOGRR(2,2) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) WLM(1:NSEA) - IF ( FLOGRR(2,4) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) T0M1(1:NSEA) - IF ( FLOGRR(2,5) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) T01(1:NSEA) - IF ( FLOGRR(2,6) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) FP0(1:NSEA) - IF ( FLOGRR(2,7) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) THM(1:NSEA) - IF ( FLOGRR(2,19) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) WNMEAN(1:NSEA) - IF ( FLOGRR(5,2) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) CHARN(1:NSEA) - IF ( FLOGRR(5,5) ) THEN - WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUWIX(1:NSEA) - WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUWIY(1:NSEA) - ENDIF - IF ( FLOGRR(5,11) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) TWS(1:NSEA) - IF ( FLOGRR(6,2) ) THEN - WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUOX(1:NSEA) - WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUOY(1:NSEA) - ENDIF - IF ( FLOGRR(6,3) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) BHD(1:NSEA) - IF ( FLOGRR(6,4) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) PHIOC(1:NSEA) - IF ( FLOGRR(6,5) ) THEN - WRITE(NDSR,ERR=803,IOSTAT=IERR) TUSX(1:NSEA) - WRITE(NDSR,ERR=803,IOSTAT=IERR) TUSY(1:NSEA) - ENDIF - IF ( FLOGRR(6,6) ) THEN - WRITE(NDSR,ERR=803,IOSTAT=IERR) USSX(1:NSEA) - WRITE(NDSR,ERR=803,IOSTAT=IERR) USSY(1:NSEA) - ENDIF - IF ( FLOGRR(6,10) ) THEN - WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUICE(1:NSEA,1) - WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUICE(1:NSEA,2) - ENDIF - IF ( FLOGRR(6,13) ) THEN - WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUOCX(1:NSEA) - WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUOCY(1:NSEA) - ENDIF - IF ( FLOGRR(7,2) ) THEN - WRITE(NDSR,ERR=803,IOSTAT=IERR) UBA(1:NSEA) - WRITE(NDSR,ERR=803,IOSTAT=IERR) UBD(1:NSEA) - ENDIF - IF ( FLOGRR(7,4) ) & - WRITE(NDSR,ERR=803,IOSTAT=IERR) PHIBBL(1:NSEA) - IF ( FLOGRR(7,5) ) THEN - WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUBBL(1:NSEA,1) - WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUBBL(1:NSEA,2) - ENDIF -! + DO IX=1, NX + DO IPART=1,NPRTY2 + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + (WXN(IX,IYL),IYL=1+(IPART-1)*NSIZE, & + MIN(NY,IPART*NSIZE)) + END DO + END DO + DO IX=1, NX + DO IPART=1,NPRTY2 + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + (WYN(IX,IYL),IYL=1+(IPART-1)*NSIZE, & + MIN(NY,IPART*NSIZE)) + END DO + END DO +#endif + ALLOCATE ( MAPTMP(NY,NX) ) + MAPTMP = MAPSTA + 8*MAPST2 + DO IY=1, NY + DO IPART=1,NPRTX2 + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + WRITEBUFF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + (MAPTMP(IY,IXL),IXL=1+(IPART-1)*NSIZE, & + MIN(NX,IPART*NSIZE)) + END DO + END DO + DEALLOCATE ( MAPTMP ) + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + (UST(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + (USTDIR(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + (ASF(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) WRITEBUFF + WRITE (NDSR,POS=RPOS,ERR=803,IOSTAT=IERR) & + (FPIS(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO + IF (OARST) THEN #ifdef W3_MPI - CALL W3SETA ( IGRD, NDSE, NDST ) + CALL W3XETA ( IGRD, NDSE, NDST ) #endif + ! + IF ( FLOGRR(1,2) ) THEN + WRITE(NDSR,ERR=803,IOSTAT=IERR) CX(1:NSEA) + WRITE(NDSR,ERR=803,IOSTAT=IERR) CY(1:NSEA) + ENDIF + IF ( FLOGRR(1,12) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) ICEF(1:NSEA) + IF ( FLOGRR(2,1) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) HS(1:NSEA) + IF ( FLOGRR(2,2) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) WLM(1:NSEA) + IF ( FLOGRR(2,4) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) T0M1(1:NSEA) + IF ( FLOGRR(2,5) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) T01(1:NSEA) + IF ( FLOGRR(2,6) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) FP0(1:NSEA) + IF ( FLOGRR(2,7) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) THM(1:NSEA) + IF ( FLOGRR(2,19) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) WNMEAN(1:NSEA) + IF ( FLOGRR(5,2) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) CHARN(1:NSEA) + IF ( FLOGRR(5,5) ) THEN + WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUWIX(1:NSEA) + WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUWIY(1:NSEA) + ENDIF + IF ( FLOGRR(5,11) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) TWS(1:NSEA) + IF ( FLOGRR(6,2) ) THEN + WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUOX(1:NSEA) + WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUOY(1:NSEA) + ENDIF + IF ( FLOGRR(6,3) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) BHD(1:NSEA) + IF ( FLOGRR(6,4) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) PHIOC(1:NSEA) + IF ( FLOGRR(6,5) ) THEN + WRITE(NDSR,ERR=803,IOSTAT=IERR) TUSX(1:NSEA) + WRITE(NDSR,ERR=803,IOSTAT=IERR) TUSY(1:NSEA) + ENDIF + IF ( FLOGRR(6,6) ) THEN + WRITE(NDSR,ERR=803,IOSTAT=IERR) USSX(1:NSEA) + WRITE(NDSR,ERR=803,IOSTAT=IERR) USSY(1:NSEA) + ENDIF + IF ( FLOGRR(6,10) ) THEN + WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUICE(1:NSEA,1) + WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUICE(1:NSEA,2) + ENDIF + IF ( FLOGRR(6,13) ) THEN + WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUOCX(1:NSEA) + WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUOCY(1:NSEA) + ENDIF + IF ( FLOGRR(7,2) ) THEN + WRITE(NDSR,ERR=803,IOSTAT=IERR) UBA(1:NSEA) + WRITE(NDSR,ERR=803,IOSTAT=IERR) UBD(1:NSEA) ENDIF + IF ( FLOGRR(7,4) ) & + WRITE(NDSR,ERR=803,IOSTAT=IERR) PHIBBL(1:NSEA) + IF ( FLOGRR(7,5) ) THEN + WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUBBL(1:NSEA,1) + WRITE(NDSR,ERR=803,IOSTAT=IERR) TAUBBL(1:NSEA,2) + ENDIF + ! +#ifdef W3_MPI + CALL W3SETA ( IGRD, NDSE, NDST ) +#endif + ENDIF #ifdef W3_T - WRITE (NDST,9007) - ELSE - DO ISEA=1, NSEA - WLV(ISEA) = 0. - ICE(ISEA) = 0. - END DO - WRITE (NDST,9008) + WRITE (NDST,9007) + ELSE + DO ISEA=1, NSEA + WLV(ISEA) = 0. + ICE(ISEA) = 0. + END DO + WRITE (NDST,9008) #endif - END IF END IF - ELSE - IF (TYPE.EQ.'FULL') THEN - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & - TLEV, TICE, TRHO + END IF + ELSE + IF (TYPE.EQ.'FULL') THEN + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & + TLEV, TICE, TRHO #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading WLV' -#endif - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & - (WLV(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO + WRITE(740+IAPROC,*) 'Before reading WLV' +#endif + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & + (WLV(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading ICE' -#endif - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & - (ICE(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO + WRITE(740+IAPROC,*) 'Before reading ICE' +#endif + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & + (ICE(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO #ifdef W3_WRST - DO IX=1, NX - DO IPART=1,NPRTY2 + DO IX=1, NX + DO IPART=1,NPRTY2 NREC = NREC + 1 RPOS = 1_8 + LRECL*(NREC-1_8) READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & - (WXNwrst(IX,IYL),IYL=1+(IPART-1)*NSIZE, & - MIN(NY,IPART*NSIZE)) - END DO - END DO - DO IX=1, NX - DO IPART=1,NPRTY2 + (WXNwrst(IX,IYL),IYL=1+(IPART-1)*NSIZE, & + MIN(NY,IPART*NSIZE)) + END DO + END DO + DO IX=1, NX + DO IPART=1,NPRTY2 NREC = NREC + 1 RPOS = 1_8 + LRECL*(NREC-1_8) READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & - (WYNwrst(IX,IYL),IYL=1+(IPART-1)*NSIZE, & - MIN(NY,IPART*NSIZE)) - END DO - END DO + (WYNwrst(IX,IYL),IYL=1+(IPART-1)*NSIZE, & + MIN(NY,IPART*NSIZE)) + END DO + END DO #endif - ALLOCATE ( MAPTMP(NY,NX) ) + ALLOCATE ( MAPTMP(NY,NX) ) #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading MAPTMP' + WRITE(740+IAPROC,*) 'Before reading MAPTMP' #endif - DO IY=1, NY - DO IPART=1,NPRTX2 - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & - (MAPTMP(IY,IXL),IXL=1+(IPART-1)*NSIZE, & - MIN(NX,IPART*NSIZE)) - END DO - END DO - MAPSTA = MOD(MAPTMP+2,8) - 2 - MAPST2 = (MAPTMP-MAPSTA) / 8 - DEALLOCATE ( MAPTMP ) -! -! Updates reflections maps: -! - IF (GTYPE.EQ.UNGTYPE) THEN -!AR: not needed since already initialized on w3iogr CALL SET_UG_IOBP + DO IY=1, NY + DO IPART=1,NPRTX2 + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & + (MAPTMP(IY,IXL),IXL=1+(IPART-1)*NSIZE, & + MIN(NX,IPART*NSIZE)) + END DO + END DO + MAPSTA = MOD(MAPTMP+2,8) - 2 + MAPST2 = (MAPTMP-MAPSTA) / 8 + DEALLOCATE ( MAPTMP ) + ! + ! Updates reflections maps: + ! + IF (GTYPE.EQ.UNGTYPE) THEN + !AR: not needed since already initialized on w3iogr CALL SET_UG_IOBP #ifdef W3_REF1 - ELSE - CALL W3SETREF + ELSE + CALL W3SETREF #endif - ENDIF -! + ENDIF + ! #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading UST' -#endif - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & - (UST(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO + WRITE(740+IAPROC,*) 'Before reading UST' +#endif + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & + (UST(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading USTDIR' -#endif - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & - (USTDIR(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO + WRITE(740+IAPROC,*) 'Before reading USTDIR' +#endif + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & + (USTDIR(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading ASF' -#endif - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & - (ASF(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO + WRITE(740+IAPROC,*) 'Before reading ASF' +#endif + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & + (ASF(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading FPIS' -#endif - DO IPART=1,NPART - NREC = NREC + 1 - RPOS = 1_8 + LRECL*(NREC-1_8) - READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & - (FPIS(ISEA),ISEA=1+(IPART-1)*NSIZE, & - MIN(NSEA,IPART*NSIZE)) - END DO - IF (OARST) THEN + WRITE(740+IAPROC,*) 'Before reading FPIS' +#endif + DO IPART=1,NPART + NREC = NREC + 1 + RPOS = 1_8 + LRECL*(NREC-1_8) + READ (NDSR,POS=RPOS,ERR=802,IOSTAT=IERR) & + (FPIS(ISEA),ISEA=1+(IPART-1)*NSIZE, & + MIN(NSEA,IPART*NSIZE)) + END DO + IF (OARST) THEN #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading CUR' + WRITE(740+IAPROC,*) 'Before reading CUR' #endif - IF ( FLOGOA(1,2) ) THEN + IF ( FLOGOA(1,2) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) CX(1:NSEA) READ (NDSR,ERR=802,IOSTAT=IERR) CY(1:NSEA) - ENDIF + ENDIF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading ICEF' + WRITE(740+IAPROC,*) 'Before reading ICEF' #endif - IF ( FLOGOA(1,12) ) THEN + IF ( FLOGOA(1,12) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) ICEF(1:NSEA) - ENDIF + ENDIF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading HS' + WRITE(740+IAPROC,*) 'Before reading HS' #endif - IF ( FLOGOA(2,1) ) THEN + IF ( FLOGOA(2,1) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) HS(I) = TMP(J) + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) HS(I) = TMP(J) ENDDO - ENDIF + ENDIF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading WLM' + WRITE(740+IAPROC,*) 'Before reading WLM' #endif - IF ( FLOGOA(2,2) ) THEN + IF ( FLOGOA(2,2) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) WLM(I) = TMP(J) + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) WLM(I) = TMP(J) ENDDO - ENDIF + ENDIF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading T0M1' + WRITE(740+IAPROC,*) 'Before reading T0M1' #endif - IF ( FLOGOA(2,4) ) THEN + IF ( FLOGOA(2,4) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) T0M1(I) = TMP(J) + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) T0M1(I) = TMP(J) ENDDO - ENDIF + ENDIF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading T01' + WRITE(740+IAPROC,*) 'Before reading T01' #endif - IF ( FLOGOA(2,5) ) THEN + IF ( FLOGOA(2,5) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) T01(I) = TMP(J) + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) T01(I) = TMP(J) ENDDO - ENDIF + ENDIF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading FP0' + WRITE(740+IAPROC,*) 'Before reading FP0' #endif - IF ( FLOGOA(2,6) ) THEN + IF ( FLOGOA(2,6) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) FP0(I) = TMP(J) + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) FP0(I) = TMP(J) ENDDO - ENDIF + ENDIF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading THM' + WRITE(740+IAPROC,*) 'Before reading THM' #endif - IF ( FLOGOA(2,7) ) THEN + IF ( FLOGOA(2,7) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) THM(I) = TMP(J) + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) THM(I) = TMP(J) ENDDO - ENDIF + ENDIF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading WNMEAN' + WRITE(740+IAPROC,*) 'Before reading WNMEAN' #endif - IF ( FLOGOA(2,19) ) THEN + IF ( FLOGOA(2,19) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) WNMEAN(I) = TMP(J) + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) WNMEAN(I) = TMP(J) ENDDO - ENDIF + ENDIF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading CHARN' + WRITE(740+IAPROC,*) 'Before reading CHARN' #endif - IF ( FLOGOA(5,2) ) THEN + IF ( FLOGOA(5,2) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) CHARN(I) = TMP(J) + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) CHARN(I) = TMP(J) ENDDO - ENDIF + ENDIF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading TAUWI' + WRITE(740+IAPROC,*) 'Before reading TAUWI' #endif - IF ( FLOGOA(5,5) ) THEN + IF ( FLOGOA(5,5) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) THEN - TAUWIX(I) = TMP(J) - TAUWIY(I) = TMP2(J) - ENDIF + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) THEN + TAUWIX(I) = TMP(J) + TAUWIY(I) = TMP2(J) + ENDIF ENDDO - ENDIF + ENDIF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading TWS' + WRITE(740+IAPROC,*) 'Before reading TWS' #endif - IF ( FLOGOA(5,11) ) THEN + IF ( FLOGOA(5,11) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) TWS(I) = TMP(J) + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) TWS(I) = TMP(J) ENDDO - ENDIF + ENDIF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading TAUO' + WRITE(740+IAPROC,*) 'Before reading TAUO' #endif - IF ( FLOGOA(6,2) ) THEN + IF ( FLOGOA(6,2) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) THEN - TAUOX(I) = TMP(J) - TAUOY(I) = TMP2(J) - ENDIF + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) THEN + TAUOX(I) = TMP(J) + TAUOY(I) = TMP2(J) + ENDIF ENDDO - ENDIF + ENDIF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading BHD' + WRITE(740+IAPROC,*) 'Before reading BHD' #endif - IF ( FLOGOA(6,3) ) THEN + IF ( FLOGOA(6,3) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) BHD(I) = TMP(J) + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) BHD(I) = TMP(J) ENDDO - ENDIF + ENDIF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading PHIOC' + WRITE(740+IAPROC,*) 'Before reading PHIOC' #endif - IF ( FLOGOA(6,4) ) THEN + IF ( FLOGOA(6,4) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) PHIOC(I) = TMP(J) + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) PHIOC(I) = TMP(J) ENDDO - ENDIF + ENDIF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading TUS' + WRITE(740+IAPROC,*) 'Before reading TUS' #endif - IF ( FLOGOA(6,5) ) THEN + IF ( FLOGOA(6,5) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) THEN - TUSX(I) = TMP(J) - TUSY(I) = TMP2(J) - ENDIF + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) THEN + TUSX(I) = TMP(J) + TUSY(I) = TMP2(J) + ENDIF ENDDO - ENDIF + ENDIF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading USS' + WRITE(740+IAPROC,*) 'Before reading USS' #endif - IF ( FLOGOA(6,6) ) THEN + IF ( FLOGOA(6,6) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) THEN - USSX(I) = TMP(J) - USSY(I) = TMP2(J) - ENDIF + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) THEN + USSX(I) = TMP(J) + USSY(I) = TMP2(J) + ENDIF ENDDO - ENDIF + ENDIF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading TAUICE' + WRITE(740+IAPROC,*) 'Before reading TAUICE' #endif - IF ( FLOGOA(6,10) ) THEN + IF ( FLOGOA(6,10) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) THEN - TAUICE(I,1) = TMP(J) - TAUICE(I,2) = TMP2(J) - ENDIF + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) THEN + TAUICE(I,1) = TMP(J) + TAUICE(I,2) = TMP2(J) + ENDIF ENDDO - ENDIF + ENDIF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading TAUOC' + WRITE(740+IAPROC,*) 'Before reading TAUOC' #endif - IF ( FLOGOA(6,13) ) THEN + IF ( FLOGOA(6,13) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) THEN - TAUOCX(I) = TMP(J) - TAUOCY(I) = TMP2(J) - ENDIF + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) THEN + TAUOCX(I) = TMP(J) + TAUOCY(I) = TMP2(J) + ENDIF ENDDO - ENDIF + ENDIF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading UB' + WRITE(740+IAPROC,*) 'Before reading UB' #endif - IF ( FLOGOA(7,2) ) THEN + IF ( FLOGOA(7,2) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) THEN - UBA(I) = TMP(J) - UBD(I) = TMP2(J) - ENDIF + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) THEN + UBA(I) = TMP(J) + UBD(I) = TMP2(J) + ENDIF ENDDO - ENDIF + ENDIF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading PHIBBL' + WRITE(740+IAPROC,*) 'Before reading PHIBBL' #endif - IF ( FLOGOA(7,4) ) THEN + IF ( FLOGOA(7,4) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) PHIBBL(I) = TMP(J) + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) PHIBBL(I) = TMP(J) ENDDO - ENDIF + ENDIF #ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'Before reading TAUBBL' + WRITE(740+IAPROC,*) 'Before reading TAUBBL' #endif - IF ( FLOGOA(7,5) ) THEN + IF ( FLOGOA(7,5) ) THEN READ (NDSR,ERR=802,IOSTAT=IERR) TMP(1:NSEA) READ (NDSR,ERR=802,IOSTAT=IERR) TMP2(1:NSEA) DO I=1, NSEALM - J = IAPROC + (I-1)*NAPROC - IF (J .LE. NSEA) THEN - TAUBBL(I,1) = TMP(J) - TAUBBL(I,2) = TMP2(J) - ENDIF + J = IAPROC + (I-1)*NAPROC + IF (J .LE. NSEA) THEN + TAUBBL(I,1) = TMP(J) + TAUBBL(I,2) = TMP2(J) + ENDIF ENDDO - ENDIF - ENDIF + ENDIF + ENDIF #ifdef W3_T - WRITE (NDST,9007) -#endif - ELSE - TLEV(1) = -1 - TLEV(2) = 0 - TICE(1) = -1 - TICE(2) = 0 - TRHO(1) = -1 - TIC1(1) = -1 - TIC1(2) = 0 - TIC5(1) = -1 - TIC5(2) = 0 + WRITE (NDST,9007) +#endif + ELSE + TLEV(1) = -1 + TLEV(2) = 0 + TICE(1) = -1 + TICE(2) = 0 + TRHO(1) = -1 + TIC1(1) = -1 + TIC1(2) = 0 + TIC5(1) = -1 + TIC5(2) = 0 #ifdef W3_WRST - WXNwrst = 0. - WYNwrst = 0. + WXNwrst = 0. + WYNwrst = 0. #endif - WLV = 0. - ICE = 0. - ASF = 1. - FPIS = DUMFPI + WLV = 0. + ICE = 0. + ASF = 1. + FPIS = DUMFPI - ! Initialize coupled fields if no restart is present - IF (OARST) THEN - CX = 0. - CY = 0. - ICEF = 0. - HS = 0. - WLM = 0. - T0M1 = 0. - T01 = 0. - FP0 = 1. - THM = 0. - WNMEAN = 0. - CHARN = 0.0185 - TAUWIX = 0. - TAUWIY = 0. - TWS = 0. - TAUOX = 0. - TAUOY = 0. - BHD = 0. - PHIOC = 0. - TUSX = 0. - TUSY = 0. - USSX = 0. - USSY = 0. - TAUOCX = 0. - TAUOCY = 0. - TAUICE = 0. - UBA = 0. - UBD = 0. - PHIBBL = 0. - TAUBBL = 0. - ENDIF + ! Initialize coupled fields if no restart is present + IF (OARST) THEN + CX = 0. + CY = 0. + ICEF = 0. + HS = 0. + WLM = 0. + T0M1 = 0. + T01 = 0. + FP0 = 1. + THM = 0. + WNMEAN = 0. + CHARN = 0.0185 + TAUWIX = 0. + TAUWIY = 0. + TWS = 0. + TAUOX = 0. + TAUOY = 0. + BHD = 0. + PHIOC = 0. + TUSX = 0. + TUSY = 0. + USSX = 0. + USSY = 0. + TAUOCX = 0. + TAUOCY = 0. + TAUICE = 0. + UBA = 0. + UBD = 0. + PHIBBL = 0. + TAUBBL = 0. + ENDIF #ifdef W3_T - WRITE (NDST,9008) + WRITE (NDST,9008) #endif - END IF - END IF -! -! Close file --------------------------------------------------------- * -! - IF (WRITE) THEN - IF ( .NOT.IOSFLG .OR. IAPROC.EQ.NAPRST ) THEN - CLOSE ( NDSR ) - END IF - ELSE - CLOSE ( NDSR ) - END IF -! + END IF + END IF + ! + ! Close file --------------------------------------------------------- * + ! + IF (WRITE) THEN + IF ( .NOT.IOSFLG .OR. IAPROC.EQ.NAPRST ) THEN + CLOSE ( NDSR ) + END IF + ELSE + CLOSE ( NDSR ) + END IF + ! #ifdef W3_DEBUGIO - WRITE(740+IAPROC,*) 'W3IORS, step 9' - FLUSH(740+IAPROC) -#endif -! - IF (ALLOCATED(WRITEBUFF)) DEALLOCATE(WRITEBUFF) - IF (ALLOCATED(TMP)) DEALLOCATE(TMP) - IF (ALLOCATED(TMP2)) DEALLOCATE(TMP2) -! - RETURN -! -! Escape locations read errors : -! - 800 CONTINUE + WRITE(740+IAPROC,*) 'W3IORS, step 9' + FLUSH(740+IAPROC) +#endif + ! + IF (ALLOCATED(WRITEBUFF)) DEALLOCATE(WRITEBUFF) + IF (ALLOCATED(TMP)) DEALLOCATE(TMP) + IF (ALLOCATED(TMP2)) DEALLOCATE(TMP2) + ! + RETURN + ! + ! Escape locations read errors : + ! +800 CONTINUE #ifdef W3_LN0 - TYPE = 'WIND' - RSTYPE = 1 + TYPE = 'WIND' + RSTYPE = 1 #endif #ifdef W3_SEED - TYPE = 'CALM' - RSTYPE = 4 + TYPE = 'CALM' + RSTYPE = 4 #endif #ifdef W3_LN1 - TYPE = 'CALM' - RSTYPE = 4 -#endif - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,990) TYPE, IERR - GOTO 100 -! - 801 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,991) - CALL EXTCDE ( 30 ) -! - 802 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,992) IERR - CALL EXTCDE ( 31 ) -! - 803 CONTINUE - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,993) IERR, RPOS - CALL EXTCDE ( 31 ) -! -! -! Formats -! - 900 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & - ' ILLEGAL INXOUT VALUE: ',A/) - 901 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & - ' ILLEGAL IDSTR, READ : ',A/ & - ' CHECK : ',A/) - 902 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & - ' ILLEGAL VERINI, READ : ',A/ & - ' CHECK : ',A/) - 903 FORMAT (/' *** WAVEWATCH III WARNING IN W3IORS :'/ & - ' ILLEGAL GNAME, READ : ',A/ & - ' CHECK : ',A/) - 904 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & - ' ILLEGAL TYPE : ',A/) - 905 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & - ' CONFLICTING NSPEC, NSEA GRID : ',2I8/ & - ' EXPECTED : ',2I8/) - 906 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & - ' CONFLICTING TIMES: FILE : ',I10.8,I8.6/ & - ' MODEL : ',I10.8,I8.6/) -! - 990 FORMAT (/' *** WAVEWATCH III WARNING IN W3IORS : '/ & - ' NO READABLE RESTART FILE, ', & - 'INITIALIZE WITH ''',A,''' INSTEAD'/ & - ' IOSTAT =',I5/) - 991 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS : '/ & - ' PREMATURE END OF FILE'/) - 992 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS : '/ & - ' ERROR IN READING FROM FILE'/ & - ' IOSTAT =',I5/) - 993 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS : '/ & - ' ERROR IN WRITING TO FILE'/ & - ' IOSTAT =',I5,', POS =',I11 /) - 1000 FORMAT (/' *** WAVEWATCH III WARNING IN W3IORS : '/ & - ' REQUESTED EXTRA RESTART GROUP',I2,' FIELD',I2, / & - ' IS NOT PRESENT IN THE RESTART FILE.'/ & - ' THIS MAY CAUSE INSTABILITIES IN COUPLED CONFIGURATIONS') -! -! + TYPE = 'CALM' + RSTYPE = 4 +#endif + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,990) TYPE, IERR + GOTO 100 + ! +801 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,991) + CALL EXTCDE ( 30 ) + ! +802 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,992) IERR + CALL EXTCDE ( 31 ) + ! +803 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,993) IERR, RPOS + CALL EXTCDE ( 31 ) + ! + ! + ! Formats + ! +900 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & + ' ILLEGAL INXOUT VALUE: ',A/) +901 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & + ' ILLEGAL IDSTR, READ : ',A/ & + ' CHECK : ',A/) +902 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & + ' ILLEGAL VERINI, READ : ',A/ & + ' CHECK : ',A/) +903 FORMAT (/' *** WAVEWATCH III WARNING IN W3IORS :'/ & + ' ILLEGAL GNAME, READ : ',A/ & + ' CHECK : ',A/) +904 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & + ' ILLEGAL TYPE : ',A/) +905 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & + ' CONFLICTING NSPEC, NSEA GRID : ',2I8/ & + ' EXPECTED : ',2I8/) +906 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS :'/ & + ' CONFLICTING TIMES: FILE : ',I10.8,I8.6/ & + ' MODEL : ',I10.8,I8.6/) + ! +990 FORMAT (/' *** WAVEWATCH III WARNING IN W3IORS : '/ & + ' NO READABLE RESTART FILE, ', & + 'INITIALIZE WITH ''',A,''' INSTEAD'/ & + ' IOSTAT =',I5/) +991 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS : '/ & + ' PREMATURE END OF FILE'/) +992 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS : '/ & + ' ERROR IN READING FROM FILE'/ & + ' IOSTAT =',I5/) +993 FORMAT (/' *** WAVEWATCH III ERROR IN W3IORS : '/ & + ' ERROR IN WRITING TO FILE'/ & + ' IOSTAT =',I5,', POS =',I11 /) +1000 FORMAT (/' *** WAVEWATCH III WARNING IN W3IORS : '/ & + ' REQUESTED EXTRA RESTART GROUP',I2,' FIELD',I2, / & + ' IS NOT PRESENT IN THE RESTART FILE.'/ & + ' THIS MAY CAUSE INSTABILITIES IN COUPLED CONFIGURATIONS') + ! + ! #ifdef W3_T - 9000 FORMAT (' TEST W3IORS : TEST PARAMETERS :'/ & - ' INXOUT : ',A,/ & - ' WRITE : ',L10/ & - ' NTPROC : ',I10/ & - ' NAPROC : ',I10/ & - ' IAPROC : ',I10/ & - ' NAPRST : ',I10) - 9001 FORMAT (' FNAME : ',A/ & - ' LRECL : ',I10) - 9002 FORMAT (' IDSTR : ',A/ & - ' VERINI : ',A/ & - ' GNAME : ',A/ & - ' TYPE : ',A/ & - ' NSEA : ',I10/ & - ' NSEAL : ',I10/ & - ' NSPEC : ',I10) - 9003 FORMAT (' TEST W3IORS :',I10.8,I8.6,' UTC') - 9004 FORMAT (' TEST W3IORS : TIME NOT AVAILABLE ') - 9005 FORMAT (' TEST W3IORS : NO SPECTRA, TYPE=''',A,''' ') - 9006 FORMAT (' TEST W3IORS : SPECTRA PROCESSED ') - 9007 FORMAT (' TEST W3IORS : WATER LEVELS ETC. PROCESSED ') - 9008 FORMAT (' TEST W3IORS : WATER LEVELS ETC. PROCESSED (DUMMY)') -#endif -! +9000 FORMAT (' TEST W3IORS : TEST PARAMETERS :'/ & + ' INXOUT : ',A,/ & + ' WRITE : ',L10/ & + ' NTPROC : ',I10/ & + ' NAPROC : ',I10/ & + ' IAPROC : ',I10/ & + ' NAPRST : ',I10) +9001 FORMAT (' FNAME : ',A/ & + ' LRECL : ',I10) +9002 FORMAT (' IDSTR : ',A/ & + ' VERINI : ',A/ & + ' GNAME : ',A/ & + ' TYPE : ',A/ & + ' NSEA : ',I10/ & + ' NSEAL : ',I10/ & + ' NSPEC : ',I10) +9003 FORMAT (' TEST W3IORS :',I10.8,I8.6,' UTC') +9004 FORMAT (' TEST W3IORS : TIME NOT AVAILABLE ') +9005 FORMAT (' TEST W3IORS : NO SPECTRA, TYPE=''',A,''' ') +9006 FORMAT (' TEST W3IORS : SPECTRA PROCESSED ') +9007 FORMAT (' TEST W3IORS : WATER LEVELS ETC. PROCESSED ') +9008 FORMAT (' TEST W3IORS : WATER LEVELS ETC. PROCESSED (DUMMY)') +#endif + ! #ifdef W3_T - 9020 FORMAT (' TEST W3IORS : RSTYPE = ',A,', PERFORMED BY W3INIT') -#endif -!/ -!/ 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 -------------------------------------------- / -!/ - END MODULE W3IORSMD +9020 FORMAT (' TEST W3IORS : RSTYPE = ',A,', PERFORMED BY W3INIT') +#endif + !/ + !/ End of W3IORS ----------------------------------------------------- / + !/ + END SUBROUTINE W3IORS + !/ + !/ End of module W3IORSMD -------------------------------------------- / + !/ +END MODULE W3IORSMD diff --git a/model/src/w3iosfmd.F90 b/model/src/w3iosfmd.F90 index aee751311e..8413541ded 100644 --- a/model/src/w3iosfmd.F90 +++ b/model/src/w3iosfmd.F90 @@ -698,37 +698,26 @@ SUBROUTINE W3IOSF ( NDSPT, IMOD ) ! 910 FORMAT (A,1X,A) 911 FORMAT (A) -! 940 FORMAT (1X,I8.8,1X,I6.6,2F8.3,2X,'''',A10,'''', & 1X,I2,F7.1,F5.1,f6.1,F5.2,F6.1) 941 FORMAT (1X,I8.8,1X,I6.6,2(F8.1,'E3'),2X,'''',A10,'''', & 1X,I2,F7.1,F5.1,f6.1,F5.2,F6.1) 942 FORMAT (I3,3F8.2,2F9.2,F7.2) -! 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3IOSF : '/ & ' ERROR IN OPENING FILE'/ & ' IOSTAT =',I5/) -! -#ifdef W3_T 9000 FORMAT (' TEST W3IOSF : IPASS =',I4,', FLFROM = ',L1, & ', NDSPT =',I3,', IMOD =',I3,','/ & ' IAPROC, NAPPRT =',2I4) 9010 FORMAT (' TEST W3IOSF : OPENING NEW FILE [',A,']') 9020 FORMAT (' TEST W3IOSF : SENDING ICPRT FROM',I3,' TO',I3, & ' WITH SIZE :',I6) -#endif -#ifdef W3_MPIT 9021 FORMAT (' TEST W3IOSF : SENDING DTPRT FROM',I3,' TO',I3, & ' WITH SIZE :',I6) -#endif -#ifdef W3_T 9030 FORMAT (' TEST W3IOSF : RECEIVING ICPRT FROM',I3, & ' WITH SIZE :',I6) -#endif -#ifdef W3_MPIT 9031 FORMAT (' TEST W3IOSF : RECEIVING DTPRT FROM',I3, & ' WITH SIZE :',I6) -#endif !/ !/ End of W3IOSF ----------------------------------------------------- / !/ diff --git a/model/src/w3meminfo.F90 b/model/src/w3meminfo.F90 index d743277d96..6ab27e4c1e 100644 --- a/model/src/w3meminfo.F90 +++ b/model/src/w3meminfo.F90 @@ -2,7 +2,7 @@ module MallocInfo_m !/ !/ +-----------------------------------+ !/ | WAVEWATCH III NOAA/NCEP | -!/ | | +!/ | | !/ | Aron Roland (BGS IT&E GmbH) | !/ | Mathieu Dutour-Sikiric (IRB) | !/ | | @@ -69,25 +69,25 @@ module MallocInfo_m !> This structure type is used to return information about the dynamic memory allocator. type, bind(c) :: MallInfo_t !> This is the total size of memory allocated with sbrk by malloc, in bytes. - integer(c_int) :: arena + integer(c_int) :: arena !> This is the number of chunks not in use. (The memory allocator internally gets chunks of memory from the operating system, and then carves them up to satisfy individual malloc requests; see Efficiency and Malloc.) - integer(c_int) :: ordblks + integer(c_int) :: ordblks !> This field is unused. - integer(c_int) :: smblks + integer(c_int) :: smblks !> This is the total number of chunks allocated with mmap. - integer(c_int) :: hblks + integer(c_int) :: hblks !> This is the total size of memory allocated with mmap, in bytes. - integer(c_int) :: hblkhd + integer(c_int) :: hblkhd !> This field is unused. - integer(c_int) :: usmblks + integer(c_int) :: usmblks !> This field is unused. - integer(c_int) :: fsmblks + integer(c_int) :: fsmblks !> This is the total size of memory occupied by chunks handed out by malloc. - integer(c_int) :: uordblks + integer(c_int) :: uordblks !> This is the total size of memory occupied by free (not in use) chunks. - integer(c_int) :: fordblks + integer(c_int) :: fordblks !> This is the size of the top-most releasable chunk that normally borders the end of the heap (i.e., the high end of the virtual address space’s data segment). - integer(c_int) :: keepcost + integer(c_int) :: keepcost end type interface @@ -95,17 +95,17 @@ function mallinfo() bind(c, name="mallinfo") result(data) use :: iso_c_binding implicit none - type, bind(c) :: MallInfo_t - integer(c_int) :: arena - integer(c_int) :: ordblks - integer(c_int) :: smblks - integer(c_int) :: hblks - integer(c_int) :: hblkhd - integer(c_int) :: usmblks - integer(c_int) :: fsmblks - integer(c_int) :: uordblks - integer(c_int) :: fordblks - integer(c_int) :: keepcost + type, bind(c) :: MallInfo_t + integer(c_int) :: arena + integer(c_int) :: ordblks + integer(c_int) :: smblks + integer(c_int) :: hblks + integer(c_int) :: hblkhd + integer(c_int) :: usmblks + integer(c_int) :: fsmblks + integer(c_int) :: uordblks + integer(c_int) :: fordblks + integer(c_int) :: keepcost end type type(MallInfo_t) :: data end function @@ -117,7 +117,7 @@ subroutine getMallocInfo(malinfo) !/ !/ +-----------------------------------+ !/ | WAVEWATCH III NOAA/NCEP | -!/ | | +!/ | | !/ | Aron Roland (BGS IT&E GmbH) | !/ | THomas Huxhorn (BGS IT&E GmbH | !/ | | @@ -187,7 +187,7 @@ subroutine printMallInfo(ihdnl,malinfo) !/ !/ +-----------------------------------+ !/ | WAVEWATCH III NOAA/NCEP | -!/ | | +!/ | | !/ | Aron Roland (BGS IT&E GmbH) | !/ | Mathieu Dutour-Sikiric (IRB) | !/ | | @@ -251,11 +251,11 @@ subroutine printMallInfo(ihdnl,malinfo) #endif real :: ib2m integer(8) :: vmsize, vmRSS - integer, intent(in) :: ihdnl + integer, intent(in) :: ihdnl type(MallInfo_t), intent(in) :: malinfo - if (ihdnl .lt. 1) stop 'ihndl not set' + if (ihdnl .lt. 1) stop 'ihndl not set' ib2m=1./REAL(1024**2) vmsize = getVmSize() vmRSS = getVMRSS() @@ -265,8 +265,8 @@ subroutine printMallInfo(ihdnl,malinfo) !write(*,'(A72,I10)') "Total number of chunks allocated with mmap. ", malinfo%hblks !write(*,'(A72,I10)') "Number of chunks not in use. ", malinfo%ordblks !write(*,'(A72,2F20.10)') "Total size of memory occupied by free (not in use) chunks. ", malinfo%fordblks*ib2m - !write(*,'(A72,2F20.10)') "Size of the top-most releasable chunk borders end of the heap", malinfo%keepcost*ib2m - write(ihdnl,'(A72,2F20.10)') "VM size in proc ", vmsize/1024. + !write(*,'(A72,2F20.10)') "Size of the top-most releasable chunk borders end of the heap", malinfo%keepcost*ib2m + write(ihdnl,'(A72,2F20.10)') "VM size in proc ", vmsize/1024. write(ihdnl,'(A72,2F20.10)') "RSS size in prof ", vmRSS/1024. call flush(ihdnl) end subroutine @@ -287,7 +287,7 @@ function getVmSize() result(vmsize) !/ !/ +-----------------------------------+ !/ | WAVEWATCH III NOAA/NCEP | -!/ | | +!/ | | !/ | Aron Roland (BGS IT&E GmbH) | !/ | Mathieu Dutour-Sikiric (IRB) | !/ | | @@ -373,7 +373,7 @@ function getVmRSS() result(vmRSS) !/ !/ +-----------------------------------+ !/ | WAVEWATCH III NOAA/NCEP | -!/ | | +!/ | | !/ | Aron Roland (BGS IT&E GmbH) | !/ | Mathieu Dutour-Sikiric (IRB) | !/ | | @@ -460,10 +460,10 @@ end function getVmRSS !program test ! use MallocInfo_m ! implicit none -! type(MallInfo_t) :: mallinfos(10000) +! type(MallInfo_t) :: mallinfos(10000) ! integer :: i, nInfos ! integer, allocatable :: data(:) -! +! ! allocate(data(0)) ! nInfos = 0 ! do i=1, 10 @@ -471,7 +471,7 @@ end function getVmRSS ! deallocate(data) ! allocate(data(i*100000)) ! nInfos = nInfos+1 -! call getMallocInfo(mallinfos(nInfos)) +! call getMallocInfo(mallinfos(nInfos)) ! call printMallInfo(IAPROC,mallInfos(nInfos)) ! call sleep(1) ! end do @@ -481,8 +481,8 @@ end function getVmRSS ! deallocate(data) ! allocate(data(i*100000)) ! nInfos = nInfos+1 -! call getMallocInfo(mallinfos(nInfos)) -! call printMallInfo(IAPROC,mallInfos(nInfos)) +! call getMallocInfo(mallinfos(nInfos)) +! call printMallInfo(IAPROC,mallInfos(nInfos)) ! call sleep(1) ! end do diff --git a/model/src/w3odatmd.F90 b/model/src/w3odatmd.F90 index 075b3118a5..b53f1dc1ce 100644 --- a/model/src/w3odatmd.F90 +++ b/model/src/w3odatmd.F90 @@ -310,6 +310,8 @@ MODULE W3ODATMD ! !/ ------------------------------------------------------------------- / USE CONSTANTS, ONLY : UNDEF + ! module default + IMPLICIT NONE PUBLIC !/ !/ Module private variable for checking error returns @@ -554,6 +556,28 @@ MODULE W3ODATMD LOGICAL, POINTER :: FLFORM, FLCOMB, O6INIT INTEGER, POINTER :: PTMETH ! C. Bunney; Partitioning method REAL, POINTER :: PTFCUT ! C. Bunney; Part. 5 freq cut + + character(len=8) :: runtype = '' !< @public the run type (startup,branch,continue) + character(len=256) :: initfile = '' !< @public name of wave initial condition file + !! if runtype is startup or branch run, then initfile is used + logical :: use_user_histname = .false. !<@public logical flag for user set history filenames + logical :: use_user_restname = .false. !<@public logical flag for user set restart filenames + character(len=512) :: user_histfname = '' !<@public user history filename prefix, timestring + !! YYYY-MM-DD-SSSSS will be appended + character(len=512) :: user_restfname = '' !<@public user restart filename prefix, timestring + !! YYYY-MM-DD-SSSSS will be appended + logical :: histwr = .false. !<@public logical to trigger history write + !! if true => write history file (snapshot) + + logical :: rstwr = .false. !<@public logical to trigger restart write + !! if true => write restart + + logical :: user_netcdf_grdout = .false. !<@public logical flag to use netCDF for gridded + !! field output + + character(len= 36) :: time_origin = '' !< @public the time_origin used for netCDF output + character(len= 36) :: calendar_name = '' !< @public the calendar used for netCDF output + integer(kind=8) :: elapsed_secs = 0 !< @public the time in seconds from the time_origin !/ CONTAINS !/ ------------------------------------------------------------------- / @@ -624,7 +648,6 @@ SUBROUTINE W3NOUT ( NDSERR, NDSTST ) USE W3SERVMD, ONLY: STRACE #endif ! - IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -1023,7 +1046,6 @@ SUBROUTINE W3DMO2 ( IMOD, NDSE, NDST, NPT ) USE W3SERVMD, ONLY: STRACE #endif ! - IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -1221,7 +1243,6 @@ SUBROUTINE W3DMO3 ( IMOD, NDSE, NDST ) USE W3SERVMD, ONLY: STRACE #endif ! - IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -1393,7 +1414,6 @@ SUBROUTINE W3DMO5 ( IMOD, NDSE, NDST, IBLOCK ) USE W3SERVMD, ONLY: STRACE #endif ! - IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -1598,7 +1618,6 @@ SUBROUTINE W3SETO ( IMOD, NDSERR, NDSTST ) USE W3SERVMD, ONLY: STRACE #endif ! - IMPLICIT NONE ! !/ !/ ------------------------------------------------------------------- / diff --git a/model/src/w3parall.F90 b/model/src/w3parall.F90 index 311d09a1a7..8378345210 100644 --- a/model/src/w3parall.F90 +++ b/model/src/w3parall.F90 @@ -1,1577 +1,1469 @@ - MODULE W3PARALL -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Parallel routines for implicit solver -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -! +MODULE W3PARALL + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Parallel routines for implicit solver + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD , ONLY : STRACE ! W3_S + USE W3ODATMD , ONLY : OUTPTS, IAPROC, NTPROC, NAPROC + USE CONSTANTS , ONLY : LPDLIB + use wav_shr_flags + + ! module default + IMPLICIT NONE + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + ! #ifdef W3_PDLIB - INTEGER :: PDLIB_NSEAL, PDLIB_NSEALM - INTEGER, ALLOCATABLE :: JX_TO_JSEA(:), ISEA_TO_JSEA(:) + INTEGER :: PDLIB_NSEAL, PDLIB_NSEALM + INTEGER, ALLOCATABLE :: JX_TO_JSEA(:), ISEA_TO_JSEA(:) #endif + INTEGER, ALLOCATABLE :: ListISPnextDir(:), ListISPprevDir(:) + INTEGER, ALLOCATABLE :: ListISPnextFreq(:), ListISPprevFreq(:) - INTEGER, ALLOCATABLE :: ListISPnextDir(:), ListISPprevDir(:) - INTEGER, ALLOCATABLE :: ListISPnextFreq(:), ListISPprevFreq(:) + LOGICAL, PARAMETER :: LSLOC = .true. + INTEGER, PARAMETER :: IMEM = 1 - LOGICAL, PARAMETER :: LSLOC = .true. - INTEGER, PARAMETER :: IMEM = 1 + REAL, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 + REAL, PARAMETER :: ONETHIRD = 1.0d0/3.0d0 + REAL, PARAMETER :: ZERO = 0.0d0 - REAL, PARAMETER :: ONESIXTH = 1.0d0/6.0d0 - REAL, PARAMETER :: ONETHIRD = 1.0d0/3.0d0 - REAL, PARAMETER :: ZERO = 0.0d0 + REAL*8, PARAMETER :: THR8 = TINY(1.d0) + REAL, PARAMETER :: THR = TINY(1.0) - REAL*8, PARAMETER :: THR8 = TINY(1.d0) - REAL, PARAMETER :: THR = TINY(1.0) -!!/S CALL STRACE (IENT, 'W3XXXX') - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE WAV_MY_WTIME(eTime) -!/ ------------------------------------------------------------------- / -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - IMPLICIT NONE -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - INTEGER mpimode - REAL(8), intent(out) :: eTime +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE WAV_MY_WTIME(eTime) + !/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL(8), intent(out) :: eTime + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER, SAVE :: IENT = 0 ! W3_S + INTEGER mpimode #ifdef W3_MPI - REAL(8) mpi_wtime + REAL(8) mpi_wtime #endif - mpimode=0 + mpimode=0 #ifdef W3_MPI - mpimode=1 - eTime=mpi_wtime() -#endif -#ifdef W3_S - CALL STRACE (IENT, 'WAV_MY_WTIME') -#endif - IF (mpimode .eq. 0) THEN - CALL CPU_TIME(eTime) - END IF -!/ -!/ End of JACOBI_INIT ------------------------------------------------ / -!/ - END SUBROUTINE -!/ ------------------------------------------------------------------- / - SUBROUTINE PRINT_MY_TIME(string) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Print timings -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif - USE W3ODATMD, ONLY : IAPROC - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -! - character(*), intent(in) :: string - REAL(8) :: eTime -#ifdef W3_S - CALL STRACE (IENT, 'PRINT_MY_TIME') -#endif - CALL WAV_MY_WTIME(eTime) - WRITE(740+IAPROC,*) 'TIMING time=', eTime, ' at step ', string -!/ -!/ End of JACOBI_INIT ------------------------------------------------ / -!/ - END SUBROUTINE -!/ ------------------------------------------------------------------- / - SUBROUTINE PROP_REFRACTION_PR1(ISEA,DTG, CAD) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Compute refraction part in matrix -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif - USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & - EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK, & - CTMAX, DMIN, DTH, CTHG0S, MAPSF - USE W3ADATMD, ONLY: CG, WN, DCXDX, DCXDY, DCYDX, DCYDY, DDDX, & - DDDY, DW + mpimode=1 + eTime=mpi_wtime() +#endif + if (w3_s_flag) then + CALL STRACE (IENT, 'WAV_MY_WTIME') + end if + IF (mpimode .eq. 0) THEN + CALL CPU_TIME(eTime) + END IF + !/ + END SUBROUTINE WAV_MY_WTIME + !/ ------------------------------------------------------------------- / + SUBROUTINE PRINT_MY_TIME(string) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Print timings + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + character(*), intent(in) :: string + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER, SAVE :: IENT = 0 ! W3_S + REAL(8) :: eTime + !/ + !/ ------------------------------------------------------------------- / + ! + if (w3_s_flag) then + CALL STRACE (IENT, 'PRINT_MY_TIME') + end if + CALL WAV_MY_WTIME(eTime) + WRITE(740+IAPROC,*) 'TIMING time=', eTime, ' at step ', string + !/ + END SUBROUTINE PRINT_MY_TIME + !/ ------------------------------------------------------------------- / + SUBROUTINE PROP_REFRACTION_PR1(ISEA,DTG, CAD) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Compute refraction part in matrix + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD , ONLY : NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN + USE W3GDATMD , ONLY : EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK + USE W3GDATMD , ONLY : CTMAX, DMIN, DTH, CTHG0S, MAPSF + USE W3ADATMD , ONLY : CG, WN, DCXDX, DCXDY, DCYDX, DCYDY, DDDX, DDDY, DW #ifdef W3_REFRX - USE W3ADATMD, ONLY: DCDX, DCDY -#endif - USE W3IDATMD, ONLY: FLCUR - USE W3ODATMD, only : IAPROC - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -!/ - REAL, intent(out) :: CAD(NSPEC) - INTEGER, intent(in) :: ISEA - REAL, intent(in) :: DTG - INTEGER :: ISP, IK, ITH, IX, IY - REAL :: FRK(NK), FRG(NK), DSDD(0:NK+1) - REAL :: FACTH, DCXY, DCYX, DCXXYY, DTTST - REAL :: eDCXDX, eDCXDY, eDCYDX, eDCYDY, eDDDX, eDDDY, eCTHG0 - REAL :: VCFLT(NSPEC), DEPTH, FDG - REAL :: FDDMAX -#ifdef W3_S - CALL STRACE (IENT, 'PROP_REFRACTION_PR1') -#endif - IX=MAPSF(ISEA,1) - IY=MAPSF(ISEA,2) - eDDDX=DDDX(IY,IX) - eDDDY=DDDY(IY,IX) - eCTHG0 = CTHG0S(ISEA) - FACTH = DTG / DTH - ! - FDG = FACTH * eCTHG0 - DEPTH = MAX ( DMIN , DW(ISEA) ) - DO IK=0, NK+1 - IF ( DEPTH*WN(IK,ISEA) .LT. 5. ) THEN + USE W3ADATMD , ONLY : DCDX, DCDY +#endif + USE W3IDATMD , ONLY : FLCUR + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER , intent(in) :: ISEA + REAL , intent(in) :: DTG + REAL , intent(out) :: CAD(NSPEC) + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ISP, IK, ITH, IX, IY + REAL :: FRK(NK), FRG(NK), DSDD(0:NK+1) + REAL :: FACTH, DCXY, DCYX, DCXXYY, DTTST + REAL :: eDCXDX, eDCXDY, eDCYDX, eDCYDY, eDDDX, eDDDY, eCTHG0 + REAL :: VCFLT(NSPEC), DEPTH, FDG + REAL :: FDDMAX + + INTEGER, SAVE :: IENT = 0 ! W3_S + !/ + !/ ------------------------------------------------------------------- / + + if (w3_s_flag) then + CALL STRACE (IENT, 'PROP_REFRACTION_PR1') + end if + IX=MAPSF(ISEA,1) + IY=MAPSF(ISEA,2) + eDDDX=DDDX(IY,IX) + eDDDY=DDDY(IY,IX) + eCTHG0 = CTHG0S(ISEA) + FACTH = DTG / DTH + ! + FDG = FACTH * eCTHG0 + DEPTH = MAX ( DMIN , DW(ISEA) ) + DO IK=0, NK+1 + IF ( DEPTH*WN(IK,ISEA) .LT. 5. ) THEN DSDD(IK) = MAX ( 0. , CG(IK,ISEA)*WN(IK,ISEA)-0.5*SIG(IK) ) / DEPTH - ELSE + ELSE DSDD(IK) = 0. - END IF - END DO - FDDMAX=0 - DO ITH=1, NTH - FDDMAX = MAX ( FDDMAX , ABS(ESIN(ITH)*eDDDX - ECOS(ITH)*eDDDY ) ) - END DO -#ifdef W3_DEBUG - WRITE(740+IAPROC,*) 'eDDDX=', eDDDX, ' Y=', eDDDY - WRITE(740+IAPROC,*) 'FDDMAX=', FDDMAX - FLUSH(740+IAPROC) -#endif - DO IK=1, NK - FRK(IK) = FACTH * DSDD(IK) / WN(IK,ISEA) - !FRK(IK) = FRK(IK) / MAX ( 1. , FRK(IK)*FDDMAX/CTMAX ) - FRG(IK) = FDG * CG(IK,ISEA) - END DO - DO ISP=1, NSPEC - VCFLT(ISP) = FRG(MAPWN(ISP)) * ECOS(ISP) + & - FRK(MAPWN(ISP)) * ( ESIN(ISP)*eDDDX - ECOS(ISP)*eDDDY ) - END DO -#ifdef W3_DEBUG - WRITE(740+IAPROC,*) 'pdlib: FACTH=', FACTH - WRITE(740+IAPROC,*) 'pdlib: CTHG0=', eCTHG0 - WRITE(740+IAPROC,*) 'pdlib: FDG=', FDG - WRITE(740+IAPROC,*) 'pdlib: FDDMAX=', FDDMAX - WRITE(740+IAPROC,*) 'pdlib: sum(FRK)=', sum(FRK) - WRITE(740+IAPROC,*) 'pdlib: sum(FRG)=', sum(FRG) - WRITE(740+IAPROC,*) 'pdlib: sum(DSDD)=', sum(DSDD) - WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' sum(VCTH)=', sum(VCFLT) - FLUSH(740+IAPROC) -#endif -! + END IF + END DO + FDDMAX=0 + DO ITH=1, NTH + FDDMAX = MAX ( FDDMAX , ABS(ESIN(ITH)*eDDDX - ECOS(ITH)*eDDDY ) ) + END DO + if (w3_debug_flag) then + WRITE(740+IAPROC,*) 'eDDDX=', eDDDX, ' Y=', eDDDY + WRITE(740+IAPROC,*) 'FDDMAX=', FDDMAX + end if + DO IK=1, NK + FRK(IK) = FACTH * DSDD(IK) / WN(IK,ISEA) + !FRK(IK) = FRK(IK) / MAX ( 1. , FRK(IK)*FDDMAX/CTMAX ) + FRG(IK) = FDG * CG(IK,ISEA) + END DO + DO ISP=1, NSPEC + VCFLT(ISP) = FRG(MAPWN(ISP)) * ECOS(ISP) + & + FRK(MAPWN(ISP)) * ( ESIN(ISP)*eDDDX - ECOS(ISP)*eDDDY ) + END DO + if (w3_debug_flag) then + WRITE(740+IAPROC,*) 'pdlib: FACTH=', FACTH + WRITE(740+IAPROC,*) 'pdlib: CTHG0=', eCTHG0 + WRITE(740+IAPROC,*) 'pdlib: FDG=', FDG + WRITE(740+IAPROC,*) 'pdlib: FDDMAX=', FDDMAX + WRITE(740+IAPROC,*) 'pdlib: sum(FRK)=', sum(FRK) + WRITE(740+IAPROC,*) 'pdlib: sum(FRG)=', sum(FRG) + WRITE(740+IAPROC,*) 'pdlib: sum(DSDD)=', sum(DSDD) + WRITE(740+IAPROC,*) 'ISEA=', ISEA, ' sum(VCTH)=', sum(VCFLT) + end if + ! #ifdef W3_REFRX -! 3.c @C/@x refraction and great-circle propagation - VCFLT = 0. - FRK = 0. - DO IK=1, NK - FRK(IK) = FACTH * CG(IK,ISEA) * WN(IK,ISEA) / SIG(IK) - END DO - DO ISP=1, NSPEC - VCFLT(ISP) = FRG(MAPWN(ISP)) * ECOS(ISP) & - + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DCDX(ISP,1,MAPWN(ISP)) & - - ECOS(ISP)*DCDY(ISP,1,MAPWN(ISP)) ) - END DO -#endif -! - IF ( FLCUR ) THEN - eDCXDX=DCXDX(IY,IX) - eDCXDY=DCXDY(IY,IX) - eDCYDX=DCYDX(IY,IX) - eDCYDY=DCYDY(IY,IX) - DCYX = FACTH * eDCYDX - DCXXYY = FACTH * ( eDCXDX - eDCYDY ) - DCXY = FACTH * eDCXDY - DO ISP=1, NSPEC + ! 3.c @C/@x refraction and great-circle propagation + VCFLT = 0. + FRK = 0. + DO IK=1, NK + FRK(IK) = FACTH * CG(IK,ISEA) * WN(IK,ISEA) / SIG(IK) + END DO + DO ISP=1, NSPEC + VCFLT(ISP) = FRG(MAPWN(ISP)) * ECOS(ISP) & + + FRK(MAPWN(ISP)) * ( ESIN(ISP)*DCDX(ISP,1,MAPWN(ISP)) & + - ECOS(ISP)*DCDY(ISP,1,MAPWN(ISP)) ) + END DO +#endif + ! + IF ( FLCUR ) THEN + eDCXDX=DCXDX(IY,IX) + eDCXDY=DCXDY(IY,IX) + eDCYDX=DCYDX(IY,IX) + eDCYDY=DCYDY(IY,IX) + DCYX = FACTH * eDCYDX + DCXXYY = FACTH * ( eDCXDX - eDCYDY ) + DCXY = FACTH * eDCXDY + DO ISP=1, NSPEC VCFLT(ISP) = VCFLT(ISP) + ES2(ISP)*DCYX + ESC(ISP)*DCXXYY - EC2(ISP)*DCXY - END DO - END IF - DO ISP=1,NSPEC - CAD(ISP)=DBLE(VCFLT(ISP)) - END DO -!/ -!/ End of JACOBI_INIT ------------------------------------------------ / -!/ - END SUBROUTINE -!/ ------------------------------------------------------------------- / -! - SUBROUTINE PROP_REFRACTION_PR3(IP, ISEA, DTG, CAD, DoLimiter) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Compute refraction part in matrix alternative approach -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif - USE CONSTANTS, ONLY : LPDLIB - USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & - EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK, & - CTMAX, DMIN, DTH, CTHG0S, MAPSF, SIG - USE W3ADATMD, ONLY: CG, WN, DCXDX, DCXDY, DCYDX, DCYDY, DDDX, & - DDDY, DW - USE W3IDATMD, ONLY: FLCUR - USE W3ODATMD, only : IAPROC - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - REAL, intent(out) :: CAD(NSPEC) - INTEGER, intent(in) :: ISEA, IP - REAL, intent(in) :: DTG - logical, intent(in) :: DoLimiter - INTEGER :: ISP, IK, ITH, IX, IY - REAL :: FRK(NK), FRG(NK), DSDD(0:NK+1) - REAL :: FACTH, DCXY, DCYX, DCXXYY, DTTST - REAL :: eDCXDX, eDCXDY, eDCYDX, eDCYDY, eDDDX, eDDDY, eCTHG0 - REAL :: VCFLT(NSPEC), DEPTH, FDG, CG1(0:NK+1), WN1(0:NK+1) - REAL :: FDDMAX, CFLTHMAX, VELNOFILT, CTMAX_eff -#ifdef W3_S - CALL STRACE (IENT, 'PROP_REFRACTION_PR3') -#endif + END DO + END IF + DO ISP=1,NSPEC + CAD(ISP)=DBLE(VCFLT(ISP)) + END DO + !/ + END SUBROUTINE PROP_REFRACTION_PR1 + !/ ------------------------------------------------------------------- / + SUBROUTINE PROP_REFRACTION_PR3(IP, ISEA, DTG, CAD, DoLimiter) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Compute refraction part in matrix alternative approach + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD , ONLY : NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN + USE W3GDATMD , ONLY : EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK + USE W3GDATMD , ONLY : CTMAX, DMIN, DTH, CTHG0S, MAPSF, SIG + USE W3ADATMD , ONLY : CG, WN, DCXDX, DCXDY, DCYDX, DCYDY, DDDX, DDDY, DW + USE W3IDATMD , ONLY : FLCUR + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + INTEGER , intent(in) :: ISEA, IP + REAL , intent(in) :: DTG + logical , intent(in) :: DoLimiter + REAL , intent(out) :: CAD(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ISP, IK, ITH, IX, IY + REAL :: FRK(NK), FRG(NK), DSDD(0:NK+1) + REAL :: FACTH, DCXY, DCYX, DCXXYY, DTTST + REAL :: eDCXDX, eDCXDY, eDCYDX, eDCYDY, eDDDX, eDDDY, eCTHG0 + REAL :: VCFLT(NSPEC), DEPTH, FDG, CG1(0:NK+1), WN1(0:NK+1) + REAL :: FDDMAX, CFLTHMAX, VELNOFILT, CTMAX_eff + INTEGER, SAVE :: IENT = 0 ! W3_S + !/ + !/ ------------------------------------------------------------------- / - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - eDDDX=DDDX(1,IP) - eDDDY=DDDY(1,IP) - eCTHG0 = CTHG0S(ISEA) - FACTH = 1.0 / DTH - ! - FDG = FACTH * eCTHG0 - DEPTH = MAX ( DMIN , DW(ISEA) ) - DO IK=0, NK+1 - IF ( DEPTH*WN(IK,ISEA) .LT. 5. ) THEN + if (w3_s_flag) then + CALL STRACE (IENT, 'PROP_REFRACTION_PR3') + end if + + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + eDDDX=DDDX(1,IP) + eDDDY=DDDY(1,IP) + eCTHG0 = CTHG0S(ISEA) + FACTH = 1.0 / DTH + ! + FDG = FACTH * eCTHG0 + DEPTH = MAX ( DMIN , DW(ISEA) ) + DO IK=0, NK+1 + IF ( DEPTH*WN(IK,ISEA) .LT. 5. ) THEN DSDD(IK) = MAX ( 0. , CG(IK,ISEA)*WN(IK,ISEA)-0.5*SIG(IK) ) / DEPTH - ELSE + ELSE DSDD(IK) = 0. - END IF - END DO - DO IK=1, NK - FRK(IK) = FACTH * DSDD(IK) / WN(IK,ISEA) - FRG(IK) = FDG * CG(IK,ISEA) - END DO - IF (FLCUR) THEN - eDCXDX = DCXDX(1,IP) - eDCXDY = DCXDY(1,IP) - eDCYDX = DCYDX(1,IP) - eDCYDY = DCYDY(1,IP) - DCYX = FACTH * eDCYDX - DCXXYY = FACTH * ( eDCXDX - eDCYDY ) - DCXY = FACTH * eDCXDY - DO ISP=1, NSPEC + END IF + END DO + DO IK=1, NK + FRK(IK) = FACTH * DSDD(IK) / WN(IK,ISEA) + FRG(IK) = FDG * CG(IK,ISEA) + END DO + IF (FLCUR) THEN + eDCXDX = DCXDX(1,IP) + eDCXDY = DCXDY(1,IP) + eDCYDX = DCYDX(1,IP) + eDCYDY = DCYDY(1,IP) + DCYX = FACTH * eDCYDX + DCXXYY = FACTH * ( eDCXDX - eDCYDY ) + DCXY = FACTH * eDCXDY + DO ISP=1, NSPEC VCFLT(ISP) = ES2(ISP)*DCYX + ESC(ISP)*DCXXYY - EC2(ISP)*DCXY - END DO - ELSE - VCFLT=0 - END IF -! + END DO + ELSE + VCFLT=0 + END IF + ! #ifdef W3_REFRX -! 3.c @C/@x refraction and great-circle propagation - DO IK=1, NK - FRK(IK) = FACTH * CG(IK,ISEA) * WN(IK,ISEA) / SIG(IK) - END DO -#endif -! - CTMAX_eff=CTMAX/DTG - DO ISP=1, NSPEC - VELNOFILT = VCFLT(ISP) & - + FRG(MAPWN(ISP)) * ECOS(ISP) & - + FRK(MAPWN(ISP)) * (ESIN(ISP)*eDDDX - ECOS(ISP)*eDDDY) -! -! Puts filtering on total velocity (including currents and great circle effects) -! the filtering limits VCFLT to be less than CTMAX -! this modification was proposed by F. Ardhuin 2011/03/06 -! - IF (DoLimiter) THEN + ! 3.c @C/@x refraction and great-circle propagation + DO IK=1, NK + FRK(IK) = FACTH * CG(IK,ISEA) * WN(IK,ISEA) / SIG(IK) + END DO +#endif + ! + CTMAX_eff=CTMAX/DTG + DO ISP=1, NSPEC + VELNOFILT = VCFLT(ISP) & + + FRG(MAPWN(ISP)) * ECOS(ISP) & + + FRK(MAPWN(ISP)) * (ESIN(ISP)*eDDDX - ECOS(ISP)*eDDDY) + ! + ! Puts filtering on total velocity (including currents and great circle effects) + ! the filtering limits VCFLT to be less than CTMAX + ! this modification was proposed by F. Ardhuin 2011/03/06 + ! + IF (DoLimiter) THEN VCFLT(ISP)=SIGN(MIN(ABS(VELNOFILT),CTMAX_eff),VELNOFILT) - ELSE + ELSE VCFLT(ISP)=VELNOFILT - END IF - END DO - DO ISP=1,NSPEC - CAD(ISP)=DBLE(VCFLT(ISP)) - END DO -!/ -!/ End of JACOBI_INIT ------------------------------------------------ / -!/ - END SUBROUTINE -!/ ------------------------------------------------------------------- / - SUBROUTINE PROP_FREQ_SHIFT(IP, ISEA, CAS, DMM, DTG) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Compute freq. shift in matrix -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif - USE CONSTANTS, ONLY : LPDLIB - USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & - EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK, & - CTMAX, DMIN, DTH, MAPSF - USE W3ADATMD, ONLY: CG, WN, DCXDX, DCXDY, DCYDX, DCYDY, CX, CY, DDDX, DDDY, DW - USE W3ODATMD, only : IAPROC - IMPLICIT NONE -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - INTEGER, intent(in) :: ISEA, IP - REAL, intent(out) :: DMM(0:NK2) - REAL, intent(in) :: DTG - REAL, intent(out) :: CAS(NSPEC) - REAL :: DB(NK2), DSDD(0:NK+1) - REAL :: eDCXDX, eDCXDY, eDCYDX, eDCYDY, eCX, eCY, eDDDX, EDDDY - REAL :: DCXX, DCXYYX, DCYY, FKD, FACK - REAL :: VELNOFILT, VELFAC, DEPTH - REAL :: CFLK(NK2,NTH), FKC(NTH), FKD0 - INTEGER :: IK, ITH, ISP, IY, IX -#ifdef W3_S - CALL STRACE (IENT, 'PROP_FREQ_SHIFT') -#endif -! - IF (LPDLIB) THEN - eDCXDX = DCXDX(1,IP) - eDCXDY = DCXDY(1,IP) - eDCYDX = DCYDX(1,IP) - eDCYDY = DCYDY(1,IP) - eDDDX = DDDX(1,IP) - eDDDY = DDDY(1,IP) - ELSE - IX=MAPSF(ISEA,1) - IY=MAPSF(ISEA,2) - eDCXDX=DCXDX(IY,IX) - eDCXDY=DCXDY(IY,IX) - eDCYDX=DCYDX(IY,IX) - eDCYDY=DCYDY(IY,IX) - eDDDX=DDDX(IY,IX) - eDDDY=DDDY(IY,IX) - ENDIF - eCX=CX(ISEA) - eCY=CY(ISEA) - DCXX = - eDCXDX - DCXYYX = - ( eDCXDY + eDCYDX ) - DCYY = - eDCYDY - FKD = ( eCX*eDDDX + eCY*eDDDY ) - FACK = DTG -#ifdef W3_DEBUG - WRITE(740+IAPROC,*) 'DCXX=', DCXX, ' DCXYYX=', DCXYYX - WRITE(740+IAPROC,*) 'DCYY=', DCYY, ' FKD=', FKD - WRITE(740+IAPROC,*) 'DTG=', DTG - FLUSH(740+IAPROC) -#endif - DO ITH=1, NTH - FKC(ITH) = EC2(ITH)*DCXX + ESC(ITH)*DCXYYX + ES2(ITH)*DCYY - END DO - DO IK=0, NK - DB(IK+1) = DSIP(IK) / CG(IK,ISEA) - DMM(IK+1) = DBLE(WN(IK+1,ISEA) - WN(IK,ISEA)) - END DO - DB(NK+2) = DSIP(NK+1) / CG(NK+1,ISEA) - DMM(NK+2) = ZERO - DMM(0)=DMM(1) -! - DEPTH = MAX ( DMIN , DW(ISEA) ) - DO IK=0, NK+1 - IF ( DEPTH*WN(IK,ISEA) .LT. 5. ) THEN + END IF + END DO + DO ISP=1,NSPEC + CAD(ISP)=DBLE(VCFLT(ISP)) + END DO + !/ + END SUBROUTINE PROP_REFRACTION_PR3 + !/ ------------------------------------------------------------------- / + SUBROUTINE PROP_FREQ_SHIFT(IP, ISEA, CAS, DMM, DTG) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Compute freq. shift in matrix + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3GDATMD , ONLY : NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN + USE W3GDATMD , ONLY : EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK + USE W3GDATMD , ONLY : CTMAX, DMIN, DTH, MAPSF + USE W3ADATMD , ONLY : CG, WN, DCXDX, DCXDY, DCYDX, DCYDY, CX, CY + USE W3ADATMD , ONLY : DDDX, DDDY, DW + + !/ Parameter list + INTEGER , intent(in) :: ISEA, IP + REAL , intent(in) :: DTG + REAL , intent(out) :: DMM(0:NK2) + REAL , intent(out) :: CAS(NSPEC) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + REAL :: DB(NK2), DSDD(0:NK+1) + REAL :: eDCXDX, eDCXDY, eDCYDX, eDCYDY, eCX, eCY, eDDDX, EDDDY + REAL :: DCXX, DCXYYX, DCYY, FKD, FACK + REAL :: VELNOFILT, VELFAC, DEPTH + REAL :: CFLK(NK2,NTH), FKC(NTH), FKD0 + INTEGER :: IK, ITH, ISP, IY, IX + INTEGER, SAVE :: IENT = 0 ! W3_S + !/ + !/ ------------------------------------------------------------------- / + + if (w3_s_flag) then + CALL STRACE (IENT, 'PROP_FREQ_SHIFT') + end if + ! + IF (LPDLIB) THEN + eDCXDX = DCXDX(1,IP) + eDCXDY = DCXDY(1,IP) + eDCYDX = DCYDX(1,IP) + eDCYDY = DCYDY(1,IP) + eDDDX = DDDX(1,IP) + eDDDY = DDDY(1,IP) + ELSE + IX=MAPSF(ISEA,1) + IY=MAPSF(ISEA,2) + eDCXDX=DCXDX(IY,IX) + eDCXDY=DCXDY(IY,IX) + eDCYDX=DCYDX(IY,IX) + eDCYDY=DCYDY(IY,IX) + eDDDX=DDDX(IY,IX) + eDDDY=DDDY(IY,IX) + ENDIF + eCX=CX(ISEA) + eCY=CY(ISEA) + DCXX = - eDCXDX + DCXYYX = - ( eDCXDY + eDCYDX ) + DCYY = - eDCYDY + FKD = ( eCX*eDDDX + eCY*eDDDY ) + FACK = DTG + if (w3_debug_flag) then + WRITE(740+IAPROC,*) 'DCXX=', DCXX, ' DCXYYX=', DCXYYX + WRITE(740+IAPROC,*) 'DCYY=', DCYY, ' FKD=', FKD + WRITE(740+IAPROC,*) 'DTG=', DTG + end if + DO ITH=1, NTH + FKC(ITH) = EC2(ITH)*DCXX + ESC(ITH)*DCXYYX + ES2(ITH)*DCYY + END DO + DO IK=0, NK + DB(IK+1) = DSIP(IK) / CG(IK,ISEA) + DMM(IK+1) = DBLE(WN(IK+1,ISEA) - WN(IK,ISEA)) + END DO + DB(NK+2) = DSIP(NK+1) / CG(NK+1,ISEA) + DMM(NK+2) = ZERO + DMM(0)=DMM(1) + ! + DEPTH = MAX ( DMIN , DW(ISEA) ) + DO IK=0, NK+1 + IF ( DEPTH*WN(IK,ISEA) .LT. 5. ) THEN DSDD(IK) = MAX ( 0. , CG(IK,ISEA)*WN(IK,ISEA)-0.5*SIG(IK) ) / DEPTH - ELSE + ELSE DSDD(IK) = 0. - END IF - END DO -#ifdef W3_DEBUG - WRITE(740+IAPROC,*) 'DSDD(min/max)=', minval(DSDD), maxval(DSDD) - FLUSH(740+IAPROC) -#endif - DO IK=0, NK+1 - FKD0 = FKD / CG(IK,ISEA) * DSDD(IK) - VELFAC = FACK/DB(IK+1) - DO ITH=1, NTH + END IF + END DO + if (w3_debug_flag) then + WRITE(740+IAPROC,*) 'DSDD(min/max)=', minval(DSDD), maxval(DSDD) + end if + DO IK=0, NK+1 + FKD0 = FKD / CG(IK,ISEA) * DSDD(IK) + VELFAC = FACK/DB(IK+1) + DO ITH=1, NTH VELNOFILT = ( FKD0 + WN(IK,ISEA)*FKC(ITH) ) * VELFAC CFLK(IK+1,ITH) = VELNOFILT/VELFAC - END DO - END DO -#ifdef W3_DEBUG - WRITE(740+IAPROC,*) 'sum(CFLK)=', sum(CFLK) - FLUSH(740+IAPROC) -#endif - DO IK=1,NK - DO ITH=1,NTH + END DO + END DO + if (w3_debug_flag) then + WRITE(740+IAPROC,*) 'sum(CFLK)=', sum(CFLK) + end if + DO IK=1,NK + DO ITH=1,NTH ISP=ITH + (IK-1)*NTH CAS(ISP)=DBLE(CFLK(IK,ITH)) - END DO - END DO -#ifdef W3_DEBUG - WRITE(740+IAPROC,*) 'sum(abs(CAS))=', sum(abs(CAS)) - FLUSH(740+IAPROC) -#endif -!/ -!/ End of JACOBI_INIT ------------------------------------------------ / -!/ - END SUBROUTINE -!/ ------------------------------------------------------------------- / - SUBROUTINE PROP_FREQ_SHIFT_M2(IP, ISEA, CWNB_M2, DWNI_M2, DTG) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Compute freq. shift alternative approach -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -! -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif - USE CONSTANTS, ONLY : LPDLIB - USE W3GDATMD, ONLY: NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN, & - EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK, & - CTMAX, DMIN, DTH, MAPSF - USE W3ADATMD, ONLY: CG, WN, DCXDX, DCXDY, DCYDX, DCYDY, CX, CY, DDDX, DDDY, DW - USE W3ODATMD, only : IAPROC - - IMPLICIT NONE - -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - - INTEGER, intent(in) :: ISEA, IP - REAL, intent(out) :: CWNB_M2(1-NTH:NSPEC) - REAL, intent(out) :: DWNI_M2(NK) - REAL, intent(in) :: DTG - ! - REAL :: eDCXDX, eDCXDY, eDCYDX, eDCYDY, eCX, eCY, eDDDX, EDDDY - REAL :: DCXX, DCXYYX, DCYY, FKD, FACK - REAL :: DEPTH - REAL :: FKC(NTH), FKD0 - REAL :: VCWN(1-NTH:NSPEC+NTH) - REAL :: DSDD(0:NK+1) - REAL :: sumDiff, sumDiff1, sumDiff2, sumDiff3 - REAL :: sumDiff0, sumDiff4, sumDiff5 - INTEGER :: IK, ITH, ISP, IY, IX - -!/ ------------------------------------------------------------------- / -#ifdef W3_S - CALL STRACE (IENT, 'PROP_FREQ_SHIFT_M2') -#endif + END DO + END DO + if (w3_debug_flag) then + WRITE(740+IAPROC,*) 'sum(abs(CAS))=', sum(abs(CAS)) + end if + !/ + END SUBROUTINE PROP_FREQ_SHIFT + !/ ------------------------------------------------------------------- / + SUBROUTINE PROP_FREQ_SHIFT_M2(IP, ISEA, CWNB_M2, DWNI_M2, DTG) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Compute freq. shift alternative approach + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3GDATMD , ONLY: NK, NK2, NTH, NSPEC, SIG, DSIP, ECOS, ESIN + USE W3GDATMD , ONLY : EC2, ESC, ES2, FACHFA, MAPWN, FLCTH, FLCK + USE W3GDATMD , ONLY : CTMAX, DMIN, DTH, MAPSF + USE W3ADATMD , ONLY : CG, WN, DCXDX, DCXDY, DCYDX, DCYDY, CX, CY + USE W3ADATMD , ONLY : DDDX, DDDY, DW + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER , intent(in) :: ISEA, IP + REAL , intent(in) :: DTG + REAL , intent(out) :: CWNB_M2(1-NTH:NSPEC) + REAL , intent(out) :: DWNI_M2(NK) + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + REAL :: eDCXDX, eDCXDY, eDCYDX, eDCYDY, eCX, eCY, eDDDX, EDDDY + REAL :: DCXX, DCXYYX, DCYY, FKD, FACK + REAL :: DEPTH + REAL :: FKC(NTH), FKD0 + REAL :: VCWN(1-NTH:NSPEC+NTH) + REAL :: DSDD(0:NK+1) + REAL :: sumDiff, sumDiff1, sumDiff2, sumDiff3 + REAL :: sumDiff0, sumDiff4, sumDiff5 + INTEGER :: IK, ITH, ISP, IY, IX + INTEGER, SAVE :: IENT = 0 ! W3_S + !/ ------------------------------------------------------------------- / + if (w3_s_flag) then + CALL STRACE (IENT, 'PROP_FREQ_SHIFT_M2') + end if -#ifdef W3_DEBUGDCXDX + if (w3_debugdcxdx_flag) then WRITE(740+IAPROC,*) 'Now we use DCXDX array in PROP_FREQ_SHIFT_M2' -#endif + end if - IF (LPDLIB) THEN - eDCXDX = DCXDX(1,IP) - eDCXDY = DCXDY(1,IP) - eDCYDX = DCYDX(1,IP) - eDCYDY = DCYDY(1,IP) - eDDDX = DDDX(1,IP) - eDDDY = DDDY(1,IP) - ELSE - IX=MAPSF(ISEA,1) - IY=MAPSF(ISEA,2) - eDCXDX=DCXDX(IY,IX) - eDCXDY=DCXDY(IY,IX) - eDCYDX=DCYDX(IY,IX) - eDCYDY=DCYDY(IY,IX) - eDDDX=DDDX(IY,IX) - eDDDY=DDDY(IY,IX) - ENDIF + IF (LPDLIB) THEN + eDCXDX = DCXDX(1,IP) + eDCXDY = DCXDY(1,IP) + eDCYDX = DCYDX(1,IP) + eDCYDY = DCYDY(1,IP) + eDDDX = DDDX(1,IP) + eDDDY = DDDY(1,IP) + ELSE + IX=MAPSF(ISEA,1) + IY=MAPSF(ISEA,2) + eDCXDX=DCXDX(IY,IX) + eDCXDY=DCXDY(IY,IX) + eDCYDX=DCYDX(IY,IX) + eDCYDY=DCYDY(IY,IX) + eDDDX=DDDX(IY,IX) + eDDDY=DDDY(IY,IX) + ENDIF - eCX = CX(ISEA) - eCY = CY(ISEA) - FACK = DTG - DCXX = - FACK * eDCXDX - DCXYYX = - FACK * ( eDCXDY + eDCYDX ) - DCYY = - FACK * eDCYDY - FKD = FACK * ( eCX*eDDDX + eCY*eDDDY ) + eCX = CX(ISEA) + eCY = CY(ISEA) + FACK = DTG + DCXX = - FACK * eDCXDX + DCXYYX = - FACK * ( eDCXDY + eDCYDX ) + DCYY = - FACK * eDCYDY + FKD = FACK * ( eCX*eDDDX + eCY*eDDDY ) -#ifdef W3_DEBUGDCXDX - sumDiff0=0 - sumDiff1=0 - sumDiff2=0 - sumDiff3=0 - sumDiff4=0 - sumDiff5=0 -#endif - DO ITH=1, NTH - FKC(ITH) = EC2(ITH)*DCXX + ESC(ITH)*DCXYYX + ES2(ITH)*DCYY -#ifdef W3_DEBUGDCXDX - sumDiff0 = sumDiff0 + MIN(EC2(ITH), ZERO) - sumDiff1 = sumDiff1 + MIN(DCXX, ZERO) - sumDiff2 = sumDiff2 + MIN(ESC(ITH), ZERO) - sumDiff3 = sumDiff3 + MIN(DCXYYX, ZERO) - sumDiff4 = sumDiff4 + MIN(ES2(ITH), ZERO) - sumDiff5 = sumDiff5 + MIN(DCYY, ZERO) -#endif - END DO -#ifdef W3_DEBUGDCXDX - WRITE(740+IAPROC,*) 'sumDiff0=', sumDiff0 - WRITE(740+IAPROC,*) 'sumDiff1=', sumDiff1 - WRITE(740+IAPROC,*) 'sumDiff2=', sumDiff2 - WRITE(740+IAPROC,*) 'sumDiff3=', sumDiff3 - WRITE(740+IAPROC,*) 'sumDiff4=', sumDiff4 - WRITE(740+IAPROC,*) 'sumDiff5=', sumDiff5 -#endif -! - DEPTH = MAX ( DMIN , DW(ISEA) ) - DO IK=0, NK+1 - IF ( DEPTH*WN(IK,ISEA) .LT. 5. ) THEN + if (w3_debugdcxdx_flag) then + sumDiff0=0 + sumDiff1=0 + sumDiff2=0 + sumDiff3=0 + sumDiff4=0 + sumDiff5=0 + end if + DO ITH=1, NTH + FKC(ITH) = EC2(ITH)*DCXX + ESC(ITH)*DCXYYX + ES2(ITH)*DCYY + if (w3_debugdcxdx_flag) then + sumDiff0 = sumDiff0 + MIN(EC2(ITH), ZERO) + sumDiff1 = sumDiff1 + MIN(DCXX, ZERO) + sumDiff2 = sumDiff2 + MIN(ESC(ITH), ZERO) + sumDiff3 = sumDiff3 + MIN(DCXYYX, ZERO) + sumDiff4 = sumDiff4 + MIN(ES2(ITH), ZERO) + sumDiff5 = sumDiff5 + MIN(DCYY, ZERO) + end if + END DO + if (w3_debugdcxdx_flag) then + WRITE(740+IAPROC,*) 'sumDiff0=', sumDiff0 + WRITE(740+IAPROC,*) 'sumDiff1=', sumDiff1 + WRITE(740+IAPROC,*) 'sumDiff2=', sumDiff2 + WRITE(740+IAPROC,*) 'sumDiff3=', sumDiff3 + WRITE(740+IAPROC,*) 'sumDiff4=', sumDiff4 + WRITE(740+IAPROC,*) 'sumDiff5=', sumDiff5 + end if + ! + DEPTH = MAX ( DMIN , DW(ISEA) ) + DO IK=0, NK+1 + IF ( DEPTH*WN(IK,ISEA) .LT. 5. ) THEN DSDD(IK) = MAX ( 0. , CG(IK,ISEA)*WN(IK,ISEA)-0.5*SIG(IK) ) / DEPTH - ELSE + ELSE DSDD(IK) = 0. - END IF - END DO - ISP = -NTH -#ifdef W3_DEBUGDCXDX - sumDiff=0 - sumDiff1=0 - sumDiff2=0 - sumDiff3=0 -#endif - DO IK=0, NK+1 - FKD0 = FKD / CG(IK,ISEA) * DSDD(IK) - DO ITH=1, NTH + END IF + END DO + ISP = -NTH + if (w3_debugdcxdx_flag) then + sumDiff=0 + sumDiff1=0 + sumDiff2=0 + sumDiff3=0 + end if + DO IK=0, NK+1 + FKD0 = FKD / CG(IK,ISEA) * DSDD(IK) + DO ITH=1, NTH ISP = ISP + 1 VCWN(ISP) = FKD0 + WN(IK,ISEA)*FKC(ITH) -#ifdef W3_DEBUGDCXDX - sumDiff = sumDiff + MAX(VCWN(ISP),ZERO) - sumDiff1 = sumDiff1 + MAX(FKD0,ZERO) - sumDiff2 = sumDiff2 + MAX(WN(IK,ISEA),ZERO) - sumDiff3 = sumDiff3 + MAX(FKC(ITH),ZERO) -#endif - END DO - END DO -#ifdef W3_DEBUGDCXDX - WRITE(740+IAPROC,*) 'sumDiff=', sumDiff - WRITE(740+IAPROC,*) 'sumDiff1=', sumDiff1 - WRITE(740+IAPROC,*) 'sumDiff2=', sumDiff2 - WRITE(740+IAPROC,*) 'sumDiff3=', sumDiff3 -#endif + if (w3_debugdcxdx_flag) then + sumDiff = sumDiff + MAX(VCWN(ISP),ZERO) + sumDiff1 = sumDiff1 + MAX(FKD0,ZERO) + sumDiff2 = sumDiff2 + MAX(WN(IK,ISEA),ZERO) + sumDiff3 = sumDiff3 + MAX(FKC(ITH),ZERO) + end if + END DO + END DO + if (w3_debugdcxdx_flag) then + WRITE(740+IAPROC,*) 'sumDiff=', sumDiff + WRITE(740+IAPROC,*) 'sumDiff1=', sumDiff1 + WRITE(740+IAPROC,*) 'sumDiff2=', sumDiff2 + WRITE(740+IAPROC,*) 'sumDiff3=', sumDiff3 + end if - sumDiff=0 - DO ISP=1-NTH,NSPEC - CWNB_M2(ISP) = DBLE(0.5 * ( VCWN(ISP) + VCWN(ISP+NTH) )) - sumDiff = sumDiff + MAX(CWNB_M2(ISP), ZERO) - END DO -#ifdef W3_DEBUGDCXDX - WRITE(740+IAPROC,*) 'sumDiff=', sumDiff -#endif - DO IK=1,NK - DWNI_M2(IK) = DBLE( CG(IK,ISEA) / DSIP(IK) ) - END DO -!/ -!/ End of JACOBI_INIT ------------------------------------------------ / -!/ - END SUBROUTINE -!/ ------------------------------------------------------------------- / - SUBROUTINE SYNCHRONIZE_IPGL_ETC_ARRAY(IMOD, IsMulti) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Sync global local arrays -! 2. Method : -! All the process need to have IPGL_tot and IPGL_TO_PROC -! This is especially the case for the output process. -! So we need some painful exportation business -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif + sumDiff=0 + DO ISP=1-NTH,NSPEC + CWNB_M2(ISP) = DBLE(0.5 * ( VCWN(ISP) + VCWN(ISP+NTH) )) + sumDiff = sumDiff + MAX(CWNB_M2(ISP), ZERO) + END DO + if (w3_debugdcxdx_flag) then + WRITE(740+IAPROC,*) 'sumDiff=', sumDiff + end if + DO IK=1,NK + DWNI_M2(IK) = DBLE( CG(IK,ISEA) / DSIP(IK) ) + END DO + !/ + END SUBROUTINE PROP_FREQ_SHIFT_M2 + !/ ------------------------------------------------------------------- / + SUBROUTINE SYNCHRONIZE_IPGL_ETC_ARRAY(IMOD, IsMulti) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Sync global local arrays + ! 2. Method : + ! All the process need to have IPGL_tot and IPGL_TO_PROC + ! This is especially the case for the output process. + ! So we need some painful exportation business + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / #ifdef W3_PDLIB - USE yowDatapool, only: istatus - USE yowNodepool, only: np_global - USE W3ODATMD, ONLY: NTPROC, NAPROC, IAPROC - USE W3GDATMD, ONLY: MAPSF, NSEA - USE W3ADATMD, ONLY: MPI_COMM_WAVE, MPI_COMM_WCMP - USE yowRankModule, only : IPGL_TO_PROC, IPGL_tot - USE WMMDATMD, ONLY: MDATAS + USE yowDatapool , only : istatus + USE yowNodepool , only : np_global + USE W3GDATMD , ONLY : MAPSF, NSEA + USE W3ADATMD , ONLY : MPI_COMM_WAVE, MPI_COMM_WCMP + USE yowRankModule , only : IPGL_TO_PROC, IPGL_tot + USE WMMDATMD , ONLY : MDATAS #endif - IMPLICIT NONE #ifdef W3_PDLIB - INCLUDE "mpif.h" -#endif - INTEGER, intent(in) :: IMOD - logical, intent(in) :: IsMulti -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif + INCLUDE "mpif.h" +#endif + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, intent(in) :: IMOD + logical, intent(in) :: IsMulti + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER, SAVE :: IENT = 0 ! W3_S #ifdef W3_PDLIB - INTEGER :: Iarr(1) - INTEGER :: ISEA, IP_glob - INTEGER :: IPROC, IERR_MPI, istat + INTEGER :: Iarr(1) + INTEGER :: ISEA, IP_glob + INTEGER :: IPROC, IERR_MPI, istat #endif + !/ + !/ ------------------------------------------------------------------- / -#ifdef W3_S - CALL STRACE (IENT, 'SYNCHRONIZE_IPGL_ETC_ARRAY') -#endif + if (w3_s_flag) then + CALL STRACE (IENT, 'SYNCHRONIZE_IPGL_ETC_ARRAY') + end if #ifdef W3_PDLIB - IF (IAPROC .le. NAPROC) THEN - IF (IAPROC .eq. 1) THEN - Iarr(1)=np_global - DO IPROC=NAPROC+1,NTPROC - CALL MPI_SEND(Iarr,1,MPI_INT, IPROC-1, 37, MPI_COMM_WAVE, IERR_MPI) - END DO - DO IPROC=NAPROC+1,NTPROC - CALL MPI_SEND(ipgl_tot,np_global,MPI_INT, IPROC-1, 43, MPI_COMM_WAVE, IERR_MPI) - CALL MPI_SEND(ipgl_to_proc,np_global,MPI_INT, IPROC-1, 91, MPI_COMM_WAVE, IERR_MPI) + IF (IAPROC .le. NAPROC) THEN + IF (IAPROC .eq. 1) THEN + Iarr(1)=np_global + DO IPROC=NAPROC+1,NTPROC + CALL MPI_SEND(Iarr,1,MPI_INT, IPROC-1, 37, MPI_COMM_WAVE, IERR_MPI) + END DO + DO IPROC=NAPROC+1,NTPROC + CALL MPI_SEND(ipgl_tot,np_global,MPI_INT, IPROC-1, 43, MPI_COMM_WAVE, IERR_MPI) + CALL MPI_SEND(ipgl_to_proc,np_global,MPI_INT, IPROC-1, 91, MPI_COMM_WAVE, IERR_MPI) + END DO + END IF + ELSE + CALL MPI_RECV(Iarr,1,MPI_INT, 0, 37, MPI_COMM_WAVE, istatus, IERR_MPI) + np_global=Iarr(1) + allocate(IPGL_tot(np_global), IPGL_TO_PROC(np_global), stat=istat) + CALL MPI_RECV(ipgl_tot,np_global,MPI_INT, 0, 43, MPI_COMM_WAVE, istatus, IERR_MPI) + CALL MPI_RECV(ipgl_to_proc,np_global,MPI_INT, 0, 91, MPI_COMM_WAVE, istatus, IERR_MPI) + END IF + IF (IsMulti) THEN + WRITE(*,*) ' Before allocation of MDATAS % SEA_IPGL, SEA_IPGL_TO_PROC : IMOD=', IMOD, ' NSEA=', NSEA + ALLOCATE(MDATAS(IMOD)%SEA_IPGL(NSEA), MDATAS(IMOD)%SEA_IPGL_TO_PROC(NSEA), STAT=ISTAT) + !CHECK_ALLOC_STATUS ( ISTAT ) + DO ISEA=1,NSEA + IP_glob = MAPSF(ISEA, 1) + MDATAS(IMOD)%SEA_IPGL(ISEA) = IPGL_tot(IP_glob) + MDATAS(IMOD)%SEA_IPGL_TO_PROC(ISEA) = IPGL_TO_PROC(IP_glob) END DO - END IF - ELSE - CALL MPI_RECV(Iarr,1,MPI_INT, 0, 37, MPI_COMM_WAVE, istatus, IERR_MPI) - np_global=Iarr(1) - allocate(IPGL_tot(np_global), IPGL_TO_PROC(np_global), stat=istat) - CALL MPI_RECV(ipgl_tot,np_global,MPI_INT, 0, 43, MPI_COMM_WAVE, istatus, IERR_MPI) - CALL MPI_RECV(ipgl_to_proc,np_global,MPI_INT, 0, 91, MPI_COMM_WAVE, istatus, IERR_MPI) - END IF - IF (IsMulti) THEN - WRITE(*,*) ' Before allocation of MDATAS % SEA_IPGL, SEA_IPGL_TO_PROC : IMOD=', IMOD, ' NSEA=', NSEA - ALLOCATE(MDATAS(IMOD)%SEA_IPGL(NSEA), MDATAS(IMOD)%SEA_IPGL_TO_PROC(NSEA), STAT=ISTAT) - !CHECK_ALLOC_STATUS ( ISTAT ) - DO ISEA=1,NSEA - IP_glob = MAPSF(ISEA, 1) - MDATAS(IMOD)%SEA_IPGL(ISEA) = IPGL_tot(IP_glob) - MDATAS(IMOD)%SEA_IPGL_TO_PROC(ISEA) = IPGL_TO_PROC(IP_glob) - END DO - END IF -#endif -!/ -!/ End of JACOBI_INIT ------------------------------------------------ / -!/ - END SUBROUTINE -!/ ....................----------------------------------------------- / - SUBROUTINE SET_UP_NSEAL_NSEALM(NSEALout, NSEALMout) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Setup nseal, nsealm in contect of pdlib -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ -!/ ------------------------------------------------------------------- / + END IF +#endif + !/ + END SUBROUTINE SYNCHRONIZE_IPGL_ETC_ARRAY + !/ ....................----------------------------------------------- / + SUBROUTINE SET_UP_NSEAL_NSEALM(NSEALout, NSEALMout) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Setup nseal, nsealm in contect of pdlib + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / #ifdef W3_PDLIB - use yowDatapool, only: istatus - use yowNodepool, only: npa - use yowRankModule, only : rank - USE W3GDATMD, ONLY: GTYPE, UNGTYPE + use yowDatapool , only : istatus + use yowNodepool , only : npa + use yowRankModule , only : rank + USE W3GDATMD , ONLY : GTYPE, UNGTYPE #endif #ifdef W3_MPI - USE W3ADATMD, ONLY: MPI_COMM_WAVE, MPI_COMM_WCMP -#endif - USE CONSTANTS, ONLY : LPDLIB - USE W3GDATMD, ONLY: NSEA - USE W3ODATMD, ONLY: NTPROC, NAPROC, IAPROC - IMPLICIT NONE - INTEGER, intent(out) :: NSEALout, NSEALMout -!/ Local parameters -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'SET_UP_NSEAL_NSEALM') -#endif -!!/PDLIB WRITE(*,*) 'LPDLIB=', LPDLIB -!!/PDLIB WRITE(*,*) 'GTYPE=', GTYPE, ' UNGTYPE=', UNGTYPE -#ifdef W3_DEBUG - WRITE(740+IAPROC,*) 'SET_UP, PDLIB=', LPDLIB - FLUSH(740+IAPROC) + USE W3ADATMD , ONLY : MPI_COMM_WAVE, MPI_COMM_WCMP #endif + USE W3GDATMD , ONLY : NSEA + + !/ ------------------------------------------------------------------- / + !/ Parameter list + INTEGER, intent(out) :: NSEALout, NSEALMout + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER, SAVE :: IENT = 0 ! W3_S + !/ ------------------------------------------------------------------- / + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'SET_UP_NSEAL_NSEALM') + end if + !!/PDLIB WRITE(*,*) 'LPDLIB=', LPDLIB + !!/PDLIB WRITE(*,*) 'GTYPE=', GTYPE, ' UNGTYPE=', UNGTYPE + if (w3_debug_flag) then + WRITE(740+IAPROC,*) 'SET_UP, PDLIB=', LPDLIB + FLUSH(740+IAPROC) + end if #ifdef W3_SHRD - NSEALout = NSEA - NSEALMout = NSEA + NSEALout = NSEA + NSEALMout = NSEA #endif -! + ! #ifdef W3_DIST - IF (.NOT. LPDLIB ) THEN - IF ( IAPROC .LE. NAPROC ) THEN + IF (.NOT. LPDLIB ) THEN + IF ( IAPROC .LE. NAPROC ) THEN NSEALout = 1 + (NSEA-IAPROC)/NAPROC - ELSE + ELSE NSEALout = 0 - END IF - NSEALMout = 1 + (NSEA-1)/NAPROC - ELSE + END IF + NSEALMout = 1 + (NSEA-1)/NAPROC + ELSE #endif #ifdef W3_PDLIB IF (GTYPE .eq. UNGTYPE) THEN - NSEALout = PDLIB_NSEAL - NSEALMout = PDLIB_NSEALM + NSEALout = PDLIB_NSEAL + NSEALMout = PDLIB_NSEALM ELSE - IF ( IAPROC .LE. NAPROC ) THEN - NSEALout = 1 + (NSEA-IAPROC)/NAPROC - ELSE - NSEALout = 0 - END IF - NSEALMout = 1 + (NSEA-1)/NAPROC + IF ( IAPROC .LE. NAPROC ) THEN + NSEALout = 1 + (NSEA-IAPROC)/NAPROC + ELSE + NSEALout = 0 + END IF + NSEALMout = 1 + (NSEA-1)/NAPROC ENDIF #endif #ifdef W3_DIST - ENDIF -#endif -!/ -!/ End of JACOBI_INIT ------------------------------------------------ / -!/ - END SUBROUTINE -!/ ------------------------------------------------------------------- / - SUBROUTINE INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) -!/ ------------------------------------------------------------------- / -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Set Jsea for all schemes -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ - USE W3ODATMD, ONLY: OUTPTS, IAPROC, NAPROC - USE W3GDATMD, ONLY: GTYPE, UNGTYPE, MAPSF - USE CONSTANTS, ONLY : LPDLIB + ENDIF +#endif + !/ + END SUBROUTINE SET_UP_NSEAL_NSEALM + !/ ------------------------------------------------------------------- / + SUBROUTINE INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) + !/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Set Jsea for all schemes + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE W3GDATMD , ONLY : GTYPE, UNGTYPE, MAPSF #ifdef W3_PDLIB - USE yowRankModule, only : IPGL_TO_PROC, IPGL_tot - use yowNodepool, only: ipgl, iplg + USE yowRankModule , only : IPGL_TO_PROC, IPGL_tot + use yowNodepool , only : ipgl, iplg #endif - IMPLICIT NONE -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / - INTEGER, intent(in) :: ISEA - INTEGER, intent(out) :: JSEA, ISPROC - INTEGER IP_glob -#ifdef W3_S - CALL STRACE (IENT, 'INIT_GET_JSEA_ISPROC') -#endif -!!/DEBUG WRITE(740+IAPROC,*) 'PDLIB=', PDLIB -!!/DEBUG WRITE(740+IAPROC,*) 'GTYPE=', GTYPE, ' UNGTYPE=', UNGTYPE -!!/DEBUG FLUSH(740+IAPROC) - IF (.NOT. LPDLIB) THEN - JSEA = 1 + (ISEA-1)/NAPROC - ISPROC = ISEA - (JSEA-1)*NAPROC - ELSE + !/ ------------------------------------------------------------------- / + !/ Parameter list + + INTEGER, intent(in) :: ISEA + INTEGER, intent(out) :: JSEA, ISPROC + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: IP_glob + INTEGER, SAVE :: IENT = 0 ! W3_S + !/ + !/ ------------------------------------------------------------------- / + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'INIT_GET_JSEA_ISPROC') + end if + !!/DEBUG WRITE(740+IAPROC,*) 'PDLIB=', PDLIB + !!/DEBUG WRITE(740+IAPROC,*) 'GTYPE=', GTYPE, ' UNGTYPE=', UNGTYPE + !!/DEBUG FLUSH(740+IAPROC) + IF (.NOT. LPDLIB) THEN + JSEA = 1 + (ISEA-1)/NAPROC + ISPROC = ISEA - (JSEA-1)*NAPROC + ELSE #ifdef W3_PDLIB - IF (GTYPE .ne. UNGTYPE) THEN - JSEA = 1 + (ISEA-1)/NAPROC - ISPROC = ISEA - (JSEA-1)*NAPROC - ELSE - IP_glob = MAPSF(ISEA,1) - IF (IAPROC .le. NAPROC) THEN - JSEA = ISEA_TO_JSEA(ISEA) - ELSE - JSEA = -1 - END IF - ISPROC = IPGL_TO_PROC(IP_glob) - ENDIF -#endif - ENDIF -!/ -!/ End of JACOBI_INIT ------------------------------------------------ / -!/ - END SUBROUTINE -!/ ------------------------------------------------------------------- / - SUBROUTINE GET_JSEA_IBELONG(ISEA, JSEA, IBELONG) -!/ ------------------------------------------------------------------- / -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Set belongings of jsea in context of pdlib -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE + IF (GTYPE .ne. UNGTYPE) THEN + JSEA = 1 + (ISEA-1)/NAPROC + ISPROC = ISEA - (JSEA-1)*NAPROC + ELSE + IP_glob = MAPSF(ISEA,1) + IF (IAPROC .le. NAPROC) THEN + JSEA = ISEA_TO_JSEA(ISEA) + ELSE + JSEA = -1 + END IF + ISPROC = IPGL_TO_PROC(IP_glob) + ENDIF #endif -!/ - USE W3ODATMD, ONLY: OUTPTS, IAPROC, NAPROC - USE W3GDATMD, ONLY: GTYPE, UNGTYPE, MAPSF - USE CONSTANTS, ONLY : LPDLIB + ENDIF + !/ + END SUBROUTINE INIT_GET_JSEA_ISPROC + !/ ------------------------------------------------------------------- / + SUBROUTINE GET_JSEA_IBELONG(ISEA, JSEA, IBELONG) + !/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Set belongings of jsea in context of pdlib + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE W3GDATMD , ONLY : GTYPE, UNGTYPE, MAPSF #ifdef W3_PDLIB - USE yowRankModule, only : IPGL_TO_PROC, IPGL_tot, IPGL_npa - use yowNodepool, only: ipgl, iplg -#endif - IMPLICIT NONE -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ - INTEGER, intent(in) :: ISEA - INTEGER, intent(out) :: JSEA, IBELONG - INTEGER ISPROC, IX, JX -#ifdef W3_S - CALL STRACE (IENT, 'GET_JSEA_IBELONG') -#endif - IF (.NOT. LPDLIB) THEN - JSEA = 1 + (ISEA-1)/NAPROC - ISPROC = ISEA - (JSEA-1)*NAPROC - IF (ISPROC .eq. IAPROC) THEN + USE yowRankModule , only : IPGL_TO_PROC, IPGL_tot, IPGL_npa + use yowNodepool , only : ipgl, iplg +#endif + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER , intent(in) :: ISEA + INTEGER , intent(out) :: JSEA, IBELONG + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ISPROC, IX, JX + INTEGER, SAVE :: IENT = 0 ! W3_S + !/ ------------------------------------------------------------------- / + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'GET_JSEA_IBELONG') + end if + IF (.NOT. LPDLIB) THEN + JSEA = 1 + (ISEA-1)/NAPROC + ISPROC = ISEA - (JSEA-1)*NAPROC + IF (ISPROC .eq. IAPROC) THEN IBELONG=1 - ELSE + ELSE IBELONG=0 - END IF - ELSE + END IF + ELSE #ifdef W3_PDLIB - IF (GTYPE .ne. UNGTYPE) THEN - JSEA = 1 + (ISEA-1)/NAPROC - ISPROC = ISEA - (JSEA-1)*NAPROC - IF (ISPROC .eq. IAPROC) THEN - IBELONG=1 - ELSE - IBELONG=0 - END IF - ELSE - IF (IAPROC .le. NAPROC) THEN - IX = MAPSF(ISEA,1) - JX = IPGL_npa(IX) - IF (JX .eq. 0) THEN - IBELONG=0 - JSEA=-1 + IF (GTYPE .ne. UNGTYPE) THEN + JSEA = 1 + (ISEA-1)/NAPROC + ISPROC = ISEA - (JSEA-1)*NAPROC + IF (ISPROC .eq. IAPROC) THEN + IBELONG=1 ELSE - IBELONG=1 - JSEA = JX_TO_JSEA(JX) + IBELONG=0 END IF - ELSE - IBELONG=0 - JSEA=-1 - END IF - ENDIF -#endif - ENDIF -!/ -!/ End of INIT_GET_ISEA ---------------------------------------------- / -!/ - END SUBROUTINE -!/ ------------------------------------------------------------------- / - SUBROUTINE INIT_GET_ISEA(ISEA, JSEA) -!/ ------------------------------------------------------------------- / -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Set Isea for all schemes -! 2. Method : -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ - USE W3ODATMD, ONLY: OUTPTS, IAPROC, NAPROC - USE W3GDATMD, ONLY: GTYPE, UNGTYPE - USE CONSTANTS, ONLY : LPDLIB -#ifdef W3_PDLIB - USE YOWNODEPOOL, ONLY: iplg + ELSE + IF (IAPROC .le. NAPROC) THEN + IX = MAPSF(ISEA,1) + JX = IPGL_npa(IX) + IF (JX .eq. 0) THEN + IBELONG=0 + JSEA=-1 + ELSE + IBELONG=1 + JSEA = JX_TO_JSEA(JX) + END IF + ELSE + IBELONG=0 + JSEA=-1 + END IF + ENDIF #endif -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -!/ ------------------------------------------------------------------- / -!/ -!/ -!/ ------------------------------------------------------------------- / -!/ -!/ ------------------------------------------------------------------- / -! - USE W3ODATMD, ONLY: OUTPTS, IAPROC, NAPROC - USE W3GDATMD, ONLY: GTYPE, UNGTYPE - USE CONSTANTS, ONLY : LPDLIB + ENDIF + !/ + !/ End of INIT_GET_ISEA ---------------------------------------------- / + !/ + END SUBROUTINE GET_JSEA_IBELONG + !/ ------------------------------------------------------------------- / + SUBROUTINE INIT_GET_ISEA(ISEA, JSEA) + !/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Set Isea for all schemes + ! 2. Method : + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + USE W3GDATMD , ONLY : GTYPE, UNGTYPE #ifdef W3_PDLIB - USE YOWNODEPOOL, ONLY: iplg -#endif - IMPLICIT NONE -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - INTEGER, intent(in) :: JSEA - INTEGER, intent(out) :: ISEA -#ifdef W3_S - CALL STRACE (IENT, 'INIT_GET_ISEA') -#endif + USE YOWNODEPOOL, ONLY : iplg +#endif + !/ ------------------------------------------------------------------- / + !/ Parameter list + INTEGER , intent(in) :: JSEA + INTEGER , intent(out) :: ISEA + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER, SAVE :: IENT = 0 ! W3_S + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + ! + if (w3_s_flag) then + CALL STRACE (IENT, 'INIT_GET_ISEA') + end if #ifdef W3_SHRD - ISEA = JSEA + ISEA = JSEA #endif #ifdef W3_DIST - IF (.NOT. LPDLIB) THEN - ISEA = IAPROC + (JSEA-1)*NAPROC - ELSE + IF (.NOT. LPDLIB) THEN + ISEA = IAPROC + (JSEA-1)*NAPROC + ELSE #endif #ifdef W3_PDLIB - IF (GTYPE .eq. UNGTYPE) THEN - ISEA = iplg(JSEA) - ELSE - ISEA = IAPROC + (JSEA-1)*NAPROC - ENDIF + IF (GTYPE .eq. UNGTYPE) THEN + ISEA = iplg(JSEA) + ELSE + ISEA = IAPROC + (JSEA-1)*NAPROC + ENDIF #endif #ifdef W3_DIST - ENDIF -#endif -!/ -!/ End of INIT_GET_ISEA ------------------------------------------------ / -!/ - END SUBROUTINE -!********************************************************************** -!* An array of size (NSEA) is send but only the (1:NSEAL) values * -!* are correct. The program synchonizes everything on all nodes. * -!********************************************************************** - SUBROUTINE SYNCHRONIZE_GLOBAL_ARRAY(TheVar) -!/ ------------------------------------------------------------------- / -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | | -!/ | Aron Roland (BGS IT&E GmbH) | -!/ | Mathieu Dutour-Sikiric (IRB) | -!/ | | -!/ | FORTRAN 90 | -!/ | Last update : 01-June-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-June-2018 : Origination. ( version 6.04 ) -!/ -! 1. Purpose : Sync global array in context of pdlib -! 2. Method : -! An array of size (NSEA) is send but only the (1:NSEAL) values -! are correct. The program synchonizes everything on all nodes. -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! ---------------------------------------------------------------- -! -! 6. Error messages : -! 7. Remarks -! 8. Structure : -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -! - USE W3GDATMD, ONLY: NSEAL, NSEA, NX + ENDIF +#endif + !/ + !/ End of INIT_GET_ISEA ------------------------------------------------ / + !/ + END SUBROUTINE INIT_GET_ISEA + !********************************************************************** + !* An array of size (NSEA) is send but only the (1:NSEAL) values * + !* are correct. The program synchonizes everything on all nodes. * + !********************************************************************** + SUBROUTINE SYNCHRONIZE_GLOBAL_ARRAY(TheVar) + !/ ------------------------------------------------------------------- / + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | | + !/ | Aron Roland (BGS IT&E GmbH) | + !/ | Mathieu Dutour-Sikiric (IRB) | + !/ | | + !/ | FORTRAN 90 | + !/ | Last update : 01-June-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-June-2018 : Origination. ( version 6.04 ) + !/ + ! 1. Purpose : Sync global array in context of pdlib + ! 2. Method : + ! An array of size (NSEA) is send but only the (1:NSEAL) values + ! are correct. The program synchonizes everything on all nodes. + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! 7. Remarks + ! 8. Structure : + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! + USE W3GDATMD , ONLY : NSEAL, NSEA, NX #ifdef W3_PDLIB - USE W3ODATMD, only : IAPROC, NAPROC, NTPROC - USE W3ADATMD, ONLY: MPI_COMM_WCMP - use yowDatapool, only: rtype, istatus - USE yowNodepool, only: npa - use yowNodepool, only: iplg -#endif - IMPLICIT NONE -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ + USE W3ADATMD , ONLY : MPI_COMM_WCMP + use yowDatapool , only : rtype, istatus + USE yowNodepool , only : npa + use yowNodepool , only : iplg +#endif + !/ ------------------------------------------------------------------- / + !/ Parameter list + REAL*8, intent(inout) :: TheVar(NX) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER, SAVE :: IENT = 0 ! W3_S + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_MPI - INCLUDE "mpif.h" -#endif - INTEGER ISEA, JSEA, Status(NX), rStatus(NX) - INTEGER IPROC, I, ierr, IP, IX, IP_glob - REAL*8, intent(inout) :: TheVar(NX) - REAL*8 rVect(NX) - Status=0 -#ifdef W3_S - CALL STRACE (IENT, 'SYNCHRONIZE_GLOBAL_ARRAY') + INCLUDE "mpif.h" #endif + INTEGER :: ISEA, JSEA, Status(NX), rStatus(NX) + INTEGER :: IPROC, I, ierr, IP, IX, IP_glob + REAL*8 :: rVect(NX) + + Status=0 + if (w3_s_flag) then + CALL STRACE (IENT, 'SYNCHRONIZE_GLOBAL_ARRAY') + end if #ifdef W3_PDLIB - DO IP=1,npa - IP_glob=iplg(IP) - Status(IP_glob)=1 - END DO - IF (IAPROC .eq. 1) THEN - DO iProc=2,NAPROC + DO IP=1,npa + IP_glob=iplg(IP) + Status(IP_glob)=1 + END DO + IF (IAPROC .eq. 1) THEN + DO iProc=2,NAPROC CALL MPI_RECV(rVect,NX,rtype, iProc-1, 19, MPI_COMM_WCMP, istatus, ierr) CALL MPI_RECV(rStatus,NX,MPI_INTEGER, iProc-1, 23, MPI_COMM_WCMP, istatus, ierr) DO I=1,NX - IF (rStatus(I) .eq. 1) THEN - TheVar(I)=rVect(I) - Status(I)=1 - END IF + IF (rStatus(I) .eq. 1) THEN + TheVar(I)=rVect(I) + Status(I)=1 + END IF END DO - END DO - DO IPROC=2,NAPROC + END DO + DO IPROC=2,NAPROC CALL MPI_SEND(TheVar,NX,rtype, iProc-1, 29, MPI_COMM_WCMP, ierr) - END DO - ELSE - CALL MPI_SEND(TheVar,NX,rtype, 0, 19, MPI_COMM_WCMP, ierr) - CALL MPI_SEND(Status,NX,MPI_INTEGER, 0, 23, MPI_COMM_WCMP, ierr) - CALL MPI_RECV(TheVar,NX,rtype, 0, 29, MPI_COMM_WCMP, istatus, ierr) - END IF -#endif -!/ -!/ End of JACOBI_INIT ------------------------------------------------ / -!/ - END SUBROUTINE -!/ ------------------------------------------------------------------- / - END MODULE W3PARALL + END DO + ELSE + CALL MPI_SEND(TheVar,NX,rtype, 0, 19, MPI_COMM_WCMP, ierr) + CALL MPI_SEND(Status,NX,MPI_INTEGER, 0, 23, MPI_COMM_WCMP, ierr) + CALL MPI_RECV(TheVar,NX,rtype, 0, 29, MPI_COMM_WCMP, istatus, ierr) + END IF +#endif + !/ + END SUBROUTINE SYNCHRONIZE_GLOBAL_ARRAY + !/ ------------------------------------------------------------------- / +END MODULE W3PARALL !/ ------------------------------------------------------------------- / - diff --git a/model/src/w3profsmd_pdlib.F90 b/model/src/w3profsmd_pdlib.F90 index 5e41d62336..f5256496d6 100644 --- a/model/src/w3profsmd_pdlib.F90 +++ b/model/src/w3profsmd_pdlib.F90 @@ -5623,10 +5623,7 @@ SUBROUTINE ADD_SOURCE_TERMS_NONLINEAR(DTG) #endif #ifdef W3_TR1 - CALL W3STR1 ( SPEC_VA, SPEC_VA, CG1, WN1, DEPTH, IX,VSTR, VDTR ) -#endif -#ifdef W3_TRX - CALL W3STRX + CALL W3STR1 ( SPEC_VA, CG1, WN1, DEPTH, IX,VSTR, VDTR ) #endif #ifdef W3_TRX CALL W3STRX diff --git a/model/src/w3servmd.F90 b/model/src/w3servmd.F90 index a9ca658266..f56d0016bc 100644 --- a/model/src/w3servmd.F90 +++ b/model/src/w3servmd.F90 @@ -1,2071 +1,2036 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3SERVMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 15-Jan-2021 | -!/ +-----------------------------------+ -!/ -!/ For update log see individual subroutines. -!/ 12-Jun-2012 : Add /RTD option or rotated grid option. -!/ (Jian-Guo Li) ( version 4.06 ) -!/ 11-Nov-2013 : SMC and rotated grid incorporated in the main -!/ trunk ( version 4.13 ) -!/ 18-Aug-2016 : Add dist_sphere: angular distance ( version 5.11 ) -!/ 01-Mar-2016 : Added W3THRTN and W3XYRTN for post ( version 6.02 ) -!/ processing rotated grid data -!/ 15-Jan-2021 : Added UV_TO_MAG_DIR routine ( version 7.12 ) -!/ -!/ Copyright 2009-2012 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! In this module all WAVEWATCH specific service routines have -! been gathered. -! -! 2. Variables and types : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! NDSTRC Int. Private Data set number for output of STRACE -! (set in ITRACE). -! NTRACE Int. Private Maximum number of trace prints in -! strace (set in ITRACE). -! ---------------------------------------------------------------- -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! ITRACE Subr. Public (Re-) Initialization for STRACE. -! STRACE Subr. Public Enable subroutine tracing, usually -! activated with the !/S switch. -! NEXTLN Subr. Public Get to next line in input command file. -! W3S2XY Subr. Public Grid conversion routine. -! EJ5P R.F. Public Five parameter JONSWAP spectrum. -! WWDATE Subr. Public Get system date. -! WWTIME Subr. Public Get system time. -! EXTCDE Subr. Public Abort program with exit code. -! Four subs for rotated grid are appended to this module. As they -! are shared with SMC grid, they are not quoted by option /RTD but -! are available for general use. JGLi12Jun2012 -! W3SPECTN turns wave spectrum anti-clockwise by AnglD -! W3ACTURN turns wave action(k,nth) anti-clockwise by AnglD. -! W3LLTOEQ convert standard into rotated lat/lon, plus AnglD -! W3EQTOLL revers of the LLTOEQ, but AnglD unchanged. -! W3THTRN turns direction value anti-clockwise by AnglD -! W3XYTRN turns 2D vectors anti-clockwise by AnglD -! -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! None. -! -! 5. Remarks : -! -! 6. Switches -! -! !/S Enable subroutine tracing using STRACE in this module. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / - PUBLIC -! - INTEGER, PRIVATE :: NDSTRC = 6, NTRACE = 0 -! - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE ITRACE (NDS, NMAX) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 23-Nov-1999 | -!/ +-----------------------------------+ -!/ -!/ 23-Nov-1999 : First version of routine. ( version 2.00 ) -!/ -! 1. Purpose : -! -! (Re-) initialization for module version of STRACE. -! -! 3. Parameter list -! ---------------------------------------------------------------- -! NDS Int. I Data set number ofr trace file. -! NMAX Int. I Maximum number of traces per routine. -! ---------------------------------------------------------------- -! -! Private to module : -! ---------------------------------------------------------------- -! NDSTRC Int. Output unit number for trace. ( from NDS ) -! NTRACE Int. Maximum number of trace prints. ( from NMAX ) -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! None. -! -! 5. Called by : -! -! Any program, multiple calls allowed. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDS, NMAX -!/ -!/ ------------------------------------------------------------------- / -!/ - NTRACE = MAX ( 0 , NMAX ) - NDSTRC = NDS -! - RETURN -!/ -!/ End of ITRACE ----------------------------------------------------- / -!/ - END SUBROUTINE ITRACE -!/ ------------------------------------------------------------------- / - SUBROUTINE STRACE (IENT, SNAME) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 25-Jan-2000 | -!/ +-----------------------------------+ -!/ Original version by N. Booij, DUT -!/ -!/ 30-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) -!/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 25-Jan-2000 : Force flushing of uniit. ( version 2.00 ) -!/ This was taken out around version 3.01. -!/ -! 1. Purpose : -! -! Keep track of entered subroutines. -! -! 3. Parameter list -! ---------------------------------------------------------------- -! IENT Int. I/O Number of times that STRACE has been -! called by the routine. -! SNAME Char. I Name of the subroutine (max. 6 characters) -! ---------------------------------------------------------------- -! -! Private to module : -! ---------------------------------------------------------------- -! NDSTRC Int. Output unit number for trace. -! NTRACE Int. Maximum number of trace prints. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! None. -! -! 5. Called by : -! -! Any program, after private variables have been set by NTRACE. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(INOUT) :: IENT - CHARACTER, INTENT(IN) :: SNAME*(*) -!/ -!/ ------------------------------------------------------------------- / -!/ - IF (NTRACE.EQ.0 .OR. IENT.GE.NTRACE) RETURN -! - IENT = IENT + 1 - IF (IENT.EQ.1) THEN - WRITE (NDSTRC,10) SNAME - ELSE - WRITE (NDSTRC,11) SNAME, IENT - END IF -! - RETURN -! -! Formats -! - 10 FORMAT (' ---> TRACE SUBR : ',A6) - 11 FORMAT (' ---> TRACE SUBR : ',A6,' ENTRY: ',I6) -!/ -!/ End of STRACE ----------------------------------------------------- / -!/ - END SUBROUTINE STRACE -!/ ------------------------------------------------------------------- / - SUBROUTINE NEXTLN ( CHCKC , NDSI , NDSE ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 10-Dec-2014 | -!/ +-----------------------------------+ -!/ -!/ 15-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) -!/ 18-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 10-Dec-2014 : Skip blank lines and leading blanks ( version 5.04 ) -!/ -! 1. Purpose : -! -! Sets file pointer to next active line of input file, by skipping -! blank lines and lines starting with the character CHCKC. Leading -! white space is allowed before the character CHCKC. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! CHCKC C*1 I Check character for defining comment line. -! NDSI Int. I Input dataset number. -! NDSE Int. I Error output dataset number. -! (No output if NDSE < 0). -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! STRACE ( !/S switch ) -! -! 5. Called by : -! -! Any routine. -! -! 6. Error messages : -! -! - On EOF or error in input file. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NDSI, NDSE - CHARACTER, INTENT(IN) :: CHCKC*1 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ +MODULE W3SERVMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 15-Jan-2021 | + !/ +-----------------------------------+ + !/ + !/ For update log see individual subroutines. + !/ 12-Jun-2012 : Add /RTD option or rotated grid option. + !/ (Jian-Guo Li) ( version 4.06 ) + !/ 11-Nov-2013 : SMC and rotated grid incorporated in the main + !/ trunk ( version 4.13 ) + !/ 18-Aug-2016 : Add dist_sphere: angular distance ( version 5.11 ) + !/ 01-Mar-2016 : Added W3THRTN and W3XYRTN for post ( version 6.02 ) + !/ processing rotated grid data + !/ 15-Jan-2021 : Added UV_TO_MAG_DIR routine ( version 7.12 ) + !/ + !/ Copyright 2009-2012 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! In this module all WAVEWATCH specific service routines have + ! been gathered. + ! + ! 2. Variables and types : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! NDSTRC Int. Private Data set number for output of STRACE + ! (set in ITRACE). + ! NTRACE Int. Private Maximum number of trace prints in + ! strace (set in ITRACE). + ! ---------------------------------------------------------------- + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! ITRACE Subr. Public (Re-) Initialization for STRACE. + ! STRACE Subr. Public Enable subroutine tracing, usually + ! activated with the !/S switch. + ! NEXTLN Subr. Public Get to next line in input command file. + ! W3S2XY Subr. Public Grid conversion routine. + ! EJ5P R.F. Public Five parameter JONSWAP spectrum. + ! WWDATE Subr. Public Get system date. + ! WWTIME Subr. Public Get system time. + ! EXTCDE Subr. Public Abort program with exit code. + ! Four subs for rotated grid are appended to this module. As they + ! are shared with SMC grid, they are not quoted by option /RTD but + ! are available for general use. JGLi12Jun2012 + ! W3SPECTN turns wave spectrum anti-clockwise by AnglD + ! W3ACTURN turns wave action(k,nth) anti-clockwise by AnglD. + ! W3LLTOEQ convert standard into rotated lat/lon, plus AnglD + ! W3EQTOLL revers of the LLTOEQ, but AnglD unchanged. + ! W3THTRN turns direction value anti-clockwise by AnglD + ! W3XYTRN turns 2D vectors anti-clockwise by AnglD + ! + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! None. + ! + ! 5. Remarks : + ! + ! 6. Switches + ! + ! !/S Enable subroutine tracing using STRACE in this module. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + + ! module default + IMPLICIT NONE + + PUBLIC + ! #ifdef W3_S - INTEGER, SAVE :: IENT = 0 + logical, parameter :: w3_s_flag = .true. !< @public a flag for "W3_S" +#else + logical, parameter :: w3_s_flag = .false. !< @public a flag for "W3_S" #endif - INTEGER :: IERR - CHARACTER(128) :: MSG - CHARACTER(256) :: LINE, TEST -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'NEXTLN') -#endif -! - 100 CONTINUE - ! read line - READ ( NDSI, 900, END=800, ERR=801, IOSTAT=IERR, IOMSG=MSG ) LINE - ! leading blanks removed and placed on the right - TEST = ADJUSTL ( LINE ) - IF ( TEST(1:1).EQ.CHCKC .OR. LEN_TRIM(TEST).EQ.0 ) THEN - ! if comment or blank line, then skip - GOTO 100 - ELSE - ! otherwise, backup to beginning of line - BACKSPACE ( NDSI, ERR=802, IOSTAT=IERR, IOMSG=MSG ) - ENDIF - RETURN -! - 800 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,910) - CALL EXTCDE ( 1 ) -! - 801 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,911) IERR, TRIM(MSG) - CALL EXTCDE ( 2 ) -! - 802 CONTINUE - IF ( NDSE .GE. 0 ) WRITE (NDSE,912) IERR, TRIM(MSG) - CALL EXTCDE ( 3 ) -! -! Formats -! - 900 FORMAT (A) - 910 FORMAT (/' *** WAVEWATCH III ERROR IN NEXTLN : '/ & - ' PREMATURE END OF INPUT FILE'/) - 911 FORMAT (/' *** WAVEWATCH III ERROR IN NEXTLN : '/ & - ' ERROR IN READING FROM FILE'/ & - ' IOSTAT =',I5,/ & - ' IOMSG = ',A/) - 912 FORMAT (/' *** WAVEWATCH III ERROR IN NEXTLN : '/ & - ' ERROR ON BACKSPACE'/ & - ' IOSTAT =',I5,/ & - ' IOMSG = ',A/) -!/ -!/ End of NEXTLN ----------------------------------------------------- / -!/ - END SUBROUTINE NEXTLN -!/ ------------------------------------------------------------------- / - SUBROUTINE W3S2XY ( NSEA, MSEA, MX, MY, S, MAPSF, XY ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NMC | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 23-Nov-1999 | -!/ +-----------------------------------+ -!/ -!/ 11-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) -!/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ -! 1. Purpose : -! -! Convert a data array on the storage grid to a data array on the -! full spatial grid. Land and ice points in the full grid are -! not touched. Output array of conventional type XY(IX,IY). -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! NSEA Int. I Number of sea points. -! MSEA, MX, MY -! Int. I Array dimensions. -! S R.A. I Data on storage grid. -! MAPSF I.A. I Storage map for IX and IY, resp. -! XY R.A. O Data on XY grid. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! None. -! -! 5. Called by : -! -! Any WAVEWATCH III routine. -! -! 9. Switches : -! -! None. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: MSEA, NSEA, MX, MY, MAPSF(MSEA,2) - REAL, INTENT(IN) :: S(MSEA) - REAL, INTENT(OUT) :: XY(MX,MY) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ISEA, IX, IY -!/ -!/ ------------------------------------------------------------------- / -!/ - DO 100, ISEA=1, NSEA - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - XY(IX,IY) = S(ISEA) - 100 CONTINUE -!/ -!/ End of W3S2XY ----------------------------------------------------- / -!/ - END SUBROUTINE W3S2XY -!/ ------------------------------------------------------------------- / - REAL FUNCTION EJ5P ( F, ALFA, FP, YLN, SIGA, SIGB ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 23-Nov-1999 | -!/ +-----------------------------------+ -!/ -!/ 23-AMy-1985 : Original by G. Ph. van Vledder. -!/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ -! 1. Purpose : -! -! Computation of spectral density using a 5-parameter -! JONSWAP-spectrum -! -! 2. Method -! -! EJ5P(F) = A.EXP(B + LN(Y).EXP(C)) -! -! where: A = ALFA * 0.06175 * F**(-5) -! B = -1.25*(FP/F)**4 -! C = -0.5 * ((F - FP)/(SIG * FP))**2 -! and -! GRAV**2/(2.PI)**4 = 0.06175 -! -! 3. Parameters : -! -! Parameter list -! -! ---------------------------------------------------------------- -! F Real I Frequency in Hz -! ALFA Real I Energy scaling factor -! FP Real I Peak frequency in Hz -! YLN Real I Peak overshoot factor, given by LN-value -! SIGA Real I Spectral width, for F < FP -! SIGB Real I Spectral width, FOR F > FP -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! None. -! -! 5. Called by : -! -! Any. -! -! 6. Error messages : -! -! 7. Remarks : -! -! EXPMIN is a machine dependant constant such that -! EXP(EXPMIN) can be successfully evaluated without -! underflow by the compiler supllied EXP routine. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! None. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: F, ALFA, FP, YLN, SIGA, SIGB -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - REAL :: SIG, A, B, C - REAL, SAVE :: EPS=1.E-4, EXPMIN=-180. -!/ -!/ ------------------------------------------------------------------- / -!/ - IF(F.LT.EPS) THEN - EJ5P = 0.0 - RETURN - END IF -! - A = ALFA * 0.06175 / F**5 - B = -1.25 * (FP/F)**4 - B = MAX(B,EXPMIN) -! - IF (YLN.LT.EPS) THEN - EJ5P = A * EXP(B) - ELSE - IF( F.LE.FP) THEN + ! + INTEGER, PRIVATE :: NDSTRC = 6, NTRACE = 0 + ! +CONTAINS + !/ ------------------------------------------------------------------- / + SUBROUTINE ITRACE (NDS, NMAX) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 23-Nov-1999 | + !/ +-----------------------------------+ + !/ + !/ 23-Nov-1999 : First version of routine. ( version 2.00 ) + !/ + ! 1. Purpose : + ! + ! (Re-) initialization for module version of STRACE. + ! + ! 3. Parameter list + ! ---------------------------------------------------------------- + ! NDS Int. I Data set number ofr trace file. + ! NMAX Int. I Maximum number of traces per routine. + ! ---------------------------------------------------------------- + ! + ! Private to module : + ! ---------------------------------------------------------------- + ! NDSTRC Int. Output unit number for trace. ( from NDS ) + ! NTRACE Int. Maximum number of trace prints. ( from NMAX ) + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! None. + ! + ! 5. Called by : + ! + ! Any program, multiple calls allowed. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDS, NMAX + !/ + !/ ------------------------------------------------------------------- / + !/ + NTRACE = MAX ( 0 , NMAX ) + NDSTRC = NDS + ! + RETURN + !/ + !/ End of ITRACE ----------------------------------------------------- / + !/ + END SUBROUTINE ITRACE + !/ ------------------------------------------------------------------- / + SUBROUTINE STRACE (IENT, SNAME) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 25-Jan-2000 | + !/ +-----------------------------------+ + !/ Original version by N. Booij, DUT + !/ + !/ 30-Mar-1993 : Final FORTRAN 77 ( version 1.18 ) + !/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 25-Jan-2000 : Force flushing of uniit. ( version 2.00 ) + !/ This was taken out around version 3.01. + !/ + ! 1. Purpose : + ! + ! Keep track of entered subroutines. + ! + ! 3. Parameter list + ! ---------------------------------------------------------------- + ! IENT Int. I/O Number of times that STRACE has been + ! called by the routine. + ! SNAME Char. I Name of the subroutine (max. 6 characters) + ! ---------------------------------------------------------------- + ! + ! Private to module : + ! ---------------------------------------------------------------- + ! NDSTRC Int. Output unit number for trace. + ! NTRACE Int. Maximum number of trace prints. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! None. + ! + ! 5. Called by : + ! + ! Any program, after private variables have been set by NTRACE. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(INOUT) :: IENT + CHARACTER, INTENT(IN) :: SNAME*(*) + !/ + !/ ------------------------------------------------------------------- / + !/ + IF (NTRACE.EQ.0 .OR. IENT.GE.NTRACE) RETURN + ! + IENT = IENT + 1 + IF (IENT.EQ.1) THEN + WRITE (NDSTRC,10) SNAME + ELSE + WRITE (NDSTRC,11) SNAME, IENT + END IF + ! + RETURN + ! + ! Formats + ! +10 FORMAT (' ---> TRACE SUBR : ',A6) +11 FORMAT (' ---> TRACE SUBR : ',A6,' ENTRY: ',I6) + !/ + !/ End of STRACE ----------------------------------------------------- / + !/ + END SUBROUTINE STRACE + !/ ------------------------------------------------------------------- / + SUBROUTINE NEXTLN ( CHCKC , NDSI , NDSE ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 10-Dec-2014 | + !/ +-----------------------------------+ + !/ + !/ 15-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) + !/ 18-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 10-Dec-2014 : Skip blank lines and leading blanks ( version 5.04 ) + !/ + ! 1. Purpose : + ! + ! Sets file pointer to next active line of input file, by skipping + ! blank lines and lines starting with the character CHCKC. Leading + ! white space is allowed before the character CHCKC. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! CHCKC C*1 I Check character for defining comment line. + ! NDSI Int. I Input dataset number. + ! NDSE Int. I Error output dataset number. + ! (No output if NDSE < 0). + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! STRACE ( !/S switch ) + ! + ! 5. Called by : + ! + ! Any routine. + ! + ! 6. Error messages : + ! + ! - On EOF or error in input file. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NDSI, NDSE + CHARACTER, INTENT(IN) :: CHCKC*1 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER, SAVE :: IENT = 0 ! W3_S + INTEGER :: IERR + CHARACTER(128) :: MSG + CHARACTER(256) :: LINE, TEST + !/ + !/ ------------------------------------------------------------------- / + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'NEXTLN') + end if + ! +100 CONTINUE + ! read line + READ ( NDSI, 900, END=800, ERR=801, IOSTAT=IERR, IOMSG=MSG ) LINE + ! leading blanks removed and placed on the right + TEST = ADJUSTL ( LINE ) + IF ( TEST(1:1).EQ.CHCKC .OR. LEN_TRIM(TEST).EQ.0 ) THEN + ! if comment or blank line, then skip + GOTO 100 + ELSE + ! otherwise, backup to beginning of line + BACKSPACE ( NDSI, ERR=802, IOSTAT=IERR, IOMSG=MSG ) + ENDIF + RETURN + ! +800 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,910) + CALL EXTCDE ( 1 ) + ! +801 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,911) IERR, TRIM(MSG) + CALL EXTCDE ( 2 ) + ! +802 CONTINUE + IF ( NDSE .GE. 0 ) WRITE (NDSE,912) IERR, TRIM(MSG) + CALL EXTCDE ( 3 ) + ! + ! Formats + ! +900 FORMAT (A) +910 FORMAT (/' *** WAVEWATCH III ERROR IN NEXTLN : '/ & + ' PREMATURE END OF INPUT FILE'/) +911 FORMAT (/' *** WAVEWATCH III ERROR IN NEXTLN : '/ & + ' ERROR IN READING FROM FILE'/ & + ' IOSTAT =',I5,/ & + ' IOMSG = ',A/) +912 FORMAT (/' *** WAVEWATCH III ERROR IN NEXTLN : '/ & + ' ERROR ON BACKSPACE'/ & + ' IOSTAT =',I5,/ & + ' IOMSG = ',A/) + !/ + !/ End of NEXTLN ----------------------------------------------------- / + !/ + END SUBROUTINE NEXTLN + !/ ------------------------------------------------------------------- / + SUBROUTINE W3S2XY ( NSEA, MSEA, MX, MY, S, MAPSF, XY ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NMC | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 23-Nov-1999 | + !/ +-----------------------------------+ + !/ + !/ 11-Dec-1996 : Final FORTRAN 77 ( version 1.18 ) + !/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ + ! 1. Purpose : + ! + ! Convert a data array on the storage grid to a data array on the + ! full spatial grid. Land and ice points in the full grid are + ! not touched. Output array of conventional type XY(IX,IY). + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! NSEA Int. I Number of sea points. + ! MSEA, MX, MY + ! Int. I Array dimensions. + ! S R.A. I Data on storage grid. + ! MAPSF I.A. I Storage map for IX and IY, resp. + ! XY R.A. O Data on XY grid. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! None. + ! + ! 5. Called by : + ! + ! Any WAVEWATCH III routine. + ! + ! 9. Switches : + ! + ! None. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: MSEA, NSEA, MX, MY, MAPSF(MSEA,2) + REAL, INTENT(IN) :: S(MSEA) + REAL, INTENT(OUT) :: XY(MX,MY) + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ISEA, IX, IY + !/ + !/ ------------------------------------------------------------------- / + !/ + DO ISEA=1, NSEA + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + XY(IX,IY) = S(ISEA) + END DO + + !/ + !/ End of W3S2XY ----------------------------------------------------- / + !/ + END SUBROUTINE W3S2XY + !/ ------------------------------------------------------------------- / + REAL FUNCTION EJ5P ( F, ALFA, FP, YLN, SIGA, SIGB ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 23-Nov-1999 | + !/ +-----------------------------------+ + !/ + !/ 23-AMy-1985 : Original by G. Ph. van Vledder. + !/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ + ! 1. Purpose : + ! + ! Computation of spectral density using a 5-parameter + ! JONSWAP-spectrum + ! + ! 2. Method + ! + ! EJ5P(F) = A.EXP(B + LN(Y).EXP(C)) + ! + ! where: A = ALFA * 0.06175 * F**(-5) + ! B = -1.25*(FP/F)**4 + ! C = -0.5 * ((F - FP)/(SIG * FP))**2 + ! and + ! GRAV**2/(2.PI)**4 = 0.06175 + ! + ! 3. Parameters : + ! + ! Parameter list + ! + ! ---------------------------------------------------------------- + ! F Real I Frequency in Hz + ! ALFA Real I Energy scaling factor + ! FP Real I Peak frequency in Hz + ! YLN Real I Peak overshoot factor, given by LN-value + ! SIGA Real I Spectral width, for F < FP + ! SIGB Real I Spectral width, FOR F > FP + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! None. + ! + ! 5. Called by : + ! + ! Any. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! EXPMIN is a machine dependant constant such that + ! EXP(EXPMIN) can be successfully evaluated without + ! underflow by the compiler supllied EXP routine. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! None. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: F, ALFA, FP, YLN, SIGA, SIGB + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + REAL :: SIG, A, B, C + REAL, SAVE :: EPS=1.E-4, EXPMIN=-180. + !/ + !/ ------------------------------------------------------------------- / + !/ + IF(F.LT.EPS) THEN + EJ5P = 0.0 + RETURN + END IF + ! + A = ALFA * 0.06175 / F**5 + B = -1.25 * (FP/F)**4 + B = MAX(B,EXPMIN) + ! + IF (YLN.LT.EPS) THEN + EJ5P = A * EXP(B) + ELSE + IF( F.LE.FP) THEN SIG = SIGA - ELSE + ELSE SIG = SIGB - END IF - C = -0.5 * ((F - FP)/(SIG * FP))**2 - C = MAX(C,EXPMIN) - EJ5P = A * EXP(B + EXP(C) * YLN) - END IF -! - RETURN -!/ -!/ End of NEXTLN ----------------------------------------------------- / -!/ - END FUNCTION -!/ ------------------------------------------------------------------- / - REAL FUNCTION DIST_SPHERE ( lo1,la1,lo2,la2 ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | F. Ardhuin | -!/ | FORTRAN 90 | -!/ | Last update : 18-Aug-2016 | -!/ +-----------------------------------+ -!/ -!/ 18-Aug-2016 : Creation ( version 5.11 ) -!/ -! 1. Purpose : -! -! Computes distance between two points on a sphere -! -! 2. Method -! -! -! 3. Parameters : -! -! Parameter list -! -! ---------------------------------------------------------------- -! LO1 Real I Longitude of 1st point -! LA1 Real I Latitude of 1st point -! LO2 Real I Longitude of 2nd point -! LA2 Real I Latitude of 2nd point -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! None. -! -! 5. Called by : -! -! WW3_BOUNC -! -! 6. Error messages : -! -! 7. Remarks : -! -! None. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! None. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - REAL, INTENT(IN) :: LO1, LA1, LO2, LA2 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -! None -!/ -!/ ------------------------------------------------------------------- / -!/ - DIST_SPHERE=acos(sin(la2*DERA)*sin(la1*DERA)+ & - cos(la2*DERA)*cos(la1*DERA)*cos((lo2-lo1)*DERA))*RADE -! - RETURN -!/ -!/ End of NEXTLN ----------------------------------------------------- / -!/ - END FUNCTION -!/ ------------------------------------------------------------------- / - -!/ ------------------------------------------------------------------- / - SUBROUTINE WWDATE (STRNG) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 26-Dec-2012 | -!/ +-----------------------------------+ -!/ -!/ 23-Dec-1998 : Final FORTRAN 77 ( version 1.18 ) -!/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 18-Sep-2000 : PGI switch added ( version 2.04 ) -!/ 13-Mar-2001 : LF95 switch added ( version 2.09 ) -!/ 08-May-2002 : Replace obsolete switches with F90 ( version 2.21 ) -!/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) -!/ -! 1. Purpose : -! -! Get date from machine dependent routine. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! STRNG C*10 O String with date in format YYYY/MM/DD -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Machine dependent. -! -! 5. Called by : -! -! Any routine. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - CHARACTER, INTENT(OUT) :: STRNG*10 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - CHARACTER(LEN=8) :: DATE - CHARACTER(LEN=10) :: TIME - CHARACTER(LEN=5) :: ZONE - INTEGER :: VALUES(8) -!/ -!/ ------------------------------------------------------------------- / -!/ - STRNG = '----/--/--' - CALL DATE_AND_TIME ( DATE, TIME, ZONE, VALUES ) - STRNG(1:4) = DATE(1:4) - STRNG(6:7) = DATE(5:6) - STRNG(9:10) = DATE(7:8) -! -! - RETURN -!/ -!/ End of WWDATE ----------------------------------------------------- / -!/ - END SUBROUTINE WWDATE -!/ ------------------------------------------------------------------- / - SUBROUTINE WWTIME (STRNG) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 26-Dec-2012 | -!/ +-----------------------------------+ -!/ -!/ 23-Dec-1998 : Final FORTRAN 77 ( version 1.18 ) -!/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 18-Sep-2000 : PGI switch added ( version 2.04 ) -!/ 13-Mar-2001 : LF95 switch added ( version 2.09 ) -!/ 08-May-2002 : Replace obsolete switches with F90 ( version 2.21 ) -!/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) -!/ -! 1. Purpose : -! -! Get time from machine dependent routine. -! -! 2. Method : -! -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! STRNG C*8 O String with time in format hh:mm:ss -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Machine dependent. -! -! 5. Called by : -! -! Any routine. -! -! 9. Switches : -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - CHARACTER, INTENT(OUT) :: STRNG*8 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - CHARACTER(LEN=8) :: DATE - CHARACTER(LEN=10) :: TIME - CHARACTER(LEN=5) :: ZONE - INTEGER :: VALUES(8) -!/ -!/ ------------------------------------------------------------------- / -!/ -! - STRNG = '--:--:--' - CALL DATE_AND_TIME ( DATE, TIME, ZONE, VALUES ) - STRNG(1:2) = TIME(1:2) - STRNG(4:5) = TIME(3:4) - STRNG(7:8) = TIME(5:6) -! - RETURN -!/ -!/ End of WWTIME ----------------------------------------------------- / -!/ - END SUBROUTINE WWTIME -!/ ------------------------------------------------------------------- / - SUBROUTINE EXTCDE ( IEXIT, UNIT, MSG, FILE, LINE, COMM ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 06-Jun-2018 | -!/ +-----------------------------------+ -!/ -!/ 06-Jan-1998 : Final FORTRAN 77 ( version 1.18 ) -!/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) -!/ 11-Mar-2015 : Allow non-error exit (iexit=0) ( version 5.04 ) -!/ 20-Jan-2017 : Add optional MPI communicator arg ( version 6.02 ) -!/ 06-Jun-2018 : Add optional MPI ( version 6.04 ) -!/ -! 1. Purpose : -! -! Perform a program stop with an exit code. -! -! If exit code IEXIT=0, then it is not an error, but -! a stop has been requested by the calling routine: -! wait for other processes in communicator to catch up. -! -! If exit code IEXIT.ne.0, then abort program w/out -! waiting for other processes to catch up (important for example -! when not all processes are used by WW3). -! -! 2. Method : -! -! Machine dependent. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IEXIT Int. I Exit code to be used. -! UNIT Int. I (optional) file unit to write error message -! MSG Str. I (optional) error message -! FILE Str. I (optional) name of source code file -! LINE Int. I (optional) line number in source code file -! COMM Int. I (optional) MPI communicator -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! 5. Called by : -! -! Any. -! -! 9. Switches : -! -! !/MPI MPI finalize interface if active -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - IMPLICIT NONE -! + END IF + C = -0.5 * ((F - FP)/(SIG * FP))**2 + C = MAX(C,EXPMIN) + EJ5P = A * EXP(B + EXP(C) * YLN) + END IF + ! + RETURN + !/ + !/ End of NEXTLN ----------------------------------------------------- / + !/ + END FUNCTION EJ5P + !/ ------------------------------------------------------------------- / + REAL FUNCTION DIST_SPHERE ( lo1,la1,lo2,la2 ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | F. Ardhuin | + !/ | FORTRAN 90 | + !/ | Last update : 18-Aug-2016 | + !/ +-----------------------------------+ + !/ + !/ 18-Aug-2016 : Creation ( version 5.11 ) + !/ + ! 1. Purpose : + ! + ! Computes distance between two points on a sphere + ! + ! 2. Method + ! + ! + ! 3. Parameters : + ! + ! Parameter list + ! + ! ---------------------------------------------------------------- + ! LO1 Real I Longitude of 1st point + ! LA1 Real I Latitude of 1st point + ! LO2 Real I Longitude of 2nd point + ! LA2 Real I Latitude of 2nd point + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! None. + ! + ! 5. Called by : + ! + ! WW3_BOUNC + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! None. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! None. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + REAL, INTENT(IN) :: LO1, LA1, LO2, LA2 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + ! None + !/ + !/ ------------------------------------------------------------------- / + !/ + DIST_SPHERE=acos(sin(la2*DERA)*sin(la1*DERA)+ & + cos(la2*DERA)*cos(la1*DERA)*cos((lo2-lo1)*DERA))*RADE + ! + RETURN + !/ + !/ End of NEXTLN ----------------------------------------------------- / + !/ + END FUNCTION DIST_SPHERE + !/ ------------------------------------------------------------------- / + + !/ ------------------------------------------------------------------- / + SUBROUTINE WWDATE (STRNG) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 26-Dec-2012 | + !/ +-----------------------------------+ + !/ + !/ 23-Dec-1998 : Final FORTRAN 77 ( version 1.18 ) + !/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 18-Sep-2000 : PGI switch added ( version 2.04 ) + !/ 13-Mar-2001 : LF95 switch added ( version 2.09 ) + !/ 08-May-2002 : Replace obsolete switches with F90 ( version 2.21 ) + !/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) + !/ + ! 1. Purpose : + ! + ! Get date from machine dependent routine. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! STRNG C*10 O String with date in format YYYY/MM/DD + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Machine dependent. + ! + ! 5. Called by : + ! + ! Any routine. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + CHARACTER, INTENT(OUT) :: STRNG*10 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + CHARACTER(LEN=8) :: DATE + CHARACTER(LEN=10) :: TIME + CHARACTER(LEN=5) :: ZONE + INTEGER :: VALUES(8) + !/ + !/ ------------------------------------------------------------------- / + !/ + STRNG = '----/--/--' + CALL DATE_AND_TIME ( DATE, TIME, ZONE, VALUES ) + STRNG(1:4) = DATE(1:4) + STRNG(6:7) = DATE(5:6) + STRNG(9:10) = DATE(7:8) + ! + ! + RETURN + !/ + !/ End of WWDATE ----------------------------------------------------- / + !/ + END SUBROUTINE WWDATE + !/ ------------------------------------------------------------------- / + SUBROUTINE WWTIME (STRNG) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 26-Dec-2012 | + !/ +-----------------------------------+ + !/ + !/ 23-Dec-1998 : Final FORTRAN 77 ( version 1.18 ) + !/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 18-Sep-2000 : PGI switch added ( version 2.04 ) + !/ 13-Mar-2001 : LF95 switch added ( version 2.09 ) + !/ 08-May-2002 : Replace obsolete switches with F90 ( version 2.21 ) + !/ 26-Dec-2012 : Modified obsolete declarations. ( version 4.11 ) + !/ + ! 1. Purpose : + ! + ! Get time from machine dependent routine. + ! + ! 2. Method : + ! + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! STRNG C*8 O String with time in format hh:mm:ss + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Machine dependent. + ! + ! 5. Called by : + ! + ! Any routine. + ! + ! 9. Switches : + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + CHARACTER, INTENT(OUT) :: STRNG*8 + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + CHARACTER(LEN=8) :: DATE + CHARACTER(LEN=10) :: TIME + CHARACTER(LEN=5) :: ZONE + INTEGER :: VALUES(8) + !/ + !/ ------------------------------------------------------------------- / + !/ + ! + STRNG = '--:--:--' + CALL DATE_AND_TIME ( DATE, TIME, ZONE, VALUES ) + STRNG(1:2) = TIME(1:2) + STRNG(4:5) = TIME(3:4) + STRNG(7:8) = TIME(5:6) + ! + RETURN + !/ + !/ End of WWTIME ----------------------------------------------------- / + !/ + END SUBROUTINE WWTIME + !/ ------------------------------------------------------------------- / + SUBROUTINE EXTCDE ( IEXIT, UNIT, MSG, FILE, LINE, COMM ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 06-Jun-2018 | + !/ +-----------------------------------+ + !/ + !/ 06-Jan-1998 : Final FORTRAN 77 ( version 1.18 ) + !/ 23-Nov-1999 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ 10-Dec-2014 : Add checks for allocate status ( version 5.04 ) + !/ 11-Mar-2015 : Allow non-error exit (iexit=0) ( version 5.04 ) + !/ 20-Jan-2017 : Add optional MPI communicator arg ( version 6.02 ) + !/ 06-Jun-2018 : Add optional MPI ( version 6.04 ) + !/ + ! 1. Purpose : + ! + ! Perform a program stop with an exit code. + ! + ! If exit code IEXIT=0, then it is not an error, but a stop + ! has been requested by the calling routine: wait for other + ! processes in communicator to catch up. + ! + ! If exit code IEXIT.ne.0, then abort program w/out + ! waiting for other processes to catch up (important for example + ! when not all processes are used by WW3). + ! + ! 2. Method : + ! + ! Machine dependent. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IEXIT Int. I Exit code to be used. + ! UNIT Int. I (optional) file unit to write error message + ! MSG Str. I (optional) error message + ! FILE Str. I (optional) name of source code file + ! LINE Int. I (optional) line number in source code file + ! COMM Int. I (optional) MPI communicator + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! 5. Called by : + ! + ! Any. + ! + ! 9. Switches : + ! + ! !/MPI MPI finalize interface if active + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + ! #ifdef W3_MPI - INCLUDE "mpif.h" + INCLUDE "mpif.h" #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: IEXIT - INTEGER, INTENT(IN), OPTIONAL :: UNIT - CHARACTER(*), INTENT(IN), OPTIONAL :: MSG - CHARACTER(*), INTENT(IN), OPTIONAL :: FILE - INTEGER, INTENT(IN), OPTIONAL :: LINE - INTEGER, INTENT(IN), OPTIONAL :: COMM -!/ -!/ ------------------------------------------------------------------- / -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: IEXIT + INTEGER, INTENT(IN), OPTIONAL :: UNIT + CHARACTER(*), INTENT(IN), OPTIONAL :: MSG + CHARACTER(*), INTENT(IN), OPTIONAL :: FILE + INTEGER, INTENT(IN), OPTIONAL :: LINE + INTEGER, INTENT(IN), OPTIONAL :: COMM + !/ + !/ ------------------------------------------------------------------- / + !/ #ifdef W3_MPI - INTEGER :: IERR_MPI - LOGICAL :: RUN + INTEGER :: IERR_MPI + LOGICAL :: RUN #endif - INTEGER :: IUN - CHARACTER(256) :: LMSG = "" - CHARACTER(6) :: LSTR - CHARACTER(10) :: PREFIX = "WW3 ERROR:" -!/ -!/ Set file unit for error output -!/ - IUN = 0 - IF (PRESENT(UNIT)) IUN = UNIT -!/ -!/ Report error message -!/ - IF (PRESENT(MSG)) THEN - WRITE (IUN,"(A)") PREFIX//" "//TRIM(MSG) - END IF -!/ -!/ Report context -!/ - IF ( PRESENT(FILE) ) THEN - LMSG = TRIM(LMSG)//" FILE="//TRIM(FILE) - END IF - IF ( PRESENT(LINE) ) THEN - WRITE (LSTR,'(I0)') LINE - LMSG = TRIM(LMSG)//" LINE="//TRIM(LSTR) - END IF - IF ( LEN_TRIM(LMSG).GT.0 ) THEN - WRITE (IUN,"(A)") PREFIX//TRIM(LMSG) - END IF -!/ -!/ Handle MPI exit -!/ + INTEGER :: IUN + CHARACTER(256) :: LMSG = "" + CHARACTER(6) :: LSTR + CHARACTER(10) :: PREFIX = "WW3 ERROR:" + !/ + !/ Set file unit for error output + !/ + IUN = 0 + IF (PRESENT(UNIT)) IUN = UNIT + !/ + !/ Report error message + !/ + IF (PRESENT(MSG)) THEN + WRITE (IUN,"(A)") PREFIX//" "//TRIM(MSG) + END IF + !/ + !/ Report context + !/ + IF ( PRESENT(FILE) ) THEN + LMSG = TRIM(LMSG)//" FILE="//TRIM(FILE) + END IF + IF ( PRESENT(LINE) ) THEN + WRITE (LSTR,'(I0)') LINE + LMSG = TRIM(LMSG)//" LINE="//TRIM(LSTR) + END IF + IF ( LEN_TRIM(LMSG).GT.0 ) THEN + WRITE (IUN,"(A)") PREFIX//TRIM(LMSG) + END IF + !/ + !/ Handle MPI exit + !/ #ifdef W3_MPI - CALL MPI_INITIALIZED ( RUN, IERR_MPI ) - IF ( RUN ) THEN - IF ( IEXIT.EQ.0 ) THEN ! non-error state + CALL MPI_INITIALIZED ( RUN, IERR_MPI ) + IF ( RUN ) THEN + IF ( IEXIT.EQ.0 ) THEN ! non-error state IF ( PRESENT(COMM) ) CALL MPI_BARRIER ( COMM, IERR_MPI ) CALL MPI_FINALIZE (IERR_MPI ) - ELSE ! error state + ELSE ! error state WRITE(*,'(/A,I6/)') 'EXTCDE MPI_ABORT, IEXIT=', IEXIT IF (PRESENT(UNIT)) THEN - WRITE(*,'(/A,I6/)') 'EXTCDE UNIT=', UNIT -#endif -!!/MPI ELSE -!!/MPI WRITE(*,'(A)') 'EXTCDE UNIT missing' -#ifdef W3_MPI + WRITE(*,'(/A,I6/)') 'EXTCDE UNIT=', UNIT END IF IF (PRESENT(MSG)) THEN - WRITE(*,'(/2A/)') 'EXTCDE MSG=', MSG -#endif -!!/MPI ELSE -!!/MPI WRITE(*,'(A)') 'EXTCDE MSG missing' -#ifdef W3_MPI + WRITE(*,'(/2A/)') 'EXTCDE MSG=', MSG END IF IF (PRESENT(FILE)) THEN - WRITE(*,'(/2A/)') 'EXTCDE FILE=', FILE -#endif -!!/MPI ELSE -!!/MPI WRITE(*,'(A)') 'EXTCDE FILE missing' -#ifdef W3_MPI + WRITE(*,'(/2A/)') 'EXTCDE FILE=', FILE END IF IF (PRESENT(LINE)) THEN - WRITE(*,'(/A,I8/)') 'EXTCDE LINE=', LINE -#endif -!!/MPI ELSE -!!/MPI WRITE(*,'(A)') 'EXTCDE LINE missing' -#ifdef W3_MPI + WRITE(*,'(/A,I8/)') 'EXTCDE LINE=', LINE END IF IF (PRESENT(COMM)) THEN - WRITE(*,'(/A,I6/)') 'EXTCDE COMM=', COMM -#endif -!!/MPI ELSE -!!/MPI WRITE(*,'(A)') 'EXTCDE COMM missing' -#ifdef W3_MPI + WRITE(*,'(/A,I6/)') 'EXTCDE COMM=', COMM END IF CALL MPI_ABORT ( MPI_COMM_WORLD, IEXIT, IERR_MPI ) - END IF - END IF + END IF + END IF #endif -!/ -!/ Handle non-MPI exit -!/ - CALL EXIT ( IEXIT ) -!/ -!/ End of EXTCDE ----------------------------------------------------- / -!/ - END SUBROUTINE EXTCDE -!/ ------------------------------------------------------------------- / -! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! This subroutine turn the wave spectrum by an fixed angle anti-clockwise -! so that it may be used in the rotated or stanadard system. -! First created: 26 Aug 2005 Jian-Guo Li -! Last modified: 21 Feb 2008 Jian-Guo Li -! -! Subroutine Interface: - - Subroutine W3SPECTN( NFreq, NDirc, Alpha, Spectr ) - -! Description: -! Rotates wave spectrum anticlockwise by angle alpha in degree -! This routine is distinct from W3ACTURN since orders spectrum as freq, dirn -! -! Subroutine arguments - IMPLICIT NONE - INTEGER, INTENT(IN) :: NFreq, NDirc ! No. freq and dirn bins - REAL, INTENT(IN) :: Alpha ! Turning angle (degrees) - REAL, INTENT(INOUT) :: Spectr(NFreq,NDirc) ! Wave spectrum in/out - -! Local variables - INTEGER :: ii, jj, kk, nsft - REAL :: Ddirc, frac, CNST - REAL, Dimension(NFreq) :: Wrkfrq, Tmpfrq - REAL, Dimension(NFreq,NDirc):: Wrkspc - -! Check input bin numbers - IF( (NFreq .LT. 0) .OR. (NDirc .LT. 0) ) THEN - PRINT*, " Invalid bin number NF or ND", NFreq, NDirc - RETURN - ELSE - Ddirc=360.0/FLOAT(NDirc) - ENDIF - -! Work out shift bin number and fraction - - CNST=Alpha/Ddirc - nsft=INT( CNST ) - frac= CNST - FLOAT( nsft ) -! PRINT*, ' nsft and frac =', nsft, frac - -! Shift nsft bins if >=1 - IF( ABS(nsft) .GE. 1 ) THEN - DO ii=1, NDirc - -! Wave spectral direction bin number is assumed to increase Anti-clockwise from EAST -! So shift nsft bins anticlockwise results in local bin number decreasing by nsft - jj=ii - nsft - -! As nsft may be either positive or negative depends on alpha, wrapping may -! happen in either ends of the bin number train - IF( jj > NDirc ) jj=jj - NDirc - IF( jj < 1 ) jj=jj + NDirc - -! Copy the selected bin to the loop bin number - Wrkspc(:,ii)=Spectr(:,jj) - - ENDDO - -! If nsft=0, no need to shift, simply copy - ELSE - Wrkspc = Spectr - ENDIF - -! Pass fraction of wave energy in frac direction -! Wave spectral direction bin number is assumed to increase Anti-clockwise from EAST -! So Positive frac or anticlock case, smaller bin upstream - IF( frac > 0.0 ) THEN - Tmpfrq=Wrkspc(:,NDirc)*frac - DO kk=1, NDirc - Wrkfrq=Wrkspc(:,kk)*frac - Spectr(:,kk)=Wrkspc(:,kk) - Wrkfrq + Tmpfrq - Tmpfrq=Wrkfrq - ENDDO - ELSE -! Negative or clockwise case, larger bin upstream - Tmpfrq=Wrkspc(:,1)*frac - DO kk=NDirc, 1, -1 - Wrkfrq=Wrkspc(:,kk)*frac - Spectr(:,kk)=Wrkspc(:,kk) + Wrkfrq - Tmpfrq - Tmpfrq=Wrkfrq - ENDDO - ENDIF - -! Spectral turning completed - - RETURN - END SUBROUTINE W3SPECTN -! -! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! This subroutine turn the wave action by an angle (deg) anti-clockwise -! so that it may be used in the rotated or stanadard system. -! First created: 26 Aug 2005 Jian-Guo Li -! Last modified: 9 Oct 2008 Jian-Guo Li -! -! Subroutine Interface: - - Subroutine W3ACTURN( NDirc, NFreq, Alpha, Spectr ) - -! Description: -! Rotates wave spectrum anticlockwise by angle alpha -! Routine is distinct from W3SPECTN since orders spectrum as dirn, freq -! -! Subroutine arguments - IMPLICIT NONE - INTEGER, INTENT(IN) :: NFreq, NDirc ! No. freq and dirn bins - REAL, INTENT(IN) :: Alpha ! Turning angle (degrees) - REAL, INTENT(INOUT) :: Spectr(NDirc, NFreq) ! Wave action in/out - -! Local variables - INTEGER :: ii, jj, kk, nsft - REAL :: Ddirc, frac, CNST - REAL, Dimension(NFreq) :: Wrkfrq, Tmpfrq - REAL, Dimension(NDirc,NFreq):: Wrkspc - -! Check input bin numbers - IF( (NFreq .LT. 0) .OR. (NDirc .LT. 0) ) THEN - PRINT*, " Invalid bin number NF or ND", NFreq, NDirc - RETURN - ELSE - Ddirc=360.0/FLOAT(NDirc) - ENDIF - -! Work out shift bin number and fraction - - CNST=Alpha/Ddirc - nsft=INT( CNST ) - frac= CNST - FLOAT( nsft ) -! PRINT*, ' nsft and frac =', nsft, frac - -! Shift nsft bins if >=1 - IF( ABS(nsft) .GE. 1 ) THEN - DO ii=1, NDirc - -! Wave spectral direction bin number is assumed to increase Anti-clockwise from EAST -! So shift nsft bins anticlockwise results in local bin number decreasing by nsft - jj=ii - nsft - -! As nsft may be either positive or negative depends on alpha, wrapping may -! happen in either ends of the bin number train - IF( jj > NDirc ) jj=jj - NDirc - IF( jj < 1 ) jj=jj + NDirc - -! Copy the selected bin to the loop bin number - Wrkspc(ii,:)=Spectr(jj,:) - - ENDDO - -! If nsft=0, no need to shift, simply copy - ELSE - Wrkspc = Spectr - ENDIF - -! Pass fraction of wave energy in frac direction -! Wave spectral direction bin number is assumed to increase anti-clockwise from EAST -! So positive frac or anticlock case, smaller bin upstream - IF( frac > 0.0 ) THEN - Tmpfrq=Wrkspc(NDirc,:)*frac - DO kk=1, NDirc - Wrkfrq=Wrkspc(kk,:)*frac - Spectr(kk,:)=Wrkspc(kk,:) - Wrkfrq + Tmpfrq - Tmpfrq=Wrkfrq - ENDDO - ELSE -! Negative or clockwise case, larger bin upstream - Tmpfrq=Wrkspc(1,:)*frac - DO kk=NDirc, 1, -1 - Wrkfrq=Wrkspc(kk,:)*frac - Spectr(kk,:)=Wrkspc(kk,:) + Wrkfrq - Tmpfrq - Tmpfrq=Wrkfrq - ENDDO - ENDIF - -! Spectral turning completed - - RETURN - END SUBROUTINE W3ACTURN -! -!Li +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!Li -!Li Merged UM source code for rotated grid, consisting the following -!Li original subroutines in UM 6.1 -!Li LLTOEQ1A WCOEFF1A and LBCROTWINDS1 -!Li The last subroutine is modified to process only one level winds -!Li cpp directives are removed and required header C_Pi.h inserted. -!Li Jian-Guo Li 26 May 2005 -!Li -!Li The WCOEFF1A subroutine is merged into LLTOEQ to reduce repetition -!Li of the same calculations. Subroutine interface changed to -!Li LLTOEQANGLE -!Li Jian-GUo Li 23 Aug 2005 -!Li -!Li Subroutine W3LLTOEQ -------------------------------------------- -!Li -!Li Purpose: Calculates latitude and longitude on equatorial -!Li latitude-longitude (eq) grid used in regional -!Li models from input arrays of latitude and -!Li longitude on standard grid. Both input and output -!Li latitudes and longitudes are in degrees. -!Li Also calculate rotation angle in degree to tranform -!Li standard wind velocity into equatorial wind. -!Li Valid for 0= 0.0) THEN - SIN_PHI_POLE = SIN(PI_OVER_180*PHI_POLE) - COS_PHI_POLE = COS(PI_OVER_180*PHI_POLE) - ELSE - SIN_PHI_POLE = -SIN(PI_OVER_180*PHI_POLE) - COS_PHI_POLE = -COS(PI_OVER_180*PHI_POLE) - ENDIF - -! 2. Transform from standard to equatorial latitude-longitude - - DO I= 1, POINTS - -! Scale longitude to range -180 to +180 degs - - A_LAMBDA=LAMBDA(I)-LAMBDA_ZERO - IF(A_LAMBDA.GT. 180.0) A_LAMBDA=A_LAMBDA-360.D0 - IF(A_LAMBDA.LE.-180.0) A_LAMBDA=A_LAMBDA+360.D0 - -! Convert latitude & longitude to radians - - A_LAMBDA=PI_OVER_180*A_LAMBDA - A_PHI=PI_OVER_180*PHI(I) - -! Compute eq latitude using equation (4.4) - - ARG=-COS_PHI_POLE*COS(A_PHI)*COS(A_LAMBDA) & - & +SIN_PHI_POLE*SIN(A_PHI) - ARG=MIN(ARG, 1.D0) - ARG=MAX(ARG,-1.D0) - E_PHI=ASIN(ARG) - PHI_EQ(I)=RECIP_PI_OVER_180*E_PHI - -! Compute eq longitude using equation (4.6) - - TERM1 = SIN_PHI_POLE*COS(A_PHI)*COS(A_LAMBDA) & - & +COS_PHI_POLE*SIN(A_PHI) - TERM2 = COS(E_PHI) - IF(TERM2 .LT. SMALL) THEN + !/ + !/ Handle non-MPI exit + !/ + CALL EXIT ( IEXIT ) + !/ + !/ End of EXTCDE ----------------------------------------------------- / + !/ + END SUBROUTINE EXTCDE + !/ ------------------------------------------------------------------- / + ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! This subroutine turn the wave spectrum by an fixed angle anti-clockwise + ! so that it may be used in the rotated or stanadard system. + ! First created: 26 Aug 2005 Jian-Guo Li + ! Last modified: 21 Feb 2008 Jian-Guo Li + ! + ! Subroutine Interface: + + Subroutine W3SPECTN( NFreq, NDirc, Alpha, Spectr ) + + ! Description: + ! Rotates wave spectrum anticlockwise by angle alpha in degree + ! This routine is distinct from W3ACTURN since orders spectrum as freq, dirn + ! + ! Subroutine arguments + + INTEGER, INTENT(IN) :: NFreq, NDirc ! No. freq and dirn bins + REAL, INTENT(IN) :: Alpha ! Turning angle (degrees) + REAL, INTENT(INOUT) :: Spectr(NFreq,NDirc) ! Wave spectrum in/out + + ! Local variables + INTEGER :: ii, jj, kk, nsft + REAL :: Ddirc, frac, CNST + REAL, Dimension(NFreq) :: Wrkfrq, Tmpfrq + REAL, Dimension(NFreq,NDirc):: Wrkspc + + ! Check input bin numbers + IF( (NFreq .LT. 0) .OR. (NDirc .LT. 0) ) THEN + PRINT*, " Invalid bin number NF or ND", NFreq, NDirc + RETURN + ELSE + Ddirc=360.0/FLOAT(NDirc) + ENDIF + + ! Work out shift bin number and fraction + + CNST=Alpha/Ddirc + nsft=INT( CNST ) + frac= CNST - FLOAT( nsft ) + ! PRINT*, ' nsft and frac =', nsft, frac + + ! Shift nsft bins if >=1 + IF( ABS(nsft) .GE. 1 ) THEN + DO ii=1, NDirc + + ! Wave spectral direction bin number is assumed to increase Anti-clockwise from EAST + ! So shift nsft bins anticlockwise results in local bin number decreasing by nsft + jj=ii - nsft + + ! As nsft may be either positive or negative depends on alpha, wrapping may + ! happen in either ends of the bin number train + IF( jj > NDirc ) jj=jj - NDirc + IF( jj < 1 ) jj=jj + NDirc + + ! Copy the selected bin to the loop bin number + Wrkspc(:,ii)=Spectr(:,jj) + + ENDDO + + ! If nsft=0, no need to shift, simply copy + ELSE + Wrkspc = Spectr + ENDIF + + ! Pass fraction of wave energy in frac direction + ! Wave spectral direction bin number is assumed to increase Anti-clockwise from EAST + ! So Positive frac or anticlock case, smaller bin upstream + IF( frac > 0.0 ) THEN + Tmpfrq=Wrkspc(:,NDirc)*frac + DO kk=1, NDirc + Wrkfrq=Wrkspc(:,kk)*frac + Spectr(:,kk)=Wrkspc(:,kk) - Wrkfrq + Tmpfrq + Tmpfrq=Wrkfrq + ENDDO + ELSE + ! Negative or clockwise case, larger bin upstream + Tmpfrq=Wrkspc(:,1)*frac + DO kk=NDirc, 1, -1 + Wrkfrq=Wrkspc(:,kk)*frac + Spectr(:,kk)=Wrkspc(:,kk) + Wrkfrq - Tmpfrq + Tmpfrq=Wrkfrq + ENDDO + ENDIF + + ! Spectral turning completed + + RETURN + END SUBROUTINE W3SPECTN + ! + ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! This subroutine turn the wave action by an angle (deg) anti-clockwise + ! so that it may be used in the rotated or stanadard system. + ! First created: 26 Aug 2005 Jian-Guo Li + ! Last modified: 9 Oct 2008 Jian-Guo Li + ! + ! Subroutine Interface: + + Subroutine W3ACTURN( NDirc, NFreq, Alpha, Spectr ) + + ! Description: + ! Rotates wave spectrum anticlockwise by angle alpha + ! Routine is distinct from W3SPECTN since orders spectrum as dirn, freq + ! + ! Subroutine arguments + + INTEGER, INTENT(IN) :: NFreq, NDirc ! No. freq and dirn bins + REAL, INTENT(IN) :: Alpha ! Turning angle (degrees) + REAL, INTENT(INOUT) :: Spectr(NDirc, NFreq) ! Wave action in/out + + ! Local variables + INTEGER :: ii, jj, kk, nsft + REAL :: Ddirc, frac, CNST + REAL, Dimension(NFreq) :: Wrkfrq, Tmpfrq + REAL, Dimension(NDirc,NFreq):: Wrkspc + + ! Check input bin numbers + IF( (NFreq .LT. 0) .OR. (NDirc .LT. 0) ) THEN + PRINT*, " Invalid bin number NF or ND", NFreq, NDirc + RETURN + ELSE + Ddirc=360.0/FLOAT(NDirc) + ENDIF + + ! Work out shift bin number and fraction + + CNST=Alpha/Ddirc + nsft=INT( CNST ) + frac= CNST - FLOAT( nsft ) + ! PRINT*, ' nsft and frac =', nsft, frac + + ! Shift nsft bins if >=1 + IF( ABS(nsft) .GE. 1 ) THEN + DO ii=1, NDirc + + ! Wave spectral direction bin number is assumed to increase Anti-clockwise from EAST + ! So shift nsft bins anticlockwise results in local bin number decreasing by nsft + jj=ii - nsft + + ! As nsft may be either positive or negative depends on alpha, wrapping may + ! happen in either ends of the bin number train + IF( jj > NDirc ) jj=jj - NDirc + IF( jj < 1 ) jj=jj + NDirc + + ! Copy the selected bin to the loop bin number + Wrkspc(ii,:)=Spectr(jj,:) + + ENDDO + + ! If nsft=0, no need to shift, simply copy + ELSE + Wrkspc = Spectr + ENDIF + + ! Pass fraction of wave energy in frac direction + ! Wave spectral direction bin number is assumed to increase anti-clockwise from EAST + ! So positive frac or anticlock case, smaller bin upstream + IF( frac > 0.0 ) THEN + Tmpfrq=Wrkspc(NDirc,:)*frac + DO kk=1, NDirc + Wrkfrq=Wrkspc(kk,:)*frac + Spectr(kk,:)=Wrkspc(kk,:) - Wrkfrq + Tmpfrq + Tmpfrq=Wrkfrq + ENDDO + ELSE + ! Negative or clockwise case, larger bin upstream + Tmpfrq=Wrkspc(1,:)*frac + DO kk=NDirc, 1, -1 + Wrkfrq=Wrkspc(kk,:)*frac + Spectr(kk,:)=Wrkspc(kk,:) + Wrkfrq - Tmpfrq + Tmpfrq=Wrkfrq + ENDDO + ENDIF + + ! Spectral turning completed + + RETURN + END SUBROUTINE W3ACTURN + ! + !Li +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + !Li + !Li Merged UM source code for rotated grid, consisting the following + !Li original subroutines in UM 6.1 + !Li LLTOEQ1A WCOEFF1A and LBCROTWINDS1 + !Li The last subroutine is modified to process only one level winds + !Li cpp directives are removed and required header C_Pi.h inserted. + !Li Jian-Guo Li 26 May 2005 + !Li + !Li The WCOEFF1A subroutine is merged into LLTOEQ to reduce repetition + !Li of the same calculations. Subroutine interface changed to + !Li LLTOEQANGLE + !Li Jian-GUo Li 23 Aug 2005 + !Li + !Li Subroutine W3LLTOEQ -------------------------------------------- + !Li + !Li Purpose: Calculates latitude and longitude on equatorial + !Li latitude-longitude (eq) grid used in regional + !Li models from input arrays of latitude and + !Li longitude on standard grid. Both input and output + !Li latitudes and longitudes are in degrees. + !Li Also calculate rotation angle in degree to tranform + !Li standard wind velocity into equatorial wind. + !Li Valid for 0= 0.0) THEN + SIN_PHI_POLE = SIN(PI_OVER_180*PHI_POLE) + COS_PHI_POLE = COS(PI_OVER_180*PHI_POLE) + ELSE + SIN_PHI_POLE = -SIN(PI_OVER_180*PHI_POLE) + COS_PHI_POLE = -COS(PI_OVER_180*PHI_POLE) + ENDIF + + ! 2. Transform from standard to equatorial latitude-longitude + + DO I= 1, POINTS + + ! Scale longitude to range -180 to +180 degs + + A_LAMBDA=LAMBDA(I)-LAMBDA_ZERO + IF(A_LAMBDA.GT. 180.0) A_LAMBDA=A_LAMBDA-360.D0 + IF(A_LAMBDA.LE.-180.0) A_LAMBDA=A_LAMBDA+360.D0 + + ! Convert latitude & longitude to radians + + A_LAMBDA=PI_OVER_180*A_LAMBDA + A_PHI=PI_OVER_180*PHI(I) + + ! Compute eq latitude using equation (4.4) + + ARG=-COS_PHI_POLE*COS(A_PHI)*COS(A_LAMBDA) & + & +SIN_PHI_POLE*SIN(A_PHI) + ARG=MIN(ARG, 1.D0) + ARG=MAX(ARG,-1.D0) + E_PHI=ASIN(ARG) + PHI_EQ(I)=RECIP_PI_OVER_180*E_PHI + + ! Compute eq longitude using equation (4.6) + + TERM1 = SIN_PHI_POLE*COS(A_PHI)*COS(A_LAMBDA) & + & +COS_PHI_POLE*SIN(A_PHI) + TERM2 = COS(E_PHI) + IF(TERM2 .LT. SMALL) THEN E_LAMBDA=0.D0 - ELSE + ELSE ARG=TERM1/TERM2 ARG=MIN(ARG, 1.D0) ARG=MAX(ARG,-1.D0) E_LAMBDA=RECIP_PI_OVER_180*ACOS(ARG) E_LAMBDA=SIGN(E_LAMBDA,A_LAMBDA) - ENDIF - -! Scale longitude to range 0 to 360 degs - - IF(E_LAMBDA.GE.360.0) E_LAMBDA=E_LAMBDA-360.D0 - IF(E_LAMBDA.LT. 0.0) E_LAMBDA=E_LAMBDA+360.D0 - LAMBDA_EQ(I)=E_LAMBDA - -!Li Calculate turning angle for standard wind velocity - - E_LAMBDA=PI_OVER_180*LAMBDA_EQ(I) - -! Formulae used are from eqs (4.19) and (4.21) - - TERM2=SIN(E_LAMBDA) - ARG= SIN(A_LAMBDA)*TERM2*SIN_PHI_POLE & - & +COS(A_LAMBDA)*COS(E_LAMBDA) - ARG=MIN(ARG, 1.D0) - ARG=MAX(ARG,-1.D0) - TERM1=RECIP_PI_OVER_180*ACOS(ARG) - ANGLED(I)=SIGN(TERM1,TERM2) -!Li - - ENDDO - -! Reset Lambda pole to the setting on entry to subroutine - LAMBDA_POLE=LAMBDA_POLE_KEEP - - RETURN - END SUBROUTINE W3LLTOEQ -! -!Li +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -!Li -!Li Merged UM source code for rotated grid, consiting the following -!Li original subroutines in UM 6.1 -!Li EQTOLL1A WCOEFF1A and LBCROTWINDS1 -!Li The last subroutine is modified to process only one level winds -!Li cpp directives are removed and required header C_Pi.h inserted. -!Li Jian-Guo Li 26 May 2005 -!Li -!Li The WCOEFF1A subroutine is merged into EQTOLL to reduce repetition -!Li of the same calculations. Subroutine interface changed to -!Li EQTOLLANGLE -!Li First created: Jian-GUo Li 23 Aug 2005 -!Li Last modified: Jian-GUo Li 25 Feb 2008 -!Li -!Li Subroutine W3EQTOLL -------------------------------------------- -!Li -!Li Purpose: Calculates latitude and longitude on standard grid -!Li from input arrays of latitude and longitude on -!Li equatorial latitude-longitude (eq) grid used -!Li in regional models. Both input and output latitudes -!Li and longitudes are in degrees. -!Li Also calculate rotation angle in degree to tranform -!Li standard wind velocity into equatorial wind. -!Li Valid for 0= 0.0) THEN - SIN_PHI_POLE = SIN(PI_OVER_180*PHI_POLE) - COS_PHI_POLE = COS(PI_OVER_180*PHI_POLE) - ELSE - SIN_PHI_POLE = -SIN(PI_OVER_180*PHI_POLE) - COS_PHI_POLE = -COS(PI_OVER_180*PHI_POLE) - ENDIF - -! 2. Transform from equatorial to standard latitude-longitude - - DO I= 1, POINTS - -! Scale eq longitude to range -180 to +180 degs - - E_LAMBDA=LAMBDA_EQ(I) - IF(E_LAMBDA.GT. 180.0) E_LAMBDA=E_LAMBDA-360.D0 - IF(E_LAMBDA.LT.-180.0) E_LAMBDA=E_LAMBDA+360.D0 - -! Convert eq latitude & longitude to radians - - E_LAMBDA=PI_OVER_180*E_LAMBDA - E_PHI=PI_OVER_180*PHI_EQ(I) - -! Compute latitude using equation (4.7) - - ARG=COS_PHI_POLE*COS(E_PHI)*COS(E_LAMBDA) & - & +SIN_PHI_POLE*SIN(E_PHI) - ARG=MIN(ARG, 1.D0) - ARG=MAX(ARG,-1.D0) - A_PHI=ASIN(ARG) - PHI(I)=RECIP_PI_OVER_180*A_PHI - -! Compute longitude using equation (4.8) - - TERM1 = COS(E_PHI)*SIN_PHI_POLE*COS(E_LAMBDA) & - & -SIN(E_PHI)*COS_PHI_POLE - TERM2 = COS(A_PHI) - IF(TERM2.LT.SMALL) THEN + ENDIF + + ! Scale longitude to range 0 to 360 degs + + IF(E_LAMBDA.GE.360.0) E_LAMBDA=E_LAMBDA-360.D0 + IF(E_LAMBDA.LT. 0.0) E_LAMBDA=E_LAMBDA+360.D0 + LAMBDA_EQ(I)=E_LAMBDA + + !Li Calculate turning angle for standard wind velocity + + E_LAMBDA=PI_OVER_180*LAMBDA_EQ(I) + + ! Formulae used are from eqs (4.19) and (4.21) + + TERM2=SIN(E_LAMBDA) + ARG= SIN(A_LAMBDA)*TERM2*SIN_PHI_POLE & + & +COS(A_LAMBDA)*COS(E_LAMBDA) + ARG=MIN(ARG, 1.D0) + ARG=MAX(ARG,-1.D0) + TERM1=RECIP_PI_OVER_180*ACOS(ARG) + ANGLED(I)=SIGN(TERM1,TERM2) + !Li + + ENDDO + + ! Reset Lambda pole to the setting on entry to subroutine + LAMBDA_POLE=LAMBDA_POLE_KEEP + + RETURN + END SUBROUTINE W3LLTOEQ + ! + !Li +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + !Li + !Li Merged UM source code for rotated grid, consiting the following + !Li original subroutines in UM 6.1 + !Li EQTOLL1A WCOEFF1A and LBCROTWINDS1 + !Li The last subroutine is modified to process only one level winds + !Li cpp directives are removed and required header C_Pi.h inserted. + !Li Jian-Guo Li 26 May 2005 + !Li + !Li The WCOEFF1A subroutine is merged into EQTOLL to reduce repetition + !Li of the same calculations. Subroutine interface changed to + !Li EQTOLLANGLE + !Li First created: Jian-GUo Li 23 Aug 2005 + !Li Last modified: Jian-GUo Li 25 Feb 2008 + !Li + !Li Subroutine W3EQTOLL -------------------------------------------- + !Li + !Li Purpose: Calculates latitude and longitude on standard grid + !Li from input arrays of latitude and longitude on + !Li equatorial latitude-longitude (eq) grid used + !Li in regional models. Both input and output latitudes + !Li and longitudes are in degrees. + !Li Also calculate rotation angle in degree to tranform + !Li standard wind velocity into equatorial wind. + !Li Valid for 0= 0.0) THEN + SIN_PHI_POLE = SIN(PI_OVER_180*PHI_POLE) + COS_PHI_POLE = COS(PI_OVER_180*PHI_POLE) + ELSE + SIN_PHI_POLE = -SIN(PI_OVER_180*PHI_POLE) + COS_PHI_POLE = -COS(PI_OVER_180*PHI_POLE) + ENDIF + + ! 2. Transform from equatorial to standard latitude-longitude + + DO I= 1, POINTS + + ! Scale eq longitude to range -180 to +180 degs + + E_LAMBDA=LAMBDA_EQ(I) + IF(E_LAMBDA.GT. 180.0) E_LAMBDA=E_LAMBDA-360.D0 + IF(E_LAMBDA.LT.-180.0) E_LAMBDA=E_LAMBDA+360.D0 + + ! Convert eq latitude & longitude to radians + + E_LAMBDA=PI_OVER_180*E_LAMBDA + E_PHI=PI_OVER_180*PHI_EQ(I) + + ! Compute latitude using equation (4.7) + + ARG=COS_PHI_POLE*COS(E_PHI)*COS(E_LAMBDA) & + & +SIN_PHI_POLE*SIN(E_PHI) + ARG=MIN(ARG, 1.D0) + ARG=MAX(ARG,-1.D0) + A_PHI=ASIN(ARG) + PHI(I)=RECIP_PI_OVER_180*A_PHI + + ! Compute longitude using equation (4.8) + + TERM1 = COS(E_PHI)*SIN_PHI_POLE*COS(E_LAMBDA) & + & -SIN(E_PHI)*COS_PHI_POLE + TERM2 = COS(A_PHI) + IF(TERM2.LT.SMALL) THEN A_LAMBDA=0.D0 - ELSE + ELSE ARG=TERM1/TERM2 ARG=MIN(ARG, 1.D0) ARG=MAX(ARG,-1.D0) A_LAMBDA=RECIP_PI_OVER_180*ACOS(ARG) A_LAMBDA=SIGN(A_LAMBDA,E_LAMBDA) A_LAMBDA=A_LAMBDA+LAMBDA_ZERO - END IF - -! Scale longitude to range 0 to 360 degs - - IF(A_LAMBDA.GE.360.0) A_LAMBDA=A_LAMBDA-360.D0 - IF(A_LAMBDA.LT. 0.0) A_LAMBDA=A_LAMBDA+360.D0 - LAMBDA(I)=A_LAMBDA - -!Li Calculate turning angle for standard wind velocity - - A_LAMBDA=PI_OVER_180*(LAMBDA(I)-LAMBDA_ZERO) - -! Formulae used are from eqs (4.19) and (4.21) - - TERM2=SIN(E_LAMBDA) - ARG=SIN(A_LAMBDA)*TERM2*SIN_PHI_POLE & - & +COS(A_LAMBDA)*COS(E_LAMBDA) - ARG=MIN(ARG, 1.D0) - ARG=MAX(ARG,-1.D0) - TERM1=RECIP_PI_OVER_180*ACOS(ARG) - ANGLED(I)=SIGN(TERM1,TERM2) -!Li - - ENDDO - - RETURN - END SUBROUTINE W3EQTOLL - -!Li -!/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / - SUBROUTINE W3THRTN ( NSEA, THETA, AnglD, Degrees ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NMC | -!/ | A. Saulter | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mar-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mar-2018 : Added subroutine ( version 6.02 ) -! -! 1. Purpose : -! Subroutine to de-rotate directions from rotated to standard pole -! reference system -! -! 2. Method: -! Rotates x,y vectors anticlockwise by angle alpha in radians -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY : DERA, TPI, UNDEF - IMPLICIT NONE -! -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NSEA ! Number of sea points - REAL, INTENT(IN) :: AnglD(NSEA) ! Turning angle (degrees) - LOGICAL, INTENT(IN) :: Degrees ! Use degrees or radians - REAL, INTENT(INOUT) :: THETA(NSEA) ! Direction seapoint array -! -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ISEA -! -!/ ------------------------------------------------------------------- / -! Apply the rotation -! - DO ISEA=1, NSEA - IF ( THETA(ISEA) .NE. UNDEF ) THEN + END IF + + ! Scale longitude to range 0 to 360 degs + + IF(A_LAMBDA.GE.360.0) A_LAMBDA=A_LAMBDA-360.D0 + IF(A_LAMBDA.LT. 0.0) A_LAMBDA=A_LAMBDA+360.D0 + LAMBDA(I)=A_LAMBDA + + !Li Calculate turning angle for standard wind velocity + + A_LAMBDA=PI_OVER_180*(LAMBDA(I)-LAMBDA_ZERO) + + ! Formulae used are from eqs (4.19) and (4.21) + + TERM2=SIN(E_LAMBDA) + ARG=SIN(A_LAMBDA)*TERM2*SIN_PHI_POLE & + & +COS(A_LAMBDA)*COS(E_LAMBDA) + ARG=MIN(ARG, 1.D0) + ARG=MAX(ARG,-1.D0) + TERM1=RECIP_PI_OVER_180*ACOS(ARG) + ANGLED(I)=SIGN(TERM1,TERM2) + !Li + + ENDDO + + RETURN + END SUBROUTINE W3EQTOLL + + !Li + !/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + SUBROUTINE W3THRTN ( NSEA, THETA, AnglD, Degrees ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NMC | + !/ | A. Saulter | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mar-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mar-2018 : Added subroutine ( version 6.02 ) + ! + ! 1. Purpose : + ! Subroutine to de-rotate directions from rotated to standard pole + ! reference system + ! + ! 2. Method: + ! Rotates x,y vectors anticlockwise by angle alpha in radians + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY : DERA, TPI, UNDEF + ! + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NSEA ! Number of sea points + REAL, INTENT(IN) :: AnglD(NSEA) ! Turning angle (degrees) + LOGICAL, INTENT(IN) :: Degrees ! Use degrees or radians + REAL, INTENT(INOUT) :: THETA(NSEA) ! Direction seapoint array + ! + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ISEA + ! + !/ ------------------------------------------------------------------- / + ! Apply the rotation + ! + DO ISEA=1, NSEA + IF ( THETA(ISEA) .NE. UNDEF ) THEN IF ( Degrees ) THEN - THETA(ISEA) = THETA(ISEA) - AnglD(ISEA) - IF ( THETA(ISEA) .LT. 0 ) THETA(ISEA) = THETA(ISEA) + 360.0 + THETA(ISEA) = THETA(ISEA) - AnglD(ISEA) + IF ( THETA(ISEA) .LT. 0 ) THETA(ISEA) = THETA(ISEA) + 360.0 ELSE - THETA(ISEA) = THETA(ISEA) - AnglD(ISEA)*DERA - IF ( THETA(ISEA) .LT. 0 ) THETA(ISEA) = THETA(ISEA) + TPI + THETA(ISEA) = THETA(ISEA) - AnglD(ISEA)*DERA + IF ( THETA(ISEA) .LT. 0 ) THETA(ISEA) = THETA(ISEA) + TPI END IF - ENDIF - END DO - - RETURN - END SUBROUTINE W3THRTN -! -!/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / - SUBROUTINE W3XYRTN ( NSEA, XVEC, YVEC, AnglD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NMC | -!/ | A. Saulter | -!/ | FORTRAN 90 | -!/ | Last update : 01-Mar-2018 | -!/ +-----------------------------------+ -!/ -!/ 01-Mar-2018 : Added subroutine ( version 6.02 ) -! -! 1. Purpose : -! Subroutine to de-rotate x,y vectors from rotated to standard pole -! reference system -! -! 2. Method: -! Rotates x,y vectors anticlockwise by angle alpha in radians -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY : DERA, TPI, UNDEF - IMPLICIT NONE -! -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ - INTEGER, INTENT(IN) :: NSEA ! Number of sea points - REAL, INTENT(IN) :: AnglD(NSEA) ! Turning angle (degrees) - REAL, INTENT(INOUT) :: XVEC(NSEA), YVEC(NSEA) -! -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ - INTEGER :: ISEA - REAL :: XVTMP, YVTMP -! -!/ ------------------------------------------------------------------- / -! Apply the rotation -! - DO ISEA=1, NSEA - IF (( XVEC(ISEA) .NE. UNDEF ) .AND. & + ENDIF + END DO + + RETURN + END SUBROUTINE W3THRTN + ! + !/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + SUBROUTINE W3XYRTN ( NSEA, XVEC, YVEC, AnglD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NMC | + !/ | A. Saulter | + !/ | FORTRAN 90 | + !/ | Last update : 01-Mar-2018 | + !/ +-----------------------------------+ + !/ + !/ 01-Mar-2018 : Added subroutine ( version 6.02 ) + ! + ! 1. Purpose : + ! Subroutine to de-rotate x,y vectors from rotated to standard pole + ! reference system + ! + ! 2. Method: + ! Rotates x,y vectors anticlockwise by angle alpha in radians + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY : DERA, TPI, UNDEF + ! + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ + INTEGER, INTENT(IN) :: NSEA ! Number of sea points + REAL, INTENT(IN) :: AnglD(NSEA) ! Turning angle (degrees) + REAL, INTENT(INOUT) :: XVEC(NSEA), YVEC(NSEA) + ! + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ISEA + REAL :: XVTMP, YVTMP + ! + !/ ------------------------------------------------------------------- / + ! Apply the rotation + ! + DO ISEA=1, NSEA + IF (( XVEC(ISEA) .NE. UNDEF ) .AND. & ( YVEC(ISEA) .NE. UNDEF )) THEN XVTMP = XVEC(ISEA)*COS(AnglD(ISEA)*DERA) + & - YVEC(ISEA)*SIN(AnglD(ISEA)*DERA) + YVEC(ISEA)*SIN(AnglD(ISEA)*DERA) YVTMP = YVEC(ISEA)*COS(AnglD(ISEA)*DERA) - & - XVEC(ISEA)*SIN(AnglD(ISEA)*DERA) + XVEC(ISEA)*SIN(AnglD(ISEA)*DERA) XVEC(ISEA) = XVTMP YVEC(ISEA) = YVTMP - END IF - END DO - - RETURN - END SUBROUTINE W3XYRTN -! -!/ ------------------------------------------------------------------- / -!/ ------------------------------------------------------------------- / -!/ - SUBROUTINE STRSPLIT(STRING,TAB) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | M. Accensi | -!/ | FORTRAN 90 | -!/ | Last update : 29-Apr-2013 ! -!/ +-----------------------------------+ -!/ -!/ 29-Mar-2013 : Origination. ( version 4.10 ) -!/ -! 1. Purpose : -! -! Splits string into words -! -! 2. Method : -! -! finds spaces and loops -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! STRING Str O String to be splitted -! TAB Str O Array of strings -! ---------------------------------------------------------------- -! - - IMPLICIT NONE - - - - CHARACTER(LEN=*), intent(IN) :: STRING - CHARACTER(LEN=100), intent(INOUT) :: TAB(*) - INTEGER :: cnt, I - CHARACTER(LEN=1024) :: tmp_str, ori_str - -! initializes arrays - ori_str=ADJUSTL(TRIM(STRING)) - tmp_str=ori_str - cnt=0 - -! counts the number of substrings - DO WHILE ((INDEX(tmp_str,' ').NE.0) .AND. (len_trim(tmp_str).NE.0)) - tmp_str=ADJUSTL(tmp_str(INDEX(tmp_str,' ')+1:)) - cnt=cnt+1 - ENDDO -! -! reinitializes arrays -! - tmp_str=ori_str -! loops on each substring - DO I=1,cnt - TAB(I)=tmp_str(:INDEX(tmp_str,' ')) - tmp_str=ADJUSTL(tmp_str(INDEX(tmp_str,' ')+1:)) - END DO - - RETURN -!/ -!/ End of STRSPLIT ----------------------------------------------------- / -!/ - END SUBROUTINE STRSPLIT -!/ - -!/ ------------------------------------------------------------------- / - SUBROUTINE STR_TO_UPPER(STR) - character(*), intent(inout) :: str - integer :: i - - DO i = 1, len(str) + END IF + END DO + + RETURN + END SUBROUTINE W3XYRTN + ! + !/ ------------------------------------------------------------------- / + !/ ------------------------------------------------------------------- / + !/ + SUBROUTINE STRSPLIT(STRING,TAB) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | M. Accensi | + !/ | FORTRAN 90 | + !/ | Last update : 29-Apr-2013 ! + !/ +-----------------------------------+ + !/ + !/ 29-Mar-2013 : Origination. ( version 4.10 ) + !/ + ! 1. Purpose : + ! + ! Splits string into words + ! + ! 2. Method : + ! + ! finds spaces and loops + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! STRING Str O String to be splitted + ! TAB Str O Array of strings + ! ---------------------------------------------------------------- + ! + CHARACTER(LEN=*), intent(IN) :: STRING + CHARACTER(LEN=100), intent(INOUT) :: TAB(*) + INTEGER :: cnt, I + CHARACTER(LEN=1024) :: tmp_str, ori_str + + ! initializes arrays + ori_str=ADJUSTL(TRIM(STRING)) + tmp_str=ori_str + cnt=0 + + ! counts the number of substrings + DO WHILE ((INDEX(tmp_str,' ').NE.0) .AND. (len_trim(tmp_str).NE.0)) + tmp_str=ADJUSTL(tmp_str(INDEX(tmp_str,' ')+1:)) + cnt=cnt+1 + ENDDO + ! + ! reinitializes arrays + ! + tmp_str=ori_str + ! loops on each substring + DO I=1,cnt + TAB(I)=tmp_str(:INDEX(tmp_str,' ')) + tmp_str=ADJUSTL(tmp_str(INDEX(tmp_str,' ')+1:)) + END DO + + RETURN + !/ + !/ End of STRSPLIT ----------------------------------------------------- / + !/ + END SUBROUTINE STRSPLIT + !/ + + !/ ------------------------------------------------------------------- / + SUBROUTINE STR_TO_UPPER(STR) + character(*), intent(inout) :: str + integer :: i + + DO i = 1, len(str) select case(str(i:i)) - case("a":"z") - str(i:i) = achar(iachar(str(i:i))-32) + case("a":"z") + str(i:i) = achar(iachar(str(i:i))-32) end select - END DO -!/ End of STR_TO_UPPER -!/ ------------------------------------------------------------------- / -END SUBROUTINE STR_TO_UPPER - -!********************************************************************** -!* * -#ifdef W3_T -!********************************************************************** - SUBROUTINE SSORT1 (X, Y, N, KFLAG) -!***BEGIN PROLOGUE SSORT -!***PURPOSE Sort an array and optionally make the same interchanges in -! an auxiliary array. The array may be sorted in increasing -! or decreasing order. A slightly modified QUICKSORT -! algorithm is used. -!***LIBRARY SLATEC -!***CATEGORY N6A2B -!***TYPE SINGLE PRECISION (SSORT-S, DSORT-D, ISORT-I) -!***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING -!***AUTHOR Jones, R. E., (SNLA) -! Wisniewski, J. A., (SNLA) -!***DESCRIPTION -! -! SSORT sorts array X and optionally makes the same interchanges in -! array Y. The array X may be sorted in increasing order or -! decreasing order. A slightly modified quicksort algorithm is used. -! -! Description of Parameters -! X - array of values to be sorted (usually abscissas) -! Y - array to be (optionally) carried along -! N - number of values in array X to be sorted -! KFLAG - control parameter -! = 2 means sort X in increasing order and carry Y along. -! = 1 means sort X in increasing order (ignoring Y) -! = -1 means sort X in decreasing order (ignoring Y) -! = -2 means sort X in decreasing order and carry Y along. -! -!***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm -! for sorting with minimal storage, Communications of -! the ACM, 12, 3 (1969), pp. 185-187. -!***REVISION HISTORY (YYMMDD) -! 761101 DATE WRITTEN -! 761118 Modified to use the Singleton quicksort algorithm. (JAW) -! 890531 Changed all specific intrinsics to generic. (WRB) -! 890831 Modified array declarations. (WRB) -! 891009 Removed unreferenced statement labels. (WRB) -! 891024 Changed category. (WRB) -! 891024 REVISION DATE from Version 3.2 -! 891214 Prologue converted to Version 4.0 format. (BAB) -! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -! 901012 Declared all variables; changed X,Y to SX,SY. (M. McClain) -! 920501 Reformatted the REFERENCES section. (DWL, WRB) -! 920519 Clarified error messages. (DWL) -! 920801 Declarations section rebuilt and code restructured to use -! IF-THEN-ELSE-ENDIF. (RWC, WRB) -!***END PROLOGUE SSORT -! .. Scalar Arguments .. - INTEGER KFLAG, N -! .. Array Arguments .. - REAL*4 X(*), Y(*) -! .. Local Scalars .. - REAL*4 R, T, TT, TTY, TY - INTEGER I, IJ, J, K, KK, L, M, NN -! .. Local Arrays .. - INTEGER IL(21), IU(21) -! .. External Subroutines .. -! None -! .. Intrinsic Functions .. - INTRINSIC ABS, INT -!***FIRST EXECUTABLE STATEMENT SSORT - NN = N - IF (NN .LT. 1) THEN - WRITE (*,*) 'The number of values to be sorted is not positive.' - RETURN - ENDIF -! - KK = ABS(KFLAG) - IF (KK.NE.1 .AND. KK.NE.2) THEN - WRITE (*,*) 'The sort control parameter, K, is not 2, 1, -1, or -2.' - RETURN - ENDIF -! -! Alter array X to get decreasing order if needed -! - IF (KFLAG .LE. -1) THEN - DO 10 I=1,NN - X(I) = -X(I) - 10 CONTINUE - ENDIF -! - IF (KK .EQ. 2) GO TO 100 -! -! Sort X only -! - M = 1 - I = 1 - J = NN - R = 0.375E0 -! - 20 IF (I .EQ. J) GO TO 60 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -! - 30 K = I -! -! Select a central element of the array and save it in location T -! - IJ = I + INT((J-I)*R) - T = X(IJ) -! -! If first element of array is greater than T, interchange with T -! - IF (X(I) .GT. T) THEN - X(IJ) = X(I) - X(I) = T - T = X(IJ) - ENDIF - L = J -! -! If last element of array is less than than T, interchange with T -! - IF (X(J) .LT. T) THEN - X(IJ) = X(J) - X(J) = T - T = X(IJ) -! -! If first element of array is greater than T, interchange with T -! - IF (X(I) .GT. T) THEN - X(IJ) = X(I) - X(I) = T - T = X(IJ) - ENDIF - ENDIF -! -! Find an element in the second half of the array which is smaller -! than T -! - 40 L = L-1 - IF (X(L) .GT. T) GO TO 40 -! -! Find an element in the first half of the array which is greater -! than T -! - 50 K = K+1 - IF (X(K) .LT. T) GO TO 50 -! -! Interchange these elements -! - IF (K .LE. L) THEN - TT = X(L) - X(L) = X(K) - X(K) = TT - GO TO 40 - ENDIF -! -! Save upper and lower subscripts of the array yet to be sorted -! - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 70 -! -! Begin again on another portion of the unsorted array -! - 60 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -! - 70 IF (J-I .GE. 1) GO TO 30 - IF (I .EQ. 1) GO TO 20 - I = I-1 -! - 80 I = I+1 - IF (I .EQ. J) GO TO 60 - T = X(I+1) - IF (X(I) .LE. T) GO TO 80 - K = I -! - 90 X(K+1) = X(K) - K = K-1 - IF (T .LT. X(K)) GO TO 90 - X(K+1) = T - GO TO 80 -! -! Sort X and carry Y along -! - 100 M = 1 - I = 1 - J = NN - R = 0.375E0 -! - 110 IF (I .EQ. J) GO TO 150 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -! - 120 K = I -! -! Select a central element of the array and save it in location T -! - IJ = I + INT((J-I)*R) - T = X(IJ) - TY = Y(IJ) -! -! If first element of array is greater than T, interchange with T -! - IF (X(I) .GT. T) THEN - X(IJ) = X(I) - X(I) = T - T = X(IJ) - Y(IJ) = Y(I) - Y(I) = TY - TY = Y(IJ) - ENDIF - L = J -! -! If last element of array is less than T, interchange with T -! - IF (X(J) .LT. T) THEN - X(IJ) = X(J) - X(J) = T - T = X(IJ) - Y(IJ) = Y(J) - Y(J) = TY - TY = Y(IJ) -! -! If first element of array is greater than T, interchange with T -! - IF (X(I) .GT. T) THEN - X(IJ) = X(I) - X(I) = T - T = X(IJ) - Y(IJ) = Y(I) - Y(I) = TY - TY = Y(IJ) - ENDIF - ENDIF -! -! Find an element in the second half of the array which is smaller -! than T -! - 130 L = L-1 - IF (X(L) .GT. T) GO TO 130 -! -! Find an element in the first half of the array which is greater -! than T -! - 140 K = K+1 - IF (X(K) .LT. T) GO TO 140 -! -! Interchange these elements -! - IF (K .LE. L) THEN - TT = X(L) - X(L) = X(K) - X(K) = TT - TTY = Y(L) - Y(L) = Y(K) - Y(K) = TTY - GO TO 130 - ENDIF -! -! Save upper and lower subscripts of the array yet to be sorted -! - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 160 -! -! Begin again on another portion of the unsorted array -! - 150 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -! - 160 IF (J-I .GE. 1) GO TO 120 - IF (I .EQ. 1) GO TO 110 - I = I-1 -! - 170 I = I+1 - IF (I .EQ. J) GO TO 150 - T = X(I+1) - TY = Y(I+1) - IF (X(I) .LE. T) GO TO 170 - K = I -! - 180 X(K+1) = X(K) - Y(K+1) = Y(K) - K = K-1 - IF (T .LT. X(K)) GO TO 180 - X(K+1) = T - Y(K+1) = TY - GO TO 170 -! -! Clean up -! - 190 IF (KFLAG .LE. -1) THEN - DO 200 I=1,NN - X(I) = -X(I) - 200 CONTINUE - ENDIF - RETURN - END SUBROUTINE SSORT1 - -#endif - -!********************************************************************* - SUBROUTINE DIAGONALIZE(a1,d,v,nrot) -!********************************************************************* - IMPLICIT NONE - INTEGER, INTENT(out) :: nrot - DOUBLE PRECISION, DIMENSION(:) , INTENT(OUT) ::d - DOUBLE PRECISION, DIMENSION(:,:), INTENT(IN) ::a1 ! Modified from INOUT to IN by F.A. on 2018/01/21 - DOUBLE PRECISION, DIMENSION(:,:), INTENT(OUT) ::v - - INTEGER i,j,ip,iq,n - DOUBLE PRECISION c,g,h,s,sm,t,tau,theta,tresh - DOUBLE PRECISION , DIMENSION(size(d)) ::b,z - DOUBLE PRECISION, DIMENSION(size(d),size(d)) :: a - LOGICAL, DIMENSION(size(d),size(d)) :: upper_triangle - - a=a1 - n=size(d) - v(:,:)=0. - upper_triangle(:,:)=.FALSE. - DO I=1,n - v(I,I)=1. - b(I)=a(I,I) - DO J=I+1,n - upper_triangle(I,J)=.TRUE. - ENDDO - ENDDO - d(:)=b(:) - z(:)=0.0 - nrot=0 - DO I=1,50 - sm=SUM(ABS(a),mask=upper_triangle) - IF (sm.EQ.0.0) RETURN - tresh=merge(0.2*sm/n**2,0.0D0,i<4) - DO ip=1,n-1 - do iq=ip+1,n - g=100.0*abs(a(ip,iq)) - IF((i > 4).AND.(ABS(d(ip))+g.EQ.abs(d(ip))) & - .AND.(ABS(d(iq))+g.EQ.abs(d(iq)))) THEN - a(ip,iq)=0.0 - ELSE IF (abs(a(ip,iq)) > tresh) THEN - h=d(iq)-d(ip) - if (abs(h)+g == abs(h)) THEN - t=a(ip,iq)/h - ELSE - theta=0.5*h/a(ip,iq) - t=1.0/(abs(theta)+sqrt(1.0+theta**2)) - IF ( theta < 0.0) t=-t - ENDIF - c=1.0/sqrt(1+t**2) - s=t*c - tau=s/(1.0+c) - h=t*a(ip,iq) - z(ip)=z(ip)-h - z(iq)=z(iq)+h - d(ip)=d(ip)-h - d(iq)=d(iq)+h - a(ip,iq)=0.0 - IF (ip.GE.1) CALL ROTATE(a(1:ip-1,ip),a(1:ip-1,iq)) -!The IF test was added by F.A. (2005/04/04) because of the following error: -!Subscript out of range. Location: line 593 column 36 of 'cb_botsc.f90' -!Subscript number 1 has value 0 in array 'A' - CALL ROTATE(a(ip,ip+1:iq-1),a(ip+1:iq-1,iq)) - CALL ROTATE(a(ip,iq+1:n),a(iq,iq+1:n)) - CALL ROTATE(v(:,ip),v(:,iq)) - nrot=nrot+1 - ENDIF - ENDDO - ENDDO - b(:)=b(:)+z(:) - d(:)=b(:) - z(:)=0.0 - ENDDO - WRITE(6,*) 'Too many iterations in DIAGONALIZE' - CONTAINS - SUBROUTINE ROTATE(X1,X2) - DOUBLE PRECISION, DIMENSION(:), INTENT(INOUT) :: X1,X2 - DOUBLE PRECISION, DIMENSION(size(X1)) :: MEM - MEM(:)=X1(:) - X1(:)=X1(:)-s*(X2(:)+X1(:)*tau) - X2(:)=X2(:)+s*(MEM(:)-X2(:)*tau) - END SUBROUTINE ROTATE - END SUBROUTINE DIAGONALIZE - -!/ ------------------------------------------------------------------- / - SUBROUTINE UV_TO_MAG_DIR(U, V, NSEA, MAG, DIR, TOLERANCE, CONV) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | C. Bunney | -!/ | FORTRAN 90 | -!/ | Last update : 15-Jan-2021 | -!/ +-----------------------------------+ -!/ -!/ 15-Jan-2021 : Creation ( version 7.12 ) -!/ -! 1. Purpose : -! -! Converts seapoint arrays formulated as U/V vectors into magnitude -! and direction arrays. -! -! If MAG and DIR input parameters are not specificed then the -! conversion is performed in-place (U => MAG, v => DIR). -! -! 2. Parameters -! -! Parameter list -! ---------------------------------------------------------------- -! U/V R.Arr I Array of U/V components -! NSEA Int I Number of sea points -! MAG R.Arr O Magnitude array (Optional) -! DIR R.Arr O Direction array (degrees) (Optional) -! TOLERANCE Real I Minimum allowed magnitude (Optional) -! CONV Char I Ouput direciton convention (Optional) -! ---------------------------------------------------------------- -! -! 3. Remarks -! -! Optional CONV specifies direction convention. Must be one of: -! 'N'=Nautical : North=0, clockwise, direction-from (default) -! 'O'=Oceangraphic : North=0, clockwise, direction-to -! 'C'=Cartesian : North=90, counter-clockwise, direction-to -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS, ONLY: RADE, UNDEF - IMPLICIT NONE - - REAL, INTENT(INOUT) :: U(NSEA), V(NSEA) - INTEGER, INTENT(IN) :: NSEA - REAL, INTENT(OUT), OPTIONAL :: MAG(NSEA), DIR(NSEA) - REAL, INTENT(IN), OPTIONAL :: TOLERANCE - CHARACTER, INTENT(IN), OPTIONAL :: CONV -!/ ------------------------------------------------------------------- / -!/ Local parameters -! - REAL :: TOL, SGN, OFFSET, TMP - CHARACTER :: DIRCONV - INTEGER :: ISEA - LOGICAL :: INPLACE - - DIRCONV = 'N' - TOL = 1.0 - INPLACE = .TRUE. - IF(PRESENT(TOLERANCE)) TOL = TOLERANCE - IF(PRESENT(CONV)) DIRCONV = CONV - IF(PRESENT(MAG) .AND. PRESENT(DIR)) INPLACE = .FALSE. - - SELECT CASE (CONV) - CASE('N') - OFFSET = 630. - SGN = -1. - CASE('O') - OFFSET = 450. - SGN = -1. - CASE('C') - OFFSET = 360. - SGN = 1. - CASE DEFAULT - WRITE(*,*) "UV_TO_MAG_DIR: UNKNOWN DIR CONVENTION: ", DIRCONV - CALL EXTCDE(1) - END SELECT - - IF(INPLACE) THEN - DO ISEA=1, NSEA - TMP = SQRT(U(ISEA)**2 + V(ISEA)**2) - IF(TMP .GE. TOL) THEN - V(ISEA) = MOD(OFFSET + (SGN * RADE * ATAN2(V(ISEA), U(ISEA))), 360.) - U(ISEA) = TMP - ELSE - U(ISEA) = UNDEF - V(ISEA) = UNDEF - END IF - END DO - ELSE - DO ISEA=1, NSEA - MAG(ISEA) = SQRT(U(ISEA)**2 + V(ISEA)**2) - IF(MAG(ISEA) .GE. TOL) THEN - DIR(ISEA) = MOD(OFFSET + (SGN * RADE * ATAN2(V(ISEA), U(ISEA))), 360.) + END DO + !/ End of STR_TO_UPPER + !/ ------------------------------------------------------------------- / + END SUBROUTINE STR_TO_UPPER + + !********************************************************************** + !* * + !********************************************************************** + SUBROUTINE SSORT1 (X, Y, N, KFLAG) + !***BEGIN PROLOGUE SSORT + !***PURPOSE Sort an array and optionally make the same interchanges in + ! an auxiliary array. The array may be sorted in increasing + ! or decreasing order. A slightly modified QUICKSORT + ! algorithm is used. + !***LIBRARY SLATEC + !***CATEGORY N6A2B + !***TYPE SINGLE PRECISION (SSORT-S, DSORT-D, ISORT-I) + !***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING + !***AUTHOR Jones, R. E., (SNLA) + ! Wisniewski, J. A., (SNLA) + !***DESCRIPTION + ! + ! SSORT sorts array X and optionally makes the same interchanges in + ! array Y. The array X may be sorted in increasing order or + ! decreasing order. A slightly modified quicksort algorithm is used. + ! + ! Description of Parameters + ! X - array of values to be sorted (usually abscissas) + ! Y - array to be (optionally) carried along + ! N - number of values in array X to be sorted + ! KFLAG - control parameter + ! = 2 means sort X in increasing order and carry Y along. + ! = 1 means sort X in increasing order (ignoring Y) + ! = -1 means sort X in decreasing order (ignoring Y) + ! = -2 means sort X in decreasing order and carry Y along. + ! + !***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm + ! for sorting with minimal storage, Communications of + ! the ACM, 12, 3 (1969), pp. 185-187. + !***REVISION HISTORY (YYMMDD) + ! 761101 DATE WRITTEN + ! 761118 Modified to use the Singleton quicksort algorithm. (JAW) + ! 890531 Changed all specific intrinsics to generic. (WRB) + ! 890831 Modified array declarations. (WRB) + ! 891009 Removed unreferenced statement labels. (WRB) + ! 891024 Changed category. (WRB) + ! 891024 REVISION DATE from Version 3.2 + ! 891214 Prologue converted to Version 4.0 format. (BAB) + ! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) + ! 901012 Declared all variables; changed X,Y to SX,SY. (M. McClain) + ! 920501 Reformatted the REFERENCES section. (DWL, WRB) + ! 920519 Clarified error messages. (DWL) + ! 920801 Declarations section rebuilt and code restructured to use + ! IF-THEN-ELSE-ENDIF. (RWC, WRB) + !***END PROLOGUE SSORT + ! .. Scalar Arguments .. + INTEGER KFLAG, N + ! .. Array Arguments .. + REAL*4 X(*), Y(*) + ! .. Local Scalars .. + REAL*4 R, T, TT, TTY, TY + INTEGER I, IJ, J, K, KK, L, M, NN + ! .. Local Arrays .. + INTEGER IL(21), IU(21) + ! .. External Subroutines .. + ! None + ! .. Intrinsic Functions .. + INTRINSIC ABS, INT + !***FIRST EXECUTABLE STATEMENT SSORT + NN = N + IF (NN .LT. 1) THEN + WRITE (*,*) 'The number of values to be sorted is not positive.' + RETURN + ENDIF + ! + KK = ABS(KFLAG) + IF (KK.NE.1 .AND. KK.NE.2) THEN + WRITE (*,*) 'The sort control parameter, K, is not 2, 1, -1, or -2.' + RETURN + ENDIF + ! + ! Alter array X to get decreasing order if needed + ! + IF (KFLAG .LE. -1) THEN + DO 10 I=1,NN + X(I) = -X(I) +10 CONTINUE + ENDIF + ! + IF (KK .EQ. 2) GO TO 100 + ! + ! Sort X only + ! + M = 1 + I = 1 + J = NN + R = 0.375E0 + ! +20 IF (I .EQ. J) GO TO 60 + IF (R .LE. 0.5898437E0) THEN + R = R+3.90625E-2 + ELSE + R = R-0.21875E0 + ENDIF + ! +30 K = I + ! + ! Select a central element of the array and save it in location T + ! + IJ = I + INT((J-I)*R) + T = X(IJ) + ! + ! If first element of array is greater than T, interchange with T + ! + IF (X(I) .GT. T) THEN + X(IJ) = X(I) + X(I) = T + T = X(IJ) + ENDIF + L = J + ! + ! If last element of array is less than than T, interchange with T + ! + IF (X(J) .LT. T) THEN + X(IJ) = X(J) + X(J) = T + T = X(IJ) + ! + ! If first element of array is greater than T, interchange with T + ! + IF (X(I) .GT. T) THEN + X(IJ) = X(I) + X(I) = T + T = X(IJ) + ENDIF + ENDIF + ! + ! Find an element in the second half of the array which is smaller + ! than T + ! +40 L = L-1 + IF (X(L) .GT. T) GO TO 40 + ! + ! Find an element in the first half of the array which is greater + ! than T + ! +50 K = K+1 + IF (X(K) .LT. T) GO TO 50 + ! + ! Interchange these elements + ! + IF (K .LE. L) THEN + TT = X(L) + X(L) = X(K) + X(K) = TT + GO TO 40 + ENDIF + ! + ! Save upper and lower subscripts of the array yet to be sorted + ! + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M+1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M+1 + ENDIF + GO TO 70 + ! + ! Begin again on another portion of the unsorted array + ! +60 M = M-1 + IF (M .EQ. 0) GO TO 190 + I = IL(M) + J = IU(M) + ! +70 IF (J-I .GE. 1) GO TO 30 + IF (I .EQ. 1) GO TO 20 + I = I-1 + ! +80 I = I+1 + IF (I .EQ. J) GO TO 60 + T = X(I+1) + IF (X(I) .LE. T) GO TO 80 + K = I + ! +90 X(K+1) = X(K) + K = K-1 + IF (T .LT. X(K)) GO TO 90 + X(K+1) = T + GO TO 80 + ! + ! Sort X and carry Y along + ! +100 M = 1 + I = 1 + J = NN + R = 0.375E0 + ! +110 IF (I .EQ. J) GO TO 150 + IF (R .LE. 0.5898437E0) THEN + R = R+3.90625E-2 + ELSE + R = R-0.21875E0 + ENDIF + ! +120 K = I + ! + ! Select a central element of the array and save it in location T + ! + IJ = I + INT((J-I)*R) + T = X(IJ) + TY = Y(IJ) + ! + ! If first element of array is greater than T, interchange with T + ! + IF (X(I) .GT. T) THEN + X(IJ) = X(I) + X(I) = T + T = X(IJ) + Y(IJ) = Y(I) + Y(I) = TY + TY = Y(IJ) + ENDIF + L = J + ! + ! If last element of array is less than T, interchange with T + ! + IF (X(J) .LT. T) THEN + X(IJ) = X(J) + X(J) = T + T = X(IJ) + Y(IJ) = Y(J) + Y(J) = TY + TY = Y(IJ) + ! + ! If first element of array is greater than T, interchange with T + ! + IF (X(I) .GT. T) THEN + X(IJ) = X(I) + X(I) = T + T = X(IJ) + Y(IJ) = Y(I) + Y(I) = TY + TY = Y(IJ) + ENDIF + ENDIF + ! + ! Find an element in the second half of the array which is smaller + ! than T + ! +130 L = L-1 + IF (X(L) .GT. T) GO TO 130 + ! + ! Find an element in the first half of the array which is greater + ! than T + ! +140 K = K+1 + IF (X(K) .LT. T) GO TO 140 + ! + ! Interchange these elements + ! + IF (K .LE. L) THEN + TT = X(L) + X(L) = X(K) + X(K) = TT + TTY = Y(L) + Y(L) = Y(K) + Y(K) = TTY + GO TO 130 + ENDIF + ! + ! Save upper and lower subscripts of the array yet to be sorted + ! + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M+1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M+1 + ENDIF + GO TO 160 + ! + ! Begin again on another portion of the unsorted array + ! +150 M = M-1 + IF (M .EQ. 0) GO TO 190 + I = IL(M) + J = IU(M) + ! +160 IF (J-I .GE. 1) GO TO 120 + IF (I .EQ. 1) GO TO 110 + I = I-1 + ! +170 I = I+1 + IF (I .EQ. J) GO TO 150 + T = X(I+1) + TY = Y(I+1) + IF (X(I) .LE. T) GO TO 170 + K = I + ! +180 X(K+1) = X(K) + Y(K+1) = Y(K) + K = K-1 + IF (T .LT. X(K)) GO TO 180 + X(K+1) = T + Y(K+1) = TY + GO TO 170 + ! + ! Clean up + ! +190 IF (KFLAG .LE. -1) THEN + DO 200 I=1,NN + X(I) = -X(I) +200 CONTINUE + ENDIF + RETURN + END SUBROUTINE SSORT1 + + !********************************************************************* + SUBROUTINE DIAGONALIZE(a1,d,v,nrot) + !********************************************************************* + + INTEGER, INTENT(out) :: nrot + DOUBLE PRECISION, DIMENSION(:) , INTENT(OUT) ::d + DOUBLE PRECISION, DIMENSION(:,:), INTENT(IN) ::a1 ! Modified from INOUT to IN by F.A. on 2018/01/21 + DOUBLE PRECISION, DIMENSION(:,:), INTENT(OUT) ::v + + INTEGER i,j,ip,iq,n + DOUBLE PRECISION c,g,h,s,sm,t,tau,theta,tresh + DOUBLE PRECISION , DIMENSION(size(d)) ::b,z + DOUBLE PRECISION, DIMENSION(size(d),size(d)) :: a + LOGICAL, DIMENSION(size(d),size(d)) :: upper_triangle + + a=a1 + n=size(d) + v(:,:)=0. + upper_triangle(:,:)=.FALSE. + DO I=1,n + v(I,I)=1. + b(I)=a(I,I) + DO J=I+1,n + upper_triangle(I,J)=.TRUE. + ENDDO + ENDDO + d(:)=b(:) + z(:)=0.0 + nrot=0 + DO I=1,50 + sm=SUM(ABS(a),mask=upper_triangle) + IF (sm.EQ.0.0) RETURN + tresh=merge(0.2*sm/n**2,0.0D0,i<4) + DO ip=1,n-1 + do iq=ip+1,n + g=100.0*abs(a(ip,iq)) + IF((i > 4).AND.(ABS(d(ip))+g.EQ.abs(d(ip))) & + .AND.(ABS(d(iq))+g.EQ.abs(d(iq)))) THEN + a(ip,iq)=0.0 + ELSE IF (abs(a(ip,iq)) > tresh) THEN + h=d(iq)-d(ip) + if (abs(h)+g == abs(h)) THEN + t=a(ip,iq)/h + ELSE + theta=0.5*h/a(ip,iq) + t=1.0/(abs(theta)+sqrt(1.0+theta**2)) + IF ( theta < 0.0) t=-t + ENDIF + c=1.0/sqrt(1+t**2) + s=t*c + tau=s/(1.0+c) + h=t*a(ip,iq) + z(ip)=z(ip)-h + z(iq)=z(iq)+h + d(ip)=d(ip)-h + d(iq)=d(iq)+h + a(ip,iq)=0.0 + IF (ip.GE.1) CALL ROTATE(a(1:ip-1,ip),a(1:ip-1,iq)) + !The IF test was added by F.A. (2005/04/04) because of the following error: + !Subscript out of range. Location: line 593 column 36 of 'cb_botsc.f90' + !Subscript number 1 has value 0 in array 'A' + CALL ROTATE(a(ip,ip+1:iq-1),a(ip+1:iq-1,iq)) + CALL ROTATE(a(ip,iq+1:n),a(iq,iq+1:n)) + CALL ROTATE(v(:,ip),v(:,iq)) + nrot=nrot+1 + ENDIF + ENDDO + ENDDO + b(:)=b(:)+z(:) + d(:)=b(:) + z(:)=0.0 + ENDDO + WRITE(6,*) 'Too many iterations in DIAGONALIZE' + CONTAINS + SUBROUTINE ROTATE(X1,X2) + DOUBLE PRECISION, DIMENSION(:), INTENT(INOUT) :: X1,X2 + DOUBLE PRECISION, DIMENSION(size(X1)) :: MEM + MEM(:)=X1(:) + X1(:)=X1(:)-s*(X2(:)+X1(:)*tau) + X2(:)=X2(:)+s*(MEM(:)-X2(:)*tau) + END SUBROUTINE ROTATE + END SUBROUTINE DIAGONALIZE + + !/ ------------------------------------------------------------------- / + SUBROUTINE UV_TO_MAG_DIR(U, V, NSEA, MAG, DIR, TOLERANCE, CONV) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | C. Bunney | + !/ | FORTRAN 90 | + !/ | Last update : 15-Jan-2021 | + !/ +-----------------------------------+ + !/ + !/ 15-Jan-2021 : Creation ( version 7.12 ) + !/ + ! 1. Purpose : + ! + ! Converts seapoint arrays formulated as U/V vectors into magnitude + ! and direction arrays. + ! + ! If MAG and DIR input parameters are not specificed then the + ! conversion is performed in-place (U => MAG, v => DIR). + ! + ! 2. Parameters + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! U/V R.Arr I Array of U/V components + ! NSEA Int I Number of sea points + ! MAG R.Arr O Magnitude array (Optional) + ! DIR R.Arr O Direction array (degrees) (Optional) + ! TOLERANCE Real I Minimum allowed magnitude (Optional) + ! CONV Char I Ouput direciton convention (Optional) + ! ---------------------------------------------------------------- + ! + ! 3. Remarks + ! + ! Optional CONV specifies direction convention. Must be one of: + ! 'N'=Nautical : North=0, clockwise, direction-from (default) + ! 'O'=Oceangraphic : North=0, clockwise, direction-to + ! 'C'=Cartesian : North=90, counter-clockwise, direction-to + ! + !/ ------------------------------------------------------------------- / + USE CONSTANTS, ONLY: RADE, UNDEF + + REAL, INTENT(INOUT) :: U(NSEA), V(NSEA) + INTEGER, INTENT(IN) :: NSEA + REAL, INTENT(OUT), OPTIONAL :: MAG(NSEA), DIR(NSEA) + REAL, INTENT(IN), OPTIONAL :: TOLERANCE + CHARACTER, INTENT(IN), OPTIONAL :: CONV + !/ ------------------------------------------------------------------- / + !/ Local parameters + ! + REAL :: TOL, SGN, OFFSET, TMP + CHARACTER :: DIRCONV + INTEGER :: ISEA + LOGICAL :: INPLACE + + DIRCONV = 'N' + TOL = 1.0 + INPLACE = .TRUE. + IF(PRESENT(TOLERANCE)) TOL = TOLERANCE + IF(PRESENT(CONV)) DIRCONV = CONV + IF(PRESENT(MAG) .AND. PRESENT(DIR)) INPLACE = .FALSE. + + SELECT CASE (CONV) + CASE('N') + OFFSET = 630. + SGN = -1. + CASE('O') + OFFSET = 450. + SGN = -1. + CASE('C') + OFFSET = 360. + SGN = 1. + CASE DEFAULT + WRITE(*,*) "UV_TO_MAG_DIR: UNKNOWN DIR CONVENTION: ", DIRCONV + CALL EXTCDE(1) + END SELECT + + IF(INPLACE) THEN + DO ISEA=1, NSEA + TMP = SQRT(U(ISEA)**2 + V(ISEA)**2) + IF(TMP .GE. TOL) THEN + V(ISEA) = MOD(OFFSET + (SGN * RADE * ATAN2(V(ISEA), U(ISEA))), 360.) + U(ISEA) = TMP + ELSE + U(ISEA) = UNDEF + V(ISEA) = UNDEF + END IF + END DO ELSE - MAG(ISEA) = UNDEF - DIR(ISEA) = UNDEF - END IF - END DO - ENDIF - - END SUBROUTINE UV_TO_MAG_DIR -!/ -!/ End of module W3SERVMD -------------------------------------------- / -!/ + DO ISEA=1, NSEA + MAG(ISEA) = SQRT(U(ISEA)**2 + V(ISEA)**2) + IF(MAG(ISEA) .GE. TOL) THEN + DIR(ISEA) = MOD(OFFSET + (SGN * RADE * ATAN2(V(ISEA), U(ISEA))), 360.) + ELSE + MAG(ISEA) = UNDEF + DIR(ISEA) = UNDEF + END IF + END DO + ENDIF + + END SUBROUTINE UV_TO_MAG_DIR + !/ + !/ End of module W3SERVMD -------------------------------------------- / + !/ END MODULE W3SERVMD diff --git a/model/src/w3sic4md.F90 b/model/src/w3sic4md.F90 index 9f9347de29..ea5c49c859 100644 --- a/model/src/w3sic4md.F90 +++ b/model/src/w3sic4md.F90 @@ -292,9 +292,6 @@ 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 !/ @@ -319,10 +316,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 :: x1,x2,x3,x1sqr,x2sqr,x3sqr !case 8 + REAL :: perfour,amhb,bmhb !case 8 + REAL :: KI1,KI2,KI3,KI4,FC5,FC6,FC7,FREQ REAL :: HS, EMEAN, HICE REAL, ALLOCATABLE :: WN_I(:) ! exponential decay rate for amplitude @@ -354,9 +351,6 @@ 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 @@ -385,10 +379,6 @@ 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 WRITE (NDSE,*) 'DUPLICATE USE OF MUD PARAMETERS' @@ -425,11 +415,11 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) ! 1.a Calculate WN_I SELECT CASE (IC4METHOD) - + CASE (1) ! IC4M1 : Exponential fit to Wadhams et al. 1988 ALPHA = EXP(-ICECOEF1 * TPI / SIG - ICECOEF2) WN_I = 0.5 * ALPHA - + CASE (2) ! IC4M2 : Polynomial fit, Eq. 3 from Meylan et al. 2014 !NB: Eq. 3 only includes T^2 and T^4 terms, ! which correspond to ICECOEF3, ICECOEF5, so in @@ -438,7 +428,7 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) MARG2 = ICECOEF4*(SIG/TPI)**3 + ICECOEF5*(SIG/TPI)**4 ALPHA = MARG1 + MARG2 WN_I = 0.5 * ALPHA - + CASE (3) ! IC4M3 : Quadratic fit to Kohout & Meylan'08 in Horvat & Tziperman'15 HICE=ICECOEF1 ! For this method, ICECOEF1=ice thickness KARG1 = -0.3203 + 2.058*HICE - 0.9375*(TPI/SIG) @@ -446,7 +436,7 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) KARG3 = 0.0006 * (TPI/SIG)**2 ALPHA = EXP(KARG1 + KARG2 + KARG3) WN_I = 0.5 * ALPHA - + CASE (4) !Eq. 1 from Kohout et al. 2014 !Calculate HS DO IK=1, NK @@ -518,7 +508,7 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) END DO CASE (7) ! Doble et al. (GRL 2015) - + HICE=ICECOEF1 ! For this method, ICECOEF1=ice thickness DO IK=1,NK FREQ=SIG(IK)/TPI @@ -526,20 +516,17 @@ 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 + 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 @@ -547,33 +534,27 @@ SUBROUTINE W3SIC4 (A, DEPTH, CG, IX, IY, S, D) 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.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.00010791)*x1sqr*x2 + & 0.00031073*x1**3 + 1.5996e-06*x2**3 + 0.090994*x3**3 - KARG1(ik)=min(karg1(ik),0.0) + 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 + 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 - - END SELECT + WN_I = ICECOEF1 !Default to IC1: Uniform in k + + END SELECT ! ! 1.b Calculate DID diff --git a/model/src/w3srcemd.F90 b/model/src/w3srcemd.F90 index f5b67b21ef..6229660283 100644 --- a/model/src/w3srcemd.F90 +++ b/model/src/w3srcemd.F90 @@ -356,7 +356,7 @@ SUBROUTINE W3SRCE ( srce_call, IT, ISEA, JSEA, IX, IY, IMOD, & ! !/ ------------------------------------------------------------------- / USE CONSTANTS, ONLY: DWAT, srce_imp_post, srce_imp_pre, & - srce_direct, GRAV, TPI, TPIINV, LPDLIB + srce_direct, GRAV, TPI, TPIINV, LPDLIB, RADE USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, TH, DMIN, DTMAX, & DTMIN, FACTI1, FACTI2, FACSD, FACHFA, FACP, & XFC, XFLT, XREL, XFT, FXFM, FXPM, DDEN, & diff --git a/model/src/w3str2md.F90 b/model/src/w3str2md.F90 index b66688b8b1..d372a0ce4a 100644 --- a/model/src/w3str2md.F90 +++ b/model/src/w3str2md.F90 @@ -15,13 +15,13 @@ MODULE W3STR2MD !/ !/ 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 : ! -! This peace of code computes the triad interaction term in the same way -! as done in the SWAN model. +! This peace of code computes the triad interaction term in the same way +! as done in the SWAN model. ! ! 2. Variables and types : ! @@ -45,15 +45,15 @@ MODULE W3STR2MD ! ---------------------------------------------------------------- ! ! 5. Remarks : The approach is truncated version of the work of Elderberky. -! In SWAN the wave spectra is treated as one-dimensional and +! In SWAN the wave spectra is treated as one-dimensional and ! only the transfer to the higher harmoics is taken into account ! for this no justification is given and it has to be further investigated. ! The approximation of Elderberky is for a flat bottom (actually bragg-0 resonance) ! The biggest problem is that it is not conservative, which is the biggest limitation factor. -! Moreover it is questionable if it was taken into account the in spectral wave models the +! Moreover it is questionable if it was taken into account the in spectral wave models the ! freq. bandwidths are exponentially distributed in freq. space, which leads to the problem that -! it is possible that some jacobian transformation is missing the derivation of hte discrete form, -! I am now looking into this and I hope that I can give some closure soon. +! it is possible that some jacobian transformation is missing the derivation of hte discrete form, +! I am now looking into this and I hope that I can give some closure soon. ! ! ! See notes in the file below where to add these elements. @@ -212,7 +212,7 @@ SUBROUTINE W3STR2 (A, CG, WN, DEPTH, IX, S, D) INTEGER I1, I2, ID, IDDUM, IENT, II, IS, ISM, ISM1, ISMAX, & ISP, ISP1, ITH, IK REAL AUX1, AUX2, BIPH, C0, CM, DEP, DEP_2, DEP_3, E0, EM, HS, & - FT, RINT, SIGPICG, SINBPH, STRI, WISM, WISM1, WISP, & + FT, RINT, SIGPICG, SINBPH, STRI, WISM, WISM1, WISP, & WISP1, W0, WM, WN0, WNM, XIS, XISLN REAL, ALLOCATABLE :: E(:), SA(:,:) REAL :: EB(NK), EBAND, EMEAN, SIGM01 @@ -251,7 +251,7 @@ SUBROUTINE W3STR2 (A, CG, WN, DEPTH, IX, S, D) END DO END DO ! -! 2. Integrate over wave numbers +! 2. Integrate over wave numbers ! DO IK=1, NK EB(IK) = EB(IK) * DDEN(IK) / CG(IK) @@ -335,7 +335,7 @@ SUBROUTINE W3STR2 (A, CG, WN, DEPTH, IX, S, D) ! DO IK = 1, NK E(IK) = A(ITH+(IK-1)*NTH) * TPI * SIG(IK) / CG(IK) - EF(IK) = EF(IK) + E(IK) + EF(IK) = EF(IK) + E(IK) END DO ! DO IK = 1, ISMAX @@ -384,7 +384,7 @@ SUBROUTINE W3STR2 (A, CG, WN, DEPTH, IX, S, D) 2.*(WISP * SA(ITH,IK+ISP1) + & WISP1 * SA(ITH,IK+ISP )) ) / & SIGPICG -! --- Functional derivative +! --- Functional derivative SF(IK) = 2.*( SA(ITH,IK) - & 2.*(WISP * SA(ITH,IK+ISP1) + & WISP1 * SA(ITH,IK+ISP )) ) + SF(IK) @@ -407,4 +407,4 @@ SUBROUTINE W3STR2 (A, CG, WN, DEPTH, IX, S, D) END SUBROUTINE W3STR2 !/ ------------------------------------------------------------------- / !/ - END MODULE W3STR1MD + END MODULE W3STR2MD diff --git a/model/src/w3timemd.F90 b/model/src/w3timemd.F90 index 73aee83993..9478a84a9e 100644 --- a/model/src/w3timemd.F90 +++ b/model/src/w3timemd.F90 @@ -72,6 +72,8 @@ MODULE W3TIMEMD USE W3SERVMD, ONLY: STRACE #endif ! + ! module default + implicit none PUBLIC ! INTEGER, PRIVATE :: PRFTB(8) @@ -130,8 +132,6 @@ SUBROUTINE TICK21 ( TIME, DTIME ) ! 10. Source code : ! !/ ------------------------------------------------------------------- / -!/ - IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -244,7 +244,6 @@ INTEGER FUNCTION IYMD21 ( NYMD ,M ) ! !/ ------------------------------------------------------------------- / !/ - IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -383,7 +382,6 @@ REAL FUNCTION DSEC21 ( TIME1, TIME2 ) ! !/ ------------------------------------------------------------------- / !/ - IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -505,7 +503,6 @@ INTEGER FUNCTION MYMD21 ( NYMD ) ! !/ ------------------------------------------------------------------- / !/ - IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -634,7 +631,6 @@ REAL FUNCTION TDIFF ( T1, T2 ) ! !/ ------------------------------------------------------------------- / !/ - IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -714,7 +710,6 @@ SUBROUTINE STME21 ( TIME , DTME21 ) ! !/ ------------------------------------------------------------------- / !/ - IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Parameter list @@ -765,7 +760,6 @@ INTEGER FUNCTION JULDAY(id,mm,iyyy) ! !/ ------------------------------------------------------------------- / !/ - IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / INTEGER(KIND=4), INTENT(in) :: id,mm,iyyy @@ -2017,6 +2011,34 @@ SUBROUTINE T2ISO(TIME,ISODT) !/ End of T2ISO ------------------------------------------------------ / !/ END SUBROUTINE T2ISO +!> Create a timestring for custom user filenames +!! +!! @details Creates a character string of form YYYY-MM-DD-SSSSS +!! +!! @param[in] time(2) YYYYMMDD HHMMSS +!! @param[out] user_timestring YYYY-MM-DD-SSSSS +!! +!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov +!> @date 01-05-2022 + subroutine set_user_timestring(time, user_timestring) + + integer , intent(in) :: time(2) + character(len=16), intent(out) :: user_timestring + + ! local variables + integer :: yy,mm,dd,hh,mn,ss,totsec + + yy = time(1)/10000 + mm = (time(1)-yy*10000)/100 + dd = (time(1)-yy*10000-mm*100) + hh = time(2)/10000 + mn = (time(2)-hh*10000)/100 + ss = (time(2)-hh*10000-mn*100) + totsec = hh*3600+mn*60+ss + + write(user_timestring,'(i4.4,a,i2.2,a,i2.2,a,i5.5)')yy,'-',mm,'-',dd,'-',totsec + + end subroutine set_user_timestring !/ End of module W3TIMEMD -------------------------------------------- / !/ diff --git a/model/src/w3wavemd.F90 b/model/src/w3wavemd.F90 index ddc78ddae6..fa7849e4a7 100644 --- a/model/src/w3wavemd.F90 +++ b/model/src/w3wavemd.F90 @@ -1,422 +1,486 @@ #include "w3macros.h" !/ ------------------------------------------------------------------- / - MODULE W3WAVEMD -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 04-Feb-2000 : Origination. ( version 2.00 ) -!/ For upgrades see subroutines. -!/ 14-Feb-2000 : Exact-NL added. ( version 2.01 ) -!/ 05-Jan-2001 : Bug fix to allow model to run ( version 2.05 ) -!/ without output. -!/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) -!/ 09-Feb-2001 : Third propagation scheme added. ( version 2.08 ) -!/ 23-Feb-2001 : Check for barrier after source -!/ terms added ( W3NMIN ). ( delayed version 2.07 ) -!/ 16-Mar-2001 : Fourth propagation scheme added. ( version 2.09 ) -!/ 30-Mar-2001 : Sub-grid obstacles added. ( version 2.10 ) -!/ 23-May-2001 : Clean up and bug fixes. ( version 2.11 ) -!/ 10-Dec-2001 : Sub-grid obstacles for UQ schemes. ( version 2.14 ) -!/ 11-Jan-2002 : Sub-grid ice. ( version 2.15 ) -!/ 24-Jan-2002 : Zero time step dor data ass. ( version 2.17 ) -!/ 18-Feb-2002 : Point output diagnostics added. ( version 2.18 ) -!/ 30-Apr-2002 : Add field output types 17-18. ( version 2.20 ) -!/ 09-May-2002 : Switch clean up. ( version 2.21 ) -!/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) -!/ 26-Dec-2002 : Moving grid version. ( version 3.02 ) -!/ 01-Aug-2003 : Moving grid GSE correction. ( version 3.03 ) -!/ 20-Aug-2003 : Output server options added. ( version 3.04 ) -!/ 07-Oct-2003 : Output options for NN training. ( version 3.05 ) -!/ 29-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ W3INIT, W3MPII-O and WWVER moved to w3initmd.ftn -!/ 04-Feb-2005 : Add STAMP to par list of W3WAVE. ( version 3.07 ) -!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) -!/ 28-Jun-2005 : Adding map recalc for W3ULEV call. ( version 3.07 ) -!/ 07-Sep-2005 : Updated boundary conditions. ( version 3.08 ) -!/ Fix NRQSG1/2 = 0 array bound issue. -!/ 13-Jun-2006 : Split STORE in G/SSTORE ( version 3.09 ) -!/ 26-Jun-2006 : Add output type 6. ( version 3.09 ) -!/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) -!/ 18-Oct-2006 : Partitioned spectral data output. ( version 3.10 ) -!/ 02-Feb-2007 : Add FLAGST test. ( version 3.10 ) -!/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) -!/ 07-May-2007 : Bug fix SKIP_O treatment. ( version 3.11 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 08-Oct-2007 : Adding AS CX-Y to W3SRCE par. list. ( version 3.13 ) -!/ 22-Feb-2008 : Initialize VGX-Y properly. ( version 3.13 ) -!/ 10-Apr-2008 : Bug fix writing log file (MPI). ( version 3.13 ) -!/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 29-Mar-2010 : Adding coupling, ice in W3SRCE. ( version 3.14_SHOM ) -!/ 16-May-2010 : Adding transparencies in W3SCRE ( version 3.14_SHOM ) -!/ 23-Jun-2011 : Movable bed bottom friction BT4 ( version 4.04 ) -!/ 03-Nov-2011 : Shoreline reflection on unst. grids ( version 4.04 ) -!/ 02-Jul-2011 : Update for PALM coupling ( version 4.07 ) -!/ 06-Mar-2012 : Initializing ITEST as needed. ( version 4.07 ) -!/ 02-Jul-2012 : Update for PALM coupling ( version 4.07 ) -!/ 02-Sep-2012 : Clean up of open BC for UG grids ( version 4.08 ) -!/ 03-Sep-2012 : Fix format 902. ( version 4.10 ) -!/ 07-Dec-2012 : Wrap W3SRCE with TMPn to limit WARN ( version 4.OF ) -!/ 10-Dec-2012 : Modify field output MPI for new ( version 4.OF ) -!/ structure and smaller memory footprint. -!/ 12-Dec-2012 : Adding SMC grid. JG_Li ( version 4.08 ) -!/ 26-Dec-2012 : Move FIELD init. to W3GATH. ( version 4.OF ) -!/ 16-Sep-2013 : Add Arctic part for SMC grid. ( version 4.11 ) -!/ 11-Nov-2013 : SMC and rotated grid incorporated in the main -!/ trunk ( version 4.13 ) -!/ 14-Nov-2013 : Remove orphaned work arrays. ( version 4.13 ) -!/ 27-Nov-2013 : Fixes for OpenMP versions. ( version 4.15 ) -!/ 23-May-2014 : Adding ice fluxes to W3SRCE ( version 5.01 ) -!/ 27-May-2014 : Move to OMPG/X switch. ( version 5.02 ) -!/ 24-Apr-2015 : Adding OASIS coupling calls ( version 5.07 ) -!/ (M. Accensi & F. Ardhuin, IFREMER) -!/ 27-Aug-2015 : Update for ICEH, ICEF ( version 5.08 ) -!/ 14-Sep-2018 : Remove PALM implementation ( version 6.06 ) -!/ 15-Sep-2020 : Bugfix FIELD allocation. Remove ( version 7.11 ) -!/ defunct OMPX switches. -!/ 22-Mar-2021 : Update TAUA, RHOA ( version 7.13 ) -!/ 06-May-2021 : Use ARCTC and SMCTYPE options. JGLi ( version 7.13 ) -!/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) -!/ 11-Nov-2021 : Remove XYB since it is obsolete ( version 7.xx ) -!/ -!/ Copyright 2009-2014 National Weather Service (NWS), -!/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. -!/ No unauthorized use without permission. -!/ -! 1. Purpose : -! -! 2. Variables and types : -! -! 3. Subroutines and functions : -! -! Name Type Scope Description -! ---------------------------------------------------------------- -! W3WAVE Subr. Public Actual wave model. -! W3GATH Subr. Public Data transpose before propagation. -! W3SCAT Subr. Public Data transpose after propagation. -! W3NMIN Subr. Public Calculate minimum number of sea -! points per processor. -! ---------------------------------------------------------------- -! -! 4. Subroutines and functions used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3SETx Subr. W3xDATMD Point to data structure. -! -! W3UCUR Subr. W3UPDTMD Interpolate current fields in time. -! W3UWND Subr. W3UPDTMD Interpolate wind fields in time. -! W3UINI Subr. W3UPDTMD Update initial conditions if init. -! with initial wind conditions. -! W3UBPT Subr. W3UPDTMD Update boundary points. -! W3UICE Subr. W3UPDTMD Update ice coverage. -! W3ULEV Subr. W3UPDTMD Transform the wavenumber grid. -! W3DDXY Subr. W3UPDTMD Calculate dirivatives of the depth. -! W3DCXY Subr. W3UPDTMD Calculate dirivatives of the current. -! -! W3MAPn Subr. W3PROnMD Preparation for ropagation schemes. -! W3XYPn Subr. W3PROnMD Longitude-latitude ("XY") propagation. -! W3KTPn Subr. W3PROnMD Intra-spectral ("k-theta") propagation. -! -! W3SRCE Subr. W3SRCEMD Source term integration and calculation. -! -! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. -! W3OUTG Subr. W3IOGOMD Generate gridded output fields. -! W3IOGO Subr. W3IOGOMD Read/write gridded output. -! W3IOPE Subr. W3IOPOMD Extract point output. -! W3IOPO Subr. W3IOPOMD Read/write point output. -! W3IOTR Subr. W3IOTRMD Process spectral output along tracks. -! W3IORS Subr. W3IORSMD Read/write restart files. -! W3IOBC Subr. W3IOBCMD Read/write boundary conditions. -! W3CPRT Subr. W3IOSFMD Partition spectra. -! W3IOSF Subr. Id. Write partitioned spectral data. -! -! STRACE Subr. W3SERVMD Subroutine tracing. -! WWTIME Subr. Id. System time in readable format. -! EXTCDE Subr. Id. Program abort. -! -! TICK21 Subr. W3TIMEMD Advance the clock. -! DSEC21 Func. Id. Difference between times. -! STME21 Subr. Id. Time in readable format. -! -! MPI_BARRIER, MPI_STARTALL, MPI_WAITALL -! Subr. Basic MPI routines. -! ---------------------------------------------------------------- -! -! 5. Remarks : -! -! 6. Switches : -! -! !/SHRD Switch for shared / distributed memory architecture. -! !/DIST Id. -! !/MPI Id. -! !/OMPG Id. -! -! !/PR1 First order propagation schemes. -! !/PR2 ULTIMATE QUICKEST scheme. -! !/PR3 Averaged ULTIMATE QUICKEST scheme. -! !/SMC UNO2 scheme on SMC grid. -! -! !/S Enable subroutine tracing. -! !/T Test output. -! !/MPIT Test output for MPI specific code. -! -! 7. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_MPI - USE W3ADATMD, ONLY: MPIBUF -#endif -! - PUBLIC -!/ - CONTAINS -!/ ------------------------------------------------------------------- / - SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & +MODULE W3WAVEMD + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 04-Feb-2000 : Origination. ( version 2.00 ) + !/ For upgrades see subroutines. + !/ 14-Feb-2000 : Exact-NL added. ( version 2.01 ) + !/ 05-Jan-2001 : Bug fix to allow model to run ( version 2.05 ) + !/ without output. + !/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) + !/ 09-Feb-2001 : Third propagation scheme added. ( version 2.08 ) + !/ 23-Feb-2001 : Check for barrier after source + !/ terms added ( W3NMIN ). ( delayed version 2.07 ) + !/ 16-Mar-2001 : Fourth propagation scheme added. ( version 2.09 ) + !/ 30-Mar-2001 : Sub-grid obstacles added. ( version 2.10 ) + !/ 23-May-2001 : Clean up and bug fixes. ( version 2.11 ) + !/ 10-Dec-2001 : Sub-grid obstacles for UQ schemes. ( version 2.14 ) + !/ 11-Jan-2002 : Sub-grid ice. ( version 2.15 ) + !/ 24-Jan-2002 : Zero time step dor data ass. ( version 2.17 ) + !/ 18-Feb-2002 : Point output diagnostics added. ( version 2.18 ) + !/ 30-Apr-2002 : Add field output types 17-18. ( version 2.20 ) + !/ 09-May-2002 : Switch clean up. ( version 2.21 ) + !/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) + !/ 26-Dec-2002 : Moving grid version. ( version 3.02 ) + !/ 01-Aug-2003 : Moving grid GSE correction. ( version 3.03 ) + !/ 20-Aug-2003 : Output server options added. ( version 3.04 ) + !/ 07-Oct-2003 : Output options for NN training. ( version 3.05 ) + !/ 29-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ W3INIT, W3MPII-O and WWVER moved to w3initmd.ftn + !/ 04-Feb-2005 : Add STAMP to par list of W3WAVE. ( version 3.07 ) + !/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) + !/ 28-Jun-2005 : Adding map recalc for W3ULEV call. ( version 3.07 ) + !/ 07-Sep-2005 : Updated boundary conditions. ( version 3.08 ) + !/ Fix NRQSG1/2 = 0 array bound issue. + !/ 13-Jun-2006 : Split STORE in G/SSTORE ( version 3.09 ) + !/ 26-Jun-2006 : Add output type 6. ( version 3.09 ) + !/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) + !/ 18-Oct-2006 : Partitioned spectral data output. ( version 3.10 ) + !/ 02-Feb-2007 : Add FLAGST test. ( version 3.10 ) + !/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) + !/ 07-May-2007 : Bug fix SKIP_O treatment. ( version 3.11 ) + !/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 08-Oct-2007 : Adding AS CX-Y to W3SRCE par. list. ( version 3.13 ) + !/ 22-Feb-2008 : Initialize VGX-Y properly. ( version 3.13 ) + !/ 10-Apr-2008 : Bug fix writing log file (MPI). ( version 3.13 ) + !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 29-Mar-2010 : Adding coupling, ice in W3SRCE. ( version 3.14_SHOM ) + !/ 16-May-2010 : Adding transparencies in W3SCRE ( version 3.14_SHOM ) + !/ 23-Jun-2011 : Movable bed bottom friction BT4 ( version 4.04 ) + !/ 03-Nov-2011 : Shoreline reflection on unst. grids ( version 4.04 ) + !/ 02-Jul-2011 : Update for PALM coupling ( version 4.07 ) + !/ 06-Mar-2012 : Initializing ITEST as needed. ( version 4.07 ) + !/ 02-Jul-2012 : Update for PALM coupling ( version 4.07 ) + !/ 02-Sep-2012 : Clean up of open BC for UG grids ( version 4.08 ) + !/ 03-Sep-2012 : Fix format 902. ( version 4.10 ) + !/ 07-Dec-2012 : Wrap W3SRCE with TMPn to limit WARN ( version 4.OF ) + !/ 10-Dec-2012 : Modify field output MPI for new ( version 4.OF ) + !/ structure and smaller memory footprint. + !/ 12-Dec-2012 : Adding SMC grid. JG_Li ( version 4.08 ) + !/ 26-Dec-2012 : Move FIELD init. to W3GATH. ( version 4.OF ) + !/ 16-Sep-2013 : Add Arctic part for SMC grid. ( version 4.11 ) + !/ 11-Nov-2013 : SMC and rotated grid incorporated in the main + !/ trunk ( version 4.13 ) + !/ 14-Nov-2013 : Remove orphaned work arrays. ( version 4.13 ) + !/ 27-Nov-2013 : Fixes for OpenMP versions. ( version 4.15 ) + !/ 23-May-2014 : Adding ice fluxes to W3SRCE ( version 5.01 ) + !/ 27-May-2014 : Move to OMPG/X switch. ( version 5.02 ) + !/ 24-Apr-2015 : Adding OASIS coupling calls ( version 5.07 ) + !/ (M. Accensi & F. Ardhuin, IFREMER) + !/ 27-Aug-2015 : Update for ICEH, ICEF ( version 5.08 ) + !/ 14-Sep-2018 : Remove PALM implementation ( version 6.06 ) + !/ 15-Sep-2020 : Bugfix FIELD allocation. Remove ( version 7.11 ) + !/ defunct OMPX switches. + !/ 22-Mar-2021 : Update TAUA, RHOA ( version 7.13 ) + !/ 06-May-2021 : Use ARCTC and SMCTYPE options. JGLi ( version 7.13 ) + !/ 19-Jul-2021 : Momentum and air density support ( version 7.14 ) + !/ 11-Nov-2021 : Remove XYB since it is obsolete ( version 7.xx ) + !/ + !/ Copyright 2009-2014 National Weather Service (NWS), + !/ National Oceanic and Atmospheric Administration. All rights + !/ reserved. WAVEWATCH III is a trademark of the NWS. + !/ No unauthorized use without permission. + !/ + ! 1. Purpose : + ! + ! 2. Variables and types : + ! + ! 3. Subroutines and functions : + ! + ! Name Type Scope Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. Public Actual wave model. + ! W3GATH Subr. Public Data transpose before propagation. + ! W3SCAT Subr. Public Data transpose after propagation. + ! W3NMIN Subr. Public Calculate minimum number of sea + ! points per processor. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines and functions used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3SETx Subr. W3xDATMD Point to data structure. + ! + ! W3UCUR Subr. W3UPDTMD Interpolate current fields in time. + ! W3UWND Subr. W3UPDTMD Interpolate wind fields in time. + ! W3UINI Subr. W3UPDTMD Update initial conditions if init. + ! with initial wind conditions. + ! W3UBPT Subr. W3UPDTMD Update boundary points. + ! W3UICE Subr. W3UPDTMD Update ice coverage. + ! W3ULEV Subr. W3UPDTMD Transform the wavenumber grid. + ! W3DDXY Subr. W3UPDTMD Calculate dirivatives of the depth. + ! W3DCXY Subr. W3UPDTMD Calculate dirivatives of the current. + ! + ! W3MAPn Subr. W3PROnMD Preparation for ropagation schemes. + ! W3XYPn Subr. W3PROnMD Longitude-latitude ("XY") propagation. + ! W3KTPn Subr. W3PROnMD Intra-spectral ("k-theta") propagation. + ! + ! W3SRCE Subr. W3SRCEMD Source term integration and calculation. + ! + ! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. + ! W3OUTG Subr. W3IOGOMD Generate gridded output fields. + ! W3IOGO Subr. W3IOGOMD Read/write gridded output. + ! W3IOPE Subr. W3IOPOMD Extract point output. + ! W3IOPO Subr. W3IOPOMD Read/write point output. + ! W3IOTR Subr. W3IOTRMD Process spectral output along tracks. + ! W3IORS Subr. W3IORSMD Read/write restart files. + ! W3IOBC Subr. W3IOBCMD Read/write boundary conditions. + ! W3CPRT Subr. W3IOSFMD Partition spectra. + ! W3IOSF Subr. Id. Write partitioned spectral data. + ! + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! WWTIME Subr. Id. System time in readable format. + ! EXTCDE Subr. Id. Program abort. + ! + ! TICK21 Subr. W3TIMEMD Advance the clock. + ! DSEC21 Func. Id. Difference between times. + ! STME21 Subr. Id. Time in readable format. + ! + ! MPI_BARRIER, MPI_STARTALL, MPI_WAITALL + ! Subr. Basic MPI routines. + ! ---------------------------------------------------------------- + ! + ! 5. Remarks : + ! + ! 6. Switches : + ! + ! !/SHRD Switch for shared / distributed memory architecture. + ! !/DIST Id. + ! !/MPI Id. + ! !/OMPG Id. + ! + ! !/PR1 First order propagation schemes. + ! !/PR2 ULTIMATE QUICKEST scheme. + ! !/PR3 Averaged ULTIMATE QUICKEST scheme. + ! !/SMC UNO2 scheme on SMC grid. + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! !/MPIT Test output for MPI specific code. + ! + ! 7. Source code : + ! + !/ ------------------------------------------------------------------- / + use wav_shr_flags +#ifdef W3_MPI + USE W3ADATMD, ONLY: MPIBUF +#endif + USE W3SERVMD , only : STRACE ! W3_S + use W3SERVMD , only : SSORT1 ! W3_T + + ! module default + IMPLICIT NONE + ! + PUBLIC + !/ +CONTAINS + !/ ------------------------------------------------------------------- / #ifdef W3_OASIS - ,ID_LCOMM, TIMEN & -#endif - ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 22-Mar-2021 | -!/ +-----------------------------------+ -!/ -!/ 17-Mar-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Major changes to logistics. -!/ 05-Jan-2001 : Bug fix to allow model to run ( version 2.05 ) -!/ without output. -!/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) -!/ 09-Feb-2001 : Third propagation scheme added. ( version 2.08 ) -!/ 23-Feb-2001 : Check for barrier after source -!/ terms added ( W3NMIN ). ( delayed version 2.07 ) -!/ 16-Mar-2001 : Fourth propagation scheme added. ( version 2.09 ) -!/ 30-Mar-2001 : Sub-grid obstacles added. ( version 2.10 ) -!/ 23-May-2001 : Barrier added for dry run, changed ( version 2.10 ) -!/ declaration of FLIWND. -!/ 10-Dec-2001 : Sub-grid obstacles for UQ schemes. ( version 2.14 ) -!/ 11-Jan-2002 : Sub-grid ice. ( version 2.15 ) -!/ 24-Jan-2002 : Zero time step dor data ass. ( version 2.17 ) -!/ 09-May-2002 : Switch clean up. ( version 2.21 ) -!/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) -!/ 26-Dec-2002 : Moving grid version. ( version 3.02 ) -!/ 01-Aug-2003 : Moving grid GSE correction. ( version 3.03 ) -!/ 07-Oct-2003 : Output options for NN training. ( version 3.05 ) -!/ 29-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 04-Feb-2005 : Add STAMP to par list. ( version 3.07 ) -!/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) -!/ 28-Jun-2005 : Adding map recalc for W3ULEV call. ( version 3.07 ) -!/ 07-Sep-2005 : Updated boundary conditions. ( version 3.08 ) -!/ 26-Jun-2006 : Add output type 6. ( version 3.09 ) -!/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) -!/ 18-Oct-2006 : Partitioned spectral data output. ( version 3.10 ) -!/ 02-Feb-2007 : Add FLAGST test. ( version 3.10 ) -!/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) -!/ Improve MPI_WAITALL call tests/allocations. -!/ 07-May-2007 : Bug fix SKIP_O treatment. ( version 3.11 ) -!/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) -!/ 08-Oct-2007 : Adding AS CX-Y to W3SRCE par. list. ( version 3.13 ) -!/ 22-Feb-2008 : Initialize VGX-Y properly. ( version 3.13 ) -!/ 10-Apr-2008 : Bug fix writing log file (MPI). ( version 3.13 ) -!/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) -!/ (W. E. Rogers & T. J. Campbell, NRL) -!/ 31-Mar-2010 : Add reflections ( version 3.14.4 ) -!/ 29-Oct-2010 : Implement unstructured grids ( version 3.14.4 ) -!/ (A. Roland and F. Ardhuin) -!/ 06-Mar-2011 : Output of max. CFL (F.Ardhuin) ( version 3.14.4 ) -!/ 05-Apr-2011 : Implement iteration for DTMAX <1s ( version 3.14.4 ) -!/ 02-Jul-2012 : Update for PALM coupling ( version 4.07 ) -!/ 02-Sep-2012 : Clean up of open BC for UG grids ( version 4.08 ) -!/ 03-Sep-2012 : Fix format 902. ( version 4.10 ) -!/ 10-Dec-2012 : Modify field output MPI for new ( version 4.OF ) -!/ structure and smaller memory footprint. -!/ 16-Nov-2013 : Allows reflection on curvi. grids ( version 4.13 ) -!/ 27-Nov-2013 : Fixes for OpenMP versions. ( version 4.15 ) -!/ 23-May-2014 : Adding ice fluxes to W3SRCE ( version 5.01 ) -!/ 27-May-2014 : Move to OMPG/X switch. ( version 5.02 ) -!/ 24-Apr-2015 : Adding OASIS coupling calls ( version 5.07 ) -!/ (M. Accensi & F. Ardhuin, IFREMER) -!/ 27-Aug-2015 : Update for ICEH, ICEF ( version 5.10 ) -!/ 31-Mar-2016 : Current option for smc grid. ( version 5.18 ) -!/ 06-Jun-2018 : Add PDLIB/MEMCHECK/SETUP/NETCDF_QAD/TIMING -!/ OASIS/DEBUGINIT/DEBUGSRC/DEBUGRUN/DEBUGCOH -!/ DEBUGIOBP/DEBUGIOBC ( version 6.04 ) -!/ 14-Sep-2018 : Remove PALM implementation ( version 6.06 ) -!/ 25-Sep-2020 : Oasis coupling at T+0 ( version 7.10 ) -!/ 22-Mar-2021 : Update TAUA, RHOA ( version 7.13 ) -!/ 06-May-2021 : Use ARCTC and SMCTYPE options. JGLi ( version 7.13 ) -!/ -! 1. Purpose : -! -! Run WAVEWATCH III for a given time interval. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! IMOD Int. I Model number. -! TEND I.A. I Ending time of integration. -! STAMP Log. I WRITE(*,*)time stamp (optional, defaults to T). -! NO_OUT Log. I Skip output (optional, defaults to F). -! Skip at ending time only! -! ---------------------------------------------------------------- -! -! Local parameters : Flags -! ---------------------------------------------------------------- -! FLOUTG Log. Flag for running W3OUTG. -! FLPART Log. Flag for running W3CPRT. -! FLZERO Log. Flag for zero time interval. -! FLAG0 Log. Flag for processors without tasks. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! See module documentation. -! -! 5. Called by : -! -! Any program shell or integrated model which uses WAVEWATCH III. -! -! 6. Error messages : -! -! 7. Remarks : -! -! - Currents are updated before winds as currents are used in wind -! and USTAR processing. -! - Ice and water levels can be updated only once per call. -! - If ice or water level time are undefined, the update -! takes place asap, otherwise around the "half-way point" -! betweem the old and new times. -! - To increase accuracy, the calculation of the intra-spectral -! propagation is performed in two parts around the spatial propagation. -! -! 8. Structure : -! -! ----------------------------------------------------------- -! 0. Initializations -! a Point to data structures -! b Subroutine tracing -! c Local parameter initialization -! d Test output -! 1. Check the consistency of the input. -! a Ending time versus initial time. -! b Water level time. -! c Current time interval. -! d Wind time interval. -! e Ice time. -! 2. Determine next time from ending and output -! time and get corresponding time step. -! 3. Loop over time steps (see below). -! 4. Perform output to file if requested. -! a Check if time is output time. -! b Processing and MPP preparations. ( W3CPRT, W3OUTG ) -! c Reset next output time. -! -------------- loop over output types ------------------ -! d Perform output. ( W3IOxx ) -! e Update next output time. -! -------------------- end loop -------------------------- -! 5. Update log file. -! 6. If time is not ending time, branch back to 2. -! ----------------------------------------------------------- -! -! Section 3. -! ---------------------------------------------------------- -! 3.1 Interpolate winds and currents. ( W3UCUR, W3DCXY ) -! ( W3UWND ) -! ( W3UINI ) -! 3.2 Update boundary conditions. ( W3IOBC, W3UBPT ) -! 3.3 Update ice coverage (if new ice map). ( W3UICE ) -! 3.4 Transform grid (if new water level). ( W3ULEV ) -! 3.5 Update maps and dirivatives. ( W3MAPn, W3DDXY ) -! ( W3NMIN, W3UTRN ) -! Update grid advection vector. -! 3.6 Perform propagation -! a Preparations. -! b Intra spectral part 1. ( W3KTPn ) -! c Longitude-latitude ( W3GATH, W3XYPn W3SCAT ) -! b Intra spectral part 2. ( W3KTPn ) -! 3.7 Calculate and integrate source terms. ( W3SRCE ) -! 3.8 Update global time step. -! ---------------------------------------------------------- -! -! 9. Switches : -! -! See module documentation. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / - USE CONSTANTS -!/ - USE W3GDATMD - USE W3WDATMD - USE W3ADATMD - USE W3IDATMD - USE W3ODATMD -!/ - USE W3UPDTMD - USE W3SRCEMD + SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT, ID_LCOMM, TIMEN) +#else + SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT) +#endif + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 22-Mar-2021 | + !/ +-----------------------------------+ + !/ + !/ 17-Mar-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) + !/ 04-Feb-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Major changes to logistics. + !/ 05-Jan-2001 : Bug fix to allow model to run ( version 2.05 ) + !/ without output. + !/ 24-Jan-2001 : Flat grid version. ( version 2.06 ) + !/ 09-Feb-2001 : Third propagation scheme added. ( version 2.08 ) + !/ 23-Feb-2001 : Check for barrier after source + !/ terms added ( W3NMIN ). ( delayed version 2.07 ) + !/ 16-Mar-2001 : Fourth propagation scheme added. ( version 2.09 ) + !/ 30-Mar-2001 : Sub-grid obstacles added. ( version 2.10 ) + !/ 23-May-2001 : Barrier added for dry run, changed ( version 2.10 ) + !/ declaration of FLIWND. + !/ 10-Dec-2001 : Sub-grid obstacles for UQ schemes. ( version 2.14 ) + !/ 11-Jan-2002 : Sub-grid ice. ( version 2.15 ) + !/ 24-Jan-2002 : Zero time step dor data ass. ( version 2.17 ) + !/ 09-May-2002 : Switch clean up. ( version 2.21 ) + !/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) + !/ 26-Dec-2002 : Moving grid version. ( version 3.02 ) + !/ 01-Aug-2003 : Moving grid GSE correction. ( version 3.03 ) + !/ 07-Oct-2003 : Output options for NN training. ( version 3.05 ) + !/ 29-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 04-Feb-2005 : Add STAMP to par list. ( version 3.07 ) + !/ 04-May-2005 : Change to MPI_COMM_WAVE. ( version 3.07 ) + !/ 28-Jun-2005 : Adding map recalc for W3ULEV call. ( version 3.07 ) + !/ 07-Sep-2005 : Updated boundary conditions. ( version 3.08 ) + !/ 26-Jun-2006 : Add output type 6. ( version 3.09 ) + !/ 04-Jul-2006 : Consolidate stress arrays. ( version 3.09 ) + !/ 18-Oct-2006 : Partitioned spectral data output. ( version 3.10 ) + !/ 02-Feb-2007 : Add FLAGST test. ( version 3.10 ) + !/ 02-Apr-2007 : Add partitioned field data. ( version 3.11 ) + !/ Improve MPI_WAITALL call tests/allocations. + !/ 07-May-2007 : Bug fix SKIP_O treatment. ( version 3.11 ) + !/ 17-May-2007 : Adding NTPROC/NAPROC separation. ( version 3.11 ) + !/ 08-Oct-2007 : Adding AS CX-Y to W3SRCE par. list. ( version 3.13 ) + !/ 22-Feb-2008 : Initialize VGX-Y properly. ( version 3.13 ) + !/ 10-Apr-2008 : Bug fix writing log file (MPI). ( version 3.13 ) + !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 30-Oct-2009 : Implement curvilinear grid type. ( version 3.14 ) + !/ (W. E. Rogers & T. J. Campbell, NRL) + !/ 31-Mar-2010 : Add reflections ( version 3.14.4 ) + !/ 29-Oct-2010 : Implement unstructured grids ( version 3.14.4 ) + !/ (A. Roland and F. Ardhuin) + !/ 06-Mar-2011 : Output of max. CFL (F.Ardhuin) ( version 3.14.4 ) + !/ 05-Apr-2011 : Implement iteration for DTMAX <1s ( version 3.14.4 ) + !/ 02-Jul-2012 : Update for PALM coupling ( version 4.07 ) + !/ 02-Sep-2012 : Clean up of open BC for UG grids ( version 4.08 ) + !/ 03-Sep-2012 : Fix format 902. ( version 4.10 ) + !/ 10-Dec-2012 : Modify field output MPI for new ( version 4.OF ) + !/ structure and smaller memory footprint. + !/ 16-Nov-2013 : Allows reflection on curvi. grids ( version 4.13 ) + !/ 27-Nov-2013 : Fixes for OpenMP versions. ( version 4.15 ) + !/ 23-May-2014 : Adding ice fluxes to W3SRCE ( version 5.01 ) + !/ 27-May-2014 : Move to OMPG/X switch. ( version 5.02 ) + !/ 24-Apr-2015 : Adding OASIS coupling calls ( version 5.07 ) + !/ (M. Accensi & F. Ardhuin, IFREMER) + !/ 27-Aug-2015 : Update for ICEH, ICEF ( version 5.10 ) + !/ 31-Mar-2016 : Current option for smc grid. ( version 5.18 ) + !/ 06-Jun-2018 : Add PDLIB/MEMCHECK/SETUP/NETCDF_QAD/TIMING + !/ OASIS/DEBUGINIT/DEBUGSRC/DEBUGRUN/DEBUGCOH + !/ DEBUGIOBP/DEBUGIOBC ( version 6.04 ) + !/ 14-Sep-2018 : Remove PALM implementation ( version 6.06 ) + !/ 25-Sep-2020 : Oasis coupling at T+0 ( version 7.10 ) + !/ 22-Mar-2021 : Update TAUA, RHOA ( version 7.13 ) + !/ 06-May-2021 : Use ARCTC and SMCTYPE options. JGLi ( version 7.13 ) + !/ + ! 1. Purpose : + ! + ! Run WAVEWATCH III for a given time interval. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! IMOD Int. I Model number. + ! TEND I.A. I Ending time of integration. + ! STAMP Log. I WRITE(*,*)time stamp (optional, defaults to T). + ! NO_OUT Log. I Skip output (optional, defaults to F). + ! Skip at ending time only! + ! ---------------------------------------------------------------- + ! + ! Local parameters : Flags + ! ---------------------------------------------------------------- + ! FLOUTG Log. Flag for running W3OUTG. + ! FLPART Log. Flag for running W3CPRT. + ! FLZERO Log. Flag for zero time interval. + ! FLAG0 Log. Flag for processors without tasks. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! See module documentation. + ! + ! 5. Called by : + ! + ! Any program shell or integrated model which uses WAVEWATCH III. + ! + ! 6. Error messages : + ! + ! 7. Remarks : + ! + ! - Currents are updated before winds as currents are used in wind + ! and USTAR processing. + ! - Ice and water levels can be updated only once per call. + ! - If ice or water level time are undefined, the update + ! takes place asap, otherwise around the "half-way point" + ! betweem the old and new times. + ! - To increase accuracy, the calculation of the intra-spectral + ! propagation is performed in two parts around the spatial propagation. + ! + ! 8. Structure : + ! + ! ----------------------------------------------------------- + ! 0. Initializations + ! a Point to data structures + ! b Subroutine tracing + ! c Local parameter initialization + ! d Test output + ! 1. Check the consistency of the input. + ! a Ending time versus initial time. + ! b Water level time. + ! c Current time interval. + ! d Wind time interval. + ! e Ice time. + ! 2. Determine next time from ending and output + ! time and get corresponding time step. + ! 3. Loop over time steps (see below). + ! 4. Perform output to file if requested. + ! a Check if time is output time. + ! b Processing and MPP preparations. ( W3CPRT, W3OUTG ) + ! c Reset next output time. + ! -------------- loop over output types ------------------ + ! d Perform output. ( W3IOxx ) + ! e Update next output time. + ! -------------------- end loop -------------------------- + ! 5. Update log file. + ! 6. If time is not ending time, branch back to 2. + ! ----------------------------------------------------------- + ! + ! Section 3. + ! ---------------------------------------------------------- + ! 3.1 Interpolate winds and currents. ( W3UCUR, W3DCXY ) + ! ( W3UWND ) + ! ( W3UINI ) + ! 3.2 Update boundary conditions. ( W3IOBC, W3UBPT ) + ! 3.3 Update ice coverage (if new ice map). ( W3UICE ) + ! 3.4 Transform grid (if new water level). ( W3ULEV ) + ! 3.5 Update maps and dirivatives. ( W3MAPn, W3DDXY ) + ! ( W3NMIN, W3UTRN ) + ! Update grid advection vector. + ! 3.6 Perform propagation + ! a Preparations. + ! b Intra spectral part 1. ( W3KTPn ) + ! c Longitude-latitude ( W3GATH, W3XYPn W3SCAT ) + ! b Intra spectral part 2. ( W3KTPn ) + ! 3.7 Calculate and integrate source terms. ( W3SRCE ) + ! 3.8 Update global time step. + ! ---------------------------------------------------------- + ! + ! 9. Switches : + ! + ! See module documentation. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + + USE CONSTANTS , only : UNDEF, RADIUS, DERA, DAIR, SRCE_DIRECT, LPDLIB + USE CONSTANTS , only : SRCE_DIRECT, LPDLIB, SRCE_IMP_POST, SRCE_IMP_PRE + USE CONSTANTS , only : TPIINV + USE CONSTANTS , only : DEBUG_NODE + + USE W3GDATMD , only : IGRID, NSEAL, NSPEC, NX, NY, NK, NSEA + USE W3GDATMD , only : GTYPE, UNGTYPE, SMCTYPE, RSTYPE, FILEXT + USE W3GDATMD , only : MAPSF, MAPFS, MAPSTA, IOBP, CTHG0S + USE W3GDATMD , only : FLCTH, FSREFRACTION, FLCK, FSFREQSHIFT, FLAGLL, FLDRY + USE W3GDATMD , only : FSTOTALIMP, FLCX, FLCY, FLSOU, FLAGST + USE W3GDATMD , only : SIG, CLATS, TRNX, TRNY + USE W3GDATMD , only : DTMAX, DTCFLI, DTH, DMIN + USE W3GDATMD , only : XGRD, YGRD, ZB + USE W3GDATMD , only : NITERSEC1 + + USE W3WDATMD , only : UST, IWDATA, TIME, TLEV, TICE, TIC1, VA, ASF, RHOAIR + USE W3WDATMD , only : USTDIR, ICE, ICEH, ICEF, ICEDMAX, BERG, FPIS + + USE W3ADATMD , only : FLIWND, FLCOLD, IAPPRO, IDLAST + USE W3ADATMD , only : IADATA, IPASS, ITIME, CFLXYMAX, CFLTHMAX, CFLKMAX, DTDYN + USE W3ADATMD , only : CG, DW, CX, CY, DCDX, DCDY, DCXDX, DCXDY, DCYDX, DCYDY + USE W3ADATMD , only : AS, TAUOX, TAUOY, TAUWIX, TAUWIY, TAUWNX, TAUWNY, DDDX, DDDY + USE W3ADATMD , only : ALPHA, WN, U10, U10D, TAUA, TAUADIR, FCUT, WHITECAP, BEDFORMS + USE W3ADATMD , only : TAUBBL, TAUICE, PHIBBL, TAUOCX, TAUOCY, WNMEAN, PHIAW, PHIOC + USE W3ADATMD , only : TWS, PHICE, CHARN + + USE W3IDATMD , only : IIDATA + USE W3IDATMD , only : INFLAGS1, FLLEV, FLCUR, FLWIND, FLICE, FLTAUA, FLRHOA + USE W3IDATMD , only : FLIC1, FLIC2, FLIC3, FLIC4, FLIC5 + USE W3IDATMD , only : TLN, TC0, TCN, TW0, TWN, TIN, TU0, TUN, TI1, TGN, TG0, GA0, GAN + USE W3IDATMD , only : GD0, GDN, TDN, TRN + + USE W3ODATMD , only : FLOUT, FLOGRD, FLOGR2, FLBPI, NOGE + USE W3ODATMD , only : NDS, NOGE, NAPLOG, NAPOUT, NDSO, NDSE, NDST, NAPROC, NAPERR, SCREEN + USE W3ODATMD , only : IAPROC, IOUTP, NOTYPE, NAPBPT, NTPROC + USE W3ODATMD , only : TOFRST, TONEXT, TBPIN, TBPI0, TOLAST, DTOUT, NAPFLD, NAPPNT + + USE W3GDATMD , only : W3SETG + USE W3ADATMD , only : W3SETA + USE W3WDATMD , only : W3SETW + USE W3ODATMD , only : W3SETO + USE W3IDATMD , only : W3SETI + USE W3UPDTMD , only : W3DZXY, W3UWND, W3UINI, W3UTAU, W3URHO, W3UBPT, W3UICE + USE W3UPDTMD , only : W3ULEV, W3UCUR, W3UIC1, W3UTRN + USE W3SRCEMD , only : W3SRCE + USE W3TRIAMD , only : UG_GRADIENTS + USE W3IOGOMD , only : W3IOGO, W3OUTG + USE W3IOPOMD , only : W3IOPO, W3IOPE + USE W3IOTRMD , only : W3IOTR + USE W3IORSMD , only : W3IORS + USE W3IOBCMD , only : W3IOBC + USE W3IOSFMD , only : W3IOSF, W3CPRT + USE W3SERVMD , only : EXTCDE, WWTIME + USE W3TIMEMD , only : DSEC21, TICK21, STME21 + USE W3GDATMD , only : FSSOURCE, FSTOTALEXP, FSTOTALIMP + USE W3GDATMD , only : FSN, FSPSI, FSFCT, FSNIMP, FLCTH #ifdef W3_PR1 - USE W3PRO1MD + USE W3PRO1MD , only : W3MAP1, W3XYP1, W3KTP1 + USE W3PROFSMD , only : W3XYPUG #endif #ifdef W3_PR2 - USE W3PRO2MD + USE W3PRO2MD , only : W3XYP2, W3MAP2, W3KTP2 + USE W3PROFSMD , only : W3XYPUG #endif #ifdef W3_PR3 - USE W3PRO3MD + USE W3PRO3MD , only : W3MAPT, W3XYP3, W3CFLXY, W3MAP3, W3KTP3 + USE W3PROFSMD , only : W3XYPUG, W3CFLUG #endif #ifdef W3_SMC - USE W3PSMCMD + USE W3SERVMD , only : W3ACTURN + USE W3PSMCMD , only : SMCDHXY, SMCDCXY, W3SCATSMC, W3GATHSMC, W3PSMC, W3KRTN #endif -! -#ifdef W3_PR1 - USE W3PROFSMD +#ifdef W3_IS2 + USE W3UPDTMD , only : W3UIC5 #endif -#ifdef W3_PR2 - USE W3PROFSMD + !/ +#ifdef W3_MPI + USE W3ODATMD , only : NRQGO, NRQGO2, IRQGO, IRQGO2, NRQPO, NRQPO2, IRQPO1, IRQPO2 + USE W3ODATMD , only : NRQRS, IRQRS, IRQPO1, NRQBP, IRQBP1, IRQBP2, NRQBP2 + USE W3ADATMD , only : NRQSG1, IRQSG1, NRQSG1, MPI_COMM_WAVE #endif -#ifdef W3_PR3 - USE W3PROFSMD -#endif -!/ - USE W3TRIAMD - USE W3IOGRMD - USE W3IOGOMD - USE W3IOPOMD - USE W3IOTRMD - USE W3IORSMD - USE W3IOBCMD - USE W3IOSFMD +#ifdef W3_REF1 + USE W3GDATMD , only : RLGTYPE, SX, SY, CLGTYPE, HPFAC, HQFAC, REFLC, REFLD +#endif +#ifdef W3_BT4 + USE W3GDATMD , only : SED_D50, SED_PSIC +#endif +#ifdef W3_SMC + USE W3GDATMD , only : ANGARC, ARCTC, NBAC, NBGL, NGLO, NCel, ICLBAC, SPCBAC + USE W3ADATMD , only : DHDX, DHDY, DHLMT + USE W3GDATMD , only : NTH +#endif + ! + !/ #ifdef W3_PDLIB - USE PDLIB_W3PROFSMD, only : APPLY_BOUNDARY_CONDITION_VA - USE PDLIB_W3PROFSMD, only : PDLIB_W3XYPUG, PDLIB_W3XYPUG_BLOCK_IMPLICIT, PDLIB_W3XYPUG_BLOCK_EXPLICIT - USE PDLIB_W3PROFSMD, only : ALL_VA_INTEGRAL_PRINT, ALL_VAOLD_INTEGRAL_PRINT, ALL_FIELD_INTEGRAL_PRINT - USE W3PARALL, only : PDLIB_NSEAL, PDLIB_NSEALM - USE yowNodepool, only: npa, iplg, np -#endif -!/ - USE W3SERVMD - USE W3TIMEMD + USE PDLIB_W3PROFSMD , only : APPLY_BOUNDARY_CONDITION_VA + USE PDLIB_W3PROFSMD , only : PDLIB_W3XYPUG, PDLIB_W3XYPUG_BLOCK_IMPLICIT, PDLIB_W3XYPUG_BLOCK_EXPLICIT + USE PDLIB_W3PROFSMD , only : ALL_VA_INTEGRAL_PRINT, ALL_VAOLD_INTEGRAL_PRINT, ALL_FIELD_INTEGRAL_PRINT + USE W3PARALL , only : PDLIB_NSEAL, PDLIB_NSEALM + USE W3WDATMD , only : VAOLD, VSTOT, VDTOT, SHAVETOT + USE W3GDATMD , only : IOBP_LOC, IOBPD_LOC, IOBPA_LOC, IOBDP_LOC + USE yowNodepool , only : npa, iplg, np +#endif + !/ #ifdef W3_IC3 - USE W3SIC3MD + USE W3GDATMD , only : IC3PARS + USE W3SIC3MD , only : CALLEDIC3TABLE, IC3TABLE_CHENG, W3IC3WNCG_V1, W3IC3WNCG_CHENG + USE W3IDATMD , only : ICEP1, ICEP2, ICEP3, ICEP4 #endif #ifdef W3_IS2 - USE W3SIS2MD + USE W3WDATMD , only : TIC5 + USE W3IDATMD , only : TI5 + USE W3UPDTMD , only : W3UIC5 #endif #ifdef W3_UOST USE W3UOSTMD, ONLY: UOST_SETGRID @@ -428,8 +492,8 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & #ifdef W3_SETUP USE W3WAVSET, only : WAVE_SETUP_COMPUTATION #endif - #ifdef W3_OASIS + USE W3WDATMD, ONLY: TIME00, TIMEEND USE W3OACPMD, ONLY: ID_OASIS_TIME, CPLT0 #endif #ifdef W3_OASOCM @@ -441,262 +505,221 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & #ifdef W3_OASICM USE W3IGCMMD, ONLY: SND_FIELDS_TO_ICE #endif - #ifdef W3_PDLIB USE PDLIB_FIELD_VEC, only : DO_OUTPUT_EXCHANGES USE PDLIB_W3PROFSMD, ONLY: ASPAR_JAC, ASPAR_DIAG_ALL, B_JAC USE W3PARALL, only : LSLOC #endif -#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 -! + USE W3PARALL , only : PRINT_MY_TIME ! W3_TIMINGS + use w3iogoncdmd , only : w3iogoncd + use w3odatmd , only : histwr, rstwr, user_netcdf_grdout + ! + ! #ifdef W3_MPI INCLUDE "mpif.h" #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ INTEGER, INTENT(IN) :: IMOD, TEND(2),ODAT(35) LOGICAL, INTENT(IN), OPTIONAL :: STAMP, NO_OUT #ifdef W3_OASIS - INTEGER, INTENT(IN), OPTIONAL :: ID_LCOMM - INTEGER, INTENT(IN), OPTIONAL :: TIMEN(2) -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters : -!/ -#ifdef W3_T - INTEGER :: ILEN -#endif -#ifdef W3_S - INTEGER, SAVE :: IENT = 0 -#endif - INTEGER :: IP - INTEGER :: TCALC(2), IT, IT0, NT, ITEST, & - ITLOC, ITLOCH, NTLOC, ISEA, JSEA, & - IX, IY, ISPEC, J, TOUT(2), TLST(2), & - REFLED(6), IK, ITH, IS, NKCFL - INTEGER :: ISP, IP_glob - INTEGER :: TTEST(2),DTTEST - REAL :: ICEDAVE -! -#ifdef W3_MPI - LOGICAL :: SBSED -#endif -#ifdef W3_SEC1 - INTEGER :: ISEC1 -#endif -#ifdef W3_SBS - INTEGER :: JJ, NDSOFLG -#endif -#ifdef W3_MPI - INTEGER :: IERR_MPI, NRQMAX - INTEGER, ALLOCATABLE :: STATCO(:,:), STATIO(:,:) -#endif - INTEGER :: IXrel - REAL :: DTTST, DTTST1, DTTST2, DTTST3, & - DTL0, DTI0, DTR0, DTI10, DTI50, & - DTGA, DTG, DTGpre, DTRES, & - FAC, VGX, VGY, FACK, FACTH, & - FACX, XXX, REFLEC(4), & - DELX, DELY, DELA, DEPTH, D50, PSIC - REAL :: VSioDummy(NSPEC), VDioDummy(NSPEC), VAoldDummy(NSPEC) - LOGICAL :: SHAVETOTioDummy -#ifdef W3_SEC1 - REAL :: DTGTEMP -#endif -! - REAL, ALLOCATABLE :: FIELD(:) - REAL :: TMP1(4), TMP2(3), TMP3(2), TMP4(2) -#ifdef W3_IC3 - REAL, ALLOCATABLE :: WN_I(:) -#endif -#ifdef W3_REFRX - REAL, ALLOCATABLE :: CIK(:) -#endif -! -! Orphaned arrays from old data structure -! - REAL, ALLOCATABLE :: TAUWX(:), TAUWY(:) -! - LOGICAL :: FLACT, FLZERO, FLFRST, FLMAP, TSTAMP,& - SKIP_O, FLAG_O, FLDDIR, READBC, & - FLAG0 = .FALSE., FLOUTG, FLPFLD, & - FLPART, LOCAL, FLOUTG2 -! -#ifdef W3_MPI - LOGICAL :: FLGMPI(0:8) -#endif -#ifdef W3_IC3 - REAL :: FIXEDVISC,FIXEDDENS,FIXEDELAS - REAL :: USE_CHENG, USE_CGICE, HICE -#endif - LOGICAL :: UGDTUPDATE ! true if time step should be updated for UG schemes - CHARACTER(LEN=8) :: STTIME - CHARACTER(LEN=21) :: IDACT - CHARACTER(LEN=16) :: OUTID - CHARACTER(LEN=23) :: IDTIME - INTEGER eIOBP - INTEGER ITH_F -#ifdef W3_PDLIB - REAL :: VS_SPEC(NSPEC) - REAL :: VD_SPEC(NSPEC) -#endif - -! -#ifdef W3_SBS - CHARACTER(LEN=30) :: FOUTNAME -#endif -! -#ifdef W3_T - REAL :: INDSORT(NSEA), DTCFL1(NSEA) -#endif -!/ -#ifdef W3_SMC - !Li Temperature spectra for Arctic boundary update. - REAL, ALLOCATABLE :: BACSPEC(:) - REAL :: BACANGL - -#endif - -!/ ------------------------------------------------------------------- / -! 0. Initializations -! -! 0.a Set pointers to data structure -! + INTEGER, INTENT(IN), OPTIONAL :: ID_LCOMM + INTEGER, INTENT(IN), OPTIONAL :: TIMEN(2) +#endif + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters : + !/ + INTEGER, SAVE :: IENT = 0 ! only for W3_S + INTEGER :: IP + INTEGER :: TCALC(2), IT, IT0, NT, ITEST + INTEGER :: ITLOC, ITLOCH, NTLOC, ISEA, JSEA + INTEGER :: IX, IY, ISPEC, J, TOUT(2), TLST(2) + INTEGER :: REFLED(6), IK, ITH, IS, NKCFL + INTEGER :: ISP, IP_glob + INTEGER :: TTEST(2),DTTEST + REAL :: ICEDAVE + ! + LOGICAL :: SBSED ! only for W3_MPI + INTEGER :: ISEC1 ! only for W3_SEC1 + INTEGER :: JJ, NDSOFLG ! only for W3_SBS + INTEGER :: IERR_MPI, NRQMAX ! only for W3_MPI + INTEGER :: NAPRST ! only for W3_MPI + INTEGER, ALLOCATABLE :: STATCO(:,:), STATIO(:,:) + INTEGER :: IXrel + REAL :: DTTST, DTTST1, DTTST2, DTTST3 + REAL :: DTL0, DTI0, DTR0, DTI10, DTI50 + REAL :: DTGA, DTG, DTGpre, DTRES + REAL :: FAC, VGX, VGY, FACK, FACTH + REAL :: FACX, XXX, REFLEC(4) + REAL :: DELX, DELY, DELA, DEPTH, D50, PSIC + REAL :: VSioDummy(NSPEC), VDioDummy(NSPEC), VAoldDummy(NSPEC) + LOGICAL :: SHAVETOTioDummy + REAL :: DTGTEMP ! only for W3_SEC1 + ! + REAL, ALLOCATABLE :: FIELD(:) + REAL :: TMP1(4), TMP2(3), TMP3(2), TMP4(2) + REAL, ALLOCATABLE :: WN_I(:) ! only for W3_IC3 + REAL, ALLOCATABLE :: CIK(:) ! only for W3_REFRX + ! + ! Orphaned arrays from old data structure + ! + REAL, ALLOCATABLE :: TAUWX(:), TAUWY(:) + ! + LOGICAL :: FLACT, FLZERO, FLFRST, FLMAP, TSTAMP + LOGICAL :: SKIP_O, FLAG_O, FLDDIR, READBC + LOGICAL :: FLAG0 = .FALSE., FLOUTG, FLPFLD + LOGICAL :: FLPART, LOCAL, FLOUTG2 + ! + LOGICAL :: FLGMPI(0:8) ! only for W3_MPI + REAL :: FIXEDVISC,FIXEDDENS,FIXEDELAS ! only for W3_IC3 + REAL :: USE_CHENG, USE_CGICE, HICE + LOGICAL :: UGDTUPDATE ! true if time step should be updated for UG schemes + CHARACTER(LEN=8) :: STTIME + CHARACTER(LEN=21) :: IDACT + CHARACTER(LEN=16) :: OUTID + CHARACTER(LEN=23) :: IDTIME + INTEGER :: eIOBP + INTEGER :: ITH_F + REAL :: VS_SPEC(NSPEC) ! only for W3_PDLIB + REAL :: VD_SPEC(NSPEC) + CHARACTER(LEN=30) :: FOUTNAME ! only for W3_SBS + REAL :: INDSORT(NSEA), DTCFL1(NSEA) ! only for W3_T + !Li Temperature spectra for Arctic boundary update. + REAL, ALLOCATABLE :: BACSPEC(:) ! only for W3_SMC + REAL :: BACANGL ! only for W3_SMC + integer :: loop_count + ! + integer :: memunit + logical :: do_gridded_output + logical :: do_point_output + logical :: do_track_output + logical :: do_restart_output + logical :: do_sf_output + logical :: do_coupler_output + logical :: do_wavefield_separation_output + !/ ------------------------------------------------------------------- / + ! 0. Initializations + ! + XXX = undef + memunit = 40000+iaproc #ifdef W3_COU SCREEN = 333 #endif -! -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3WAVE, step 1' -#endif -#ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'Step 1 : max(UST)=', maxval(UST) -#endif -#ifdef W3_DEBUGINIT - FLUSH(740+IAPROC) -#endif + ! + ! 0.a Set pointers to data structure + ! + ! + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 1' + endif + if (w3_debugsrc_flag) then + write(740+IAPROC,*) 'Step 1 : max(UST)=', maxval(UST) + end if IF ( IOUTP .NE. IMOD ) CALL W3SETO ( IMOD, NDSE, NDST ) IF ( IGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST ) IF ( IWDATA .NE. IMOD ) CALL W3SETW ( IMOD, NDSE, NDST ) IF ( IADATA .NE. IMOD ) CALL W3SETA ( IMOD, NDSE, NDST ) IF ( IIDATA .NE. IMOD ) CALL W3SETI ( IMOD, NDSE, NDST ) #ifdef W3_UOST - CALL UOST_SETGRID(IMOD) -#endif - -#ifdef W3_DEBUGRUN - DO JSEA = 1, NSEAL - DO IS = 1, NSPEC - IF (VA(IS, JSEA) .LT. 0.) THEN - WRITE(740+IAPROC,*) 'NEGATIVE ACTION 1', IS, JSEA, VA(IS,JSEA) - CALL FLUSH(740+IAPROC) + CALL UOST_SETGRID(IMOD) +#endif + if (w3_debugrun_flag) then + DO JSEA = 1, NSEAL + DO IS = 1, NSPEC + IF (VA(IS, JSEA) .LT. 0.) THEN + write(740+IAPROC,*) 'NEGATIVE ACTION 1', IS, JSEA, VA(IS,JSEA) + CALL EXTCDE(666) + ENDIF + ENDDO + ENDDO + IF (SUM(VA) .NE. SUM(VA)) THEN + WRITE(740+IAPROC,*) 'NAN in ACTION 1', SUM(VA) CALL EXTCDE(666) - ENDIF - ENDDO - ENDDO - IF (SUM(VA) .NE. SUM(VA)) THEN - WRITE(740+IAPROC,*) 'NAN in ACTION 1', SUM(VA) - CALL FLUSH(740+IAPROC) - CALL EXTCDE(666) - ENDIF -#endif - - + ENDIF + end if #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 1") -#endif -#ifdef W3_DEBUGIOBP + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 1") + end if + if (w3_debugiobp_flag) then IF (NX .ge. 10210) WRITE(*,*) 'CRIT 1:', MAPSTA(1,10210), IOBP(10210) + end if #endif -#endif - -! + ! ALLOCATE(TAUWX(NSEAL), TAUWY(NSEAL)) #ifdef W3_REFRX ALLOCATE(CIK(NSEAL)) #endif -! + ! IF ( PRESENT(STAMP) ) THEN - TSTAMP = STAMP - ELSE - TSTAMP = .TRUE. - END IF -! + TSTAMP = STAMP + ELSE + TSTAMP = .TRUE. + END IF + ! IF ( PRESENT(NO_OUT) ) THEN - SKIP_O = NO_OUT - ELSE - SKIP_O = .FALSE. - END IF -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3WAVE, step 2' - FLUSH(740+IAPROC) -#endif + SKIP_O = NO_OUT + ELSE + SKIP_O = .FALSE. + END IF + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 2' + end if #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 2") -#endif -#endif -! -! 0.b Subroutine tracing -! -#ifdef W3_S - CALL STRACE (IENT, 'W3WAVE') -#endif -! -! -! 0.c Local parameter initialization -! + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 2") + end if +#endif + ! + ! 0.b Subroutine tracing + ! + if (w3_s_flag) then + CALL STRACE (IENT, 'W3WAVE') + end if + ! + ! + ! 0.c Local parameter initialization + ! IPASS = IPASS + 1 IDACT = ' ' OUTID = ' ' FLACT = ITIME .EQ. 0 FLMAP = ITIME .EQ. 0 - FLDDIR = ITIME .EQ. 0 .AND. ( FLCTH .OR. FSREFRACTION & - .OR. FLCK .OR. FSFREQSHIFT ) -! + FLDDIR = ITIME .EQ. 0 .AND. ( FLCTH .OR. FSREFRACTION .OR. FLCK .OR. FSFREQSHIFT ) + ! FLPFLD = .FALSE. DO J=1,NOGE(4) - FLPFLD = FLPFLD .OR. FLOGRD(4,J) .OR. FLOGR2(4,J) - END DO -! + FLPFLD = FLPFLD .OR. FLOGRD(4,J) .OR. FLOGR2(4,J) + END DO + ! IF ( IAPROC .EQ. NAPLOG ) BACKSPACE ( NDSO ) -! + ! IF ( FLCOLD ) THEN - DTDYN = 0. - FCUT = SIG(NK) * TPIINV - END IF -! + DTDYN = 0. + FCUT = SIG(NK) * TPIINV + END IF + ! IF( GTYPE .EQ. SMCTYPE ) THEN - J = 1 + J = 1 #ifdef W3_SMC - !!Li Use sea point only field for SMC grid. - ALLOCATE ( FIELD(NCel) ) + !!Li Use sea point only field for SMC grid. + ALLOCATE ( FIELD(NCel) ) #endif ELSE - ALLOCATE ( FIELD(1-NY:NY*(NX+2)) ) + ALLOCATE ( FIELD(1-NY:NY*(NX+2)) ) ENDIF -! + ! LOCAL = IAPROC .LE. NAPROC UGDTUPDATE = .FALSE. IF (FLAGLL) THEN - FACX = 1./(DERA * RADIUS) + FACX = 1./(DERA * RADIUS) ELSE - FACX = 1. - END IF -! + FACX = 1. + END IF + ! #ifdef W3_SBS NDSOFLG = 99 #endif @@ -706,3729 +729,3238 @@ SUBROUTINE W3WAVE ( IMOD, ODAT, TEND, STAMP, NO_OUT & #ifdef W3_SBS SBSED = .TRUE. #endif -! + ! TAUWX = 0. TAUWY = 0. -! -! 0.d Test output -! -#ifdef W3_T - ILEN = LEN_TRIM(FILEXT) - WRITE (NDST,9000) IMOD, FILEXT(:ILEN), TEND -#endif -! -! 1. Check the consistency of the input ----------------------------- / -! 1.a Ending time versus initial time -! + ! + ! 0.d Test output + ! + if (w3_t_flag) then + WRITE (NDST,9000) IMOD, trim(FILEXT), TEND + end if + ! + ! 1. Check the consistency of the input ----------------------------- / + ! 1.a Ending time versus initial time + ! DTTST = DSEC21 ( TIME , TEND ) -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) '1 : DTTST=', DTTST, TIME, TEND -#endif + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) '1 : DTTST=', DTTST, TIME, TEND + end if FLZERO = DTTST .EQ. 0. -#ifdef W3_T - WRITE (NDST,9010) DTTST, FLZERO -#endif + if (w3_t_flag) then + WRITE (NDST,9010) DTTST, FLZERO + end if IF ( DTTST .LT. 0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) - CALL EXTCDE ( 1 ) - END IF -! -! 1.b Water level time -! + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000) + CALL EXTCDE ( 1 ) + END IF + ! + ! 1.b Water level time + ! IF ( FLLEV ) THEN - IF ( TLEV(1) .GE. 0. ) THEN - DTL0 = DSEC21 ( TLEV , TLN ) - ELSE - DTL0 = 1. - END IF -#ifdef W3_T - WRITE (NDST,9011) DTL0 -#endif - IF ( DTL0 .LT. 0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1001) - CALL EXTCDE ( 2 ) - END IF - ELSE - DTL0 = 0. - END IF -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3WAVE, step 4' - FLUSH(740+IAPROC) -#endif + IF ( TLEV(1) .GE. 0. ) THEN + DTL0 = DSEC21 ( TLEV , TLN ) + ELSE + DTL0 = 1. + END IF + if (w3_t_flag) then + WRITE (NDST,9011) DTL0 + end if + IF ( DTL0 .LT. 0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1001) + CALL EXTCDE ( 2 ) + END IF + ELSE + DTL0 = 0. + END IF + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 4' + end if #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 4") -#endif + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 4") + end if #endif -! -! 1.c Current interval -! + ! + ! 1.c Current interval + ! IF ( FLCUR ) THEN - DTTST1 = DSEC21 ( TC0 , TCN ) - DTTST2 = DSEC21 ( TC0 , TIME ) - DTTST3 = DSEC21 ( TEND , TCN ) -#ifdef W3_T - WRITE (NDST,9012) DTTST1, DTTST2, DTTST3 -#endif - IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1002) - CALL EXTCDE ( 3 ) - END IF - IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN - IDACT(7:7) = 'F' - TOFRST = TIME - END IF - END IF -! -! 1.d Wind interval -! + DTTST1 = DSEC21 ( TC0 , TCN ) + DTTST2 = DSEC21 ( TC0 , TIME ) + DTTST3 = DSEC21 ( TEND , TCN ) + if (w3_t_flag) then + WRITE (NDST,9012) DTTST1, DTTST2, DTTST3 + end if + IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1002) + CALL EXTCDE ( 3 ) + END IF + IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN + IDACT(7:7) = 'F' + TOFRST = TIME + END IF + END IF + ! + ! 1.d Wind interval + ! IF ( FLWIND ) THEN - DTTST1 = DSEC21 ( TW0 , TWN ) - DTTST2 = DSEC21 ( TW0 , TIME ) - DTTST3 = DSEC21 ( TEND , TWN ) -#ifdef W3_T - WRITE (NDST,9013) DTTST1, DTTST2, DTTST3 -#endif - IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1003) - CALL EXTCDE ( 4 ) - END IF - IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN - IDACT(3:3) = 'F' - TOFRST = TIME - END IF - END IF -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3WAVE, step 5' - FLUSH(740+IAPROC) -#endif + DTTST1 = DSEC21 ( TW0 , TWN ) + DTTST2 = DSEC21 ( TW0 , TIME ) + DTTST3 = DSEC21 ( TEND , TWN ) + if (w3_t_flag) then + WRITE (NDST,9013) DTTST1, DTTST2, DTTST3 + end if + IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1003) + CALL EXTCDE ( 4 ) + END IF + IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN + IDACT(3:3) = 'F' + TOFRST = TIME + END IF + END IF + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 5' + end if #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 5") -#endif + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 5") + end if #endif -! -! 1.e Ice concentration interval -! + ! + ! 1.e Ice concentration interval + ! IF ( FLICE ) THEN - IF ( TICE(1) .GE. 0 ) THEN - DTI0 = DSEC21 ( TICE , TIN ) - ELSE - DTI0 = 1. - END IF -#ifdef W3_T - WRITE (NDST,9014) DTI0 -#endif - IF ( DTI0 .LT. 0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1004) - CALL EXTCDE ( 5 ) - END IF - ELSE - DTI0 = 0. - END IF -#ifdef W3_DEBUGINIT - WRITE(740+IAPROC,*) 'W3WAVE, step 6' - FLUSH(740+IAPROC) -#endif + IF ( TICE(1) .GE. 0 ) THEN + DTI0 = DSEC21 ( TICE , TIN ) + ELSE + DTI0 = 1. + END IF + if (w3_t_flag) then + WRITE (NDST,9014) DTI0 + end if + IF ( DTI0 .LT. 0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1004) + CALL EXTCDE ( 5 ) + END IF + ELSE + DTI0 = 0. + END IF + if (w3_debuginit_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6' + end if #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 6") -#endif + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 6") + end if #endif -! -! 1.f Momentum interval -! + ! + ! 1.f Momentum interval + ! IF ( FLTAUA ) THEN - DTTST1 = DSEC21 ( TU0 , TUN ) - DTTST2 = DSEC21 ( TU0 , TIME ) - DTTST3 = DSEC21 ( TEND , TUN ) -#ifdef W3_T - WRITE (NDST,9017) DTTST1, DTTST2, DTTST3 -#endif - IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1007) - CALL EXTCDE ( 3 ) - END IF - IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN - IDACT(9:9) = 'F' - TOFRST = TIME - END IF - END IF -! -! 1.g Air density time -! + DTTST1 = DSEC21 ( TU0 , TUN ) + DTTST2 = DSEC21 ( TU0 , TIME ) + DTTST3 = DSEC21 ( TEND , TUN ) + if (w3_t_flag) then + WRITE (NDST,9017) DTTST1, DTTST2, DTTST3 + end if + IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1007) + CALL EXTCDE ( 3 ) + END IF + IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN + IDACT(9:9) = 'F' + TOFRST = TIME + END IF + END IF + ! + ! 1.g Air density time + ! IF ( FLRHOA ) THEN - DTTST1 = DSEC21 ( TU0 , TUN ) - DTTST2 = DSEC21 ( TU0 , TIME ) - DTTST3 = DSEC21 ( TEND , TUN ) -#ifdef W3_T - WRITE (NDST,9018) DTTST1, DTTST2, DTTST3 -#endif - IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1008) - CALL EXTCDE ( 2 ) - END IF - IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN - IDACT(11:11) = 'F' - TOFRST = TIME - END IF - END IF -! -! 1.e Ice thickness interval -! + DTTST1 = DSEC21 ( TU0 , TUN ) + DTTST2 = DSEC21 ( TU0 , TIME ) + DTTST3 = DSEC21 ( TEND , TUN ) + if (w3_t_flag) then + WRITE (NDST,9018) DTTST1, DTTST2, DTTST3 + end if + IF ( DTTST1.LT.0. .OR. DTTST2.LT.0. .OR. DTTST3.LT.0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1008) + CALL EXTCDE ( 2 ) + END IF + IF ( DTTST2.EQ.0..AND. ITIME.EQ.0 ) THEN + IDACT(11:11) = 'F' + TOFRST = TIME + END IF + END IF + ! + ! 1.e Ice thickness interval + ! IF ( FLIC1 ) THEN - IF ( TIC1(1) .GE. 0 ) THEN - DTI10 = DSEC21 ( TIC1 , TI1 ) - ELSE - DTI10 = 1. - END IF -#ifdef W3_T - WRITE (NDST,9015) DTI10 -#endif - IF ( DTI10 .LT. 0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1005) - CALL EXTCDE ( 5 ) - END IF - ELSE - DTI10 = 0. - END IF -! -! 1.e Ice floe interval -! + IF ( TIC1(1) .GE. 0 ) THEN + DTI10 = DSEC21 ( TIC1 , TI1 ) + ELSE + DTI10 = 1. + END IF + if (w3_t_flag) then + WRITE (NDST,9015) DTI10 + end if + IF ( DTI10 .LT. 0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1005) + CALL EXTCDE ( 5 ) + END IF + ELSE + DTI10 = 0. + END IF + ! + ! 1.e Ice floe interval + ! #ifdef W3_IS2 IF ( FLIC5 ) THEN - IF ( TIC5(1) .GE. 0 ) THEN - DTI50 = DSEC21 ( TIC5 , TI5 ) - ELSE - DTI50 = 1. - END IF -#ifdef W3_T - WRITE (NDST,9016) DTI50 + IF ( TIC5(1) .GE. 0 ) THEN + DTI50 = DSEC21 ( TIC5 , TI5 ) + ELSE + DTI50 = 1. + END IF + if (w3_t_flag) then + WRITE (NDST,9016) DTI50 + end if + IF ( DTI50 .LT. 0. ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1006) + CALL EXTCDE ( 5 ) + END IF + ELSE + DTI50 = 0. + END IF #endif - IF ( DTI50 .LT. 0. ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1006) - CALL EXTCDE ( 5 ) - END IF - ELSE - DTI50 = 0. - END IF -#endif -! -! 2. Determine next time from ending and output --------------------- / -! time and get corresponding time step. -! + ! + ! 2. Determine next time from ending and output --------------------- / + ! time and get corresponding time step. + ! FLFRST = .TRUE. DO -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'First entry in the TIME LOOP' - FLUSH(740+IAPROC) -#endif -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("First entry in the TIME LOOP") -#endif -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.1' - FLUSH(740+IAPROC) -#endif -! DO JSEA = 1, NSEAL -! DO IS = 1, NSPEC -! IF (VA(IS, JSEA) .LT. 0.) THEN -! WRITE(740+IAPROC,*) 'TEST W3WAVE 2', VA(IS,JSEA) -! CALL FLUSH(740+IAPROC) -! ENDIF -! ENDDO -! ENDDO -! IF (SUM(VA) .NE. SUM(VA)) THEN -! WRITE(740+IAPROC,*) 'NAN in ACTION 2', IX, IY, SUM(VA) -! CALL FLUSH(740+IAPROC) -! STOP -! ENDIF + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'First entry in the TIME LOOP' + end if + if (w3_timings_flag) then + CALL PRINT_MY_TIME("First entry in the TIME LOOP") + end if + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.1' + end if + ! DO JSEA = 1, NSEAL + ! DO IS = 1, NSPEC + ! IF (VA(IS, JSEA) .LT. 0.) THEN + ! WRITE(740+IAPROC,*) 'TEST W3WAVE 2', VA(IS,JSEA) + ! ENDIF + ! ENDDO + ! ENDDO + ! IF (SUM(VA) .NE. SUM(VA)) THEN + ! WRITE(740+IAPROC,*) 'NAN in ACTION 2', IX, IY, SUM(VA) + ! STOP + ! ENDIF #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 6.1") -#endif -#endif -! -! -! 2.a Pre-calculate table for IC3 ------------------------------------ / + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "W3WAVEMD, step 6.1") + end if +#endif + ! + ! + ! 2.a Pre-calculate table for IC3 ------------------------------------ / + !TODO: Clean up serial W3_IC3 ifdefs #ifdef W3_IC3 - USE_CHENG=IC3PARS(9) - IF( USE_CHENG==1.0 )THEN - FIXEDVISC=IC3PARS(14) - FIXEDDENS=IC3PARS(15) - FIXEDELAS=IC3PARS(16) - IF ( (FIXEDVISC.LT.0.0).OR.(FIXEDDENS.LT.0.0) .OR. & - (FIXEDELAS.LT.0.0) ) THEN + USE_CHENG=IC3PARS(9) + IF( USE_CHENG==1.0 )THEN + FIXEDVISC=IC3PARS(14) + FIXEDDENS=IC3PARS(15) + FIXEDELAS=IC3PARS(16) + IF ( (FIXEDVISC.LT.0.0).OR.(FIXEDDENS.LT.0.0) .OR. (FIXEDELAS.LT.0.0) ) THEN IF ( IAPROC .EQ. NAPERR ) & - WRITE(NDSE,*)'Cheng method requires stationary', & - ' and uniform rheology from namelist.' + WRITE(NDSE,*)'Cheng method requires stationary', & + ' and uniform rheology from namelist.' CALL EXTCDE(2) - END IF - IF (CALLEDIC3TABLE==0) THEN - CALL IC3TABLE_CHENG(FIXEDVISC,FIXEDDENS,FIXEDELAS) - CALLEDIC3TABLE = 1 - ENDIF - ENDIF + END IF + IF (CALLEDIC3TABLE==0) THEN + CALL IC3TABLE_CHENG(FIXEDVISC,FIXEDDENS,FIXEDELAS) + CALLEDIC3TABLE = 1 + ENDIF + ENDIF #endif - -! 2.b Update group velocity and wavenumber from ice parameters ------- / -! from W3SIC3MD module. ------------------------------------------ / -! Note: "IF FLFRST" can be added for efficiency, but testing req'd + ! 2.b Update group velocity and wavenumber from ice parameters ------- / + ! from W3SIC3MD module. ------------------------------------------ / + ! Note: "IF FLFRST" can be added for efficiency, but testing req'd JSEA=1 ! no switch (intentional) #ifdef W3_IC3 - USE_CGICE=IC3PARS(12) - IF ( USE_CGICE==1.0 ) THEN - IF ( IAPROC .EQ. NAPERR ) WRITE(SCREEN,920) -#endif + USE_CGICE=IC3PARS(12) + IF ( USE_CGICE==1.0 ) THEN + IF ( IAPROC .EQ. NAPERR ) WRITE(SCREEN,920) -#ifdef W3_IC3 - DO JSEA=1,NSEAL + DO JSEA=1,NSEAL #endif #ifdef W3_DIST - ISEA = IAPROC + (JSEA-1)*NAPROC + ISEA = IAPROC + (JSEA-1)*NAPROC #endif #ifdef W3_SHRD - ISEA = JSEA + ISEA = JSEA #endif #ifdef W3_IC3 - ALLOCATE(WN_I(SIZE(WN(:,ISEA)))) - WN_I(:) = 0. - DEPTH = MAX( DMIN , DW(ISEA) ) - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) + ALLOCATE(WN_I(SIZE(WN(:,ISEA)))) + WN_I(:) = 0. + DEPTH = MAX( DMIN , DW(ISEA) ) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) #endif -! 2.b.1 Using Cheng method: requires stationary/uniform rheology. -! However, ice thickness may be input by either method - + ! 2.b.1 Using Cheng method: requires stationary/uniform rheology. + ! However, ice thickness may be input by either method #ifdef W3_IC3 - IF ( USE_CHENG==1.0 ) THEN - IF (FLIC1) THEN - HICE=ICEP1(IX,IY) - ELSEIF (IC3PARS(13).GE.0.0)THEN - HICE=IC3PARS(13) - ELSE - IF ( IAPROC .EQ. NAPERR ) & - WRITE(NDSE,*)'ICE THICKNESS NOT AVAILABLE ', & - 'FOR CG CALC' - CALL EXTCDE(2) - ENDIF - IF (HICE > 0.0) THEN ! non-zero ice - CALL W3IC3WNCG_CHENG(WN(:,ISEA),WN_I(:), & - CG(:,ISEA),HICE,FIXEDVISC, & - FIXEDDENS, FIXEDELAS, DEPTH) - END IF ! non-zero ice + IF ( USE_CHENG==1.0 ) THEN + IF (FLIC1) THEN + HICE=ICEP1(IX,IY) + ELSEIF (IC3PARS(13).GE.0.0)THEN + HICE=IC3PARS(13) + ELSE + IF ( IAPROC .EQ. NAPERR ) & + WRITE(NDSE,*)'ICE THICKNESS NOT AVAILABLE ', & + 'FOR CG CALC' + CALL EXTCDE(2) + ENDIF + IF (HICE > 0.0) THEN ! non-zero ice + CALL W3IC3WNCG_CHENG(WN(:,ISEA),WN_I(:), & + CG(:,ISEA),HICE,FIXEDVISC, & + FIXEDDENS, FIXEDELAS, DEPTH) + END IF ! non-zero ice #endif - #ifdef W3_IC3 - ELSE ! not using Cheng method + ELSE ! not using Cheng method #endif -! 2.b.2 If not using Cheng method: require FLIC1 to FLIC4 (not strictly -! necesssary, but makes code simpler) - + ! 2.b.2 If not using Cheng method: require FLIC1 to FLIC4 (not strictly + ! necesssary, but makes code simpler) #ifdef W3_IC3 - IF (FLIC1.AND.FLIC2.AND.FLIC3.AND.FLIC4) THEN - IF (ICEP1(IX,IY)>0.0) THEN ! non-zero ice - CALL W3IC3WNCG_V1(WN(:,ISEA),WN_I(:), & - CG(:,ISEA),ICEP1(IX,IY),ICEP2(IX,IY), & - ICEP3(IX,IY),ICEP4(IX,IY),DEPTH) - END IF ! non-zero ice - ELSE - IF ( IAPROC .EQ. NAPERR ) & - WRITE(NDSE,*)'ICE PARAMETERS NOT AVAILABLE ', & - 'FOR CG CALC' - CALL EXTCDE(2) - END IF - ENDIF ! IF USE_CHENG... + IF (FLIC1.AND.FLIC2.AND.FLIC3.AND.FLIC4) THEN + IF (ICEP1(IX,IY)>0.0) THEN ! non-zero ice + CALL W3IC3WNCG_V1(WN(:,ISEA),WN_I(:), & + CG(:,ISEA),ICEP1(IX,IY),ICEP2(IX,IY), & + ICEP3(IX,IY),ICEP4(IX,IY),DEPTH) + END IF ! non-zero ice + ELSE + IF ( IAPROC .EQ. NAPERR ) & + WRITE(NDSE,*)'ICE PARAMETERS NOT AVAILABLE ', & + 'FOR CG CALC' + CALL EXTCDE(2) + END IF + ENDIF ! IF USE_CHENG... #endif - #ifdef W3_IC3 - DEALLOCATE(WN_I) - END DO ! DO JSEA=1,NSEAL - END IF ! IF USE_CGICE ... + DEALLOCATE(WN_I) + END DO ! DO JSEA=1,NSEAL + END IF ! IF USE_CGICE ... #endif -! - IF ( TOFRST(1) .GT. 0 ) THEN + ! + IF ( TOFRST(1) .GT. 0 ) THEN DTTST = DSEC21 ( TEND , TOFRST ) - ELSE + ELSE DTTST = 0. - ENDIF -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) '2 : DTTST=', DTTST, TEND, TOFRST -#endif -! - IF ( DTTST.GE.0. ) THEN + ENDIF + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) '2 : DTTST=', DTTST, TEND, TOFRST + end if + ! + IF ( DTTST.GE.0. ) THEN TCALC = TEND - ELSE + ELSE TCALC = TOFRST - END IF -! - DTTST = DSEC21 ( TIME , TCALC ) -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) '3 : DTTST=', DTTST, TEND, TOFRST -#endif - NT = 1 + INT ( DTTST / DTMAX - 0.001 ) - DTGA = DTTST / REAL(NT) -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'DTTST=', DTTST, ' NT=', NT -#endif - IF ( DTTST .EQ. 0. ) THEN + END IF + ! + DTTST = DSEC21 ( TIME , TCALC ) + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) '3 : DTTST=', DTTST, TEND, TOFRST + end if + NT = 1 + INT ( DTTST / DTMAX - 0.001 ) + DTGA = DTTST / REAL(NT) + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'DTTST=', DTTST, ' NT=', NT + end if + IF ( DTTST .EQ. 0. ) THEN IT0 = 0 IF ( .NOT.FLZERO ) ITIME = ITIME - 1 NT = 0 - ELSE + ELSE IT0 = 1 - END IF - -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif - -! -#ifdef W3_T - WRITE (NDST,9020) IT0, NT, DTGA -#endif -! -! ==================================================================== / -! -! 3. Loop over time steps -! - DTRES = 0. - -#ifdef W3_DEBUGRUN - DO JSEA = 1, NSEAL - DO IS = 1, NSPEC - IF (VA(IS, JSEA) .LT. 0.) THEN - WRITE(740+IAPROC,*) 'TEST W3WAVE 3', VA(IS,JSEA) - CALL FLUSH(740+IAPROC) - ENDIF - ENDDO - ENDDO - IF (SUM(VA) .NE. SUM(VA)) THEN - WRITE(740+IAPROC,*) 'NAN in ACTION 3', IX, IY, SUM(VA) - CALL FLUSH(740+IAPROC) - STOP - ENDIF - WRITE(740+IAPROC,*) 'IT0=', IT0, ' NT=', NT - FLUSH(740+IAPROC) -#endif -! - DO IT = IT0, NT -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Begin of IT loop") -#endif + END IF + call print_memcheck(memunit, 'memcheck_____:'//' WW3_WAVE') + ! + if (w3_t_flag) then + WRITE (NDST,9020) IT0, NT, DTGA + end if + ! + ! ==================================================================== / + ! + ! 3. Loop over time steps + ! + DTRES = 0. + + if (w3_debugrun_flag) then + DO JSEA = 1, NSEAL + DO IS = 1, NSPEC + IF (VA(IS, JSEA) .LT. 0.) THEN + WRITE(740+IAPROC,*) 'TEST W3WAVE 3', VA(IS,JSEA) + ENDIF + ENDDO + ENDDO + IF (SUM(VA) .NE. SUM(VA)) THEN + WRITE(740+IAPROC,*) 'NAN in ACTION 3', IX, IY, SUM(VA) + STOP + ENDIF + WRITE(740+IAPROC,*) 'IT0=', IT0, ' NT=', NT + end if + ! + DO IT = IT0, NT + if (w3_timings_flag) then + CALL PRINT_MY_TIME("Begin of IT loop") + end if #ifdef W3_SETUP - CALL WAVE_SETUP_COMPUTATION -#endif -! copy old values -#ifdef W3_PDLIB - DO IP=1,NSEAL - DO ISPEC=1,NSPEC - VAOLD(ISPEC,IP)=VA(ISPEC,IP) - END DO - END DO + CALL WAVE_SETUP_COMPUTATION #endif -! + ! copy old values #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Beginning time loop") -#endif -#endif -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After assigning VAOLD") -#endif -! -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 0' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif -! - ITIME = ITIME + 1 -! - DTG = REAL(NINT(DTGA+DTRES+0.0001)) - DTRES = DTRES + DTGA - DTG - IF ( ABS(DTRES) .LT. 0.001 ) DTRES = 0. - CALL TICK21 ( TIME , DTG ) -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'DTGA=', DTGA, ' DTRES=', DTRES - WRITE(740+IAPROC,*) 'DTG 1 : DTG=', DTG - FLUSH(740+IAPROC) -#endif -! -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 1' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif - - IF ( TSTAMP .AND. SCREEN.NE.NDSO .AND. IAPROC.EQ.NAPOUT ) THEN - CALL WWTIME ( STTIME ) - CALL STME21 ( TIME , IDTIME ) - WRITE (SCREEN,950) IDTIME, STTIME + DO IP=1,NSEAL + DO ISPEC=1,NSPEC + VAOLD(ISPEC,IP)=VA(ISPEC,IP) + END DO + END DO + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Beginning time loop") + end if +#endif + if (w3_timings_flag) then + CALL PRINT_MY_TIME("After assigning VAOLD") + end if + call print_memcheck(memunit, 'memcheck_____:'//' WW3_WAVE TIME LOOP 0') + ! + ITIME = ITIME + 1 + ! + DTG = REAL(NINT(DTGA+DTRES+0.0001)) + DTRES = DTRES + DTGA - DTG + IF ( ABS(DTRES) .LT. 0.001 ) DTRES = 0. + CALL TICK21 ( TIME , DTG ) + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'DTGA=', DTGA, ' DTRES=', DTRES + WRITE(740+IAPROC,*) 'DTG 1 : DTG=', DTG + end if + ! + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE TIME LOOP 1') + ! + IF ( TSTAMP .AND. SCREEN.NE.NDSO .AND. IAPROC.EQ.NAPOUT ) THEN + CALL WWTIME ( STTIME ) + CALL STME21 ( TIME , IDTIME ) + WRITE (SCREEN,950) IDTIME, STTIME END IF - -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 2' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif - -#ifdef W3_DEBUGRUN - DO JSEA = 1, NSEAL - DO IS = 1, NSPEC - IF (VA(IS, JSEA) .LT. 0.) THEN - WRITE(740+IAPROC,*) 'TEST W3WAVE 4', VA(IS,JSEA) - CALL FLUSH(740+IAPROC) - ENDIF - ENDDO - ENDDO - IF (SUM(VA) .NE. SUM(VA)) THEN - WRITE(740+IAPROC,*) 'NAN in ACTION 4', IX, IY, SUM(VA) - CALL FLUSH(740+IAPROC) - STOP - ENDIF -#endif -! - VGX = 0. - VGY = 0. - IF(INFLAGS1(10)) THEN - DTTST1 = DSEC21 ( TIME, TGN ) - DTTST2 = DSEC21 ( TG0, TGN ) - FAC = DTTST1 / MAX ( 1. , DTTST2 ) - VGX = (FAC*GA0+(1.-FAC)*GAN) * & - COS(FAC*GD0+(1.-FAC)*GDN) - VGY = (FAC*GA0+(1.-FAC)*GAN) * & - SIN(FAC*GD0+(1.-FAC)*GDN) + ! + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE TIME LOOP 2') + ! + if (w3_debugrun_flag) then + DO JSEA = 1, NSEAL + DO IS = 1, NSPEC + IF (VA(IS, JSEA) .LT. 0.) THEN + WRITE(740+IAPROC,*) 'TEST W3WAVE 4', VA(IS,JSEA) + ENDIF + ENDDO + ENDDO + IF (SUM(VA) .NE. SUM(VA)) THEN + WRITE(740+IAPROC,*) 'NAN in ACTION 4', IX, IY, SUM(VA) + STOP + ENDIF + end if + ! + VGX = 0. + VGY = 0. + IF(INFLAGS1(10)) THEN + DTTST1 = DSEC21 ( TIME, TGN ) + DTTST2 = DSEC21 ( TG0, TGN ) + FAC = DTTST1 / MAX ( 1. , DTTST2 ) + VGX = (FAC*GA0+(1.-FAC)*GAN) * & + COS(FAC*GD0+(1.-FAC)*GDN) + VGY = (FAC*GA0+(1.-FAC)*GAN) * & + SIN(FAC*GD0+(1.-FAC)*GDN) END IF -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After VGX/VGY assignation") -#endif -! -#ifdef W3_T - WRITE (NDST,9021) ITIME, IT, TIME, FLMAP, FLDDIR, & - VGX, VGY, DTG, DTRES -#endif -#ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'DTG 2 : DTG=', DTG - WRITE(740+IAPROC,*) 'max(UST)=', maxval(UST) - FLUSH(740+IAPROC) -#endif -! -! 3.1 Interpolate winds, currents, and momentum. -! (Initialize wave fields with winds) -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'FLCUR=', FLCUR - FLUSH(740+IAPROC) -#endif -#ifdef W3_DEBUGDCXDX - WRITE(740+IAPROC,*) 'Debug DCXDX FLCUR=', FLCUR -#endif -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 3a ' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif - - IF ( FLCUR ) THEN -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.4' - FLUSH(740+IAPROC) -#endif + if (w3_timings_flag) then + CALL PRINT_MY_TIME("After VGX/VGY assignation") + end if + if (w3_t_flag) then + WRITE (NDST,9021) ITIME, IT, TIME, FLMAP, FLDDIR, VGX, VGY, DTG, DTRES + end if + if (w3_debugsrc_flag) then + WRITE(740+IAPROC,*) 'DTG 2 : DTG=', DTG + WRITE(740+IAPROC,*) 'max(UST)=', maxval(UST) + end if + ! + ! 3.1 Interpolate winds, currents, and momentum. + ! (Initialize wave fields with winds) + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'FLCUR=', FLCUR + end if + if (w3_debugdcxdx_flag) then + WRITE(740+IAPROC,*) 'Debug DCXDX FLCUR=', FLCUR + end if + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE TIME LOOP 3a ') + + IF ( FLCUR ) THEN + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.4' + end if #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before UCUR") -#endif -#endif -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.4.1' - FLUSH(740+IAPROC) -#endif -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("W3WAVE, step 6.4.1") -#endif - -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.4.2 before W3UCUR' - FLUSH(740+IAPROC) -#endif - CALL W3UCUR ( FLFRST ) -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.4.1 after W3UCUR' - FLUSH(740+IAPROC) -#endif - -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 3b ' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif - IF (GTYPE .EQ. SMCTYPE) THEN - IX = 1 + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before UCUR") + end if +#endif + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.4.1' + end if + if (w3_timings_flag) then + CALL PRINT_MY_TIME("W3WAVE, step 6.4.1") + end if + + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.4.2 before W3UCUR' + end if + CALL W3UCUR ( FLFRST ) + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.4.1 after W3UCUR' + end if + + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE TIME LOOP 3b ') + IF (GTYPE .EQ. SMCTYPE) THEN + IX = 1 #ifdef W3_SMC - !!Li Use new sub for DCXDX/Y and DCYDX/Y assignment. - CALL SMCDCXY -#endif - ELSE IF (GTYPE .EQ. UNGTYPE) THEN -#ifdef W3_DEBUGDCXDX - WRITE(740+IAPROC,*) 'Before call to UG_GRADIENT for assigning DCXDX/DCXDY array' -#endif - CALL UG_GRADIENTS(CX, DCXDX, DCXDY) - CALL UG_GRADIENTS(CY, DCYDX, DCYDY) - UGDTUPDATE=.TRUE. - CFLXYMAX = 0. - ELSE - CALL W3DZXY(CX(1:UBOUND(CX,1)),'m/s',DCXDX, DCXDY) !CX GRADIENT - CALL W3DZXY(CY(1:UBOUND(CY,1)),'m/s',DCYDX, DCYDY) !CY GRADIENT - ENDIF !! End GTYPE -! -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 4' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif -! + !!Li Use new sub for DCXDX/Y and DCYDX/Y assignment. + CALL SMCDCXY +#endif + ELSE IF (GTYPE .EQ. UNGTYPE) THEN + if (w3_debugdcxdx_flag) then + WRITE(740+IAPROC,*) 'Before call to UG_GRADIENT for assigning DCXDX/DCXDY array' + end if + CALL UG_GRADIENTS(CX, DCXDX, DCXDY) + CALL UG_GRADIENTS(CY, DCYDX, DCYDY) + UGDTUPDATE=.TRUE. + CFLXYMAX = 0. + ELSE + CALL W3DZXY(CX(1:UBOUND(CX,1)),'m/s',DCXDX, DCXDY) !CX GRADIENT + CALL W3DZXY(CY(1:UBOUND(CY,1)),'m/s',DCYDX, DCYDY) !CY GRADIENT + ENDIF !! End GTYPE + ! + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE TIME LOOP 4') + ! ELSE IF ( FLFRST ) THEN - UGDTUPDATE=.TRUE. - CFLXYMAX = 0. - CX = 0. - CY = 0. - END IF ! FLCUR -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After CX/CY assignation") -#endif -! -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 5' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif - - IF ( FLWIND ) THEN - IF ( FLFRST ) ASF = 1. - CALL W3UWND ( FLFRST, VGX, VGY ) - ELSE IF ( FLFRST ) THEN - U10 = 0.01 - U10D = 0. - UST = 0.05 - USTDIR = 0.05 - END IF - -! DO JSEA = 1, NSEAL -! DO IS = 1, NSPEC -! IF (VA(IS, JSEA) .LT. 0.) THEN -! WRITE(740+IAPROC,*) 'TEST W3WAVE 5', VA(IS,JSEA) -! CALL FLUSH(740+IAPROC) -! ENDIF -! ENDDO -! ENDDO -! IF (SUM(VA) .NE. SUM(VA)) THEN -! WRITE(740+IAPROC,*) 'NAN in ACTION 5', IX, IY, SUM(VA) -! CALL FLUSH(740+IAPROC) -! STOP -! ENDIF - -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 6' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif + UGDTUPDATE=.TRUE. + CFLXYMAX = 0. + CX = 0. + CY = 0. + END IF ! FLCUR + if (w3_timings_flag) then + CALL PRINT_MY_TIME("After CX/CY assignation") + end if + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE TIME LOOP 5') + ! + IF ( FLWIND ) THEN + IF ( FLFRST ) ASF = 1. + CALL W3UWND ( FLFRST, VGX, VGY ) + ELSE IF ( FLFRST ) THEN + U10 = 0.01 + U10D = 0. + UST = 0.05 + USTDIR = 0.05 + END IF -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After U10, etc. assignation") -#endif -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.5' - FLUSH(740+IAPROC) -#endif + ! DO JSEA = 1, NSEAL + ! DO IS = 1, NSPEC + ! IF (VA(IS, JSEA) .LT. 0.) THEN + ! WRITE(740+IAPROC,*) 'TEST W3WAVE 5', VA(IS,JSEA) + ! ENDIF + ! ENDDO + ! ENDDO + ! IF (SUM(VA) .NE. SUM(VA)) THEN + ! WRITE(740+IAPROC,*) 'NAN in ACTION 5', IX, IY, SUM(VA) + ! STOP + ! ENDIF + + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE TIME LOOP 6') + + if (w3_timings_flag) then + CALL PRINT_MY_TIME("After U10, etc. assignation") + end if + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.5' + end if #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before call to W3UINI") -#endif -#endif -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Before call W3UINI") -#endif - IF ( FLIWND .AND. LOCAL ) CALL W3UINI ( VA ) -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.5.1 DTG=', DTG - FLUSH(740+IAPROC) -#endif -! - IF ( FLTAUA ) THEN - CALL W3UTAU ( FLFRST ) - ELSE IF ( FLFRST ) THEN - TAUA = 0.01 - TAUADIR = 0. - END IF -! - IF ( FLRHOA ) THEN - CALL W3URHO ( FLFRST ) - ELSE IF ( FLFRST ) THEN - RHOAIR = DAIR - END IF -! -! 3.2 Update boundary conditions if boundary flag is true (FLBPI) -! + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before call to W3UINI") + end if +#endif + if (w3_timings_flag) then + CALL PRINT_MY_TIME("Before call W3UINI") + end if + IF ( FLIWND .AND. LOCAL ) CALL W3UINI ( VA ) + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.5.1 DTG=', DTG + end if + ! + IF ( FLTAUA ) THEN + CALL W3UTAU ( FLFRST ) + ELSE IF ( FLFRST ) THEN + TAUA = 0.01 + TAUADIR = 0. + END IF + ! + IF ( FLRHOA ) THEN + CALL W3URHO ( FLFRST ) + ELSE IF ( FLFRST ) THEN + RHOAIR = DAIR + END IF + ! + ! 3.2 Update boundary conditions if boundary flag is true (FLBPI) + ! #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before boundary update") -#endif -#endif -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Before boundary update") -#endif -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'FLBPI=', FLBPI - WRITE(740+IAPROC,*) 'LOCAL=', LOCAL - FLUSH(740+IAPROC) -#endif - -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 7' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif - - IF ( FLBPI .AND. LOCAL ) THEN -! - DO - IF ( TBPIN(1) .EQ. -1 ) THEN - READBC = .TRUE. - IDACT(1:1) = 'F' - ELSE - READBC = DSEC21(TIME,TBPIN).LT.0. - IF (READBC.AND.IDACT(1:1).EQ.' ') IDACT(1:1) = 'X' - END IF - FLACT = READBC .OR. FLACT -#ifdef W3_DEBUGIOBC - WRITE(740+IAPROC,*) 'READBC=', READBC - FLUSH(740+IAPROC) -#endif - - IF ( READBC ) THEN -#ifdef W3_DEBUGIOBC - WRITE(740+IAPROC,*) 'Before call to W3IOBC' - FLUSH(740+IAPROC) -#endif - CALL W3IOBC ( 'READ', NDS(9), TBPI0, TBPIN, & - ITEST, IMOD ) -#ifdef W3_DEBUGIOBC - WRITE(740+IAPROC,*) 'After call to W3IOBC' - WRITE(740+IAPROC,*) 'ITEST=', ITEST - FLUSH(740+IAPROC) -#endif - IF ( ITEST .NE. 1 ) CALL W3UBPT - ELSE - ITEST = 0 - END IF - IF ( ITEST .LT. 0 ) IDACT(1:1) = 'L' - IF ( ITEST .GT. 0 ) IDACT(1:1) = ' ' - IF ( .NOT. (READBC.AND.FLBPI) ) EXIT - END DO - - END IF - -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 7' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif - - + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before boundary update") + end if +#endif + if (w3_timings_flag) then + CALL PRINT_MY_TIME("Before boundary update") + end if + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'FLBPI=', FLBPI + WRITE(740+IAPROC,*) 'LOCAL=', LOCAL + end if + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE TIME LOOP 7') + IF ( FLBPI .AND. LOCAL ) THEN + ! + DO + IF ( TBPIN(1) .EQ. -1 ) THEN + READBC = .TRUE. + IDACT(1:1) = 'F' + ELSE + READBC = DSEC21(TIME,TBPIN).LT.0. + IF (READBC.AND.IDACT(1:1).EQ.' ') IDACT(1:1) = 'X' + END IF + FLACT = READBC .OR. FLACT + if (w3_debugiobc_flag) then + WRITE(740+IAPROC,*) 'READBC=', READBC + end if + + IF ( READBC ) THEN + if (w3_debugiobc_flag) then + WRITE(740+IAPROC,*) 'Before call to W3IOBC' + end if + CALL W3IOBC ( 'READ', NDS(9), TBPI0, TBPIN, ITEST, IMOD ) + if (w3_debugiobc_flag) then + WRITE(740+IAPROC,*) 'After call to W3IOBC' + WRITE(740+IAPROC,*) 'ITEST=', ITEST + end if + IF ( ITEST .NE. 1 ) CALL W3UBPT + ELSE + ITEST = 0 + END IF + IF ( ITEST .LT. 0 ) IDACT(1:1) = 'L' + IF ( ITEST .GT. 0 ) IDACT(1:1) = ' ' + IF ( .NOT. (READBC.AND.FLBPI) ) EXIT + END DO + ! + END IF + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE TIME LOOP 7') + ! #ifdef W3_PDLIB - CALL APPLY_BOUNDARY_CONDITION_VA -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After FLBPI and LOCAL") -#endif -#endif -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After FLBPI and LOCAL") -#endif - -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 8' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif -! -! 3.3.1 Update ice coverage (if new ice map). -! Need to be run on output nodes too, to update MAPSTx -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'FLICE=', FLICE - WRITE(740+IAPROC,*) 'DTI0=', DTI0 - FLUSH(740+IAPROC) -#endif - IF ( FLICE .AND. DTI0.NE.0. ) THEN -! - IF ( TICE(1).GE.0 ) THEN + CALL APPLY_BOUNDARY_CONDITION_VA + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After FLBPI and LOCAL") + end if +#endif + if (w3_timings_flag) then + CALL PRINT_MY_TIME("After FLBPI and LOCAL") + end if + ! + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE TIME LOOP 8') + ! + ! 3.3.1 Update ice coverage (if new ice map). + ! Need to be run on output nodes too, to update MAPSTx + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'FLICE=', FLICE + WRITE(740+IAPROC,*) 'DTI0=', DTI0 + end if + IF ( FLICE .AND. DTI0.NE.0. ) THEN + ! + IF ( TICE(1).GE.0 ) THEN IF ( DTI0 .LT. 0. ) THEN - IDACT(13:13) = 'B' - ELSE - DTTST = DSEC21 ( TIME, TIN ) - IF ( DTTST .LE. 0.5*DTI0 ) IDACT(13:13) = 'U' - END IF - ELSE + IDACT(13:13) = 'B' + ELSE + DTTST = DSEC21 ( TIME, TIN ) + IF ( DTTST .LE. 0.5*DTI0 ) IDACT(13:13) = 'U' + END IF + ELSE IDACT(13:13) = 'I' - END IF -! - IF ( IDACT(13:13).NE.' ' ) THEN + END IF + ! + IF ( IDACT(13:13).NE.' ' ) THEN CALL W3UICE ( VA ) DTI0 = 0. FLACT = .TRUE. FLMAP = .TRUE. - END IF - END IF + END IF + END IF #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After FLICE and DTI0") -#endif -#endif -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After FLICE and DTI0") -#endif -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.7 DTG=', DTG - FLUSH(740+IAPROC) -#endif + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After FLICE and DTI0") + end if +#endif + if (w3_timings_flag) then + CALL PRINT_MY_TIME("After FLICE and DTI0") + end if + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.7 DTG=', DTG + end if #ifdef W3_PDLIB -#ifdef W3_DEBUGIOBP - IF (NX .ge. 10210) WRITE(*,*) 'Before W3ULEV:', MAPSTA(1,10210), IOBP(10210) -#endif -#endif - -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 9' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif -! -! 3.3.2 Update ice thickness -! - IF ( FLIC1 .AND. DTI10.NE.0. ) THEN -! - IF ( TIC1(1).GE.0 ) THEN + if (w3_debugiobp_flag) then + IF (NX .ge. 10210) WRITE(*,*) 'Before W3ULEV:', MAPSTA(1,10210), IOBP(10210) + end if +#endif + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE TIME LOOP 9') + ! + ! 3.3.2 Update ice thickness + ! + IF ( FLIC1 .AND. DTI10.NE.0. ) THEN + ! + IF ( TIC1(1).GE.0 ) THEN IF ( DTI10 .LT. 0. ) THEN - IDACT(15:15) = 'B' - ELSE - DTTST = DSEC21 ( TIME, TI1 ) - IF ( DTTST .LE. 0.5*DTI10 ) IDACT(15:15) = 'U' - END IF - ELSE + IDACT(15:15) = 'B' + ELSE + DTTST = DSEC21 ( TIME, TI1 ) + IF ( DTTST .LE. 0.5*DTI10 ) IDACT(15:15) = 'U' + END IF + ELSE IDACT(15:15) = 'I' - END IF + END IF -! - IF ( IDACT(15:15).NE.' ' ) THEN + ! + IF ( IDACT(15:15).NE.' ' ) THEN CALL W3UIC1 ( FLFRST ) DTI10 = 0. FLACT = .TRUE. FLMAP = .TRUE. - END IF -! + END IF + ! END IF - -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 10' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif - -! -! 3.3.3 Update ice floe diameter -! + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE TIME LOOP 10') + ! + ! 3.3.3 Update ice floe diameter + ! #ifdef W3_IS2 - IF ( FLIC5 .AND. DTI50.NE.0. ) THEN -! - IF ( TIC5(1).GE.0 ) THEN + IF ( FLIC5 .AND. DTI50.NE.0. ) THEN + IF ( TIC5(1).GE.0 ) THEN IF ( DTI50 .LT. 0. ) THEN - IDACT(18:18) = 'B' - ELSE - DTTST = DSEC21 ( TIME, TI5 ) - IF ( DTTST .LE. 0.5*DTI50 ) IDACT(18:18) = 'U' - END IF - ELSE + IDACT(18:18) = 'B' + ELSE + DTTST = DSEC21 ( TIME, TI5 ) + IF ( DTTST .LE. 0.5*DTI50 ) IDACT(18:18) = 'U' + END IF + ELSE IDACT(18:18) = 'I' - END IF -! - IF ( IDACT(18:18).NE.' ' ) THEN - CALL W3UIC5( FLFRST ) + END IF + ! + IF ( IDACT(18:18).NE.' ' ) THEN + CALL W3UIC5( FLFRST ) DTI50 = 0. FLACT = .TRUE. FLMAP = .TRUE. - END IF -! + END IF END IF #endif - -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 11a' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif -! -! 3.4 Transform grid (if new water level). -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'FLLEV=', FLLEV, ' DTL0=', DTL0 - FLUSH(740+IAPROC) -#endif - IF ( FLLEV .AND. DTL0 .NE.0. ) THEN -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'Before time works' - FLUSH(740+IAPROC) -#endif - IF ( TLEV(1) .GE. 0 ) THEN + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE TIME LOOP 11a') + ! + ! 3.4 Transform grid (if new water level). + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'FLLEV=', FLLEV, ' DTL0=', DTL0 + end if + IF ( FLLEV .AND. DTL0 .NE.0. ) THEN + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'Before time works' + end if + IF ( TLEV(1) .GE. 0 ) THEN IF ( DTL0 .LT. 0. ) THEN - IDACT(5:5) = 'B' - ELSE - DTTST = DSEC21 ( TIME, TLN ) - IF ( DTTST .LE. 0.5*DTL0 ) IDACT(5:5) = 'U' - END IF - ELSE + IDACT(5:5) = 'B' + ELSE + DTTST = DSEC21 ( TIME, TLN ) + IF ( DTTST .LE. 0.5*DTL0 ) IDACT(5:5) = 'U' + END IF + ELSE IDACT(5:5) = 'I' - END IF -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'After time works' - FLUSH(740+IAPROC) -#endif -! - IF ( IDACT(5:5).NE.' ' ) THEN - -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'Before W3ULEV' - FLUSH(740+IAPROC) -#endif + END IF + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'After time works' + end if + ! + IF ( IDACT(5:5).NE.' ' ) THEN + + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'Before W3ULEV' + end if CALL W3ULEV ( VA, VA ) -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'After W3ULEV' - FLUSH(740+IAPROC) -#endif + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'After W3ULEV' + end if UGDTUPDATE=.TRUE. CFLXYMAX = 0. DTL0 = 0. FLACT = .TRUE. FLMAP = .TRUE. - FLDDIR = FLDDIR .OR. FLCTH .OR. FSREFRACTION & - .OR. FLCK .OR. FSFREQSHIFT - END IF -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'After IDACT if test' - FLUSH(740+IAPROC) -#endif - END IF -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'After FLLEV test' - FLUSH(740+IAPROC) -#endif + FLDDIR = FLDDIR .OR. FLCTH .OR. FSREFRACTION .OR. FLCK .OR. FSFREQSHIFT + END IF + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'After IDACT if test' + end if + END IF + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'After FLLEV test' + end if #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After FFLEV and DTL0") -#endif -#ifdef W3_DEBUGIOBP - IF (NX .ge. 10210) WRITE(*,*) ' After W3ULEV:', MAPSTA(1,10210), IOBP(10210) -#endif -#endif -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After FFLEV and DTL0") -#endif -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'FLMAP=', FLMAP - FLUSH(740+IAPROC) -#endif - -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 11b' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif - -! -! 3.5 Update maps and derivatives. -! - IF ( FLMAP ) THEN - IF ( GTYPE .NE. SMCTYPE ) THEN + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After FFLEV and DTL0") + end if + if (w3_debugiobp_flag) then + IF (NX .ge. 10210) WRITE(*,*) ' After W3ULEV:', MAPSTA(1,10210), IOBP(10210) + end if +#endif + if (w3_timings_flag) then + CALL PRINT_MY_TIME("After FFLEV and DTL0") + end if + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'FLMAP=', FLMAP + end if + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE TIME LOOP 11b') + ! + ! 3.5 Update maps and derivatives. + ! + IF ( FLMAP ) THEN + IF ( GTYPE .NE. SMCTYPE ) THEN #ifdef W3_PR1 - CALL W3MAP1 ( MAPSTA ) + CALL W3MAP1 ( MAPSTA ) #endif #ifdef W3_PR2 - CALL W3MAP2 + CALL W3MAP2 #endif #ifdef W3_PR3 - CALL W3MAP3 + CALL W3MAP3 #endif - CALL W3UTRN ( TRNX, TRNY ) + CALL W3UTRN ( TRNX, TRNY ) #ifdef W3_PR3 - CALL W3MAPT -#endif - END IF !! GTYPE - CALL W3NMIN ( MAPSTA, FLAG0 ) - IF ( FLAG0 .AND. IAPROC.EQ.NAPERR ) WRITE (NDSE,1030) IMOD - FLMAP = .FALSE. - END IF -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.1 DTG=', DTG - FLUSH(740+IAPROC) -#endif -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.2 DTG=', DTG - WRITE(740+IAPROC,*) 'FLDDIR=', FLDDIR - FLUSH(740+IAPROC) -#endif - IF ( FLDDIR ) THEN - IF (GTYPE .EQ. SMCTYPE) THEN - IX = 1 + CALL W3MAPT +#endif + END IF !! GTYPE + CALL W3NMIN ( MAPSTA, FLAG0 ) + IF ( FLAG0 .AND. IAPROC.EQ.NAPERR ) WRITE (NDSE,1030) IMOD + FLMAP = .FALSE. + END IF + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.1 DTG=', DTG + end if + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.2 DTG=', DTG + WRITE(740+IAPROC,*) 'FLDDIR=', FLDDIR + end if + IF ( FLDDIR ) THEN + IF (GTYPE .EQ. SMCTYPE) THEN + IX = 1 #ifdef W3_SMC - !!Li Use new sub for DDDX and DDDY assignment. - CALL SMCDHXY + !!Li Use new sub for DDDX and DDDY assignment. + CALL SMCDHXY #endif - ELSE IF (GTYPE .EQ. UNGTYPE) THEN - CALL UG_GRADIENTS(DW, DDDX, DDDY) + ELSE IF (GTYPE .EQ. UNGTYPE) THEN + CALL UG_GRADIENTS(DW, DDDX, DDDY) + ELSE + CALL W3DZXY(DW(1:UBOUND(DW,1)),'m',DDDX,DDDY) + END IF + FLDDIR = .FALSE. + END IF + ! + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE TIME LOOP 12') + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.3 DTG=', DTG + end if + ! + ! Calculate PHASE SPEED GRADIENT. + ! + DCDX = 0. + DCDY = 0. +#ifdef W3_REFRX + CIK = 0. + IF (GTYPE .NE. UNGTYPE) THEN + DO IK=0,NK+1 + CIK = SIG(IK) / WN(IK,1:NSEA) + CALL W3DZXY(CIK,'m/s',DCDX(IK,:,:),DCDY(IK,:,:)) + END DO ELSE - CALL W3DZXY(DW(1:UBOUND(DW,1)),'m',DDDX,DDDY) + WRITE (NDSE,1040) + CALL EXTCDE(2) + ! CALL UG_GRADIENTS(CMN, DCDX, DCDY) !/ Stefan, to be confirmed! END IF - FLDDIR = .FALSE. - END IF - -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 12' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) #endif - -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.3 DTG=', DTG - FLUSH(740+IAPROC) -#endif -! -! Calculate PHASE SPEED GRADIENT. - DCDX = 0. - DCDY = 0. -#ifdef W3_REFRX - CIK = 0. -! - IF (GTYPE .NE. UNGTYPE) THEN - DO IK=0,NK+1 - CIK = SIG(IK) / WN(IK,1:NSEA) - CALL W3DZXY(CIK,'m/s',DCDX(IK,:,:),DCDY(IK,:,:)) - END DO - ELSE - WRITE (NDSE,1040) - CALL EXTCDE(2) - ! CALL UG_GRADIENTS(CMN, DCDX, DCDY) !/ Stefan, to be confirmed! - END IF -#endif -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.4' - FLUSH(740+IAPROC) -#endif -! - FLIWND = .FALSE. - FLFRST = .FALSE. -! + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.4' + end if + ! + FLIWND = .FALSE. + FLFRST = .FALSE. + ! + ! TODO: Clean up serial W3_PDLIB #ifdef W3_PDLIB -#ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA before W3SRCE_IMP_PRE") - CALL ALL_FIELD_INTEGRAL_PRINT(VSTOT, "VSTOT before W3SRCE_IMP_PRE") - CALL ALL_FIELD_INTEGRAL_PRINT(VDTOT, "VDTOT before W3SRCE_IMP_PRE") - IF (DEBUG_NODE .le. NSEAL) THEN - WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE - WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) - WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,DEBUG_NODE)) - WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,DEBUG_NODE)) - END IF -#endif - IF (IT .eq. 0) THEN - DTGpre = 1. - ELSE - DTGpre = DTG - END IF -#endif - -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 13' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) + if (w3_debugsrc_flag) then + WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA before W3SRCE_IMP_PRE") + CALL ALL_FIELD_INTEGRAL_PRINT(VSTOT, "VSTOT before W3SRCE_IMP_PRE") + CALL ALL_FIELD_INTEGRAL_PRINT(VDTOT, "VDTOT before W3SRCE_IMP_PRE") + IF (DEBUG_NODE .le. NSEAL) THEN + WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE + WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,DEBUG_NODE)) + END IF + end if + IF (IT .eq. 0) THEN + DTGpre = 1. + ELSE + DTGpre = DTG + END IF #endif -! + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE TIME LOOP 13') + ! #ifdef W3_PDLIB - IF ( FLSOU .and. LPDLIB .and. FSSOURCE) THEN -#endif - -#ifdef W3_OMP0 -!$OMP PARALLEL DO PRIVATE (JSEA,ISEA,IX,IY) SCHEDULE (DYNAMIC,1) + IF ( FLSOU .and. LPDLIB .and. FSSOURCE) THEN #endif - #ifdef W3_PDLIB - D50=0.0002 - REFLEC(:)=0. - REFLED(:)=0 - PSIC=0. + D50=0.0002 + REFLEC(:)=0. + REFLED(:)=0 + PSIC=0. #endif #ifdef W3_PDLIB - IF (.not. LSLOC) THEN - VSTOT = 0. - VDTOT = 0. - ENDIF - IF (LSLOC) THEN - B_JAC = 0. - ASPAR_JAC = 0. - ENDIF + IF (.not. LSLOC) THEN + VSTOT = 0. + VDTOT = 0. + ENDIF + IF (LSLOC) THEN + B_JAC = 0. + ASPAR_JAC = 0. + ENDIF #endif - - #ifdef W3_PDLIB - DO JSEA = 1, NP + DO JSEA = 1, NP #endif #ifdef W3_PDLIB - CALL INIT_GET_ISEA(ISEA, JSEA) + CALL INIT_GET_ISEA(ISEA, JSEA) #endif #ifdef W3_PDLIB - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - DELA=1. - DELX=1. - DELY=1. -#ifdef W3_REF1 - IF (GTYPE.EQ.RLGTYPE) THEN - DELX=SX*CLATS(ISEA)/FACX - DELY=SY/FACX - DELA=DELX*DELY - END IF - IF (GTYPE.EQ.CLGTYPE) THEN -! Maybe what follows works also for RLGTYPE ... to be verified - DELX=HPFAC(IY,IX)/ FACX - DELY=HQFAC(IY,IX)/ FACX - DELA=DELX*DELY - END IF -#endif -! + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + DELA=1. + DELX=1. + DELY=1. #ifdef W3_REF1 - REFLEC=REFLC(:,ISEA) - REFLEC(4)=BERG(ISEA)*REFLEC(4) - REFLED=REFLD(:,ISEA) -#endif -#ifdef W3_BT4 - D50=SED_D50(ISEA) - PSIC=SED_PSIC(ISEA) + IF (GTYPE.EQ.RLGTYPE) THEN + DELX=SX*CLATS(ISEA)/FACX + DELY=SY/FACX + DELA=DELX*DELY + END IF + IF (GTYPE.EQ.CLGTYPE) THEN + ! Maybe what follows works also for RLGTYPE ... to be verified + DELX=HPFAC(IY,IX)/ FACX + DELY=HQFAC(IY,IX)/ FACX + DELA=DELX*DELY + END IF #endif + ! #ifdef W3_REF1 - REFLEC=REFLC(:,ISEA) - REFLEC(4)=BERG(ISEA)*REFLEC(4) - REFLED=REFLD(:,ISEA) + REFLEC=REFLC(:,ISEA) + REFLEC(4)=BERG(ISEA)*REFLEC(4) + REFLED=REFLD(:,ISEA) #endif #ifdef W3_BT4 - D50=SED_D50(ISEA) - PSIC=SED_PSIC(ISEA) -#endif -! -#ifdef W3_DEBUGRUN - DO IS = 1, NSPEC - IF (VA(IS, JSEA) .LT. 0.) THEN - WRITE(740+IAPROC,*) 'TEST W3WAVE 7', VA(IS,JSEA) - CALL FLUSH(740+IAPROC) - ENDIF - ENDDO -#endif + D50=SED_D50(ISEA) + PSIC=SED_PSIC(ISEA) +#endif + ! + if (w3_debugrun_flag) then + DO IS = 1, NSPEC + IF (VA(IS, JSEA) .LT. 0.) THEN + WRITE(740+IAPROC,*) 'TEST W3WAVE 7', VA(IS,JSEA) + ENDIF + ENDDO + end if -! + ! #ifdef W3_PDLIB - IF ((IOBP_LOC(JSEA) .eq. 1 .or. IOBP_LOC(JSEA) .eq. 3) & - & .and. IOBDP_LOC(JSEA) .eq. 1 .and. IOBPA_LOC(JSEA) .eq. 0) THEN + IF ((IOBP_LOC(JSEA) .eq. 1 .or. IOBP_LOC(JSEA) .eq. 3) & + & .and. IOBDP_LOC(JSEA) .eq. 1 .and. IOBPA_LOC(JSEA) .eq. 0) THEN #endif -!!/PDLIB IF ( MAPSTA(IY,IX) .EQ. 1 .AND. FLAGST(ISEA)) THEN + !!/PDLIB IF ( MAPSTA(IY,IX) .EQ. 1 .AND. FLAGST(ISEA)) THEN #ifdef W3_PDLIB -#ifdef W3_DEBUGSRC - IF (IX .eq. DEBUG_NODE) THEN - WRITE(740+IAPROC,*) 'NODE_SRCE_IMP_PRE : IX=', IX, ' JSEA=', JSEA - END IF - WRITE(740+IAPROC,*) 'IT/IX/IY/IMOD=', IT, IX, IY, IMOD - WRITE(740+IAPROC,*) 'ISEA/JSEA=', ISEA, JSEA - WRITE(740+IAPROC,*) 'Before sum(VA)=', sum(VA(:,JSEA)) - FLUSH(740+IAPROC) -#endif - CALL W3SRCE(srce_imp_pre, IT, ISEA, JSEA, IX, IY, IMOD, & - VAold(:,JSEA), VA(:,JSEA), & - VSioDummy, VDioDummy, SHAVETOT(JSEA), & - ALPHA(1:NK,JSEA), WN(1:NK,ISEA), & - CG(1:NK,ISEA), CLATS(ISEA), DW(ISEA), U10(ISEA), & - U10D(ISEA), & + if (w3_debugsrc_flag) then + IF (IX .eq. DEBUG_NODE) THEN + WRITE(740+IAPROC,*) 'NODE_SRCE_IMP_PRE : IX=', IX, ' JSEA=', JSEA + END IF + WRITE(740+IAPROC,*) 'IT/IX/IY/IMOD=', IT, IX, IY, IMOD + WRITE(740+IAPROC,*) 'ISEA/JSEA=', ISEA, JSEA + WRITE(740+IAPROC,*) 'Before sum(VA)=', sum(VA(:,JSEA)) + end if + CALL W3SRCE(srce_imp_pre, IT, ISEA, JSEA, IX, IY, IMOD, & + VAold(:,JSEA), VA(:,JSEA), & + VSioDummy, VDioDummy, SHAVETOT(JSEA), & + ALPHA(1:NK,JSEA), WN(1:NK,ISEA), & + CG(1:NK,ISEA), CLATS(ISEA), DW(ISEA), U10(ISEA), & + U10D(ISEA), & #ifdef W3_FLX5 - TAUA(ISEA), TAUADIR(ISEA), & -#endif - AS(ISEA), UST(ISEA), & - USTDIR(ISEA), CX(ISEA), CY(ISEA), & - ICE(ISEA), ICEH(ISEA), ICEF(ISEA), & - ICEDMAX(ISEA), & - REFLEC, REFLED, DELX, DELY, DELA, & - TRNX(IY,IX), TRNY(IY,IX), BERG(ISEA), & - FPIS(ISEA), DTDYN(JSEA), & - FCUT(JSEA), DTGpre, TAUWX(JSEA), TAUWY(JSEA), & - TAUOX(JSEA), TAUOY(JSEA), TAUWIX(JSEA), & - TAUWIY(JSEA), TAUWNX(JSEA), & - TAUWNY(JSEA), PHIAW(JSEA), CHARN(JSEA), & - TWS(JSEA), PHIOC(JSEA), TMP1, D50, PSIC, TMP2, & - PHIBBL(JSEA), TMP3, TMP4, PHICE(JSEA), & - TAUOCX(JSEA), TAUOCY(JSEA), WNMEAN(JSEA), & - RHOAIR(ISEA), ASF(ISEA)) - IF (.not. LSLOC) THEN - VSTOT(:,JSEA) = VSioDummy - VDTOT(:,JSEA) = VDioDummy - ENDIF -#ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'After sum(VA)=', sum(VA(:,JSEA)) - WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,JSEA)) - WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,JSEA)) - WRITE(740+IAPROC,*) ' SHAVETOT=', SHAVETOT(JSEA) - FLUSH(740+IAPROC) -#endif + TAUA(ISEA), TAUADIR(ISEA), & +#endif + AS(ISEA), UST(ISEA), & + USTDIR(ISEA), CX(ISEA), CY(ISEA), & + ICE(ISEA), ICEH(ISEA), ICEF(ISEA), & + ICEDMAX(ISEA), & + REFLEC, REFLED, DELX, DELY, DELA, & + TRNX(IY,IX), TRNY(IY,IX), BERG(ISEA), & + FPIS(ISEA), DTDYN(JSEA), & + FCUT(JSEA), DTGpre, TAUWX(JSEA), TAUWY(JSEA), & + TAUOX(JSEA), TAUOY(JSEA), TAUWIX(JSEA), & + TAUWIY(JSEA), TAUWNX(JSEA), & + TAUWNY(JSEA), PHIAW(JSEA), CHARN(JSEA), & + TWS(JSEA), PHIOC(JSEA), TMP1, D50, PSIC, TMP2, & + PHIBBL(JSEA), TMP3, TMP4, PHICE(JSEA), & + TAUOCX(JSEA), TAUOCY(JSEA), WNMEAN(JSEA), & + RHOAIR(ISEA), ASF(ISEA)) + IF (.not. LSLOC) THEN + VSTOT(:,JSEA) = VSioDummy + VDTOT(:,JSEA) = VDioDummy + ENDIF + if (w3_debugsrc_flag) then + WRITE(740+IAPROC,*) 'After sum(VA)=', sum(VA(:,JSEA)) + WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,JSEA)) + WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,JSEA)) + WRITE(740+IAPROC,*) ' SHAVETOT=', SHAVETOT(JSEA) + end if #endif - ELSE - UST (ISEA) = UNDEF - USTDIR(ISEA) = UNDEF - DTDYN (JSEA) = UNDEF - FCUT (JSEA) = UNDEF - END IF - END DO ! JSEA - END IF ! PDLIB + ELSE + UST (ISEA) = UNDEF + USTDIR(ISEA) = UNDEF + DTDYN (JSEA) = UNDEF + FCUT (JSEA) = UNDEF + END IF + END DO ! JSEA + END IF ! PDLIB #endif - #ifdef W3_PDLIB -#ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA after W3SRCE_IMP_PRE") - CALL ALL_FIELD_INTEGRAL_PRINT(VSTOT, "VSTOT after W3SRCE_IMP_PRE") - CALL ALL_FIELD_INTEGRAL_PRINT(VDTOT, "VDTOT after W3SRCE_IMP_PRE") - IF (DEBUG_NODE .le. NSEAL) THEN - WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE - WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) - WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,DEBUG_NODE)) - WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,DEBUG_NODE)) - END IF -#endif -#endif - -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 14' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif - - IF ( FLZERO ) THEN -#ifdef W3_T - WRITE (NDST,9022) -#endif - GOTO 400 + if (w3_debugsrc_flag) then + WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA after W3SRCE_IMP_PRE") + CALL ALL_FIELD_INTEGRAL_PRINT(VSTOT, "VSTOT after W3SRCE_IMP_PRE") + CALL ALL_FIELD_INTEGRAL_PRINT(VDTOT, "VDTOT after W3SRCE_IMP_PRE") + IF (DEBUG_NODE .le. NSEAL) THEN + WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE + WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,DEBUG_NODE)) + END IF + end if +#endif + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE TIME LOOP 14') + ! + IF ( FLZERO ) THEN + if (w3_t_flag) then + WRITE (NDST,9022) + end if + GOTO 400 END IF - IF ( IT.EQ.0 ) THEN - DTG = 1. -! DTG = 60. - GOTO 370 - END IF -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.5' - WRITE(740+IAPROC,*) 'FLDRY=', FLDRY - FLUSH(740+IAPROC) -#endif - IF ( FLDRY .OR. IAPROC.GT.NAPROC ) THEN -#ifdef W3_T - WRITE (NDST,9023) -#endif -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'Jump to 380' - FLUSH(740+IAPROC) -#endif - GOTO 380 - END IF -! -! Estimation of the local maximum CFL for XY propagation -! -#ifdef W3_T - WRITE(NDSE,*) 'Computing CFLs .... ',NSEAL -#endif -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'FLOGRD(9,3) = ', FLOGRD(9,3) - WRITE(740+IAPROC,*) 'UGDTUPDATE=', UGDTUPDATE - FLUSH(740+IAPROC) -#endif - IF ( FLOGRD(9,3).AND. UGDTUPDATE ) THEN -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.6' - FLUSH(740+IAPROC) -#endif - IF (FSTOTALIMP .eqv. .FALSE.) THEN - NKCFL=NK -#ifdef W3_T - NKCFL=1 -#endif -! -#ifdef W3_OMPG -!$OMP PARALLEL DO PRIVATE (JSEA,ISEA) SCHEDULE (DYNAMIC,1) -#endif -! - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) + IF ( IT.EQ.0 ) THEN + DTG = 1. + ! DTG = 60. + GOTO 370 + END IF + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.5' + WRITE(740+IAPROC,*) 'FLDRY=', FLDRY + end if + IF ( FLDRY .OR. IAPROC.GT.NAPROC ) THEN + if (w3_t_flag) then + WRITE (NDST,9023) + end if + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'Jump to 380' + end if + GOTO 380 + END IF + ! + ! Estimation of the local maximum CFL for XY propagation + ! + if (w3_t_flag) then + WRITE(NDSE,*) 'Computing CFLs .... ',NSEAL + end if + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'FLOGRD(9,3) = ', FLOGRD(9,3) + WRITE(740+IAPROC,*) 'UGDTUPDATE=', UGDTUPDATE + end if + IF ( FLOGRD(9,3).AND. UGDTUPDATE ) THEN + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.6' + end if + IF (FSTOTALIMP .eqv. .FALSE.) THEN + NKCFL=NK + if (w3_t_flag) then + NKCFL=1 + end if + ! + !$OMP PARALLEL DO PRIVATE (JSEA,ISEA) SCHEDULE (DYNAMIC,1) + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) #ifdef W3_PR3 - IF (GTYPE .EQ. UNGTYPE) THEN + IF (GTYPE .EQ. UNGTYPE) THEN IF ( FLOGRD(9,3) ) THEN #endif -#ifdef W3_T - IF (MOD(ISEA,100).EQ.0) WRITE(NDSE,*) 'COMPUTING CFL FOR NODE:',ISEA -#endif + if (w3_t_flag) then + IF (MOD(ISEA,100).EQ.0) WRITE(NDSE,*) 'COMPUTING CFL FOR NODE:',ISEA + end if #ifdef W3_PDLIB - IF (.NOT. LPDLIB) THEN + IF (.NOT. LPDLIB) THEN #endif #ifdef W3_PR3 - CALL W3CFLUG ( ISEA, NKCFL, FACX, FACX, DTG, & - MAPFS, CFLXYMAX(JSEA), VGX, VGY ) + CALL W3CFLUG ( ISEA, NKCFL, FACX, FACX, DTG, MAPFS, CFLXYMAX(JSEA), VGX, VGY ) #endif #ifdef W3_PDLIB - ENDIF + ENDIF #endif #ifdef W3_PR3 END IF - ELSE - CALL W3CFLXY ( ISEA, DTG, MAPSTA, MAPFS, & - CFLXYMAX(JSEA), VGX, VGY ) - END IF -#endif - END DO -! -#ifdef W3_OMPG -!$OMP END PARALLEL DO -#endif -! - END IF - END IF -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.7' - FLUSH(740+IAPROC) -#endif - -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 15' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif -! -#ifdef W3_DEBUGRUN - DO JSEA = 1, NSEAL - DO IS = 1, NSPEC - IF (VA(IS, JSEA) .LT. 0.) THEN - WRITE(740+IAPROC,*) 'TEST W3WAVE 8', VA(IS,JSEA) - CALL FLUSH(740+IAPROC) - ENDIF - ENDDO - ENDDO - IF (SUM(VA) .NE. SUM(VA)) THEN - WRITE(740+IAPROC,*) 'NAN in ACTION 6 ', IX, IY, SUM(VA) - CALL FLUSH(740+IAPROC) - STOP - ENDIF -#endif - -! -#ifdef W3_T - IF (GTYPE .EQ. UNGTYPE) THEN - IF ( FLOGRD(9,3) ) THEN - DTCFL1(:)=1. - DO JSEA=1,NSEAL - INDSORT(JSEA)=FLOAT(JSEA) - DTCFL1(JSEA)=DTG/CFLXYMAX(JSEA) - END DO - CALL SSORT1 (DTCFL1, INDSORT, NSEAL, 2) - IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,*) 'Nodes requesting smallest timesteps:' - IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,'(A,10I10)') 'Nodes ',NINT(INDSORT(1:10)) - IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,'(A,10F10.2)') 'time steps ',DTCFL1(1:10) - DO JSEA = 1, MIN(NSEAL,200) - ISEA = NINT(INDSORT(JSEA)) ! will not work with MPI - IX = MAPSF(ISEA,1) - IF (JSEA.EQ.1) & - WRITE(995,*) ' IP dtmax_exp(ip) x-coord y-coord z-coord' - WRITE(995,'(I10,F10.2,3F10.4)') IX, DTCFL1(JSEA), XGRD(1,IX), YGRD(2,IX), ZB(IX) - END DO ! JSEA - CLOSE(995) - END IF - END IF + ELSE + CALL W3CFLXY ( ISEA, DTG, MAPSTA, MAPFS, CFLXYMAX(JSEA), VGX, VGY ) + END IF #endif - -! -! 3.6 Perform Propagation = = = = = = = = = = = = = = = = = = = = = = = -! 3.6.1 Preparations -! + END DO + ! + !$OMP END PARALLEL DO + END IF + END IF + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.8.7' + end if + ! + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE TIME LOOP 15') + ! + if (w3_debugrun_flag) then + DO JSEA = 1, NSEAL + DO IS = 1, NSPEC + IF (VA(IS, JSEA) .LT. 0.) THEN + WRITE(740+IAPROC,*) 'TEST W3WAVE 8', VA(IS,JSEA) + ENDIF + ENDDO + ENDDO + IF (SUM(VA) .NE. SUM(VA)) THEN + WRITE(740+IAPROC,*) 'NAN in ACTION 6 ', IX, IY, SUM(VA) + STOP + ENDIF + end if + ! + if (w3_t_flag) then + IF (GTYPE .EQ. UNGTYPE) THEN + IF ( FLOGRD(9,3) ) THEN + DTCFL1(:)=1. + DO JSEA=1,NSEAL + INDSORT(JSEA)=FLOAT(JSEA) + DTCFL1(JSEA)=DTG/CFLXYMAX(JSEA) + END DO + CALL SSORT1 (DTCFL1, INDSORT, NSEAL, 2) + IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,*) 'Nodes requesting smallest timesteps:' + IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,'(A,10I10)') 'Nodes ',NINT(INDSORT(1:10)) + IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,'(A,10F10.2)') 'time steps ',DTCFL1(1:10) + DO JSEA = 1, MIN(NSEAL,200) + ISEA = NINT(INDSORT(JSEA)) ! will not work with MPI + IX = MAPSF(ISEA,1) + IF (JSEA.EQ.1) then + WRITE(995,*) ' IP dtmax_exp(ip) x-coord y-coord z-coord' + end IF + WRITE(995,'(I10,F10.2,3F10.4)') IX, DTCFL1(JSEA), XGRD(1,IX), YGRD(2,IX), ZB(IX) + END DO ! JSEA + CLOSE(995) + END IF + END IF + end if + ! + ! 3.6 Perform Propagation = = = = = = = = = = = = = = = = = = = = = = = + ! 3.6.1 Preparations + ! #ifdef W3_SEC1 - DTGTEMP=DTG - DTG=DTG/NITERSEC1 - DO ISEC1=1,NITERSEC1 + DTGTEMP=DTG + DTG=DTG/NITERSEC1 + DO ISEC1=1,NITERSEC1 #endif - NTLOC = 1 + INT( DTG/DTCFLI - 0.001 ) + NTLOC = 1 + INT( DTG/DTCFLI - 0.001 ) #ifdef W3_SEC1 - IF ( IAPROC .EQ. NAPOUT ) WRITE(NDSE,'(A,I4,A,I4)') ' SUBSECOND STEP:',ISEC1,' out of ',NITERSEC1 -#endif -! - FACTH = DTG / (DTH*REAL(NTLOC)) -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, DTCFLI=', DTCFLI - WRITE(740+IAPROC,*) 'W3WAVE, DTG=', DTG - WRITE(740+IAPROC,*) 'W3WAVE, DTH=', DTH - WRITE(740+IAPROC,*) 'W3WAVE, NTLOC=', NTLOC - FLUSH(740+IAPROC) -#endif - FACK = DTG / REAL(NTLOC) - - TTEST(1) = TIME(1) - TTEST(2) = 0 - DTTEST = DSEC21(TTEST,TIME) - ITLOCH = ( NTLOC + 1 - MOD(NINT(DTTEST/DTG),2) ) / 2 -! -! 3.6.2 Intra-spectral part 1 -! + IF ( IAPROC .EQ. NAPOUT ) WRITE(NDSE,'(A,I4,A,I4)') ' SUBSECOND STEP:',ISEC1,' out of ',NITERSEC1 +#endif + ! + FACTH = DTG / (DTH*REAL(NTLOC)) + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, DTCFLI=', DTCFLI + WRITE(740+IAPROC,*) 'W3WAVE, DTG=', DTG + WRITE(740+IAPROC,*) 'W3WAVE, DTH=', DTH + WRITE(740+IAPROC,*) 'W3WAVE, NTLOC=', NTLOC + end if + FACK = DTG / REAL(NTLOC) + + TTEST(1) = TIME(1) + TTEST(2) = 0 + DTTEST = DSEC21(TTEST,TIME) + ITLOCH = ( NTLOC + 1 - MOD(NINT(DTTEST/DTG),2) ) / 2 + ! + ! 3.6.2 Intra-spectral part 1 + ! #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before intraspectral part 1") -#endif -#endif -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Before intraspectral") -#endif -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.10' - WRITE(740+IAPROC,*) 'FLCTH=', FLCTH, ' FLCK=', FLCK - FLUSH(740+IAPROC) -#endif - IF ( FLCTH .OR. FLCK ) THEN - DO ITLOC=1, ITLOCH -! -#ifdef W3_OMPG -!$OMP PARALLEL PRIVATE (JSEA,ISEA,IX,IY,DEPTH,IXrel) -!$OMP DO SCHEDULE (DYNAMIC,1) -#endif -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) ' ITLOC=', ITLOC - WRITE(740+IAPROC,*) ' 1: Before call to W3KTP1 / W3KTP2 / W3KTP3' -#endif - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - -#ifdef W3_DEBUGRUN - IF (JSEA == DEBUG_NODE) WRITE(*,*) 'W3WAVE TEST', SUM(VA(:,JSEA)) -#endif + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before intraspectral part 1") + end if +#endif + if (w3_timings_flag) then + CALL PRINT_MY_TIME("Before intraspectral") + end if + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.10' + WRITE(740+IAPROC,*) 'FLCTH=', FLCTH, ' FLCK=', FLCK + end if + IF ( FLCTH .OR. FLCK ) THEN + DO ITLOC=1, ITLOCH + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) ' ITLOC=', ITLOC + WRITE(740+IAPROC,*) ' 1: Before call to W3KTP1 / W3KTP2 / W3KTP3' + end if + ! + !$OMP PARALLEL PRIVATE (JSEA,ISEA,IX,IY,DEPTH,IXrel) + !$OMP DO SCHEDULE (DYNAMIC,1) + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + if (w3_debugrun_flag) then + IF (JSEA == DEBUG_NODE) WRITE(*,*) 'W3WAVE TEST', SUM(VA(:,JSEA)) + end if - IF ( GTYPE .EQ. UNGTYPE ) THEN - IF (LPDLIB) THEN + IF ( GTYPE .EQ. UNGTYPE ) THEN + IF (LPDLIB) THEN #ifdef W3_PDLIB - IF (IOBP_LOC(JSEA) .NE. 1) CYCLE + IF (IOBP_LOC(JSEA) .NE. 1) CYCLE #endif - ELSE - IF (IOBP(ISEA) .NE. 1) CYCLE - ENDIF - ENDIF + ELSE + IF (IOBP(ISEA) .NE. 1) CYCLE + ENDIF + ENDIF - IF ( MAPSTA(IY,IX) .EQ. 1 ) THEN + IF ( MAPSTA(IY,IX) .EQ. 1 ) THEN DEPTH = MAX ( DMIN , DW(ISEA) ) IF (LPDLIB) THEN - IXrel = JSEA + IXrel = JSEA ELSE - IXrel = IX + IXrel = IX END IF -! - IF( GTYPE .EQ. SMCTYPE ) THEN - J = 1 + ! + IF( GTYPE .EQ. SMCTYPE ) THEN + J = 1 #ifdef W3_SMC - !!Li Refraction and GCT in theta direction is done by rotation. - CALL W3KRTN ( ISEA, FACTH, FACK, CTHG0S(ISEA), & - CG(:,ISEA), WN(:,ISEA), DEPTH, & - DHDX(ISEA), DHDY(ISEA), DHLMT(:,ISEA), & - CX(ISEA), CY(ISEA), DCXDX(IY,IX), & - DCXDY(IY,IX), DCYDX(IY,IX), DCYDY(IY,IX), & - DCDX(:,IY,IX), DCDY(:,IY,IX), VA(:,JSEA) ) -#endif -! - ELSE - J = 1 -! + !!Li Refraction and GCT in theta direction is done by rotation. + CALL W3KRTN ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DHDX(ISEA), DHDY(ISEA), DHLMT(:,ISEA), & + CX(ISEA), CY(ISEA), DCXDX(IY,IX), & + DCXDY(IY,IX), DCYDX(IY,IX), DCYDY(IY,IX), & + DCDX(:,IY,IX), DCDY(:,IY,IX), VA(:,JSEA) ) +#endif + ! + ELSE + J = 1 + ! #ifdef W3_PR1 - CALL W3KTP1 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & - CG(:,ISEA), WN(:,ISEA), DEPTH, & - DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & - CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & - DCYDX(IY,IXrel), DCYDY(IY,IXrel), & - DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) + CALL W3KTP1 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & + CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & + DCYDX(IY,IXrel), DCYDY(IY,IXrel), & + DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) #endif #ifdef W3_PR2 - CALL W3KTP2 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & - CG(:,ISEA), WN(:,ISEA), DEPTH, & - DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & - CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & - DCYDX(IY,IXrel), DCYDY(IY,IXrel), & - DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) + CALL W3KTP2 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & + CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & + DCYDX(IY,IXrel), DCYDY(IY,IXrel), & + DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) #endif #ifdef W3_PR3 - CALL W3KTP3 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & - CG(:,ISEA), WN(:,ISEA), DEPTH, & - DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & - CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & - DCYDX(IY,IXrel), DCYDY(IY,IXrel), & - DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA), & - CFLTHMAX(JSEA), CFLKMAX(JSEA) ) -#endif -! - END IF !! GTYPE -! - END IF + CALL W3KTP3 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & + CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & + DCYDX(IY,IXrel), DCYDY(IY,IXrel), & + DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA), & + CFLTHMAX(JSEA), CFLKMAX(JSEA) ) +#endif + ! + END IF !! GTYPE + ! + END IF + END DO + ! + !$OMP END DO + !$OMP END PARALLEL END DO -! -#ifdef W3_OMPG -!$OMP END DO -!$OMP END PARALLEL -#endif -! - END DO - END IF - -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 16' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif - + END IF + ! + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE TIME LOOP 16') + ! #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before spatial advection") -#endif -#endif -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Before spatial advection") -#endif -! -! 3.6.3 Longitude-latitude -! (time step correction in routine) -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.12' - WRITE(740+IAPROC,*) 'FSN=', FSN - WRITE(740+IAPROC,*) 'FSPSI=', FSPSI - WRITE(740+IAPROC,*) 'FSFCT=', FSFCT - WRITE(740+IAPROC,*) 'FSNIMP=', FSNIMP - WRITE(740+IAPROC,*) 'FLCTH=', FLCTH - WRITE(740+IAPROC,*) 'FSREFRACTION=', FSREFRACTION - WRITE(740+IAPROC,*) 'FLCK=', FLCK - WRITE(740+IAPROC,*) 'FSFREQSHIFT=', FSFREQSHIFT - WRITE(740+IAPROC,*) 'FLSOU=', FLSOU - WRITE(740+IAPROC,*) 'FSSOURCE=', FSSOURCE - WRITE(740+IAPROC,*) 'FSTOTALIMP=', FSTOTALIMP - WRITE(740+IAPROC,*) 'FSTOTALEXP=', FSTOTALEXP - WRITE(740+IAPROC,*) 'FLCUR=', FLCUR - WRITE(740+IAPROC,*) 'PDLIB=', LPDLIB - WRITE(740+IAPROC,*) 'GTYPE=', GTYPE - WRITE(740+IAPROC,*) 'UNGTYPE=', UNGTYPE - WRITE(740+IAPROC,*) 'NAPROC=', NAPROC, 'NTPROC=', NTPROC - WRITE(740+IAPROC,*) 'FLCX=', FLCX, ' FLCY=', FLCY - FLUSH(740+IAPROC) -#endif -! - IF (GTYPE .EQ. UNGTYPE) THEN - IF (FLAGLL) THEN - FACX = 1./(DERA * RADIUS) - ELSE - FACX = 1. - END IF - END IF - IF ((GTYPE .EQ. UNGTYPE) .and. LPDLIB) THEN -! + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "Before spatial advection") + end if +#endif + if (w3_timings_flag) then + CALL PRINT_MY_TIME("Before spatial advection") + end if + ! + ! 3.6.3 Longitude-latitude + ! (time step correction in routine) + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.12' + WRITE(740+IAPROC,*) 'FSN=', FSN + WRITE(740+IAPROC,*) 'FSPSI=', FSPSI + WRITE(740+IAPROC,*) 'FSFCT=', FSFCT + WRITE(740+IAPROC,*) 'FSNIMP=', FSNIMP + WRITE(740+IAPROC,*) 'FLCTH=', FLCTH + WRITE(740+IAPROC,*) 'FSREFRACTION=', FSREFRACTION + WRITE(740+IAPROC,*) 'FLCK=', FLCK + WRITE(740+IAPROC,*) 'FSFREQSHIFT=', FSFREQSHIFT + WRITE(740+IAPROC,*) 'FLSOU=', FLSOU + WRITE(740+IAPROC,*) 'FSSOURCE=', FSSOURCE + WRITE(740+IAPROC,*) 'FSTOTALIMP=', FSTOTALIMP + WRITE(740+IAPROC,*) 'FSTOTALEXP=', FSTOTALEXP + WRITE(740+IAPROC,*) 'FLCUR=', FLCUR + WRITE(740+IAPROC,*) 'PDLIB=', LPDLIB + WRITE(740+IAPROC,*) 'GTYPE=', GTYPE + WRITE(740+IAPROC,*) 'UNGTYPE=', UNGTYPE + WRITE(740+IAPROC,*) 'NAPROC=', NAPROC, 'NTPROC=', NTPROC + WRITE(740+IAPROC,*) 'FLCX=', FLCX, ' FLCY=', FLCY + end if + ! + IF (GTYPE .EQ. UNGTYPE) THEN + IF (FLAGLL) THEN + FACX = 1./(DERA * RADIUS) + ELSE + FACX = 1. + END IF + END IF + ! TODO: Clean up serial W3_PDLIB + IF ((GTYPE .EQ. UNGTYPE) .and. LPDLIB) THEN + ! #ifdef W3_PDLIB - IF ((FSTOTALIMP .eqv. .FALSE.).and.(FLCX .or. FLCY)) THEN -#endif -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.1' - FLUSH(740+IAPROC) + IF ((FSTOTALIMP .eqv. .FALSE.).and.(FLCX .or. FLCY)) THEN #endif + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.1' + end if #ifdef W3_PDLIB - DO ISPEC=1,NSPEC - CALL PDLIB_W3XYPUG ( ISPEC, FACX, FACX, DTG, & - VGX, VGY, UGDTUPDATE ) - END DO -#endif -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.2' - FLUSH(740+IAPROC) + DO ISPEC=1,NSPEC + CALL PDLIB_W3XYPUG ( ISPEC, FACX, FACX, DTG, VGX, VGY, UGDTUPDATE ) + END DO #endif + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.2' + end if #ifdef W3_PDLIB - END IF + END IF #endif -! + ! #ifdef W3_PDLIB - IF (FSTOTALIMP .and. (IT .ne. 0)) THEN -#endif -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.3A' - WRITE(*,*), 'W3WAVE, step 6.12.3A' - FLUSH(740+IAPROC) + IF (FSTOTALIMP .and. (IT .ne. 0)) THEN #endif + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.3A' + end if #ifdef W3_PDLIB - CALL PDLIB_W3XYPUG_BLOCK_IMPLICIT (FACX, FACX, DTG, VGX, VGY) -#endif -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.4A' - WRITE(*,*), 'W3WAVE, step 6.12.4A' - FLUSH(740+IAPROC) + CALL PDLIB_W3XYPUG_BLOCK_IMPLICIT (FACX, FACX, DTG, VGX, VGY) #endif + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.4A' + end if #ifdef W3_PDLIB - ELSE IF(FSTOTALEXP .and. (IT .ne. 0)) THEN -#endif -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.3B' - WRITE(*,*), 'W3WAVE, step 6.12.3B' - FLUSH(740+IAPROC) + ELSE IF(FSTOTALEXP .and. (IT .ne. 0)) THEN #endif + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.3B' + end if #ifdef W3_PDLIB - CALL PDLIB_W3XYPUG_BLOCK_EXPLICIT(FACX, FACX, DTG, VGX, VGY) -#endif -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.4B' - WRITE(*,*), 'W3WAVE, step 6.12.4B' - FLUSH(740+IAPROC) + CALL PDLIB_W3XYPUG_BLOCK_EXPLICIT(FACX, FACX, DTG, VGX, VGY) #endif + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.12.4B' + end if #ifdef W3_PDLIB - ENDIF -#endif - ELSE - IF (FLCX .or. FLCY) THEN -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.13' - FLUSH(740+IAPROC) + ENDIF #endif -! -#ifdef W3_MPI - IF ( NRQSG1 .GT. 0 ) THEN - CALL MPI_STARTALL (NRQSG1, IRQSG1(1,1), IERR_MPI) - CALL MPI_STARTALL (NRQSG1, IRQSG1(1,2), IERR_MPI) - END IF -#endif -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.14' - FLUSH(740+IAPROC) -#endif -! -! Initialize FIELD variable - FIELD = 0. -! - DO ISPEC=1, NSPEC - IF ( IAPPRO(ISPEC) .EQ. IAPROC ) THEN -! - IF( GTYPE .EQ. SMCTYPE ) THEN - IX = 1 + ELSE + IF (FLCX .or. FLCY) THEN + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.13' + end if + ! +#ifdef W3_MPI + IF ( NRQSG1 .GT. 0 ) THEN + CALL MPI_STARTALL (NRQSG1, IRQSG1(1,1), IERR_MPI) + CALL MPI_STARTALL (NRQSG1, IRQSG1(1,2), IERR_MPI) + END IF +#endif + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.14' + end if + ! + ! Initialize FIELD variable + FIELD = 0. + ! + DO ISPEC=1, NSPEC + IF ( IAPPRO(ISPEC) .EQ. IAPROC ) THEN + ! + IF( GTYPE .EQ. SMCTYPE ) THEN + IX = 1 #ifdef W3_SMC - !!Li Use SMC sub to gether field - CALL W3GATHSMC ( ISPEC, FIELD ) -#endif - ELSE IF (.NOT.LPDLIB ) THEN - CALL W3GATH ( ISPEC, FIELD ) - END IF !! GTYPE -! - IF (GTYPE .EQ. SMCTYPE) THEN - IX = 1 + !!Li Use SMC sub to gether field + CALL W3GATHSMC ( ISPEC, FIELD ) +#endif + ELSE IF (.NOT.LPDLIB ) THEN + CALL W3GATH ( ISPEC, FIELD ) + END IF !! GTYPE + ! + IF (GTYPE .EQ. SMCTYPE) THEN + IX = 1 #ifdef W3_SMC - !!Li Propagation on SMC grid uses UNO2 scheme. - CALL W3PSMC ( ISPEC, DTG, FIELD ) + !!Li Propagation on SMC grid uses UNO2 scheme. + CALL W3PSMC ( ISPEC, DTG, FIELD ) #endif -! - ELSE IF (GTYPE .EQ. UNGTYPE) THEN - IX = 1 + ! + ELSE IF (GTYPE .EQ. UNGTYPE) THEN + IX = 1 #ifdef W3_MPI - IF (.NOT. LPDLIB) THEN + IF (.NOT. LPDLIB) THEN #endif #ifdef W3_PR1 - CALL W3XYPUG ( ISPEC, FACX, FACX, DTG, & - FIELD, VGX, VGY, UGDTUPDATE ) + CALL W3XYPUG ( ISPEC, FACX, FACX, DTG, FIELD, VGX, VGY, UGDTUPDATE ) #endif #ifdef W3_PR2 - CALL W3XYPUG ( ISPEC, FACX, FACX, DTG, & - FIELD, VGX, VGY, UGDTUPDATE ) + CALL W3XYPUG ( ISPEC, FACX, FACX, DTG, FIELD, VGX, VGY, UGDTUPDATE ) #endif #ifdef W3_PR3 - CALL W3XYPUG ( ISPEC, FACX, FACX, DTG, & - FIELD, VGX, VGY, UGDTUPDATE ) + CALL W3XYPUG ( ISPEC, FACX, FACX, DTG, FIELD, VGX, VGY, UGDTUPDATE ) #endif #ifdef W3_MPI - END IF + END IF #endif -! - ELSE - IX = 1 + ! + ELSE + IX = 1 #ifdef W3_PR1 - CALL W3XYP1 ( ISPEC, DTG, MAPSTA, FIELD, VGX, VGY ) + CALL W3XYP1 ( ISPEC, DTG, MAPSTA, FIELD, VGX, VGY ) #endif #ifdef W3_PR2 - CALL W3XYP2 ( ISPEC, DTG, MAPSTA, MAPFS, FIELD, VGX, VGY ) + CALL W3XYP2 ( ISPEC, DTG, MAPSTA, MAPFS, FIELD, VGX, VGY ) #endif #ifdef W3_PR3 - CALL W3XYP3 ( ISPEC, DTG, MAPSTA, MAPFS, FIELD, VGX, VGY ) + CALL W3XYP3 ( ISPEC, DTG, MAPSTA, MAPFS, FIELD, VGX, VGY ) #endif -! - END IF !! GTYPE -! - IF( GTYPE .EQ. SMCTYPE ) THEN - IX = 1 + ! + END IF !! GTYPE + ! + IF( GTYPE .EQ. SMCTYPE ) THEN + IX = 1 #ifdef W3_SMC - !!Li Use SMC sub to scatter field - CALL W3SCATSMC ( ISPEC, MAPSTA, FIELD ) -#endif - ELSE IF (.NOT.LPDLIB ) THEN - CALL W3SCAT ( ISPEC, MAPSTA, FIELD ) - END IF !! GTYPE - - END IF - END DO -! -#ifdef W3_MPI - IF ( NRQSG1 .GT. 0 ) THEN - ALLOCATE ( STATCO(MPI_STATUS_SIZE,NRQSG1) ) - CALL MPI_WAITALL (NRQSG1, IRQSG1(1,1), STATCO, & - IERR_MPI) - CALL MPI_WAITALL (NRQSG1, IRQSG1(1,2), STATCO, & - IERR_MPI) - DEALLOCATE ( STATCO ) - END IF + !!Li Use SMC sub to scatter field + CALL W3SCATSMC ( ISPEC, MAPSTA, FIELD ) #endif + ELSE IF (.NOT.LPDLIB ) THEN + CALL W3SCAT ( ISPEC, MAPSTA, FIELD ) + END IF !! GTYPE -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE TIME LOOP 17' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif -! -!Li Initialise IK IX IY in case ARC option is not used to avoid warnings. - IK=1 - IX=1 - IY=1 + END IF + END DO + ! +#ifdef W3_MPI + IF ( NRQSG1 .GT. 0 ) THEN + ALLOCATE ( STATCO(MPI_STATUS_SIZE,NRQSG1) ) + CALL MPI_WAITALL (NRQSG1, IRQSG1(1,1), STATCO, IERR_MPI) + CALL MPI_WAITALL (NRQSG1, IRQSG1(1,2), STATCO, IERR_MPI) + DEALLOCATE ( STATCO ) + END IF +#endif + ! + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE TIME LOOP 17') + ! + !Li Initialise IK IX IY in case ARC option is not used to avoid warnings. + IK=1 + IX=1 + IY=1 #ifdef W3_SMC - !Li Find source boundary spectra and assign to SPCBAC - IF( ARCTC ) THEN + !Li Find source boundary spectra and assign to SPCBAC + IF( ARCTC ) THEN - DO IK = 1, NBAC - IF( IK .LE. (NBAC-NBGL) ) THEN - IY = ICLBAC(IK) - ELSE - IY = NGLO + IK - ENDIF + DO IK = 1, NBAC + IF( IK .LE. (NBAC-NBGL) ) THEN + IY = ICLBAC(IK) + ELSE + IY = NGLO + IK + ENDIF - !Li Work out root PE (ISPEC) and JSEA numbers for IY + !Li Work out root PE (ISPEC) and JSEA numbers for IY #ifdef W3_DIST - ISPEC = MOD( IY-1, NAPROC ) - JSEA = 1 + (IY - ISPEC - 1)/NAPROC + ISPEC = MOD( IY-1, NAPROC ) + JSEA = 1 + (IY - ISPEC - 1)/NAPROC #endif #ifdef W3_SHRD - ISPEC = 0 - JSEA = IY + ISPEC = 0 + JSEA = IY +#endif #endif -#endif -! W3_SMC ... -! + ! W3_SMC ... + ! #ifdef W3_SMC - !!Li Assign boundary cell spectra. - IF( IAPROC .EQ. ISPEC+1 ) THEN - SPCBAC(:,IK)=VA(:,JSEA) - ENDIF + !!Li Assign boundary cell spectra. + IF( IAPROC .EQ. ISPEC+1 ) THEN + SPCBAC(:,IK)=VA(:,JSEA) + ENDIF #endif -! + ! #ifdef W3_SMC - !!Li Broadcast local SPCBAC(:,IK) to all other PEs. + !!Li Broadcast local SPCBAC(:,IK) to all other PEs. #ifdef W3_MPI - CALL MPI_BCAST(SPCBAC(1,IK),NSPEC,MPI_REAL,ISPEC,MPI_COMM_WAVE,IERR_MPI) - CALL MPI_BARRIER (MPI_COMM_WAVE,IERR_MPI) + CALL MPI_BCAST(SPCBAC(1,IK),NSPEC,MPI_REAL,ISPEC,MPI_COMM_WAVE,IERR_MPI) + CALL MPI_BARRIER (MPI_COMM_WAVE,IERR_MPI) #endif #endif -! + ! #ifdef W3_SMC - END DO !! Loop IK ends. + END DO !! Loop IK ends. #endif -! + ! #ifdef W3_SMC - !!Li Update Arctic boundary cell spectra if within local range - ALLOCATE ( BACSPEC(NSPEC) ) - DO IK = 1, NBAC - IF( IK .LE. (NBAC-NBGL) ) THEN - IX = NGLO + IK - BACANGL = ANGARC(IK) - ELSE - IX = ICLBAC(IK) - BACANGL = - ANGARC(IK) - ENDIF + !!Li Update Arctic boundary cell spectra if within local range + ALLOCATE ( BACSPEC(NSPEC) ) + DO IK = 1, NBAC + IF( IK .LE. (NBAC-NBGL) ) THEN + IX = NGLO + IK + BACANGL = ANGARC(IK) + ELSE + IX = ICLBAC(IK) + BACANGL = - ANGARC(IK) + ENDIF - !!Li Work out boundary PE (ISPEC) and JSEA numbers for IX + !!Li Work out boundary PE (ISPEC) and JSEA numbers for IX #ifdef W3_DIST - ISPEC = MOD( IX-1, NAPROC ) - JSEA = 1 + (IX - ISPEC - 1)/NAPROC + ISPEC = MOD( IX-1, NAPROC ) + JSEA = 1 + (IX - ISPEC - 1)/NAPROC #endif #ifdef W3_SHRD - ISPEC = 0 - JSEA = IX + ISPEC = 0 + JSEA = IX #endif #endif -! + ! #ifdef W3_SMC - IF( IAPROC .EQ. ISPEC+1 ) THEN - BACSPEC = SPCBAC(:,IK) + IF( IAPROC .EQ. ISPEC+1 ) THEN + BACSPEC = SPCBAC(:,IK) - CALL w3acturn( NTH, NK, BACANGL, BACSPEC ) + CALL w3acturn( NTH, NK, BACANGL, BACSPEC ) - VA(:,JSEA) = BACSPEC - !!Li WRITE(NDSE,*) "IAPROC, IX, JSEAx, IK=", IAPROC, IX, JSEA, IK - ENDIF + VA(:,JSEA) = BACSPEC + !!Li WRITE(NDSE,*) "IAPROC, IX, JSEAx, IK=", IAPROC, IX, JSEA, IK + ENDIF - END DO !! Loop IK ends. - DEALLOCATE ( BACSPEC ) + END DO !! Loop IK ends. + DEALLOCATE ( BACSPEC ) - ENDIF !! ARCTC + ENDIF !! ARCTC #endif -! -! End of test FLCX.OR.FLCY - END IF -! - END IF + ! + ! End of test FLCX.OR.FLCY + END IF + ! + END IF #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After spatial advection") -#endif -#endif -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After spatial advection") -#endif -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.16' - WRITE(740+IAPROC,*) 'NTLOC=', NTLOC - WRITE(740+IAPROC,*) 'ITLOCH=', ITLOCH - FLUSH(740+IAPROC) -#endif -! -! 3.6.4 Intra-spectral part 2 -! - IF ( FLCTH .OR. FLCK ) THEN - DO ITLOC=ITLOCH+1, NTLOC -! -#ifdef W3_OMPG -!$OMP PARALLEL PRIVATE (JSEA,ISEA,IX,IY,DEPTH,IXrel) -!$OMP DO SCHEDULE (DYNAMIC,1) -#endif -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) ' ITLOC=', ITLOC - WRITE(740+IAPROC,*) ' 2: Before call to W3KTP1 / W3KTP2 / W3KTP3' -#endif - DO JSEA = 1, NSEAL - - CALL INIT_GET_ISEA(ISEA, JSEA) - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) -#ifdef W3_DEBUGRUN - IF (JSEA == DEBUG_NODE) WRITE(*,*) 'W3WAVE TEST', SUM(VA(:,JSEA)) -#endif - DEPTH = MAX ( DMIN , DW(ISEA) ) + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After spatial advection") + end if +#endif + if (w3_timings_flag) then + CALL PRINT_MY_TIME("After spatial advection") + end if + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.16' + WRITE(740+IAPROC,*) 'NTLOC=', NTLOC + WRITE(740+IAPROC,*) 'ITLOCH=', ITLOCH + end if + ! + ! 3.6.4 Intra-spectral part 2 + ! + IF ( FLCTH .OR. FLCK ) THEN + DO ITLOC=ITLOCH+1, NTLOC + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) ' ITLOC=', ITLOC + WRITE(740+IAPROC,*) ' 2: Before call to W3KTP1 / W3KTP2 / W3KTP3' + end if + ! + !$OMP PARALLEL PRIVATE (JSEA,ISEA,IX,IY,DEPTH,IXrel) + !$OMP DO SCHEDULE (DYNAMIC,1) + DO JSEA = 1, NSEAL - IF ( GTYPE .EQ. UNGTYPE ) THEN - IF (LPDLIB) THEN + CALL INIT_GET_ISEA(ISEA, JSEA) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + if (w3_debugrun_flag) then + IF (JSEA == DEBUG_NODE) WRITE(*,*) 'W3WAVE TEST', SUM(VA(:,JSEA)) + end if + DEPTH = MAX ( DMIN , DW(ISEA) ) + + IF ( GTYPE .EQ. UNGTYPE ) THEN + IF (LPDLIB) THEN #ifdef W3_PDLIB - IF (IOBP_LOC(JSEA) .NE. 1) CYCLE + IF (IOBP_LOC(JSEA) .NE. 1) CYCLE #endif - ELSE - IF (IOBP(ISEA) .NE. 1) CYCLE - ENDIF - ENDIF + ELSE + IF (IOBP(ISEA) .NE. 1) CYCLE + ENDIF + ENDIF - IF ( MAPSTA(IY,IX) .EQ. 1 ) THEN + IF ( MAPSTA(IY,IX) .EQ. 1 ) THEN IF (LPDLIB) THEN - IXrel = JSEA + IXrel = JSEA ELSE - IXrel = IX + IXrel = IX END IF -! - IF( GTYPE .EQ. SMCTYPE ) THEN - J = 1 + ! + IF( GTYPE .EQ. SMCTYPE ) THEN + J = 1 #ifdef W3_SMC - !!Li Refraction and GCT in theta direction is done by rotation. - CALL W3KRTN ( ISEA, FACTH, FACK, CTHG0S(ISEA), & - CG(:,ISEA), WN(:,ISEA), DEPTH, & - DHDX(ISEA), DHDY(ISEA), DHLMT(:,ISEA), & - CX(ISEA), CY(ISEA), DCXDX(IY,IX), & - DCXDY(IY,IX), DCYDX(IY,IX), DCYDY(IY,IX), & - DCDX(:,IY,IX), DCDY(:,IY,IX), VA(:,JSEA) ) -#endif -! - ELSE - J = 1 + !!Li Refraction and GCT in theta direction is done by rotation. + CALL W3KRTN ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DHDX(ISEA), DHDY(ISEA), DHLMT(:,ISEA), & + CX(ISEA), CY(ISEA), DCXDX(IY,IX), & + DCXDY(IY,IX), DCYDX(IY,IX), DCYDY(IY,IX), & + DCDX(:,IY,IX), DCDY(:,IY,IX), VA(:,JSEA) ) +#endif + ! + ELSE + J = 1 #ifdef W3_PR1 - CALL W3KTP1 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & - CG(:,ISEA), WN(:,ISEA), DEPTH, & - DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & - CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & - DCYDX(IY,IXrel), DCYDY(IY,IXrel), & - DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) + CALL W3KTP1 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & + CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & + DCYDX(IY,IXrel), DCYDY(IY,IXrel), & + DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) #endif #ifdef W3_PR2 - CALL W3KTP2 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & - CG(:,ISEA), WN(:,ISEA), DEPTH, & - DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & - CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & - DCYDX(IY,IXrel), DCYDY(IY,IXrel), & - DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) + CALL W3KTP2 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & + CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & + DCYDX(IY,IXrel), DCYDY(IY,IXrel), & + DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA)) #endif #ifdef W3_PR3 - CALL W3KTP3 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & - CG(:,ISEA), WN(:,ISEA), DEPTH, & - DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & - CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & - DCYDX(IY,IXrel), DCYDY(IY,IXrel), & - DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA), & - CFLTHMAX(JSEA), CFLKMAX(JSEA) ) -#endif -! - END IF !! GTYPE -! - END IF + CALL W3KTP3 ( ISEA, FACTH, FACK, CTHG0S(ISEA), & + CG(:,ISEA), WN(:,ISEA), DEPTH, & + DDDX(IY,IXrel), DDDY(IY,IXrel), CX(ISEA), & + CY(ISEA), DCXDX(IY,IXrel), DCXDY(IY,IXrel), & + DCYDX(IY,IXrel), DCYDY(IY,IXrel), & + DCDX(:,IY,IXrel), DCDY(:,IY,IXrel), VA(:,JSEA), & + CFLTHMAX(JSEA), CFLKMAX(JSEA) ) +#endif + ! + END IF !! GTYPE + ! + END IF + END DO + ! + !$OMP END DO + !$OMP END PARALLEL END DO -! -#ifdef W3_OMPG -!$OMP END DO -!$OMP END PARALLEL -#endif -! - END DO - END IF + END IF #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After intraspectral adv.") -#endif -#endif -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("fter intraspectral adv.") -#endif -! - UGDTUPDATE = .FALSE. -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.17' - WRITE(740+IAPROC,*) 'FSSOURCE=', FSSOURCE - FLUSH(740+IAPROC) -#endif -! -! 3.6 End propapgation = = = = = = = = = = = = = = = = = = = = = = = = - -! 3.7 Calculate and integrate source terms. -! - 370 CONTINUE - IF ( FLSOU ) THEN -! - D50=0.0002 - REFLEC(:)=0. - REFLED(:)=0 - PSIC=0. + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After intraspectral adv.") + end if +#endif + if (w3_timings_flag) then + CALL PRINT_MY_TIME("fter intraspectral adv.") + end if + ! + UGDTUPDATE = .FALSE. + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.17' + WRITE(740+IAPROC,*) 'FSSOURCE=', FSSOURCE + end if + ! + ! 3.6 End propapgation = = = = = = = = = = = = = = = = = = = = = = = = + + ! 3.7 Calculate and integrate source terms. + ! +370 CONTINUE + IF ( FLSOU ) THEN + ! + D50=0.0002 + REFLEC(:)=0. + REFLED(:)=0 + PSIC=0. #ifdef W3_PDLIB -#ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT - CALL ALL_VAOLD_INTEGRAL_PRINT("VAOLD before W3SRCE_IMP_POST") - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA before W3SRCE_IMP_POST") - IF (DEBUG_NODE .le. NSEAL) THEN - WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE - WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) - WRITE(740+IAPROC,*) ' sum(VAOLD)=', sum(VAOLD(:,DEBUG_NODE)) - WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,DEBUG_NODE)) - WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,DEBUG_NODE)) - END IF -#endif -#endif -! -#ifdef W3_OMPG -!$OMP PARALLEL PRIVATE (JSEA,ISEA,IX,IY,DELA,DELX,DELY, & -!$OMP& REFLEC,REFLED,D50,PSIC,TMP1,TMP2,TMP3,TMP4) -!$OMP DO SCHEDULE (DYNAMIC,1) -#endif -! - DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - IX = MAPSF(ISEA,1) - IY = MAPSF(ISEA,2) - DELA=1. - DELX=1. - DELY=1. + if (w3_debugsrc_flag) then + WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT + CALL ALL_VAOLD_INTEGRAL_PRINT("VAOLD before W3SRCE_IMP_POST") + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA before W3SRCE_IMP_POST") + IF (DEBUG_NODE .le. NSEAL) THEN + WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE + WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' sum(VAOLD)=', sum(VAOLD(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' sum(VSTOT)=', sum(VSTOT(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' sum(VDTOT)=', sum(VDTOT(:,DEBUG_NODE)) + END IF + end if +#endif + ! + !$OMP PARALLEL PRIVATE (JSEA,ISEA,IX,IY,DELA,DELX,DELY, & + !$OMP& REFLEC,REFLED,D50,PSIC,TMP1,TMP2,TMP3,TMP4) + !$OMP DO SCHEDULE (DYNAMIC,1) + DO JSEA=1, NSEAL + CALL INIT_GET_ISEA(ISEA, JSEA) + IX = MAPSF(ISEA,1) + IY = MAPSF(ISEA,2) + DELA=1. + DELX=1. + DELY=1. #ifdef W3_REF1 - IF (GTYPE.EQ.RLGTYPE) THEN - DELX=SX*CLATS(ISEA)/FACX - DELY=SY/FACX - DELA=DELX*DELY - END IF - IF (GTYPE.EQ.CLGTYPE) THEN -! Maybe what follows works also for RLGTYPE ... to be verified - DELX=HPFAC(IY,IX)/ FACX - DELY=HQFAC(IY,IX)/ FACX - DELA=DELX*DELY - END IF -#endif -! + IF (GTYPE.EQ.RLGTYPE) THEN + DELX=SX*CLATS(ISEA)/FACX + DELY=SY/FACX + DELA=DELX*DELY + END IF + IF (GTYPE.EQ.CLGTYPE) THEN + ! Maybe what follows works also for RLGTYPE ... to be verified + DELX=HPFAC(IY,IX)/ FACX + DELY=HQFAC(IY,IX)/ FACX + DELA=DELX*DELY + END IF +#endif + ! #ifdef W3_REF1 - REFLEC=REFLC(:,ISEA) - REFLEC(4)=BERG(ISEA)*REFLEC(4) - REFLED=REFLD(:,ISEA) + REFLEC=REFLC(:,ISEA) + REFLEC(4)=BERG(ISEA)*REFLEC(4) + REFLED=REFLD(:,ISEA) #endif #ifdef W3_BT4 - D50=SED_D50(ISEA) - PSIC=SED_PSIC(ISEA) -#endif - -#ifdef W3_DEBUGRUN - IF (JSEA == DEBUG_NODE) WRITE(*,*) 'W3WAVE TEST', ISEA, JSEA, SUM(VA(:,JSEA)) -#endif - - IF ( MAPSTA(IY,IX) .EQ. 1 .AND. FLAGST(ISEA)) THEN - TMP1 = WHITECAP(JSEA,1:4) - TMP2 = BEDFORMS(JSEA,1:3) - TMP3 = TAUBBL(JSEA,1:2) - TMP4 = TAUICE(JSEA,1:2) + D50=SED_D50(ISEA) + PSIC=SED_PSIC(ISEA) +#endif + if (w3_debugrun_flag) then + IF (JSEA == DEBUG_NODE) WRITE(*,*) 'W3WAVE TEST', ISEA, JSEA, SUM(VA(:,JSEA)) + end if + + IF ( MAPSTA(IY,IX) .EQ. 1 .AND. FLAGST(ISEA)) THEN + TMP1 = WHITECAP(JSEA,1:4) + TMP2 = BEDFORMS(JSEA,1:3) + TMP3 = TAUBBL(JSEA,1:2) + TMP4 = TAUICE(JSEA,1:2) #ifdef W3_PDLIB - IF (FSSOURCE) THEN - CALL W3SRCE(srce_imp_post,IT,ISEA,JSEA,IX,IY,IMOD, & - VAOLD(:,JSEA), VA(:,JSEA), & - VSioDummy,VDioDummy,SHAVETOT(JSEA), & - ALPHA(1:NK,JSEA), WN(1:NK,ISEA), & - CG(1:NK,ISEA), CLATS(ISEA), DW(ISEA), U10(ISEA), & - U10D(ISEA), & + IF (FSSOURCE) THEN + CALL W3SRCE(srce_imp_post,IT,ISEA,JSEA,IX,IY,IMOD, & + VAOLD(:,JSEA), VA(:,JSEA), & + VSioDummy,VDioDummy,SHAVETOT(JSEA), & + ALPHA(1:NK,JSEA), WN(1:NK,ISEA), & + CG(1:NK,ISEA), CLATS(ISEA), DW(ISEA), U10(ISEA), & + U10D(ISEA), & #ifdef W3_FLX5 - TAUA(ISEA), TAUADIR(ISEA), & -#endif - AS(ISEA), UST(ISEA), & - USTDIR(ISEA), CX(ISEA), CY(ISEA), & - ICE(ISEA), ICEH(ISEA), ICEF(ISEA), & - ICEDMAX(ISEA), & - REFLEC, REFLED, DELX, DELY, DELA, & - TRNX(IY,IX), TRNY(IY,IX), BERG(ISEA), & - FPIS(ISEA), DTDYN(JSEA), & - FCUT(JSEA), DTG, TAUWX(JSEA), TAUWY(JSEA), & - TAUOX(JSEA), TAUOY(JSEA), TAUWIX(JSEA), & - TAUWIY(JSEA), TAUWNX(JSEA), & - TAUWNY(JSEA), PHIAW(JSEA), CHARN(JSEA), & - TWS(JSEA),PHIOC(JSEA), TMP1, D50, PSIC, TMP2,& - PHIBBL(JSEA), TMP3, TMP4, PHICE(JSEA), & - TAUOCX(JSEA), TAUOCY(JSEA), WNMEAN(JSEA), & - RHOAIR(ISEA), ASF(ISEA)) - ELSE -#endif - CALL W3SRCE(srce_direct, IT, ISEA, JSEA, IX, IY, IMOD, & - VAoldDummy, VA(:,JSEA), & - VSioDummy, VDioDummy, SHAVETOTioDummy, & - ALPHA(1:NK,JSEA), WN(1:NK,ISEA), & - CG(1:NK,ISEA), CLATS(ISEA), DW(ISEA), U10(ISEA), & - U10D(ISEA), & + TAUA(ISEA), TAUADIR(ISEA), & +#endif + AS(ISEA), UST(ISEA), & + USTDIR(ISEA), CX(ISEA), CY(ISEA), & + ICE(ISEA), ICEH(ISEA), ICEF(ISEA), & + ICEDMAX(ISEA), & + REFLEC, REFLED, DELX, DELY, DELA, & + TRNX(IY,IX), TRNY(IY,IX), BERG(ISEA), & + FPIS(ISEA), DTDYN(JSEA), & + FCUT(JSEA), DTG, TAUWX(JSEA), TAUWY(JSEA), & + TAUOX(JSEA), TAUOY(JSEA), TAUWIX(JSEA), & + TAUWIY(JSEA), TAUWNX(JSEA), & + TAUWNY(JSEA), PHIAW(JSEA), CHARN(JSEA), & + TWS(JSEA),PHIOC(JSEA), TMP1, D50, PSIC, TMP2, & + PHIBBL(JSEA), TMP3, TMP4, PHICE(JSEA), & + TAUOCX(JSEA), TAUOCY(JSEA), WNMEAN(JSEA), & + RHOAIR(ISEA), ASF(ISEA)) + ELSE +#endif + CALL W3SRCE(srce_direct, IT, ISEA, JSEA, IX, IY, IMOD, & + VAoldDummy, VA(:,JSEA), & + VSioDummy, VDioDummy, SHAVETOTioDummy, & + ALPHA(1:NK,JSEA), WN(1:NK,ISEA), & + CG(1:NK,ISEA), CLATS(ISEA), DW(ISEA), U10(ISEA), & + U10D(ISEA), & #ifdef W3_FLX5 - TAUA(ISEA), TAUADIR(ISEA), & -#endif - AS(ISEA), UST(ISEA), & - USTDIR(ISEA), CX(ISEA), CY(ISEA), & - ICE(ISEA), ICEH(ISEA), ICEF(ISEA), & - ICEDMAX(ISEA), & - REFLEC, REFLED, DELX, DELY, DELA, & - TRNX(IY,IX), TRNY(IY,IX), BERG(ISEA), & - FPIS(ISEA), DTDYN(JSEA), & - FCUT(JSEA), DTG, TAUWX(JSEA), TAUWY(JSEA), & - TAUOX(JSEA), TAUOY(JSEA), TAUWIX(JSEA), & - TAUWIY(JSEA), TAUWNX(JSEA), & - TAUWNY(JSEA), PHIAW(JSEA), CHARN(JSEA), & - TWS(JSEA), PHIOC(JSEA), TMP1, D50, PSIC,TMP2,& - PHIBBL(JSEA), TMP3, TMP4 , PHICE(JSEA), & - TAUOCX(JSEA), TAUOCY(JSEA), WNMEAN(JSEA), & - RHOAIR(ISEA), ASF(ISEA)) + TAUA(ISEA), TAUADIR(ISEA), & +#endif + AS(ISEA), UST(ISEA), & + USTDIR(ISEA), CX(ISEA), CY(ISEA), & + ICE(ISEA), ICEH(ISEA), ICEF(ISEA), & + ICEDMAX(ISEA), & + REFLEC, REFLED, DELX, DELY, DELA, & + TRNX(IY,IX), TRNY(IY,IX), BERG(ISEA), & + FPIS(ISEA), DTDYN(JSEA), & + FCUT(JSEA), DTG, TAUWX(JSEA), TAUWY(JSEA), & + TAUOX(JSEA), TAUOY(JSEA), TAUWIX(JSEA), & + TAUWIY(JSEA), TAUWNX(JSEA), & + TAUWNY(JSEA), PHIAW(JSEA), CHARN(JSEA), & + TWS(JSEA), PHIOC(JSEA), TMP1, D50, PSIC,TMP2, & + PHIBBL(JSEA), TMP3, TMP4 , PHICE(JSEA), & + TAUOCX(JSEA), TAUOCY(JSEA), WNMEAN(JSEA), & + RHOAIR(ISEA), ASF(ISEA)) #ifdef W3_PDLIB - END IF -#endif - WHITECAP(JSEA,1:4) = TMP1 - BEDFORMS(JSEA,1:3) = TMP2 - TAUBBL(JSEA,1:2) = TMP3 - TAUICE(JSEA,1:2) = TMP4 - ELSE - UST (ISEA) = UNDEF - USTDIR(ISEA) = UNDEF - DTDYN (JSEA) = UNDEF - FCUT (JSEA) = UNDEF -! VA(:,JSEA) = 0. - END IF -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'RET: min/max/sum(VA)=',minval(VA(:,JSEA)),maxval(VA(:,JSEA)),sum(VA(:,JSEA)) -#endif - END DO -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'min/max/sum(VAtot)=', minval(VA), maxval(VA), sum(VA) - FLUSH(740+IAPROC) -#endif - -#ifdef W3_DEBUGRUN - DO JSEA = 1, NSEAL - DO IS = 1, NSPEC - IF (VA(IS, JSEA) .LT. 0.) THEN - WRITE(740+IAPROC,*) 'TEST W3WAVE 9', VA(IS,JSEA) - CALL FLUSH(740+IAPROC) - ENDIF - ENDDO - ENDDO - IF (SUM(VA) .NE. SUM(VA)) THEN - WRITE(740+IAPROC,*) 'NAN in ACTION 7', IX, IY, SUM(VA) - CALL FLUSH(740+IAPROC) - STOP - ENDIF -#endif - -! -#ifdef W3_OMPG -!$OMP END DO -!$OMP END PARALLEL + END IF #endif -! + WHITECAP(JSEA,1:4) = TMP1 + BEDFORMS(JSEA,1:3) = TMP2 + TAUBBL(JSEA,1:2) = TMP3 + TAUICE(JSEA,1:2) = TMP4 + ELSE + UST (ISEA) = UNDEF + USTDIR(ISEA) = UNDEF + DTDYN (JSEA) = UNDEF + FCUT (JSEA) = UNDEF + ! VA(:,JSEA) = 0. + END IF + + END DO ! DO JSEA=1, NSEAL + !$OMP END DO + !$OMP END PARALLEL + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'RET: min/max/sum(VA)=',minval(VA(:,JSEA)),maxval(VA(:,JSEA)),sum(VA(:,JSEA)) + WRITE(740+IAPROC,*) 'min/max/sum(VAtot)=', minval(VA), maxval(VA), sum(VA) + + DO JSEA = 1, NSEAL + DO IS = 1, NSPEC + IF (VA(IS, JSEA) .LT. 0.) THEN + WRITE(740+IAPROC,*) 'TEST W3WAVE 9', VA(IS,JSEA) + ENDIF + ENDDO + ENDDO + IF (SUM(VA) .NE. SUM(VA)) THEN + WRITE(740+IAPROC,*) 'NAN in ACTION 7', IX, IY, SUM(VA) + STOP + ENDIF + end if #ifdef W3_PDLIB -#ifdef W3_DEBUGSRC - WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT - CALL ALL_VAOLD_INTEGRAL_PRINT("VAOLD after W3SRCE_IMP_PRE_POST") - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA after W3SRCE_IMP_PRE_POST") - IF (DEBUG_NODE .le. NSEAL) THEN - WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE - WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) - WRITE(740+IAPROC,*) ' min/max(VA)=', minval(VA(:,DEBUG_NODE)), maxval(VA(:,DEBUG_NODE)) - END IF -#endif -#endif - -! -! This barrier is from older code versions. It has been removed in 3.11 -! to optimize IO2/3 settings. May be needed on some systems still -! -!!/MPI IF (FLAG0) CALL MPI_BARRIER (MPI_COMM_WCMP,IERR_MPI) -!!/MPI ELSE -!!/MPI CALL MPI_BARRIER (MPI_COMM_WCMP,IERR_MPI) -! - END IF -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.18' - FLUSH(740+IAPROC) -#endif + if (w3_debugsrc_flag) then + WRITE(740+IAPROC,*) 'ITIME=', ITIME, ' IT=', IT + CALL ALL_VAOLD_INTEGRAL_PRINT("VAOLD after W3SRCE_IMP_PRE_POST") + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "VA after W3SRCE_IMP_PRE_POST") + IF (DEBUG_NODE .le. NSEAL) THEN + WRITE(740+IAPROC,*) ' Values for DEBUG_NODE=', DEBUG_NODE + WRITE(740+IAPROC,*) ' sum(VA)=', sum(VA(:,DEBUG_NODE)) + WRITE(740+IAPROC,*) ' min/max(VA)=', minval(VA(:,DEBUG_NODE)), maxval(VA(:,DEBUG_NODE)) + END IF + end if +#endif + ! This barrier is from older code versions. It has been removed in 3.11 + ! to optimize IO2/3 settings. May be needed on some systems still + !!/MPI IF (FLAG0) CALL MPI_BARRIER (MPI_COMM_WCMP,IERR_MPI) + !!/MPI ELSE + !!/MPI CALL MPI_BARRIER (MPI_COMM_WCMP,IERR_MPI) + END IF ! IF ( FLSOU ) + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.18' + end if #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After source terms") -#endif -#endif -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("After source terms") -#endif -! -! End of interations for DTMAX < 1s -! + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "After source terms") + end if +#endif + if (w3_timings_flag) then + CALL PRINT_MY_TIME("After source terms") + end if + ! + ! End of interations for DTMAX < 1s + ! #ifdef W3_SEC1 - IF (IT.EQ.0) EXIT - END DO - IF (IT.GT.0) DTG=DTGTEMP -#endif - -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.19' - FLUSH(740+IAPROC) - DO JSEA = 1, NSEAL - DO IS = 1, NSPEC - IF (VA(IS, JSEA) .LT. 0.) THEN - WRITE(740+IAPROC,*) 'TEST W3WAVE 10', VA(IS,JSEA) - CALL FLUSH(740+IAPROC) - ENDIF - ENDDO - ENDDO - IF (SUM(VA) .NE. SUM(VA)) THEN - WRITE(740+IAPROC,*) 'NAN in ACTION 8', IX, IY, SUM(VA) - CALL FLUSH(740+IAPROC) - STOP - ENDIF -#endif -! -! 3.8 Update global time step. -! (Branch point FLDRY, IT=0) -! - 380 CONTINUE -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.20' - FLUSH(740+IAPROC) -#endif - IF (IT.NE.NT) THEN - DTTST = DSEC21 ( TIME , TCALC ) - DTG = DTTST / REAL(NT-IT) + IF (IT.EQ.0) EXIT + END DO + IF (IT.GT.0) DTG=DTGTEMP +#endif + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.19' + DO JSEA = 1, NSEAL + DO IS = 1, NSPEC + IF (VA(IS, JSEA) .LT. 0.) THEN + WRITE(740+IAPROC,*) 'TEST W3WAVE 10', VA(IS,JSEA) + ENDIF + ENDDO + ENDDO + IF (SUM(VA) .NE. SUM(VA)) THEN + WRITE(740+IAPROC,*) 'NAN in ACTION 8', IX, IY, SUM(VA) + STOP + ENDIF + end if + ! + ! 3.8 Update global time step. + ! (Branch point FLDRY, IT=0) + ! +380 CONTINUE + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.20' + end if + IF (IT.NE.NT) THEN + DTTST = DSEC21 ( TIME , TCALC ) + DTG = DTTST / REAL(NT-IT) END IF -! - IF ( FLACT .AND. IT.NE.NT .AND. IAPROC.EQ.NAPLOG ) THEN - CALL STME21 ( TIME , IDTIME ) - IF ( IDLAST .NE. TIME(1) ) THEN + ! + IF ( FLACT .AND. IT.NE.NT .AND. IAPROC.EQ.NAPLOG ) THEN + CALL STME21 ( TIME , IDTIME ) + IF ( IDLAST .NE. TIME(1) ) THEN WRITE (NDSO,900) ITIME, IPASS, IDTIME(01:19), & - IDACT, OUTID + IDACT, OUTID IDLAST = TIME(1) - ELSE + ELSE WRITE (NDSO,901) ITIME, IPASS, IDTIME(12:19), & - IDACT, OUTID - END IF - FLACT = .FALSE. - IDACT = ' ' - END IF -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.21' - FLUSH(740+IAPROC) -#endif -! + IDACT, OUTID + END IF + FLACT = .FALSE. + IDACT = ' ' + END IF + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.21' + end if + ! #ifdef W3_PDLIB -#ifdef W3_DEBUGCOH - CALL ALL_VA_INTEGRAL_PRINT(IMOD, "end of time loop") -#endif -#endif -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("end of time loop") -#endif -! -! - END DO - -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.1' - FLUSH(740+IAPROC) -#endif -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("W3WAVE, step 6.21.1") -#endif -! -#ifdef W3_T - WRITE (NDST,9030) -#endif -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE END TIME LOOP' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif -! -! End of loop over time steps -! ==================================================================== / -! - 400 CONTINUE -! -! 4. Perform output to file if requested ---------------------------- / -! 4.a Check if time is output time -! Delay if data assimilation time. -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.2' - FLUSH(740+IAPROC) -#endif -! - IF ( TOFRST(1) .EQ. -1 ) THEN + if (w3_debugcoh_flag) then + CALL ALL_VA_INTEGRAL_PRINT(IMOD, "end of time loop") + end if +#endif + if (w3_timings_flag) then + CALL PRINT_MY_TIME("end of time loop") + end if + END DO ! DO IT = IT0, NT + + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.1' + end if + if (w3_timings_flag) then + CALL PRINT_MY_TIME("W3WAVE, step 6.21.1") + end if + ! + if (w3_t_flag) then + WRITE (NDST,9030) + end if + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE END TIME LOOP') + ! + ! End of loop over time steps + ! ==================================================================== / + ! +400 CONTINUE + ! + ! 4. Perform output to file if requested ---------------------------- / + ! 4.a Check if time is output time + ! Delay if data assimilation time. + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.2' + end if + ! + IF ( TOFRST(1) .EQ. -1 ) THEN DTTST = 1. - ELSE + ELSE DTTST = DSEC21 ( TIME, TOFRST ) - END IF -! - IF ( TDN(1) .EQ. -1 ) THEN + END IF + ! + IF ( TDN(1) .EQ. -1 ) THEN DTTST1 = 1. - ELSE + ELSE DTTST1 = DSEC21 ( TIME, TDN ) - END IF -! - DTTST2 = DSEC21 ( TIME, TEND ) - FLAG_O = .NOT.SKIP_O .OR. ( SKIP_O .AND. DTTST2.NE.0. ) -! -#ifdef W3_T - WRITE (NDST,9040) TOFRST, TDN, DTTST, DTTST1, FLAG_O -#endif -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.3' - FLUSH(740+IAPROC) -#endif - IF ( DTTST.LE.0. .AND. DTTST1.NE.0. .AND. FLAG_O ) THEN -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.4' - FLUSH(740+IAPROC) -#endif -! -#ifdef W3_T - WRITE (NDST,9041) -#endif -! -! 4.b Processing and MPP preparations -! + END IF + ! + DTTST2 = DSEC21 ( TIME, TEND ) + FLAG_O = .NOT.SKIP_O .OR. ( SKIP_O .AND. DTTST2.NE.0. ) + ! + if (w3_t_flag) then + WRITE (NDST,9040) TOFRST, TDN, DTTST, DTTST1, FLAG_O + end if + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.3' + end if + ! + IF ( DTTST.LE.0. .AND. DTTST1.NE.0. .AND. FLAG_O ) THEN + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.4' + end if + if (w3_t_flag) then + WRITE (NDST,9041) + end if + ! + ! 4.b Processing and MPP preparations + ! IF ( FLOUT(1) ) THEN - FLOUTG = DSEC21(TIME,TONEXT(:,1)).EQ.0. - ELSE - FLOUTG = .FALSE. - END IF -! + FLOUTG = DSEC21(TIME,TONEXT(:,1)).EQ.0. + ELSE + FLOUTG = .FALSE. + END IF + ! IF ( FLOUT(7) ) THEN - FLOUTG2 = DSEC21(TIME,TONEXT(:,7)).EQ.0. - ELSE - FLOUTG2 = .FALSE. - END IF -! - FLPART = .FALSE. - IF ( FLOUT(1) .AND. FLPFLD ) & - FLPART = FLPART .OR. DSEC21(TIME,TONEXT(:,1)).EQ.0. -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.7' - FLUSH(740+IAPROC) -#endif - IF ( FLOUT(6) ) & - FLPART = FLPART .OR. DSEC21(TIME,TONEXT(:,6)).EQ.0. -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.8' - FLUSH(740+IAPROC) -#endif -! -#ifdef W3_T - WRITE (NDST,9042) LOCAL, FLPART, FLOUTG -#endif -! + FLOUTG2 = DSEC21(TIME,TONEXT(:,7)).EQ.0. + ELSE + FLOUTG2 = .FALSE. + END IF + ! + FLPART = .FALSE. + IF ( FLOUT(1) .AND. FLPFLD ) & + FLPART = FLPART .OR. DSEC21(TIME,TONEXT(:,1)).EQ.0. + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.7' + end if + IF ( FLOUT(6) ) & + FLPART = FLPART .OR. DSEC21(TIME,TONEXT(:,6)).EQ.0. + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'W3WAVE, step 6.21.8' + end if + ! + if (w3_t_flag) then + WRITE (NDST,9042) LOCAL, FLPART, FLOUTG + end if + ! IF ( LOCAL .AND. FLPART ) CALL W3CPRT ( IMOD ) - IF ( LOCAL .AND. (FLOUTG .OR. FLOUTG2) ) & - CALL W3OUTG ( VA, FLPFLD, FLOUTG, FLOUTG2 ) -! + IF ( LOCAL .AND. (FLOUTG .OR. FLOUTG2) ) then + CALL W3OUTG ( VA, FLPFLD, FLOUTG, FLOUTG2 ) + end if + ! #ifdef W3_MPI FLGMPI = .FALSE. NRQMAX = 0 + ! + IF ( ( (DSEC21(TIME,TONEXT(:,1)).EQ.0.) .AND. FLOUT(1) ) .OR. & + ( (DSEC21(TIME,TONEXT(:,7)).EQ.0.) .AND. FLOUT(7) .AND. & + SBSED ) ) THEN + + IF (.NOT. LPDLIB .or. (GTYPE.ne.UNGTYPE)) THEN + IF (NRQGO.NE.0 ) THEN + if (w3_debugrun_flag) then + WRITE(memunit,*) 'BEFORE STARTALL NRQGO.NE.0 , step 0', & + NRQGO, IRQGO, GTYPE, UNGTYPE, .NOT. LPDLIB .or. (GTYPE.ne.UNGTYPE) + end if + CALL MPI_STARTALL ( NRQGO, IRQGO , IERR_MPI ) + if (w3_debugrun_flag) then + WRITE(memunit,*) 'AFTER STARTALL NRQGO.NE.0, step 0' + end if + FLGMPI(0) = .TRUE. + NRQMAX = MAX ( NRQMAX , NRQGO ) + if (w3_mpit_flag) then + WRITE (NDST,9043) '1a', NRQGO, NRQMAX, NAPFLD + end if + END IF + ! + IF (NRQGO2.NE.0 ) THEN + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'BEFORE STARTALL NRQGO2.NE.0, step 0', & + NRQGO2, IRQGO2, GTYPE, UNGTYPE, .NOT. LPDLIB .or. (GTYPE.ne.UNGTYPE) + end if + CALL MPI_STARTALL ( NRQGO2, IRQGO2, IERR_MPI ) + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'AFTER STARTALL NRQGO2.NE.0, step 0' + end if + FLGMPI(1) = .TRUE. + NRQMAX = MAX ( NRQMAX , NRQGO2 ) + if (w3_mpit_flag) then + WRITE (NDST,9043) '1b', NRQGO2, NRQMAX, NAPFLD + end if + END IF + ELSE + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'BEFORE DO_OUTPUT_EXCHANGES, step 0' + end if +#ifdef W3_PDLIB + CALL DO_OUTPUT_EXCHANGES(IMOD) #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 -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'BEFORE STARTALL NRQGO.NE.0 , step 0', & - NRQGO, IRQGO, GTYPE, UNGTYPE, .NOT. LPDLIB .or. (GTYPE.ne.UNGTYPE) - FLUSH(740+IAPROC) -#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' - FLUSH(740+IAPROC) -#endif - -#ifdef W3_MPI - FLGMPI(0) = .TRUE. - NRQMAX = MAX ( NRQMAX , NRQGO ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9043) '1a', NRQGO, NRQMAX, NAPFLD -#endif -#ifdef W3_MPI - END IF -#endif -! -#ifdef W3_MPI - 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) -#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) -#endif -#ifdef W3_MPI - FLGMPI(1) = .TRUE. - NRQMAX = MAX ( NRQMAX , NRQGO2 ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9043) '1b', NRQGO2, NRQMAX, NAPFLD -#endif -#ifdef W3_MPI - END IF - ELSE -#endif -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'BEFORE DO_OUTPUT_EXCHANGES, step 0' - FLUSH(740+IAPROC) -#endif -#ifdef W3_PDLIB - CALL DO_OUTPUT_EXCHANGES(IMOD) -#endif -#ifdef W3_MPI - END IF - END IF -#endif - -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 1' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif - -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 1' - FLUSH(740+IAPROC) -#endif -#ifdef W3_MPI + END IF + END IF + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE AFTER TIME LOOP 1') + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 1' + end if IF ( FLOUT(2) .AND. NRQPO.NE.0 ) THEN - IF ( DSEC21(TIME,TONEXT(:,2)).EQ.0. ) THEN - CALL MPI_STARTALL ( NRQPO, IRQPO1, IERR_MPI ) - FLGMPI(2) = .TRUE. - NRQMAX = MAX ( NRQMAX , NRQPO ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9043) '2 ', NRQPO, NRQMAX, NAPPNT -#endif -#ifdef W3_MPI - END IF - END IF -#endif -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 2' - FLUSH(740+IAPROC) -#endif -#ifdef W3_MPI + IF ( DSEC21(TIME,TONEXT(:,2)).EQ.0. ) THEN + CALL MPI_STARTALL ( NRQPO, IRQPO1, IERR_MPI ) + FLGMPI(2) = .TRUE. + NRQMAX = MAX ( NRQMAX , NRQPO ) + if (w3_mpit_flag) then + WRITE (NDST,9043) '2 ', NRQPO, NRQMAX, NAPPNT + end if + END IF + END IF + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 2' + end if IF ( FLOUT(4) .AND. NRQRS.NE.0 ) THEN - IF ( DSEC21(TIME,TONEXT(:,4)).EQ.0. ) THEN - CALL MPI_STARTALL ( NRQRS, IRQRS , IERR_MPI ) - FLGMPI(4) = .TRUE. - NRQMAX = MAX ( NRQMAX , NRQRS ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9043) '4 ', NRQRS, NRQMAX, NAPRST -#endif -#ifdef W3_MPI - END IF - END IF -#endif -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 2' - FLUSH(740+IAPROC) -#endif -#ifdef W3_MPI + IF ( DSEC21(TIME,TONEXT(:,4)).EQ.0. ) THEN + CALL MPI_STARTALL ( NRQRS, IRQRS , IERR_MPI ) + FLGMPI(4) = .TRUE. + NRQMAX = MAX ( NRQMAX , NRQRS ) + if (w3_mpit_flag) then + WRITE (NDST,9043) '4 ', NRQRS, NRQMAX, NAPRST + end if + END IF + END IF + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 2' + end if IF ( FLOUT(8) .AND. NRQRS.NE.0 ) THEN - IF ( DSEC21(TIME,TONEXT(:,8)).EQ.0. ) THEN - CALL MPI_STARTALL ( NRQRS, IRQRS , IERR_MPI ) - FLGMPI(8) = .TRUE. - NRQMAX = MAX ( NRQMAX , NRQRS ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9043) '8 ', NRQRS, NRQMAX, NAPRST -#endif -#ifdef W3_MPI - END IF - END IF -#endif -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 3' - FLUSH(740+IAPROC) -#endif -#ifdef W3_MPI + IF ( DSEC21(TIME,TONEXT(:,8)).EQ.0. ) THEN + CALL MPI_STARTALL ( NRQRS, IRQRS , IERR_MPI ) + FLGMPI(8) = .TRUE. + NRQMAX = MAX ( NRQMAX , NRQRS ) + if (w3_mpit_flag) then + WRITE (NDST,9043) '8 ', NRQRS, NRQMAX, NAPRST + end if + END IF + END IF + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 3' + end if IF ( FLOUT(5) .AND. NRQBP.NE.0 ) THEN - IF ( DSEC21(TIME,TONEXT(:,5)).EQ.0. ) THEN - CALL MPI_STARTALL ( NRQBP , IRQBP1, IERR_MPI ) - FLGMPI(5) = .TRUE. - NRQMAX = MAX ( NRQMAX , NRQBP ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9043) '5a', NRQBP, NRQMAX, NAPBPT -#endif -#ifdef W3_MPI - END IF - END IF -#endif -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 4' - FLUSH(740+IAPROC) -#endif -#ifdef W3_MPI - IF ( FLOUT(5) .AND. NRQBP2.NE.0 .AND. & - IAPROC.EQ.NAPBPT) THEN - IF ( DSEC21(TIME,TONEXT(:,5)).EQ.0. ) THEN - CALL MPI_STARTALL (NRQBP2,IRQBP2,IERR_MPI) - NRQMAX = MAX ( NRQMAX , NRQBP2 ) -#endif -#ifdef W3_MPIT - WRITE (NDST,9043) '5b', NRQBP2, NRQMAX, NAPBPT -#endif -#ifdef W3_MPI - END IF - END IF -#endif -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 5' - FLUSH(740+IAPROC) -#endif -#ifdef W3_MPI - IF ( NRQMAX .NE. 0 ) ALLOCATE & - ( STATIO(MPI_STATUS_SIZE,NRQMAX) ) -#endif - -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 2' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif - -! -! 4.c Reset next output time - -#ifdef W3_DEBUGRUN - IF (MINVAL(VA) .LT. 0.) THEN - WRITE(740+IAPROC,*) 'TEST W3WAVE 12', SUM(VA), MINVAL(VA), MAXVAL(VA) - CALL FLUSH(740+IAPROC) - STOP - ENDIF - IF (SUM(VA) .NE. SUM(VA)) THEN - WRITE(740+IAPROC,*) 'NAN in ACTION 9', IX, IY, SUM(VA) - CALL FLUSH(740+IAPROC) - STOP - ENDIF -#endif -! + IF ( DSEC21(TIME,TONEXT(:,5)).EQ.0. ) THEN + CALL MPI_STARTALL ( NRQBP , IRQBP1, IERR_MPI ) + FLGMPI(5) = .TRUE. + NRQMAX = MAX ( NRQMAX , NRQBP ) + if (w3_mpit_flag) then + WRITE (NDST,9043) '5a', NRQBP, NRQMAX, NAPBPT + end if + END IF + END IF + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 4' + end if + IF ( FLOUT(5) .AND. NRQBP2.NE.0 .AND. IAPROC.EQ.NAPBPT) THEN + IF ( DSEC21(TIME,TONEXT(:,5)).EQ.0. ) THEN + CALL MPI_STARTALL (NRQBP2,IRQBP2,IERR_MPI) + NRQMAX = MAX ( NRQMAX , NRQBP2 ) + if (w3_mpit_flag) then + WRITE (NDST,9043) '5b', NRQBP2, NRQMAX, NAPBPT + end if + END IF + END IF + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'After DO_OUTPUT_EXCHANGES, step 5' + end if + IF ( NRQMAX .NE. 0 ) ALLOCATE( STATIO(MPI_STATUS_SIZE,NRQMAX) ) +#endif + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE AFTER TIME LOOP 2') + ! + ! 4.c Reset next output time + ! + if (w3_debugrun_flag) then + IF (MINVAL(VA) .LT. 0.) THEN + WRITE(740+IAPROC,*) 'TEST W3WAVE 12', SUM(VA), MINVAL(VA), MAXVAL(VA) + STOP + ENDIF + IF (SUM(VA) .NE. SUM(VA)) THEN + WRITE(740+IAPROC,*) 'NAN in ACTION 9', IX, IY, SUM(VA) + STOP + ENDIF + end if + ! TOFRST(1) = -1 TOFRST(2) = 0 -! + ! DO J=1, NOTYPE -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'NOTYPE, J=', J - FLUSH(740+IAPROC) -#endif - - IF ( FLOUT(J) ) THEN -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'Matching FLOUT(J)' - FLUSH(740+IAPROC) -#endif -! -! 4.d Perform output -! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'NOTYPE, J=', J + end if + + IF ( FLOUT(J) ) THEN + ! + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'Matching FLOUT(J)' + end if + ! + ! Determine output flags + ! + if (w3_sbs_flag) then + do_gridded_output = ( j .eq. 1 ) .or. ( j .eq. 7 ) + else + if (w3_cesmcoupled_flag) then + do_gridded_output = ( j .eq. 1 ) .and. histwr + else + do_gridded_output = ( j .eq. 1 ) + end if + end if + do_point_output = (j .eq. 2) + do_track_output = (j .eq. 3) + if (w3_cesmcoupled_flag) then + do_restart_output = (j .eq. 4) .and. rstwr + else + do_restart_output = (j .eq. 4) + end if + do_wavefield_separation_output = (j .eq. 5) + do_sf_output = (j .eq. 6) + do_coupler_output = (j .eq. 7) + ! + ! 4.d Perform output + ! #ifdef W3_NL5 - IF (J .EQ. 2) TOSNL5 = TONEXT(:, 2) + IF (J .EQ. 2) TOSNL5 = TONEXT(:, 2) #endif TOUT(:) = TONEXT(:,J) 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 ) & + if (do_gridded_output) then + + if (user_netcdf_grdout) then + !TODO: why is this using FLGMPI(0)? The block netcdf/binary blocks + ! could be combined w/o this +#ifdef W3_MPI + CALL MPI_WAITALL( NRQGO, IRQGO, STATIO, IERR_MPI ) + FLGMPI(0) = .FALSE. #endif - ) THEN - IF ( IAPROC .EQ. NAPFLD ) THEN + IF ( IAPROC .EQ. NAPFLD ) THEN #ifdef W3_MPI - IF ( FLGMPI(1) ) CALL MPI_WAITALL & - ( NRQGO2, IRQGO2, STATIO, IERR_MPI ) + IF ( FLGMPI(1) ) CALL MPI_WAITALL( NRQGO2, IRQGO2, STATIO, IERR_MPI ) FLGMPI(1) = .FALSE. #endif -! -#ifdef W3_SBS - IF ( J .EQ. 1 ) THEN -#endif - CALL W3IOGO( 'WRITE', NDS(7), ITEST, IMOD ) -#ifdef W3_SBS - ENDIF - ! - ! - ! Generate output flag file for fields and SBS coupling. - ! - JJ = LEN_TRIM ( FILEXT ) - CALL STME21 ( TIME, IDTIME ) - FOUTNAME = 'Field_done.' // IDTIME(1:4) & - // IDTIME(6:7) // IDTIME(9:10) & - // IDTIME(12:13) // '.' // FILEXT(1:JJ) -! - 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 -! - IF ( IAPROC .EQ. NAPPNT ) THEN -! -! Gets the necessary spectral data -! - CALL W3IOPE ( VA ) - CALL W3IOPO ( 'WRITE', NDS(8), ITEST, IMOD ) - END IF -! - ELSE IF ( J .EQ. 3 ) THEN -! -! 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) ) + CALL W3IOGONCD () + END IF + ! default (binary) output + else + IF ( IAPROC .EQ. NAPFLD ) THEN +#ifdef W3_MPI + IF ( FLGMPI(1) ) CALL MPI_WAITALL( NRQGO2, IRQGO2, STATIO, IERR_MPI ) + FLGMPI(1) = .FALSE. #endif - ITEST = RSTYPE - ELSE IF ( J .EQ. 5 ) THEN - IF ( IAPROC .EQ. NAPBPT ) THEN + if (w3_sbs_flag) then + IF ( J .EQ. 1 ) THEN + CALL W3IOGO( 'WRITE', NDS(7), ITEST, IMOD ) + ENDIF + + ! Generate output flag file for fields and SBS coupling. + CALL STME21 ( TIME, IDTIME ) + FOUTNAME = 'Field_done.' // IDTIME(1:4) & + // IDTIME(6:7) // IDTIME(9:10) & + // IDTIME(12:13) // '.' // TRIM(FILEXT) + OPEN( UNIT=NDSOFLG, FILE=FOUTNAME) + CLOSE( NDSOFLG ) + else + CALL W3IOGO( 'WRITE', NDS(7), ITEST, IMOD ) + endif + end if + end if ! user_netcdf_grdout + + ELSE IF ( do_point_output ) THEN + IF ( IAPROC .EQ. NAPPNT ) THEN + CALL W3IOPE ( VA ) + CALL W3IOPO ( 'WRITE', NDS(8), ITEST, IMOD ) + END IF + + ELSE IF ( do_track_output ) THEN + CALL W3IOTR ( NDS(11), NDS(12), VA, IMOD ) + + ELSE IF ( do_restart_output ) THEN + CALL W3IORS ('HOT', NDS(6), XXX, IMOD, FLOUT(8) ) + ITEST = RSTYPE + + ELSE IF ( do_wavefield_separation_output ) THEN + IF ( IAPROC .EQ. NAPBPT ) THEN #ifdef W3_MPI - IF (NRQBP2.NE.0) CALL MPI_WAITALL & - ( NRQBP2, IRQBP2,STATIO, IERR_MPI ) -#endif - CALL W3IOBC ( 'WRITE', NDS(10), & - TIME, TIME, ITEST, IMOD ) - END IF - ELSE IF ( J .EQ. 6 ) THEN - CALL W3IOSF ( NDS(13), IMOD ) + IF (NRQBP2.NE.0) CALL MPI_WAITALL( NRQBP2, IRQBP2, STATIO, IERR_MPI ) +#endif + CALL W3IOBC ( 'WRITE', NDS(10), TIME, TIME, ITEST, IMOD ) + END IF + + ELSE IF ( do_sf_output ) THEN + CALL W3IOSF ( NDS(13), IMOD ) #ifdef W3_OASIS - ELSE IF ( J .EQ. 7 ) THEN + ELSE IF ( do_coupler_output ) THEN ! ! Send variables to atmospheric or ocean circulation or ice model ! IF (DTOUT(7).NE.0) THEN - IF ( (MOD(ID_OASIS_TIME,NINT(DTOUT(7))) .EQ. 0 ) .AND. & - (DSEC21 (TIME00, TIME) .GT. 0.0) ) THEN - IF ( (CPLT0 .AND. (DSEC21 (TIME, TIMEN) .GT. 0.0)) .OR. & - .NOT. CPLT0 ) THEN - IF (CPLT0) ID_OASIS_TIME = NINT(DSEC21 ( TIME00 , TIME )) + IF ( (MOD(ID_OASIS_TIME,NINT(DTOUT(7))) .EQ. 0 ) .AND. & + (DSEC21 (TIME00, TIME) .GT. 0.0) ) THEN + IF ( (CPLT0 .AND. (DSEC21 (TIME, TIMEN) .GT. 0.0)) .OR. .NOT. CPLT0 ) THEN + IF (CPLT0) ID_OASIS_TIME = NINT(DSEC21 ( TIME00 , TIME )) -#endif #ifdef W3_OASACM - CALL SND_FIELDS_TO_ATMOS() + CALL SND_FIELDS_TO_ATMOS() #endif #ifdef W3_OASOCM - CALL SND_FIELDS_TO_OCEAN() + CALL SND_FIELDS_TO_OCEAN() #endif #ifdef W3_OASICM - CALL SND_FIELDS_TO_ICE() + CALL SND_FIELDS_TO_ICE() #endif -#ifdef W3_OASIS - IF (.NOT. CPLT0) ID_OASIS_TIME = NINT(DSEC21 ( TIME00 , TIME )) - ENDIF - ENDIF + IF (.NOT. CPLT0) ID_OASIS_TIME = NINT(DSEC21 ( TIME00 , TIME )) + ENDIF + ENDIF ENDIF #endif - END IF -! - CALL TICK21 ( TOUT, DTOUT(J) ) - TONEXT(:,J) = TOUT - TLST = TOLAST(:,J) - DTTST = DSEC21 ( TOUT , TLST ) - FLOUT(J) = DTTST.GE.0. - IF ( FLOUT(J) ) THEN - OUTID(2*J-1:2*J-1) = 'X' + END IF + ! + CALL TICK21 ( TOUT, DTOUT(J) ) + TONEXT(:,J) = TOUT + TLST = TOLAST(:,J) + DTTST = DSEC21 ( TOUT , TLST ) + FLOUT(J) = DTTST.GE.0. + IF ( FLOUT(J) ) THEN + OUTID(2*J-1:2*J-1) = 'X' #ifdef W3_OASIS - IF ( (DTOUT(7).NE.0) .AND. & - (DSEC21(TIME,TIME00).EQ.0 .OR. & - DSEC21(TIME,TIMEEND).EQ.0) ) OUTID(13:13) = ' ' + IF ( (DTOUT(7).NE.0) .AND. & + (DSEC21(TIME,TIME00).EQ.0 .OR. & + DSEC21(TIME,TIMEEND).EQ.0) ) OUTID(13:13) = ' ' #endif - ELSE - OUTID(2*J-1:2*J-1) = 'L' - END IF - END IF -! -! 4.e Update next output time -! + ELSE + OUTID(2*J-1:2*J-1) = 'L' + END IF + + END IF + ! + ! 4.e Update next output time + ! IF ( FLOUT(J) ) THEN - IF ( TOFRST(1).EQ.-1 ) THEN - TOFRST = TOUT - ELSE - DTTST = DSEC21 ( TOUT , TOFRST ) - IF ( DTTST.GT.0.) THEN - TOFRST = TOUT - END IF + IF ( TOFRST(1).EQ.-1 ) THEN + TOFRST = TOUT + ELSE + DTTST = DSEC21 ( TOUT , TOFRST ) + IF ( DTTST.GT.0.) THEN + TOFRST = TOUT END IF - END IF -! - END IF -! - END DO -! -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 3' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif - -! If there is a second stream of restart files then J=8 and FLOUT(8)=.TRUE. + END IF + END IF + ! + END IF + ! + END DO + ! + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE AFTER TIME LOOP 3') + ! + ! If there is a second stream of restart files then J=8 and FLOUT(8)=.TRUE. J=8 IF ( FLOUT(J) ) THEN -! -#ifdef W3_DEBUGRUN - WRITE(740+IAPROC,*) 'Matching FLOUT(J)' - FLUSH(740+IAPROC) -#endif -! -! 4.d Perform output -! - TOUT(:) = TONEXT(:,J) - DTTST = DSEC21 ( TIME, TOUT ) - IF ( DTTST .EQ. 0. ) THEN - CALL W3IORS ('HOT', NDS(6), XXX, IMOD, FLOUT(8) ) - ITEST = RSTYPE - CALL TICK21 ( TOUT, DTOUT(J) ) - TONEXT(:,J) = TOUT - TLST = TOLAST(:,J) - DTTST = DSEC21 ( TOUT , TLST ) - FLOUT(J) = DTTST.GE.0. - IF ( FLOUT(J) ) THEN - OUTID(2*J-1:2*J-1) = 'X' + if (w3_debugrun_flag) then + WRITE(740+IAPROC,*) 'Matching FLOUT(J)' + end if + ! + ! 4.d Perform output + ! + TOUT(:) = TONEXT(:,J) + DTTST = DSEC21 ( TIME, TOUT ) + IF ( DTTST .EQ. 0. ) THEN + CALL W3IORS ('HOT', NDS(6), XXX, IMOD, FLOUT(8) ) + ITEST = RSTYPE + CALL TICK21 ( TOUT, DTOUT(J) ) + TONEXT(:,J) = TOUT + TLST = TOLAST(:,J) + DTTST = DSEC21 ( TOUT , TLST ) + FLOUT(J) = DTTST.GE.0. + IF ( FLOUT(J) ) THEN + OUTID(2*J-1:2*J-1) = 'X' #ifdef W3_OASIS IF ( (DTOUT(7).NE.0) .AND. & - (DSEC21(TIME,TIME00).EQ.0 .OR. & - DSEC21(TIME,TIMEEND).EQ.0) ) OUTID(13:13) = ' ' + (DSEC21(TIME,TIME00).EQ.0 .OR. & + DSEC21(TIME,TIMEEND).EQ.0) ) OUTID(13:13) = ' ' #endif ELSE - OUTID(2*J-1:2*J-1) = 'L' + OUTID(2*J-1:2*J-1) = 'L' END IF - END IF -! -! 4.e Update next output time -! - IF ( FLOUT(J) ) THEN - IF ( TOFRST(1).EQ.-1 ) THEN - TOFRST = TOUT - ELSE - DTTST = DSEC21 ( TOUT , TOFRST ) - IF ( DTTST.GT.0.) THEN - TOFRST = TOUT - END IF + END IF + ! + ! 4.e Update next output time + ! + IF ( FLOUT(J) ) THEN + IF ( TOFRST(1).EQ.-1 ) THEN + TOFRST = TOUT + ELSE + DTTST = DSEC21 ( TOUT , TOFRST ) + IF ( DTTST.GT.0.) THEN + TOFRST = TOUT + END IF END IF - END IF + END IF END IF -! END OF CHECKPOINT -! -#ifdef W3_MEMCHECK - write(740+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 3' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC,mallInfos) -#endif - -! -#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 & - ( NRQRS, IRQRS , STATIO, IERR_MPI ) - IF ( FLGMPI(8) ) CALL MPI_WAITALL & - ( NRQRS, IRQRS , STATIO, IERR_MPI ) - IF ( FLGMPI(5) ) CALL MPI_WAITALL & - ( NRQBP, IRQBP1, STATIO, IERR_MPI ) + ! END OF CHECKPOINT + ! + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE AFTER TIME LOOP 3') + ! +#ifdef W3_MPI + IF ( FLGMPI(0) ) CALL MPI_WAITALL ( NRQGO, IRQGO , STATIO, IERR_MPI) + if (user_netcdf_grdout) then + IF ( FLGMPI(1) .and. ( IAPROC .EQ. NAPFLD ) ) then + CALL MPI_WAITALL ( NRQGO2, IRQGO2 , STATIO, IERR_MPI ) + end if + end if + IF ( FLGMPI(2) ) CALL MPI_WAITALL ( NRQPO, IRQPO1, STATIO, IERR_MPI ) + IF ( FLGMPI(4) ) CALL MPI_WAITALL ( NRQRS, IRQRS , STATIO, IERR_MPI ) + IF ( FLGMPI(8) ) CALL MPI_WAITALL ( NRQRS, IRQRS , STATIO, IERR_MPI ) + IF ( FLGMPI(5) ) CALL MPI_WAITALL ( NRQBP, IRQBP1, STATIO, IERR_MPI ) IF ( NRQMAX .NE. 0 ) DEALLOCATE ( STATIO ) #endif -! -#ifdef W3_T - WRITE (NDST,9044) -#endif -! -! This barrier is from older code versions. It has been removed in 3.11 -! to optimize IO2/3 settings. May be needed on some systems still -! -!!/MPI IF (FLDRY) CALL MPI_BARRIER (MPI_COMM_WAVE,IERR_MPI) -! - END IF -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Before update log file") -#endif - -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 4' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif - -! -! 5. Update log file ------------------------------------------------ / - -! IF (MINVAL(VA) .LT. 0.) THEN -! WRITE(740+IAPROC,*) 'TEST W3WAVE 13', SUM(VA), MINVAL(VA), MAXVAL(VA) -! CALL FLUSH(740+IAPROC) -! STOP -! ENDIF -! - IF ( IAPROC.EQ.NAPLOG ) THEN -! + ! + if (w3_t_flag) then + WRITE (NDST,9044) + end if + ! + ! This barrier is from older code versions. It has been removed in 3.11 + ! to optimize IO2/3 settings. May be needed on some systems still + ! + !!/MPI IF (FLDRY) CALL MPI_BARRIER (MPI_COMM_WAVE,IERR_MPI) + ! + END IF + if (w3_timings_flag) then + CALL PRINT_MY_TIME("Before update log file") + end if + ! + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE AFTER TIME LOOP 4') + ! + ! + ! 5. Update log file ------------------------------------------------ / + + ! IF (MINVAL(VA) .LT. 0.) THEN + ! WRITE(740+IAPROC,*) 'TEST W3WAVE 13', SUM(VA), MINVAL(VA), MAXVAL(VA) + ! STOP + ! ENDIF + ! + IF ( IAPROC.EQ.NAPLOG ) THEN + ! CALL STME21 ( TIME , IDTIME ) IF ( FLCUR ) THEN - DTTST = DSEC21 ( TIME , TCN ) - IF ( DTTST .EQ. 0. ) IDACT(7:7) = 'X' - END IF + DTTST = DSEC21 ( TIME , TCN ) + IF ( DTTST .EQ. 0. ) IDACT(7:7) = 'X' + END IF IF ( FLWIND ) THEN - DTTST = DSEC21 ( TIME , TWN ) - IF ( DTTST .EQ. 0. ) IDACT(3:3) = 'X' - END IF + DTTST = DSEC21 ( TIME , TWN ) + IF ( DTTST .EQ. 0. ) IDACT(3:3) = 'X' + END IF IF ( FLTAUA ) THEN - DTTST = DSEC21 ( TIME , TUN ) - IF ( DTTST .EQ. 0. ) IDACT(9:9) = 'X' - END IF + DTTST = DSEC21 ( TIME , TUN ) + IF ( DTTST .EQ. 0. ) IDACT(9:9) = 'X' + END IF IF ( FLRHOA ) THEN - DTTST = DSEC21 ( TIME , TRN ) - IF ( DTTST .EQ. 0. ) IDACT(11:11) = 'X' - END IF + DTTST = DSEC21 ( TIME , TRN ) + IF ( DTTST .EQ. 0. ) IDACT(11:11) = 'X' + END IF IF ( TDN(1) .GT. 0 ) THEN - DTTST = DSEC21 ( TIME , TDN ) - IF ( DTTST .EQ. 0. ) IDACT(21:21) = 'X' - END IF -! + DTTST = DSEC21 ( TIME , TDN ) + IF ( DTTST .EQ. 0. ) IDACT(21:21) = 'X' + END IF + ! IF ( IDLAST.NE.TIME(1) ) THEN - WRITE (NDSO,900) ITIME, IPASS, IDTIME(1:19), & - IDACT, OUTID - IDLAST = TIME(1) - ELSE - WRITE (NDSO,901) ITIME, IPASS, IDTIME(12:19), & - IDACT, OUTID - END IF -! - END IF -! - IDACT = ' ' - OUTID = ' ' - FLACT = .FALSE. -! -! 6. If time is not ending time, branch back to 2 ------------------- / -! - DTTST = DSEC21 ( TIME, TEND ) - IF ( DTTST .EQ. 0. ) EXIT -#ifdef W3_TIMINGS - CALL PRINT_MY_TIME("Continuing the loop") -#endif - END DO - -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE AFTER TIME LOOP 5' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif -! - + WRITE (NDSO,900) ITIME, IPASS, IDTIME(1:19), & + IDACT, OUTID + IDLAST = TIME(1) + ELSE + WRITE (NDSO,901) ITIME, IPASS, IDTIME(12:19), & + IDACT, OUTID + END IF + ! + END IF + ! + IDACT = ' ' + OUTID = ' ' + FLACT = .FALSE. + ! + ! 6. If time is not ending time, branch back to 2 ------------------- / + ! + DTTST = DSEC21 ( TIME, TEND ) + IF ( DTTST .EQ. 0. ) EXIT + if (w3_timings_flag) then + CALL PRINT_MY_TIME("Continuing the loop") + end if + END DO ! DO statement at 2. + ! + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE AFTER TIME LOOP 5') + ! IF ( TSTAMP .AND. SCREEN.NE.NDSO .AND. IAPROC.EQ.NAPOUT ) THEN CALL WWTIME ( STTIME ) WRITE (SCREEN,951) STTIME END IF IF ( IAPROC .EQ. NAPLOG ) WRITE (NDSO,902) -! + ! DEALLOCATE(FIELD) DEALLOCATE(TAUWX, TAUWY) -! -#ifdef W3_MEMCHECK - write(40000+IAPROC,*) 'memcheck_____:', 'WW3_WAVE END W3WAVE' - call getMallocInfo(mallinfos) - call printMallInfo(IAPROC+40000,mallInfos) -#endif -! + ! + call print_memcheck(memunit, 'memcheck_____:'// ' WW3_WAVE END W3WAVE') + ! RETURN -! -! Formats -! - 900 FORMAT (4X,I6,'|',I6,'| ', A19 ,' | ',A,' | ',A,' |') - 901 FORMAT (4X,I6,'|',I6,'| ',11X,A8,' | ',A,' | ',A,' |') - 902 FORMAT (2X,'--------+------+---------------------+' & + ! + ! Formats + ! +900 FORMAT (4X,I6,'|',I6,'| ', A19 ,' | ',A,' | ',A,' |') +901 FORMAT (4X,I6,'|',I6,'| ',11X,A8,' | ',A,' | ',A,' |') +902 FORMAT (2X,'--------+------+---------------------+' & ,'-----------------------+------------------+') -! -#ifdef W3_IC3 - 920 FORMAT (' Updating k and Cg from ice param. 1,2,3,4.'/) -#endif - 950 FORMAT (' WAVEWATCH III calculating for ',A,' at ',A) - 951 FORMAT (' WAVEWATCH III reached the end of a computation', & - ' loop at ',A) - 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & + ! +920 FORMAT (' Updating k and Cg from ice param. 1,2,3,4.'/) +950 FORMAT (' WAVEWATCH III calculating for ',A,' at ',A) +951 FORMAT (' WAVEWATCH III reached the end of a computation', & + ' loop at ',A) +1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & ' ENDING TIME BEFORE STARTING TIME '/) - 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & +1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & ' NEW WATER LEVEL BEFORE OLD WATER LEVEL '/) - 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & +1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & ' ILLEGAL CURRENT INTERVAL '/) - 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & +1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & ' ILLEGAL WIND INTERVAL '/) - 1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & +1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & ' NEW ICE FIELD BEFORE OLD ICE FIELD '/) - 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & +1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & ' NEW IC1 FIELD BEFORE OLD IC1 FIELD '/) - 1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & +1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & ' NEW ATM MOMENTUM BEFORE OLD ATM MOMENTUM '/) - 1008 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & +1008 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & ' NEW AIR DENSITY BEFORE OLD AIR DENSITY '/) -#ifdef W3_IS2 - 1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & +1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & ' NEW IC5 FIELD BEFORE OLD IC5 FIELD '/) -#endif - 1030 FORMAT (/' *** WAVEWATCH III WARING IN W3WAVE :'/ & - ' AT LEAST ONE PROCESSOR HAS 0 ACTIVE POINTS', & - ' IN GRID',I3) -#ifdef W3_REFRX - 1040 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & +1030 FORMAT (/' *** WAVEWATCH III WARING IN W3WAVE :'/ & + ' AT LEAST ONE PROCESSOR HAS 0 ACTIVE POINTS', & + ' IN GRID',I3) +1040 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ & ' EXPERIMENTAL FEATURE !/REFRX NOT FULLY IMPLEMENTED.'/) -#endif -! -#ifdef W3_T - 9000 FORMAT ( & - '============================================================', & - '===================='/ & - ' TEST W3WAVE : RUN MODEL',I3,' FILEXT [',A, & - '] UP TO ',I8.8,I7.6 / & - '====================', & - '============================================================') - 9010 FORMAT (' TEST W3WAVE : DT INT. =',F12.1,' FLZERO = ',L1) - 9011 FORMAT (' TEST W3WAVE : DT LEV. =',F12.1) - 9012 FORMAT (' TEST W3WAVE : DT CUR. =',F12.1/ & - ' ',F12.1/ & + ! +9000 FORMAT ( & + '============================================================', & + '===================='/ & + ' TEST W3WAVE : RUN MODEL',I3,' FILEXT [',A, & + '] UP TO ',I8.8,I7.6 / & + '====================', & + '============================================================') +9010 FORMAT (' TEST W3WAVE : DT INT. =',F12.1,' FLZERO = ',L1) +9011 FORMAT (' TEST W3WAVE : DT LEV. =',F12.1) +9012 FORMAT (' TEST W3WAVE : DT CUR. =',F12.1/ & + ' ',F12.1/ & ' ',F12.1) - 9013 FORMAT (' TEST W3WAVE : DT WIND =',F12.1/ & - ' ',F12.1/ & +9013 FORMAT (' TEST W3WAVE : DT WIND =',F12.1/ & + ' ',F12.1/ & ' ',F12.1) - 9014 FORMAT (' TEST W3WAVE : DT ICE =',F12.1) - 9015 FORMAT (' TEST W3WAVE : DT IC1 =',F12.1) - 9016 FORMAT (' TEST W3WAVE : DT IC5 =',F12.1) - 9017 FORMAT (' TEST W3WAVE : DT TAU =',F12.1) - 9018 FORMAT (' TEST W3WAVE : DT RHO =',F12.1) - 9020 FORMAT (' TEST W3WAVE : IT0, NT, DTG :',2I4,F8.1) - 9021 FORMAT (' TEST W3WAVE : ITIME etc',I6,I4,I10.8,I7.6,1X,2L1, & - 2F6.2,F7.1,F6.2) - 9022 FORMAT (' TEST W3WAVE : SKIP TO 400 IN 3.5') - 9023 FORMAT (' TEST W3WAVE : SKIP TO 380 IN 3.5') - 9030 FORMAT (' TEST W3WAVE : END OF COMPUTATION LOOP') - 9040 FORMAT (' TEST W3WAVE : CHECKING FOR OUTPUT'/ & - ' TOFRST :',I9.8,I7.6/ & - ' TND :',I9.8,I7.6/ & +9014 FORMAT (' TEST W3WAVE : DT ICE =',F12.1) +9015 FORMAT (' TEST W3WAVE : DT IC1 =',F12.1) +9016 FORMAT (' TEST W3WAVE : DT IC5 =',F12.1) +9017 FORMAT (' TEST W3WAVE : DT TAU =',F12.1) +9018 FORMAT (' TEST W3WAVE : DT RHO =',F12.1) +9020 FORMAT (' TEST W3WAVE : IT0, NT, DTG :',2I4,F8.1) +9021 FORMAT (' TEST W3WAVE : ITIME etc',I6,I4,I10.8,I7.6,1X,2L1, & + 2F6.2,F7.1,F6.2) +9022 FORMAT (' TEST W3WAVE : SKIP TO 400 IN 3.5') +9023 FORMAT (' TEST W3WAVE : SKIP TO 380 IN 3.5') +9030 FORMAT (' TEST W3WAVE : END OF COMPUTATION LOOP') +9040 FORMAT (' TEST W3WAVE : CHECKING FOR OUTPUT'/ & + ' TOFRST :',I9.8,I7.6/ & + ' TND :',I9.8,I7.6/ & ' DTTST[1], FLAG_O :',2F8.1,L4) - 9041 FORMAT (' TEST W3WAVE : PERFORMING OUTPUT') - 9042 FORMAT (' TEST W3WAVE : OUTPUT COMPUTATION FLAGS: ',3L2) -#endif -#ifdef W3_MPIT - 9043 FORMAT (' TEST W3WAVE : TYPE, NRQ, NRQMAX, NA : ',A2,3I6) -#endif -#ifdef W3_T - 9044 FORMAT (' TEST W3WAVE : END OF OUTPUT') -#endif -!/ -!/ End of W3WAVE ----------------------------------------------------- / -!/ - END SUBROUTINE W3WAVE -!/ ------------------------------------------------------------------- / - SUBROUTINE W3GATH ( ISPEC, FIELD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 26-Dec-2012 | -!/ +-----------------------------------+ -!/ -!/ 04-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Major changes to logistics. -!/ 29-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 13-Jun-2006 : Split STORE in G/SSTORE ( version 3.09 ) -!/ 26-Dec-2012 : Move FIELD init. to W3GATH. ( version 4.OF ) -!/ -! 1. Purpose : -! -! Gather spectral bin information into a propagation field array. -! -! 2. Method : -! -! Direct copy or communication calls (MPP version). -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ISPEC Int. I Spectral bin considered. -! FIELD R.A. O Full field to be propagated. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! -! MPI_STARTALL, MPI_WAITALL -! Subr. mpif.h MPI persistent comm. routines (!/MPI). -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - The field is extracted but not converted. -! - MPI version requires posing of send and receive calls in -! W3WAVE to match local calls. -! - MPI version does not require an MPI_TESTALL call for the -! posted gather operation as MPI_WAITALL is mandatory to -! reset persistent communication for next time step. -! - MPI version allows only two new pre-fetch postings per -! call to minimize chances to be slowed down by gathers that -! are not yet needed, while maximizing the pre-loading -! during the early (low-frequency) calls to the routine -! where the amount of calculation needed for proagation is -! the largest. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Switch for message passing method. -! !/MPI Id. -! -! !/S Enable subroutine tracing. -! !/MPIT MPI test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ +9041 FORMAT (' TEST W3WAVE : PERFORMING OUTPUT') +9042 FORMAT (' TEST W3WAVE : OUTPUT COMPUTATION FLAGS: ',3L2) +9043 FORMAT (' TEST W3WAVE : TYPE, NRQ, NRQMAX, NA : ',A2,3I6) +9044 FORMAT (' TEST W3WAVE : END OF OUTPUT') + !/ + !/ End of W3WAVE ----------------------------------------------------- / + !/ + END SUBROUTINE W3WAVE + !/ ------------------------------------------------------------------- / + SUBROUTINE W3GATH ( ISPEC, FIELD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 26-Dec-2012 | + !/ +-----------------------------------+ + !/ + !/ 04-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) + !/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Major changes to logistics. + !/ 29-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 13-Jun-2006 : Split STORE in G/SSTORE ( version 3.09 ) + !/ 26-Dec-2012 : Move FIELD init. to W3GATH. ( version 4.OF ) + !/ + ! 1. Purpose : + ! + ! Gather spectral bin information into a propagation field array. + ! + ! 2. Method : + ! + ! Direct copy or communication calls (MPP version). + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ISPEC Int. I Spectral bin considered. + ! FIELD R.A. O Full field to be propagated. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! + ! MPI_STARTALL, MPI_WAITALL + ! Subr. mpif.h MPI persistent comm. routines (!/MPI). + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - The field is extracted but not converted. + ! - MPI version requires posing of send and receive calls in + ! W3WAVE to match local calls. + ! - MPI version does not require an MPI_TESTALL call for the + ! posted gather operation as MPI_WAITALL is mandatory to + ! reset persistent communication for next time step. + ! - MPI version allows only two new pre-fetch postings per + ! call to minimize chances to be slowed down by gathers that + ! are not yet needed, while maximizing the pre-loading + ! during the early (low-frequency) calls to the routine + ! where the amount of calculation needed for proagation is + ! the largest. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Switch for message passing method. + ! !/MPI Id. + ! + ! !/S Enable subroutine tracing. + ! !/MPIT MPI test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: STRACE ! W3_S + !/ USE W3GDATMD, ONLY: NSPEC, NX, NY, NSEA, NSEAL, MAPSF, DMIN USE W3PARALL, ONLY: INIT_GET_ISEA USE W3WDATMD, ONLY: A => VA -#ifdef W3_MPI - USE W3ADATMD, ONLY: MPIBUF, BSTAT, IBFLOC, ISPLOC, BISPL, & - NSPLOC, NRQSG2, IRQSG2, GSTORE - USE W3ODATMD, ONLY: NDST, IAPROC, NAPROC, NOTYPE -#endif -!/ - IMPLICIT NONE -! + USE W3ADATMD, ONLY: MPIBUF, BSTAT, IBFLOC, ISPLOC, BISPL ! W3_MPI + USE W3ADATMD, ONLY: NSPLOC, NRQSG2, IRQSG2, GSTORE ! W3_MPI + USE W3ODATMD, ONLY: NDST, IAPROC, NAPROC, NOTYPE ! W3_MPI + !/ + ! #ifdef W3_MPI INCLUDE "mpif.h" #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ INTEGER, INTENT(IN) :: ISPEC REAL, INTENT(OUT) :: FIELD(1-NY:NY*(NX+2)) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -#ifdef W3_SHRD - INTEGER :: ISEA, IXY -#endif -#ifdef W3_MPI - INTEGER :: STATUS(MPI_STATUS_SIZE,NSPEC), & - IOFF, IERR_MPI, JSEA, ISEA, & - IXY, IS0, IB0, NPST, J -#endif -#ifdef W3_S - INTEGER, SAVE :: IENT -#endif -#ifdef W3_MPIT - CHARACTER(LEN=15) :: STR(MPIBUF), STRT -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3GATH') -#endif -! - FIELD = 0. -! -! 1. Shared memory version ------------------------------------------ / -! + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ISEA, JSEA, IXY +#ifdef W3_MPI + INTEGER :: STATUS(MPI_STATUS_SIZE,NSPEC) +#endif + INTEGER :: IOFF, IERR_MPI ! W3_MPI + INTEGER :: IS0, IB0, NPST, J ! W3_MPI + CHARACTER(LEN=15) :: STR(MPIBUF), STRT ! W3_MPIT + INTEGER, SAVE :: IENT ! W3_S + !/ + !/ ------------------------------------------------------------------- / + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'W3GATH') + end if + ! + FIELD = 0. + ! + ! 1. Shared memory version ------------------------------------------ / + ! #ifdef W3_SHRD DO ISEA=1, NSEA - IXY = MAPSF(ISEA,3) - FIELD(IXY) = A(ISPEC,ISEA) - END DO -#endif -! -#ifdef W3_SHRD + IXY = MAPSF(ISEA,3) + FIELD(IXY) = A(ISPEC,ISEA) + END DO + RETURN #endif -! -! 2. Distributed memory version ( MPI ) ----------------------------- / -! 2.a Update counters -! #ifdef W3_MPI + ! + ! 2. Distributed memory version ( MPI ) ----------------------------- / + ! 2.a Update counters + ! ISPLOC = ISPLOC + 1 IBFLOC = IBFLOC + 1 IF ( IBFLOC .GT. MPIBUF ) IBFLOC = 1 -#endif -! -#ifdef W3_MPIT - IF ( ISPLOC .EQ. 1 ) THEN - STR = '--------------+' - WRITE (NDST,9000) STR - END IF - STR = ' |' - STRT = STR(IBFLOC) - STRT(9:9) = 'A' -#endif -! -! 2.b Check status of present buffer -! 2.b.1 Scatter (send) still in progress, wait to end -! -#ifdef W3_MPI + ! + if (w3_mpit_flag) then + IF ( ISPLOC .EQ. 1 ) THEN + STR = '--------------+' + WRITE (NDST,9000) STR + END IF + STR = ' |' + STRT = STR(IBFLOC) + STRT(9:9) = 'A' + end if + ! + ! 2.b Check status of present buffer + ! 2.b.1 Scatter (send) still in progress, wait to end + ! IF ( BSTAT(IBFLOC) .EQ. 2 ) THEN - IOFF = 1 + (BISPL(IBFLOC)-1)*NRQSG2 - IF ( NRQSG2 .GT. 0 ) CALL & - MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & - STATUS, IERR_MPI ) - BSTAT(IBFLOC) = 0 -#endif -#ifdef W3_MPIT - STRT(13:13) = 'S' -#endif -#ifdef W3_MPI - END IF -#endif -! -! 2.b.2 Gather (recv) not yet posted, post now -! -#ifdef W3_MPI + IOFF = 1 + (BISPL(IBFLOC)-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & + STATUS, IERR_MPI ) + BSTAT(IBFLOC) = 0 + if (w3_mpit_flag) then + STRT(13:13) = 'S' + end if + END IF + ! + ! 2.b.2 Gather (recv) not yet posted, post now + ! IF ( BSTAT(IBFLOC) .EQ. 0 ) THEN - BSTAT(IBFLOC) = 1 - BISPL(IBFLOC) = ISPLOC - IOFF = 1 + (ISPLOC-1)*NRQSG2 - IF ( NRQSG2 .GT. 0 ) CALL & - MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,1), IERR_MPI ) -#endif -#ifdef W3_MPIT - STRT(10:10) = 'g' -#endif -#ifdef W3_MPI - END IF -#endif -! -! 2.c Put local spectral densities in store -! -#ifdef W3_MPI + BSTAT(IBFLOC) = 1 + BISPL(IBFLOC) = ISPLOC + IOFF = 1 + (ISPLOC-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,1), IERR_MPI ) + + if (w3_mpit_flag) then + STRT(10:10) = 'g' + end if + END IF + ! + ! 2.c Put local spectral densities in store + ! DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - GSTORE(ISEA,IBFLOC) = A(ISPEC,JSEA) - END DO -#endif -! -! 2.d Wait for remote spectral densities -! -#ifdef W3_MPI + CALL INIT_GET_ISEA(ISEA, JSEA) + GSTORE(ISEA,IBFLOC) = A(ISPEC,JSEA) + END DO + ! + ! 2.d Wait for remote spectral densities + ! IOFF = 1 + (BISPL(IBFLOC)-1)*NRQSG2 - IF ( NRQSG2 .GT. 0 ) CALL & - MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,1), STATUS, IERR_MPI ) -#endif -! -#ifdef W3_MPIT - STRT(11:11) = 'G' - WRITE (STRT(1:7),'(I2,I5)') BSTAT(IBFLOC), ISPLOC - STR(IBFLOC) = STRT -#endif -! -! 2.e Convert storage array to field. -! -#ifdef W3_MPI + IF ( NRQSG2 .GT. 0 ) CALL MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,1), STATUS, IERR_MPI ) + ! + if (w3_mpit_flag) then + STRT(11:11) = 'G' + WRITE (STRT(1:7),'(I2,I5)') BSTAT(IBFLOC), ISPLOC + STR(IBFLOC) = STRT + end if + ! + ! 2.e Convert storage array to field. + ! DO ISEA=1, NSEA - IXY = MAPSF(ISEA,3) - FIELD(IXY) = GSTORE(ISEA,IBFLOC) - END DO -#endif -! -! 2.f Pre-fetch data in available buffers -! -#ifdef W3_MPI + IXY = MAPSF(ISEA,3) + FIELD(IXY) = GSTORE(ISEA,IBFLOC) + END DO + ! + ! 2.f Pre-fetch data in available buffers + ! IS0 = ISPLOC IB0 = IBFLOC NPST = 0 -#endif -! -#ifdef W3_MPI + ! DO J=1, MPIBUF-1 - IS0 = IS0 + 1 - IF ( IS0 .GT. NSPLOC ) EXIT - IB0 = 1 + MOD(IB0,MPIBUF) - IF ( BSTAT(IB0) .EQ. 0 ) THEN + IS0 = IS0 + 1 + IF ( IS0 .GT. NSPLOC ) EXIT + IB0 = 1 + MOD(IB0,MPIBUF) + IF ( BSTAT(IB0) .EQ. 0 ) THEN BSTAT(IB0) = 1 BISPL(IB0) = IS0 IOFF = 1 + (IS0-1)*NRQSG2 IF ( NRQSG2 .GT. 0 ) CALL & MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,1), IERR_MPI ) NPST = NPST + 1 -#endif -#ifdef W3_MPIT - STRT = STR(IB0) - STRT(10:10) = 'g' - WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) - STR(IB0) = STRT -#endif -#ifdef W3_MPI - END IF - IF ( NPST .GE. 2 ) EXIT - END DO -#endif -! -! 2.g Test output -! -#ifdef W3_MPIT - DO IB0=1, MPIBUF - STRT = STR(IB0) - IF ( STRT(2:2) .EQ. ' ' ) THEN - IF ( BSTAT(IB0) .EQ. 0 ) THEN - WRITE (STRT(1:2),'(I2)') BSTAT(IB0) - ELSE - WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) - END IF - STR(IB0) = STRT - END IF - END DO - WRITE (NDST,9010) ISPLOC, STR -#endif -! -#ifdef W3_MPI + + if (w3_mpit_flag) then + STRT = STR(IB0) + STRT(10:10) = 'g' + WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) + STR(IB0) = STRT + end if + + END IF + IF ( NPST .GE. 2 ) EXIT + END DO + ! + ! 2.g Test output + ! + if (w3_mpit_flag) then + DO IB0=1, MPIBUF + STRT = STR(IB0) + IF ( STRT(2:2) .EQ. ' ' ) THEN + IF ( BSTAT(IB0) .EQ. 0 ) THEN + WRITE (STRT(1:2),'(I2)') BSTAT(IB0) + ELSE + WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) + END IF + STR(IB0) = STRT + END IF + END DO + WRITE (NDST,9010) ISPLOC, STR + end if + ! RETURN #endif -! -! Formats -! -#ifdef W3_MPIT - 9000 FORMAT ( ' TEST OF BUFFER MANAGEMENT MPI :'/ & - ' -------------------------------'/ & - ' RECORDS ALTERNATELY WRITTEN BY W3GATH AND W3SCAT'/ & - ' FRIST COLLUMN : LOCAL ISPEC'/ & - ' OTHER COLLUMNS : BUFFER STATUS INDICATOR '/ & - ' 0 : INACTIVE'/ & - ' 1 : RECEIVING'/ & - ' 2 : SENDING'/ & - ' LOCAL ISPEC FOR BUFFER'/ & - ' A : ACTIVE BUFFER'/ & - ' g/G: START/FINISH RECIEVE'/ & - ' s/S: START/FINISH SEND'/ & - ' +-----+',8A15) - 9010 FORMAT ( ' |',I4,' |',8A15) -#endif -!/ -!/ End of W3GATH ----------------------------------------------------- / -!/ - END SUBROUTINE W3GATH -!/ ------------------------------------------------------------------- / - SUBROUTINE W3SCAT ( ISPEC, MAPSTA, FIELD ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 13-Jun-2006 | -!/ +-----------------------------------+ -!/ -!/ 04-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) -!/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) -!/ Major changes to logistics. -!/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ 07-Sep-2005 : Updated boundary conditions. ( version 3.08 ) -!/ 13-Jun-2006 : Split STORE in G/SSTORE ( version 3.09 ) -!/ -! 1. Purpose : -! -! 'Scatter' data back to spectral storage after propagation. -! -! 2. Method : -! -! Direct copy or communication calls (MPP version). -! See also W3GATH. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! ISPEC Int. I Spectral bin considered. -! MAPSTA I.A. I Status map for spatial grid. -! FIELD R.A. I Full field to be propagated. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! -! MPI_STARTALL, MPI_WAITALL, MPI_TESTALL -! Subr. mpif.h MPI persistent comm. routines (!/MPI). -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! - The field is put back but not converted ! -! - MPI persistent communication calls initialize in W3MPII. -! - See W3GATH and W3MPII for additional comments on data -! buffering. -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/SHRD Switch for message passing method. -! !/MPI Id. -! -! !/S Enable subroutine tracing. -! !/MPIT MPI test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / + ! + ! Formats + ! +9000 FORMAT ( ' TEST OF BUFFER MANAGEMENT MPI :'/ & + ' -------------------------------'/ & + ' RECORDS ALTERNATELY WRITTEN BY W3GATH AND W3SCAT'/ & + ' FRIST COLLUMN : LOCAL ISPEC'/ & + ' OTHER COLLUMNS : BUFFER STATUS INDICATOR '/ & + ' 0 : INACTIVE'/ & + ' 1 : RECEIVING'/ & + ' 2 : SENDING'/ & + ' LOCAL ISPEC FOR BUFFER'/ & + ' A : ACTIVE BUFFER'/ & + ' g/G: START/FINISH RECIEVE'/ & + ' s/S: START/FINISH SEND'/ & + ' +-----+',8A15) +9010 FORMAT ( ' |',I4,' |',8A15) + !/ + !/ End of W3GATH ----------------------------------------------------- / + !/ + END SUBROUTINE W3GATH + !/ ------------------------------------------------------------------- / + SUBROUTINE W3SCAT ( ISPEC, MAPSTA, FIELD ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 13-Jun-2006 | + !/ +-----------------------------------+ + !/ + !/ 04-Jan-1999 : Distributed FORTRAN 77 version. ( version 1.18 ) + !/ 13-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) + !/ Major changes to logistics. + !/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ 07-Sep-2005 : Updated boundary conditions. ( version 3.08 ) + !/ 13-Jun-2006 : Split STORE in G/SSTORE ( version 3.09 ) + !/ + ! 1. Purpose : + ! + ! 'Scatter' data back to spectral storage after propagation. + ! + ! 2. Method : + ! + ! Direct copy or communication calls (MPP version). + ! See also W3GATH. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! ISPEC Int. I Spectral bin considered. + ! MAPSTA I.A. I Status map for spatial grid. + ! FIELD R.A. I Full field to be propagated. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! + ! MPI_STARTALL, MPI_WAITALL, MPI_TESTALL + ! Subr. mpif.h MPI persistent comm. routines (!/MPI). + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! - The field is put back but not converted ! + ! - MPI persistent communication calls initialize in W3MPII. + ! - See W3GATH and W3MPII for additional comments on data + ! buffering. + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/SHRD Switch for message passing method. + ! !/MPI Id. + ! + ! !/S Enable subroutine tracing. + ! !/MPIT MPI test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY: NSEA, NSEAL, MAPSF, NSPEC, NX, NY -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ + USE W3SERVMD, ONLY: STRACE ! W3_S + !/ USE W3WDATMD, ONLY: A => VA -#ifdef W3_MPI - USE W3ADATMD, ONLY: MPIBUF, BSTAT, IBFLOC, ISPLOC, BISPL, & - NSPLOC, NRQSG2, IRQSG2, SSTORE -#endif - USE W3ODATMD, ONLY: NDST -#ifdef W3_MPI - USE W3ODATMD, ONLY: IAPROC, NAPROC -#endif - USE CONSTANTS, ONLY : LPDLIB - USE W3PARALL, only: INIT_GET_ISEA -!/ - IMPLICIT NONE -! + USE W3ADATMD , ONLY : MPIBUF, BSTAT, IBFLOC, ISPLOC, BISPL, NSPLOC, NRQSG2, IRQSG2, SSTORE ! W3_MPI + USE W3ODATMD , ONLY : NDST + USE W3ODATMD , ONLY : IAPROC, NAPROC ! W3_MPI + USE CONSTANTS , ONLY : LPDLIB + USE W3PARALL , only : INIT_GET_ISEA + !/ + ! #ifdef W3_MPI INCLUDE "mpif.h" #endif -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ INTEGER, INTENT(IN) :: ISPEC, MAPSTA(NY*NX) REAL, INTENT(IN) :: FIELD(1-NY:NY*(NX+2)) -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ -#ifdef W3_SHRD - INTEGER :: ISEA, IXY -#endif -#ifdef W3_MPI - INTEGER :: ISEA, IXY, IOFF, IERR_MPI, J, & - STATUS(MPI_STATUS_SIZE,NSPEC), & - JSEA, IB0 -#endif -#ifdef W3_S - INTEGER, SAVE :: IENT -#endif -#ifdef W3_MPIT - CHARACTER(LEN=15) :: STR(MPIBUF), STRT -#endif -#ifdef W3_MPI - LOGICAL :: DONE -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3SCAT') -#endif -! -! 1. Shared memory version ------------------------------------------ * -! + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ + INTEGER :: ISEA, JSEA, IXY + INTEGER :: IOFF, IERR_MPI, J ! W3_MPI +#ifdef W3_MPI + INTEGER :: STATUS(MPI_STATUS_SIZE,NSPEC) ! W3_MPI +#endif + INTEGER :: IB0 ! W3_MPI + CHARACTER(LEN=15) :: STR(MPIBUF), STRT ! W3_MPIT + LOGICAL :: DONE ! W3_MPI + INTEGER, SAVE :: IENT ! W3_S + !/ + !/ ------------------------------------------------------------------- / + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'W3SCAT') + end if + ! + ! 1. Shared memory version ------------------------------------------ * + ! #ifdef W3_SHRD DO ISEA=1, NSEA - IXY = MAPSF(ISEA,3) - IF ( MAPSTA(IXY) .NE. 0 ) A(ISPEC,ISEA) = FIELD(IXY) - END DO -#endif -! -#ifdef W3_SHRD + IXY = MAPSF(ISEA,3) + IF ( MAPSTA(IXY) .NE. 0 ) A(ISPEC,ISEA) = FIELD(IXY) + END DO + ! RETURN #endif -! -! 2. Distributed memory version ( MPI ) ----------------------------- * -! 2.a Initializations -! -#ifdef W3_MPIT - DO IB0=1, MPIBUF - STR(IB0) = ' |' - END DO -#endif -! -#ifdef W3_MPIT - STRT = STR(IBFLOC) - STRT(9:9) = 'A' -#endif -! -! 2.b Convert full grid to sea grid, active points only -! #ifdef W3_MPI + ! + ! 2. Distributed memory version ( MPI ) ----------------------------- * + ! 2.a Initializations + ! + if (w3_mpit_flag) then + DO IB0=1, MPIBUF + STR(IB0) = ' |' + END DO + STRT = STR(IBFLOC) + STRT(9:9) = 'A' + end if + ! + ! 2.b Convert full grid to sea grid, active points only + ! DO ISEA=1, NSEA - IXY = MAPSF(ISEA,3) - IF ( MAPSTA(IXY) .NE. 0 ) SSTORE(ISEA,IBFLOC) = FIELD(IXY) - END DO -#endif -! -! 2.c Send spectral densities to appropriate remote -! -#ifdef W3_MPI + IXY = MAPSF(ISEA,3) + IF ( MAPSTA(IXY) .NE. 0 ) SSTORE(ISEA,IBFLOC) = FIELD(IXY) + END DO + ! + ! 2.c Send spectral densities to appropriate remote + ! IOFF = 1 + (ISPLOC-1)*NRQSG2 - IF ( NRQSG2 .GT. 0 ) CALL & - MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,2), IERR_MPI ) + IF ( NRQSG2 .GT. 0 ) CALL MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,2), IERR_MPI ) BSTAT(IBFLOC) = 2 -#endif -#ifdef W3_MPIT - STRT(12:12) = 's' - WRITE (STRT(1:7),'(I2,I5)') BSTAT(IBFLOC), ISPLOC - STR(IBFLOC) = STRT -#endif -! -! 2.d Save locally stored results -! -#ifdef W3_MPI + if (w3_mpit_flag) then + STRT(12:12) = 's' + WRITE (STRT(1:7),'(I2,I5)') BSTAT(IBFLOC), ISPLOC + STR(IBFLOC) = STRT + end if + ! + ! 2.d Save locally stored results + ! DO JSEA=1, NSEAL - CALL INIT_GET_ISEA(ISEA, JSEA) - IXY = MAPSF(ISEA,3) - IF (MAPSTA(IXY) .NE. 0) A(ISPEC,JSEA) = SSTORE(ISEA,IBFLOC) - END DO -#endif -! -! 2.e Check if any sends have finished -! -#ifdef W3_MPI + CALL INIT_GET_ISEA(ISEA, JSEA) + IXY = MAPSF(ISEA,3) + IF (MAPSTA(IXY) .NE. 0) A(ISPEC,JSEA) = SSTORE(ISEA,IBFLOC) + END DO + ! + ! 2.e Check if any sends have finished + ! IB0 = IBFLOC -#endif -! -#ifdef W3_MPI + ! DO J=1, MPIBUF - IB0 = 1 + MOD(IB0,MPIBUF) - IF ( BSTAT(IB0) .EQ. 2 ) THEN + IB0 = 1 + MOD(IB0,MPIBUF) + IF ( BSTAT(IB0) .EQ. 2 ) THEN IOFF = 1 + (BISPL(IB0)-1)*NRQSG2 IF ( NRQSG2 .GT. 0 ) THEN - CALL MPI_TESTALL ( NRQSG2, IRQSG2(IOFF,2), DONE, & - STATUS, IERR_MPI ) - ELSE - DONE = .TRUE. - END IF - IF ( DONE .AND. NRQSG2.GT.0 ) CALL & - MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & - STATUS, IERR_MPI ) + CALL MPI_TESTALL ( NRQSG2, IRQSG2(IOFF,2), DONE, STATUS, IERR_MPI ) + ELSE + DONE = .TRUE. + END IF + IF ( DONE .AND. NRQSG2.GT.0 ) THEN + CALL MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), STATUS, IERR_MPI ) + END IF IF ( DONE ) THEN - BSTAT(IB0) = 0 -#endif -#ifdef W3_MPIT - STRT = STR(IB0) - WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) - STRT(13:13) = 'S' - STR(IB0) = STRT -#endif -#ifdef W3_MPI - END IF - END IF - END DO -#endif -! -! 2.f Last component, finish message passing, reset buffer control -! -#ifdef W3_MPI + BSTAT(IB0) = 0 + if (w3_mpit_flag) then + STRT = STR(IB0) + WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) + STRT(13:13) = 'S' + STR(IB0) = STRT + end if + END IF + END IF + END DO + ! + ! 2.f Last component, finish message passing, reset buffer control + ! IF ( ISPLOC .EQ. NSPLOC ) THEN -#endif -! -#ifdef W3_MPI - DO IB0=1, MPIBUF + ! + DO IB0=1, MPIBUF IF ( BSTAT(IB0) .EQ. 2 ) THEN - IOFF = 1 + (BISPL(IB0)-1)*NRQSG2 - IF ( NRQSG2 .GT. 0 ) CALL & - MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & - STATUS, IERR_MPI ) - BSTAT(IB0) = 0 -#endif -#ifdef W3_MPIT - STRT = STR(IB0) - WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) - STRT(13:13) = 'S' - STR(IB0) = STRT -#endif -#ifdef W3_MPI - END IF - END DO -#endif -! -#ifdef W3_MPI - ISPLOC = 0 - IBFLOC = 0 -#endif -! -#ifdef W3_MPI - END IF -#endif -! -! 2.g Test output -! -#ifdef W3_MPIT - DO IB0=1, MPIBUF - STRT = STR(IB0) - IF ( STRT(2:2) .EQ. ' ' ) THEN - IF ( BSTAT(IB0) .EQ. 0 ) THEN - WRITE (STRT(1:2),'(I2)') BSTAT(IB0) - ELSE - WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) - END IF - STR(IB0) = STRT - END IF - END DO -#endif -! -#ifdef W3_MPIT - WRITE (NDST,9000) STR -#endif -! -#ifdef W3_MPIT - IF ( ISPLOC .EQ. 0 ) THEN - DO IB0=1, MPIBUF - STR(IB0) = '--------------+' + IOFF = 1 + (BISPL(IB0)-1)*NRQSG2 + IF ( NRQSG2 .GT. 0 ) CALL & + MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), & + STATUS, IERR_MPI ) + BSTAT(IB0) = 0 + if (w3_mpit_flag) then + STRT = STR(IB0) + WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) + STRT(13:13) = 'S' + STR(IB0) = STRT + end if + END IF + END DO + ! + ISPLOC = 0 + IBFLOC = 0 + ! + END IF + + ! + ! 2.g Test output + ! + if (w3_mpit_flag) then + DO IB0=1, MPIBUF + STRT = STR(IB0) + IF ( STRT(2:2) .EQ. ' ' ) THEN + IF ( BSTAT(IB0) .EQ. 0 ) THEN + WRITE (STRT(1:2),'(I2)') BSTAT(IB0) + ELSE + WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0) + END IF + STR(IB0) = STRT + END IF + END DO + WRITE (NDST,9000) STR + IF ( ISPLOC .EQ. 0 ) THEN + DO IB0=1, MPIBUF + STR(IB0) = '--------------+' END DO - WRITE (NDST,9010) STR - WRITE (NDST,*) - END IF -#endif -! -#ifdef W3_MPI + WRITE (NDST,9010) STR + WRITE (NDST,*) + END IF + end if + ! RETURN #endif -! -! Formats -! -#ifdef W3_MPIT - 9000 FORMAT ( ' | |',8A15) - 9010 FORMAT ( ' +-----+',8A15) -#endif -!/ -!/ End of W3SCAT ----------------------------------------------------- / -!/ - END SUBROUTINE W3SCAT -!/ ------------------------------------------------------------------- / - SUBROUTINE W3NMIN ( MAPSTA, FLAG0 ) -!/ -!/ +-----------------------------------+ -!/ | WAVEWATCH III NOAA/NCEP | -!/ | H. L. Tolman | -!/ | FORTRAN 90 | -!/ | Last update : 28-Dec-2004 | -!/ +-----------------------------------+ -!/ -!/ 23-Feb-2001 : Origination. ( version 2.07 ) -!/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) -!/ -! 1. Purpose : -! -! Check minimum number of active sea points at given processor to -! evaluate the need for a MPI_BARRIER call. -! -! 2. Method : -! -! Evaluate mapsta. -! -! 3. Parameters : -! -! Parameter list -! ---------------------------------------------------------------- -! MAPSTA I.A. I Status map for spatial grid. -! FLAG0 log. O Flag to identify 0 as minimum. -! ---------------------------------------------------------------- -! -! 4. Subroutines used : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! STRACE Subr. W3SERVMD Subroutine tracing. -! ---------------------------------------------------------------- -! -! 5. Called by : -! -! Name Type Module Description -! ---------------------------------------------------------------- -! W3WAVE Subr. W3WAVEMD Actual wave model routine. -! ---------------------------------------------------------------- -! -! 6. Error messages : -! -! None. -! -! 7. Remarks : -! -! 8. Structure : -! -! See source code. -! -! 9. Switches : -! -! !/S Enable subroutine tracing. -! !/T Test output. -! -! 10. Source code : -! -!/ ------------------------------------------------------------------- / -#ifdef W3_S - USE W3SERVMD, ONLY: STRACE -#endif -!/ + ! + ! Formats + ! +9000 FORMAT ( ' | |',8A15) +9010 FORMAT ( ' +-----+',8A15) + !/ + !/ End of W3SCAT ----------------------------------------------------- / + !/ + END SUBROUTINE W3SCAT + !/ ------------------------------------------------------------------- / + SUBROUTINE W3NMIN ( MAPSTA, FLAG0 ) + !/ + !/ +-----------------------------------+ + !/ | WAVEWATCH III NOAA/NCEP | + !/ | H. L. Tolman | + !/ | FORTRAN 90 | + !/ | Last update : 28-Dec-2004 | + !/ +-----------------------------------+ + !/ + !/ 23-Feb-2001 : Origination. ( version 2.07 ) + !/ 28-Dec-2004 : Multiple grid version. ( version 3.06 ) + !/ + ! 1. Purpose : + ! + ! Check minimum number of active sea points at given processor to + ! evaluate the need for a MPI_BARRIER call. + ! + ! 2. Method : + ! + ! Evaluate mapsta. + ! + ! 3. Parameters : + ! + ! Parameter list + ! ---------------------------------------------------------------- + ! MAPSTA I.A. I Status map for spatial grid. + ! FLAG0 log. O Flag to identify 0 as minimum. + ! ---------------------------------------------------------------- + ! + ! 4. Subroutines used : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! STRACE Subr. W3SERVMD Subroutine tracing. + ! ---------------------------------------------------------------- + ! + ! 5. Called by : + ! + ! Name Type Module Description + ! ---------------------------------------------------------------- + ! W3WAVE Subr. W3WAVEMD Actual wave model routine. + ! ---------------------------------------------------------------- + ! + ! 6. Error messages : + ! + ! None. + ! + ! 7. Remarks : + ! + ! 8. Structure : + ! + ! See source code. + ! + ! 9. Switches : + ! + ! !/S Enable subroutine tracing. + ! !/T Test output. + ! + ! 10. Source code : + ! + !/ ------------------------------------------------------------------- / + USE W3SERVMD, ONLY: STRACE ! W3_S + !/ USE W3GDATMD, ONLY: NSEA, MAPSF, NX, NY USE W3ODATMD, ONLY: NDST, NAPROC USE W3PARALL, ONLY: INIT_GET_JSEA_ISPROC -!/ - IMPLICIT NONE -!/ -!/ ------------------------------------------------------------------- / -!/ Parameter list -!/ + !/ + !/ + !/ ------------------------------------------------------------------- / + !/ Parameter list + !/ INTEGER, INTENT(IN) :: MAPSTA(NY*NX) LOGICAL, INTENT(OUT) :: FLAG0 -!/ -!/ ------------------------------------------------------------------- / -!/ Local parameters -!/ + !/ + !/ ------------------------------------------------------------------- / + !/ Local parameters + !/ INTEGER :: NMIN, IPROC, NLOC, ISEA, IXY INTEGER :: JSEA, ISPROC -#ifdef W3_S - INTEGER, SAVE :: IENT -#endif -!/ -!/ ------------------------------------------------------------------- / -!/ -#ifdef W3_S - CALL STRACE (IENT, 'W3NMIN') -#endif -! + INTEGER, SAVE :: IENT ! W3_S + !/ + !/ ------------------------------------------------------------------- / + !/ + if (w3_s_flag) then + CALL STRACE (IENT, 'W3NMIN') + end if + ! NMIN = NSEA -! + ! DO IPROC=1, NAPROC - NLOC = 0 - DO ISEA=1, NSEA - CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) - IF (ISPROC .eq. IPROC) THEN - IXY = MAPSF(ISEA,3) - IF ( MAPSTA(IXY) .EQ. 1 ) NLOC = NLOC + 1 - END IF - END DO + NLOC = 0 + DO ISEA=1, NSEA + CALL INIT_GET_JSEA_ISPROC(ISEA, JSEA, ISPROC) + IF (ISPROC .eq. IPROC) THEN + IXY = MAPSF(ISEA,3) + IF ( MAPSTA(IXY) .EQ. 1 ) NLOC = NLOC + 1 + END IF + END DO #ifdef W3_SMC - !!Li For SMC grid, local sea points are equally NSEA/NAPROC - !!Li so the NLOC is overwirte by a constant. - NLOC = NSEA/NAPROC -#endif -! -#ifdef W3_T - WRITE (NDST,9000) IPROC, NLOC -#endif - NMIN = MIN ( NMIN , NLOC ) - END DO -! + !!Li For SMC grid, local sea points are equally NSEA/NAPROC + !!Li so the NLOC is overwirte by a constant. + NLOC = NSEA/NAPROC +#endif + ! + if (w3_t_flag) then + WRITE (NDST,9000) IPROC, NLOC + end if + NMIN = MIN ( NMIN , NLOC ) + END DO + ! FLAG0 = NMIN .EQ. 0 -#ifdef W3_T - WRITE (NDST,9001) NMIN, FLAG0 -#endif -! + if (w3_t_flag) then + WRITE (NDST,9001) NMIN, FLAG0 + end if + ! RETURN -! -! Formats -! -#ifdef W3_T - 9000 FORMAT ( ' TEST W3NMIN : IPROC =',I3,' NLOC =',I5) - 9001 FORMAT ( ' TEST W3NMIN : NMIN =',I5,' FLAG0 =',L2) -#endif -!/ -!/ End of W3NMIN ----------------------------------------------------- / -!/ - END SUBROUTINE W3NMIN -!/ -!/ End of module W3WAVEMD -------------------------------------------- / -!/ - END MODULE W3WAVEMD + ! + ! Formats + ! +9000 FORMAT ( ' TEST W3NMIN : IPROC =',I3,' NLOC =',I5) +9001 FORMAT ( ' TEST W3NMIN : NMIN =',I5,' FLAG0 =',L2) + !/ + !/ End of W3NMIN ----------------------------------------------------- / + !/ + END SUBROUTINE W3NMIN + !/ + !/ End of module W3WAVEMD -------------------------------------------- / + !/ + END MODULE W3WAVEMD diff --git a/model/src/w3wdatmd.F90 b/model/src/w3wdatmd.F90 index 12b2467d17..97dea5f88a 100644 --- a/model/src/w3wdatmd.F90 +++ b/model/src/w3wdatmd.F90 @@ -24,7 +24,7 @@ MODULE W3WDATMD !/ !/ 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 : @@ -49,7 +49,7 @@ MODULE W3WDATMD ! ---------------------------------------------------------------- ! TIME I.A. Public Valid time for spectra. ! TIME00 I.A. Public Initial time -! TIMEEND I.A. Public Final time +! TIMEEND I.A. Public Final time ! QI5TBEG I.A. Public Initial time for NL5 (absol. time) ! QR5TIM0 R.A. Public Previous time step t0 (relat. time) ! QR5CVK0 R.A. Public Cvk @ t0 @@ -57,16 +57,16 @@ MODULE W3WDATMD ! QR5TMIX R.A. Public Previous time for phase mixing ! TLEV I.A. Public Valid time for water levels. ! TICE I.A. Public Valid time for ice concentration -! TRHO I.A. Public Valid time for air density +! TRHO I.A. Public Valid time for air density ! TIC1 I.A. Public Valid time for ice thickness ! TIC5 I.A. Public Valid time for ice floe ! VA R.A. Public Storage array for spectra. -! WLV R.A. Public Water levels. -! ICE R.A. Public Ice coverage. +! WLV R.A. Public Water levels. +! ICE R.A. Public Ice coverage. ! RHOAIR R.A. Public Air density ! ICEH R.A. Public Ice thickness. -! ICEF R.A. Public Ice flow maximum diameter. -! ICEDMAX R.A. Public Ice flow maximum diameter for updates. +! ICEF R.A. Public Ice flow maximum diameter. +! ICEDMAX R.A. Public Ice flow maximum diameter for updates. ! BERG R.A. Public Iceberg damping. ! UST R.A. Public Friction velocity (absolute). ! USTDIR R.A. Public Friction velocity direction. @@ -361,7 +361,7 @@ SUBROUTINE W3DIMW ( IMOD, NDSE, NDST, F_ONLY ) ! ! 7. Remarks : ! -! - W3SETW needs to be called after allocation to point to +! - W3SETW needs to be called after allocation to point to ! proper allocated arrays. ! ! 8. Structure : @@ -380,7 +380,7 @@ SUBROUTINE W3DIMW ( IMOD, NDSE, NDST, F_ONLY ) USE W3ODATMD, ONLY: NAPROC, IAPROC USE W3SERVMD, ONLY: EXTCDE USE CONSTANTS, ONLY : LPDLIB, DAIR - USE W3PARALL, ONLY: SET_UP_NSEAL_NSEALM, LSLOC + USE W3PARALL, ONLY: SET_UP_NSEAL_NSEALM, LSLOC #ifdef W3_NL5 USE W3GDATMD, ONLY: QI5NNZ #endif @@ -531,7 +531,7 @@ SUBROUTINE W3DIMW ( IMOD, NDSE, NDST, F_ONLY ) FLUSH(740+IAPROC) #endif #ifdef W3_PDLIB - ENDIF ! LSLOC + ENDIF ! LSLOC ALLOCATE ( WDATAS(IMOD)%VAOLD(NSPEC,NSEAL), stat=istat ) #endif #ifdef W3_DEBUGINIT @@ -554,7 +554,7 @@ SUBROUTINE W3DIMW ( IMOD, NDSE, NDST, F_ONLY ) FLUSH(740+IAPROC) #endif #ifdef W3_PDLIB - ENDIF ! LSLOC + ENDIF ! LSLOC WDATAS(IMOD)%SHAVETOT=.FALSE. #endif #ifdef W3_DEBUGINIT @@ -800,7 +800,7 @@ SUBROUTINE W3SETW ( IMOD, NDSE, NDST ) IF ( NWDATA .EQ. -1 ) THEN WRITE (NDSE,1001) CALL EXTCDE (1) - END IF + END IF ! IF ( IMOD.LT.0 .OR. IMOD.GT.NWDATA ) THEN WRITE (NDSE,1002) IMOD, NWDATA diff --git a/model/src/wav_comp_nuopc.F90 b/model/src/wav_comp_nuopc.F90 index 4109ac05af..f835e686cf 100644 --- a/model/src/wav_comp_nuopc.F90 +++ b/model/src/wav_comp_nuopc.F90 @@ -41,10 +41,13 @@ module wav_comp_nuopc use wav_import_export , only : advertise_fields, realize_fields use wav_shr_mod , only : state_diagnose, state_getfldptr, state_fldchk use wav_shr_mod , only : chkerr, state_setscalar, state_getscalar, alarmInit, ymd2date - use wav_shr_mod , only : runtype, merge_import, dbug_flag + use wav_shr_mod , only : wav_coupling_to_cice + use wav_shr_mod , only : merge_import, dbug_flag use w3odatmd , only : nds, iaproc, napout + use w3odatmd , only : runtype, use_user_histname, user_histfname, use_user_restname, user_restfname + use w3odatmd , only : user_netcdf_grdout + use w3odatmd , only : time_origin, calendar_name, elapsed_secs 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 @@ -73,39 +76,47 @@ module wav_comp_nuopc ! 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 + 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 + logical :: root_task = .false. !< logical to indicate root task #ifdef W3_CESMCOUPLED - logical :: cesmcoupled = .true. !< logical to indicate CESM use case + 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 + logical :: cesmcoupled = .false. !< logical to indicate non-CESM use case #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 + integer, allocatable :: tend(:,:) !< the ending time of ModelAdvance when + !! run with multigrid=true + logical :: user_histalarm = .false. !< logical flag for user to set history alarms + !! using ESMF. If history_option is present as config + !! option, user_histalarm will be true and will be + !! set using history_option, history_n and history_ymd + logical :: user_restalarm = .false. !< logical flag for user to set restart alarms + !! using ESMF. If restart_option is present as config + !! option, user_restalarm will be true and will be + !! set using restart_option, restart_n and restart_ymd + integer :: time0(2) + integer :: timen(2) + + 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 + !=============================================================================== + !> 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 @@ -158,19 +169,19 @@ subroutine SetServices(gcomp, rc) 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 + !> 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 @@ -188,29 +199,29 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) 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 + !> 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 @@ -306,7 +317,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call NUOPC_CompAttributeGet(gcomp, name='dbug_flag', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(cvalue,*) dbug_flag + read(cvalue,*) dbug_flag end if write(logmsg,'(A,i6)') trim(subname)//': Wave cap dbug_flag is ',dbug_flag call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO) @@ -330,13 +341,27 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) inst_index=1 endif + ! Get Multigrid setting 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") + if (isPresent .and. isSet) then + multigrid=(trim(cvalue)=="true") + end if write(logmsg,'(A,l)') trim(subname)//': Wave multigrid setting is ',multigrid call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO) + ! Determine wave-ice coupling + wav_coupling_to_cice = .false. + call NUOPC_CompAttributeGet(gcomp, name='wav_coupling_to_cice', value=cvalue, isPresent=isPresent, & + isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + wav_coupling_to_cice=(trim(cvalue)=="true") + end if + write(logmsg,'(A,l)') trim(subname)//': Wave wav_coupling_to_cice setting is ',wav_coupling_to_cice + call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO) + call advertise_fields(importState, exportState, flds_scalar_name, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -345,28 +370,28 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) 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 + !> 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 @@ -380,6 +405,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) use wmunitmd , only : wmuget, wmuset #endif use wav_shel_inp , only : set_shel_io + use wav_grdout , only : wavinit_grdout ! input/output variables type(ESMF_GridComp) :: gcomp @@ -399,15 +425,13 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) 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 :: ntrace(2) integer :: i,j integer :: ierr integer :: n, jsea,isea, ncnt @@ -616,11 +640,11 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) 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 ) + 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 ) + call wminit ( idsi, idso, idss, idst, idse, trim(ifname), & + mpi_comm, preamb=preamb ) endif allocate(tend(2,nrgrd)) @@ -637,13 +661,23 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) 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) + call waveinit_cesm(gcomp, ntrace, mpi_comm, mds, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return #endif ! call mpi_barrier ( mpi_comm, ierr ) + if ( root_task ) then + inquire(unit=nds(1), name=logfile) + print *,'WW3 log written to '//trim(logfile) + end if + + !-------------------------------------------------------------------- + ! Intialize the list of requested output variables for netCDF output + !-------------------------------------------------------------------- + + if (user_netcdf_grdout) then + call wavinit_grdout + end if !-------------------------------------------------------------------- ! Mesh initialization @@ -720,7 +754,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) EMeshTemp = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if ( root_task ) then - write(stdout,*)'mesh file for domain is ',trim(cvalue) + write(nds(1),*)'mesh file for domain is ',trim(cvalue) end if ! recreate the mesh using the above distGrid @@ -766,14 +800,14 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) !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 ) + 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 @@ -783,21 +817,20 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) 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 + !> 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 @@ -811,8 +844,6 @@ subroutine DataInitialize(gcomp, rc) 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)' ! ------------------------------------------------------------------- @@ -828,36 +859,28 @@ subroutine DataInitialize(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (state_fldchk(exportState, 'Sw_lamult')) then - call state_getfldptr(exportState, 'Sw_lamult', sw_lamult, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - sw_lamult (:) = 1. + call state_getfldptr(exportState, 'Sw_lamult', sw_lamult, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + sw_lamult (:) = 1. endif if (state_fldchk(exportState, 'Sw_ustokes')) then - call state_getfldptr(exportState, 'Sw_ustokes', sw_ustokes, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - sw_ustokes(:) = 0. + call state_getfldptr(exportState, 'Sw_ustokes', sw_ustokes, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + sw_ustokes(:) = 0. endif if (state_fldchk(exportState, 'Sw_vstokes')) then - call state_getfldptr(exportState, 'Sw_vstokes', sw_vstokes, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - sw_vstokes(:) = 0. + call state_getfldptr(exportState, 'Sw_vstokes', sw_vstokes, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + sw_vstokes(:) = 0. endif if (state_fldchk(exportState, 'Sw_z0')) then call state_getfldptr(exportState, 'Sw_z0', z0rlen, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call CalcRoughl(z0rlen) 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. + call state_getfldptr(exportState, 'wave_elevation_spectrum', wave_elevation_spectrum, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return wave_elevation_spectrum(:,:) = 0. endif @@ -877,20 +900,20 @@ subroutine DataInitialize(gcomp, rc) 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 + !> 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) !------------------------ @@ -901,7 +924,7 @@ subroutine ModelAdvance(gcomp, rc) 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 + use w3odatmd , only : rstwr, histwr ! arguments: type(ESMF_GridComp) :: gcomp @@ -918,8 +941,6 @@ subroutine ModelAdvance(gcomp, rc) 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) ' @@ -935,11 +956,11 @@ subroutine ModelAdvance(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_ClockPrint(clock, options="currTime", preString="------>Advancing WAV from: ", & - unit=msgString, rc=rc) + 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) + unit=msgString, rc=rc) call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) !------------ @@ -1000,9 +1021,8 @@ subroutine ModelAdvance(gcomp, rc) !------------ 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 + if (user_restalarm) then + ! Determine if time to write ww3 restart files call ESMF_ClockGetAlarm(clock, alarmname='alarm_restart', alarm=alarm, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (ESMF_AlarmIsRinging(alarm, rc=rc)) then @@ -1017,34 +1037,24 @@ subroutine ModelAdvance(gcomp, rc) 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 + if (user_histalarm) then + ! Determine if time to write ww3 history files + call ESMF_ClockGetAlarm(clock, alarmname='alarm_history', alarm=alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ESMF_AlarmIsRinging(alarm, rc=rc)) then + if (ChkErr(rc,__LINE__,u_FILE_u)) return histwr = .true. - endif - endif - if (.not. histwr) then - if (histwr_is_active) then - call ESMF_ClockGetAlarm(clock, alarmname='alarm_history', alarm=alarm, rc=rc) + call ESMF_AlarmRingerOff( 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 + else + histwr = .false. + endif + else + histwr = .false. + end if + if ( root_task ) then + ! write(nds(1),*) 'wav_comp_nuopc time', time, timen + ! write(nds(1),*) 'ww3 hist flag ', histwr, hh end if ! Advance the wave model @@ -1071,13 +1081,13 @@ subroutine ModelAdvance(gcomp, rc) 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 + !> 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 @@ -1151,26 +1161,36 @@ subroutine ModelSetRunClock(gcomp, rc) !---------------- ! Restart alarm !---------------- - call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=restart_option, rc=rc) + call NUOPC_CompAttributeGet(gcomp, name="restart_option", isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=restart_option, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) restart_n + call NUOPC_CompAttributeGet(gcomp, name="restart_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 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 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 + call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + user_restalarm = .true. + else + ! If attribute is not present - write restarts at native WW3 freq + restart_option = 'none' + restart_n = -999 + user_restalarm = .false. + end if !---------------- ! Stop alarm @@ -1196,9 +1216,9 @@ subroutine ModelSetRunClock(gcomp, rc) call ESMF_AlarmSet(stop_alarm, clock=mclock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - !---------------- - ! History alarm - !---------------- + !---------------- + ! 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 @@ -1208,6 +1228,7 @@ subroutine ModelSetRunClock(gcomp, rc) 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 @@ -1221,12 +1242,12 @@ subroutine ModelSetRunClock(gcomp, rc) call ESMF_AlarmSet(history_alarm, clock=mclock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - histwr_is_active = .true. + user_histalarm = .true. else - ! If attribute is not present - write history native WW3 output if requested + ! If attribute is not present - write history output at native WW3 frequency history_option = 'none' history_n = -999 - histwr_is_active = .false. + user_histalarm = .false. end if end if @@ -1246,13 +1267,13 @@ subroutine ModelSetRunClock(gcomp, rc) 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 + !> 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 @@ -1279,26 +1300,31 @@ subroutine ModelFinalize(gcomp, rc) 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 the wave model for the CESM use case + !! + !> @details Calls public routine read_shel_config to read the ww3_shel.inp or + !! ww3_shel.nml 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_cesm(gcomp, ntrace, mpi_comm, 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 w3idatmd , only : inflags1, inflags2 + use w3odatmd , only : initfile + use wav_shr_mod , only : casename use wav_shr_mod , only : inst_index, inst_name, inst_suffix - use wav_shel_inp , only : set_shel_inp + use wav_shr_mod , only : wav_coupling_to_cice + use wav_shel_inp , only : read_shel_config use wav_shel_inp , only : npts, odat, iprt, x, y, pnames, prtfrm use wav_shel_inp , only : flgrd, flgd, flgr2, flg2 @@ -1306,7 +1332,6 @@ subroutine waveinit_cesm(gcomp, ntrace, mpi_comm, dtime_sync, mds, rc) 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 @@ -1324,13 +1349,13 @@ subroutine waveinit_cesm(gcomp, ntrace, mpi_comm, dtime_sync, mds, rc) character(len=*), parameter :: subname = '(wav_comp_nuopc:wavinit_cesm)' ! ------------------------------------------------------------------- - namelist /ww3_inparm/ initfile, outfreq, dtcfl, dtcfli, dtmax, dtmin + namelist /ww3_inparm/ initfile, 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) + ! Read namelist (set initfile in w3odatmd) if ( root_task ) then open (newunit=unitn, file='wav_in'//trim(inst_suffix), status='old') read (unitn, ww3_inparm, iostat=ierr) @@ -1358,7 +1383,6 @@ subroutine waveinit_cesm(gcomp, ntrace, mpi_comm, dtime_sync, mds, rc) 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 @@ -1370,13 +1394,6 @@ subroutine waveinit_cesm(gcomp, ntrace, mpi_comm, dtime_sync, mds, rc) 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 ',& @@ -1410,8 +1427,51 @@ subroutine waveinit_cesm(gcomp, ntrace, mpi_comm, dtime_sync, mds, rc) 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 the namelist settings in ww3_shel.nml + call ESMF_LogWrite(trim(subname)//' call read_shel_config', ESMF_LOGMSG_INFO) + call read_shel_config(mpi_comm, time0_overwrite=time0, timen_overwrite=timen) + + ! NOTE: that wavice_coupling must be set BEFORE the call to advertise_fields + ! So the current mechanism is to force the inflags1(-7) and inflags1(-3) be set to true + ! if wavice coupling is active + ! NOTE: + ! inflags1(-7) = nml_input%forcing%ice_param1 + ! inflags1(-3) = nml_input%forcing%ice_param5 + + ! Force inflags2 to be false - otherwise inflags2 will be set to inflags1 and answers will change + ! Need to set this to .false. to avoid scaling of ice in section 4. of w3srcemed. + ! inflags2(4) is true if ice concentration was ever read during this simulation + ! Currently IC4 is used in cesm + inflags2(:) = .false. + if (wav_coupling_to_cice) then + inflags2(4) = .true. ! inflags2(4) is true if ice concentration was read during initialization + inflags1(-7) = .true. ! ice thickness + inflags2(-7) = .true. ! ice thickness + inflags1(-3) = .true. ! ice floe size + inflags2(-3) = .true. ! ice floe size + else + inflags1(-7) = .false. ! ice thickness + inflags2(-7) = .false. ! ice thickness + inflags1(-3) = .false. ! ice floe size + inflags2(-3) = .false. ! ice floe size + end if + + ! custom restart and history file names are used for CESM + use_user_histname = .true. + use_user_restname = .true. + + ! if runtype=initial, the initfile will be read in w3iorsmd + if (len_trim(inst_suffix) > 0) then + user_restfname = trim(casename)//'.ww3'//trim(inst_suffix)//'.r.' + user_histfname = trim(casename)//'.ww3'//trim(inst_suffix)//'.hi.' + else + user_restfname = trim(casename)//'.ww3.r.' + user_histfname = trim(casename)//'.ww3.hi.' + endif + + ! netcdf gridded output is used for CESM + user_netcdf_grdout = .true. + ! restart and history alarms are set for CESM by default through config ! Read in initial/restart data and initialize the model ! ww3 read initialization occurs in w3iors (which is called by initmd in module w3initmd) @@ -1422,6 +1482,7 @@ subroutine waveinit_cesm(gcomp, ntrace, mpi_comm, dtime_sync, mds, rc) ! 1 is model number ! IsMulti does not appear to be used, setting to .false. + 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 ) @@ -1436,27 +1497,26 @@ subroutine waveinit_cesm(gcomp, ntrace, mpi_comm, dtime_sync, mds, rc) 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 + !> Initialize the wave model for the UWM use case + !! + !> @details Calls public routine read_shel_config to read the ww3_shel.inp or + !! ww3_shel.nml 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 : read_shel_config use wav_shel_inp , only : npts, odat, iprt, x, y, pnames, prtfrm use wav_shel_inp , only : flgrd, flgd, flgr2, flg2 @@ -1468,17 +1528,51 @@ subroutine waveinit_ufs( gcomp, ntrace, mpi_comm, mds, rc) integer, intent(out) :: rc ! local variables + character(len=CL) :: logmsg + logical :: isPresent, isSet + character(len=CL) :: cvalue 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 + ! restart and history alarms are optional for UFS and used via allcomp config settings + call NUOPC_CompAttributeGet(gcomp, name='user_sets_histname', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + use_user_histname=(trim(cvalue)=="true") + end if + write(logmsg,'(A,l)') trim(subname)//': Custom history names in use ',use_user_histname + call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO) + + call NUOPC_CompAttributeGet(gcomp, name='user_sets_restname', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + use_user_restname=(trim(cvalue)=="true") + end if + write(logmsg,'(A,l)') trim(subname)//': Custom restart names in use ',use_user_restname + call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO) + + call NUOPC_CompAttributeGet(gcomp, name='gridded_netcdfout', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + user_netcdf_grdout=(trim(cvalue)=="true") + end if + write(logmsg,'(A,l)') trim(subname)//': Gridded netcdf output is requested ',user_netcdf_grdout + call ESMF_LogWrite(trim(logmsg), ESMF_LOGMSG_INFO) + + if (use_user_histname) then + user_histfname = trim(casename)//'.ww3.hi.' + end if + if (use_user_restname) then + user_restfname = trim(casename)//'.ww3.r.' + end if + 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 read_shel_config', ESMF_LOGMSG_INFO) + call read_shel_config(mpi_comm, time0_overwrite=time0, timen_overwrite=timen) call ESMF_LogWrite(trim(subname)//' call w3init', ESMF_LOGMSG_INFO) call w3init ( 1, .false., 'ww3', mds, ntrace, odat, flgrd, flgr2, flgd, flg2, & diff --git a/model/src/wav_grdout.F90 b/model/src/wav_grdout.F90 new file mode 100644 index 0000000000..166802ad6b --- /dev/null +++ b/model/src/wav_grdout.F90 @@ -0,0 +1,294 @@ +module wav_grdout + + use w3odatmd , only: nogrp, ngrpp + + implicit none + + integer, parameter :: maxvars = 24 ! maximum number of variables/group + + private ! except + + public :: varatts + public :: outvars + public :: wavinit_grdout + + ! tag read from inp file and is used to set flogrd flags + ! var_name is the name of the variable + type :: varatts + character(len= 5) :: tag + character(len=10) :: var_name + character(len=48) :: long_name + character(len=10) :: unit_name + character(len= 2) :: dims + logical :: validout + end type + + type(varatts), dimension(nogrp,maxvars) :: gridoutdefs + + type(varatts), dimension(:), allocatable :: outvars + +!=============================================================================== +contains +!=============================================================================== + + !==================================================================================== + subroutine wavinit_grdout + + use w3gdatmd , only: e3df, p2msf, us3df, usspf + use w3odatmd , only: nds, iaproc, napout + use w3iogomd , only: fldout + use w3servmd , only: strsplit + + ! local variables + character(len=100) :: inptags(100) = '' + integer :: j,k,n,nout + character(len= 12) :: ttag + + ! obtain all possible output variable tags and attributes + call initialize_gridout + + ! obtain the tags for the requested output variables + call strsplit(fldout,inptags) + + ! determine which variables are tagged for output + do k = 1,nogrp + do j = 1,maxvars + if (len_trim(gridoutdefs(k,j)%tag) > 0) then + do n = 1,len(inptags) + if (len_trim(inptags(n)) > 0) then + if (trim(inptags(n)) == trim(gridoutdefs(k,j)%tag)) gridoutdefs(k,j)%validout = .true. + end if + end do + end if + end do + end do + + ! remove requested variables which are only allocated if specific + ! options are set in mod_def (see w3adatmd, '3D arrays') + do k = 1,nogrp + do j = 1,maxvars + if (gridoutdefs(k,j)%validout) then + ttag = trim(gridoutdefs(k,j)%tag) + if (ttag == 'EF' .and. e3df(1,1) == 0) gridoutdefs(k,j)%validout = .false. + if (ttag == 'TH1M' .and. e3df(1,2) == 0) gridoutdefs(k,j)%validout = .false. + if (ttag == 'STH1M' .and. e3df(1,3) == 0) gridoutdefs(k,j)%validout = .false. + if (ttag == 'TH2M' .and. e3df(1,4) == 0) gridoutdefs(k,j)%validout = .false. + if (ttag == 'STH2M' .and. e3df(1,5) == 0) gridoutdefs(k,j)%validout = .false. + + if (ttag == 'P2L' .and. p2msf(1) == 0) gridoutdefs(k,j)%validout = .false. + if (ttag == 'USF' .and. us3df(1) == 0) gridoutdefs(k,j)%validout = .false. + if (ttag == 'USP' .and. usspf(1) == 0) gridoutdefs(k,j)%validout = .false. + end if + end do + end do + + ! determine number of output variables (not the same as the number of tags) + n = 0 + do k = 1,nogrp + do j = 1,maxvars + if (gridoutdefs(k,j)%validout) n = n+1 + end do + end do + nout = n + allocate(outvars(1:nout)) + + ! subset variables requested + n = 0 + do k = 1,nogrp + do j = 1,maxvars + if (gridoutdefs(k,j)%validout) then + n = n+1 + outvars(n) = gridoutdefs(k,j) + end if + enddo + end do + + ! check + if ( iaproc == napout ) then + write(nds(1),*) + write(nds(1),'(a)')' --------------------------------------------------' + write(nds(1),'(a)')' Requested gridded output variables : ' + write(nds(1),'(a)')' --------------------------------------------------' + write(nds(1),*) + do n = 1,nout + write(nds(1),'(i5,2a12,a50)')n,' '//trim(outvars(n)%tag), & + ' '//trim(outvars(n)%var_name), & + ' '//trim(outvars(n)%long_name) + end do + write(nds(1),*) + end if + + end subroutine wavinit_grdout + + !==================================================================================== + subroutine initialize_gridout + + gridoutdefs(:,:)%tag = "" + gridoutdefs(:,:)%var_name = "" + gridoutdefs(:,:)%long_name = "" + gridoutdefs(:,:)%unit_name = "" + gridoutdefs(:,:)%dims = "" + gridoutdefs(:,:)%validout = .false. + + ! TODO: confirm unit values + ! 1 Forcing Fields + gridoutdefs(1,1:14) = [ & + varatts( "DPT ", "DW ", "Water depth ", "m ", " ", .false.) , & + varatts( "CUR ", "CX ", "Mean current, x-component ", "m s-1 ", " ", .false.) , & + varatts( "CUR ", "CY ", "Mean current, y-component ", "m s-1 ", " ", .false.) , & + varatts( "WND ", "UAX ", "Mean wind, x-component ", "m s-1 ", " ", .false.) , & + varatts( "WND ", "UAY ", "Mean wind, y-component ", "m s-1 ", " ", .false.) , & + varatts( "AST ", "AS ", "Air-sea temperature difference ", "K ", " ", .false.) , & + varatts( "WLV ", "WLV ", "Water levels ", "m ", " ", .false.) , & + varatts( "ICE ", "ICE ", "Ice coverage ", "nd ", " ", .false.) , & + varatts( "IBG ", "BERG ", "Iceberg-induced damping ", "km-1 ", " ", .false.) , & + varatts( "TAUA ", "TAUAX ", "Atm momentum x ", "Pa ", " ", .false.) , & + varatts( "TAUA ", "TAUAY ", "Atm momentum y ", "Pa ", " ", .false.) , & + varatts( "RHO ", "RHOAIR ", "Air density ", "kg m-3 ", " ", .false.) , & + varatts( "IC1 ", "ICEH ", "Ice thickness ", "m ", " ", .false.) , & + varatts( "IC5 ", "ICEF ", "Ice floe diameter ", "m ", " ", .false.) & + ] + + ! 2 Standard mean wave Parameters + gridoutdefs(2,1:18) = [ & + varatts( "HS ", "HS ", "Significant wave height ", "m ", " ", .false.) , & + varatts( "LM ", "WLM ", "Mean wave length ", "m ", " ", .false.) , & + varatts( "T02 ", "T02 ", "Mean wave period (Tm0,2) ", "s ", " ", .false.) , & + varatts( "T0M1 ", "T0M1 ", "Mean wave period (Tm0,-1) ", "s ", " ", .false.) , & + varatts( "T01 ", "T01 ", "Mean wave period (Tm0,1) ", "s ", " ", .false.) , & + varatts( "FP ", "FP0 ", "Peak frequency ", "s-1 ", " ", .false.) , & + varatts( "DIR ", "THM ", "Mean wave direction ", "rad ", " ", .false.) , & + varatts( "SPR ", "THS ", "Mean directional spread ", "rad ", " ", .false.) , & + varatts( "DP ", "THP0 ", "Peak direction ", "rad ", " ", .false.) , & + varatts( "HIG ", "HSIG ", "Infragravity height ", "m ", " ", .false.) , & + varatts( "MXE ", "STMAXE ", "Max surface elev (STE) ", "m ", " ", .false.) , & + varatts( "MXES ", "STMAXD ", "St Dev Max surface elev (STE) ", "m ", " ", .false.) , & + varatts( "MXH ", "HMAXE ", "Max wave height (S.) ", "m ", " ", .false.) , & + varatts( "MXHC ", "HCMAXE ", "Max wave height from crest (STE) ", "m ", " ", .false.) , & + varatts( "SDMH ", "HMAXD ", "St Dev of MXC (STE) ", "m ", " ", .false.) , & + varatts( "SDMHC", "HCMAXD ", "St Dev of MXHC (STE) ", "m ", " ", .false.) , & + varatts( "WBT ", "WBT ", "Dominant wave breaking probability (b_T) ", "nd ", " ", .false.) , & + varatts( "WNM ", "WNMEAN ", "Mean wave number ", "m-1 ", " ", .false.) & + ] + + ! 3 Spectral Parameters + gridoutdefs(3,1:6) = [ & + varatts( "EF ", "EF ", "1D spectral density ", "m2 s ", "k ", .false.) , & + varatts( "TH1M ", "TH1M ", "Mean wave direction from a1,b2 ", "deg ", "k ", .false.) , & + varatts( "STH1M", "STH1M ", "Directional spreading from a1,b2 ", "deg ", "k ", .false.) , & + varatts( "TH2M ", "TH2M ", "Mean wave direction from a2,b2 ", "deg ", "k ", .false.) , & + varatts( "STH2M", "STH2M ", "Directional spreading from a2,b2 ", "deg ", "k ", .false.) , & + !TODO: has reverse indices (nk,nsea) + varatts( "WN ", "WN ", "Wavenumber array ", "m-1 ", "k ", .false.) & + ] + + ! 4 Spectral Partition Parameters + gridoutdefs(4,1:17) = [ & + varatts( "PHS ", "PHS ", "Partitioned wave heights ", "m ", "s ", .false.) , & + varatts( "PTP ", "PTP ", "Partitioned peak period ", "s ", "s ", .false.) , & + varatts( "PLP ", "PLP ", "Partitioned peak wave length ", "m ", "s ", .false.) , & + varatts( "PDIR ", "PDIR ", "Partitioned mean direction ", "deg ", "s ", .false.) , & + varatts( "PSPR ", "PSI ", "Partitioned mean directional spread ", "deg ", "s ", .false.) , & + varatts( "PWS ", "PWS ", "Partitioned wind sea fraction ", "nd ", "s ", .false.) , & + varatts( "PDP ", "PTHP0 ", "Peak wave direction of partition ", "deg ", "s ", .false.) , & + varatts( "PQP ", "PQP ", "Goda peakdedness parameter of partition ", "nd ", "s ", .false.) , & + varatts( "PPE ", "PPE ", "JONSWAP peak enhancement factor of partition ", "s-1 ", "s ", .false.) , & + varatts( "PGW ", "PGW ", "Gaussian frequency width of partition ", "nd ", "s ", .false.) , & + varatts( "PSW ", "PSW ", "Spectral width of partition ", "nd ", "s ", .false.) , & + varatts( "PTM10", "PTM1 ", "Mean wave period (m-1,0) of partition ", "s ", "s ", .false.) , & + varatts( "PT01 ", "PT1 ", "Mean wave period (m0,1) of partition ", "s ", "s ", .false.) , & + varatts( "PT02 ", "PT2 ", "Mean wave period (m0,2) of partition ", "s ", "s ", .false.) , & + varatts( "PEP ", "PEP ", "Peak spectral density of partition ", "m2 s rad-1", "s ", .false.) , & + varatts( "TWS ", "PWST ", "Total wind sea fraction ", "nd ", " ", .false.) , & + varatts( "PNR ", "PNR ", "Number of partitions ", "nd ", " ", .false.) & + ] + + ! 5 Atmosphere-waves layer + gridoutdefs(5,1:14) = [ & + varatts( "UST ", "USTX ", "Friction velocity x ", "m s-1 ", " ", .false.) , & + varatts( "UST ", "USTY ", "Friction velocity y ", "m s-1 ", " ", .false.) , & + varatts( "CHA ", "CHARN ", "Charnock parameter ", "nd ", " ", .false.) , & + varatts( "CGE ", "CGE ", "Energy flux ", "kW m-1 ", " ", .false.) , & + varatts( "FAW ", "PHIAW ", "Air-sea energy flux ", "W m-2 ", " ", .false.) , & + varatts( "TAW ", "TAUWIX ", "Net wave-supported stress x ", "m2 s-2 ", " ", .false.) , & + varatts( "TAW ", "TAUWIY ", "Net wave-supported stress y ", "m2 s-2 ", " ", .false.) , & + varatts( "TWA ", "TAUWNX ", "Negative part of the wave-supported stress x ", "m2 s-2 ", " ", .false.) , & + varatts( "TWA ", "TAUWNY ", "Negative part of the wave-supported stress y ", "m2 s-2 ", " ", .false.) , & + varatts( "WCC ", "WCC ", "Whitecap coverage ", "nd ", " ", .false.) , & + varatts( "WCF ", "WCF ", "Whitecap foam thickness ", "m ", " ", .false.) , & + varatts( "WCH ", "WCH ", "Mean breaking wave heigh ", "m ", " ", .false.) , & + varatts( "WCM ", "WCM ", "Whitecap moment ", "nd ", " ", .false.) , & + varatts( "FWS ", "TWS ", "Wind sea mean period ", "s ", " ", .false.) & + ] + + ! 6 Wave-ocean layer + gridoutdefs(6,1:24) = [ & + varatts( "SXY ", "SXX ", "Radiation stresses xx ", "N m-1 ", " ", .false.) , & + varatts( "SXY ", "SYY ", "Radiation stresses yy ", "N m-1 ", " ", .false.) , & + varatts( "SXY ", "SXY ", "Radiation stresses xy ", "N m-1 ", " ", .false.) , & + varatts( "TWO ", "TAUOX ", "Wave to ocean momentum flux x ", "m2 s-2 ", " ", .false.) , & + varatts( "TWO ", "TAUOY ", "Wave to ocean momentum flux y ", "m2 s-2 ", " ", .false.) , & + varatts( "BHD ", "BHD ", "Bernoulli head (J term) ", "m2 s-2 ", " ", .false.) , & + varatts( "FOC ", "PHIOC ", "Wave to ocean energy flux ", "W m-2 ", " ", .false.) , & + varatts( "TUS ", "TUSX ", "Stokes transport x ", "m2 s-1 ", " ", .false.) , & + varatts( "TUS ", "TUSY ", "Stokes transport y ", "m2 s-1 ", " ", .false.) , & + varatts( "USS ", "USSX ", "Surface Stokes drift x ", "m s-1 ", " ", .false.) , & + varatts( "USS ", "USSY ", "Surface Stokes drift y ", "m s-1 ", " ", .false.) , & + varatts( "P2S ", "PRMS ", "Second-order sum pressure ", "m4 ", " ", .false.) , & + varatts( "P2S ", "TPMS ", "Second-order sum pressure ", "s-1 ", " ", .false.) , & + varatts( "USF ", "US3DX ", "Spectrum of surface Stokes drift x ", "m s-1 Hz-1", "k ", .false.) , & + varatts( "USF ", "US3DY ", "Spectrum of surface Stokes drift y ", "m s-1 Hz-1", "k ", .false.) , & + varatts( "P2L ", "P2SMS ", "Micro seism source term ", "Pa2 m2 s ", "m ", .false.) , & + varatts( "TWI ", "TAUICEX ", "Wave to sea ice stress x ", "m2 s-2 ", " ", .false.) , & + varatts( "TWI ", "TAUICEY ", "Wave to sea ice stress y ", "m2 s-2 ", " ", .false.) , & + varatts( "FIC ", "PHICE ", "Wave to sea ice energy flux ", "W m-2 ", " ", .false.) , & + varatts( "USP ", "USSPX ", "Partitioned surface Stokes drift x ", "m s-1 ", "p ", .false.) , & + varatts( "USP ", "USSPY ", "Partitioned surface Stokes drift y ", "m s-1 ", "p ", .false.) , & + varatts( "TWC ", "TAUOCX ", "Total wave to ocean stress x ", "Pa ", " ", .false.) , & + varatts( "TWC ", "TAUOCY ", "Total wave to ocean stress y ", "Pa ", " ", .false.) , & + varatts( "LAN ", "LANGMT ", "Turbulent Langmuir number (La_t) ", "nd ", " ", .false.) & + ] + + ! 7 Wave-bottom layer + gridoutdefs(7,1:10) = [ & + varatts( "ABR ", "ABAX ", "Near bottom rms wave excursion amplitudes x ", "m ", " ", .false.) , & + varatts( "ABR ", "ABAY ", "Near bottom rms wave excursion amplitudes y ", "m ", " ", .false.) , & + varatts( "UBR ", "UBAX ", "Near bottom rms wave velocities x ", "m s-1 ", " ", .false.) , & + varatts( "UBR ", "UBAY ", "Near bottom rms wave velocities y ", "m s-1 ", " ", .false.) , & + varatts( "BED ", "BED ", "Bottom roughness ", "m ", " ", .false.) , & + varatts( "BED ", "RIPPLEX ", "Sea bottom ripple wavelength x ", "m ", " ", .false.) , & + varatts( "BED ", "RIPPLEY ", "Sea bottom ripple wavelength y ", "m ", " ", .false.) , & + varatts( "FBB ", "PHIBBL ", "Energy flux due to bottom friction ", "W m-2 ", " ", .false.) , & + varatts( "TBB ", "TAUBBLX ", "Momentum flux due to bottom friction x ", "m2 s-2 ", " ", .false.) , & + varatts( "TBB ", "TAUBBLY ", "Momentum flux due to bottom friction y ", "m2 s-2 ", " ", .false.) & + ] + + ! 8 Spectrum parameters + gridoutdefs(8,1:9) = [ & + varatts( "MSS ", "MSSX ", "Surface mean square slope x ", "nd ", " ", .false.) , & + varatts( "MSS ", "MSSY ", "Surface mean square slope y ", "nd ", " ", .false.) , & + varatts( "MSC ", "MSCX ", "Spectral level at high frequency tail x ", "nd ", " ", .false.) , & + varatts( "MSC ", "MSCY ", "Spectral level at high frequency tail y ", "nd ", " ", .false.) , & + varatts( "WL02 ", "WL02X ", "East/X North/Y mean wavelength component ", "nd ", " ", .false.) , & + varatts( "WL02 ", "WL02Y ", "East/X North/Y mean wavelength component ", "nd ", " ", .false.) , & + varatts( "AXT ", "ALPXT ", "Correl sea surface gradients (x,t) ", "nd ", " ", .false.) , & + varatts( "AYT ", "ALPYT ", "Correl sea surface gradients (y,t) ", "nd ", " ", .false.) , & + varatts( "AXY ", "ALPXY ", "Correl sea surface gradients (x,y) ", "nd ", " ", .false.) & + ] + + ! 9 Numerical diagnostics + gridoutdefs(9,1:5) = [ & + varatts( "DTD ", "DTDYN ", "Average time step in integration ", "min ", " ", .false.) , & + varatts( "FC ", "FCUT ", "Cut-off frequency ", "s-1 ", " ", .false.) , & + varatts( "CFX ", "CFLXYMAX ", "Max. CFL number for spatial advection ", "nd ", " ", .false.) , & + varatts( "CFD ", "CFLTHMAX ", "Max. CFL number for theta-advection ", "nd ", " ", .false.) , & + varatts( "CFK ", "CFLKMAX ", "Max. CFL number for k-advection ", "nd ", " ", .false.) & + ] + + ! 10 User defined + gridoutdefs(10,1:2) = [ & + varatts( "U1 ", "U1 ", "User defined 1 ", "nd ", " ", .false.) , & + varatts( "U2 ", "U2 ", "User defined 2 ", "nd ", " ", .false.) & + ] + end subroutine initialize_gridout +end module wav_grdout diff --git a/model/src/wav_import_export.F90 b/model/src/wav_import_export.F90 index 7a2c33b2dc..068627acbe 100644 --- a/model/src/wav_import_export.F90 +++ b/model/src/wav_import_export.F90 @@ -13,6 +13,7 @@ module wav_import_export use ESMF use NUOPC use NUOPC_Model + use wav_shr_flags 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 @@ -119,7 +120,6 @@ subroutine advertise_fields(importState, ExportState, flds_scalar_name, rc) 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') @@ -157,10 +157,7 @@ subroutine advertise_fields(importState, ExportState, flds_scalar_name, rc) ! 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 @@ -277,8 +274,11 @@ subroutine import_fields( gcomp, time0, timen, rc ) use w3idatmd , only: HML #else use wmupdtmd , only: wmupd2 - use wmmdatmd , only: wmsetm, mpi_comm_grd + use wmmdatmd , only: wmsetm use wmmdatmd , only: mdse, mdst, nrgrd, inpmap +#ifdef W3_MPI + use wmmdatmd , only: mpi_comm_grd +#endif #endif ! input/output variables @@ -584,7 +584,7 @@ subroutine export_fields (gcomp, rc) !--------------------------------------------------------------------------- use wav_kind_mod, only : R8 => SHR_KIND_R8 - use w3adatmd , only : USSX, USSY, EF, TAUICE, USSP + use w3adatmd , only : USSX, USSY, EF, USSP use w3adatmd , only : w3seta use w3idatmd , only : w3seti use w3wdatmd , only : va, w3setw @@ -620,8 +620,6 @@ subroutine export_fields (gcomp, rc) 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(:,:) @@ -752,19 +750,11 @@ subroutine export_fields (gcomp, 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 @@ -772,15 +762,10 @@ subroutine export_fields (gcomp, rc) 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 @@ -1092,14 +1077,13 @@ subroutine CalcRoughl ( wrln) 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 + use w3odatmd, only : naproc, iaproc, runtype #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 @@ -1417,7 +1401,7 @@ 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 +!> @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 @@ -1518,7 +1502,7 @@ 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, +!> @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. !! diff --git a/model/src/wav_shel_inp.F90 b/model/src/wav_shel_inp.F90 index 12c955aec7..46b7e4c8b4 100644 --- a/model/src/wav_shel_inp.F90 +++ b/model/src/wav_shel_inp.F90 @@ -3,8 +3,7 @@ !> 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). +!! either reads a shel configuration file (either ww3_shel.inp or ww3_shel.nml) !! !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov !> @date 01-05-2022 @@ -15,9 +14,9 @@ module wav_shel_inp 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) + public :: set_shel_io !< @public set the IO unit numbers + public :: read_shel_config !< @public reads ww3_shel.nml if present, otherwise + !! read ww3_shel.inp integer, public :: odat(40) !< @public output dates character(len=40), allocatable, public :: pnames(:) !< @public point names @@ -34,17 +33,17 @@ module wav_shel_inp 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 + !=============================================================================== + !> 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 @@ -97,877 +96,1405 @@ subroutine set_shel_io(stdout,mds,ntrace) 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 + !=============================================================================== + !> Read ww3_shel.inp Or ww3_shel.nml + !! + !! @param[in] mpi_comm mpi communicator + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 01-05-2022 + subroutine read_shel_config(mpi_comm, time0_overwrite, timen_overwrite) + + use wav_shr_flags + use w3nmlshelmd , only : nml_domain_t, nml_input_t, nml_output_type_t + use w3nmlshelmd , only : nml_output_date_t, nml_homog_count_t, nml_homog_input_t + use w3nmlshelmd , only : w3nmlshel + use w3gdatmd , only : flagll, dtmax, nx, ny, gtype + use w3wdatmd , only : time, 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, fldout, w3flgrdflag + use w3servmd , only : nextln, extcde + use w3timemd , only : dsec21, stme21, tick21, t2d, d2j +#ifdef W3_OASIS + use w3wdatmd , only : time00, timeend +#endif +#ifdef W3_NL5 + use w3wdatmd , only : qi5tbeg +#endif - ! Local parameters - logical :: flt - integer :: i,j,j0 + ! input/output parameters + integer, intent(in) :: mpi_comm + integer, intent(in), optional :: time0_overwrite(2) + integer, intent(in), optional :: timen_overwrite(2) + + ! local parameters + integer, parameter :: nhmax = 200 + + type(nml_domain_t) :: nml_domain + type(nml_input_t) :: nml_input + type(nml_output_type_t) :: nml_output_type + type(nml_output_date_t) :: nml_output_date + type(nml_homog_count_t) :: nml_homog_count + type(nml_homog_input_t), allocatable :: nml_homog_input(:) + + integer :: ndsi, ndsi2, ndss, ndso, ndse, ndst, ndsl + integer :: ndsen, ierr, j, i, iloop, ipts + integer :: ndsf(-7:9) + integer :: nh(-7:10), tho(2,-7:10,nhmax), rcld(7:9) + integer :: nodata(7:9), startdate(8), stopdate(8), ihh(-7:10) + integer :: jfirst, ierr_mpi, flagtide, ih, n_tot + real :: factor, dttst, xx, yy, ha(nhmax,-7:10) + real :: hd(nhmax,-7:10), hs(nhmax,-7:10) + double precision :: startjulday, stopjulday + character(len=1) :: comstr, flagtfc(-7:10) + character(len=3) :: idstr(-7:10), idtst + character(len=6) :: yesxno + character(len=40) :: pn + character(len=13) :: idflds(-7:10) + character(len=20) :: strng + character(len=23) :: dtme21 + character(len=30) :: idotyp(8) + character(len=80) :: line + character(len=256) :: tmpline, test + character(len=1024) :: fldrst='' + character(len=80) :: linein + character(len=30) :: ofile ! w3_cou only + character(len=8) :: words(7)='' + logical :: flflg, flhom, tflagi, prtfrm, flgnml, flh(-7:10) + integer :: thrlev = 1 + integer :: time0(2), timen(2), ttime(2) + character(len=80) :: msg1 + + 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' / + !--------------------------------------------------- + ! !--------------------------------------------------- - !-------------------------------------------------------------------- - ! 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 + flgr2 = .false. + flh(:) = .false. + iprt(:) = 0 + call print_logmsg(740+IAPROC, 'read_shel_config, step 1', w3_debuginit_flag) + + ndsi = 10 + ndss = 90 + ndso = 6 + ndse = 6 + ndst = 6 + if (w3_cou_flag) then + ndso = 333 + ndse = 333 + ndst = 333 end if - !-------------------------------------------------------------------- - ! Define output type and fields - !-------------------------------------------------------------------- + if ( iaproc .eq. naperr ) then + ndsen = ndse + else + ndsen = -1 + end if +#ifdef W3_OMPH + if ( iaproc .eq. napout ) write (ndso,905) MPI_THREAD_FUNNELED, thrlev +#endif + 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 + call print_logmsg(740+IAPROC, 'read_shel_config, step 2', w3_debuginit_flag) + + if (w3_nco_flag) then + ndsi = 11 + ndss = 90 + ndso = 6 + ndse = ndso + ndst = ndso + ndsf(1) = 12 + ndsf(2) = 13 + ndsf(3) = 14 + ndsf(4) = 15 + ndsf(5) = 16 + ndsf(6) = 17 + ndsf(7) = 18 + ndsf(8) = 19 + ndsf(9) = 20 + end if - ! Set number of output types. This is nomally set in w3_shel, CMB made 7. - notype = 7 + ! 1.c Local parameters - 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 + ! Default COMSTR to "$" (for when using nml input files) + COMSTR = "$" + call print_logmsg(740+IAPROC, 'read_shel_config, step 2', w3_debuginit_flag) - ! 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 + ! If using experimental mud or ice physics, additional lines will + ! be read in from read_shel_config.inp and applied, so JFIRST is + ! changed from its initialization setting "JFIRST=1" to some + ! lower value. + jfirst=1 + if (w3_ic1_flag) jfirst = -7 + if (w3_ic2_flag) jfirst = -7 + if (w3_is2_flag) jfirst = -7 + if (w3_ic3_flag) jfirst = -7 + if (w3_bt8_flag) jfirst = -7 + if (w3_bt9_flag) jfirst = -7 + if (w3_ic4_flag) jfirst = -7 + if (w3_ic5_flag) jfirst = -7 + + write(msg1,*)'JFIRST=', JFIRST + call print_logmsg(740+IAPROC, 'read_shel_config, step 4', trim(msg1), w3_debuginit_flag) - ! 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 + !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! 2. Define input fields + + inquire(file=trim(fnmpre)//"ww3_shel.nml", exist=flgnml) + + ! =============================================================== + ! process ww3_prnc namelist + ! =============================================================== + + if (flgnml) then + + !-------------------- + ! Read namelist + !-------------------- + + call w3nmlshel (mpi_comm, ndsi, trim(fnmpre)//'ww3_shel.nml', & + nml_domain, nml_input, nml_output_type, & + nml_output_date, nml_homog_count, & + nml_homog_input, ierr) + + !-------------------- + ! 2.1 forcing flags + !-------------------- + + flh(-7:10) = .false. + flagtfc(-7) = trim(nml_input%forcing%ice_param1) + flagtfc(-6) = trim(nml_input%forcing%ice_param2) + flagtfc(-5) = trim(nml_input%forcing%ice_param3) + flagtfc(-4) = trim(nml_input%forcing%ice_param4) + flagtfc(-3) = trim(nml_input%forcing%ice_param5) + flagtfc(-2) = trim(nml_input%forcing%mud_density) + flagtfc(-1) = trim(nml_input%forcing%mud_thickness) + flagtfc(0) = trim(nml_input%forcing%mud_viscosity) + flagtfc(1) = trim(nml_input%forcing%water_levels) + flagtfc(2) = trim(nml_input%forcing%currents) + flagtfc(3) = trim(nml_input%forcing%winds) + flagtfc(4) = trim(nml_input%forcing%ice_conc) + flagtfc(5) = trim(nml_input%forcing%atm_momentum) + flagtfc(6) = trim(nml_input%forcing%air_density) + flagtfc(7) = trim(nml_input%assim%mean) + flagtfc(8) = trim(nml_input%assim%spec1d) + flagtfc(9) = trim(nml_input%assim%spec2d) + + if (trim(nml_input%forcing%ice_param1) .eq. 'H') then + flagtfc(-7)='T' + flh(-7)=.true. + end if + if (trim(nml_input%forcing%ice_param2) .eq. 'H') THEN + flagtfc(-6)='T' + flh(-6)=.true. + end if + if (trim(nml_input%forcing%ice_param3) .eq. 'H') THEN + flagtfc(-5)='T' + flh(-5)=.true. + end if + if (trim(nml_input%forcing%ice_param4) .eq. 'H') THEN + flagtfc(-4)='T' + flh(-4)=.true. + end if + if (trim(nml_input%forcing%ice_param5) .eq. 'H') THEN + flagtfc(-3)='T' + flh(-3)=.true. + end if + if (trim(nml_input%forcing%mud_density) .eq. 'H') THEN + flagtfc(-2)='T' + flh(-2)=.true. + end if + if (trim(nml_input%forcing%mud_thickness) .eq. 'H') THEN + flagtfc(-1)='T' + flh(-1)=.true. + end if + if (trim(nml_input%forcing%mud_viscosity) .eq. 'H') THEN + flagtfc(0)='T' + flh(0)=.true. + end if + if (trim(nml_input%forcing%water_levels) .eq. 'H') THEN + flagtfc(1)='T' + flh(1)=.true. + end if + if (trim(nml_input%forcing%currents) .eq. 'H') THEN + flagtfc(2)='T' + flh(2)=.true. + end if + if (trim(nml_input%forcing%winds) .eq. 'H') THEN + flagtfc(3)='T' + flh(3)=.true. + end if + if (trim(nml_input%forcing%ice_conc) .eq. 'H') THEN + flagtfc(4)='T' + flh(4)=.true. + end if + if (trim(nml_input%forcing%atm_momentum) .eq. 'H') THEN + flagtfc(5)='T' + flh(5)=.true. + end if + if (trim(nml_input%forcing%air_density) .eq. 'H') THEN + flagtfc(6)='T' + flh(6)=.true. + end if + + if ( iaproc .eq. napout ) write (ndso, 920) + DO J=JFIRST, 9 + if (flagtfc(j).eq.'T') THEN + inflags1(j)=.true. + flagsc(j)=.false. + end if + if (flagtfc(j).eq.'F') THEN + inflags1(j)=.false. + flagsc(j)=.false. + end if + if (flagtfc(j).eq.'C') THEN + inflags1(j)=.true. + flagsc(j)=.true. + end if + if ( j .le. 6 ) then + flh(j) = flh(j) .and. inflags1(j) + end if + if ( inflags1(j) ) then + yesxno = 'YES/--' + else + yesxno = '---/NO' + end IF + if ( flh(j) ) then + strng = '(homogeneous field) ' + else if ( flagsc(j) ) then + strng = '(coupling field) ' + else + strng = ' ' + end if + if ( iaproc .eq. napout ) write (ndso,921) idflds(j), yesxno, strng + end do + if (w3_cou_flag) then + if (flagsc(1) .and. inflags1(2) .and. .not. flagsc(2)) goto 2102 + if (flagsc(2) .and. inflags1(1) .and. .not. flagsc(1)) goto 2102 + end if + + inflags1(10) = .false. + if (w3_mgw_flag .or. w3_mgp_flag) then + inflags1(10) = .true. + flh(10) = .true. + end if + if ( inflags1(10) .and. iaproc.eq.napout ) & + write (ndso,921) idflds(10), 'yes/--', ' ' + + flflg = inflags1(-7) .or. inflags1(-6) .or. inflags1(-5) .or. inflags1(-4) & + .or. inflags1(-3) .or. inflags1(-2) .or. inflags1(-1) & + .or. inflags1(0) .or. inflags1(1) .or. inflags1(2) & + .or. inflags1(3) .or. inflags1(4) .or. inflags1(5) & + .or. inflags1(6) .or. inflags1(7) .or. inflags1(8) & + .or. inflags1(9) + flhom = flh(-7) .or. flh(-6) .or. flh(-5) .or. flh(-4) & + .or. flh(-3) .or. flh(-2) .or. flh(-1) .or. flh(0) & + .or. flh(1) .or. flh(2) .or. flh(3) .or. flh(4) & + .or. flh(5) .or. flh(6) .or. flh(10) + + if ( iaproc .eq. napout ) write (ndso,922) + ! inflags2 is just "initial value of inflags1", i.e. does *not* get + ! changed when model reads last record of ice.ww3 + inflags2=inflags1 + if (w3_t_flag) then + write (ndst,9020) flflg, inflags1, flhom, flh + end if + + !-------------------- + ! 2.2 Time setup + !-------------------- + + read (nml_domain%start,*) time0 + call t2d(time0,startdate,ierr) + call d2j(startdate,startjulday,ierr) + read(nml_domain%stop,*) timen + call t2d(timen,stopdate,ierr) + call d2j(stopdate,stopjulday,ierr) + + !-------------------- + ! 2.3 Domain setup + !-------------------- + + iostyp = nml_domain%iostyp + if (w3_pdlib_flag) then + if (iostyp .gt. 1) then + write(*,*) 'iostyp not supported in domain decomposition mode' + call extcde ( 6666 ) + endif + end if + + call w3iogr ( 'GRID', ndsf(7) ) + if ( flagll ) then + factor = 1. + else + factor = 1.e-3 + end if + + !-------------------- + ! 2.4 Output dates + !-------------------- + + read(nml_output_date%field%start, *) odat(1), odat(2) + read(nml_output_date%field%stride, *) odat(3) + read(nml_output_date%field%stop, *) odat(4), odat(5) + + read(nml_output_date%field%outffile, *) ofiles(1) + ! outpts(i)%outstride(1)=odat(3,i) + + read(nml_output_date%point%start, *) odat(6), odat(7) + read(nml_output_date%point%stride, *) odat(8) + read(nml_output_date%point%stop, *) odat(9), odat(10) + + read(nml_output_date%point%outffile, *) ofiles(2) + ! outpts(i)%outstride(2)=odat(8,i) + + read(nml_output_date%track%start, *) odat(11), odat(12) + read(nml_output_date%track%stride, *) odat(13) + read(nml_output_date%track%stop, *) odat(14), odat(15) + + read(nml_output_date%restart%start, *) odat(16), odat(17) + read(nml_output_date%restart%stride, *) odat(18) + read(nml_output_date%restart%stop, *) odat(19), odat(20) + + read(nml_output_date%restart2%start, *) odat(36), odat(37) + read(nml_output_date%restart2%stride, *) odat(38) + read(nml_output_date%restart2%stop, *) odat(39), odat(40) + + read(nml_output_date%boundary%start, *) odat(21), odat(22) + read(nml_output_date%boundary%stride, *) odat(23) + read(nml_output_date%boundary%stop, *) odat(24), odat(25) + + read(nml_output_date%partition%start, *) odat(26), odat(27) + read(nml_output_date%partition%stride, *) odat(28) + read(nml_output_date%partition%stop, *) odat(29), odat(30) + + read(nml_output_date%coupling%start, *) odat(31), odat(32) + read(nml_output_date%coupling%stride, *) odat(33) + read(nml_output_date%coupling%stop, *) odat(34), odat(35) + + ! set the time stride at 0 or more + odat(3) = max ( 0 , odat(3) ) + odat(8) = max ( 0 , odat(8) ) + odat(13) = max ( 0 , odat(13) ) + odat(18) = max ( 0 , odat(18) ) + odat(23) = max ( 0 , odat(23) ) + odat(28) = max ( 0 , odat(28) ) + odat(33) = max ( 0 , odat(33) ) + odat(38) = max ( 0 , odat(38) ) + + if (w3_cou_flag) then + ! test the validity of the coupling time step + if (odat(33) == 0) then + if ( iaproc .eq. napout ) then + write(ndso,1010) odat(33), int(dtmax) end if + odat(33) = int(dtmax) + else if (mod(odat(33),int(dtmax)) .ne. 0) then + goto 2009 + end if + end if + + !-------------------- + ! 2.5 Output types + !-------------------- + + npts = 0 + notype = 6 + if (w3_cou_flag) then + notype = 7 + end if + do j = 1, notype + + ! outpts(i)%ofiles(j)=ofiles(j) + if ( odat(5*(j-1)+3) .ne. 0 ) then + + if ( j .eq. 1 ) then + + ! type 1: fields of mean wave parameters + fldout = nml_output_type%field%list + call w3flgrdflag ( ndso, ndso, ndse, fldout, flgd, flgrd, iaproc, napout, ierr ) + if ( ierr .ne. 0 ) goto 2222 + + else if ( j .eq. 2 ) then + + ! type 2: point output + open (newunit=ndsl, file=trim(fnmpre)//trim(nml_output_type%point%file), & + form='formatted', status='old', err=2104, iostat=ierr) + + ! first loop to count the number of points + ! second loop to allocate the array and store the points + ipts = 0 + do iloop=1,2 + rewind (ndsl) + + if ( iloop.eq.2) then + npts = ipts + if ( npts.gt.0 ) then + allocate ( x(npts), y(npts), pnames(npts) ) + ipts = 0 ! reset counter to be reused for next do loop + else + allocate ( x(1), y(1), pnames(1) ) + goto 2054 + end if + end if + + do + read (ndsl,*,err=2004,iostat=ierr) tmpline + ! if end of file or stopstring, then exit + if ( ierr.ne.0 .or. index(tmpline,"STOPSTRING").ne.0 ) exit + + ! leading blanks removed and placed on the right + test = adjustl ( tmpline ) + if ( test(1:1).eq.comstr .or. len_trim(test).eq.0 ) then + ! if comment or blank line, then skip + cycle + else + ! otherwise, backup to beginning of line + backspace ( ndsl, err=2004, iostat=ierr) + read (ndsl,*,err=2004,iostat=ierr) xx, yy, pn + end if + ipts = ipts + 1 + if ( iloop .eq. 1 ) cycle + if ( iloop .eq. 2 ) then + x(ipts) = xx + y(ipts) = yy + pnames(ipts) = pn + if ( iaproc .eq. napout ) then + if ( flagll ) then + if ( ipts .eq. 1 ) then + write (ndso,2945) factor*xx, factor*yy, pn + else + write (ndso,2946) ipts, factor*xx, factor*yy, pn + end if + else + if ( ipts .eq. 1 ) then + write (ndso,2955) factor*xx, factor*yy, pn + else + write (ndso,2956) ipts, factor*xx, factor*yy, pn + end if + end if + end if + end if ! iloop.eq.2 + end do ! end of file + end do ! iloop + close(ndsl) + + else if ( j .eq. 3 ) then + + ! Type 3: track output + tflagi = nml_output_type%track%format + if ( .not. tflagi ) nds(11) = -nds(11) + if ( iaproc .eq. napout ) then + if ( .not. tflagi ) then + write (ndso,3945) 'input', 'unformatted' + else + write (ndso,3945) 'input', 'formatted' + end if + end if + + else if ( j .eq. 6 ) then + + ! Type 6: partitioning + iprt(1) = nml_output_type%partition%x0 + iprt(2) = nml_output_type%partition%xn + iprt(3) = nml_output_type%partition%nx + iprt(4) = nml_output_type%partition%y0 + iprt(5) = nml_output_type%partition%yn + iprt(6) = nml_output_type%partition%ny + prtfrm = nml_output_type%partition%format + + if ( iaproc .eq. napout ) then + if ( prtfrm ) then + yesxno = 'YES/--' + else + yesxno = '---/NO' + end if + write (ndso,6945) iprt, yesxno + end if + + else if ( j .eq. 7 ) then +#ifdef W3_COU + ! Type 7: coupling + fldout = nml_output_type%coupling%sent + call w3flgrdflag ( ndso, ndso, ndse, fldout, flg2, flgr2, iaproc, napout, ierr ) + if ( ierr .ne. 0 ) goto 2222 + fldin = nml_output_type%coupling%received + cplt0 = nml_output_type%coupling%couplet0 +#endif + + end if ! j + end if ! odat + end do ! j + + ! Extra fields to be written in the restart + fldrst = nml_output_type%restart%extra + call w3flgrdflag ( ndso, ndso, ndse, fldrst, flogr, flogrr, iaproc, napout, ierr ) + if ( ierr .ne. 0 ) goto 2222 + + ! force minimal allocation to avoid memory seg fault + if ( .not.allocated(x) .and. npts.eq.0 ) allocate ( x(1), y(1), pnames(1) ) + + !-------------------- + ! 2.6 Homogeneous field data + !-------------------- + + if ( flhom ) then + if ( iaproc .eq. napout ) write (ndso,951) & + 'Homogeneous field data (and moving grid) ...' + + nh(-7) = nml_homog_count%n_ic1 + nh(-6) = nml_homog_count%n_ic2 + nh(-5) = nml_homog_count%n_ic3 + nh(-4) = nml_homog_count%n_ic4 + nh(-3) = nml_homog_count%n_ic5 + nh(-2) = nml_homog_count%n_mdn + nh(-1) = nml_homog_count%n_mth + nh(0) = nml_homog_count%n_mvs + nh(1) = nml_homog_count%n_lev + nh(2) = nml_homog_count%n_cur + nh(3) = nml_homog_count%n_wnd + nh(4) = nml_homog_count%n_ice + nh(5) = nml_homog_count%n_tau + nh(6) = nml_homog_count%n_rho + nh(10) = nml_homog_count%n_mov + + n_tot = nml_homog_count%n_tot + + do j=jfirst,10 + if ( nh(j) .gt. nhmax ) goto 2006 end do + + ! Store homogeneous fields + if ( n_tot .gt. 0 ) then + ihh(:)=0 + do ih=1,n_tot + read(nml_homog_input(ih)%name,*) idtst + select case (idtst) + case ('IC1') + j=-7 + case ('IC2') + j=-6 + case ('IC3') + j=-5 + case ('IC4') + j=-4 + case ('IC5') + j=-3 + case ('MDN') + j=-2 + case ('MTH') + j=-1 + case ('MVS') + j=0 + case ('LEV') + j=1 + case ('CUR') + j=2 + case ('WND') + j=3 + case ('ICE') + j=4 + case ('TAU') + j=5 + case ('RHO') + j=6 + case ('MOV') + j=10 + case DEFAULT + goto 2062 + end SELECT + ihh(j)=ihh(j)+1 + read(nml_homog_input(ih)%date,*) tho(:,j,ihh(j)) + ha(ihh(j),j) = nml_homog_input(ih)%value1 + hd(ihh(j),j) = nml_homog_input(ih)%value2 + hs(ihh(j),j) = nml_homog_input(ih)%value3 + end do + end if + + if (w3_o7_flag) then + do j=jfirst, 10 + if ( flh(j) .and. iaproc.eq.napout ) then + write (ndso,952) nh(j), idflds(j) + do i=1, nh(j) + if ( ( j .le. 1 ) .or. ( j .eq. 4 ) .or. ( j .eq. 6 ) ) then + write (ndso,953) i, tho(1,j,i), tho(2,j,i), ha(i,j) + else if ( ( j .eq. 2 ) .or. ( j .eq. 5 ) .or. ( j .eq. 10 ) ) then + write (ndso,953) i, tho(1,j,i), tho(2,j,i), ha(i,j), hd(i,j) + else if ( j .eq. 3 ) then + write (ndso,953) i, tho(1,j,i), tho(2,j,i), ha(i,j), hd(i,j), hs(i,j) + end if + end do + end if + end do + end if + + if ( ( flh(-7) .and. (nh(-7).eq.0) ) .or. & + ( flh(-6) .and. (nh(-6).eq.0) ) .or. & + ( flh(-5) .and. (nh(-5).eq.0) ) .or. & + ( flh(-4) .and. (nh(-4).eq.0) ) .or. & + ( flh(-3) .and. (nh(-3).eq.0) ) .or. & + ( flh(-2) .and. (nh(-2).eq.0) ) .or. & + ( flh(-1) .and. (nh(-1).eq.0) ) .or. & + ( flh(0) .and. (nh(0).eq.0) ) .or. & + ( flh(1) .and. (nh(1).eq.0) ) .or. & + ( flh(2) .and. (nh(2).eq.0) ) .or. & + ( flh(3) .and. (nh(3).eq.0) ) .or. & + ( flh(4) .and. (nh(4).eq.0) ) .or. & + ( flh(5) .and. (nh(5).eq.0) ) .or. & + ( flh(6) .and. (nh(6).eq.0) ) .or. & + ( flh(10) .and. (nh(10).eq.0) ) ) goto 2007 + + end if ! flhom + + end if ! flgnml + + ! + ! =============================================================== + ! process old read_shel_config.inp format + ! =============================================================== + ! + if (.not. flgnml) then + + call print_logmsg(740+IAPROC, ' fnmpre'//trim(fnmpre), w3_debuginit_flag) + open (ndsi,file=trim(fnmpre)//'ww3_shel.inp',status='old',iostat=ierr) + rewind (ndsi) + call print_logmsg(740+IAPROC, 'Before read 2002, case 1', w3_debuginit_flag) + !ar: i changed the error handling for err=2002, see commit message ... + + read (ndsi,'(a)') comstr + call print_logmsg(740+IAPROC, ' comstr='//trim(comstr), ' After read 2002, case 1', w3_debuginit_flag) + 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 + call print_logmsg(740+IAPROC, 'Before read 2002, case 2', w3_debuginit_flag) + read (ndsi,*) flagtfc(j), flh(j) + + write(msg1,*)' J=', j, ' FLAGTFC=', flagtfc(j), ' FLH=', flh(j) + call print_logmsg(740+IAPROC, trim(msg1), ' After read 2002, case 2', w3_debuginit_flag) + else + call print_logmsg(740+IAPROC, 'Before read 2002, case 3', w3_debuginit_flag) + read (ndsi,*) flagtfc(j) + + write(msg1,*) ' J=', j, ' FLAGTFC=', flagtfc(j) + call print_logmsg(740+IAPROC, trim(msg1), ' After read 2002, case 3 ', w3_debuginit_flag) + end if end do - if ( flt ) then - write (nds(1),'(a)') ' Fields : '//'no fields defined' + + if ( iaproc .eq. napout ) write (ndso,920) + do j=jfirst, 9 + if (flagtfc(j).eq.'T') then + inflags1(j)=.true. + flagsc(j)=.false. + end if + if (flagtfc(j).eq.'F') then + inflags1(j)=.false. + flagsc(j)=.false. + end if + if (flagtfc(j).eq.'C') then + inflags1(j)=.true. + flagsc(j)=.true. + end if + if ( j .le. 6 ) then + flh(j) = flh(j) .and. inflags1(j) + end if + if ( inflags1(j) ) then + yesxno = 'YES/--' + else + yesxno = '---/NO' + end if + if ( flh(j) ) then + strng = '(homogeneous field) ' + else if ( flagsc(j) ) then + strng = '(coupling field) ' + else + strng = ' ' + end if + if ( iaproc .eq. napout ) write (ndso,921) idflds(j), yesxno, strng + end do + if (w3_cou_flag) then + if (flagsc(1) .and. inflags1(2) .and. .not. flagsc(2)) goto 2102 + if (flagsc(2) .and. inflags1(1) .and. .not. flagsc(1)) goto 2102 end if - end if - ! npts, pnames are fpr point output - allocate ( x(1), y(1), pnames(1) ) - npts = 0 - pnames(1) = ' ' - prtfrm = .false. + call print_memcheck(740+IAPROC, 'memcheck_____:'//'read_shel_config SECTION 2b') + call print_logmsg(740+IAPROC, 'read_shel_config, step 5', w3_debuginit_flag) - end subroutine set_shel_inp + inflags1(10) = .false. + if (w3_mgw_flag .or. w3_mgp_flag) then + inflags1(10) = .true. + flh(10) = .true. + end if + if ( inflags1(10) .and. iaproc.eq.napout ) & + write (ndso,921) idflds(10), 'yes/--', ' ' + + flflg = inflags1(-7) .or. inflags1(-6) .or. inflags1(-5) .or. inflags1(-4) & + .or. inflags1(-3) .or. inflags1(-2) .or. inflags1(-1) & + .or. inflags1(0) .or. inflags1(1) .or. inflags1(2) & + .or. inflags1(3) .or. inflags1(4) .or. inflags1(5) & + .or. inflags1(6) .or. inflags1(7) .or. inflags1(8) & + .or. inflags1(9) + flhom = flh(-7) .or. flh(-6) .or. flh(-5) .or. flh(-4) & + .or. flh(-3) .or. flh(-2) .or. flh(-1) .or. flh(0) & + .or. flh(1) .or. flh(2) .or. flh(3) .or. flh(4) & + .or. flh(5) .or. flh(6) .or. flh(10) + + if ( iaproc .eq. napout ) write (ndso,922) + ! inflags2 is just "initial value of inflags1", i.e. does *not* get + ! changed when model reads last record of ice.ww3 + inflags2=inflags1 + + if (w3_t_flag) then + write (ndst,9020) flflg, inflags1, flhom, flh + end if - !=============================================================================== -!> 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 + !-------------------- + ! 2.2 Time setup + !-------------------- + + call nextln ( comstr , ndsi , ndsen ) + call print_logmsg(740+IAPROC, 'Before read 2002, case 4', w3_debuginit_flag) + read (ndsi,*) time0 + + call print_logmsg(740+IAPROC, ' After read 2002, case 4', w3_debuginit_flag) + call print_memcheck(740+IAPROC, 'memcheck_____:'//'read_shel_config SECTION 2c') + + call nextln ( comstr , ndsi , ndsen ) + call print_logmsg(740+IAPROC, 'Before read 2002, case 5', w3_debuginit_flag) + read (ndsi,*) timen + call print_logmsg(740+IAPROC, ' After read 2002, case 5', 'read_shel_config, step 6', w3_debuginit_flag) + call print_memcheck(740+IAPROC, 'memcheck_____:'//'read_shel_config SECTION 2d') + + !-------------------- + ! 2.3 Domain setup + !-------------------- + + call print_logmsg(740+IAPROC, 'read_shel_config, step 7', w3_debuginit_flag) + call nextln ( COMSTR , NDSI , NDSEN ) + call print_logmsg(740+IAPROC, 'Before read 2002, case 6', w3_debuginit_flag) + read (ndsi,*) iostyp + if (w3_pdlib_flag) then + if (iostyp .gt. 1) then + write(*,*) 'iostyp not supported in domain decomposition mode' + call extcde ( 6666 ) + endif + end if + call print_logmsg(740+IAPROC, ' After read 2002, case 6', w3_debuginit_flag) + call w3iogr ( 'GRID', ndsf(7) ) + if ( flagll ) then + factor = 1. + else + factor = 1.e-3 + end if + call print_logmsg(740+IAPROC, 'read_shel_config, step 8', w3_debuginit_flag) - ! 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 + !-------------------- + ! 2.4 Output dates + !-------------------- - ! 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 + npts = 0 + notype = 6 + if (w3_cou_flag) then + notype = 7 + end if + call print_logmsg(740+IAPROC, 'Before NOTYPE loop', w3_debuginit_flag) + do j = 1, notype + write(msg1,*)'J=', J, '/ NOTYPE=', NOTYPE + call print_logmsg(740+IAPROC, trim(msg1), w3_debuginit_flag) + call nextln ( comstr , ndsi , ndsen ) + call print_logmsg(740+IAPROC, 'Before read 2002, case 7', w3_debuginit_flag) + + ! 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 - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*) TIME0 - CALL NEXTLN ( COMSTR , NDSI , NDSEN ) - READ (NDSI,*) TIMEN + if (words(6) .ne. '0' .and. words(6) .ne. '1') then + ofiles(j)=0 + else + read(words( 6 ), * ) ofiles(j) + end if - ! 2.3 Domain setup + else if(j .eq. 7) then - 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 +#ifdef W3_COU + words(1:6)='' + read (ndsi,'(a)') linein + read(linein,*,iostat=ierr) words - ! 2.4 Output dates + read(words( 1 ), * ) odat(31) + read(words( 2 ), * ) odat(32) + read(words( 3 ), * ) odat(33) + read(words( 4 ), * ) odat(34) + read(words( 5 ), * ) odat(35) - 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 + if (words(6) .eq. 'T') then + cplt0 = .true. + else + cplt0 = .false. + end if +#endif - 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 + else - ! 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 + ofiles(j)=0 + read (ndsi,*,end=2001,err=2002)(odat(i),i=5*(j-1)+1,5*j) - ! 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 + end if !j le 2 + ! write(*,*) 'ofiles(j)= ', ofiles(j),j + ! + call print_logmsg(740+IAPROC, ' After read 2002, case 7', w3_debuginit_flag) + odat(5*(j-1)+3) = max ( 0 , odat(5*(j-1)+3) ) + ! + write(msg1, *) 'read_shel_config NOTTYPE', J + call print_memcheck(740+IAPROC, 'memcheck_____:'//trim(msg1)) + + !-------------------- + ! 2.5 Output types + !-------------------- + + if ( odat(5*(j-1)+3) .ne. 0 ) then + + call print_logmsg(740+IAPROC, ' Case analysis', w3_debuginit_flag) + if ( j .eq. 1 ) then + + ! type 1: fields of mean wave parameters + call w3readflgrd ( ndsi, ndso, 9, ndsen, comstr, flgd, flgrd, iaproc, napout, ierr ) + if ( ierr .ne. 0 ) goto 2222 + + else if ( j .eq. 2 ) then + + ! type 2: point output + do iloop=1,2 + if ( iloop .eq. 1 ) then + ndsi2 = ndsi + if ( iaproc .eq. 1 ) open (ndss,file=trim(fnmpre)//'ww3_shel.scratch') + else + ndsi2 = ndss +#ifdef W3_MPI + call mpi_barrier (mpi_comm,ierr_mpi) +#endif + open (ndss,file=trim(fnmpre)//'ww3_shel.scratch') + rewind (ndss) + + if ( .not.allocated(x) ) then + if ( npts.gt.0 ) then + allocate ( x(npts), y(npts), pnames(npts) ) + else + allocate ( x(1), y(1), pnames(1) ) + goto 2054 + end if + end if + end if + + npts = 0 + do + call nextln ( comstr , ndsi , ndsen ) + call print_logmsg(740+IAPROC, 'before read 2002, case 8', w3_debuginit_flag) + read (ndsi2,*) xx, yy, pn + call print_logmsg(740+IAPROC, ' After read 2002, case 8', w3_debuginit_flag) + 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 +#ifdef W3_MPI + call mpi_barrier ( mpi_comm, ierr_mpi ) +#endif + close (ndss,status='delete') + else +#ifdef W3_MPI + call mpi_barrier ( mpi_comm, ierr_mpi ) #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 + close (ndss) + end if + + else if ( j .eq. 3 ) then + + ! Type 3: track output + call nextln ( comstr , ndsi , ndsen ) + call print_logmsg(740+IAPROC, 'Before read 2002, case 9', w3_debuginit_flag) + read (ndsi,*) tflagi + call print_logmsg(740+IAPROC, ' After read 2002, case 9', w3_debuginit_flag) + + if ( .not. tflagi ) nds(11) = -nds(11) + if ( iaproc .eq. napout ) then + if ( .not. tflagi ) then + write (ndso,3945) 'input', 'UNFORMATTED' + else + write (ndso,3945) 'input', 'FORMATTED' + end if + end if + + else if ( j .eq. 6 ) then + + ! Type 6: partitioning + ! IPRT: IX0, IXN, IXS, IY0, IYN, IYS + call nextln ( comstr , ndsi , ndsen ) + call print_logmsg(740+IAPROC, 'Before reading IPRT', 'Before read 2002, case 10', w3_debuginit_flag) + read (ndsi,*) iprt, prtfrm + call print_logmsg(740+IAPROC, ' After read 2002, case 10', w3_debuginit_flag) + + if ( iaproc .eq. napout ) then + if ( prtfrm ) then + yesxno = 'YES/--' + else + yesxno = '---/NO' + end if + write (ndso,6945) iprt, yesxno + end if + + else if ( j .eq. 7 ) then + + ! Type 7: coupling +#ifdef W3_COU + call w3readflgrd ( ndsi, ndso, ndss, ndsen, comstr, flg2, flgr2, iaproc, napout, ierr ) + if ( ierr .ne. 0 ) goto 2222 + call nextln ( comstr , ndsi , ndsen ) + read (ndsi,'(a)',end=2001,err=2002,iostat=ierr) fldin +#endif + + end if ! j + + end if ! odat + end if ! if j=4 + end do ! j + + ! force minimal allocation to avoid memory seg fault + if ( .not.allocated(x) .and. npts.eq.0 ) allocate ( x(1), y(1), pnames(1) ) + + !-------------------- + ! 2.6 Homogeneous field data + !-------------------- + + 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 ) + call print_logmsg(740+IAPROC, 'before read 2002, case 11', w3_debuginit_flag) + read (ndsi,*) idtst + call print_logmsg(740+IAPROC, ' after read 2002, case 11', w3_debuginit_flag) + + + ! 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 + call print_logmsg(740+IAPROC, 'Before read 2002, case 12', w3_debuginit_flag) + read (ndsi,*) idtst, & + tho(1,j,nh(j)), tho(2,j,nh(j)), & + ha(nh(j),j) + call print_logmsg(740+IAPROC, ' After read 2002, case 12', w3_debuginit_flag) + ELSE IF ( J .EQ. 2 ) THEN ! currents: get HA and HD + call print_logmsg(740+IAPROC, 'Before read 2002, case 13', w3_debuginit_flag) + read (ndsi,*) idtst, & + tho(1,j,nh(j)), tho(2,j,nh(j)), & + ha(nh(j),j), hd(nh(j),j) + call print_logmsg(740+IAPROC, ' After read 2002, case 13', w3_debuginit_flag) + ELSE IF ( J .EQ. 3 ) THEN ! wind: get HA HD and HS + call print_logmsg(740+IAPROC, 'Before read 2002, case 14', w3_debuginit_flag) + 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) + call print_logmsg(740+IAPROC, ' After read 2002, case 14', w3_debuginit_flag) + ELSE IF ( J .EQ. 4 ) THEN ! ice + call print_logmsg(740+IAPROC, 'Before read 2002, case 15', w3_debuginit_flag) + read (ndsi,*) idtst, & + tho(1,j,nh(j)), tho(2,j,nh(j)), & + ha(nh(j),j) + call print_logmsg(740+IAPROC, ' After read 2002, case 15', w3_debuginit_flag) + ELSE IF ( J .EQ. 5 ) THEN ! atmospheric momentum + call print_logmsg(740+IAPROC, 'Before read 2002, case 16', w3_debuginit_flag) + read (ndsi,*) idtst, & + tho(1,j,nh(j)), tho(2,j,nh(j)), & + ha(nh(j),j), hd(nh(j),j) + call print_logmsg(740+IAPROC, ' After read 2002, case 16', w3_debuginit_flag) + ELSE IF ( J .EQ. 6 ) THEN ! air density + call print_logmsg(740+IAPROC, 'Before read 2002, case 17', w3_debuginit_flag) + read (ndsi,*) idtst, & + tho(1,j,nh(j)), tho(2,j,nh(j)), & + ha(nh(j),j) + call print_logmsg(740+IAPROC, ' After read 2002, case 17', w3_debuginit_flag) + ELSE IF ( J .EQ. 10 ) THEN ! mov: HA and HD + call print_logmsg(740+IAPROC, 'Before read 2002, case 18', w3_debuginit_flag) + read (ndsi,*) idtst, & + tho(1,j,nh(j)), tho(2,j,nh(j)), & + ha(nh(j),j), hd(nh(j),j) + call print_logmsg(740+IAPROC, ' After read 2002, case 18', w3_debuginit_flag) + END IF + end if + end do + end do + call print_memcheck(740+IAPROC, 'memcheck_____:'//'read_shel_config SECTION 3') + + if (w3_o7_flag) then + do j=jfirst, 10 + if ( flh(j) .and. iaproc.eq.napout ) then + write (ndso,952) nh(j), idflds(j) + do i=1, nh(j) + if ( ( j .le. 1 ) .or. ( j .eq. 4 ) .or. ( j .eq. 6 ) ) then + write (ndso,953) i, tho(1,j,i), tho(2,j,i), ha(i,j) + else if ( ( j .eq. 2 ) .or. ( j .eq. 5 ) .or. ( j .eq. 10 ) ) then + write (ndso,953) i, tho(1,j,i), tho(2,j,i), ha(i,j), hd(i,j) + else if ( j .eq. 3 ) then + write (ndso,953) i, tho(1,j,i), tho(2,j,i), ha(i,j), hd(i,j), hs(i,j) + end if + end do + end if + end do + end if + + if ( ( flh(-7) .and. (nh(-7).eq.0) ) .or. & + ( flh(-6) .and. (nh(-6).eq.0) ) .or. & + ( flh(-5) .and. (nh(-5).eq.0) ) .or. & + ( flh(-4) .and. (nh(-4).eq.0) ) .or. & + ( flh(-3) .and. (nh(-3).eq.0) ) .or. & + ( flh(-2) .and. (nh(-2).eq.0) ) .or. & + ( flh(-1) .and. (nh(-1).eq.0) ) .or. & + ( flh(0) .and. (nh(0).eq.0) ) .or. & + ( flh(1) .and. (nh(1).eq.0) ) .or. & + ( flh(2) .and. (nh(2).eq.0) ) .or. & + ( flh(3) .and. (nh(3).eq.0) ) .or. & + ( flh(4) .and. (nh(4).eq.0) ) .or. & + ( flh(5) .and. (nh(5).eq.0) ) .or. & + ( flh(6) .and. (nh(6).eq.0) ) .or. & + ( flh(10) .and. (nh(10).eq.0) ) ) goto 2007 + + end if ! flhom + close(ndsi) + end if ! .not. flgnml + + call print_memcheck(740+IAPROC, 'memcheck_____:'//'read_shel_config SECTION 4') + + !-------------------- ! 2.2 Time setup + !-------------------- + + if (present(time0_overwrite) .and. present(timen_overwrite)) then + time0(:) = time0_overwrite(:) + timen(:) = timen_overwrite(:) + do j = 1,notype + if (odat(5*(j-1)+3) .ne. 0 ) then ! non-zero stride + odat(5*(j-1)+1) = time0(1) + odat(5*(j-1)+2) = time0(2) + odat(5*(j-1)+4) = timen(1) + odat(5*(j-1)+5) = timen(2) + end if + end do + j=8 + if (odat(5*(j-1)+3) .ne. 0) then ! non-zero stride + odat(5*(j-1)+1) = time0(1) + odat(5*(j-1)+2) = time0(2) + odat(5*(j-1)+4) = timen(1) + odat(5*(j-1)+5) = timen(2) + end if + end if - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,930) - 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 + if ( iaproc .eq. napout ) write (ndso,930) + call stme21 ( time0 , dtme21 ) + if ( iaproc .eq. napout ) write (ndso,931) dtme21 + time = time0 + call stme21 ( timen , dtme21 ) + if ( iaproc .eq. napout ) write (ndso,932) dtme21 +#ifdef W3_OASIS + time00 = time0 + timeend = timen +#endif +#ifdef W3_NL5 + qi5tbeg = time0 +#endif + dttst = dsec21 ( time0 , timen ) + if ( dttst .le. 0. ) goto 2003 + + !-------------------- ! 2.3 Domain setup + !-------------------- + + iostyp = max ( 0 , min ( 3 , iostyp ) ) + if (w3_pdlib_flag) then + if (iostyp .gt. 1) then + write(*,*) 'iostyp not supported in domain decomposition mode' + call extcde ( 6666 ) + end if + endif + + if ( iaproc .eq. napout ) then + if ( iostyp .eq. 0 ) then + write (ndso,940) 'No dedicated output process, parallel file system required.' + else if ( iostyp .eq. 1 ) then + write (ndso,940) 'No dedicated output process, any file system.' + else if ( iostyp .eq. 2 ) then + write (ndso,940) 'Single dedicated output process.' + else if ( iostyp .eq. 3 ) then + write (ndso,940) 'Multiple dedicated output processes.' + else + write (ndso,940) 'IOSTYP NOT RECOGNIZED' + end if + end if - 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 + ! TODO: the following documents the output dates according to + ! the nml/inp files. Check if it be removed if user controls + ! output w/ alarms ! 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 + 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 + j=8 + if (odat(5*(j-1)+3) .ne. 0) then + if ( iaproc .eq. napout ) write (ndso,941) j, idotyp(j) + ttime(1) = odat(5*(j-1)+1) + ttime(2) = odat(5*(j-1)+2) + call stme21 ( ttime , dtme21 ) + if ( iaproc .eq. napout ) write (ndso,942) dtme21 + ttime(1) = odat(5*(j-1)+4) + ttime(2) = odat(5*(j-1)+5) + call stme21 ( ttime , dtme21 ) + if ( iaproc .eq. napout ) write (ndso,943) dtme21 + ttime(1) = 0 + ttime(2) = 0 + dttst = real ( odat(5*(j-1)+3) ) + call tick21 ( ttime , dttst ) + call stme21 ( ttime , dtme21 ) + if ( ( odat(5*(j-1)+1) .ne. odat(5*(j-1)+4) .or. & + odat(5*(j-1)+2) .ne. odat(5*(j-1)+5) ) .and. & + iaproc .eq. napout ) then + if ( dtme21(9:9) .ne. '0' ) then + write (ndso,1944) dtme21( 9:19) + else if ( dtme21(10:10) .ne. '0' ) then + write (ndso,2944) dtme21(10:19) + else + write (ndso,3944) dtme21(12:19) + end if + end if + 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. + + if (w3_t_flag) then + write (ndst,9040) odat + write (ndst,9041) flgrd + write (ndst,9042) iprt, prtfrm + end if + if (.not. present(time0_overwrite) .and. .not. present(timen_overwrite)) then + ! + ! For outputs with non-zero time step, check dates : + ! If output ends before run start OR output starts after run end, + ! deactivate output cleanly with output time step = 0 + ! This is usefull for IOSTYP=3 (Multiple dedicated output processes) + ! to avoid the definition of dedicated proc. for unused output. + ! + do j = 1, notype + dttst = dsec21 ( time0 , odat(5*(j-1)+4:5*(j-1)+5) ) + if ( dttst .lt. 0 ) then + odat(5*(j-1)+3) = 0 + if ( iaproc .eq. napout ) write (ndso,8945) trim(idotyp(j)) + continue + end if + dttst = dsec21 ( odat(5*(j-1)+1:5*(j-1)+2), timen ) + if ( dttst .lt. 0 ) then + odat(5*(j-1)+3) = 0 + if ( iaproc .eq. napout ) write (ndso,8945) trim(idotyp(j)) + continue + end if + end do + end if + + ! checkpoint + j = 8 + dttst = dsec21 ( time0 , odat(5*(j-1)+4:5*(j-1)+5) ) + if ( dttst .lt. 0 ) then + odat(5*(j-1)+3) = 0 + if ( iaproc .eq. napout ) write (ndso,8945) trim(idotyp(j)) + continue + 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 ! - 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 + + call print_memcheck(740+IAPROC, 'memcheck_____:'//'read_shel_config SECTION 5') !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 5. Initializations - IF ( IAPROC .EQ. NAPOUT ) WRITE (NDSO,951) 'Wave model ...' - GOTO 2222 + if ( iaproc .eq. napout ) write (ndso,951) 'Wave model ...' + goto 2222 ! Error escape locations 2001 CONTINUE @@ -976,9 +1503,18 @@ subroutine read_shel_inp(mpi_comm) 2002 CONTINUE IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1002) IERR CALL EXTCDE ( 1002 ) +2102 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1102) + CALL EXTCDE ( 1102 ) 2003 CONTINUE IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1003) CALL EXTCDE ( 1003 ) +2104 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1104) IERR + CALL EXTCDE ( 1104 ) +2004 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1004) IERR + CALL EXTCDE ( 1004 ) 2005 CONTINUE IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1005) IDTST CALL EXTCDE ( 1005 ) @@ -988,10 +1524,15 @@ subroutine read_shel_inp(mpi_comm) 2006 CONTINUE IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1006) IDTST, NH(J) CALL EXTCDE ( 1006 ) +2062 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1062) IDTST + CALL EXTCDE ( 1062 ) 2007 CONTINUE IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1007) CALL EXTCDE ( 1007 ) - +2009 CONTINUE + IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1009) ODAT(33), NINT(DTMAX) + CALL EXTCDE ( 1009 ) 2222 CONTINUE ! Formats @@ -999,25 +1540,30 @@ subroutine read_shel_inp(mpi_comm) 15X,'==============================================='/) 901 FORMAT ( ' Comment character is ''',A,''''/) 905 FORMAT ( ' Hybrid MPI/OMP thread support level:'/ & - ' Requested: ', I2/ & - ' Provided: ', I2/ ) + ' Requested: ', I2/ & + ' Provided: ', I2/ ) 920 FORMAT (/' Input fields : '/ & - ' --------------------------------------------------') + ' --------------------------------------------------') 921 FORMAT ( ' ',A,2X,A,2X,A) 922 FORMAT ( ' ' ) 930 FORMAT (/' Time interval : '/ & - ' --------------------------------------------------') + ' --------------------------------------------------') 931 FORMAT ( ' Starting time : ',A) 932 FORMAT ( ' Ending time : ',A/) 940 FORMAT (/' Output requests : '/ & - ' --------------------------------------------------'/ & - ' ',A) + ' --------------------------------------------------'/ & + ' ',A) 941 FORMAT (/' Type',I2,' : ',A/ & - ' -----------------------------------------') + ' -----------------------------------------') 942 FORMAT ( ' From : ',A) 943 FORMAT ( ' To : ',A) +954 FORMAT ( ' ',A,': file not needed') +955 FORMAT ( ' ',A,': file OK') +956 FORMAT ( ' ',A,': file OK, recl =',I3, & + ' undef = ',E10.3) 1944 FORMAT ( ' Interval : ', 8X,A11/) 2944 FORMAT ( ' Interval : ', 9X,A10/) +3944 FORMAT ( ' Interval : ',11X,A8/) 2945 FORMAT ( ' Point 1 : ',2F8.2,2X,A) 2955 FORMAT ( ' Point 1 : ',2(F8.1,'E3'),2X,A) 2946 FORMAT ( ' ',I6,' : ',2F8.2,2X,A) @@ -1025,33 +1571,59 @@ subroutine read_shel_inp(mpi_comm) 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/) - + ' IY first,last,inc :',3I5/ & + ' Formatted file : ',A) 8945 FORMAT ( ' output dates out of run dates : ', A, & ' deactivated') +950 FORMAT (/' Initializations :'/ & + ' --------------------------------------------------') 951 FORMAT ( ' ',A) 952 FORMAT ( ' ',I6,2X,A) 953 FORMAT ( ' ',I6,I11.8,I7.6,3E12.4) 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' PREMATURE END OF INPUT FILE'/) + ' PREMATURE END OF INPUT FILE'/) 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' ERROR IN READING FROM INPUT FILE'/ & - ' IOSTAT =',I5/) + ' ERROR IN READING FROM INPUT FILE'/ & + ' IOSTAT =',I5/) +1102 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & + ' LEVEL AND CURRENT ARE MIXING COUPLED AND FORCED'/& + ' IT MUST BE FULLY COUPLED OR DISABLED '/) 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' ILLEGAL TIME INTERVAL'/) + ' ILLEGAL TIME INTERVAL'/) +1104 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & + ' ERROR IN OPENING POINT FILE'/ & + ' IOSTAT =',I5/) +1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & + ' ERROR IN READING FROM POINT FILE'/ & + ' IOSTAT =',I5/) 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' ILLEGAL ID STRING HOMOGENEOUS FIELD : ',A/) + ' ILLEGAL ID STRING HOMOGENEOUS FIELD : ',A/) 1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' TOO MANY HOMOGENEOUS FIELDS : ',A,1X,I4/) + ' TOO MANY HOMOGENEOUS FIELDS : ',A,1X,I4/) +1062 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : ***'/ & + ' HOMOGENEOUS NAME NOT RECOGNIZED : ', A/) 1007 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' INSUFFICIENT DATA FOR HOMOGENEOUS FIELDS'/) + ' INSUFFICIENT DATA FOR HOMOGENEOUS FIELDS'/) 1008 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' ERROR IN OPENING OUTPUT FILE'/ & - ' IOSTAT =',I5/) + ' ERROR IN OPENING OUTPUT FILE'/ & + ' IOSTAT =',I5/) +1009 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & + ' COUPLING TIME STEP NOT MULTIPLE OF'/ & + ' MODEL TIME STEP: ',I6, I6/) +1010 FORMAT (/' *** WAVEWATCH III WARNING IN W3SHEL : *** '/ & + ' COUPLING TIME STEP NOT DEFINED, '/ & + ' IT WILL BE OVERRIDEN TO DEFAULT VALUE'/ & + ' FROM ',I6, ' TO ',I6/) 1054 FORMAT (/' *** WAVEWATCH III ERROR IN W3SHEL : *** '/ & - ' POINT OUTPUT ACTIVATED BUT NO POINTS DEFINED'/) - end subroutine read_shel_inp + ' POINT OUTPUT ACTIVATED BUT NO POINTS DEFINED'/) +9000 FORMAT ( ' TEST W3SHEL : UNIT NUMBERS :',12I4) +9001 FORMAT ( ' TEST W3SHEL : SUBR. TRACING :',2I4) +9020 FORMAT ( ' TEST W3SHEL : FLAGS DEF / HOM : ',9L2,2X,9L2) +9040 FORMAT ( ' TEST W3SHEL : ODAT : ',I9.8,I7.6,I7,I9.8,I7.6, & + 4(/24X,I9.8,I7.6,I7,I9.8,I7.6) ) +9041 FORMAT ( ' TEST W3SHEL : FLGRD : ',20L2) +9042 FORMAT ( ' TEST W3SHEL : IPR, PRFRM : ',6I6,1X,L1) + + end subroutine read_shel_config end module wav_shel_inp diff --git a/model/src/wav_shr_flags.F90 b/model/src/wav_shr_flags.F90 new file mode 100644 index 0000000000..704c16893e --- /dev/null +++ b/model/src/wav_shr_flags.F90 @@ -0,0 +1,1201 @@ +!> @file wav_shr_flags +!! +!> Shared flags matching compile time options +!! +!> @details Sets logical flags to according to compile time +!! options +!! +!> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov +!> @date 07-01-2022 +module wav_shr_flags + + implicit none + public + +#ifdef W3_DIST + logical, parameter :: w3_dist_flag = .true. !< @public a flag for "W3_DIST" +#else + logical, parameter :: w3_dist_flag = .false. !< @public a flag for "W3_DIST" +#endif +#ifdef W3_SHRD + logical, parameter :: w3_shrd_flag = .true. !< @public a flag for "W3_SHRD" +#else + logical, parameter :: w3_shrd_flag = .false. !< @public a flag for "W3_SHRD" +#endif + ! debug/logging +#ifdef W3_DEBUG + logical, parameter :: w3_debug_flag = .true. !< @public a flag for "W3_DEBUG" +#else + logical, parameter :: w3_debug_flag = .false. !< @public a flag for "W3_DEBUG" +#endif +#ifdef W3_DEBUGGRID + logical, parameter :: w3_debuggrid_flag = .true. !< @public a flag for "W3_DEBUGGRID" +#else + logical, parameter :: w3_debuggrid_flag = .false. !< @public a flag for "W3_DEBUGGRID" +#endif + +#ifdef W3_DEBUGSTP + logical, parameter :: w3_debugstp_flag = .true. !< @public a flag for "W3_DEBUGSTP" +#else + logical, parameter :: w3_debugstp_flag = .false. !< @public a flag for "W3_DEBUGSTP" +#endif + +#ifdef W3_DEBUGFLS + logical, parameter :: w3_debugfls_flag = .true. !< @public a flag for "W3_DEBUGFLS" +#else + logical, parameter :: w3_debugfls_flag = .false. !< @public a flag for "W3_DEBUGFLS" +#endif + +#ifdef W3_DEBUGCOH + logical, parameter :: w3_debugcoh_flag = .true. !< @public a flag for "W3_DEBUGCOH" +#else + logical, parameter :: w3_debugcoh_flag = .false. !< @public a flag for "W3_DEBUGCOH" +#endif + +#ifdef W3_DEBUGIOBP + logical, parameter :: w3_debugiobp_flag = .true. !< @public a flag for "W3_DEBUGIOBP" +#else + logical, parameter :: w3_debugiobp_flag = .false. !< @public a flag for "W3_DEBUGIOBP" +#endif + +#ifdef W3_DEBUGIOGR + logical, parameter :: w3_debugiogr_flag = .true. !< @public a flag for "W3_DEBUGIOGR" +#else + logical, parameter :: w3_debugiogr_flag = .false. !< @public a flag for "W3_DEBUGIOGR" +#endif + +#ifdef W3_DEBUGIOBC + logical, parameter :: w3_debugiobc_flag = .true. !< @public a flag for "W3_DEBUGIOBC" +#else + logical, parameter :: w3_debugiobc_flag = .false. !< @public a flag for "W3_DEBUGIOBC" +#endif +#ifdef W3_DEBUGDCXDX + logical, parameter :: w3_debugdcxdx_flag = .true. !< @public a flag for "W3_DEBUGDCXDX" +#else + logical, parameter :: w3_debugdcxdx_flag = .false. !< @public a flag for "W3_DEBUGDCXDX" +#endif + +#ifdef W3_DEBUSETIOBP + logical, parameter :: w3_debugsetiobp_flag = .true. !< @public a flag for "W3_DEBUSETIOBP" +#else + logical, parameter :: w3_debugsetiobp_flag = .false. !< @public a flag for "W3_DEBUSETIOBP" +#endif + +#ifdef W3_DEBUSETUGIOBP + logical, parameter :: w3_debugsetugiobp_flag = .true. !< @public a flag for "W3_DEBUSETUGIOBP" +#else + logical, parameter :: w3_debugsetugiobp_flag = .false. !< @public a flag for "W3_DEBUSETUGIOBP" +#endif + +#ifdef W3_DEBUGSRC + logical, parameter :: w3_debugsrc_flag = .true. !< @public a flag for "W3_DEBUGSRC" +#else + logical, parameter :: w3_debugsrc_flag = .false. !< @public a flag for "W3_DEBUGSRC" +#endif + +#ifdef W3_DEBUGINIT + logical, parameter :: w3_debuginit_flag = .true. !< @public a flag for "W3_DEBUGINIT" +#else + logical, parameter :: w3_debuginit_flag = .false. !< @public a flag for "W3_DEBUGINIT" +#endif + +#ifdef W3_DEBUGRUN + logical, parameter :: w3_debugrun_flag = .true. !< @public a flag for "W3_DEBUGRUN" +#else + logical, parameter :: w3_debugrun_flag = .false. !< @public a flag for "W3_DEBUGRUN" +#endif + +#ifdef W3_DEBUGIO + logical, parameter :: w3_debugio_flag = .true. !< @public a flag for "W3_DEBUGIO" +#else + logical, parameter :: w3_debugio_flag = .false. !< @public a flag for "W3_DEBUGIO" +#endif +#ifdef W3_DEBUGW3ULEV + logical, parameter :: w3_debugw3ulev_flag = .true. !< @public a flag for "W3_DEBUGW3ULEV" +#else + logical, parameter :: w3_debugw3ulev_flag = .false. !< @public a flag for "W3_DEBUGW3ULEV" +#endif + +#ifdef W3_TIMINGS + logical, parameter :: w3_timings_flag = .true. !< @public a flag for "W3_TIMINGS" +#else + logical, parameter :: w3_timings_flag = .false. !< @public a flag for "W3_TIMINGS" +#endif +#ifdef W3_TS + logical, parameter :: w3_ts_flag = .true. !< @public a flag for "W3_TS" +#else + logical, parameter :: w3_ts_flag = .false. !< @public a flag for "W3_TS" +#endif + + ! propagation/gse + +#ifdef W3_PR0 + logical, parameter :: w3_pr0_flag = .true. !< @public a flag for "W3_PR0" +#else + logical, parameter :: w3_pr0_flag = .false. !< @public a flag for "W3_PR0" +#endif + +#ifdef W3_PR1 + logical, parameter :: w3_pr1_flag = .true. !< @public a flag for "W3_PR1" +#else + logical, parameter :: w3_pr1_flag = .false. !< @public a flag for "W3_PR1" +#endif + +#ifdef W3_PR2 + logical, parameter :: w3_pr2_flag = .true. !< @public a flag for "W3_PR2" +#else + logical, parameter :: w3_pr2_flag = .false. !< @public a flag for "W3_PR2" +#endif + +#ifdef W3_PR3 + logical, parameter :: w3_pr3_flag = .true. !< @public a flag for "W3_PR3" +#else + logical, parameter :: w3_pr3_flag = .false. !< @public a flag for "W3_PR3" +#endif + +#ifdef W3_UNO + logical, parameter :: w3_uno_flag = .true. !< @public a flag for "W3_UNO" +#else + logical, parameter :: w3_uno_flag = .false. !< @public a flag for "W3_UNO" +#endif + +#ifdef W3_UQ + logical, parameter :: w3_uq_flag = .true. !< @public a flag for "W3_UQ" +#else + logical, parameter :: w3_uq_flag = .false. !< @public a flag for "W3_UQ" +#endif + + ! flux scheme + +#ifdef W3_FLX0 + logical, parameter :: w3_flx0_flag = .true. !< @public a flag for "W3_FLX0" +#else + logical, parameter :: w3_flx0_flag = .false. !< @public a flag for "W3_FLX0" +#endif + +#ifdef W3_FLX1 + logical, parameter :: w3_flx1_flag = .true. !< @public a flag for "W3_FLX1" +#else + logical, parameter :: w3_flx1_flag = .false. !< @public a flag for "W3_FLX1" +#endif + +#ifdef W3_FLX2 + logical, parameter :: w3_flx2_flag = .true. !< @public a flag for "W3_FLX2" +#else + logical, parameter :: w3_flx2_flag = .false. !< @public a flag for "W3_FLX2" +#endif + +#ifdef W3_FLX3 + logical, parameter :: w3_flx3_flag = .true. !< @public a flag for "W3_FLX3" +#else + logical, parameter :: w3_flx3_flag = .false. !< @public a flag for "W3_FLX3" +#endif + +#ifdef W3_FLX4 + logical, parameter :: w3_flx4_flag = .true. !< @public a flag for "W3_FLX4" +#else + logical, parameter :: w3_flx4_flag = .false. !< @public a flag for "W3_FLX4" +#endif + +#ifdef W3_FLX5 + logical, parameter :: w3_flx5_flag = .true. !< @public a flag for "W3_FLX5" +#else + logical, parameter :: w3_flx5_flag = .false. !< @public a flag for "W3_FLX5" +#endif + + ! linear input + +#ifdef W3_LN0 + logical, parameter :: w3_ln0_flag = .true. !< @public a flag for "W3_LN0" +#else + logical, parameter :: w3_ln0_flag = .false. !< @public a flag for "W3_LN0" +#endif + +#ifdef W3_SEED + logical, parameter :: w3_seed_flag = .true. !< @public a flag for "W3_SEED" +#else + logical, parameter :: w3_seed_flag = .false. !< @public a flag for "W3_SEED" +#endif + +#ifdef W3_LN1 + logical, parameter :: w3_ln1_flag = .true. !< @public a flag for "W3_LN1" +#else + logical, parameter :: w3_ln1_flag = .false. !< @public a flag for "W3_LN1" +#endif + + ! input/dissipation + +#ifdef W3_ST0 + logical, parameter :: w3_st0_flag = .true. !< @public a flag for "W3_ST0" +#else + logical, parameter :: w3_st0_flag = .false. !< @public a flag for "W3_ST0" +#endif + +#ifdef W3_ST1 + logical, parameter :: w3_st1_flag = .true. !< @public a flag for "W3_ST1" +#else + logical, parameter :: w3_st1_flag = .false. !< @public a flag for "W3_ST1" +#endif + +#ifdef W3_ST2 + logical, parameter :: w3_st2_flag = .true. !< @public a flag for "W3_ST2" +#else + logical, parameter :: w3_st2_flag = .false. !< @public a flag for "W3_ST2" +#endif + +#ifdef W3_STAB0 + logical, parameter :: w3_stab0_flag = .true. !< @public a flag for "W3_STAB0" +#else + logical, parameter :: w3_stab0_flag = .false. !< @public a flag for "W3_STAB0" +#endif + +#ifdef W3_STAB2 + logical, parameter :: w3_stab2_flag = .true. !< @public a flag for "W3_STAB2" +#else + logical, parameter :: w3_stab2_flag = .false. !< @public a flag for "W3_STAB2" +#endif + +#ifdef W3_ST3 + logical, parameter :: w3_st3_flag = .true. !< @public a flag for "W3_ST3" +#else + logical, parameter :: w3_st3_flag = .false. !< @public a flag for "W3_ST3" +#endif + +#ifdef W3_STAB3 + logical, parameter :: w3_stab3_flag = .true. !< @public a flag for "W3_STAB3" +#else + logical, parameter :: w3_stab3_flag = .false. !< @public a flag for "W3_STAB3" +#endif + +#ifdef W3_ST4 + logical, parameter :: w3_st4_flag = .true. !< @public a flag for "W3_ST4" +#else + logical, parameter :: w3_st4_flag = .false. !< @public a flag for "W3_ST4" +#endif + +#ifdef W3_ST6 + logical, parameter :: w3_st6_flag = .true. !< @public a flag for "W3_ST6" +#else + logical, parameter :: w3_st6_flag = .false. !< @public a flag for "W3_ST6" +#endif + + ! non-linear interaction + +#ifdef W3_NL0 + logical, parameter :: w3_nl0_flag = .true. !< @public a flag for "W3_NL0" +#else + logical, parameter :: w3_nl0_flag = .false. !< @public a flag for "W3_NL0" +#endif + +#ifdef W3_NL1 + logical, parameter :: w3_nl1_flag = .true. !< @public a flag for "W3_NL1" +#else + logical, parameter :: w3_nl1_flag = .false. !< @public a flag for "W3_NL1" +#endif + +#ifdef W3_NL2 + logical, parameter :: w3_nl2_flag = .true. !< @public a flag for "W3_NL2" +#else + logical, parameter :: w3_nl2_flag = .false. !< @public a flag for "W3_NL2" +#endif + +#ifdef W3_NL3 + logical, parameter :: w3_nl3_flag = .true. !< @public a flag for "W3_NL3" +#else + logical, parameter :: w3_nl3_flag = .false. !< @public a flag for "W3_NL3" +#endif + +#ifdef W3_NL4 + logical, parameter :: w3_nl4_flag = .true. !< @public a flag for "W3_NL4" +#else + logical, parameter :: w3_nl4_flag = .false. !< @public a flag for "W3_NL4" +#endif + +#ifdef W3_NL5 + logical, parameter :: w3_nl5_flag = .true. !< @public a flag for "W3_NL5" +#else + logical, parameter :: w3_nl5_flag = .false. !< @public a flag for "W3_NL5" +#endif + + ! bottom friction + +#ifdef W3_BT0 + logical, parameter :: w3_bt0_flag = .true. !< @public a flag for "W3_BT0" +#else + logical, parameter :: w3_bt0_flag = .false. !< @public a flag for "W3_BT0" +#endif + +#ifdef W3_BT1 + logical, parameter :: w3_bt1_flag = .true. !< @public a flag for "W3_BT1" +#else + logical, parameter :: w3_bt1_flag = .false. !< @public a flag for "W3_BT1" +#endif + +#ifdef W3_B24 + logical, parameter :: w3_b24_flag = .true. !< @public a flag for "W3_B24" +#else + logical, parameter :: w3_b24_flag = .false. !< @public a flag for "W3_B24" +#endif + +#ifdef W3_BT8 + logical, parameter :: w3_bt8_flag = .true. !< @public a flag for "W3_BT8" +#else + logical, parameter :: w3_bt8_flag = .false. !< @public a flag for "W3_BT8" +#endif + +#ifdef W3_BT9 + logical, parameter :: w3_bt9_flag = .true. !< @public a flag for "W3_BT9" +#else + logical, parameter :: w3_bt9_flag = .false. !< @public a flag for "W3_BT9" +#endif + + ! damping by sea ice + +#ifdef W3_IC0 + logical, parameter :: w3_ic0_flag = .true. !< @public a flag for "W3_IC0" +#else + logical, parameter :: w3_ic0_flag = .false. !< @public a flag for "W3_IC0" +#endif + +#ifdef W3_IC1 + logical, parameter :: w3_ic1_flag = .true. !< @public a flag for "W3_IC1" +#else + logical, parameter :: w3_ic1_flag = .false. !< @public a flag for "W3_IC1" +#endif + +#ifdef W3_IC2 + logical, parameter :: w3_ic2_flag = .true. !< @public a flag for "W3_IC2" +#else + logical, parameter :: w3_ic2_flag = .false. !< @public a flag for "W3_IC2" +#endif + +#ifdef W3_IC3 + logical, parameter :: w3_ic3_flag = .true. !< @public a flag for "W3_IC3" +#else + logical, parameter :: w3_ic3_flag = .false. !< @public a flag for "W3_IC3" +#endif + +#ifdef W3_IC4 + logical, parameter :: w3_ic4_flag = .true. !< @public a flag for "W3_IC4" +#else + logical, parameter :: w3_ic4_flag = .false. !< @public a flag for "W3_IC4" +#endif + +#ifdef W3_IC5 + logical, parameter :: w3_ic5_flag = .true. !< @public a flag for "W3_IC5" +#else + logical, parameter :: w3_ic5_flag = .false. !< @public a flag for "W3_IC5" +#endif + + ! scattering by seaice + +#ifdef W3_IS0 + logical, parameter :: w3_is0_flag = .true. !< @public a flag for "W3_IS0" +#else + logical, parameter :: w3_is0_flag = .false. !< @public a flag for "W3_IS0" +#endif + +#ifdef W3_IS1 + logical, parameter :: w3_is1_flag = .true. !< @public a flag for "W3_IS1" +#else + logical, parameter :: w3_is1_flag = .false. !< @public a flag for "W3_IS1" +#endif + +#ifdef W3_IS2 + logical, parameter :: w3_is2_flag = .true. !< @public a flag for "W3_IS2" +#else + logical, parameter :: w3_is2_flag = .false. !< @public a flag for "W3_IS2" +#endif + + ! reflection + +#ifdef W3_REF0 + logical, parameter :: w3_ref0_flag = .true. !< @public a flag for "W3_REF0" +#else + logical, parameter :: w3_ref0_flag = .false. !< @public a flag for "W3_REF0" +#endif + +#ifdef W3_REF1 + logical, parameter :: w3_ref1_flag = .true. !< @public a flag for "W3_REF1" +#else + logical, parameter :: w3_ref1_flag = .false. !< @public a flag for "W3_REF1" +#endif + + ! depth induced breaking + +#ifdef W3_DB0 + logical, parameter :: w3_db0_flag = .true. !< @public a flag for "W3_DB0" +#else + logical, parameter :: w3_db0_flag = .false. !< @public a flag for "W3_DB0" +#endif + +#ifdef W3_DB1 + logical, parameter :: w3_db1_flag = .true. !< @public a flag for "W3_DB1" +#else + logical, parameter :: w3_db1_flag = .false. !< @public a flag for "W3_DB1" +#endif + + ! tidal interaction + +#ifdef W3_TR0 + logical, parameter :: w3_tr0_flag = .true. !< @public a flag for "W3_TR0" +#else + logical, parameter :: w3_tr0_flag = .false. !< @public a flag for "W3_TR0" +#endif + +#ifdef W3_TR1 + logical, parameter :: w3_tr1_flag = .true. !< @public a flag for "W3_TR1" +#else + logical, parameter :: w3_tr1_flag = .false. !< @public a flag for "W3_TR1" +#endif + + ! bottom scattering + +#ifdef W3_BS0 + logical, parameter :: w3_bs0_flag = .true. !< @public a flag for "W3_BS0" +#else + logical, parameter :: w3_bs0_flag = .false. !< @public a flag for "W3_BS0" +#endif + +#ifdef W3_BS1 + logical, parameter :: w3_bs1_flag = .true. !< @public a flag for "W3_BS1" +#else + logical, parameter :: w3_bs1_flag = .false. !< @public a flag for "W3_BS1" +#endif + + ! wind interpolation in time + +#ifdef W3_WNT0 + logical, parameter :: w3_wnt0_flag = .true. !< @public a flag for "W3_WNT0" +#else + logical, parameter :: w3_wnt0_flag = .false. !< @public a flag for "W3_WNT0" +#endif + +#ifdef W3_WNT1 + logical, parameter :: w3_wnt1_flag = .true. !< @public a flag for "W3_WNT1" +#else + logical, parameter :: w3_wnt1_flag = .false. !< @public a flag for "W3_WNT1" +#endif + +#ifdef W3_WNT2 + logical, parameter :: w3_wnt2_flag = .true. !< @public a flag for "W3_WNT2" +#else + logical, parameter :: w3_wnt2_flag = .false. !< @public a flag for "W3_WNT2" +#endif + + ! wind interpolation in space + +#ifdef W3_WNX0 + logical, parameter :: w3_wnx0_flag = .true. !< @public a flag for "W3_WNX0" +#else + logical, parameter :: w3_wnx0_flag = .false. !< @public a flag for "W3_WNX0" +#endif + +#ifdef W3_WNX1 + logical, parameter :: w3_wnx1_flag = .true. !< @public a flag for "W3_WNX1" +#else + logical, parameter :: w3_wnx1_flag = .false. !< @public a flag for "W3_WNX1" +#endif + +#ifdef W3_WNX2 + logical, parameter :: w3_wnx2_flag = .true. !< @public a flag for "W3_WNX2" +#else + logical, parameter :: w3_wnx2_flag = .false. !< @public a flag for "W3_WNX2" +#endif + + ! current interpolation in time + +#ifdef W3_CRT0 + logical, parameter :: w3_crt0_flag = .true. !< @public a flag for "W3_CRT0" +#else + logical, parameter :: w3_crt0_flag = .false. !< @public a flag for "W3_CRT0" +#endif + +#ifdef W3_CRT1 + logical, parameter :: w3_crt1_flag = .true. !< @public a flag for "W3_CRT1" +#else + logical, parameter :: w3_crt1_flag = .false. !< @public a flag for "W3_CRT1" +#endif + +#ifdef W3_CRT2 + logical, parameter :: w3_crt2_flag = .true. !< @public a flag for "W3_CRT2" +#else + logical, parameter :: w3_crt2_flag = .false. !< @public a flag for "W3_CRT2" +#endif + + ! current interpolation in space + +#ifdef W3_CRX0 + logical, parameter :: w3_crx0_flag = .true. !< @public a flag for "W3_CRX0" +#else + logical, parameter :: w3_crx0_flag = .false. !< @public a flag for "W3_CRX0" +#endif + +#ifdef W3_CRX1 + logical, parameter :: w3_crx1_flag = .true. !< @public a flag for "W3_CRX1" +#else + logical, parameter :: w3_crx1_flag = .false. !< @public a flag for "W3_CRX1" +#endif + +#ifdef W3_CRX2 + logical, parameter :: w3_crx2_flag = .true. !< @public a flag for "W3_CRX2" +#else + logical, parameter :: w3_crx2_flag = .false. !< @public a flag for "W3_CRX2" +#endif + + ! grib + +#ifdef W3_NOGRB + logical, parameter :: w3_nogrb_flag = .true. !< @public a flag for "W3_NOGRB" +#else + logical, parameter :: w3_nogrb_flag = .false. !< @public a flag for "W3_NOGRB" +#endif + +#ifdef W3_NCEP1 + logical, parameter :: w3_ncep1_flag = .true. !< @public a flag for "W3_NCEP1" +#else + logical, parameter :: w3_ncep1_flag = .false. !< @public a flag for "W3_NCEP1" +#endif + +#ifdef W3_NCEP2 + logical, parameter :: w3_ncep2_flag = .true. !< @public a flag for "W3_NCEP2" +#else + logical, parameter :: w3_ncep2_flag = .false. !< @public a flag for "W3_NCEP2" +#endif + + ! optional output + +#ifdef W3_O0 + logical, parameter :: w3_o0_flag = .true. !< @public a flag for "W3_O0" +#else + logical, parameter :: w3_o0_flag = .false. !< @public a flag for "W3_O0" +#endif + +#ifdef W3_O1 + logical, parameter :: w3_o1_flag = .true. !< @public a flag for "W3_O1" +#else + logical, parameter :: w3_o1_flag = .false. !< @public a flag for "W3_O1" +#endif + +#ifdef W3_O2 + logical, parameter :: w3_o2_flag = .true. !< @public a flag for "W3_O2" +#else + logical, parameter :: w3_o2_flag = .false. !< @public a flag for "W3_O2" +#endif + +#ifdef W3_O3 + logical, parameter :: w3_o3_flag = .true. !< @public a flag for "W3_O3" +#else + logical, parameter :: w3_o3_flag = .false. !< @public a flag for "W3_O3" +#endif + +#ifdef W3_O4 + logical, parameter :: w3_o4_flag = .true. !< @public a flag for "W3_O4" +#else + logical, parameter :: w3_o4_flag = .false. !< @public a flag for "W3_O4" +#endif + +#ifdef W3_O5 + logical, parameter :: w3_o5_flag = .true. !< @public a flag for "W3_O5" +#else + logical, parameter :: w3_o5_flag = .false. !< @public a flag for "W3_O5" +#endif + +#ifdef W3_O6 + logical, parameter :: w3_o6_flag = .true. !< @public a flag for "W3_O6" +#else + logical, parameter :: w3_o6_flag = .false. !< @public a flag for "W3_O6" +#endif + +#ifdef W3_O7 + logical, parameter :: w3_o7_flag = .true. !< @public a flag for "W3_O7" +#else + logical, parameter :: w3_o7_flag = .false. !< @public a flag for "W3_O7" +#endif + +#ifdef W3_O8 + logical, parameter :: w3_o8_flag = .true. !< @public a flag for "W3_O8" +#else + logical, parameter :: w3_o8_flag = .false. !< @public a flag for "W3_O8" +#endif + +#ifdef W3_O9 + logical, parameter :: w3_o9_flag = .true. !< @public a flag for "W3_O9" +#else + logical, parameter :: w3_o9_flag = .false. !< @public a flag for "W3_O9" +#endif + +#ifdef W3_O10 + logical, parameter :: w3_o10_flag = .true. !< @public a flag for "W3_O10" +#else + logical, parameter :: w3_o10_flag = .false. !< @public a flag for "W3_O10" +#endif + +#ifdef W3_O11 + logical, parameter :: w3_o11_flag = .true. !< @public a flag for "W3_O11" +#else + logical, parameter :: w3_o11_flag = .false. !< @public a flag for "W3_O11" +#endif + +#ifdef W3_O12 + logical, parameter :: w3_o12_flag = .true. !< @public a flag for "W3_O12" +#else + logical, parameter :: w3_o12_flag = .false. !< @public a flag for "W3_O12" +#endif + +#ifdef W3_O13 + logical, parameter :: w3_o13_flag = .true. !< @public a flag for "W3_O13" +#else + logical, parameter :: w3_o13_flag = .false. !< @public a flag for "W3_O13" +#endif + +#ifdef W3_O14 + logical, parameter :: w3_o14_flag = .true. !< @public a flag for "W3_O14" +#else + logical, parameter :: w3_o14_flag = .false. !< @public a flag for "W3_O14" +#endif + +#ifdef W3_O15 + logical, parameter :: w3_o15_flag = .true. !< @public a flag for "W3_O15" +#else + logical, parameter :: w3_o15_flag = .false. !< @public a flag for "W3_O15" +#endif + +#ifdef W3_O16 + logical, parameter :: w3_o16_flag = .true. !< @public a flag for "W3_O16" +#else + logical, parameter :: w3_o16_flag = .false. !< @public a flag for "W3_O16" +#endif + + ! threading + +#ifdef W3_OMPG + logical, parameter :: w3_ompg_flag = .true. !< @public a flag for "W3_OMPG" +#else + logical, parameter :: w3_ompg_flag = .false. !< @public a flag for "W3_OMPG" +#endif + +#ifdef W3_OMPH + logical, parameter :: w3_omph_flag = .true. !< @public a flag for "W3_OMPH" +#else + logical, parameter :: w3_omph_flag = .false. !< @public a flag for "W3_OMPH" +#endif + +#ifdef W3_PDLIB + logical, parameter :: w3_pdlib_flag = .true. !< @public a flag for "W3_PDLIB" +#else + logical, parameter :: w3_pdlib_flag = .false. !< @public a flag for "W3_PDLIB" +#endif + +#ifdef W3_B4B + logical, parameter :: w3_b4b_flag = .true. !< @public a flag for "W3_B4B" +#else + logical, parameter :: w3_b4b_flag = .false. !< @public a flag for "W3_B4B" +#endif + + ! moving grids + +#ifdef W3_MGP + logical, parameter :: w3_mgp_flag = .true. !< @public a flag for "W3_MGP" +#else + logical, parameter :: w3_mgp_flag = .false. !< @public a flag for "W3_MGP" +#endif + +#ifdef W3_MGW + logical, parameter :: w3_mgw_flag = .true. !< @public a flag for "W3_MGW" +#else + logical, parameter :: w3_mgw_flag = .false. !< @public a flag for "W3_MGW" +#endif + +#ifdef W3_MGG + logical, parameter :: w3_mgg_flag = .true. !< @public a flag for "W3_MGG" +#else + logical, parameter :: w3_mgg_flag = .false. !< @public a flag for "W3_MGG" +#endif + + ! misc + +#ifdef W3_COU + logical, parameter :: w3_cou_flag = .true. !< @public a flag for "W3_COU" +#else + logical, parameter :: w3_cou_flag = .false. !< @public a flag for "W3_COU" +#endif + +#ifdef W3_DSS0 + logical, parameter :: w3_dss0_flag = .true. !< @public a flag for "W3_DSS0" +#else + logical, parameter :: w3_dss0_flag = .false. !< @public a flag for "W3_DSS0" +#endif + +#ifdef W3_FLD1 + logical, parameter :: w3_fld1_flag = .true. !< @public a flag for "W3_FLD1" +#else + logical, parameter :: w3_fld1_flag = .false. !< @public a flag for "W3_FLD1" +#endif + +#ifdef W3_FLD2 + logical, parameter :: w3_fld2_flag = .true. !< @public a flag for "W3_FLD2" +#else + logical, parameter :: w3_fld2_flag = .false. !< @public a flag for "W3_FLD2" +#endif + +#ifdef W3_IG1 + logical, parameter :: w3_ig1_flag = .true. !< @public a flag for "W3_IG1" +#else + logical, parameter :: w3_ig1_flag = .false. !< @public a flag for "W3_IG1" +#endif + +#ifdef W3_MLIM + logical, parameter :: w3_mlim_flag = .true. !< @public a flag for "W3_MLIM" +#else + logical, parameter :: w3_mlim_flag = .false. !< @public a flag for "W3_MLIM" +#endif + +#ifdef W3_MPI + logical, parameter :: w3_mpi_flag = .true. !< @public a flag for "W3_MPI" +#else + logical, parameter :: w3_mpi_flag = .false. !< @public a flag for "W3_MPI" +#endif + +#ifdef W3_MPIBDI + logical, parameter :: w3_mpibdi_flag = .true. !< @public a flag for "W3_MPIBDI" +#else + logical, parameter :: w3_mpibdi_flag = .false. !< @public a flag for "W3_MPIBDI" +#endif + +#ifdef W3_MPIT + logical, parameter :: w3_mpit_flag = .true. !< @public a flag for "W3_MPIT" +#else + logical, parameter :: w3_mpit_flag = .false. !< @public a flag for "W3_MPIT" +#endif + +#ifdef W3_MPRF + logical, parameter :: w3_mprf_flag = .true. !< @public a flag for "W3_MPRF" +#else + logical, parameter :: w3_mprf_flag = .false. !< @public a flag for "W3_MPRF" +#endif + +#ifdef W3_NCO + logical, parameter :: w3_nco_flag = .true. !< @public a flag for "W3_NCO" +#else + logical, parameter :: w3_nco_flag = .false. !< @public a flag for "W3_NCO" +#endif + +#ifdef W3_NLS + logical, parameter :: w3_nls_flag = .true. !< @public a flag for "W3_NLS" +#else + logical, parameter :: w3_nls_flag = .false. !< @public a flag for "W3_NLS" +#endif + +#ifdef W3_NNT + logical, parameter :: w3_nnt_flag = .true. !< @public a flag for "W3_NNT" +#else + logical, parameter :: w3_nnt_flag = .false. !< @public a flag for "W3_NNT" +#endif + +#ifdef W3_OASIS + logical, parameter :: w3_oasis_flag = .true. !< @public a flag for "W3_OASIS" +#else + logical, parameter :: w3_oasis_flag = .false. !< @public a flag for "W3_OASIS" +#endif + +#ifdef W3_OASACM + logical, parameter :: w3_oasacm_flag = .true. !< @public a flag for "W3_OASACM" +#else + logical, parameter :: w3_oasacm_flag = .false. !< @public a flag for "W3_OASACM" +#endif + +#ifdef W3_OASOCM + logical, parameter :: w3_oasocm_flag = .true. !< @public a flag for "W3_OASOCM" +#else + logical, parameter :: w3_oasocm_flag = .false. !< @public a flag for "W3_OASOCM" +#endif + +#ifdef W3_OASICM + logical, parameter :: w3_oasicm_flag = .true. !< @public a flag for "W3_OASICM" +#else + logical, parameter :: w3_oasicm_flag = .false. !< @public a flag for "W3_OASICM" +#endif + +#ifdef W3_REFRX + logical, parameter :: w3_refrx_flag = .true. !< @public a flag for "W3_REFRX" +#else + logical, parameter :: w3_refrx_flag = .false. !< @public a flag for "W3_REFRX" +#endif + +#ifdef W3_REFT + logical, parameter :: w3_reft_flag = .true. !< @public a flag for "W3_REFT" +#else + logical, parameter :: w3_reft_flag = .false. !< @public a flag for "W3_REFT" +#endif + +#ifdef W3_RTD + logical, parameter :: w3_rtd_flag = .true. !< @public a flag for "W3_RTD" +#else + logical, parameter :: w3_rtd_flag = .false. !< @public a flag for "W3_RTD" +#endif + +#ifdef W3_RWND + logical, parameter :: w3_rwnd_flag = .true. !< @public a flag for "W3_RWND" +#else + logical, parameter :: w3_rwnd_flag = .false. !< @public a flag for "W3_RWND" +#endif + +#ifdef W3_S + logical, parameter :: w3_s_flag = .true. !< @public a flag for "W3_S" +#else + logical, parameter :: w3_s_flag = .false. !< @public a flag for "W3_S" +#endif + +#ifdef W3_SCRIP + logical, parameter :: w3_scrip_flag = .true. !< @public a flag for "W3_SCRIP" +#else + logical, parameter :: w3_scrip_flag = .false. !< @public a flag for "W3_SCRIP" +#endif + +#ifdef W3_SCRIPNC + logical, parameter :: w3_scripnc_flag = .true. !< @public a flag for "W3_SCRIPNC" +#else + logical, parameter :: w3_scripnc_flag = .false. !< @public a flag for "W3_SCRIPNC" +#endif + +#ifdef W3_SEC1 + logical, parameter :: w3_sec1_flag = .true. !< @public a flag for "W3_SEC1" +#else + logical, parameter :: w3_sec1_flag = .false. !< @public a flag for "W3_SEC1" +#endif + +#ifdef W3_SMC + logical, parameter :: w3_smc_flag = .true. !< @public a flag for "W3_SMC" +#else + logical, parameter :: w3_smc_flag = .false. !< @public a flag for "W3_SMC" +#endif + +#ifdef W3_T + logical, parameter :: w3_t_flag = .true. !< @public a flag for "W3_T" +#else + logical, parameter :: w3_t_flag = .false. !< @public a flag for "W3_T" +#endif +#ifdef W3_T0 + logical, parameter :: w3_t0_flag = .true. !< @public a flag for "W3_T0" +#else + logical, parameter :: w3_t0_flag = .false. !< @public a flag for "W3_T0" +#endif + +#ifdef W3_T1 + logical, parameter :: w3_t1_flag = .true. !< @public a flag for "W3_T1" +#else + logical, parameter :: w3_t1_flag = .false. !< @public a flag for "W3_T1" +#endif + +#ifdef W3_T2 + logical, parameter :: w3_t2_flag = .true. !< @public a flag for "W3_T2" +#else + logical, parameter :: w3_t2_flag = .false. !< @public a flag for "W3_T2" +#endif +#ifdef W3_T3 + logical, parameter :: w3_t3_flag = .true. !< @public a flag for "W3_T3" +#else + logical, parameter :: w3_t3_flag = .false. !< @public a flag for "W3_T3" +#endif +#ifdef W3_T4 + logical, parameter :: w3_t4_flag = .true. !< @public a flag for "W3_T4" +#else + logical, parameter :: w3_t4_flag = .false. !< @public a flag for "W3_T4" +#endif +#ifdef W3_T5 + logical, parameter :: w3_t5_flag = .true. !< @public a flag for "W3_T5" +#else + logical, parameter :: w3_t5_flag = .false. !< @public a flag for "W3_T5" +#endif +#ifdef W3_T6 + logical, parameter :: w3_t6_flag = .true. !< @public a flag for "W3_T6" +#else + logical, parameter :: w3_t6_flag = .false. !< @public a flag for "W3_T6" +#endif +#ifdef W3_T7 + logical, parameter :: w3_t7_flag = .true. !< @public a flag for "W3_T7" +#else + logical, parameter :: w3_t7_flag = .false. !< @public a flag for "W3_T7" +#endif +#ifdef W3_T8 + logical, parameter :: w3_t8_flag = .true. !< @public a flag for "W3_T8" +#else + logical, parameter :: w3_t8_flag = .false. !< @public a flag for "W3_T8" +#endif +#ifdef W3_T9 + logical, parameter :: w3_t9_flag = .true. !< @public a flag for "W3_T9" +#else + logical, parameter :: w3_t9_flag = .false. !< @public a flag for "W3_T9" +#endif +#ifdef W3_T38 + logical, parameter :: w3_t38_flag = .true. !< @public a flag for "W3_T38" +#else + logical, parameter :: w3_t38_flag = .false. !< @public a flag for "W3_T38" +#endif +#ifdef W3_TDYN + logical, parameter :: w3_tdyn_flag = .true. !< @public a flag for "W3_TDYN" +#else + logical, parameter :: w3_tdyn_flag = .false. !< @public a flag for "W3_TDYN" +#endif + +#ifdef W3_TIDE + logical, parameter :: w3_tide_flag = .true. !< @public a flag for "W3_TIDE" +#else + logical, parameter :: w3_tide_flag = .false. !< @public a flag for "W3_TIDE" +#endif + +#ifdef W3_TIDET + logical, parameter :: w3_tidet_flag = .true. !< @public a flag for "W3_TIDET" +#else + logical, parameter :: w3_tidet_flag = .false. !< @public a flag for "W3_TIDET" +#endif + +#ifdef W3_TRKNC + logical, parameter :: w3_trknc_flag = .true. !< @public a flag for "W3_TRKNC" +#else + logical, parameter :: w3_trknc_flag = .false. !< @public a flag for "W3_TRKNC" +#endif + +#ifdef W3_UOST + logical, parameter :: w3_uost_flag = .true. !< @public a flag for "W3_UOST" +#else + logical, parameter :: w3_uost_flag = .false. !< @public a flag for "W3_UOST" +#endif + +#ifdef W3_WRST + logical, parameter :: w3_wrst_flag = .true. !< @public a flag for "W3_WRST" +#else + logical, parameter :: w3_wrst_flag = .false. !< @public a flag for "W3_WRST" +#endif + +#ifdef W3_XW0 + logical, parameter :: w3_xw0_flag = .true. !< @public a flag for "W3_XW0" +#else + logical, parameter :: w3_xw0_flag = .false. !< @public a flag for "W3_XW0" +#endif + +#ifdef W3_XW1 + logical, parameter :: w3_xw1_flag = .true. !< @public a flag for "W3_XW1" +#else + logical, parameter :: w3_xw1_flag = .false. !< @public a flag for "W3_XW1" +#endif + +#ifdef W3_CESMCOUPLED + logical, parameter :: w3_cesmcoupled_flag = .true. !< @public a flag for "W3_CESMCOUPLED" +#else + logical, parameter :: w3_cesmcoupled_flag = .false. !< @public a flag for "W3_CESMCOUPLED" +#endif + +#ifdef W3_UWM + logical, parameter :: w3_uwm_flag = .true. !< @public a flag for "W3_UWM" +#else + logical, parameter :: w3_uwm_flag = .false. !< @public a flag for "W3_UWM" +#endif + +#ifdef W3_SBS + logical, parameter :: w3_sbs_flag = .true. !< @public a flag for "W3_SBS" +#else + logical, parameter :: w3_sbs_flag = .false. !< @public a flag for "W3_SBS" +#endif + +#ifdef W3_BT4 + logical, parameter :: w3_bt4_flag = .true. !< @public a flag for "W3_BT4" +#else + logical, parameter :: w3_bt4_flag = .false. !< @public a flag for "W3_BT4" +#endif + +#ifdef W3_WCOR + logical, parameter :: w3_wcor_flag = .true. !< @public a flag for "W3_WCOR" +#else + logical, parameter :: w3_wcor_flag = .false. !< @public a flag for "W3_WCOR" +#endif + +#ifdef W3_SETUP + logical, parameter :: w3_setup_flag = .true. !< @public a flag for "W3_SETUP" +#else + logical, parameter :: w3_setup_flag = .false. !< @public a flag for "W3_SETUP" +#endif + +#ifdef W3_O2A + logical, parameter :: w3_O2a_flag = .true. !< @public a flag for "W3_O2A" +#else + logical, parameter :: w3_O2a_flag = .false. !< @public a flag for "W3_O2A" +#endif + +#ifdef W3_O2B + logical, parameter :: w3_O2b_flag = .true. !< @public a flag for "W3_O2B" +#else + logical, parameter :: w3_O2b_flag = .false. !< @public a flag for "W3_O2B" +#endif +#ifdef W3_O2C + logical, parameter :: w3_O2c_flag = .true. !< @public a flag for "W3_O2C" +#else + logical, parameter :: w3_O2c_flag = .false. !< @public a flag for "W3_O2C" +#endif +#ifdef W3_O7A + logical, parameter :: w3_O7a_flag = .true. !< @public a flag for "W3_O7A" +#else + logical, parameter :: w3_O7a_flag = .false. !< @public a flag for "W3_O7A" +#endif +#ifdef W3_O7B + logical, parameter :: w3_O7b_flag = .true. !< @public a flag for "W3_O7B" +#else + logical, parameter :: w3_O7b_flag = .false. !< @public a flag for "W3_O7B" +#endif +#ifdef W3_01 + logical, parameter :: w3_01_flag = .true. !< @public a flag for "W3_01" +#else + logical, parameter :: w3_01_flag = .false. !< @public a flag for "W3_01" +#endif + + interface print_logmsg + module procedure print_logmsg_1line + module procedure print_logmsg_2line + module procedure print_logmsg_3line + module procedure print_logmsg_4line + end interface print_logmsg + +contains + + !======================================================================== + !> Write a 1 line message if requested + !! + !> @details Writes a one line message + !! + !! @param[in] unum unit number + !! @param[in] msg1 one line message + !! @param[in] lwrite logical to control message writing + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 06-01-2022 + subroutine print_logmsg_1line(unum, msg1, lwrite) + + integer , intent(in) :: unum + character(len=*), intent(in) :: msg1 + logical , intent(in) :: lwrite + + if (.not. lwrite) return + + write(unum,'(a)') trim(msg1) + flush(unum) + + end subroutine print_logmsg_1line + + !======================================================================== + !> Write a 2 line message if requested + !! + !> @details Writes a two line message + !! + !! @param[in] unum unit number + !! @param[in] msg1 first line of message + !! @param[in] msg2 second line of message + !! @param[in] lwrite logical to control message writing + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 06-01-2022 + subroutine print_logmsg_2line(unum, msg1, msg2, lwrite) + + integer , intent(in) :: unum + character(len=*), intent(in) :: msg1 + character(len=*), intent(in) :: msg2 + logical , intent(in) :: lwrite + + if (.not. lwrite) return + + write(unum,'(a)') trim(msg1) + write(unum,'(a)') trim(msg2) + flush(unum) + + end subroutine print_logmsg_2line + + !======================================================================== + !> Write a 3 line message if requested + !! + !> @details Writes a three line message + !! + !! @param[in] unum unit number + !! @param[in] msg1 first line of message + !! @param[in] msg2 second line of message + !! @param[in] msg3 third line of message + !! @param[in] lwrite logical to control message writing + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 06-01-2022 + subroutine print_logmsg_3line(unum, msg1, msg2, msg3, lwrite) + + integer , intent(in) :: unum + character(len=*), intent(in) :: msg1 + character(len=*), intent(in) :: msg2 + character(len=*), intent(in) :: msg3 + logical , intent(in) :: lwrite + + if (.not. lwrite) return + + write(unum,'(a)') trim(msg1) + write(unum,'(a)') trim(msg2) + write(unum,'(a)') trim(msg3) + flush(unum) + + end subroutine print_logmsg_3line + + !======================================================================== + !> Write a 4 line message if requested + !! + !> @details Writes a four line message + !! + !! @param[in] unum unit number + !! @param[in] msg1 first line of message + !! @param[in] msg2 second line of message + !! @param[in] msg3 third line of message + !! @param[in] msg4 forth line of message + !! @param[in] lwrite logical to control message writing + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 06-01-2022 + + subroutine print_logmsg_4line(unum, msg1, msg2, msg3, msg4, lwrite) + + integer , intent(in) :: unum + character(len=*), intent(in) :: msg1 + character(len=*), intent(in) :: msg2 + character(len=*), intent(in) :: msg3 + character(len=*), intent(in) :: msg4 + logical , intent(in) :: lwrite + + if (.not. lwrite) return + + write(unum,'(a)') trim(msg1) + write(unum,'(a)') trim(msg2) + write(unum,'(a)') trim(msg3) + write(unum,'(a)') trim(msg4) + flush(unum) + + end subroutine print_logmsg_4line + + !======================================================================== + !> Write memory statistics if requested + !! + !> @details Writes a single line of memory statistics + !! + !! @param[in] iun unit number + !! @param[in] msg message + !! + !> @author mvertens@ucar.edu, Denise.Worthen@noaa.gov + !> @date 06-01-2022 + + subroutine print_memcheck(iun, msg) +#if W3_MEMCHECK + USE MallocInfo_m +#endif + integer , intent(in) :: iun + character(len=*) , intent(in) :: msg + +#if W3_MEMCHECK + write(iun,*) trim(msg) + call getMallocInfo(mallinfos) + call printMallInfo(iun, mallInfos) +#endif + end subroutine print_memcheck + +end module wav_shr_flags diff --git a/model/src/wav_shr_mod.F90 b/model/src/wav_shr_mod.F90 index 1afd0706ef..61c712d58b 100644 --- a/model/src/wav_shr_mod.F90 +++ b/model/src/wav_shr_mod.F90 @@ -51,25 +51,15 @@ module wav_shr_mod 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 + character(len=256) , public :: casename = '' !< @public the name pre-prended to an output file ! 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 @@ -117,7 +107,7 @@ module wav_shr_mod !=============================================================================== !> Get scalar data from a state !! -!! @details Obtain the field flds_scalar_name from a State and broadcast and +!> @details Obtain the field flds_scalar_name from a State and broadcast and !! it to all PEs !! !! @param[in] State an ESMF_State @@ -185,7 +175,7 @@ end subroutine state_getscalar !! 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 +!! 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 @@ -625,7 +615,7 @@ end subroutine field_getfldptr !=============================================================================== !> Set up an alarm in a clock !! -!! @details Create an ESMF_Alarm according to the desired frequency, where the +!> @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 diff --git a/model/src/wmesmfmd.F90 b/model/src/wmesmfmd.F90 index ba77582cc5..e707a429ea 100644 --- a/model/src/wmesmfmd.F90 +++ b/model/src/wmesmfmd.F90 @@ -1,11 +1,11 @@ !> @file !> @brief Contains module WMESMFMD. -!> +!> !> @author T. J. Campell !> @author J. Meixner !> @author A. J. van der Westhuysen !> @date 09-Aug-2017 -!> +!> #include "w3macros.h" !/ @@ -55,7 +55,7 @@ !> @brief National Unified Prediction Capability (NUOPC) based !> Earth System Modeling Framework (ESMF) interface module for !> multi-grid wave model. -!> +!> !> @details All module variables and types are scoped private by default. !> The private module variables and types are not listed in this section. !> @@ -77,11 +77,11 @@ module WMESMFMD !/ !/ 20-Jan-2017 : Origination. ( version 6.02 ) !/ 09-Aug-2017 : Add ocean forcing export fields ( version 6.03 ) -!/ 28-Feb-2018 : Modifications for unstruc meshes ( version 6.06 ) +!/ 28-Feb-2018 : Modifications for unstruc meshes ( version 6.06 ) !/ !/ Copyright 2009-2014 National Weather Service (NWS), !/ National Oceanic and Atmospheric Administration. All rights -!/ reserved. WAVEWATCH III is a trademark of the NWS. +!/ reserved. WAVEWATCH III is a trademark of the NWS. !/ No unauthorized use without permission. !/ ! 1. Purpose : @@ -189,7 +189,7 @@ module WMESMFMD #endif use W3IOGOMD, only: W3OUTG #ifdef W3_SCRIP - use WMSCRPMD, only: get_scrip_info_structured + use WMSCRPMD, only: get_scrip_info_structured #endif !/ !/ Specify default data typing @@ -314,7 +314,7 @@ module WMESMFMD character(256) :: flds_scalar_name = '' !< flds_scalar_name integer :: flds_scalar_num = 0 !< flds_scalar_num ! flds_scalar_index_nx and flds_scalar_index_nx are domain - ! metadata that allows CMEPS to convert a mesh back to 2d + ! metadata that allows CMEPS to convert a mesh back to 2d ! space for mediator restart and history outputs integer :: flds_scalar_index_nx = 0 !< flds_scalar_index_nx integer :: flds_scalar_index_ny = 0 !< flds_scalar_index_ny @@ -337,7 +337,7 @@ module WMESMFMD !> @param[out] rc Return code. !> !> @author T. J. Campbell @date 20-Jan-2017 -!> +!> #undef METHOD #define METHOD "SetServices" subroutine SetServices ( gcomp, rc ) @@ -508,7 +508,7 @@ end subroutine SetServices !> @param[out] rc Return code. !> !> @author T. J. Campbell @date 20-Jan-2017 -!> +!> #undef METHOD #define METHOD "InitializeP0" subroutine InitializeP0 ( gcomp, impState, expState, extClock, rc ) @@ -662,10 +662,10 @@ end subroutine InitializeP0 !> @param impState Import state. !> @param expState Export state. !> @param extClock External clock. -!> @param[out] rc Return code. +!> @param[out] rc Return code. !> !> @author T. J. Campbell @date 09-Aug-2017 -!> +!> #undef METHOD #define METHOD "InitializeP1" subroutine InitializeP1 ( gcomp, impState, expState, extClock, rc ) @@ -777,7 +777,7 @@ subroutine InitializeP1 ( gcomp, impState, expState, extClock, rc ) ': entered InitializeP1', ESMF_LOGMSG_INFO) ! ! -------------------------------------------------------------------- / -! Query mediator specific attributes +! Query mediator specific attributes ! if (med_present) then call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", & @@ -970,7 +970,7 @@ subroutine InitializeP1 ( gcomp, impState, expState, extClock, rc ) ! ! Adjust internal start time to currTime in case of delayed start ! - if ( cttmp.gt.ttmp ) ttmp=cttmp + if ( cttmp.gt.ttmp ) ttmp=cttmp call ESMF_TimeGet(ttmp, yy=yy,mm=mm,dd=dd,h=h,m=m,s=s, rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return stime(1) = 10000*yy + 100*mm + dd @@ -1019,7 +1019,7 @@ subroutine InitializeP1 ( gcomp, impState, expState, extClock, rc ) ! 2. Initialization of all wave models / grids ! ! 2.a Call into WMINIT -! +! if ( .not.lsep_ss ) idss = stdo if ( .not.lsep_st ) idst = stdo if ( .not.lsep_se ) idse = stdo @@ -1296,10 +1296,10 @@ subroutine InitializeP1 ( gcomp, impState, expState, extClock, rc ) expFieldDim(i) = 2 endif - if (med_present) then + if (med_present) then i = i + 1 if ( istep.eq.2 ) then - expFieldName(i) = trim(flds_scalar_name) + expFieldName(i) = trim(flds_scalar_name) expFieldStdName(i) = trim(flds_scalar_name) expFieldDim(i) = 1 endif @@ -1405,12 +1405,12 @@ end subroutine InitializeP1 !> @param impState Import state. !> @param expState Export state. !> @param extClock External clock. -!> @param[out] rc Return code. +!> @param[out] rc Return code. !> !> @author T. J. Campbell !> @author A. J. van der Westhuysen !> @date 09-Aug-2017 -!> +!> #undef METHOD #define METHOD "InitializeP3" subroutine InitializeP3 ( gcomp, impState, expState, extClock, rc ) @@ -1425,7 +1425,7 @@ subroutine InitializeP3 ( gcomp, impState, expState, extClock, rc ) !/ !/ 20-Jan-2017 : Origination. ( version 6.02 ) !/ 09-Aug-2017 : Update 3D export field setup ( version 6.03 ) -!/ 28-Feb-2018 : Modifications for unstruc meshes ( version 6.06 ) +!/ 28-Feb-2018 : Modifications for unstruc meshes ( version 6.06 ) !/ ! 1. Purpose : ! @@ -1761,7 +1761,7 @@ end subroutine InitializeP3 !> @param[out] rc Return code. !> !> @author T. J. Campbell @date 09-Aug-2017 -!> +!> #undef METHOD #define METHOD "Finalize" subroutine Finalize ( gcomp, rc ) @@ -1985,7 +1985,7 @@ end subroutine Finalize !> @param[out] rc Return code. !> !> @author T. J. Campbell @date 20-Jan-2017 -!> +!> #undef METHOD #define METHOD "DataInitialize" subroutine DataInitialize ( gcomp, rc ) @@ -2204,10 +2204,10 @@ end subroutine DataInitialize !> @brief Advance wave model in time. !> !> @param gcomp Gridded component. -!> @param[out] rc Return code. +!> @param[out] rc Return code. !> !> @author T. J. Campbell @date 20-Jan-2017 -!> +!> #undef METHOD #define METHOD "ModelAdvance" subroutine ModelAdvance ( gcomp, rc ) @@ -2411,7 +2411,7 @@ end subroutine ModelAdvance !> @param[out] rc Return code. !> !> @author T. J. Campbell @date 20-Jan-2017 -!> +!> #undef METHOD #define METHOD "GetImport" subroutine GetImport ( gcomp, rc ) @@ -2682,9 +2682,9 @@ subroutine GetImport ( gcomp, rc ) ! an atm model that does not have 10m wind speeds at ! initialization. If there is no restart, wind is zero wxn = WXNwrst !replace with values from restart - wyn = WYNwrst - wx0 = WXNwrst - wy0 = WYNwrst + wyn = WYNwrst + wx0 = WXNwrst + wy0 = WYNwrst do imod = 1,nrgrd call w3setg ( imod, mdse, mdst ) call w3setw ( imod, mdse, mdst ) @@ -2694,22 +2694,22 @@ subroutine GetImport ( gcomp, rc ) if ( mpi_comm_grd .eq. mpi_comm_null ) cycle #endif INPUTS(IMOD)%TW0(:) = INPUTS(impGridID)%TW0(:) - INPUTS(IMOD)%TFN(:,3) = INPUTS(impGridID)%TFN(:,3) + INPUTS(IMOD)%TFN(:,3) = INPUTS(impGridID)%TFN(:,3) wxn = WXNwrst !replace with values from restart - wyn = WYNwrst - wx0 = WXNwrst - wy0 = WYNwrst + wyn = WYNwrst + wx0 = WXNwrst + wy0 = WYNwrst if (ESMF_LogFoundError(rc, PASSTHRU)) return enddo #endif endif #ifdef W3_WRST - if ( ((twn(1)-tw0(1))*1000000+((twn(2)-tw0(2)))) .le. 0 ) then + if ( ((twn(1)-tw0(1))*1000000+((twn(2)-tw0(2)))) .le. 0 ) then !If the time of the field is still initial time, replace !with restart field wxn = WXNwrst !replace with values from restart - wyn = WYNwrst + wyn = WYNwrst else !twn>tw0 #endif do imod = 1,nrgrd @@ -2798,7 +2798,7 @@ end subroutine GetImport !> @param[out] rc Return code !> !> @author T. J. Campbell @date 09-Aug-2017 -!> +!> #undef METHOD #define METHOD "SetExport" subroutine SetExport ( gcomp, rc ) @@ -2904,7 +2904,7 @@ subroutine SetExport ( gcomp, rc ) endif ! ! -------------------------------------------------------------------- / -! Surface Roughness +! Surface Roughness ! i1 = FieldIndex( expFieldName, 'z0rlen', rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return @@ -2927,7 +2927,7 @@ subroutine SetExport ( gcomp, rc ) endif ! ! -------------------------------------------------------------------- / -! Partitioned Stokes Drift 3 2D fields +! Partitioned Stokes Drift 3 2D fields ! i1 = FieldIndex( expFieldName, 'x1pstk', rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return @@ -2994,13 +2994,13 @@ subroutine SetExport ( gcomp, rc ) call ESMF_FieldGet(expField(i1), farrayPtr=farrayptr, rc=rc) if (ESMF_LogFoundError(rc, PASSTHRU)) return if (flds_scalar_index_nx > 0 .and. flds_scalar_index_nx < flds_scalar_num) then - farrayptr(flds_scalar_index_nx,1) = dble(nx) + farrayptr(flds_scalar_index_nx,1) = dble(nx) endif if (flds_scalar_index_ny > 0 .and. flds_scalar_index_ny < flds_scalar_num) then farrayptr(flds_scalar_index_ny,1) = dble(ny) endif endif - endif + endif ! ! -------------------------------------------------------------------- / ! Post @@ -3032,7 +3032,7 @@ end subroutine SetExport !> @param[out] rc Return code !> !> @author T. J. Campbell @date 20-Jan-2017 -!> +!> #undef METHOD #define METHOD "CreateImpGrid" subroutine CreateImpGrid ( gcomp, rc ) @@ -3284,14 +3284,14 @@ subroutine CreateImpGrid ( gcomp, rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return ! Calculate grid coordinates with help of SCRIP module - ! It does not return coordinates of top-most row and - ! right-most column but ESMF expects it. So, top-most row + ! It does not return coordinates of top-most row and + ! right-most column but ESMF expects it. So, top-most row ! and right-most column are theated specially in below call get_scrip_info_structured(impGridID, & xgrd_center, ygrd_center, xgrd_corner, ygrd_corner, & land_sea, grid_dims, grid_size, grid_corners, grid_rank) - ! Add corner coordinates + ! Add corner coordinates if ( impGridIsLocal ) then ! Retrieve pointers call ESMF_GridGetCoord( impGrid, 1, localDE=lde, & @@ -3349,8 +3349,8 @@ subroutine CreateImpGrid ( gcomp, rc ) rptry(grid_dims(1)+1,grid_dims(2)+1) = & rptry(grid_dims(1),grid_dims(2)+1) end if - endif -#endif + endif +#endif ! ! -------------------------------------------------------------------- / ! 3. Create import field mask and routeHandle halo update @@ -3488,12 +3488,12 @@ end subroutine CreateImpGrid !/ ------------------------------------------------------------------- / !> !> @brief Create ESMF grid for export fields -!> +!> !> @param gcomp Gridded component !> @param[out] rc Return code !> !> @author T. J. Campbell @date 20-Jan-2017 -!> +!> #undef METHOD #define METHOD "CreateExpGrid" subroutine CreateExpGrid ( gcomp, rc ) @@ -3509,7 +3509,7 @@ subroutine CreateExpGrid ( gcomp, rc ) !/ ! 1. Purpose : ! -! +! ! ! 2. Method : ! @@ -3774,14 +3774,14 @@ subroutine CreateExpGrid ( gcomp, rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return ! Calculate grid coordinates with help of SCRIP module - ! It does not return coordinates of top-most row and - ! right-most column but ESMF expects it. So, top-most row + ! It does not return coordinates of top-most row and + ! right-most column but ESMF expects it. So, top-most row ! and right-most column are theated specially in below call get_scrip_info_structured(expGridID, & xgrd_center, ygrd_center, xgrd_corner, ygrd_corner, & land_sea, grid_dims, grid_size, grid_corners, grid_rank) - ! Add corner coordinates + ! Add corner coordinates if ( impGridIsLocal ) then ! Retrieve pointers call ESMF_GridGetCoord( expGrid, 1, localDE=lde, & @@ -3987,7 +3987,7 @@ subroutine CreateExpGrid ( gcomp, rc ) ! ! 5.b Store route handle ! - call ESMF_FieldRedistStore( nField, eField, n2eRH, rc=rc ) + call ESMF_FieldRedistStore( nField, eField, n2eRH, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return ! ! 5.c Clean up @@ -4103,16 +4103,16 @@ end subroutine CreateExpGrid !> @brief Create ESMF mesh (unstructured) for import fields. !> !> @details Create an ESMF Mesh for import using the unstructured mesh -!> description in W3GDATMD. At present, this import mesh is not -!> domain decomposed, but instead is defined on PET 0 only. (In +!> description in W3GDATMD. At present, this import mesh is not +!> domain decomposed, but instead is defined on PET 0 only. (In !> future, when the unstructured mesh will run on domain decomposition, -!> we will use that decomposition.) -!> +!> we will use that decomposition.) +!> !> @param gcomp Gridded component !> @param[out] rc Return code !> !> @author A. J. van der Westhuysen @date 28-Feb-2018 -!> +!> #undef METHOD #define METHOD "CreateImpMesh" subroutine CreateImpMesh ( gcomp, rc ) @@ -4132,9 +4132,9 @@ subroutine CreateImpMesh ( gcomp, rc ) ! ! 2. Method : ! -! Create an ESMF Mesh for import using the unstructured mesh description -! in W3GDATMD. At present, this import mesh is not domain decomposed, -! but instead is defined on PET 0 only. (In future, when the unstructured +! Create an ESMF Mesh for import using the unstructured mesh description +! in W3GDATMD. At present, this import mesh is not domain decomposed, +! but instead is defined on PET 0 only. (In future, when the unstructured ! mesh will run on domain decomposition, we will use that decomposition.) ! ! 3. Parameters : @@ -4253,7 +4253,7 @@ subroutine CreateImpMesh ( gcomp, rc ) ! ------------------------------------------------------------------- ! ESMF Definition: The global id's of the nodes resident on this processor ! ------------------------------------------------------------------- -! Allocate global node ids, including ghost nodes (npa=np+ng) +! Allocate global node ids, including ghost nodes (npa=np+ng) allocate(nodeIds(npa)) do i = 1,npa nodeIds(i)=iplg(i) @@ -4287,7 +4287,7 @@ subroutine CreateImpMesh ( gcomp, rc ) do i = 1,NX do j = 1,2 pos=2*(i-1)+j - if (j == 1) then + if (j == 1) then nodeCoords(pos) = xgrd(1,i) else nodeCoords(pos) = ygrd(1,i) @@ -4448,9 +4448,9 @@ subroutine CreateImpMesh ( gcomp, rc ) #ifdef W3_PDLIB else ! ------------------------------------------------------------------- -! ESMF Definition: Connectivity table. The number of entries should -! be equal to the number of nodes in the given topology. The indices -! should be the local index (1 based) into the array of nodes that +! ESMF Definition: Connectivity table. The number of entries should +! be equal to the number of nodes in the given topology. The indices +! should be the local index (1 based) into the array of nodes that ! was declared with MeshAddNodes. ! ------------------------------------------------------------------- ! > INE is local element array. it stores the local node IDs @@ -4510,24 +4510,24 @@ end subroutine CreateImpMesh !> !> @brief Create ESMF mesh (unstructured) for export fields. !> -!> @details Create an ESMF Mesh for export using the unstructured mesh +!> @details Create an ESMF Mesh for export using the unstructured mesh !> description in W3GDATMD. At present, this export mesh is not domain !> decomposed, but instead is defined on PET 0 only. (In future, when the !> unstructured mesh will run on domain decomposition, we will use that !> decomposition.) !> -!> Since the internal parallel data is currently stored accross grid points +!> Since the internal parallel data is currently stored accross grid points !> in a "card deck" fashion, we will define an intermediate native grid, as !> is done for regular/curvilinear grids, and perform an ESMF regrid to the -!> export mesh. This code segment is taken from T. J. Campbell, and -!> modified to 1D, because the internal data structure for unstructred -!> meshes is an array with dimensions [NX,NY=1]. -!> +!> export mesh. This code segment is taken from T. J. Campbell, and +!> modified to 1D, because the internal data structure for unstructred +!> meshes is an array with dimensions [NX,NY=1]. +!> !> @param gcomp Gridded component !> @param[out] rc Return code !> !> @author A. J. van der Westhuysen @date 28-Feb-2018 -!> +!> #undef METHOD #define METHOD "CreateExpMesh" subroutine CreateExpMesh ( gcomp, rc ) @@ -4547,16 +4547,16 @@ subroutine CreateExpMesh ( gcomp, rc ) ! ! 2. Method : ! -! Create an ESMF Mesh for export using the unstructured mesh description -! in W3GDATMD. At present, this export mesh is not domain decomposed, -! but instead is defined on PET 0 only. (In future, when the unstructured +! Create an ESMF Mesh for export using the unstructured mesh description +! in W3GDATMD. At present, this export mesh is not domain decomposed, +! but instead is defined on PET 0 only. (In future, when the unstructured ! mesh will run on domain decomposition, we will use that decomposition.) ! -! Since the internal parallel data is currently stored accross grid points +! Since the internal parallel data is currently stored accross grid points ! in a "card deck" fashion, we will define an intermediate native grid, as ! is done for regular/curvilinear grids, and perform an ESMF regrid to the -! export mesh. This code segment is taken from T. J. Campbell, and -! modified to 1D, because the internal data structure for unstructred +! export mesh. This code segment is taken from T. J. Campbell, and +! modified to 1D, because the internal data structure for unstructred ! meshes is an array with dimensions [NX,NY=1]. ! ! 3. Parameters : @@ -4667,7 +4667,7 @@ subroutine CreateExpMesh ( gcomp, rc ) natIndexFlag = ESMF_INDEX_DELOCAL ! ! -------------------------------------------------------------------- / -! 2. Create ESMF mesh for export +! 2. Create ESMF mesh for export ! ! 2.a Create ESMF export mesh ! @@ -4684,7 +4684,7 @@ subroutine CreateExpMesh ( gcomp, rc ) ! ------------------------------------------------------------------- ! ESMF Definition: The global id's of the nodes resident on this processor ! ------------------------------------------------------------------- -! Allocate global node ids, including ghost nodes (npa=np+ng) +! Allocate global node ids, including ghost nodes (npa=np+ng) allocate(nodeIds(npa)) do i = 1,npa nodeIds(i)=iplg(i) @@ -4878,9 +4878,9 @@ subroutine CreateExpMesh ( gcomp, rc ) #ifdef W3_PDLIB else ! ------------------------------------------------------------------- -! ESMF Definition: Connectivity table. The number of entries should -! be equal to the number of nodes in the given topology. The indices -! should be the local index (1 based) into the array of nodes that +! ESMF Definition: Connectivity table. The number of entries should +! be equal to the number of nodes in the given topology. The indices +! should be the local index (1 based) into the array of nodes that ! was declared with MeshAddNodes. ! ------------------------------------------------------------------- ! > INE is local element array. it stores the local node IDs @@ -5012,7 +5012,7 @@ subroutine CreateExpMesh ( gcomp, rc ) ! ! 4.b Store route handle ! - call ESMF_FieldRedistStore( nField, eField, n2eRH, rc=rc ) + call ESMF_FieldRedistStore( nField, eField, n2eRH, rc=rc ) if (ESMF_LogFoundError(rc, PASSTHRU)) return ! ! 4.c Clean up @@ -5046,7 +5046,7 @@ end subroutine CreateExpMesh !> @param rc Return code !> !> @author T. J. Campbell @date 09-Aug-2017 -!> +!> #undef METHOD #define METHOD "SetupImpBmsk" subroutine SetupImpBmsk( bmskField, impField, missingVal, rc ) @@ -5274,7 +5274,7 @@ end subroutine SetupImpBmsk !> @param[inout] rc Return code !> !> @author T. J. Campbell @date 09-Aug-2017 -!> +!> #undef METHOD #define METHOD "BlendImpField" subroutine BlendImpField( impField, mbgField, bmskField, rc ) @@ -5388,7 +5388,7 @@ end subroutine BlendImpField !> @param rc Return code !> !> @author U. Turuncoglu @date 18-May-2021 -!> +!> #undef METHOD #define METHOD "SetupImpMmsk" subroutine SetupImpMmsk( mmskField, impField, fillVal, mskCreated, rc ) @@ -5416,7 +5416,7 @@ subroutine SetupImpMmsk( mmskField, impField, fillVal, mskCreated, rc ) ! mmskField Type I/O merging mask field ! impField Type I import field ! fillVal Real I fill value -! mskCreated Log. I/O mask is created or not +! mskCreated Log. I/O mask is created or not ! rc Int O Return code ! ---------------------------------------------------------------- ! @@ -5503,7 +5503,7 @@ subroutine SetupImpMmsk( mmskField, impField, fillVal, mskCreated, rc ) endif ! ! -------------------------------------------------------------------- / -! Set mask created flag +! Set mask created flag ! mskCreated = .true. #if defined(TEST_WMESMFMD) || defined(TEST_WMESMFMD_SETUPIMPMMSK) @@ -5526,7 +5526,7 @@ end subroutine SetupImpMmsk !> @param rc !> !> @author T. J. Campbell @date 09-Aug-2017 -!> +!> #undef METHOD #define METHOD "FieldFill" subroutine FieldFill(field, fillVal, rc) @@ -5660,7 +5660,7 @@ end subroutine FieldFill !> @author T. J. Campbell !> @author A. J. van der Westhuysen !> @date 20-Jan-2017 -!> +!> #undef METHOD #define METHOD "FieldGather" subroutine FieldGather(field, n1, n2, fout, rc) @@ -5824,7 +5824,7 @@ end subroutine FieldGather !> @returns indx Returned index of fname !> !> @author T. J. Campbell @date 20-Jan-2017 -!> +!> #undef METHOD #define METHOD "FieldIndex" function FieldIndex ( fnameList, fname, rc ) result (indx) @@ -5918,7 +5918,7 @@ end function FieldIndex !> @param wtime !> !> @author T. J. Campbell @date 20-Jan-2017 -!> +!> #undef METHOD #define METHOD "PrintTimers" subroutine PrintTimers ( cname, wtnam, wtcnt, wtime ) @@ -6017,7 +6017,7 @@ end subroutine PrintTimers !> @param[inout] rc Return code !> !> @author T. J. Campbell @date 09-Aug-2017 -!> +!> #undef METHOD #define METHOD "CalcDecomp" subroutine CalcDecomp ( nx, ny, nproc, npmin, adjust, nxproc, nyproc, rc ) @@ -6158,7 +6158,7 @@ end subroutine CalcDecomp !> @param rc Return code !> !> @author T. J. Campbell @date 09-Aug-2017 -!> +!> #undef METHOD #define METHOD "GetEnvValue" subroutine GetEnvValue ( cenv, cval, rc ) @@ -6253,7 +6253,7 @@ end subroutine GetEnvValue !> @param[inout] rc Return code !> !> @author T. J. Campbell @date 09-Aug-2017 -!> +!> #undef METHOD #define METHOD "GetZlevels" subroutine GetZlevels ( rc ) @@ -6369,7 +6369,7 @@ end subroutine GetZlevels !> @param rc Return code !> !> @author T. J. Campbell @date 09-Aug-2017 -!> +!> #undef METHOD #define METHOD "CalcCharnk" subroutine CalcCharnk ( chkField, rc ) @@ -6483,7 +6483,7 @@ subroutine CalcCharnk ( chkField, rc ) 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, & + tauwy, cd, z0, charn(jsea), llws, fmeanws, & dlwmean ) #endif endif !firstCall @@ -6518,7 +6518,7 @@ end subroutine CalcCharnk !> @param rc Return code !> !> @author T. J. Campbell @date 09-Aug-2017 -!> +!> #undef METHOD #define METHOD "CalcRoughl" subroutine CalcRoughl ( wrlField, rc ) @@ -6612,7 +6612,7 @@ subroutine CalcRoughl ( wrlField, rc ) #endif IX = MAPSF(ISEA,1) IY = MAPSF(ISEA,2) - IF ( MAPSTA(IY,IX) .EQ. 1 ) THEN + IF ( MAPSTA(IY,IX) .EQ. 1 ) THEN if ( firstCall ) then charn(jsea) = zero #ifdef W3_ST3 @@ -6640,7 +6640,7 @@ subroutine CalcRoughl ( wrlField, rc ) #endif endif !firstCall wrln(jsea) = charn(jsea)*ust(isea)**2/grav - endif + endif enddo jsea_loop endif !natGridIsLocal @@ -6674,7 +6674,7 @@ end subroutine CalcRoughl !> @param rc Return code !> !> @author T. J. Campbell @date 09-Aug-2017 -!> +!> #undef METHOD #define METHOD "CalcBotcur" subroutine CalcBotcur ( a, wbxField, wbyField, wbpField, rc ) @@ -6848,7 +6848,7 @@ subroutine CalcBotcur ( a, wbxField, wbyField, wbpField, rc ) enddo ith_loop fack = dden(ik)/cg(ik,isea) kd = max(kdmin,min(kdmax,wn(ik,isea)*depth)) - fkd = fack/sinh(kd)**2 + fkd = fack/sinh(kd)**2 abr = abr + aka*fkd ubr = ubr + aka*sig2(ik)*fkd ubx = ubx + akx*sig2(ik)*fkd @@ -6909,7 +6909,7 @@ end subroutine CalcBotcur !> @param[inout] rc Return code !> !> @author T. J. Campbell @date 09-Aug-2017 -!> +!> #undef METHOD #define METHOD "CalcRadstr2D" subroutine CalcRadstr2D ( a, sxxField, sxyField, syyField, rc ) @@ -7126,7 +7126,7 @@ subroutine CalcRadstr2D ( a, sxxField, sxyField, syyField, rc ) enddo jsea_loop #ifdef W3_PDLIB else - jsea_loop2: do jsea = 1,np + jsea_loop2: do jsea = 1,np isea = iplg(jsea) ! if ( dw(isea).le.zero ) cycle jsea_loop sxxn(jsea) = sxx(jsea) @@ -7186,7 +7186,7 @@ end subroutine CalcRadstr2D !> @param rc Return code !> !> @author T. J. Campbell @date 09-Aug-2017 -!> +!> #undef METHOD #define METHOD "CalcStokes3D" subroutine CalcStokes3D ( a, usxField, usyField, rc ) @@ -7450,7 +7450,7 @@ end subroutine CalcStokes3D !> @param rc Return code !> !> @author J. Meixner @date 29-Oct-2019 -!> +!> #undef METHOD #define METHOD "CalcPStokes" subroutine CalcPStokes ( a, p1xField, p1yField, p2xField, & @@ -7476,9 +7476,9 @@ subroutine CalcPStokes ( a, p1xField, p1yField, p2xField, & ! Parameter list ! ---------------------------------------------------------------- ! a Real I Input spectra (in par list to change shape) -! p1Field Type I/O -! p2Field Type I/O -! p3Field Type I/O +! p1Field Type I/O +! p2Field Type I/O +! p3Field Type I/O ! rc Int O Return code ! ---------------------------------------------------------------- ! @@ -7523,7 +7523,7 @@ subroutine CalcPStokes ( a, p1xField, p1yField, p2xField, & real(ESMF_KIND_RX), pointer :: p1xn(:), p2xn(:), p3xn(:) real(ESMF_KIND_RX), pointer :: p1yn(:), p2yn(:), p3yn(:) integer, save :: timeSlice = 1 - integer :: isea,jsea + integer :: isea,jsea ! ! -------------------------------------------------------------------- / ! @@ -7641,7 +7641,7 @@ subroutine CalcPStokes ( a, p1xField, p1yField, p2xField, & if (ESMF_LogFoundError(rc, PASSTHRU)) return call ESMF_FieldWrite( p3yField, "wmesmfmd_pstokes_3y.nc", & overwrite=.true., timeSlice=timeSlice, rc=rc ) - if (ESMF_LogFoundError(rc, PASSTHRU)) return + if (ESMF_LogFoundError(rc, PASSTHRU)) return timeSlice = timeSlice + 1 #endif !/ @@ -7660,7 +7660,7 @@ end subroutine CalcPStokes !> @param[inout] rc Return code !> !> @author U. Turuncoglu @date 18-May-2021 -!> +!> #undef METHOD #define METHOD "ReadFromFile" subroutine ReadFromFile (idfld, fldwx, fldwy, time0, timen, rc) @@ -7687,8 +7687,8 @@ subroutine ReadFromFile (idfld, fldwx, fldwy, time0, timen, rc) ! idfld Str I/O Field name ! fldwx Type I/O 2D eastward-component of field ! fldwy Type I/O 2D northward-component of field -! time0 Int I Time stamp for current time -! timen Int I Time stamp for end time +! time0 Int I Time stamp for current time +! timen Int I Time stamp for end time ! rc Int I/O Return code ! ---------------------------------------------------------------- ! @@ -7752,12 +7752,12 @@ subroutine ReadFromFile (idfld, fldwx, fldwy, time0, timen, rc) ! rc = ESMF_SUCCESS - if (firstCall) then - ! assign unit number for input file + if (firstCall) then + ! assign unit number for input file call wmuget(mdse, mdst, mdsf, 'INP') call wmuset(mdse, mdst, mdsf, .true., desc='Input data file') - ! open file + ! open file call w3fldo('READ', idfld, mdsf, mdst, mdse, nx, ny, gtype, ierr) if (ierr.ne.0) then write(logmsg,*) "Error in opening "//idfld//", iostat = ", ierr @@ -7778,7 +7778,7 @@ subroutine ReadFromFile (idfld, fldwx, fldwy, time0, timen, rc) dtnl = 0.0 ! need to rewind to the begining of the file to access - ! data of requested date correctly + ! data of requested date correctly rewind(mdsf) ! read header information @@ -7790,7 +7790,7 @@ subroutine ReadFromFile (idfld, fldwx, fldwy, time0, timen, rc) ! read input call w3fldg('READ', idfld, mdsf, mdst, mdse, nx, ny, & nx, ny, time0, timen, tw0l, wx0l, wy0l, dt0l, twnl, & - wxnl, wynl, dtnl, ierr, flagsc) + wxnl, wynl, dtnl, ierr, flagsc) ! fill fields with data belong to current time if ( impGridIsLocal ) then