!#include "w3macros.h"
#include PROJECT_HEADER
#include GLOBAL_DEFS
!/ ------------------------------------------------------------------- /
MODULE W3WAVEMD
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | H. L. Tolman |
!/ | FORTRAN 90 |
!/ | Last update : 27-Aug-2015 |
!/ +-----------------------------------+
!/
!/ 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 )
!/
!/ 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.
! !/OMPX Id.
!
! !/PR1 First order propagation schemes.
! !/PR2 ULTIMATE QUICKEST scheme.
! !/PR3 Averaged ULTIMATE QUICKEST scheme.
! !/PRX User-defined scheme.
! !/SMC UNO2 scheme on SMC grid.
!
! !/S Enable subroutine tracing.
! !/T Test output.
! !/MPIT Test output for MPI specific code.
!
! 7. Source code :
!
!/ ------------------------------------------------------------------- /
!/MPI USE W3ADATMD, ONLY: MPIBUF
!
PUBLIC
!/
CONTAINS
!/ ------------------------------------------------------------------- /
SUBROUTINE W3WAVE ( IMOD, TEND, STAMP, NO_OUT &
!/OASIS ,ID_LCOMM &
)
!/
!/ +-----------------------------------+
!/ | WAVEWATCH III NOAA/NCEP |
!/ | H. L. Tolman |
!/ | FORTRAN 90 |
!/ | Last update : 27-Aug-2015 |
!/ +-----------------------------------+
!/
!/ 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 )
!/
! 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 Print 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
!/PR1 USE W3PRO1MD
!/PR2 USE W3PRO2MD
!/PR3 USE W3PRO3MD
!/PRX USE W3PROXMD
!/SMC USE W3PSMCMD
!
!/PR1 USE W3PROFSMD
!/PR2 USE W3PROFSMD
!/PR3 USE W3PROFSMD
!/PRX USE W3PROFSMD
!/
USE W3TRIAMD
USE W3IOGRMD
USE W3IOGOMD
USE W3IOPOMD
USE W3IOTRMD
USE W3IORSMD
USE W3IOBCMD
USE W3IOSFMD
!/
USE W3SERVMD
USE W3TIMEMD
!/IC3 USE W3SIC3MD
!/IS2 USE W3SIS2MD
!/OASIS USE W3OACPMD, ONLY: ID_OASIS_TIME
!/OASOCM USE W3OGCMMD, ONLY: SND_FIELDS_TO_OCEAN
!/OASACM USE W3AGCMMD, ONLY: SND_FIELDS_TO_ATMOS
#if defined COAWST_COUPLING && defined MCT_LIB
!/COAWST USE CWSTWVCP
#endif
!/PALM USE palmlib !interface for palm coupler
!/PALM USE palm_user_param !min_palm_time_a etc ...
!
IMPLICIT NONE
!
!/MPI INCLUDE "mpif.h"
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
INTEGER, INTENT(IN) :: IMOD, TEND(2)
LOGICAL, INTENT(IN), OPTIONAL :: STAMP, NO_OUT
!/OASIS INTEGER, INTENT(IN), OPTIONAL :: ID_LCOMM
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters :
!/
!/T INTEGER :: ILEN
!/S INTEGER, SAVE :: IENT = 0
INTEGER :: TCALC(2), IT, IT0, NT, ITEST, &
ITLOC, ITLOCH, NTLOC, ISEA, JSEA, &
IX, IY, ISPEC, J, TOUT(2), TLST(2), &
REFLED(6), IK, NKCFL
!/OASIS INTEGER :: OASISED
!/SEC1 INTEGER :: ISEC1
!/SBS INTEGER :: JJ, NDSOFLG
!/MPI INTEGER :: IERR_MPI, NRQMAX
!/MPI INTEGER, ALLOCATABLE :: STATCO(:,:), STATIO(:,:)
REAL :: DTTST, DTTST1, DTTST2, DTTST3, &
DTL0, DTI0, DTI10, DTI50, &
DTGA, DTG, DTRES, &
FAC, VGX, VGY, FACK, FACTH, &
FACX, XXX, REFLEC(4), &
DELX, DELY, DELA, DEPTH, D50, PSIC
!/SEC1 REAL :: DTGTEMP
!
REAL, ALLOCATABLE :: FIELD(:)
REAL :: TMP1(4), TMP2(3), TMP3(2), TMP4(2)
!/IC3 REAL, ALLOCATABLE :: WN_I(:)
!/REFRX REAL, ALLOCATABLE :: CIK(:)
!
! 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, &
FLOMP = .FALSE.
!
!!Li Logical variable to control regular gird lines in conflict with SMC option.
LOGICAL :: RGLGRD = .TRUE., ARCTIC = .FALSE.
!!Li
!/MPI LOGICAL :: FLGMPI(0:6)
!/IC3 REAL :: FIXEDVISC,FIXEDDENS,FIXEDELAS
!/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=17) :: IDACT
CHARACTER(LEN=13) :: OUTID
CHARACTER(LEN=23) :: IDTIME
!
!/SBS CHARACTER(LEN=30) :: FOUTNAME
!
!/PALM integer ::il_err, palm_time_a,palm_time_b
!/PALM real,allocatable ::vecta(:),vectb(:)
!/PALM real,allocatable ::vectg(:),vecth(:),vecti(:)
!/PALM real,allocatable ::vectj(:),vectk(:),vectl(:)
!/PALM real,allocatable ::vectm(:),vectn(:),vectp(:)
!/PALM real,allocatable ::vectq(:),vectr(:),vects(:)
!/PALM real,allocatable ::vectwlm(:)
!/PALM real,allocatable ::vectt(:),vectu(:)
!/PALM CHARACTER(LEN=PL_LNAME) :: cl_object, cl_space
!/PALM INTEGER :: PALMED
!/PALM LOGICAL :: MEL03
!/T REAL :: INDSORT(NSEA), DTCFL1(NSEA)
!/
!/ARC !Li Temperature spectra for Arctic boundary update.
!/ARC REAL, ALLOCATABLE :: BACSPEC(:)
!/ARC REAL :: BACANGL
!/ARC
!/ ------------------------------------------------------------------- /
! 0. Initializations
!/SMC !!Li Switch off lat-lon grid lines in conflict with SMC option.
!/SMC RGLGRD = .FALSE.
!
!/ARC !!Li Switch on lines related to Arctic part on SMC grid.
!/ARC ARCTIC = .TRUE.
!
! 0.a Set pointers to data structure
!
!/OMPX FLOMP = .TRUE.
!
!/PALM PALMED = 1
!/OASIS OASISED = 1
!/COU SCREEN = 333
!
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 )
!
ALLOCATE(TAUWX(NSEAL), TAUWY(NSEAL))
!/REFRX ALLOCATE(CIK(NSEAL))
!
!/PALM ALLOCATE(vecta(1:NSEAL),vectb(1:NSEAL))
!/PALM ALLOCATE(vectg(1:NSEAL),vecth(1:NSEAL),vecti(1:NSEAL))
!/PALM ALLOCATE(vectj(1:NSEAL),vectk(1:NSEAL),vectl(1:NSEAL))
!/PALM ALLOCATE(vectm(1:NSEAL),vectn(1:NSEAL),vectp(1:NSEAL))
!/PALM ALLOCATE(vectq(1:NSEAL),vectr(1:NSEAL),vects(1:NSEAL))
!/PALM ALLOCATE(vectwlm(1:NSEAL))
!/PALM ALLOCATE(vectt(1:NSEAL),vectu(1:NSEAL))
!
IF ( PRESENT(STAMP) ) THEN
TSTAMP = STAMP
ELSE
TSTAMP = .TRUE.
END IF
!
IF ( PRESENT(NO_OUT) ) THEN
SKIP_O = NO_OUT
ELSE
SKIP_O = .FALSE.
END IF
!
! 0.b Subroutine tracing
!
!/S CALL STRACE (IENT, 'W3WAVE')
!
!
! 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. FLCK )
!
FLPFLD = .FALSE.
DO J=1,8
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
!
!!Li ALLOCATE ( FIELD(1-NY:NY*(NX+2)) )
IF( RGLGRD .AND. .NOT. FLOMP ) ALLOCATE ( FIELD(1-NY:NY*(NX+2)) )
!
!/SMC !!Li Otherwise use sea point only field
!/SMC ALLOCATE ( FIELD(NCel) )
!
! FIELD(:) = 0.
!
LOCAL = IAPROC .LE. NAPROC
UGDTUPDATE = .FALSE.
IF (FLAGLL) THEN
FACX = 1./(DERA * RADIUS)
ELSE
FACX = 1.
END IF
!
!/SBS NDSOFLG = 99
!
TAUWX = 0.
TAUWY = 0.
!
! 0.d Test output
!
!/T ILEN = LEN_TRIM(FILEXT)
!/T WRITE (NDST,9000) IMOD, FILEXT(:ILEN), TEND
!
! 1. Check the consistency of the input ----------------------------- /
! 1.a Ending time versus initial time
!
DTTST = DSEC21 ( TIME , TEND )
FLZERO = DTTST .EQ. 0.
!/T WRITE (NDST,9010) DTTST, FLZERO
IF ( DTTST .LT. 0. ) THEN
IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1000)
CALL EXTCDE ( 1 )
END IF
!
! 1.b Water level time
!
IF ( FLLEV ) THEN
IF ( TLEV(1) .GE. 0. ) THEN
DTL0 = DSEC21 ( TLEV , TLN )
ELSE
DTL0 = 1.
END IF
!/T WRITE (NDST,9011) DTL0
IF ( DTL0 .LT. 0. ) THEN
IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1001)
CALL EXTCDE ( 2 )
END IF
ELSE
DTL0 = 0.
END IF
!
! 1.c Current interval
!
IF ( FLCUR ) THEN
DTTST1 = DSEC21 ( TC0 , TCN )
DTTST2 = DSEC21 ( TC0 , TIME )
DTTST3 = DSEC21 ( TEND , TCN )
!/T WRITE (NDST,9012) DTTST1, DTTST2, DTTST3
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 )
!/T WRITE (NDST,9013) DTTST1, DTTST2, DTTST3
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
!
! 1.e Ice concentration interval
!
IF ( FLICE ) THEN
IF ( TICE(1) .GE. 0 ) THEN
DTI0 = DSEC21 ( TICE , TIN )
ELSE
DTI0 = 1.
END IF
!/T WRITE (NDST,9014) DTI0
IF ( DTI0 .LT. 0. ) THEN
IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1004)
CALL EXTCDE ( 5 )
END IF
ELSE
DTI0 = 0.
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
!/T WRITE (NDST,9015) DTI10
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
!
!/IS2 IF ( FLIC5 ) THEN
!/IS2 IF ( TIC5(1) .GE. 0 ) THEN
!/IS2 DTI50 = DSEC21 ( TIC5 , TI5 )
!/IS2 ELSE
!/IS2 DTI50 = 1.
!/IS2 END IF
!/IS2!/T WRITE (NDST,9016) DTI50
!/IS2 IF ( DTI50 .LT. 0. ) THEN
!/IS2 IF ( IAPROC .EQ. NAPERR ) WRITE (NDSE,1006)
!/IS2 CALL EXTCDE ( 5 )
!/IS2 END IF
!/IS2 ELSE
!/IS2 DTI50 = 0.
!/IS2 END IF
!
! 2. Determine next time from ending and output --------------------- /
! time and get corresponding time step.
!
FLFRST = .TRUE.
DO
!
!
! 2.a Pre-calculate table for IC3 ------------------------------------ /
!/IC3 USE_CHENG=IC3PARS(9)
!/IC3 IF( USE_CHENG==1.0 )THEN
!/IC3 FIXEDVISC=IC3PARS(14)
!/IC3 FIXEDDENS=IC3PARS(15)
!/IC3 FIXEDELAS=IC3PARS(16)
!/IC3 IF ( (FIXEDVISC.LT.0.0).OR.(FIXEDDENS.LT.0.0) .OR. &
!/IC3 (FIXEDELAS.LT.0.0) ) THEN
!/IC3 IF ( IAPROC .EQ. NAPERR ) &
!/IC3 WRITE(NDSE,*)'Cheng method requires stationary', &
!/IC3 ' and uniform rheology from namelist.'
!/IC3 CALL EXTCDE(2)
!/IC3 END IF
!/IC3 IF (CALLEDIC3TABLE==0) THEN
!/IC3 CALL IC3TABLE_CHENG(FIXEDVISC,FIXEDDENS,FIXEDELAS)
!/IC3 CALLEDIC3TABLE = 1
!/IC3 ENDIF
!/IC3 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
JSEA=1 ! no switch (intentional)
!/IC3 USE_CGICE=IC3PARS(12)
!/IC3 IF ( USE_CGICE==1.0 ) THEN
!/IC3 IF ( IAPROC .EQ. NAPERR ) WRITE(SCREEN,920)
!/IC3 DO JSEA=1,NSEAL
!/DIST ISEA = IAPROC + (JSEA-1)*NAPROC
!/SHRD ISEA = JSEA
!/IC3 ALLOCATE(WN_I(SIZE(WN(:,ISEA))))
!/IC3 WN_I(:) = 0.
!/IC3 DEPTH = MAX( DMIN , DW(ISEA) )
!/IC3 IX = MAPSF(ISEA,1)
!/IC3 IY = MAPSF(ISEA,2)
! 2.b.1 Using Cheng method: requires stationary/uniform rheology.
! However, ice thickness may be input by either method
!/IC3 IF ( USE_CHENG==1.0 ) THEN
!/IC3 IF (FLIC1) THEN
!/IC3 HICE=ICEP1(IX,IY)
!/IC3 ELSEIF (IC3PARS(13).GE.0.0)THEN
!/IC3 HICE=IC3PARS(13)
!/IC3 ELSE
!/IC3 IF ( IAPROC .EQ. NAPERR ) &
!/IC3 WRITE(NDSE,*)'ICE THICKNESS NOT AVAILABLE ', &
!/IC3 'FOR CG CALC'
!/IC3 CALL EXTCDE(2)
!/IC3 ENDIF
!/IC3 IF (HICE > 0.0) THEN ! non-zero ice
!/IC3 CALL W3IC3WNCG_CHENG(WN(:,ISEA),WN_I(:), &
!/IC3 CG(:,ISEA),HICE,FIXEDVISC, &
!/IC3 FIXEDDENS, FIXEDELAS, DEPTH)
!/IC3 END IF ! non-zero ice
!/IC3 ELSE ! not using Cheng method
! 2.b.2 If not using Cheng method: require FLIC1 to FLIC4 (not strictly
! necesssary, but makes code simpler)
!/IC3 IF (FLIC1.AND.FLIC2.AND.FLIC3.AND.FLIC4) THEN
!/IC3 IF (ICEP1(IX,IY)>0.0) THEN ! non-zero ice
!/IC3 CALL W3IC3WNCG_V1(WN(:,ISEA),WN_I(:), &
!/IC3 CG(:,ISEA),ICEP1(IX,IY),ICEP2(IX,IY), &
!/IC3 ICEP3(IX,IY),ICEP4(IX,IY),DEPTH)
!/IC3 END IF ! non-zero ice
!/IC3 ELSE
!/IC3 IF ( IAPROC .EQ. NAPERR ) &
!/IC3 WRITE(NDSE,*)'ICE PARAMETERS NOT AVAILABLE ', &
!/IC3 'FOR CG CALC'
!/IC3 CALL EXTCDE(2)
!/IC3 END IF
!/IC3 ENDIF ! IF USE_CHENG...
!/IC3 DEALLOCATE(WN_I)
!/IC3 END DO ! DO JSEA=1,NSEAL
!/IC3 END IF ! IF USE_CGICE ...
!
IF ( TOFRST(1) .GT. 0 ) THEN
DTTST = DSEC21 ( TEND , TOFRST )
ELSE
DTTST = 0.
ENDIF
!
IF ( DTTST.GE.0. ) THEN
TCALC = TEND
ELSE
TCALC = TOFRST
END IF
!
DTTST = DSEC21 ( TIME , TCALC )
NT = 1 + INT ( DTTST / DTMAX - 0.001 )
DTGA = DTTST / REAL(NT)
IF ( DTTST .EQ. 0. ) THEN
IT0 = 0
IF ( .NOT.FLZERO ) ITIME = ITIME - 1
NT = 0
ELSE
IT0 = 1
END IF
!
!/T WRITE (NDST,9020) IT0, NT, DTGA
!
! ==================================================================== /
!
! 3. Loop over time steps
!
DTRES = 0.
!
DO IT=IT0, NT
!
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 ( TSTAMP .AND. SCREEN.NE.NDSO .AND. IAPROC.EQ.NAPOUT ) THEN
CALL WWTIME ( STTIME )
CALL STME21 ( TIME , IDTIME )
WRITE (SCREEN,950) IDTIME, STTIME
END IF
!
VGX = 0.
VGY = 0.
IF(INFLAGS1(8)) 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
!
!/T WRITE (NDST,9021) ITIME, IT, TIME, FLMAP, FLDDIR, &
!/T VGX, VGY, DTG, DTRES
!
! 3.1 Interpolate winds and currents.
! (Initialize wave fields with winds)
!
IF ( FLCUR ) THEN
!/PALM !
!/PALM ! Getting currents AND water levels from coupler
!/PALM !
!/PALM write(*,*)'PALM:ww this is before goingto 3.1 ',itime,iaproc
!/PALM PALM_TIME_a=ITIME
!/PALM if((palm_time_a.ge.min_palm_time_a).and.(palm_time_a.le.max_palm_time_a))then
!/PALM if (iaproc==1)write(*,*)'PALM:ww wavemd : palm_time_a',palm_time_a
!/PALM !get du cx
!/PALM if (iaproc==1)write(*,*)'PALM:ww will get cx cy',palm_time_a,itime
!/PALM cl_space = 'vect1d'
!/PALM cl_object = 'vectcx'
!
!/PALM CALL PALM_GET(cl_space, cl_object, palm_time_a, PL_NO_TAG, cx, il_err)
!
!/PALM! get du cy
!/PALM cl_space = 'vect1d'
!/PALM cl_object = 'vectcy'
!
!/PALM CALL PALM_GET(cl_space, cl_object, palm_time_a, PL_NO_TAG, cy, il_err)
!
!/PALM if(iaproc==1)write(*,*)'PALM:ww got cx',palm_time_a,itime,cx(100),cy(100)
!/PALM! get du wlv
!/PALM cl_space = 'vect1d'
!/PALM cl_object = 'vectwlv'
!/PALM CALL PALM_GET(cl_space, cl_object, palm_time_a, PL_NO_TAG, wlv, il_err)
!/PALM if(iaproc==1)write(*,*)'PALM:ww got wlv',palm_time_a,itime,wlv(100)
!/PALM endif
!/PALM !
!/PALM ! End of current and water level update from coupler
!/PALM !
!/PALM IF (PALMED.EQ.0) THEN
#if !defined WAVES_OCEAN
CALL W3UCUR ( FLFRST )
#endif
!/PALM ENDIF
IF (GTYPE .NE. UNGTYPE) THEN
IF( RGLGRD ) THEN
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
!/SMC !!Li Use new sub for DCXDX/Y and DCYDX/Y assignment.
!/SMC CALL SMCDCXY
ELSE
CALL UG_GRADIENTS(CX, DCXDX, DCXDY)
CALL UG_GRADIENTS(CY, DCYDX, DCYDY)
UGDTUPDATE=.TRUE.
END IF
!
ELSE IF ( FLFRST ) THEN
UGDTUPDATE=.TRUE.
CX = 0.
CY = 0.
END IF ! FLCUR
!
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
!
IF ( FLIWND .AND. LOCAL ) CALL W3UINI ( VA )
!
! 3.2 Update boundary conditions if boundary flag is true (FLBPI)
!
IF ( FLBPI .AND. LOCAL ) THEN
!
DO
IF ( TBPIN(1) .EQ. -1 ) THEN
READBC = .TRUE.
IDACT(1:1) = 'F'
ELSE
READBC = DSEC21(TIME,TBPIN).LT.0.
IF (READBC.AND.IDACT(1:1).EQ.' ') IDACT(1:1) = 'X'
END IF
FLACT = READBC .OR. FLACT
IF ( READBC ) THEN
CALL W3IOBC ( 'READ', NDS(9), TBPI0, TBPIN, &
ITEST, IMOD )
IF ( ITEST .NE. 1 ) CALL W3UBPT
ELSE
ITEST = 0
END IF
IF ( ITEST .LT. 0 ) IDACT(1:1) = 'L'
IF ( ITEST .GT. 0 ) IDACT(1:1) = ' '
IF ( .NOT. (READBC.AND.FLBPI) ) EXIT
END DO
!
END IF
!
! 3.3.1 Update ice coverage (if new ice map).
! Need to be run on output nodes too, to update MAPSTx
!
IF ( FLICE .AND. DTI0.NE.0. ) THEN
!
IF ( TICE(1).GE.0 ) THEN
IF ( DTI0 .LT. 0. ) THEN
IDACT(9:9) = 'B'
ELSE
DTTST = DSEC21 ( TIME, TIN )
IF ( DTTST .LE. 0.5*DTI0 ) IDACT(9:9) = 'U'
END IF
ELSE
IDACT(9:9) = 'I'
END IF
!
IF ( IDACT(9:9).NE.' ' ) THEN
CALL W3UICE ( VA, VA )
DTI0 = 0.
FLACT = .TRUE.
FLMAP = .TRUE.
END IF
!
END IF
!
! 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(11:11) = 'B'
ELSE
DTTST = DSEC21 ( TIME, TI1 )
IF ( DTTST .LE. 0.5*DTI10 ) IDACT(11:11) = 'U'
END IF
ELSE
IDACT(11:11) = 'I'
END IF
!
IF ( IDACT(11:11).NE.' ' ) THEN
CALL W3UIC1 ( FLFRST )
DTI10 = 0.
FLACT = .TRUE.
FLMAP = .TRUE.
END IF
!
END IF
!
! 3.3.3 Update ice floe diameter
!
!/IS2 IF ( FLIC5 .AND. DTI50.NE.0. ) THEN
!
!/IS2 IF ( TIC5(1).GE.0 ) THEN
!/IS2 IF ( DTI50 .LT. 0. ) THEN
!/IS2 IDACT(14:14) = 'B'
!/IS2 ELSE
!/IS2 DTTST = DSEC21 ( TIME, TI5 )
!/IS2 IF ( DTTST .LE. 0.5*DTI50 ) IDACT(14:14) = 'U'
!/IS2 END IF
!/IS2 ELSE
!/IS2 IDACT(14:14) = 'I'
!/IS2 END IF
!
!/IS2 IF ( IDACT(14:14).NE.' ' ) THEN
!/IS2 CALL W3UIC5( FLFRST )
!/IS2 DTI50 = 0.
!/IS2 FLACT = .TRUE.
!/IS2 FLMAP = .TRUE.
!/IS2 END IF
!
!/IS2 END IF
!
! 3.4 Transform grid (if new water level).
!
IF ( FLLEV .AND. DTL0.NE.0. ) THEN
!
IF ( TLEV(1).GE.0 ) THEN
IF ( DTL0 .LT. 0. ) THEN
IDACT(5:5) = 'B'
ELSE
DTTST = DSEC21 ( TIME, TLN )
IF ( DTTST .LE. 0.5*DTL0 ) IDACT(5:5) = 'U'
END IF
ELSE
IDACT(5:5) = 'I'
END IF
!
IF ( IDACT(5:5).NE.' ' ) THEN
CALL W3ULEV ( VA, VA )
UGDTUPDATE=.TRUE.
DTL0 = 0.
FLACT = .TRUE.
FLMAP = .TRUE.
FLDDIR = FLDDIR .OR. FLCTH .OR. FLCK
END IF
!
END IF
!
! 3.5 Update maps and derivatives.
!
!!Li IF ( FLMAP ) THEN
IF ( FLMAP .AND. RGLGRD ) THEN
!/PR1 CALL W3MAP1 ( MAPSTA )
!/PR2 CALL W3MAP2
!/PR3 CALL W3MAP3
!/PRX CALL W3MAPX
CALL W3UTRN ( TRNX, TRNY )
!/PR3 CALL W3MAPT
CALL W3NMIN ( MAPSTA, FLAG0 )
IF ( FLAG0 .AND. IAPROC.EQ.NAPERR ) WRITE (NDSE,1030) IMOD
FLMAP = .FALSE.
END IF
!
!/SMC !!Li The sea point nubmer per pe is also checked for SMC grid.
!/SMC IF ( FLMAP ) THEN
!/SMC CALL W3NMIN ( MAPSTA, FLAG0 )
!/SMC IF ( FLAG0 .AND. IAPROC.EQ.NAPERR ) WRITE (NDSE,1030) IMOD
!/SMC FLMAP = .FALSE.
!/SMC END IF
!
IF ( FLDDIR ) THEN
IF (GTYPE .NE. UNGTYPE) THEN
!!Li CALL W3DZXY(DW(1:NSEA),'m',DDDX,DDDY) !DEPTH (DW) GRADIENT
IF( RGLGRD ) CALL W3DZXY(DW(1:UBOUND(DW,1)),'m',DDDX,DDDY)
!/SMC !!Li Use new sub for DDDX and DDDY assignment.
!/SMC CALL SMCDHXY
!/SMCT WRITE (NDST,*) " * SMCDHXY completed IT DTG =", IT, DTG
!
ELSE
CALL UG_GRADIENTS(DW, DDDX, DDDY)
END IF
FLDDIR = .FALSE.
END IF
!
! Calculate PHASE SPEED GRADIENT.
DCDX = 0.
DCDY = 0.
!/REFRX CIK = 0.
!/REFRX!
!/REFRX IF (GTYPE .NE. UNGTYPE) THEN
!/REFRX DO IK=0,NK+1
!/REFRX CIK = SIG(IK) / WN(IK,1:NSEA)
!/REFRX CALL W3DZXY(CIK,'m/s',DCDX(IK,:,:),DCDY(IK,:,:))
!/REFRX END DO
!/REFRX ELSE
!/REFRX WRITE (NDSE,1040)
!/REFRX CALL EXTCDE(2)
!/REFRX ! CALL UG_GRADIENTS(CMN, DCDX, DCDY) !/ Stefan, to be confirmed!
!/REFRX END IF
!
FLIWND = .FALSE.
FLFRST = .FALSE.
!
IF ( FLZERO ) THEN
!/T WRITE (NDST,9022)
GOTO 400
END IF
IF ( IT.EQ.0 ) THEN
DTG = 1.
GOTO 370
END IF
IF ( FLDRY .OR. IAPROC.GT.NAPROC ) THEN
!/T WRITE (NDST,9023)
GOTO 380
END IF
!
! Estimation of the local maximum CFL for XY propagation
!
!/T FLOGRD(9,3)=.TRUE.
!/T WRITE(NDSE,*) 'Computing CFLs .... ',NSEAL
IF ( FLOGRD(9,3).AND. UGDTUPDATE ) THEN
NKCFL=NK
!/T NKCFL=1
!
!/OMPG/!$OMP PARALLEL DO PRIVATE (JSEA,ISEA,IX,IY) SCHEDULE (DYNAMIC,1)
!
DO JSEA=1, NSEAL
!/DIST ISEA = IAPROC + (JSEA-1)*NAPROC
!/SHRD ISEA = JSEA
!/T IF (MOD(ISEA,100).EQ.0) WRITE(NDSE,*) 'COMPUTING CFL FOR NODE:',ISEA
!/PR3 IF (GTYPE .EQ. UNGTYPE) THEN
!/PR3 CALL W3CFLUG ( ISEA, NKCFL, FACX, FACX, DTG, &
!/PR3 MAPFS, CFLXYMAX(JSEA), VGX, VGY )
!/PR3 ELSE
!/PR3 CALL W3CFLXY ( ISEA, DTG, MAPSTA, MAPFS, &
!/PR3 CFLXYMAX(JSEA), VGX, VGY )
!/PR3 END IF
END DO
!
!/OMPG/!$OMP END PARALLEL DO
!
END IF
!
!/T IF (GTYPE .EQ. UNGTYPE) THEN
!/T DTCFL1(:)=1.
!/T DO ISEA=1,NSEA
!/T INDSORT(ISEA)=FLOAT(ISEA)
!/T DTCFL1(ISEA)=DTG/CFLXYMAX(ISEA)
!/T END DO
!/T CALL SSORT1 (DTCFL1, INDSORT, NSEAL, 2)
!/T IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,*) 'Nodes requesting smallest timesteps:'
!/T IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,'(A,10I10)') 'Nodes ',NINT(INDSORT(1:10))
!/T IF ( IAPROC .EQ. NAPERR ) WRITE(NDSE,'(A,10F10.2)') 'time steps ',DTCFL1(1:10)
!/T DO JSEA = 1, MIN(NSEAL,200)
!/T ISEA = NINT(INDSORT(JSEA)) ! will not work with MPI
!/T IX = MAPSF(ISEA,1)
!/T IF (JSEA.EQ.1) &
!/T WRITE(995,*) ' IP dtmax_exp(ip) x-coord y-coord z-coord'
!/T WRITE(995,'(I10,F10.2,3F10.4)') IX, DTCFL1(JSEA), XYB(IX,1), XYB(IX,2), XYB(IX,3)
!/T END DO ! JSEA
!/T CLOSE(995)
!/T END IF
!
! 3.6 Perform Propagation = = = = = = = = = = = = = = = = = = = = = = =
! 3.6.1 Preparations
!
!/SEC1 DTGTEMP=DTG
!/SEC1 DTG=DTG/NITERSEC1
!/SEC1 DO ISEC1=1,NITERSEC1
NTLOC = 1 + INT( DTG/DTCFLI - 0.001 )
!/SEC1 IF ( IAPROC .EQ. NAPOUT ) WRITE(NDSE,'(A,I4,A,I4)') ' SUBSECOND STEP:',ISEC1,' out of ',NITERSEC1
!
FACTH = DTG / (DTH*REAL(NTLOC))
FACK = DTG / REAL(NTLOC)
ITLOCH = ( NTLOC + 1 - MOD(ITIME,2) ) / 2
!
! 3.6.2 Intra-spectral part 1
!
IF ( FLCTH .OR. FLCK ) THEN
DO ITLOC=1, ITLOCH
!
!/OMPG/!$OMP PARALLEL PRIVATE (JSEA,ISEA,IX,IY,DEPTH)
!/OMPG/!$OMP DO SCHEDULE (DYNAMIC,1)
!
DO JSEA=1, NSEAL
!/DIST ISEA = IAPROC + (JSEA-1)*NAPROC
!/SHRD ISEA = JSEA
IX = MAPSF(ISEA,1)
IY = MAPSF(ISEA,2)
IF ( MAPSTA(IY,IX) .EQ. 1 ) THEN
DEPTH = MAX ( DMIN , DW(ISEA) )
!/PR1 CALL W3KTP1 ( ISEA, FACTH, FACK, CTHG0S(ISEA), &
!/PR1 CG(:,ISEA), WN(:,ISEA), DEPTH, &
!/PR1 DDDX(IY,IX), DDDY(IY,IX), CX(ISEA), &
!/PR1 CY(ISEA), DCXDX(IY,IX), DCXDY(IY,IX), &
!/PR1 DCYDX(IY,IX), DCYDY(IY,IX), &
!/PR1 DCDX(:,IY,IX), DCDY(:,IY,IX), VA(:,JSEA))
!/PR2 CALL W3KTP2 ( ISEA, FACTH, FACK, CTHG0S(ISEA), &
!/PR2 CG(:,ISEA), WN(:,ISEA), DEPTH, &
!/PR2 DDDX(IY,IX), DDDY(IY,IX), CX(ISEA), &
!/PR2 CY(ISEA), DCXDX(IY,IX), DCXDY(IY,IX), &
!/PR2 DCYDX(IY,IX), DCYDY(IY,IX), &
!/PR2 DCDX(:,IY,IX), DCDY(:,IY,IX), VA(:,JSEA))
!/PR3 CALL W3KTP3 ( ISEA, FACTH, FACK, CTHG0S(ISEA), &
!/PR3 CG(:,ISEA), WN(:,ISEA), DEPTH, &
!/PR3 DDDX(IY,IX), DDDY(IY,IX), CX(ISEA), &
!/PR3 CY(ISEA), DCXDX(IY,IX), DCXDY(IY,IX), &
!/PR3 DCYDX(IY,IX), DCYDY(IY,IX), &
!/PR3 DCDX(:,IY,IX), DCDY(:,IY,IX), VA(:,JSEA), &
!/PR3 CFLTHMAX(JSEA), CFLKMAX(JSEA) )
!/PRX CALL W3KTPX
!
!/SMC !!Li Refraction and GCT in theta direction is done by rotation.
!/SMC CALL W3KRTN ( ISEA, FACTH, FACK, CTHG0S(ISEA), &
!/SMC CG(:,ISEA), WN(:,ISEA), DEPTH, &
!/SMC DHDX(ISEA), DHDY(ISEA), DHLMT(:,ISEA), &
!/SMC CX(ISEA), CY(ISEA), DCXDX(IY,IX), &
!/SMC DCXDY(IY,IX), DCYDX(IY,IX), DCYDY(IY,IX), &
!/SMC DCDX(:,IY,IX), DCDY(:,IY,IX), VA(:,JSEA) )
!
END IF
END DO
!
!/OMPG/!$OMP END DO
!/OMPG/!$OMP END PARALLEL
!
END DO
END IF
!
! 3.6.3 Longitude-latitude
! (time step correction in routine)
!
IF ( FLCX .OR. FLCY ) THEN
!
!/MPI IF ( NRQSG1 .GT. 0 ) THEN
!/MPI CALL MPI_STARTALL (NRQSG1, IRQSG1(1,1), IERR_MPI)
!/MPI CALL MPI_STARTALL (NRQSG1, IRQSG1(1,2), IERR_MPI)
!/MPI END IF
!
!/OMPX/!$OMP PARALLEL PRIVATE (ISPEC,FIELD)
!
IF ( FLOMP ) ALLOCATE ( FIELD(1-NY:NY*(NX+2)) )
!
!/OMPX/!$OMP DO SCHEDULE (DYNAMIC,1)
!
DO ISPEC=1, NSPEC
IF ( IAPPRO(ISPEC) .EQ. IAPROC ) THEN
!!Li CALL W3GATH ( ISPEC, FIELD )
IF( RGLGRD ) CALL W3GATH ( ISPEC, FIELD )
!/SMC !!Li Otherwise use SMC sub to gether field
!/SMC CALL W3GATHSMC ( ISPEC, FIELD )
!
IF (GTYPE .NE. UNGTYPE) THEN
!/PR1 CALL W3XYP1 ( ISPEC, DTG, MAPSTA, FIELD, VGX, VGY )
!/PR2 CALL W3XYP2 ( ISPEC, DTG, MAPSTA, MAPFS, FIELD, VGX, VGY )
!/PR3 CALL W3XYP3 ( ISPEC, DTG, MAPSTA, MAPFS, FIELD, VGX, VGY )
!/PRX CALL W3XYPX
!/SMC !!Li Propagation on SMC grid uses UNO2 scheme.
!/SMC CALL W3PSMC ( ISPEC, DTG, FIELD )
!
ELSE IF (GTYPE .EQ. UNGTYPE) THEN
!/PR1 CALL W3XYPUG ( ISPEC, FACX, FACX, DTG, &
!/PR1 FIELD, VGX, VGY, UGDTUPDATE )
!/PR2 CALL W3XYPUG ( ISPEC, FACX, FACX, DTG, &
!/PR2 FIELD, VGX, VGY, UGDTUPDATE )
!/PR3 CALL W3XYPUG ( ISPEC, FACX, FACX, DTG, &
!/PR3 FIELD, VGX, VGY, UGDTUPDATE )
!/PRX CALL W3XYPUG ( ISPEC, FACX, FACX, DTG, &
!/PRX FIELD, VGX, VGY, UGDTUPDATE )
END IF
!!Li CALL W3SCAT ( ISPEC, MAPSTA, FIELD )
IF( RGLGRD ) CALL W3SCAT ( ISPEC, MAPSTA, FIELD )
!/SMC !!Li Otherwise use SMC sub to scatter field
!/SMC CALL W3SCATSMC ( ISPEC, MAPSTA, FIELD )
!
END IF
END DO
!
!/MPI IF ( NRQSG1 .GT. 0 ) THEN
!/MPI ALLOCATE ( STATCO(MPI_STATUS_SIZE,NRQSG1) )
!/MPI CALL MPI_WAITALL (NRQSG1, IRQSG1(1,1), STATCO, &
!/MPI IERR_MPI)
!/MPI CALL MPI_WAITALL (NRQSG1, IRQSG1(1,2), STATCO, &
!/MPI IERR_MPI)
!/MPI DEALLOCATE ( STATCO )
!/MPI END IF
!/OMPX/!$OMP END DO
IF ( FLOMP ) DEALLOCATE ( FIELD )
!/OMPX/!$OMP END PARALLEL
!
!/ARC !Li Find source boundary spectra and assign to SPCBAC
!/ARC !Li Have to use mpi options so will be empty if ARC not selected.
!/ARC DO IK = 1, NBAC
!/ARC IF( IK .LE. (NBAC-NBGL) ) THEN
!/ARC IY = ICLBAC(IK)
!/ARC ELSE
!/ARC IY = NGLO + IK
!/ARC ENDIF
!/ARC
!/ARC !Li Work out root PE (ISPEC) and JSEA numbers for IY
!
IF( ARCTIC ) THEN
!/DIST ISPEC = MOD( IY-1, NAPROC )
!/DIST JSEA = 1 + (IY - ISPEC - 1)/NAPROC
!/SHRD ISPEC = 0
!/SHRD JSEA = IY
ENDIF
!
!/ARC !!Li Assign boundary cell spectra.
!/ARC IF( IAPROC .EQ. ISPEC+1 ) THEN
!/ARC SPCBAC(:,IK)=VA(:,JSEA)
!/ARC ENDIF
!
!/MPI !!Li Broadcast local SPCBAC(:,IK) to all other PEs.
!/MPI IF( ARCTIC ) THEN
!/MPI CALL MPI_BCAST(SPCBAC(1,IK),NSPEC,MPI_REAL,ISPEC,MPI_COMM_WORLD,IERR_MPI)
!/MPI CALL MPI_BARRIER (MPI_COMM_WORLD,IERR_MPI)
!/MPI ENDIF
!
!/ARC !!Li Boundary cell loop IK ends.
!/ARC END DO
!
!/ARC !Li Update Arctic boundary cell spectra if within local range
!/ARC ALLOCATE ( BACSPEC(NSPEC) )
!/ARC DO IK = 1, NBAC
!/ARC IF( IK .LE. (NBAC-NBGL) ) THEN
!/ARC IX = NGLO + IK
!/ARC BACANGL = ANGARC(IK)
!/ARC ELSE
!/ARC IX = ICLBAC(IK)
!/ARC BACANGL = - ANGARC(IK)
!/ARC ENDIF
!/ARC
!/ARC !Li Work out boundary PE (ISPEC) and JSEA numbers for IX
!
IF( ARCTIC ) THEN
!/DIST ISPEC = MOD( IX-1, NAPROC )
!/DIST JSEA = 1 + (IX - ISPEC - 1)/NAPROC
!/SHRD ISPEC = 0
!/SHRD JSEA = IX
ENDIF
!
!/ARC IF( IAPROC .EQ. ISPEC+1 ) THEN
!/ARC BACSPEC = SPCBAC(:,IK)
!/ARC
!/ARC CALL w3acturn( NTH, NK, BACANGL, BACSPEC )
!/ARC
!/ARC VA(:,JSEA) = BACSPEC
!/ARC !Li WRITE(NDSE,*) "IAPROC, IX, JSEAx, IK=", IAPROC, IX, JSEA, IK
!/ARC ENDIF
!/ARC
!/ARC !!Li Boundary cell loop IK ends.
!/ARC END DO
!/ARC DEALLOCATE ( BACSPEC )
!
! End of test FLCX.OR.FLCY
!
END IF
!
! 3.6.4 Intra-spectral part 2
!
IF ( FLCTH .OR. FLCK ) THEN
DO ITLOC=ITLOCH+1, NTLOC
!
!/OMPG/!$OMP PARALLEL PRIVATE (JSEA,ISEA,IX,IY,DEPTH)
!/OMPG/!$OMP DO SCHEDULE (DYNAMIC,1)
!
DO JSEA=1, NSEAL
!/DIST ISEA = IAPROC + (JSEA-1)*NAPROC
!/SHRD ISEA = JSEA
IX = MAPSF(ISEA,1)
IY = MAPSF(ISEA,2)
DEPTH = MAX ( DMIN , DW(ISEA) )
IF ( MAPSTA(IY,IX) .EQ. 1 ) THEN
!/PR1 CALL W3KTP1 ( ISEA, FACTH, FACK, CTHG0S(ISEA), &
!/PR1 CG(:,ISEA), WN(:,ISEA), DEPTH, &
!/PR1 DDDX(IY,IX), DDDY(IY,IX), CX(ISEA), &
!/PR1 CY(ISEA), DCXDX(IY,IX), DCXDY(IY,IX), &
!/PR1 DCYDX(IY,IX), DCYDY(IY,IX), &
!/PR1 DCDX(:,IY,IX), DCDY(:,IY,IX), VA(:,JSEA))
!/PR2 CALL W3KTP2 ( ISEA, FACTH, FACK, CTHG0S(ISEA), &
!/PR2 CG(:,ISEA), WN(:,ISEA), DEPTH, &
!/PR2 DDDX(IY,IX), DDDY(IY,IX), CX(ISEA), &
!/PR2 CY(ISEA), DCXDX(IY,IX), DCXDY(IY,IX), &
!/PR2 DCYDX(IY,IX), DCYDY(IY,IX), &
!/PR2 DCDX(:,IY,IX), DCDY(:,IY,IX), VA(:,JSEA))
!/PR3 CALL W3KTP3 ( ISEA, FACTH, FACK, CTHG0S(ISEA), &
!/PR3 CG(:,ISEA), WN(:,ISEA), DEPTH, &
!/PR3 DDDX(IY,IX), DDDY(IY,IX), CX(ISEA), &
!/PR3 CY(ISEA), DCXDX(IY,IX), DCXDY(IY,IX), &
!/PR3 DCYDX(IY,IX), DCYDY(IY,IX), &
!/PR3 DCDX(:,IY,IX), DCDY(:,IY,IX), VA(:,JSEA), &
!/PR3 CFLTHMAX(JSEA), CFLKMAX(JSEA) )
!/PRX CALL W3KTPX
!
!/SMC !!Li Refraction and GCT in theta direction is done by rotation.
!/SMC CALL W3KRTN ( ISEA, FACTH, FACK, CTHG0S(ISEA), &
!/SMC CG(:,ISEA), WN(:,ISEA), DEPTH, &
!/SMC DHDX(ISEA), DHDY(ISEA), DHLMT(:,ISEA), &
!/SMC CX(ISEA), CY(ISEA), DCXDX(IY,IX), &
!/SMC DCXDY(IY,IX), DCYDX(IY,IX), DCYDY(IY,IX), &
!/SMC DCDX(:,IY,IX), DCDY(:,IY,IX), VA(:,JSEA) )
!
END IF
END DO
!
!/OMPG/!$OMP END DO
!/OMPG/!$OMP END PARALLEL
!
END DO
END IF
!
UGDTUPDATE = .FALSE.
!
! 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.
!
!/OMPG/!$OMP PARALLEL PRIVATE (JSEA,ISEA,IX,IY,DELA,DELX,DELY, &
!/OMPG/!$OMP& REFLEC,REFLED,D50,PSIC,TMP1,TMP2,TMP3)
!/OMPG/!$OMP DO SCHEDULE (DYNAMIC,1)
!
DO JSEA=1, NSEAL
!/DIST ISEA = IAPROC + (JSEA-1)*NAPROC
!/SHRD ISEA = JSEA
IX = MAPSF(ISEA,1)
IY = MAPSF(ISEA,2)
DELA=1.
DELX=1.
DELY=1.
!/REF1 IF (GTYPE.EQ.RLGTYPE) THEN
!/REF1 DELX=SX*CLATS(ISEA)/FACX
!/REF1 DELY=SY/FACX
!/REF1 DELA=DELX*DELY
!/REF1 END IF
!/REF1 IF (GTYPE.EQ.CLGTYPE) THEN
!/REF1! Maybe what follows works also for RLGTYPE ... to be verified
!/REF1 DELX=HPFAC(IY,IX)/ FACX
!/REF1 DELY=HQFAC(IY,IX)/ FACX
!/REF1 DELA=DELX*DELY
!/REF1 END IF
!
!/REF1 REFLEC=REFLC(:,ISEA)
!/REF1 REFLEC(4)=BERG(ISEA)*REFLEC(4)
!/REF1 REFLED=REFLD(:,ISEA)
!/BT4 D50=SED_D50(ISEA)
!/BT4 PSIC=SED_PSIC(ISEA)
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)
CALL W3SRCE ( IT, IX, IY, IMOD, VA(:,JSEA), &
ALPHA(1:NK,JSEA), WN(1:NK,ISEA), &
CG(1:NK,ISEA), DW(ISEA), U10(ISEA), &
U10D(ISEA), 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), &
PHIOC(JSEA), TMP1, D50, PSIC, TMP2, &
PHIBBL(JSEA), TMP3, TMP4 , PHICE(JSEA), &
ASF(ISEA))
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
END IF
END DO
!
!/OMPG/!$OMP END DO
!/OMPG/!$OMP END PARALLEL
!
!
! 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
!
! End of interations for DTMAX < 1s
!
!/SEC1 IF (IT.EQ.0) EXIT
!/SEC1 END DO
!/SEC1 IF (IT.GT.0) DTG=DTGTEMP
!
!
! PALM COUPLER Calls
!
!/PALM DO JSEA=1, NSEAL
!/PALM ISEA = IAPROC + (JSEA-1)*NAPROC
!/PALM! vecta(JSEA)=ust(ISEA)
!/PALM! vectb(JSEA)=ustdir(ISEA)
!/PALM vecta(JSEA)=0.0
!/PALM vectb(JSEA)=0.0
!/PALM END DO
!
!/PALM write(*,*)'suis dans w3wavemd, print iaproc,vecta,vectb',iaproc
!/PALM write(*,*)'PALM:ww this is where you send vecta',itime
! this may be the mistake
!modif ac 060410
!/PALM palm_time_b=ITIME
!fin modif ac
!/PALM if (iaproc==1) write(*,*)'palm_time_b,min_palm_time_b,max_palm_time_b',palm_time_b,min_palm_time_b,max_palm_time_b
!/PALM if((palm_time_b.ge.min_palm_time_b).and.(palm_time_b.le.max_palm_time_b))then
!/PALM if (iaproc==1) write(*,*)'send ust plam_time_b iaproc',palm_time_b,iaproc
!/PALM cl_space = 'vect1d'
!/PALM cl_object = 'vecta'
!/PALM if (iaproc==1) write(*,*)'PALM:ww will send vecta',palm_time_b,itime
!/PALM CALL PALM_PUT(cl_space, cl_object, palm_time_b, PL_NO_TAG, vecta, il_err)
!/PALM if (iaproc==1) write(*,*)'PALM:ww sent vecta',palm_time_b,itime
!/PALM cl_space = 'vect1d'
!/PALM cl_object = 'vectb'
!/PALM CALL PALM_PUT(cl_space, cl_object, palm_time_b, PL_NO_TAG, vectb, il_err)
!/PALM if (iaproc==1)write(*,*)'PALM:ww sent vectb',palm_time_b,itime
!/PALM endif
!
!
!
!/PALM !modif ac pour tester avec ma version de mellor 2003
!/PALM MEL03=.FALSE.
!/PALM if (iaproc==1)write(*,*)'PALM:ww coucou here calculating vect g,h,i,j,k,l at itime=',itime,iaproc
!/PALM if (iaproc==1)write(*,*)'PALM:ww this is where you send vect g,h,i,j,k,l',itime,palm_time_b,iaproc
!/PALM if((palm_time_b.ge.min_palm_time_b).and.(palm_time_b.le.max_palm_time_b))then
!/PALM IF (MEL03) THEN
!/PALM if (iaproc==1) write(*,*)'je suis dans le if de MEL03'
!/PALM DO JSEA=1, NSEAL
!/PALM ISEA = IAPROC + (JSEA-1)*NAPROC
!/PALM vectg(JSEA)=WLV(ISEA)
!/PALM vecth(JSEA)=T0M1(ISEA)
!/PALM vecti(JSEA)=HS(ISEA)
!/PALM vectj(JSEA)=THM(ISEA)
!/PALM vectk(JSEA)=TAUWX(ISEA)
!/PALM vectl(JSEA)=TAUWY(ISEA)
!/PALM END DO
!/PALM ELSE
!/PALM if (iaproc==1) write(*,*)'je suis dans le else de MEL03'
!/PALM DO JSEA=1, NSEAL
!/PALM ISEA = IAPROC + (JSEA-1)*NAPROC
!/PALM vectg(JSEA)=WLV(ISEA)
!/PALM vecth(JSEA)=T0M1(ISEA)
!/PALM vecti(JSEA)=HS(ISEA)
!/PALM vectj(JSEA)=THM(ISEA)
!/PALM vectk(JSEA)=BHD(ISEA)
!/PALM vectl(JSEA)=TAUOX(ISEA)
!/PALM vectm(JSEA)=TAUOY(ISEA)
!/PALM vectn(JSEA)=TAUWX(ISEA)
!/PALM vectp(JSEA)=TAUWY(ISEA)
!/PALM vectq(JSEA)=UBA(ISEA)
!/PALM vectr(JSEA)=UBD(ISEA)
!/PALM vects(JSEA)=PHIOC(ISEA)
!/PALM vectt(JSEA)=TAUWIX(ISEA)
!/PALM vectu(JSEA)=TAUWIY(ISEA)
!/PALM vectwlm(JSEA)=WLM(ISEA)
!/PALM END DO
!/PALM END IF
!/PALM end if
!/PALM if (iaproc==1) write(*,*)'HS: 1933-2008',HS(1933:2008)
!/PALM !fin modif ac
!/PALM if((palm_time_b.ge.min_palm_time_b).and.(palm_time_b.le.max_palm_time_b))then
!/PALM cl_space = 'vect1d'
!/PALM cl_object = 'vectg'
!/PALM CALL PALM_PUT(cl_space, cl_object, palm_time_b, PL_NO_TAG, vectg, il_err)
!/PALM cl_space = 'vect1d'
!/PALM cl_object = 'vecth'
!/PALM CALL PALM_PUT(cl_space, cl_object, palm_time_b, PL_NO_TAG, vecth, il_err)
!/PALM cl_space = 'vect1d'
!/PALM cl_object = 'vecti'
!/PALM CALL PALM_PUT(cl_space, cl_object, palm_time_b, PL_NO_TAG, vecti, il_err)
!/PALM cl_space = 'vect1d'
!/PALM cl_object = 'vectj'
!/PALM CALL PALM_PUT(cl_space, cl_object, palm_time_b, PL_NO_TAG, vectj, il_err)
!/PALM cl_space = 'vect1d'
!/PALM cl_object = 'vectk'
!/PALM CALL PALM_PUT(cl_space, cl_object, palm_time_b, PL_NO_TAG, vectk, il_err)
!/PALM cl_space = 'vect1d'
!/PALM cl_object = 'vectl'
!/PALM CALL PALM_PUT(cl_space, cl_object, palm_time_b, PL_NO_TAG, vectl, il_err)
!/PALM cl_space = 'vect1d'
!/PALM cl_object = 'vectm'
!/PALM CALL PALM_PUT(cl_space, cl_object, palm_time_b, PL_NO_TAG, vectm, il_err)
!/PALM cl_space = 'vect1d'
!/PALM cl_object = 'vectn'
!/PALM CALL PALM_PUT(cl_space, cl_object, palm_time_b, PL_NO_TAG, vectn, il_err)
!/PALM cl_space = 'vect1d'
!/PALM cl_object = 'vectp'
!/PALM CALL PALM_PUT(cl_space, cl_object, palm_time_b, PL_NO_TAG, vectp, il_err)
!/PALM cl_space = 'vect1d'
!/PALM cl_object = 'vectq'
!/PALM CALL PALM_PUT(cl_space, cl_object, palm_time_b, PL_NO_TAG, vectq, il_err)
!/PALM cl_space = 'vect1d'
!/PALM cl_object = 'vectr'
!/PALM CALL PALM_PUT(cl_space, cl_object, palm_time_b, PL_NO_TAG, vectr, il_err)
!/PALM cl_space = 'vect1d'
!/PALM cl_object = 'vects'
!/PALM CALL PALM_PUT(cl_space, cl_object, palm_time_b, PL_NO_TAG, vects, il_err)
!/PALM cl_space = 'vect1d'
!/PALM cl_object = 'vectt'
!/PALM CALL PALM_PUT(cl_space, cl_object, palm_time_b, PL_NO_TAG, vectt, il_err)
!/PALM cl_space = 'vect1d'
!/PALM cl_object = 'vectu'
!/PALM CALL PALM_PUT(cl_space, cl_object, palm_time_b, PL_NO_TAG, vectu, il_err)
!/PALM cl_space = 'vect1d'
!/PALM cl_object = 'vectwlm'
!/PALM CALL PALM_PUT(cl_space, cl_object, palm_time_b, PL_NO_TAG, vectwlm, il_err)
!/PALM if (iaproc==1) write(*,*)'PALM:ww sent vect g...rs wlm',palm_time_b,itime,iaproc
!/PALM endif
!
!
! 3.8 Update global time step.
! (Branch point FLDRY, IT=0)
!
380 CONTINUE
!
IF (IT.NE.NT) THEN
DTTST = DSEC21 ( TIME , TCALC )
DTG = DTTST / REAL(NT-IT)
END IF
!
IF ( FLACT .AND. IT.NE.NT .AND. IAPROC.EQ.NAPLOG ) THEN
CALL STME21 ( TIME , IDTIME )
IF ( IDLAST .NE. TIME(1) ) THEN
WRITE (NDSO,900) ITIME, IPASS, IDTIME(01:19), &
IDACT, OUTID
IDLAST = TIME(1)
ELSE
WRITE (NDSO,901) ITIME, IPASS, IDTIME(12:19), &
IDACT, OUTID
END IF
FLACT = .FALSE.
IDACT = ' '
END IF
!
END DO
!
!/T WRITE (NDST,9030)
!
! End of loop over time steps
! ==================================================================== /
!
400 CONTINUE
!
! 4. Perform output to file if requested ---------------------------- /
! 4.a Check if time is output time
! Delay if data assimilation time.
!
IF ( TOFRST(1) .EQ. -1 ) THEN
DTTST = 1.
ELSE
DTTST = DSEC21 ( TIME, TOFRST )
END IF
!
IF ( TDN(1) .EQ. -1 ) THEN
DTTST1 = 1.
ELSE
DTTST1 = DSEC21 ( TIME, TDN )
END IF
!
DTTST2 = DSEC21 ( TIME, TEND )
FLAG_O = .NOT.SKIP_O .OR. ( SKIP_O .AND. DTTST2.NE.0. )
!
!/T WRITE (NDST,9040) TOFRST, TDN, DTTST, DTTST1, FLAG_O
!
IF ( DTTST.LE.0. .AND. DTTST1.NE.0. .AND. FLAG_O ) THEN
!
!/T WRITE (NDST,9041)
!
! 4.b Processing and MPP preparations
!
IF ( FLOUT(1) ) THEN
FLOUTG = DSEC21(TIME,TONEXT(:,1)).EQ.0.
ELSE
FLOUTG = .FALSE.
END IF
!
IF ( FLOUT(7) ) THEN
FLOUTG2 = DSEC21(TIME,TONEXT(:,7)).EQ.0.
ELSE
FLOUTG2 = .FALSE.
END IF
!
FLPART = .FALSE.
IF ( FLOUT(1) .AND. FLPFLD ) &
FLPART = FLPART .OR. DSEC21(TIME,TONEXT(:,1)).EQ.0.
IF ( FLOUT(6) ) &
FLPART = FLPART .OR. DSEC21(TIME,TONEXT(:,6)).EQ.0.
!
!/T WRITE (NDST,9042) LOCAL, FLPART, FLOUTG
!
IF ( LOCAL .AND. FLPART ) CALL W3CPRT ( IMOD )
IF ( LOCAL .AND. (FLOUTG .OR. FLOUTG2) ) &
CALL W3OUTG ( VA, FLPFLD, FLOUTG, FLOUTG2 )
!
!/MPI FLGMPI = .FALSE.
!/MPI NRQMAX = 0
!
!/MPI IF ( (FLOUT(1) .OR. FLOUT(7)) .AND. NRQGO.NE.0 ) THEN
!/MPI IF ( ( DSEC21(TIME,TONEXT(:,1)).EQ.0. ) .OR. &
!/MPI ( DSEC21(TIME,TONEXT(:,7)).EQ.0. ) ) THEN
!/MPI CALL MPI_STARTALL ( NRQGO, IRQGO , IERR_MPI )
!/MPI FLGMPI(0) = .TRUE.
!/MPI NRQMAX = MAX ( NRQMAX , NRQGO )
!/MPIT WRITE (NDST,9043) '1a', NRQGO, NRQMAX, NAPFLD
!/MPI END IF
!/MPI END IF
!
!/MPI IF ( (FLOUT(1) .OR. FLOUT(7)) .AND. NRQGO2.NE.0 ) THEN
!/MPI IF ( ( DSEC21(TIME,TONEXT(:,1)).EQ.0. ) .OR. &
!/MPI ( DSEC21(TIME,TONEXT(:,7)).EQ.0. ) ) THEN
!/MPI CALL MPI_STARTALL ( NRQGO2, IRQGO2, IERR_MPI )
!/MPI FLGMPI(1) = .TRUE.
!/MPI NRQMAX = MAX ( NRQMAX , NRQGO2 )
!/MPIT WRITE (NDST,9043) '1b', NRQGO2, NRQMAX, NAPFLD
!/MPI END IF
!/MPI END IF
!
!/MPI IF ( FLOUT(2) .AND. NRQPO.NE.0 ) THEN
!/MPI IF ( DSEC21(TIME,TONEXT(:,2)).EQ.0. ) THEN
!/MPI CALL MPI_STARTALL ( NRQPO, IRQPO1, IERR_MPI )
!/MPI FLGMPI(2) = .TRUE.
!/MPI NRQMAX = MAX ( NRQMAX , NRQPO )
!/MPIT WRITE (NDST,9043) '2 ', NRQPO, NRQMAX, NAPPNT
!/MPI END IF
!/MPI END IF
!
!/MPI IF ( FLOUT(4) .AND. NRQRS.NE.0 ) THEN
!/MPI IF ( DSEC21(TIME,TONEXT(:,4)).EQ.0. ) THEN
!/MPI CALL MPI_STARTALL ( NRQRS, IRQRS , IERR_MPI )
!/MPI FLGMPI(4) = .TRUE.
!/MPI NRQMAX = MAX ( NRQMAX , NRQRS )
!/MPIT WRITE (NDST,9043) '4 ', NRQRS, NRQMAX, NAPRST
!/MPI END IF
!/MPI END IF
!
!/MPI IF ( FLOUT(5) .AND. NRQBP.NE.0 ) THEN
!/MPI IF ( DSEC21(TIME,TONEXT(:,5)).EQ.0. ) THEN
!/MPI CALL MPI_STARTALL ( NRQBP , IRQBP1, IERR_MPI )
!/MPI FLGMPI(5) = .TRUE.
!/MPI NRQMAX = MAX ( NRQMAX , NRQBP )
!/MPIT WRITE (NDST,9043) '5a', NRQBP, NRQMAX, NAPBPT
!/MPI END IF
!/MPI END IF
!
!/MPI IF ( FLOUT(5) .AND. NRQBP2.NE.0 .AND. &
!/MPI IAPROC.EQ.NAPBPT) THEN
!/MPI IF ( DSEC21(TIME,TONEXT(:,5)).EQ.0. ) THEN
!/MPI CALL MPI_STARTALL (NRQBP2,IRQBP2,IERR_MPI)
!/MPI NRQMAX = MAX ( NRQMAX , NRQBP2 )
!/MPIT WRITE (NDST,9043) '5b', NRQBP2, NRQMAX, NAPBPT
!/MPI END IF
!/MPI END IF
!
!/MPI IF ( NRQMAX .NE. 0 ) ALLOCATE &
!/MPI ( STATIO(MPI_STATUS_SIZE,NRQMAX) )
!
! 4.c Reset next output time
!
TOFRST(1) = -1
TOFRST(2) = 0
!
#if defined COAWST_COUPLING && defined MCT_LIB
! jcw bottom of wavemd calling the coupler
!/COAWST IF (ITIME.gt.0) THEN
!/COAWST CALL COAWST_CPL (ITIME)
!/COAWST END IF
#endif
DO J=1, NOTYPE
IF ( FLOUT(J) ) THEN
!
! 4.d Perform output
!
TOUT(:) = TONEXT(:,J)
DTTST = DSEC21 ( TIME, TOUT )
!
IF ( DTTST .EQ. 0. ) THEN
IF ( ( J .EQ. 1 ) .OR. ( J .EQ. 7 ) ) THEN
IF ( IAPROC .EQ. NAPFLD ) THEN
!/MPI IF ( FLGMPI(1) ) CALL MPI_WAITALL &
!/MPI ( NRQGO2, IRQGO2, STATIO, IERR_MPI )
!/MPI FLGMPI(1) = .FALSE.
IF ( J .EQ. 1 ) CALL W3IOGO &
( 'WRITE', NDS(7), ITEST, IMOD )
!/SBS !
!/SBS ! Generate output flag file for fields and SBS coupling.
!/SBS !
!/SBS JJ = LEN_TRIM ( FILEXT )
!/SBS CALL STME21 ( TIME, IDTIME )
!/SBS FOUTNAME = 'Field_done.' // IDTIME(1:4) &
!/SBS // IDTIME(6:7) // IDTIME(9:10) &
!/SBS // IDTIME(12:13) // '.' // FILEXT(1:JJ)
!/SBS OPEN( UNIT=NDSOFLG, FILE=FOUTNAME)
!/SBS CLOSE( NDSOFLG )
END IF
IF ( J .EQ. 7 ) THEN
!/OASIS !
!/OASIS ! Send variables to atmospheric or ocean circulation model
!/OASIS !
!/OASIS IF (OASISED.EQ.1) THEN
!/OASIS IF ( (MOD(ID_OASIS_TIME/DTOUT(7),1.0) .LT. 1.E-7 ) .AND. &
!/OASIS (DSEC21 (TIME00, TIME) .GT. 0.0) ) THEN
!/OASACM CALL SND_FIELDS_TO_ATMOS()
!/OASOCM CALL SND_FIELDS_TO_OCEAN()
!/OASIS ID_OASIS_TIME = DSEC21 ( TIME00 , TIME )
!/OASIS ENDIF
!/OASIS END IF
END IF
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 )
ELSE IF ( J .EQ. 4 ) THEN
CALL W3IORS ('HOT', NDS(6), XXX, ITEST, IMOD )
ELSE IF ( J .EQ. 5 ) THEN
IF ( IAPROC .EQ. NAPBPT ) THEN
!/MPI IF (NRQBP2.NE.0) CALL MPI_WAITALL &
!/MPI ( NRQBP2, IRQBP2,STATIO, IERR_MPI )
CALL W3IOBC ( 'WRITE', NDS(10), &
TIME, TIME, ITEST, IMOD )
END IF
ELSE IF ( J .EQ. 6 ) THEN
CALL W3IOSF ( NDS(13), IMOD )
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'
!/OASIS IF ( (DSEC21(TIME,TIME00).EQ.0) .OR. &
!/OASIS (DSEC21(TIME,TIMEEND).EQ.0) ) OUTID(13:13) = ' '
ELSE
OUTID(2*J-1:2*J-1) = 'L'
END IF
END IF
!
! 4.e Update next output time
!
IF ( FLOUT(J) ) THEN
IF ( TOFRST(1).EQ.-1 ) THEN
TOFRST = TOUT
ELSE
DTTST = DSEC21 ( TOUT , TOFRST )
IF ( DTTST.GT.0.) THEN
TOFRST = TOUT
END IF
END IF
END IF
!
END IF
!
END DO
!
!/MPI IF ( FLGMPI(0) ) CALL MPI_WAITALL &
!/MPI ( NRQGO, IRQGO , STATIO, IERR_MPI )
!/MPI IF ( FLGMPI(2) ) CALL MPI_WAITALL &
!/MPI ( NRQPO, IRQPO1, STATIO, IERR_MPI )
!/MPI IF ( FLGMPI(4) ) CALL MPI_WAITALL &
!/MPI ( NRQRS, IRQRS , STATIO, IERR_MPI )
!/MPI IF ( FLGMPI(5) ) CALL MPI_WAITALL &
!/MPI ( NRQBP, IRQBP1, STATIO, IERR_MPI )
!/MPI IF ( NRQMAX .NE. 0 ) DEALLOCATE ( STATIO )
!
!/T WRITE (NDST,9044)
!
! 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
!
! 5. Update log file ------------------------------------------------ /
!
IF ( IAPROC.EQ.NAPLOG ) THEN
!
CALL STME21 ( TIME , IDTIME )
IF ( FLCUR ) THEN
DTTST = DSEC21 ( TIME , TCN )
IF ( DTTST .EQ. 0. ) IDACT(7:7) = 'X'
END IF
IF ( FLWIND ) THEN
DTTST = DSEC21 ( TIME , TWN )
IF ( DTTST .EQ. 0. ) IDACT(3:3) = 'X'
END IF
IF ( TDN(1) .GT. 0 ) THEN
DTTST = DSEC21 ( TIME , TDN )
IF ( DTTST .EQ. 0. ) IDACT(17:17) = '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
END DO
!
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)
!
IF ( .NOT. FLOMP ) DEALLOCATE ( FIELD )
!
DEALLOCATE(TAUWX, TAUWY)
!
!/PALM DEALLOCATE(vecta,vectb)
!/PALM DEALLOCATE(vectg,vecth,vecti)
!/PALM DEALLOCATE(vectj,vectk,vectl)
!/PALM DEALLOCATE(vectm,vectn,vectp)
!/PALM DEALLOCATE(vectq,vectr,vects)
!/PALM DEALLOCATE(vectwlm)
!/PALM DEALLOCATE(vectt,vectu)
!
RETURN
!
! Formats
!
900 FORMAT (2X,I6,' |',I4,' | ', A19 ,' | ',A,' | ',A,' |')
901 FORMAT (2X,I6,' |',I4,' | ',11X,A8,' | ',A,' | ',A,' |')
902 FORMAT (2X,'--------+------+---------------------+' &
,'-------------------+---------------+')
!
!/IC3 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 :'/ &
' NEW WATER LEVEL BEFORE OLD WATER LEVEL '/)
1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ &
' ILLEGAL CURRENT INTERVAL '/)
1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ &
' ILLEGAL WIND INTERVAL '/)
1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ &
' NEW ICE FIELD BEFORE OLD ICE FIELD '/)
1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ &
' NEW IC1 FIELD BEFORE OLD IC1 FIELD '/)
1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ &
' NEW IC5 FIELD BEFORE OLD IC5 FIELD '/)
1030 FORMAT (/' *** WAVEWATCH III WARING IN W3WAVE :'/ &
' AT LEAST ONE PROCESSOR HAS 0 ACTIVE POINTS', &
' IN GRID',I3)
!/REFRX 1040 FORMAT (/' *** WAVEWATCH III ERROR IN W3WAVE :'/ &
!/REFRX ' EXPERIMENTAL FEATURE !/REFRX NOT FULLY IMPLEMENTED.'/)
!
!/T 9000 FORMAT ( &
!/T '============================================================', &
!/T '===================='/ &
!/T ' TEST W3WAVE : RUN MODEL',I3,' FILEXT [',A, &
!/T '] UP TO ',I8.8,I7.6 / &
!/T '====================', &
!/T '============================================================')
!/T 9010 FORMAT (' TEST W3WAVE : DT INT. =',F12.1,' FLZERO = ',L1)
!/T 9011 FORMAT (' TEST W3WAVE : DT LEV. =',F12.1)
!/T 9012 FORMAT (' TEST W3WAVE : DT CUR. =',F12.1/ &
!/T ' ',F12.1/ &
!/T ' ',F12.1)
!/T 9013 FORMAT (' TEST W3WAVE : DT WIND =',F12.1/ &
!/T ' ',F12.1/ &
!/T ' ',F12.1)
!/T 9014 FORMAT (' TEST W3WAVE : DT ICE =',F12.1)
!/T 9015 FORMAT (' TEST W3WAVE : DT IC1 =',F12.1)
!/T 9016 FORMAT (' TEST W3WAVE : DT IC5 =',F12.1)
!/T 9020 FORMAT (' TEST W3WAVE : IT0, NT, DTG :',2I4,F8.1)
!/T 9021 FORMAT (' TEST W3WAVE : ITIME etc',I6,I4,I10.8,I7.6,1X,2L1, &
!/T 2F6.2,F7.1,F6.2)
!/T 9022 FORMAT (' TEST W3WAVE : SKIP TO 400 IN 3.5')
!/T 9023 FORMAT (' TEST W3WAVE : SKIP TO 380 IN 3.5')
!/T 9030 FORMAT (' TEST W3WAVE : END OF COMPUTATION LOOP')
!/T 9040 FORMAT (' TEST W3WAVE : CHECKING FOR OUTPUT'/ &
!/T ' TOFRST :',I9.8,I7.6/ &
!/T ' TND :',I9.8,I7.6/ &
!/T ' DTTST[1], FLAG_O :',2F8.1,L4)
!/T 9041 FORMAT (' TEST W3WAVE : PERFORMING OUTPUT')
!/T 9042 FORMAT (' TEST W3WAVE : OUTPUT COMPUTATION FLAGS: ',3L2)
!/MPIT 9043 FORMAT (' TEST W3WAVE : TYPE, NRQ, NRQMAX, NA : ',A2,3I6)
!/T 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 :
!
!/ ------------------------------------------------------------------- /
!/S USE W3SERVMD, ONLY: STRACE
!/
USE W3GDATMD, ONLY: NSPEC, NX, NY, NSEA, NSEAL, MAPSF, DMIN
USE W3WDATMD, ONLY: A => VA
!/MPI USE W3ADATMD, ONLY: MPIBUF, BSTAT, IBFLOC, ISPLOC, BISPL, &
!/MPI NSPLOC, NRQSG2, IRQSG2, GSTORE
!/MPI USE W3ODATMD, ONLY: NDST, IAPROC, NAPROC, NOTYPE
!/
IMPLICIT NONE
!
!/MPI INCLUDE "mpif.h"
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
INTEGER, INTENT(IN) :: ISPEC
REAL, INTENT(OUT) :: FIELD(1-NY:NY*(NX+2))
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
!/SHRD INTEGER :: ISEA, IXY
!/MPI INTEGER :: STATUS(MPI_STATUS_SIZE,NSPEC), &
!/MPI IOFF, IERR_MPI, JSEA, ISEA, &
!/MPI IXY, IS0, IB0, NPST, J
!/S INTEGER, SAVE :: IENT
!/MPIT CHARACTER(LEN=15) :: STR(MPIBUF), STRT
!/
!/ ------------------------------------------------------------------- /
!/
!/S CALL STRACE (IENT, 'W3GATH')
!
FIELD = 0.
!
! 1. Shared memory version ------------------------------------------ /
!
!/SHRD DO ISEA=1, NSEA
!/SHRD IXY = MAPSF(ISEA,3)
!/SHRD FIELD(IXY) = A(ISPEC,ISEA)
!/SHRD END DO
!
!/SHRD RETURN
!
! 2. Distributed memory version ( MPI ) ----------------------------- /
! 2.a Update counters
!
!/MPI ISPLOC = ISPLOC + 1
!/MPI IBFLOC = IBFLOC + 1
!/MPI IF ( IBFLOC .GT. MPIBUF ) IBFLOC = 1
!
!/MPIT IF ( ISPLOC .EQ. 1 ) THEN
!/MPIT STR = '--------------+'
!/MPIT WRITE (NDST,9000) STR
!/MPIT END IF
!/MPIT STR = ' |'
!/MPIT STRT = STR(IBFLOC)
!/MPIT STRT(9:9) = 'A'
!
! 2.b Check status of present buffer
! 2.b.1 Scatter (send) still in progress, wait to end
!
!/MPI IF ( BSTAT(IBFLOC) .EQ. 2 ) THEN
!/MPI IOFF = 1 + (BISPL(IBFLOC)-1)*NRQSG2
!/MPI IF ( NRQSG2 .GT. 0 ) CALL &
!/MPI MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), &
!/MPI STATUS, IERR_MPI )
!/MPI BSTAT(IBFLOC) = 0
!/MPIT STRT(13:13) = 'S'
!/MPI END IF
!
! 2.b.2 Gather (recv) not yet posted, post now
!
!/MPI IF ( BSTAT(IBFLOC) .EQ. 0 ) THEN
!/MPI BSTAT(IBFLOC) = 1
!/MPI BISPL(IBFLOC) = ISPLOC
!/MPI IOFF = 1 + (ISPLOC-1)*NRQSG2
!/MPI IF ( NRQSG2 .GT. 0 ) CALL &
!/MPI MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,1), IERR_MPI )
!/MPIT STRT(10:10) = 'g'
!/MPI END IF
!
! 2.c Put local spectral densities in store
!
!/MPI DO JSEA=1, NSEAL
!/MPI GSTORE(IAPROC+(JSEA-1)*NAPROC,IBFLOC) = A(ISPEC,JSEA)
!/MPI END DO
!
! 2.d Wait for remote spectral densities
!
!/MPI IOFF = 1 + (BISPL(IBFLOC)-1)*NRQSG2
!/MPI IF ( NRQSG2 .GT. 0 ) CALL &
!/MPI MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,1), STATUS, IERR_MPI )
!
!/MPIT STRT(11:11) = 'G'
!/MPIT WRITE (STRT(1:7),'(I2,I5)') BSTAT(IBFLOC), ISPLOC
!/MPIT STR(IBFLOC) = STRT
!
! 2.e Convert storage array to field.
!
!/MPI DO ISEA=1, NSEA
!/MPI IXY = MAPSF(ISEA,3)
!/MPI FIELD(IXY) = GSTORE(ISEA,IBFLOC)
!/MPI END DO
!
! 2.f Pre-fetch data in available buffers
!
!/MPI IS0 = ISPLOC
!/MPI IB0 = IBFLOC
!/MPI NPST = 0
!
!/MPI DO J=1, MPIBUF-1
!/MPI IS0 = IS0 + 1
!/MPI IF ( IS0 .GT. NSPLOC ) EXIT
!/MPI IB0 = 1 + MOD(IB0,MPIBUF)
!/MPI IF ( BSTAT(IB0) .EQ. 0 ) THEN
!/MPI BSTAT(IB0) = 1
!/MPI BISPL(IB0) = IS0
!/MPI IOFF = 1 + (IS0-1)*NRQSG2
!/MPI IF ( NRQSG2 .GT. 0 ) CALL &
!/MPI MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,1), IERR_MPI )
!/MPI NPST = NPST + 1
!/MPIT STRT = STR(IB0)
!/MPIT STRT(10:10) = 'g'
!/MPIT WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0)
!/MPIT STR(IB0) = STRT
!/MPI END IF
!/MPI IF ( NPST .GE. 2 ) EXIT
!/MPI END DO
!
! 2.g Test output
!
!/MPIT DO IB0=1, MPIBUF
!/MPIT STRT = STR(IB0)
!/MPIT IF ( STRT(2:2) .EQ. ' ' ) THEN
!/MPIT IF ( BSTAT(IB0) .EQ. 0 ) THEN
!/MPIT WRITE (STRT(1:2),'(I2)') BSTAT(IB0)
!/MPIT ELSE
!/MPIT WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0)
!/MPIT END IF
!/MPIT STR(IB0) = STRT
!/MPIT END IF
!/MPIT END DO
!/MPIT WRITE (NDST,9010) ISPLOC, STR
!
!/MPI RETURN
!
! Formats
!
!/MPIT 9000 FORMAT ( ' TEST OF BUFFER MANAGEMENT MPI :'/ &
!/MPIT ' -------------------------------'/ &
!/MPIT ' RECORDS ALTERNATELY WRITTEN BY W3GATH AND W3SCAT'/ &
!/MPIT ' FRIST COLLUMN : LOCAL ISPEC'/ &
!/MPIT ' OTHER COLLUMNS : BUFFER STATUS INDICATOR '/ &
!/MPIT ' 0 : INACTIVE'/ &
!/MPIT ' 1 : RECEIVING'/ &
!/MPIT ' 2 : SENDING'/ &
!/MPIT ' LOCAL ISPEC FOR BUFFER'/ &
!/MPIT ' A : ACTIVE BUFFER'/ &
!/MPIT ' g/G: START/FINISH RECIEVE'/ &
!/MPIT ' s/S: START/FINISH SEND'/ &
!/MPIT ' +-----+',8A15)
!/MPIT 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 :
!
!/ ------------------------------------------------------------------- /
!/S USE W3SERVMD, ONLY: STRACE
!/
USE W3GDATMD, ONLY: NSPEC, NX, NY, NSEA, NSEAL, MAPSF
USE W3WDATMD, ONLY: A => VA
!/MPI USE W3ADATMD, ONLY: MPIBUF, BSTAT, IBFLOC, ISPLOC, BISPL, &
!/MPI NSPLOC, NRQSG2, IRQSG2, SSTORE
USE W3ODATMD, ONLY: NDST
!/MPI USE W3ODATMD, ONLY: IAPROC, NAPROC
!/
IMPLICIT NONE
!
!/MPI INCLUDE "mpif.h"
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
INTEGER, INTENT(IN) :: ISPEC, MAPSTA(NY*NX)
REAL, INTENT(IN) :: FIELD(1-NY:NY*(NX+2))
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
!/SHRD INTEGER :: ISEA, IXY
!/MPI INTEGER :: ISEA, IXY, IOFF, IERR_MPI, J, &
!/MPI STATUS(MPI_STATUS_SIZE,NSPEC), &
!/MPI JSEA, IB0
!/S INTEGER, SAVE :: IENT
!/MPIT CHARACTER(LEN=15) :: STR(MPIBUF), STRT
!/MPI LOGICAL :: DONE
!/
!/ ------------------------------------------------------------------- /
!/
!/S CALL STRACE (IENT, 'W3SCAT')
!
! 1. Shared memory version ------------------------------------------ *
!
!/SHRD DO ISEA=1, NSEA
!/SHRD IXY = MAPSF(ISEA,3)
!/SHRD IF ( MAPSTA(IXY) .GE. 1 ) A(ISPEC,ISEA) = FIELD(IXY)
!/SHRD END DO
!
!/SHRD RETURN
!
! 2. Distributed memory version ( MPI ) ----------------------------- *
! 2.a Initializations
!
!/MPIT DO IB0=1, MPIBUF
!/MPIT STR(IB0) = ' |'
!/MPIT END DO
!
!/MPIT STRT = STR(IBFLOC)
!/MPIT STRT(9:9) = 'A'
!
! 2.b Convert full grid to sea grid, active points only
!
!/MPI DO ISEA=1, NSEA
!/MPI IXY = MAPSF(ISEA,3)
!/MPI IF ( MAPSTA(IXY) .GE. 1 ) SSTORE(ISEA,IBFLOC) = FIELD(IXY)
!/MPI END DO
!
! 2.c Send spectral densities to appropriate remote
!
!/MPI IOFF = 1 + (ISPLOC-1)*NRQSG2
!/MPI IF ( NRQSG2 .GT. 0 ) CALL &
!/MPI MPI_STARTALL ( NRQSG2, IRQSG2(IOFF,2), IERR_MPI )
!/MPI BSTAT(IBFLOC) = 2
!/MPIT STRT(12:12) = 's'
!/MPIT WRITE (STRT(1:7),'(I2,I5)') BSTAT(IBFLOC), ISPLOC
!/MPIT STR(IBFLOC) = STRT
!
! 2.d Save locally stored results
!
!/MPI DO JSEA=1, NSEAL
!/MPI ISEA = IAPROC+(JSEA-1)*NAPROC
!/MPI IXY = MAPSF(ISEA,3)
!/MPI IF (MAPSTA(IXY) .GE. 1) A(ISPEC,JSEA) = SSTORE(ISEA,IBFLOC)
!/MPI END DO
!
! 2.e Check if any sends have finished
!
!/MPI IB0 = IBFLOC
!
!/MPI DO J=1, MPIBUF
!/MPI IB0 = 1 + MOD(IB0,MPIBUF)
!/MPI IF ( BSTAT(IB0) .EQ. 2 ) THEN
!/MPI IOFF = 1 + (BISPL(IB0)-1)*NRQSG2
!/MPI IF ( NRQSG2 .GT. 0 ) THEN
!/MPI CALL MPI_TESTALL ( NRQSG2, IRQSG2(IOFF,2), DONE, &
!/MPI STATUS, IERR_MPI )
!/MPI ELSE
!/MPI DONE = .TRUE.
!/MPI END IF
!/MPI IF ( DONE .AND. NRQSG2.GT.0 ) CALL &
!/MPI MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), &
!/MPI STATUS, IERR_MPI )
!/MPI IF ( DONE ) THEN
!/MPI BSTAT(IB0) = 0
!/MPIT STRT = STR(IB0)
!/MPIT WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0)
!/MPIT STRT(13:13) = 'S'
!/MPIT STR(IB0) = STRT
!/MPI END IF
!/MPI END IF
!/MPI END DO
!
! 2.f Last component, finish message passing, reset buffer control
!
!/MPI IF ( ISPLOC .EQ. NSPLOC ) THEN
!
!/MPI DO IB0=1, MPIBUF
!/MPI IF ( BSTAT(IB0) .EQ. 2 ) THEN
!/MPI IOFF = 1 + (BISPL(IB0)-1)*NRQSG2
!/MPI IF ( NRQSG2 .GT. 0 ) CALL &
!/MPI MPI_WAITALL ( NRQSG2, IRQSG2(IOFF,2), &
!/MPI STATUS, IERR_MPI )
!/MPI BSTAT(IB0) = 0
!/MPIT STRT = STR(IB0)
!/MPIT WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0)
!/MPIT STRT(13:13) = 'S'
!/MPIT STR(IB0) = STRT
!/MPI END IF
!/MPI END DO
!
!/MPI ISPLOC = 0
!/MPI IBFLOC = 0
!
!/MPI END IF
!
! 2.g Test output
!
!/MPIT DO IB0=1, MPIBUF
!/MPIT STRT = STR(IB0)
!/MPIT IF ( STRT(2:2) .EQ. ' ' ) THEN
!/MPIT IF ( BSTAT(IB0) .EQ. 0 ) THEN
!/MPIT WRITE (STRT(1:2),'(I2)') BSTAT(IB0)
!/MPIT ELSE
!/MPIT WRITE (STRT(1:7),'(I2,I5)') BSTAT(IB0), BISPL(IB0)
!/MPIT END IF
!/MPIT STR(IB0) = STRT
!/MPIT END IF
!/MPIT END DO
!
!/MPIT WRITE (NDST,9000) STR
!
!/MPIT IF ( ISPLOC .EQ. 0 ) THEN
!/MPIT DO IB0=1, MPIBUF
!/MPIT STR(IB0) = '--------------+'
!/MPIT END DO
!/MPIT WRITE (NDST,9010) STR
!/MPIT WRITE (NDST,*)
!/MPIT END IF
!
!/MPI RETURN
!
! Formats
!
!/MPIT 9000 FORMAT ( ' | |',8A15)
!/MPIT 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 :
!
!/ ------------------------------------------------------------------- /
!/S USE W3SERVMD, ONLY: STRACE
!/
USE W3GDATMD, ONLY: NX, NY, NSEA, MAPSF
USE W3ODATMD, ONLY: NDST, NAPROC
!/
IMPLICIT NONE
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
INTEGER, INTENT(IN) :: MAPSTA(NY*NX)
LOGICAL, INTENT(OUT) :: FLAG0
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
INTEGER :: NMIN, IPROC, NLOC, ISEA, IXY
!/S INTEGER, SAVE :: IENT
!/
!/ ------------------------------------------------------------------- /
!/
!/S CALL STRACE (IENT, 'W3NMIN')
!
NMIN = NSEA
!
DO IPROC=1, NAPROC
NLOC = 0
DO ISEA=IPROC, NSEA, NAPROC
IXY = MAPSF(ISEA,3)
IF ( MAPSTA(IXY) .EQ. 1 ) NLOC = NLOC + 1
END DO
!/SMC !!Li For SMC grid, local sea points are equally NSEA/NAPROC
!/SMC !!Li so the NLOC is overwirte by a constant.
!/SMC NLOC = NSEA/NAPROC
!
!/T WRITE (NDST,9000) IPROC, NLOC
NMIN = MIN ( NMIN , NLOC )
END DO
!
FLAG0 = NMIN .EQ. 0
!/T WRITE (NDST,9001) NMIN, FLAG0
!
RETURN
!
! Formats
!
!/T 9000 FORMAT ( ' TEST W3NMIN : IPROC =',I3,' NLOC =',I5)
!/T 9001 FORMAT ( ' TEST W3NMIN : NMIN =',I5,' FLAG0 =',L2)
!/
!/ End of W3NMIN ----------------------------------------------------- /
!/
END SUBROUTINE W3NMIN
!/
!/ End of module W3WAVEMD -------------------------------------------- /
!/
END MODULE W3WAVEMD