#include "swancpp.h"
!
! SWAN/SWREAD file 2 of 2
!
! Contents of this file:
! SPROUT: Reading and processing of the user output commands
! SWREPS: Reading and processing of the commands defining output points
! SWREOQ: Reading and processing of the output requests
! SIRAY : Searching the first point on a ray where the depth is DP
! SWNMPS
! SVARTP
! SWBOUN 40.00
! BCFILE 40.00
! BCWAMN 40.00
! BCWW3N
! SWBCPT
! RETSTP 40.00
!
!***********************************************************************
! *
#ifdef SWAN_MODEL
SUBROUTINE SPROUT (FOUND, BOTLEV, WATLEV, ng)
#else
SUBROUTINE SPROUT (FOUND, BOTLEV, WATLEV) 40.31
#endif
! *
!***********************************************************************
!
USE OCPCOMM4 40.41
USE SWCOMM3 40.41
!
!
! --|-----------------------------------------------------------|--
! | Delft University of Technology |
! | Faculty of Civil Engineering |
! | Environmental Fluid Mechanics Section |
! | P.O. Box 5048, 2600 GA Delft, The Netherlands |
! | |
! | Programmers: The SWAN team |
! --|-----------------------------------------------------------|--
!
!
! SWAN (Simulating WAves Nearshore); a third generation wave model
! Copyright (C) 1993-2017 Delft University of Technology
!
! This program is free software; you can redistribute it and/or
! modify it under the terms of the GNU General Public License as
! published by the Free Software Foundation; either version 2 of
! the License, or (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! A copy of the GNU General Public License is available at
! http://www.gnu.org/copyleft/gpl.html#SEC3
! or by writing to the Free Software Foundation, Inc.,
! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
!
!
! 0. Authors
!
! 30.70: Nico Booij
! 30.72: IJsbrand Haagsma
! 30.81: Annette Kieftenburg
! 30.82: IJsbrand Haagsma
! 30.90: IJsbrand Haagsma (Equivalence version)
! 32.02: Roeland Ris & Cor van der Schelde (1D version)
! 34.01: Jeroen Adema
! 40.02: IJsbrand Haagsma
! 40.03: Nico Booij
! 40.31: Marcel Zijlema
! 40.41: Marcel Zijlema
!
! 1. Updates
!
! 100.04, Nov. 92: Filename of plotfile will be given by user
! 30.70, Nov. 97: Arguments BOTLEV and WATLEV added
! 32.02, Feb. 98: 1D version introduced
! 30.72, Feb. 98: Introduced generic names XCGRID, YCGRID and SPCSIG for SWAN
! 30.82, Apr. 98: Removed reference to commons KAART and KAR
! 30.90, Oct. 98: Introduced EQUIVALENCE POOL-arrays
! 30.81, Nov. 98: Replaced variable STATUS by IERR (because STATUS is a
! reserved word)
! 30.81, Jan. 99: Replaced variable FROM by FROM_ (because FROM is a
! reserved word)
! 34.01, Feb. 99: Introducing STPNOW
! 40.03, Sep. 00: inconsistency with manual corrected
! 40.02, Oct. 00: Initialisation of IERR
! 40.31, Nov. 03: removing POOL construction and HPGL functionality
! 40.41, Oct. 04: common blocks replaced by modules, include files removed
!
! 2. Purpose
!
! Reading and processing of the user output commands
!
! 3. Method
!
! If the first characters of the last read command are equal to a
! given string (KEYWIS ('STRING')), the keywords and varia-
! bles of this command are further read and processed
!
! 4. Argument variables
!
! i BOTLEV: Bottom levels 30.70
! i WATLEV: Water levels 30.70
!
#ifdef SWAN_MODEL
INTEGER, INTENT(IN) :: ng
#endif
REAL BOTLEV(*) 30.70
REAL WATLEV(*) 30.70
!
! 6. Local variables
!
! 8. Subroutines used
!
! MSGERR
! SWREPS
! SWREOQ
! STPNOW
!
LOGICAL STPNOW 34.01
!
! 9. Subroutines calling
!
! SWREAD
!
! 10. Error messages
!
! ---
!
! 11. Remarks
!
! ---
!
! 12. Structure
!
! ----------------------------------------------------------------
! Most of the source code will be clear with the
! aid of the user manual, the system documentation
! and the additional comments in the source code.
! ----------------------------------------------------------------
!
! 13. Source text
!
LOGICAL FOUND
LOGICAL KEYWIS
SAVE IENT
DATA IENT/0/ 40.31 30.81
CALL STRACE (IENT,'SPROUT')
!
FOUND = .FALSE.
!
! definition of output point sets
!
#ifdef SWAN_MODEL
CALL SWREPS ( FOUND, BOTLEV, WATLEV, ng)
#else
CALL SWREPS ( FOUND, BOTLEV, WATLEV ) 40.31
#endif
IF (STPNOW()) RETURN 34.01
IF (FOUND) RETURN
!
! output requests
!
#ifdef SWAN_MODEL
CALL SWREOQ ( FOUND, ng)
#else
CALL SWREOQ ( FOUND ) 40.31 30.90
#endif
IF (STPNOW()) RETURN 34.01
IF (FOUND) RETURN
!
IF (KEYWIS('SIT') .OR. KEYWIS('PLA')) THEN
CALL MSGERR(2,'Keyword SITES is no longer maintained') 40.31
GOTO 800 40.31
ENDIF
!
IF (KEYWIS ('LIN')) THEN
CALL MSGERR(2,'Keyword LINE is no longer maintained') 40.31
GOTO 800 40.31
ENDIF
! -------------------------------------------------------------------
! ***** command name not found *****
RETURN
!
800 FOUND = .TRUE.
RETURN
! * end of subroutine SPROUT *
END
!***********************************************************************
! *
#ifdef SWAN_MODEL
SUBROUTINE SWREPS ( FOUND, BOTLEV, WATLEV, ng)
#else
SUBROUTINE SWREPS ( FOUND, BOTLEV, WATLEV ) 40.31
#endif
! *
!***********************************************************************
!
USE OCPCOMM1 40.41
USE OCPCOMM3 40.41
USE OCPCOMM4 40.41
USE SWCOMM2 40.41
USE SWCOMM3 40.41
USE SWCOMM4 40.41
USE OUTP_DATA 40.31
USE M_PARALL 40.31
USE SwanGriddata 40.80
!
!
! --|-----------------------------------------------------------|--
! | Delft University of Technology |
! | Faculty of Civil Engineering |
! | Environmental Fluid Mechanics Section |
! | P.O. Box 5048, 2600 GA Delft, The Netherlands |
! | |
! | Programmers: The SWAN team |
! --|-----------------------------------------------------------|--
!
!
! SWAN (Simulating WAves Nearshore); a third generation wave model
! Copyright (C) 1993-2017 Delft University of Technology
!
! This program is free software; you can redistribute it and/or
! modify it under the terms of the GNU General Public License as
! published by the Free Software Foundation; either version 2 of
! the License, or (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! A copy of the GNU General Public License is available at
! http://www.gnu.org/copyleft/gpl.html#SEC3
! or by writing to the Free Software Foundation, Inc.,
! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
!
!
! 0. Authors
!
! 30.70, 40.03, 40.13: Nico Booij
! 30.72: IJsbrand Haagsma
! 30.81: Annette Kieftenburg
! 30.82: IJsbrand Haagsma
! 32.02: Roeland Ris & Cor van der Schelde (1D version)
! 34.01: Jeroen Adema
! 40.30: Marcel Zijlema
! 40.31: Marcel Zijlema
! 40.41: Marcel Zijlema
! 40.80: Marcel Zijlema
!
! 1. Updates
!
! 30.72, Sept 97: Changed DO-block with one CONTINUE to DO-block with
! two CONTINUE's
! 30.70, Nov. 97: comm ISO, inquire pointer added to get correct value
! for IADRAY
! 30.70, Nov. 97: comm ISO, offset origin added in message concerning rays
! declaration INT SIRAY added
! 30.70, Nov. 97: arguments BOTLEV and WATLEV added
! 30.72, Feb. 98: Declaration of Argument variables updated
! 32.02, Feb. 98: 1D version introduced
! 30.72, Feb. 98: Introduced generic names XCGRID, YCGRID and SPCSIG for SWAN
! 30.82, Apr. 98: removed reference to commons KAART and KAR
! 30.81, Nov. 98: Replaced variable STATUS by IERR (because STATUS is a
! reserved word)
! 34.01, Feb. 99: Introducing STPNOW
! 40.01, Sep. 99: XASM and YASM replace fixed numbers
! 33.09, Sep. 00: modifications in view of spherical coordinates
! 40.03, Sep. 00: inconsistency with manual corrected
! 40.13, Sep. 01: nesting in curvilinear grid: division by 0 prevented
! 40.30, May 03: introduction distributed-memory approach using MPI
! 40.31, Dec. 03: removing POOL-mechanism
! 40.41, Oct. 04: common blocks replaced by modules, include files removed
! 40.80, Mar. 08: extension to unstructured grids
!
! 2. PURPOSE
!
! Reading and processing of the commands defining output points
!
! 4. Argument variables (updated 30.72)
!
! BOTLEV: input bottom levels 30.70
! WATLEV: input water levels 30.70
!
#ifdef SWAN_MODEL
INTEGER, INTENT(IN) :: ng
#endif
REAL BOTLEV(*), WATLEV(*) 30.70
!
! FOUND : output parameter indicating whether command
! being processed is found (value True)
! or not (False)
!
LOGICAL FOUND
!
! Local variables
REAL :: XPFR, YPFR, XLENFR, YLENFR 40.31
#if defined SWAN_MODEL
TYPE(OPSDAT), POINTER :: ROPS
#else
TYPE(OPSDAT), POINTER :: OPSTMP, ROPS 40.31
#endif
TYPE XYPT 40.31
REAL :: X, Y, XQ, YQ
TYPE(XYPT), POINTER :: NEXTXY
END TYPE XYPT
TYPE(XYPT), TARGET :: FRST 40.31
TYPE(XYPT), POINTER :: CURR, TMP 40.31
INTEGER, ALLOCATABLE :: VM(:) 40.80
REAL, ALLOCATABLE :: XG(:), YG(:) 40.80
CHARACTER (LEN=80) :: BASENM 40.80
! 8. Subroutines used
!
! command reading routines
! (all Ocean Pack)
LOGICAL :: STPNOW 34.01
LOGICAL :: EQREAL ! if True the two (real) arguments are equal 33.09
! 9. Subroutines calling
!
! SPROUT
!
! 10. Error messages
!
! ---
!
! 13. Source text
!
LOGICAL PP 30.72
INTEGER IERR, SIRAY 30.81 30.72
CHARACTER PSNAME*16, STYPE*1, PRNAME*16 40.31 30.21
LOGICAL KEYWIS, BOTDEP 30.70
SAVE IENT
DATA IENT/0/
CALL STRACE (IENT,'SWREPS')
!
! --------------------------------------------------------------------
! FRAME 'sname' [xpfr] [ypfr] [alpfr] [xlenfr] [ylenfr] &
! [mxfr] [myfr]
! --------------------------------------------------------------------
!
IF (KEYWIS ('FRA')) THEN
!
IF (ONED) THEN 32.02
CALL MSGERR (2,' Illegal keyword (FRA) in combination with'// 32.02
& ' 1D-computation') 32.02
GOTO 800 32.02
ELSE 32.02
! ver 30.20: names of input variables changed, order of data changed
#ifdef SWAN_MODEL
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP) 40.31
! ALLOCATE(OPSDATZ_MOD(ng)%COPS)
! ALLOCATE(OPSDATZ_MOD(ng)%FOPS)
CALL INCSTR ('SNAME',PSNAME,'REQ',' ')
IF (LENCST.GT.8) CALL MSGERR (2, 'SNAME is too long')
OPSDATZ_MOD(ng)%OPSTMP%PSNAME = PSNAME 40.31
CALL READXY ('XPFR', 'YPFR', XPFR, YPFR, 'REQ', 0., 0.) 40.31 30.20
OPSDATZ_MOD(ng)%OPSTMP%OPR(1) = XPFR 40.31
OPSDATZ_MOD(ng)%OPSTMP%OPR(2) = YPFR 40.31
CALL INREAL('ALPFR',ALPK,'REQ',0.) 30.20
IF (KSPHER.GT.0 .AND. .NOT.EQREAL(ALPK,0.)) CALL MSGERR (2,
& '[alpfr] must be 0 with spherical coordinates') 33.09
CALL INREAL('XLENFR', XLENFR,'REQ',0.) 40.31 30.20
CALL INREAL('YLENFR', YLENFR,'REQ',0.) 40.31 30.20
OPSDATZ_MOD(ng)%OPSTMP%OPR(3)=XLENFR 40.31
OPSDATZ_MOD(ng)%OPSTMP%OPR(4)=YLENFR 40.31
OPSDATZ_MOD(ng)%OPSTMP%OPR(5)=PI2*(ALPK/360.-NINT(ALPK/360.))
! ***** the user gives number of meshes along each side *****
! ***** program uses the number of points *****
CALL ININTG ('MXFR',MXK,'STA',20) 30.20
CALL ININTG ('MYFR',MYK,'STA',20) 30.20
OPSDATZ_MOD(ng)%OPSTMP%PSTYPE = 'F' 40.31
OPSDATZ_MOD(ng)%OPSTMP%OPI(1) = MXK+1 40.31
OPSDATZ_MOD(ng)%OPSTMP%OPI(2) = MYK+1 40.31
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP%XP(0)) 40.31
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP%YP(0)) 40.31
NULLIFY(OPSDATZ_MOD(ng)%OPSTMP%NEXTOPS) 40.31
IF ( .NOT.LOPS ) THEN 40.31
OPSDATZ_MOD(ng)%FOPS = OPSDATZ_MOD(ng)%OPSTMP 40.31
OPSDATZ_MOD(ng)%COPS => OPSDATZ_MOD(ng)%FOPS 40.31
LOPS = .TRUE. 40.31
ELSE 40.31
OPSDATZ_MOD(ng)%COPS%NEXTOPS => OPSDATZ_MOD(ng)%OPSTMP 40.31
OPSDATZ_MOD(ng)%COPS => OPSDATZ_MOD(ng)%OPSTMP 40.31
END IF 40.31
GOTO 800
#else
ALLOCATE(OPSTMP) 40.31
CALL INCSTR ('SNAME',PSNAME,'REQ',' ')
IF (LENCST.GT.8) CALL MSGERR (2, 'SNAME is too long')
OPSTMP%PSNAME = PSNAME 40.31
CALL READXY ('XPFR', 'YPFR', XPFR, YPFR, 'REQ', 0., 0.) 40.31 30.20
OPSTMP%OPR(1) = XPFR 40.31
OPSTMP%OPR(2) = YPFR 40.31
CALL INREAL('ALPFR',ALPK,'REQ',0.) 30.20
IF (KSPHER.GT.0 .AND. .NOT.EQREAL(ALPK,0.)) CALL MSGERR (2,
& '[alpfr] must be 0 with spherical coordinates') 33.09
CALL INREAL('XLENFR', XLENFR,'REQ',0.) 40.31 30.20
CALL INREAL('YLENFR', YLENFR,'REQ',0.) 40.31 30.20
OPSTMP%OPR(3) = XLENFR 40.31
OPSTMP%OPR(4) = YLENFR 40.31
OPSTMP%OPR(5) = PI2 * (ALPK/360.-NINT(ALPK/360.))
! ***** the user gives number of meshes along each side *****
! ***** program uses the number of points *****
CALL ININTG ('MXFR',MXK,'STA',20) 30.20
CALL ININTG ('MYFR',MYK,'STA',20) 30.20
OPSTMP%PSTYPE = 'F' 40.31
OPSTMP%OPI(1) = MXK+1 40.31
OPSTMP%OPI(2) = MYK+1 40.31
ALLOCATE(OPSTMP%XP(0)) 40.31
ALLOCATE(OPSTMP%YP(0)) 40.31
NULLIFY(OPSTMP%NEXTOPS) 40.31
IF ( .NOT.LOPS ) THEN 40.31
FOPS = OPSTMP 40.31
COPS => FOPS 40.31
LOPS = .TRUE. 40.31
ELSE 40.31
COPS%NEXTOPS => OPSTMP 40.31
COPS => OPSTMP 40.31
END IF 40.31
GOTO 800
#endif
ENDIF 32.02
ENDIF
!
! ------------------------------------------------------------------
! GROUP 'sname' SUBGRID [ix1] [ix2] [iy1] [iy2]
! ------------------------------------------------------------------
!
IF (KEYWIS('GROUP') .OR. KEYWIS ('SUBG')) THEN 970221
!
IF (ONED) THEN 32.02
CALL MSGERR (2,' Illegal keyword (GROUP) in combination'// 32.02
& ' with 1D-computation') 32.02
GOTO 800 32.02
ELSEIF (OPTG.EQ.5) THEN 40.80
CALL MSGERR(2,
& ' Keyword GROUP not supported in unstructured grid') 40.80
GOTO 800 40.80
ELSE 32.02
! mod 970221: GROUP is introduced as a new command instead of
! an option SUBG within the Frame command
#ifdef SWAN_MODEL
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP) 40.31
CALL INCSTR ('SNAME',PSNAME,'REQ',' ')
IF (LENCST.GT.8) CALL MSGERR (2, 'SNAME is too long')
OPSDATZ_MOD(ng)%OPSTMP%PSNAME = PSNAME 40.31
#else
ALLOCATE(OPSTMP) 40.31
CALL INCSTR ('SNAME',PSNAME,'REQ',' ')
IF (LENCST.GT.8) CALL MSGERR (2, 'SNAME is too long')
OPSTMP%PSNAME = PSNAME 40.31
#endif
CALL INKEYW ('STA', ' ')
CALL IGNORE ('SUBG') 970221
CALL ININTG ('IX1', IX1, 'REQ', 0)
CALL ININTG ('IX2', IX2, 'REQ', 0)
CALL ININTG ('IY1', IY1, 'REQ', 0)
CALL ININTG ('IY2', IY2, 'REQ', 0)
IF (IX1 .LT. 0 .OR. IX2 .GT. MXCGL-1 .OR. IX1 .GT. IX2 .OR.
& IY1 .LT. 0 .OR. IY2 .GT. MYCGL-1 .OR. IY1 .GT. IY2) THEN
CALL MSGERR (3, 'Check corners of GROUP (SUBGRID) command')
CALL MSGERR (3, ' .........the values should be.........')
CALL MSGERR (3, 'ix1<ix2 and both between 0 and MXC')
CALL MSGERR (3, 'iy1<iy2 and both between 0 and MYC')
ENDIF
!
IF (OPTG .EQ. 3) THEN
! *** If the comput grid is curvilinear then the next ***
! *** quantities are stored : 'H' ,FLOAT(IX2), FLOAT(IY2)***
! *** FLOAT(IX1) ,FLOAT(IY1) , 0 ,MXK+1 ,MYK+1 ***
! *** Here frame type H is introduce, means that regular***
! *** frame is required from a curvilinear compt. grid ***
#ifdef SWAN_MODEL
OPSDATZ_MOD(ng)%OPSTMP%PSTYPE = 'H' 40.31
MXK = IX2-IX1
MYK = IY2-IY1
OPSDATZ_MOD(ng)%OPSTMP%OPR(1) = FLOAT(IX2) 40.31
OPSDATZ_MOD(ng)%OPSTMP%OPR(2) = FLOAT(IY2) 40.31
OPSDATZ_MOD(ng)%OPSTMP%OPR(3) = FLOAT(IX1) 40.31
OPSDATZ_MOD(ng)%OPSTMP%OPR(4) = FLOAT(IY1) 40.31
OPSDATZ_MOD(ng)%OPSTMP%OPR(5) = 0. 40.31
OPSDATZ_MOD(ng)%OPSTMP%OPI(1) = MXK+1 40.31
OPSDATZ_MOD(ng)%OPSTMP%OPI(2) = MYK+1 40.31
ELSE IF (OPTG .EQ. 1) THEN
OPSDATZ_MOD(ng)%OPSTMP%PSTYPE = 'F' 40.31
IF (IX1.NE.IX2) THEN
OPSDATZ_MOD(ng)%OPSTMP%OPR(3) = (IX2-IX1)*DX 40.31
ELSE
OPSDATZ_MOD(ng)%OPSTMP%OPR(3) = 0.01 40.31
ENDIF
IF (IY1.NE.IY2) THEN
OPSDATZ_MOD(ng)%OPSTMP%OPR(4) = (IY2-IY1)*DY 40.31
ELSE
OPSDATZ_MOD(ng)%OPSTMP%OPR(4) = 0.01 40.31
ENDIF
OPSDATZ_MOD(ng)%OPSTMP%OPR(1) = XPC + IX1*DX*COSPC - &
& IY1*DY*SINPC 40.31
OPSDATZ_MOD(ng)%OPSTMP%OPR(2) = YPC + IX1*DX*SINPC + &
& IY1*DY*COSPC 40.31
OPSDATZ_MOD(ng)%OPSTMP%OPR(5) = ALPC 40.31
MXK = IX2-IX1
MYK = IY2-IY1
OPSDATZ_MOD(ng)%OPSTMP%OPI(1) = MXK+1 40.31
OPSDATZ_MOD(ng)%OPSTMP%OPI(2) = MYK+1 40.31
IF (ITEST .GE. 20 .OR. INTES .GE. 10) &
& WRITE (PRINTF, 6020) (OPSDATZ_MOD(ng)%OPSTMP%OPR(II), &
& II=2,6) 40.31
6020 FORMAT (' Subgrid parms.', 6(1X,E12.4))
ENDIF
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP%XP(0)) 40.31
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP%YP(0)) 40.31
NULLIFY(OPSDATZ_MOD(ng)%OPSTMP%NEXTOPS) 40.31
IF ( .NOT.LOPS ) THEN 40.31
OPSDATZ_MOD(ng)%FOPS = OPSDATZ_MOD(ng)%OPSTMP 40.31
OPSDATZ_MOD(ng)%COPS => OPSDATZ_MOD(ng)%FOPS 40.31
LOPS = .TRUE. 40.31
ELSE 40.31
OPSDATZ_MOD(ng)%COPS%NEXTOPS => OPSDATZ_MOD(ng)%OPSTMP 40.31
OPSDATZ_MOD(ng)%COPS => OPSDATZ_MOD(ng)%OPSTMP 40.31
END IF 40.31
#else
OPSTMP%PSTYPE = 'H' 40.31
MXK = IX2-IX1
MYK = IY2-IY1
OPSTMP%OPR(1) = FLOAT(IX2) 40.31
OPSTMP%OPR(2) = FLOAT(IY2) 40.31
OPSTMP%OPR(3) = FLOAT(IX1) 40.31
OPSTMP%OPR(4) = FLOAT(IY1) 40.31
OPSTMP%OPR(5) = 0. 40.31
OPSTMP%OPI(1) = MXK+1 40.31
OPSTMP%OPI(2) = MYK+1 40.31
ELSE IF (OPTG .EQ. 1) THEN
OPSTMP%PSTYPE = 'F' 40.31
IF (IX1.NE.IX2) THEN
OPSTMP%OPR(3) = (IX2-IX1)*DX 40.31
ELSE
OPSTMP%OPR(3) = 0.01 40.31
ENDIF
IF (IY1.NE.IY2) THEN
OPSTMP%OPR(4) = (IY2-IY1)*DY 40.31
ELSE
OPSTMP%OPR(4) = 0.01 40.31
ENDIF
OPSTMP%OPR(1) = XPC + IX1*DX*COSPC - IY1*DY*SINPC 40.31
OPSTMP%OPR(2) = YPC + IX1*DX*SINPC + IY1*DY*COSPC 40.31
OPSTMP%OPR(5) = ALPC 40.31
MXK = IX2-IX1
MYK = IY2-IY1
OPSTMP%OPI(1) = MXK+1 40.31
OPSTMP%OPI(2) = MYK+1 40.31
IF (ITEST .GE. 20 .OR. INTES .GE. 10)
& WRITE (PRINTF, 6020) (OPSTMP%OPR(II), II=2,6) 40.31
6020 FORMAT (' Subgrid parms.', 6(1X,E12.4))
ENDIF
ALLOCATE(OPSTMP%XP(0)) 40.31
ALLOCATE(OPSTMP%YP(0)) 40.31
NULLIFY(OPSTMP%NEXTOPS) 40.31
IF ( .NOT.LOPS ) THEN 40.31
FOPS = OPSTMP 40.31
COPS => FOPS 40.31
LOPS = .TRUE. 40.31
ELSE 40.31
COPS%NEXTOPS => OPSTMP 40.31
COPS => OPSTMP 40.31
END IF 40.31
#endif
GOTO 800
ENDIF 32.01
ENDIF
!
! ------------------------------------------------------------------
! CURVE 'sname' [xp1] [yp1] < [int] [xp] [yp] >
! ------------------------------------------------------------------
!
IF (KEYWIS ('CURV')) THEN
#ifdef SWAN_MODEL
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP) 40.31
CALL INCSTR('SNAME',PSNAME,'REQ',' ')
IF (LENCST.GT.8) CALL MSGERR (2, 'SNAME is too long')
OPSDATZ_MOD(ng)%OPSTMP%PSNAME = PSNAME 40.31
OPSDATZ_MOD(ng)%OPSTMP%PSTYPE = 'C' 40.31
MIP = 0
OPSDATZ_MOD(ng)%OPSTMP%MIP = MIP 40.31
#else
ALLOCATE(OPSTMP) 40.31
CALL INCSTR('SNAME',PSNAME,'REQ',' ')
IF (LENCST.GT.8) CALL MSGERR (2, 'SNAME is too long')
OPSTMP%PSNAME = PSNAME 40.31
OPSTMP%PSTYPE = 'C' 40.31
MIP = 0
OPSTMP%MIP = MIP 40.31
#endif
! ***** first point of a curve *****
30 CALL NWLINE
IF (STPNOW()) RETURN 34.01
CALL READXY ('XP1', 'YP1', XP, YP, 'REQ', 0., 0.)
FRST%X = XP 40.31
FRST%Y = YP 40.31
NULLIFY(FRST%NEXTXY) 40.31
CURR => FRST 40.31
MIP = 1
! ***** interval and next corner point *****
33 CALL ININTG ('INT',INTV,'REP',-1)
IF (INTV .NE. -1) THEN
IF (INTV .LE. 0) THEN
CALL MSGERR (2,'INT is negative or zero')
INTV = 1
ENDIF
XP1 = XP
YP1 = YP
CALL READXY ('XP', 'YP', XP, YP, 'REQ', 0., 0.) 40.03
IF (ITEST .GE. 200 .OR. INTES .GE. 20) THEN 30.21
WRITE(PRINTF, 31) PSNAME
31 FORMAT ('COORDINATES OF OUTPUT POINTS FOR CURVE : ', A)
ENDIF
DO 36 JJ=1,INTV
MIP = MIP+1
ALLOCATE(TMP) 40.31
TMP%X = XP1+REAL(JJ)*(XP-XP1)/REAL(INTV) 40.31
TMP%Y = YP1+REAL(JJ)*(YP-YP1)/REAL(INTV) 40.31
NULLIFY(TMP%NEXTXY) 40.31
CURR%NEXTXY => TMP 40.31
CURR => TMP 40.31
36 CONTINUE
GOTO 33
ENDIF
#ifdef SWAN_MODEL
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP%XP(MIP)) 40.31
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP%YP(MIP)) 40.31
! ALLOCATE(OPSDATZ_MOD(ng)%COPS)
! ALLOCATE(OPSDATZ_MOD(ng)%FOPS)
CURR => FRST 40.31
DO JJ = 1, MIP 40.31
OPSDATZ_MOD(ng)%OPSTMP%XP(JJ) = CURR%X 40.31
OPSDATZ_MOD(ng)%OPSTMP%YP(JJ) = CURR%Y 40.31
IF (ITEST .GE. 200 .OR. INTES .GE. 50) THEN 40.31
WRITE(PRINTF,32) JJ, CURR%X, CURR%Y 40.31
32 FORMAT(' POINT(',I4,')',' (IX,IY) -> ',2F10.2) 40.31
ENDIF 40.31
CURR => CURR%NEXTXY 40.31
END DO 40.31
DEALLOCATE(TMP) 40.31
! ***** store number of points of the curve *****
OPSDATZ_MOD(ng)%OPSTMP%MIP = MIP 40.31
IF (MIP .EQ. 0) CALL MSGERR(1,'No output points found')
NULLIFY(OPSDATZ_MOD(ng)%OPSTMP%NEXTOPS) 40.31
IF ( .NOT.LOPS ) THEN 40.31
OPSDATZ_MOD(ng)%FOPS = OPSDATZ_MOD(ng)%OPSTMP 40.31
OPSDATZ_MOD(ng)%COPS => OPSDATZ_MOD(ng)%FOPS 40.31
LOPS = .TRUE. 40.31
ELSE 40.31
OPSDATZ_MOD(ng)%COPS%NEXTOPS => OPSDATZ_MOD(ng)%OPSTMP 40.31
OPSDATZ_MOD(ng)%COPS => OPSDATZ_MOD(ng)%OPSTMP 40.31
END IF 40.31
#else
ALLOCATE(OPSTMP%XP(MIP)) 40.31
ALLOCATE(OPSTMP%YP(MIP)) 40.31
CURR => FRST 40.31
DO JJ = 1, MIP 40.31
OPSTMP%XP(JJ) = CURR%X 40.31
OPSTMP%YP(JJ) = CURR%Y 40.31
IF (ITEST .GE. 200 .OR. INTES .GE. 50) THEN 40.31
WRITE(PRINTF,32) JJ, CURR%X, CURR%Y 40.31
32 FORMAT(' POINT(',I4,')',' (IX,IY) -> ',2F10.2) 40.31
ENDIF 40.31
CURR => CURR%NEXTXY 40.31
END DO 40.31
DEALLOCATE(TMP) 40.31
! ***** store number of points of the curve *****
OPSTMP%MIP = MIP 40.31
IF (MIP .EQ. 0) CALL MSGERR(1,'No output points found')
NULLIFY(OPSTMP%NEXTOPS) 40.31
IF ( .NOT.LOPS ) THEN 40.31
FOPS = OPSTMP 40.31
COPS => FOPS 40.31
LOPS = .TRUE. 40.31
ELSE 40.31
COPS%NEXTOPS => OPSTMP 40.31
COPS => OPSTMP 40.31
END IF 40.31
#endif
GOTO 800
ENDIF
!
! ------------------------------------------------------------------
! POINTS 'sname' < [xp] [yp] > | FILE 'fname'
! ------------------------------------------------------------------
!
IF (KEYWIS ('POIN')) THEN
#ifdef SWAN_MODEL
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP) 40.31
CALL INCSTR('SNAME',PSNAME,'REQ',' ')
IF (LENCST.GT.8) CALL MSGERR (2, 'SNAME is too long')
OPSDATZ_MOD(ng)%OPSTMP%PSNAME = PSNAME 40.31
OPSDATZ_MOD(ng)%OPSTMP%PSTYPE = 'P' 40.31
MIP = 0
OPSDATZ_MOD(ng)%OPSTMP%MIP = MIP 40.31
#else
ALLOCATE(OPSTMP) 40.31
CALL INCSTR('SNAME',PSNAME,'REQ',' ')
IF (LENCST.GT.8) CALL MSGERR (2, 'SNAME is too long')
OPSTMP%PSNAME = PSNAME 40.31
OPSTMP%PSTYPE = 'P' 40.31
MIP = 0
OPSTMP%MIP = MIP 40.31
#endif
CALL INKEYW ('STA', ' ')
IF (KEYWIS('FILE')) THEN
IOSTAT = 0
NDS = 0
PP = .TRUE.
CALL INCSTR ('FNAME', FILENM, 'REQ', ' ')
CALL FOR (NDS, FILENM, 'OF', IOSTAT) 10.31
IF (STPNOW()) RETURN 34.01
ELSE
PP = .FALSE.
ENDIF
FRST%X = 0. 40.31
FRST%Y = 0. 40.31
NULLIFY(FRST%NEXTXY) 40.31
CURR => FRST 40.31
DO
IF (PP) THEN
IERR = 0 10.18
CALL REFIXY (NDS, XP, YP, IERR) 10.18
IF (IERR.EQ.-1) GOTO 47
IF (IERR.EQ.-2) THEN
CALL MSGERR (2, 'Error reading point coord. from file')
GOTO 800
ENDIF
ELSE
CALL READXY ('XP', 'YP', XP, YP, 'REP', -1.E10, -1.E10)
IF (XP .LT. -0.9E10) GOTO 47
ENDIF
MIP = MIP+1
ALLOCATE(TMP) 40.31
TMP%X = XP 40.31
TMP%Y = YP 40.31
NULLIFY(TMP%NEXTXY) 40.31
CURR%NEXTXY => TMP 40.31
CURR => TMP 40.31
ENDDO
#ifdef SWAN_MODEL
47 ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP%XP(MIP)) 40.31
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP%YP(MIP)) 40.31
! ALLOCATE(OPSDATZ_MOD(ng)%COPS)
! ALLOCATE(OPSDATZ_MOD(ng)%FOPS)
CURR => FRST%NEXTXY 40.31
DO JJ = 1, MIP 40.31
OPSDATZ_MOD(ng)%OPSTMP%XP(JJ) = CURR%X 40.31
OPSDATZ_MOD(ng)%OPSTMP%YP(JJ) = CURR%Y 40.31
CURR => CURR%NEXTXY 40.31
END DO 40.31
DEALLOCATE(TMP) 40.31
! ***** store number of output points *****
OPSDATZ_MOD(ng)%OPSTMP%MIP = MIP 40.31
IF (MIP .EQ. 0) CALL MSGERR (2, 'No output points found') 10.32
NULLIFY(OPSDATZ_MOD(ng)%OPSTMP%NEXTOPS) 40.31
IF ( .NOT.LOPS ) THEN 40.31
OPSDATZ_MOD(ng)%FOPS = OPSDATZ_MOD(ng)%OPSTMP 40.31
OPSDATZ_MOD(ng)%COPS => OPSDATZ_MOD(ng)%FOPS 40.31
LOPS = .TRUE. 40.31
ELSE 40.31
OPSDATZ_MOD(ng)%COPS%NEXTOPS => OPSDATZ_MOD(ng)%OPSTMP 40.31
OPSDATZ_MOD(ng)%COPS => OPSDATZ_MOD(ng)%OPSTMP 40.31
END IF 40.31
#else
47 ALLOCATE(OPSTMP%XP(MIP)) 40.31
ALLOCATE(OPSTMP%YP(MIP)) 40.31
CURR => FRST%NEXTXY 40.31
DO JJ = 1, MIP 40.31
OPSTMP%XP(JJ) = CURR%X 40.31
OPSTMP%YP(JJ) = CURR%Y 40.31
CURR => CURR%NEXTXY 40.31
END DO 40.31
DEALLOCATE(TMP) 40.31
! ***** store number of output points *****
OPSTMP%MIP = MIP 40.31
IF (MIP .EQ. 0) CALL MSGERR (2, 'No output points found') 10.32
NULLIFY(OPSTMP%NEXTOPS) 40.31
IF ( .NOT.LOPS ) THEN 40.31
FOPS = OPSTMP 40.31
COPS => FOPS 40.31
LOPS = .TRUE. 40.31
ELSE 40.31
COPS%NEXTOPS => OPSTMP 40.31
COPS => OPSTMP 40.31
END IF 40.31
#endif
GOTO 800
ENDIF
!
! -------------------------------------------------------------------
! RAY 'rname' [xp1] [yp1] [xq1] [yq1] &
! < [int] [xp] [yp] [xq] [yq] >
! -------------------------------------------------------------------
!
IF (KEYWIS ('RAY')) THEN
!
IF (ONED) THEN 32.02
CALL MSGERR (2,' Illegal keyword (RAY) in combination'// 32.02
& ' with 1D-computation') 32.02
GOTO 800 32.02
ELSE 32.02
#ifdef SWAN_MODEL
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP) 40.31
CALL INCSTR('RNAME',PSNAME,'REQ',' ')
IF (LENCST.GT.8) CALL MSGERR (2, 'RNAME is too long')
OPSDATZ_MOD(ng)%OPSTMP%PSNAME = PSNAME 40.31
OPSDATZ_MOD(ng)%OPSTMP%PSTYPE = 'R' 40.31
MIP = 1
OPSDATZ_MOD(ng)%OPSTMP%MIP = MIP 40.31
#else
ALLOCATE(OPSTMP) 40.31
CALL INCSTR('RNAME',PSNAME,'REQ',' ')
IF (LENCST.GT.8) CALL MSGERR (2, 'RNAME is too long')
OPSTMP%PSNAME = PSNAME 40.31
OPSTMP%PSTYPE = 'R' 40.31
MIP = 1
OPSTMP%MIP = MIP 40.31
#endif
! first ray
CALL NWLINE
IF (STPNOW()) RETURN 34.01
CALL READXY ('XP1', 'YP1', XP, YP, 'REQ', 0., 0.)
CALL READXY ('XQ1', 'YQ1', XQ, YQ, 'REQ', 0., 0.)
FRST%X = XP 40.31
FRST%Y = YP 40.31
FRST%XQ = XQ 40.31
FRST%YQ = YQ 40.31
NULLIFY(FRST%NEXTXY) 40.31
CURR => FRST 40.31
! following rays
110 CALL ININTG ('INT',INTD,'REP',-1)
IF (INTD .NE. -1) THEN
IF (INTD .LE. 0) THEN
CALL MSGERR(2, 'INT negative or zero')
INTD = 1
ENDIF
XP1 = XP
YP1 = YP
XQ1 = XQ
YQ1 = YQ
CALL READXY ('XP', 'YP', XP, YP, 'REQ', 0., 0.)
CALL READXY ('XQ', 'YQ', XQ, YQ, 'REQ', 0., 0.)
DO 115 JJ=1,INTD
MIP = MIP+1
ALLOCATE(TMP) 40.31
TMP%X = XP1 + REAL(JJ)*(XP-XP1)/REAL(INTD) 40.31
TMP%Y = YP1 + REAL(JJ)*(YP-YP1)/REAL(INTD) 40.31
TMP%XQ = XQ1 + REAL(JJ)*(XQ-XQ1)/REAL(INTD) 40.31
TMP%YQ = YQ1 + REAL(JJ)*(YQ-YQ1)/REAL(INTD) 40.31
NULLIFY(TMP%NEXTXY) 40.31
CURR%NEXTXY => TMP 40.31
CURR => TMP 40.31
115 CONTINUE
GOTO 110
ENDIF
#ifdef SWAN_MODEL
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP%XP(MIP)) 40.31
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP%YP(MIP)) 40.31
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP%XQ(MIP)) 40.31
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP%YQ(MIP)) 40.31
! ALLOCATE(OPSDATZ_MOD(ng)%COPS)
! ALLOCATE(OPSDATZ_MOD(ng)%FOPS)
CURR => FRST 40.31
DO JJ = 1, MIP 40.31
OPSDATZ_MOD(ng)%OPSTMP%XP(JJ) = CURR%X 40.31
OPSDATZ_MOD(ng)%OPSTMP%YP(JJ) = CURR%Y 40.31
OPSDATZ_MOD(ng)%OPSTMP%XQ(JJ) = CURR%XQ 40.31
OPSDATZ_MOD(ng)%OPSTMP%YQ(JJ) = CURR%YQ 40.31
CURR => CURR%NEXTXY 40.31
END DO 40.31
DEALLOCATE(TMP) 40.31
!
! ***** termination *****
OPSDATZ_MOD(ng)%OPSTMP%MIP = MIP 40.31
IF (MIP .EQ. 1) CALL MSGERR (1,'Only one ray is defined')
NULLIFY(OPSDATZ_MOD(ng)%OPSTMP%NEXTOPS) 40.31
IF ( .NOT.LOPS ) THEN 40.31
OPSDATZ_MOD(ng)%FOPS = OPSDATZ_MOD(ng)%OPSTMP 40.31
OPSDATZ_MOD(ng)%COPS => OPSDATZ_MOD(ng)%FOPS 40.31
LOPS = .TRUE. 40.31
ELSE 40.31
OPSDATZ_MOD(ng)%COPS%NEXTOPS => OPSDATZ_MOD(ng)%OPSTMP 40.31
OPSDATZ_MOD(ng)%COPS => OPSDATZ_MOD(ng)%OPSTMP 40.31
END IF 40.31
#else
ALLOCATE(OPSTMP%XP(MIP)) 40.31
ALLOCATE(OPSTMP%YP(MIP)) 40.31
ALLOCATE(OPSTMP%XQ(MIP)) 40.31
ALLOCATE(OPSTMP%YQ(MIP)) 40.31
CURR => FRST 40.31
DO JJ = 1, MIP 40.31
OPSTMP%XP(JJ) = CURR%X 40.31
OPSTMP%YP(JJ) = CURR%Y 40.31
OPSTMP%XQ(JJ) = CURR%XQ 40.31
OPSTMP%YQ(JJ) = CURR%YQ 40.31
CURR => CURR%NEXTXY 40.31
END DO 40.31
DEALLOCATE(TMP) 40.31
!
! ***** termination *****
OPSTMP%MIP = MIP 40.31
IF (MIP .EQ. 1) CALL MSGERR (1,'Only one ray is defined')
NULLIFY(OPSTMP%NEXTOPS) 40.31
IF ( .NOT.LOPS ) THEN 40.31
FOPS = OPSTMP 40.31
COPS => FOPS 40.31
LOPS = .TRUE. 40.31
ELSE 40.31
COPS%NEXTOPS => OPSTMP 40.31
COPS => OPSTMP 40.31
END IF 40.31
#endif
GOTO 800
ENDIF 32.02
ENDIF
!
! -------------------------------------------------------------------
! ISOline 'sname' 'rname' DEPTH / BOTTOM [dep]
! -------------------------------------------------------------------
!
IF (KEYWIS ('ISO')) THEN
!
IF (ONED) THEN 32.02
CALL MSGERR (2,' Illegal keyword (ISO) in combination'// 32.02
& ' with 1D-computation') 32.02
GOTO 800 32.02
ELSE 32.02
#ifdef SWAN_MODEL
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP) 40.31
#else
ALLOCATE(OPSTMP) 40.31
#endif
CALL INCSTR ('SNAME',PSNAME,'REQ',' ')
IF (LENCST.GT.8) CALL MSGERR (2, 'SNAME is too long')
#ifdef SWAN_MODEL
OPSDATZ_MOD(ng)%OPSTMP%PSNAME = PSNAME 40.31
#else
OPSTMP%PSNAME = PSNAME 40.31
#endif
CALL INCSTR ('RNAME', PRNAME, 'REQ', ' ')
IF (LENCST.GT.8) CALL MSGERR (2, 'RNAME is too long')
CALL INKEYW ('STA', 'DEP')
IF (KEYWIS ('BOT')) THEN
BOTDEP = .TRUE. 30.70
ELSE
CALL IGNORE ('DEP')
BOTDEP = .FALSE. 30.70
IF (DYNDEP) CALL MSGERR (2,'depths will vary with time') 40.00
ENDIF
CALL INREAL ('DEP',DP,'REP',-1.E10)
#ifdef SWAN_MODEL
ROPS => OPSDATZ_MOD(ng)%FOPS
#else
ROPS => FOPS 40.31
#endif
DO 40.31
IF (ROPS%PSNAME.EQ.PRNAME) EXIT 40.31
IF (.NOT.ASSOCIATED(ROPS%NEXTOPS)) THEN 40.31
CALL MSGERR(2,'Set of rays not defined') 40.31
GOTO 800 40.31
END IF 40.31
ROPS => ROPS%NEXTOPS 40.31
END DO 40.31
STYPE = ROPS%PSTYPE 40.31
IF (STYPE .NE. 'R') THEN 40.31
CALL MSGERR 40.31
& (2,'Ray name set assigned to set of output locations') 40.31
GOTO 800 40.31
END IF 40.31
MIPR = ROPS%MIP 40.31
#ifdef SWAN_MODEL
OPSDATZ_MOD(ng)%OPSTMP%PSTYPE = 'C' 40.31
MIP = 0
OPSDATZ_MOD(ng)%OPSTMP%MIP = MIP 40.31
#else
OPSTMP%PSTYPE = 'C' 40.31
MIP = 0
OPSTMP%MIP = MIP 40.31
#endif
FRST%X = 0. 40.31
FRST%Y = 0. 40.31
NULLIFY(FRST%NEXTXY) 40.31
CURR => FRST 40.31
DO 125 IK=1,MIPR
XP = ROPS%XP(IK) 40.31
YP = ROPS%YP(IK) 40.31
XQ = ROPS%XQ(IK) 40.31
YQ = ROPS%YQ(IK) 40.31
II = SIRAY (DP, XP, YP, XQ, YQ, XX, YY, BOTDEP, 30.70
& BOTLEV, WATLEV) 30.70
IF (II.EQ.0) THEN
WRITE (PRINTF, 6120) DP, XP+XOFFS, YP+YOFFS, 30.70
& XQ+XOFFS, YQ+YOFFS 30.70
6120 FORMAT(' No point with depth ',F5.2,
& ' is found in ray :',4F10.2)
ELSE
MIP = MIP+1
ALLOCATE(TMP) 40.31
TMP%X = XX 40.31
TMP%Y = YY 40.31
NULLIFY(TMP%NEXTXY) 40.31
CURR%NEXTXY => TMP 40.31
CURR => TMP 40.31
ENDIF
125 CONTINUE
#ifdef SWAN_MODEL
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP%XP(MIP)) 40.31
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP%YP(MIP)) 40.31
! ALLOCATE(OPSDATZ_MOD(ng)%COPS)
! ALLOCATE(OPSDATZ_MOD(ng)%FOPS)
CURR => FRST%NEXTXY 40.31
DO IK = 1, MIP 40.31
OPSDATZ_MOD(ng)%OPSTMP%XP(IK) = CURR%X 40.31
OPSDATZ_MOD(ng)%OPSTMP%YP(IK) = CURR%Y 40.31
CURR => CURR%NEXTXY 40.31
END DO 40.31
DEALLOCATE(TMP) 40.31
IF (MIP.EQ.0) CALL MSGERR
& (2, 'No points with valid depth found')
! ***** store number of points of the curve *****
OPSDATZ_MOD(ng)%OPSTMP%MIP = MIP 40.31
NULLIFY(OPSDATZ_MOD(ng)%OPSTMP%NEXTOPS) 40.31
IF ( .NOT.LOPS ) THEN 40.31
OPSDATZ_MOD(ng)%FOPS = OPSDATZ_MOD(ng)%OPSTMP 40.31
OPSDATZ_MOD(ng)%COPS => OPSDATZ_MOD(ng)%FOPS 40.31
LOPS = .TRUE. 40.31
ELSE 40.31
OPSDATZ_MOD(ng)%COPS%NEXTOPS => OPSDATZ_MOD(ng)%OPSTMP 40.31
OPSDATZ_MOD(ng)%COPS => OPSDATZ_MOD(ng)%OPSTMP 40.31
END IF 40.31
#else
ALLOCATE(OPSTMP%XP(MIP)) 40.31
ALLOCATE(OPSTMP%YP(MIP)) 40.31
CURR => FRST%NEXTXY 40.31
DO IK = 1, MIP 40.31
OPSTMP%XP(IK) = CURR%X 40.31
OPSTMP%YP(IK) = CURR%Y 40.31
CURR => CURR%NEXTXY 40.31
END DO 40.31
DEALLOCATE(TMP) 40.31
IF (MIP.EQ.0) CALL MSGERR
& (2, 'No points with valid depth found')
! ***** store number of points of the curve *****
OPSTMP%MIP = MIP 40.31
NULLIFY(OPSTMP%NEXTOPS) 40.31
IF ( .NOT.LOPS ) THEN 40.31
FOPS = OPSTMP 40.31
COPS => FOPS 40.31
LOPS = .TRUE. 40.31
ELSE 40.31
COPS%NEXTOPS => OPSTMP 40.31
COPS => OPSTMP 40.31
END IF 40.31
#endif
GOTO 800
ENDIF 32.02
ENDIF
!
! -------------------------------------------------------------------
! | [xpn] [ypn] [alpn] [xlenn] [ylenn] [mxn] [myn]
! NGRID 'sname' <
! | UNSTRUCtured / -> TRIAngle \
! \ EASYmesh / 'fname'
! -------------------------------------------------------------------
!
IF (KEYWIS ('NGR')) THEN
!
IF (ONED) THEN 32.02
CALL MSGERR (2,' Illegal keyword (NGR) in combination'// 32.02
& ' with 1D-computation') 32.02
GOTO 800 32.02
ELSE 32.02
! ver 30.20: names changed, order changed
#ifdef SWAN_MODEL
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP) 40.31
CALL INCSTR('SNAME',PSNAME,'REQ',' ')
IF (LENCST.GT.8) CALL MSGERR (2, 'SNAME is too long')
OPSDATZ_MOD(ng)%OPSTMP%PSNAME = PSNAME 40.31
OPSDATZ_MOD(ng)%OPSTMP%PSTYPE = 'N' 40.31
#else
ALLOCATE(OPSTMP) 40.31
CALL INCSTR('SNAME',PSNAME,'REQ',' ')
IF (LENCST.GT.8) CALL MSGERR (2, 'SNAME is too long')
OPSTMP%PSNAME = PSNAME 40.31
OPSTMP%PSTYPE = 'N' 40.31
#endif
CALL INKEYW ('STA', ' ')
IF (KEYWIS('UNSTRUC')) THEN 40.80
PP = .TRUE.
CALL INKEYW('STA','TRIA')
IF (KEYWIS('EASY')) THEN
IOSTAT = 0
NDS = 0
CALL INCSTR ('FNAME', BASENM, 'REQ', ' ')
FILENM = TRIM(BASENM)//'.n'
CALL FOR (NDS, FILENM, 'OF', IOSTAT)
IF (STPNOW()) RETURN
!
! --- read first line to determine number of vertices
!
READ(NDS, *, END=950, ERR=910) NVTX
ISTAT = 0
IF(.NOT.ALLOCATED(XG)) ALLOCATE(XG(NVTX), STAT = ISTAT)
IF ( ISTAT == 0 ) THEN
IF(.NOT.ALLOCATED(YG)) ALLOCATE(YG(NVTX), STAT=ISTAT)
ENDIF
IF ( ISTAT == 0 ) THEN
IF(.NOT.ALLOCATED(VM)) ALLOCATE(VM(NVTX), STAT=ISTAT)
ENDIF
IF ( ISTAT /= 0 ) THEN
CALL MSGERR ( 4,
& 'Allocation problem in SWREPS: array XG, YG or VM ' )
RETURN
ENDIF
!
! --- read coordinates of vertices and boundary marker
!
DO KK = 1, NVTX
READ(NDS, 100, END=950, ERR=910) XG(I),YG(I),VM(I)
ENDDO
!
! --- close file <name>.n
!
CLOSE(NDS)
!
ELSE
CALL IGNORE('TRIA')
IOSTAT = 0
NDS = 0
CALL INCSTR ('FNAME', BASENM, 'REQ', ' ')
FILENM = TRIM(BASENM)//'.node'
CALL FOR (NDS, FILENM, 'OF', IOSTAT)
IF (STPNOW()) RETURN
!
! --- read first line to determine number of vertices
!
READ(NDS, *, END=950, ERR=910) NVTX, NDIM, NATTR, NBMARK
ISTAT = 0
IF(.NOT.ALLOCATED(XG)) ALLOCATE(XG(NVTX), STAT = ISTAT)
IF ( ISTAT == 0 ) THEN
IF(.NOT.ALLOCATED(YG)) ALLOCATE(YG(NVTX), STAT=ISTAT)
ENDIF
IF ( ISTAT == 0 ) THEN
IF(.NOT.ALLOCATED(VM)) ALLOCATE(VM(NVTX), STAT=ISTAT)
ENDIF
IF ( ISTAT /= 0 ) THEN
CALL MSGERR ( 4,
& 'Allocation problem in SWREPS: array XG, YG or VM ' )
RETURN
ENDIF
!
! --- check if boundary marker has been specified
!
IF ( NBMARK == 0 ) THEN
CALL MSGERR ( 4,
& 'boundary marker for vertices/faces must be specified ' )
RETURN
ENDIF
!
! --- read coordinates of vertices and boundary marker
!
IF ( NATTR == 0 ) THEN
DO KK = 1, NVTX
READ(NDS, *, END=950, ERR=910) I,XG(I),YG(I),VM(I)
ENDDO
ELSE
DO KK = 1, NVTX
READ(NDS, *, END=950, ERR=910) I,XG(I),YG(I),RDUM,
& VM(I)
ENDDO
ENDIF
!
! --- close file <name>.node
!
CLOSE(NDS)
!
ENDIF
ELSE
PP = .FALSE.
ENDIF
IF (.NOT.PP) THEN 40.80
! structured grid
CALL READXY ('XPN', 'YPN', XPCN, YPCN , 'REQ', 0., 0.) 30.20
CALL INREAL('ALPN',ALPCN,'REQ',0.) 30.20
CALL INREAL('XLENN',XNLEN,'REQ',0.) 30.20
CALL INREAL('YLENN',YNLEN,'REQ',0.) 30.20
ALTNP = ALPCN / 360.
ANG = PI2 * (ALTNP - NINT(ALTNP))
! estimate step size for output 40.00
IF (OPTG.EQ.1) THEN 40.13
COSA2 = (COS(ANG-ALPC))**2 40.00
SINA2 = (SIN(ANG-ALPC))**2 40.00
DXN = DX*COSA2 + DY*SINA2 40.00
DYN = DX*SINA2 + DY*COSA2 40.00
ELSEIF (OPTG.EQ.3) THEN 40.80 40.13
! curvilinear grid, DXN and DYN are average step size 40.13
DXN = (XCLEN+YCLEN)/REAL(MXCGL+MYCGL) 40.31 40.13
DYN = DXN 40.13
ELSEIF (OPTG.EQ.5) THEN 40.80
! unstructured grid, DXN and DYN are average grid size 40.80
DXN = 0.5*(mingsiz+maxgsiz) 40.80
DYN = DXN 40.80
ENDIF 40.13
CALL ININTG ('MXN',MXN,'STA',MAX(1,NINT(XNLEN/DXN))) 40.00
CALL ININTG ('MYN',MYN,'STA',MAX(1,NINT(YNLEN/DYN))) 40.00
MIP = 0
#ifdef SWAN_MODEL
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP%XP(2*(MXN+MYN))) 40.31
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP%YP(2*(MXN+MYN))) 40.31
#else
ALLOCATE(OPSTMP%XP(2*(MXN+MYN))) 40.31
ALLOCATE(OPSTMP%YP(2*(MXN+MYN))) 40.31
#endif
XF=XPCN
YF=YPCN
! ***** start to calculate the positions ********
! ***** of the boundary point in the four sides ********
DO 50 I=1,4
INTE=MXN
ALON=XNLEN
ANGLE=ANG+PI2*(90.*REAL(I-1))/360.
IF (I .EQ. 2 .OR. I .EQ. 4) THEN
INTE=MYN
ALON=YNLEN
ENDIF
XI=XF
YI=YF
XF=XI+ALON*COS(ANGLE)
YF=YI+ALON*SIN(ANGLE)
DO 55 KK=1,INTE
MIP=MIP+1
#ifdef SWAN_MODEL
OPSDATZ_MOD(ng)%OPSTMP%XP(MIP)=XI+REAL(KK)*(XF-XI)/ &
& REAL(INTE)
OPSDATZ_MOD(ng)%OPSTMP%YP(MIP)=YI+REAL(KK)*(YF-YI)/ &
& REAL(INTE)
55 CONTINUE
50 CONTINUE
! ***** store number of points of the curve *****
OPSDATZ_MOD(ng)%OPSTMP%MIP = MIP 40.31
OPSDATZ_MOD(ng)%OPSTMP%OPR(1) = XNLEN 40.31
OPSDATZ_MOD(ng)%OPSTMP%OPR(2) = YNLEN 40.31
OPSDATZ_MOD(ng)%OPSTMP%OPR(3) = XPCN 40.31
OPSDATZ_MOD(ng)%OPSTMP%OPR(4) = YPCN 40.31
OPSDATZ_MOD(ng)%OPSTMP%OPR(5) = PI2 * &
& (ALPCN/360.-NINT(ALPCN/360.)) 40.31
OPSDATZ_MOD(ng)%OPSTMP%OPI(1) = MXN 40.31
OPSDATZ_MOD(ng)%OPSTMP%OPI(2) = MYN 40.31
IF (MIP .EQ. 0) CALL MSGERR(1,'No output points found')
NULLIFY(OPSDATZ_MOD(ng)%OPSTMP%NEXTOPS) 40.31
IF ( .NOT.LOPS ) THEN 40.31
OPSDATZ_MOD(ng)%FOPS = OPSDATZ_MOD(ng)%OPSTMP 40.31
OPSDATZ_MOD(ng)%COPS => OPSDATZ_MOD(ng)%FOPS 40.31
LOPS = .TRUE. 40.31
ELSE 40.31
OPSDATZ_MOD(ng)%COPS%NEXTOPS => OPSDATZ_MOD(ng)%OPSTMP 40.31
OPSDATZ_MOD(ng)%COPS => OPSDATZ_MOD(ng)%OPSTMP 40.31
END IF 40.31
END IF jcw
#else
OPSTMP%XP(MIP)=XI+REAL(KK)*(XF-XI)/REAL(INTE)
OPSTMP%YP(MIP)=YI+REAL(KK)*(YF-YI)/REAL(INTE)
55 CONTINUE
50 CONTINUE
! ***** store number of points *****
OPSTMP%MIP = MIP 40.31
OPSTMP%OPR(1) = XNLEN 40.31
OPSTMP%OPR(2) = YNLEN 40.31
OPSTMP%OPR(3) = XPCN 40.31
OPSTMP%OPR(4) = YPCN 40.31
OPSTMP%OPR(5) = PI2 * (ALPCN/360.-NINT(ALPCN/360.)) 40.31
OPSTMP%OPI(1) = MXN 40.31
OPSTMP%OPI(2) = MYN 40.31
ELSE 40.80
! unstructured grid
!
MIP = COUNT(MASK=VM/=0)
ALLOCATE(OPSTMP%XP(MIP))
ALLOCATE(OPSTMP%YP(MIP))
I = 0
DO KK = 1, NVTX
IF ( VM(KK) /= 0 ) THEN
I = I + 1
OPSTMP%XP(I)= XG(KK)-XOFFS
OPSTMP%YP(I)= YG(KK)-YOFFS
ENDIF
ENDDO
IF (ALLOCATED(XG)) DEALLOCATE(XG)
IF (ALLOCATED(YG)) DEALLOCATE(YG)
IF (ALLOCATED(VM)) DEALLOCATE(VM)
OPSTMP%MIP = MIP
! next variable will be used for checking grid in
! present computational and/or bottom grid
OPSTMP%OPR(1) = -999.
ENDIF 40.80
IF (MIP .EQ. 0) CALL MSGERR(1,'No output points found')
NULLIFY(OPSTMP%NEXTOPS) 40.31
IF ( .NOT.LOPS ) THEN 40.31
FOPS = OPSTMP 40.31
COPS => FOPS 40.31
LOPS = .TRUE. 40.31
ELSE 40.31
COPS%NEXTOPS => OPSTMP 40.31
COPS => OPSTMP 40.31
END IF 40.31
#endif
GOTO 800
!
910 INQUIRE (UNIT=NDS, NAME=FILENM) 40.80
CALL MSGERR (4, 'error reading data from file '//FILENM ) 40.80
RETURN 40.80
950 INQUIRE (UNIT=NDS, NAME=FILENM) 40.80
CALL MSGERR (4, 'unexpected end of file in file '//FILENM ) 40.80
RETURN 40.80
!
ENDIF 32.02
ENDIF
! ---------------------------------------------------------
! command not found:
RETURN
800 FOUND = .TRUE.
RETURN
100 FORMAT((6X,2E22.15,I3)) 40.80
!* end of subroutine SWREPS **
END
!***********************************************************************
! *
#ifdef SWAN_MODEL
SUBROUTINE SWREOQ ( FOUND, ng)
#else
SUBROUTINE SWREOQ ( FOUND ) 40.31
#endif
! *
!***********************************************************************
!
USE OCPCOMM1 40.41
USE OCPCOMM2 40.41
USE OCPCOMM3 40.41
USE OCPCOMM4 40.41
USE SWCOMM1 40.41
USE SWCOMM2 40.41
USE SWCOMM3 40.41
USE SWCOMM4 40.41
USE OUTP_DATA 40.13
USE M_PARALL 40.31
USE swn_outnc 41.52
!PUN USE SIZES 40.95
!
!
! --|-----------------------------------------------------------|--
! | Delft University of Technology |
! | Faculty of Civil Engineering |
! | Environmental Fluid Mechanics Section |
! | P.O. Box 5048, 2600 GA Delft, The Netherlands |
! | |
! | Programmers: The SWAN team |
! --|-----------------------------------------------------------|--
!
!
! SWAN (Simulating WAves Nearshore); a third generation wave model
! Copyright (C) 1993-2017 Delft University of Technology
!
! This program is free software; you can redistribute it and/or
! modify it under the terms of the GNU General Public License as
! published by the Free Software Foundation; either version 2 of
! the License, or (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! A copy of the GNU General Public License is available at
! http://www.gnu.org/copyleft/gpl.html#SEC3
! or by writing to the Free Software Foundation, Inc.,
! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
!
!
! 0. Authors
!
! 30.72: IJsbrand Haagsma
! 30.81: Annette Kieftenburg
! 30.82: IJsbrand Haagsma
! 32.02: Roeland Ris & Cor van der Schelde (1D version)
! 34.01: Jeroen Adema
! 40.03, 40.13: Nico Booij
! 40.14: Annette Kieftenburg
! 40.30: Marcel Zijlema
! 40.31: Marcel Zijlema
! 40.41: Marcel Zijlema
! 41.62: Andre van der Westhuysen
!
! 1. Updates
!
! 30.50 : option COORD added in command PLOT
! option STAR added in command PLOT
! 32.02, Feb. 98: 1D version introduced
! 30.72, Feb. 98: Introduced generic names XCGRID, YCGRID and SPCSIG for SWAN
! 30.82, Apr. 98: removed reference to commons KAART and KAR
! 30.81, Nov. 98: Replaced variable STATUS by IERR (because STATUS is a
! reserved word)
! 30.81, Jan. 99: Replaced variable TO by TO_ (because TO is a reserved
! word)
! 34.01, Feb. 99: Introducing STPNOW
! 40.03, Nov. 99: in case SPEC2D the value of MXOUTAR is increased by
! 6*MIP
! 40.03, Mar. 00: NQUA increased in case of Isoline plot
! Sep. 00: inconsistency with manual corrected
! 40.13, Mar. 01: option BLOCKed added in plot of problem points
! Aug. 01: array for NESTOUT request extended to 20 (in view of SETUP)
! 40.13, Oct. 01: filenames are stored in array OUTP_FILES
! not any more in array containing output request parameters
! 40.14, Dec. 01: format for setup corrected.
! 40.30, Mar. 03: introduction distributed-memory approach using MPI
! 40.31, Nov. 03: removing POOL construction and HPGL funcationality
! 40.41, Oct. 04: common blocks replaced by modules, include files removed
! 41.62, Nov. 15: included input fields for wave partitioning
!
! 2. Purpose
!
! Reading and processing of the output requests
!
! 3. Method
!
! ---
!
! 4. Argument variables
!
! FOUND : output parameter indicating whether command
! being processed is found (value True)
! or not (False)
!
LOGICAL FOUND 30.72
!
! 8. Subroutines used
!
! command reading routines
! (all Ocean Pack)
!
LOGICAL STPNOW 34.01
!
! 9. Subroutines calling
!
! SPROUT
!
! 10. Error messages
!
! ---
!
! 13. Source text
!
#ifdef SWAN_MODEL
INTEGER, INTENT(IN) :: ng
#endif
PARAMETER (NEXPT=10) 41.62
INTEGER IERR 40.31
CHARACTER PSNAME *16, STYPE *1, RTYPE *4 40.31
LOGICAL KEYWIS 40.31
TYPE(ORQDAT), POINTER :: ORQTMP 40.31
TYPE(ORQDAT), SAVE, POINTER :: CORQ 40.31
#if !defined SWAN_MODEL
LOGICAL, SAVE :: LORQ = .FALSE. 40.31
#endif
TYPE AUXT 40.31
INTEGER :: I
REAL :: R
TYPE(AUXT), POINTER :: NEXTI
END TYPE AUXT
TYPE(AUXT), TARGET :: FRST 40.31
TYPE(AUXT), POINTER :: CURR, TMP 40.31
INTEGER IEXPT(NEXPT) 41.62
INTEGER IVT 41.62
SAVE IENT, IEXPT
DATA IENT/0/
DATA IEXPT /1, 2, 4, 5, 10, 12, 13, 16, 17, 26/ 41.62
CALL STRACE (IENT,'SWREOQ')
!
! --------------------------------------------------------------------------
! BLOCK 'sname' HEADER / NOHEADER 'fname' (LAY-OUT [idla]) &
! < DSPR/HSIGN/DIR/PDIR/TDIR/TM01/RTM01/RTP/TM02/FSPR/DEPTH/VEL/ &
! FRCOEFF/WIND/DISSIP/QB/TRANSP/FORCE/UBOT/URMS/WLEN/STEEPNESS/ &
! DHSIGN/DRTM01/LEAK/TSEC/XP/YP/DIST/SETUP/TMM10/RTMM10/ &
#ifdef SWAN_MODEL
! TMBOT/DIRBOT/QP/BFI/WATLEV/BOTLEV/TPS/DISBOT/DISSURF/DISWCAP/ &
#else
! TMBOT/QP/BFI/WATLEV/BOTLEV/TPS/DISBOT/DISSURF/DISWCAP/ &
#endif
! GENE/GENW/REDI/REDQ/REDT/PROPA/PROPX/PROPT/PROPS/RADS|LWAVP/ &
! DISTUR/TURB/DISSWELL/ &
! PTHSIGN/PTRTP/PTWLEN/PTDIR/PTDSPR/PTWFRAC/PTSTEEPNESS> &
! ([unit]) (OUTPUT [tbegblk] [deltblk] SEC/MIN/HR/DAY)
! --------------------------------------------------------------------------
! BLO block type output
IF (KEYWIS ('BLO')) THEN
!
IF (ONED) THEN 32.02
CALL MSGERR (2,' Illegal keyword (BLO) in combination'// 32.02
& ' with 1D-computation') 32.02
GOTO 800 32.02
ELSE 32.02
#ifdef SWAN_MODEL
CALL SWNMPS (PSNAME, STYPE, MIP, IERR, ng)
#else
CALL SWNMPS (PSNAME, STYPE, MIP, IERR) 40.31
#endif
IF (IERR.NE.0) GOTO 800
IF (STYPE.NE.'F' .AND. STYPE.NE.'H' .AND. STYPE.NE.'U' ) THEN 40.80 30.21
CALL MSGERR(2,'Set of output locations is not correct type')
GOTO 800
ENDIF
!
! output frame exists
!
ALLOCATE(ORQTMP) 40.31
NREOQ = NREOQ + 1 40.31
IF (NREOQ.GT.MAX_OUTP_REQ) CALL MSGERR (2, 40.31 40.13
& 'too many output requests') 40.13
IDLAO = 1
!
CALL INKEYW ('REQ',' ')
IF (KEYWIS('NOHEAD') .OR. KEYWIS ('FIL')) THEN 30.20
CALL INCSTR ('FNAME', FILENM, 'REQ', ' ')
DFAC = 1.
CALL INKEYW ('STA', ' ')
IF (KEYWIS('LONG')) THEN
! option disabled 40.13
CALL MSGERR (2, 'option LONG disabled; use OUTP OPT') 40.13
ENDIF 40.13
RTYPE = 'BLKD'
ELSE
CALL IGNORE ('HEAD') 30.20
CALL IGNORE ('PAP')
DFAC = -1.
CALL INCSTR ('FNAME', FILENM, 'STA', ' ') 30.20
RTYPE = 'BLKP'
IF ( INDEX( FILENM, '.MAT' ).NE.0 .OR. 40.41 40.30
& INDEX (FILENM, '.mat' ).NE.0 ) THEN 40.41 40.30
CALL MSGERR(4,'No header allowed for Matlab files') 40.30
RETURN 40.30
END IF 40.30
END IF
IF (FILENM .EQ. ' ') THEN 24/FEB
NREF = PRINTF
ELSE
NREF = 0
! --- append node number to FILENM in case of 40.30
! parallel computing 40.30
IF ( PARLL ) THEN 40.30
ILPOS = INDEX ( FILENM, ' ' )-1 40.30
WRITE(FILENM(ILPOS+1:ILPOS+4),33) INODE 40.30
33 FORMAT('-',I3.3) 40.30
END IF 40.30
!PUN FILENM = TRIM(LOCALDIR)//DIRCH2//TRIM(FILENM) 40.95
ENDIF
CALL INKEYW ('STA', ' ')
IF (KEYWIS('LAY')) THEN
CALL ININTG ('IDLA', IDLAO, 'REQ', 0)
CALL INKEYW ('REQ', ' ')
IF (IDLAO.NE.1 .AND. IDLAO.NE.3 .AND. IDLAO.NE.4
& .AND. IDLAO.NE.5
& )
& CALL MSGERR (2, 'Illegal value for IDLA')
ENDIF
ORQTMP%OQR(1) = -1. 40.31
ORQTMP%OQR(2) = -1. 40.31
ORQTMP%RQTYPE = RTYPE 40.31
ORQTMP%PSNAME = PSNAME 40.31
ORQTMP%OQI(1) = NREF 40.31
ORQTMP%OQI(2) = NREOQ 40.31
NVAR = 0 40.31
ORQTMP%OQI(3) = NVAR 40.31
ORQTMP%OQI(4) = IDLAO 40.31
OUTP_FILES(NREOQ) = FILENM 40.13
!
! read types of output quantities
!
FRST%I = 0 40.31
FRST%R = 0. 40.31
NULLIFY(FRST%NEXTI) 40.31
CURR => FRST 40.31
70 CALL SVARTP (IVTYPE)
IF (IVTYPE .EQ. 98) GOTO 91 30.00
IF (IVTYPE .NE. 999) THEN
IF ( INDEX(FILENM,'.NC').NE.0 .OR. 41.52
& INDEX(FILENM,'.nc').NE.0 ) THEN 41.52
IF ( IVTYPE.GT.2 ) THEN 41.52
call stnames_init() 41.52
IF ( STNAMES(IVTYPE,1).EQ. ' ' ) CALL MSGERR (2, 41.52
& 'netCDF output not allowed for '//TRIM(FILENM)) 41.52
ENDIF 41.52
ENDIF 41.52
CALL INREAL ('UNIT', DFAC, 'STA', -1.)
IF (OVSVTY(IVTYPE).EQ.5) THEN
CALL MSGERR (2,
& 'Type of output not allowed for this quantity')
WRITE (PRINTF, *) ' -> ', OVSNAM(IVTYPE)
ELSE IF (IVTYPE.GT.100 .AND. IVTYPE.LT.110) THEN 41.62
CALL MSGERR (2,'Invalid partitioning output '// 41.62
& 'specification. Use PTHSIGN instead.') 41.62
WRITE (PRINTF, *) ' -> ', OVSNAM(IVTYPE) 41.62
ELSE IF (IVTYPE.GT.110 .AND. IVTYPE.LT.120) THEN 41.62
CALL MSGERR (2,'Invalid partitioning output '// 41.62
& 'specification. Use PTRTP instead.') 41.62
WRITE (PRINTF, *) ' -> ', OVSNAM(IVTYPE) 41.62
ELSE IF (IVTYPE.GT.120 .AND. IVTYPE.LT.130) THEN 41.62
CALL MSGERR (2,'Invalid partitioning output '// 41.62
& 'specification. Use PTWLEN instead.') 41.62
WRITE (PRINTF, *) ' -> ', OVSNAM(IVTYPE) 41.62
ELSE IF (IVTYPE.GT.130 .AND. IVTYPE.LT.140) THEN 41.62
CALL MSGERR (2,'Invalid partitioning output '// 41.62
& 'specification. Use PTDIR instead.') 41.62
WRITE (PRINTF, *) ' -> ', OVSNAM(IVTYPE) 41.62
ELSE IF (IVTYPE.GT.140 .AND. IVTYPE.LT.150) THEN 41.62
CALL MSGERR (2,'Invalid partitioning output '// 41.62
& 'specification. Use PTDSPR instead.') 41.62
WRITE (PRINTF, *) ' -> ', OVSNAM(IVTYPE) 41.62
ELSE IF (IVTYPE.GT.150 .AND. IVTYPE.LT.160) THEN 41.62
CALL MSGERR (2,'Invalid partitioning output '// 41.62
& 'specification. Use PTWFRAC instead.') 41.62
WRITE (PRINTF, *) ' -> ', OVSNAM(IVTYPE) 41.62
ELSE IF (IVTYPE.GT.160 .AND. IVTYPE.LT.170) THEN 41.62
CALL MSGERR (2,'Invalid partitioning output '// 41.62
& 'specification. Use PTSTEEPNESS instead.') 41.62
WRITE (PRINTF, *) ' -> ', OVSNAM(IVTYPE) 41.62
ELSE IF (IVTYPE.GT.0 .AND. IVTYPE.LT.100) THEN 41.62
NVAR = NVAR+1
ALLOCATE(TMP) 40.31
TMP%I = IVTYPE 40.31
TMP%R = DFAC 40.31
NULLIFY(TMP%NEXTI) 40.31
CURR%NEXTI => TMP 40.31
CURR => TMP 40.31
IF (IVTYPE.EQ.6) IUBOTR = 1
IF (IVTYPE.EQ.36 .AND. JZEL.LE.1) THEN
MCMVAR = MCMVAR+1 40.65
JZEL = MCMVAR 40.65
ALOCMP = .TRUE. 40.97
ENDIF 40.65
IF (IVTYPE.EQ.50 .AND. JPBOT.LE.1) THEN 40.65
MCMVAR = MCMVAR+1 40.65
JPBOT = MCMVAR 40.65
ALOCMP = .TRUE. 40.97
ENDIF 40.65
IF (IVTYPE.EQ.54 .AND. JDSXB.LE.1) THEN 40.65
MCMVAR = MCMVAR+1 40.65
JDSXB = MCMVAR 40.65
ALOCMP = .TRUE. 40.97
ENDIF 40.65
IF (IVTYPE.EQ.55 .AND. JDSXS.LE.1) THEN 40.65
MCMVAR = MCMVAR+1 40.65
JDSXS = MCMVAR 40.65
ALOCMP = .TRUE. 40.97
ENDIF 40.65
IF (IVTYPE.EQ.56 .AND. JDSXW.LE.1) THEN 40.65
MCMVAR = MCMVAR+1 40.65
JDSXW = MCMVAR 40.65
ALOCMP = .TRUE. 40.97
ENDIF 40.65
IF (IVTYPE.EQ.57 .AND. JDSXV.LE.1) THEN 40.65
MCMVAR = MCMVAR+1 40.65
JDSXV = MCMVAR 40.65
ALOCMP = .TRUE. 40.97
ENDIF 40.65
IF (IVTYPE.EQ.60 .AND. JGENR.LE.1) THEN 40.85
MCMVAR = MCMVAR+1 40.85
JGENR = MCMVAR 40.85
ALOCMP = .TRUE. 40.97
ENDIF 40.85
IF (IVTYPE.EQ.61 .AND. JGSXW.LE.1) THEN 40.85
MCMVAR = MCMVAR+1 40.85
JGSXW = MCMVAR 40.85
ALOCMP = .TRUE. 40.97
ENDIF 40.85
IF (IVTYPE.EQ.62 .AND. JREDS.LE.1) THEN 40.85
MCMVAR = MCMVAR+1 40.85
JREDS = MCMVAR 40.85
ALOCMP = .TRUE. 40.97
ENDIF 40.85
IF (IVTYPE.EQ.63 .AND. JRSXQ.LE.1) THEN 40.85
MCMVAR = MCMVAR+1 40.85
JRSXQ = MCMVAR 40.85
ALOCMP = .TRUE. 40.97
ENDIF 40.85
IF (IVTYPE.EQ.64 .AND. JRSXT.LE.1) THEN 40.85
MCMVAR = MCMVAR+1 40.85
JRSXT = MCMVAR 40.85
ALOCMP = .TRUE. 40.97
ENDIF 40.85
IF (IVTYPE.EQ.65 .AND. JTRAN.LE.1) THEN 40.85
MCMVAR = MCMVAR+1 40.85
JTRAN = MCMVAR 40.85
ALOCMP = .TRUE. 40.97
ENDIF 40.85
IF (IVTYPE.EQ.66 .AND. JTSXG.LE.1) THEN 40.85
MCMVAR = MCMVAR+1 40.85
JTSXG = MCMVAR 40.85
ALOCMP = .TRUE. 40.97
ENDIF 40.85
IF (IVTYPE.EQ.67 .AND. JTSXT.LE.1) THEN 40.85
MCMVAR = MCMVAR+1 40.85
JTSXT = MCMVAR 40.85
ALOCMP = .TRUE. 40.97
ENDIF 40.85
IF (IVTYPE.EQ.68 .AND. JTSXS.LE.1) THEN 40.85
MCMVAR = MCMVAR+1 40.85
JTSXS = MCMVAR 40.85
ALOCMP = .TRUE. 40.97
ENDIF 40.85
IF (IVTYPE.EQ.69 .AND. JRADS.LE.1) THEN 40.85
MCMVAR = MCMVAR+1 40.85
JRADS = MCMVAR 40.85
ALOCMP = .TRUE. 40.97
ENDIF 40.85
IF (IVTYPE.EQ.72 .AND. JDSXT.LE.1) THEN 40.35
MCMVAR = MCMVAR+1 40.35
JDSXT = MCMVAR 40.35
ALOCMP = .TRUE. 40.35
ENDIF 40.35
IF (IVTYPE.EQ.74 .AND. JDSXM.LE.1) THEN 40.65
MCMVAR = MCMVAR+1 40.65
JDSXM = MCMVAR 40.65
ALOCMP = .TRUE. 40.97
ENDIF 40.65
IF (IVTYPE.EQ.75 .AND. JDSXL.LE.1) THEN 40.88
MCMVAR = MCMVAR+1 40.88
JDSXL = MCMVAR 40.88
ALOCMP = .TRUE. 40.88
ENDIF 40.88
#ifdef SWAN_MODEL
IF (IVTYPE.EQ.76 .AND. JDBOT.LE.1) THEN !PSD 09/21/2011
MCMVAR = MCMVAR+1 !PSD 09/21/2011
JDBOT = MCMVAR !PSD 09/21/2011
ALOCMP = .TRUE. !PSD 09/21/2011
ENDIF !PSD 09/21/2011
#endif
IF (IVTYPE.EQ.7 .OR. IVTYPE.EQ.9 .OR. 40.85
& IVTYPE.EQ.54 .OR. IVTYPE.EQ.55 .OR. 40.85
& IVTYPE.EQ.56 .OR. IVTYPE.EQ.57 .OR. 40.85
& IVTYPE.GE.60 ) LADDS = .TRUE. 40.85
ELSE IF (IVTYPE.LT.170) THEN 41.62
! add all 10 partitions of requested partition parameter
DO IVT = IVTYPE, IVTYPE+9 41.62
NVAR = NVAR+1 41.62
ALLOCATE(TMP) 41.62
TMP%I = IVT 41.62
TMP%R = DFAC 41.62
NULLIFY(TMP%NEXTI) 41.62
CURR%NEXTI => TMP 41.62
CURR => TMP 41.62
ENDDO 41.62
ELSE IF (IVTYPE.EQ.170) THEN 41.62
! in case of PARTITIONS, add all partition parameters
NVAR = NVAR+1
ALLOCATE(TMP) 41.62
TMP%I = 171 41.62
TMP%R = DFAC 41.62
NULLIFY(TMP%NEXTI) 41.62
CURR%NEXTI => TMP 41.62
CURR => TMP 41.62
DO IVT = 100, 159 41.62
NVAR = NVAR+1 41.62
ALLOCATE(TMP) 41.62
TMP%I = IVT 41.62
TMP%R = DFAC 41.62
NULLIFY(TMP%NEXTI) 41.62
CURR%NEXTI => TMP 41.62
CURR => TMP 41.62
ENDDO 41.62
! add some other parameters e.g. Xp, Yp, Depth, Hs, etc.
DO IVT = 1, NEXPT 41.62
NVAR = NVAR+1 41.62
ALLOCATE(TMP) 41.62
TMP%I = IEXPT(IVT) 41.62
TMP%R = DFAC 41.62
NULLIFY(TMP%NEXTI) 41.62
CURR%NEXTI => TMP 41.62
CURR => TMP 41.62
ENDDO 41.62
ENDIF
GOTO 70
ENDIF
91 IF (NVAR.GT.0) THEN 40.31
ALLOCATE(ORQTMP%IVTYP(NVAR)) 40.31
ALLOCATE(ORQTMP%FAC(NVAR)) 40.31
CURR => FRST%NEXTI 40.31
DO JJ = 1, NVAR 40.31
ORQTMP%IVTYP(JJ) = CURR%I 40.31
ORQTMP%FAC (JJ) = CURR%R 40.31
CURR => CURR%NEXTI 40.31
END DO 40.31
DEALLOCATE(TMP) 40.31
END IF 40.31
!
IF (IVTYPE .EQ. 98) THEN 30.00
IF (NSTATM.EQ.0) CALL MSGERR (3,
& 'time information not allowed in stationary mode')
NSTATM = 1
CALL INCTIM (ITMOPT, 'TBEG', ORQTMP%OQR(1), 'REQ', 0D0) 40.31 30.00
CALL INITVD ('DELT', ORQTMP%OQR(2), 'REQ', 0D0) 40.31 30.00
ENDIF
!
ORQTMP%OQI(3) = NVAR 40.31
NULLIFY(ORQTMP%NEXTORQ) 40.31
IF ( .NOT.LORQ ) THEN 40.31
#ifdef SWAN_MODEL
ALLOCATE (ORQDATZ_MOD(ng)%FORQ%IVTYP(NVAR))
ALLOCATE (ORQDATZ_MOD(ng)%FORQ%FAC(NVAR))
ORQDATZ_MOD(ng)%FORQ = ORQTMP 40.31
CORQ => ORQDATZ_MOD(ng)%FORQ 40.31
#else
FORQ = ORQTMP 40.31
CORQ => FORQ 40.31
#endif
LORQ = .TRUE. 40.31
ELSE 40.31
CORQ%NEXTORQ => ORQTMP 40.31
CORQ => ORQTMP 40.31
END IF 40.31
GOTO 800
ENDIF 32.02
ENDIF
! --------------------------------------------------------------------------
! TABLE 'sname' HEADER / NOHEADER / INDEXED 'fname' &
! < DSPR/HSIGN/DIR/PDIR/TDIR/TM01/RTM01/RTP/TM02/FSPR/DEPTH/VEL/ &
! FRCOEFF/WIND/DISSIP/QB/TRANSP/FORCE/UBOT/URMS/WLEN/STEEPNESS/ &
! DHSIGN/DRTM01/LEAK/TIME/TSEC/XP/YP/DIST/SETUP/TMM10/RTMM10/ &
#ifdef SWAN_MODEL
! TMBOT/DIRBOT/QP/BFI/WATLEV/BOTLEV/TPS/DISBOT/DISSURF/DISWCAP/ &
#else
! TMBOT/QP/BFI/WATLEV/BOTLEV/TPS/DISBOT/DISSURF/DISWCAP/ &
#endif
! GENE/GENW/REDI/REDQ/REDT/PROPA/PROPX/PROPT/PROPS/RADS|LWAVP/ &
! DISTUR/TURB/DISSWELL &
! PTHSIGN/PTRTP/PTWLEN/PTDIR/PTDSPR/PTWFRAC/PTSTEEPNESS> &
! ([unit]) (OUTPUT [tbegtbl] [delttbl] SEC/MIN/HR/DAY)
! --------------------------------------------------------------------------
! TABLE output in the form of a table
IF (KEYWIS ('TAB')) THEN
#ifdef SWAN_MODEL
CALL SWNMPS (PSNAME, STYPE, MIP, IERR, ng)
#else
CALL SWNMPS (PSNAME, STYPE, MIP, IERR) 40.31
#endif
IF (IERR.NE.0) GOTO 800
!
! output points exist
!
ALLOCATE(ORQTMP) 40.31
NREOQ = NREOQ + 1 40.31
IF (NREOQ.GT.MAX_OUTP_REQ) CALL MSGERR (2, 40.31 40.13
& 'too many output requests') 40.13
!
CALL INKEYW ('STA','HEAD') 20.67
IF (KEYWIS('NOHEAD') .OR. KEYWIS ('FIL')) THEN 20.67
RTYPE = 'TABD'
ELSE IF (KEYWIS ('IND')) THEN 30.50
RTYPE = 'TABI'
ELSE IF (KEYWIS ('SWAN')) THEN 40.00
RTYPE = 'TABS'
ELSE IF (KEYWIS ('STAB')) THEN 40.00
RTYPE = 'TABT'
ELSE
CALL IGNORE ('HEAD') 20.67
CALL IGNORE ('PAP')
RTYPE = 'TABP'
END IF
ORQTMP%OQR(1) = -1. 40.31
ORQTMP%OQR(2) = -1. 40.31
ORQTMP%RQTYPE = RTYPE 40.31
! unit reference number NREF is 0, will be determined in output module
CALL INCSTR ('FNAME', FILENM, 'STA', ' ')
IF (FILENM .NE. ' ') THEN
IF ( INDEX( FILENM, '.NC' ).NE.0 .OR.
& INDEX (FILENM, '.nc' ).NE.0 ) THEN
RTYPE = 'TABC'
ORQTMP%RQTYPE = RTYPE
ENDIF
NREF = 0
! --- append node number to FILENM in case of 40.30
! parallel computing 40.30
IF ( PARLL ) THEN 40.30
ILPOS = INDEX ( FILENM, ' ' )-1 40.30
WRITE(FILENM(ILPOS+1:ILPOS+4),33) INODE 40.30
END IF 40.30
!PUN FILENM = TRIM(LOCALDIR)//DIRCH2//TRIM(FILENM) 40.95
ELSE
NREF = PRINTF
ENDIF
ORQTMP%PSNAME = PSNAME 40.31
ORQTMP%OQI(1) = NREF 40.31
ORQTMP%OQI(2) = NREOQ 40.31
OUTP_FILES(NREOQ) = FILENM 40.31 40.13
!
NVAR = 0
ORQTMP%OQI(3) = NVAR 40.31
! read types of variables to be printed in the table
FRST%I = 0 40.31
NULLIFY(FRST%NEXTI) 40.31
CURR => FRST 40.31
80 CALL SVARTP (IVTYPE)
IF (IVTYPE .EQ. 98) GOTO 90 30.00
IF (IVTYPE .NE. 999) THEN
IF ( INDEX(FILENM,'.NC').NE.0 .OR. 41.52
& INDEX(FILENM,'.nc').NE.0 ) THEN 41.52
IF ( IVTYPE.GT.2.AND.IVTYPE.NE.40 ) THEN 41.52
call stnames_init() 41.52
IF ( STNAMES(IVTYPE,1).EQ. ' ' ) CALL MSGERR (2, 41.52
& 'netCDF table does not support '//OVKEYW(IVTYPE)) 41.52
ENDIF 41.52
ENDIF 41.52
IF (OVSVTY(IVTYPE).EQ.5) THEN
CALL MSGERR (2,
& 'Type of output not allowed for this quantity')
WRITE (PRINTF, *) ' -> ', OVSNAM(IVTYPE)
ELSE IF (IVTYPE.GT.100 .AND. IVTYPE.LT.110) THEN 41.62
CALL MSGERR (2,'Invalid partitioning output '// 41.62
& 'specification. Use PTHSIGN instead.') 41.62
WRITE (PRINTF, *) ' -> ', OVSNAM(IVTYPE) 41.62
ELSE IF (IVTYPE.GT.110 .AND. IVTYPE.LT.120) THEN 41.62
CALL MSGERR (2,'Invalid partitioning output '// 41.62
& 'specification. Use PTRTP instead.') 41.62
WRITE (PRINTF, *) ' -> ', OVSNAM(IVTYPE) 41.62
ELSE IF (IVTYPE.GT.120 .AND. IVTYPE.LT.130) THEN 41.62
CALL MSGERR (2,'Invalid partitioning output '// 41.62
& 'specification. Use PTWLEN instead.') 41.62
WRITE (PRINTF, *) ' -> ', OVSNAM(IVTYPE) 41.62
ELSE IF (IVTYPE.GT.130 .AND. IVTYPE.LT.140) THEN 41.62
CALL MSGERR (2,'Invalid partitioning output '// 41.62
& 'specification. Use PTDIR instead.') 41.62
WRITE (PRINTF, *) ' -> ', OVSNAM(IVTYPE) 41.62
ELSE IF (IVTYPE.GT.140 .AND. IVTYPE.LT.150) THEN 41.62
CALL MSGERR (2,'Invalid partitioning output '// 41.62
& 'specification. Use PTDSPR instead.') 41.62
WRITE (PRINTF, *) ' -> ', OVSNAM(IVTYPE) 41.62
ELSE IF (IVTYPE.GT.150 .AND. IVTYPE.LT.160) THEN 41.62
CALL MSGERR (2,'Invalid partitioning output '// 41.62
& 'specification. Use PTWFRAC instead.') 41.62
WRITE (PRINTF, *) ' -> ', OVSNAM(IVTYPE) 41.62
ELSE IF (IVTYPE.GT.160 .AND. IVTYPE.LT.170) THEN 41.62
CALL MSGERR (2,'Invalid partitioning output '// 41.62
& 'specification. Use PTSTEEPNESS instead.') 41.62
WRITE (PRINTF, *) ' -> ', OVSNAM(IVTYPE) 41.62
ELSE IF (IVTYPE.GT.0 .AND. IVTYPE.LT.100) THEN 41.62
NVAR = NVAR+1
ALLOCATE(TMP) 40.31
TMP%I = IVTYPE 40.31
NULLIFY(TMP%NEXTI) 40.31
CURR%NEXTI => TMP 40.31
CURR => TMP 40.31
IF (IVTYPE.EQ.18) IUBOTR = 1
IF (IVTYPE.EQ.50 .AND. JPBOT.LE.1) THEN 40.65
MCMVAR = MCMVAR+1 40.65
JPBOT = MCMVAR 40.65
ALOCMP = .TRUE. 40.97
ENDIF 40.65
IF (IVTYPE.EQ.54 .AND. JDSXB.LE.1) THEN 40.65
MCMVAR = MCMVAR+1 40.65
JDSXB = MCMVAR 40.65
ALOCMP = .TRUE. 40.97
ENDIF 40.65
IF (IVTYPE.EQ.55 .AND. JDSXS.LE.1) THEN 40.65
MCMVAR = MCMVAR+1 40.65
JDSXS = MCMVAR 40.65
ALOCMP = .TRUE. 40.97
ENDIF 40.65
IF (IVTYPE.EQ.56 .AND. JDSXW.LE.1) THEN 40.65
MCMVAR = MCMVAR+1 40.65
JDSXW = MCMVAR 40.65
ALOCMP = .TRUE. 40.97
ENDIF 40.65
IF (IVTYPE.EQ.57 .AND. JDSXV.LE.1) THEN 40.65
MCMVAR = MCMVAR+1 40.65
JDSXV = MCMVAR 40.65
ALOCMP = .TRUE. 40.97
ENDIF 40.65
IF (IVTYPE.EQ.60 .AND. JGENR.LE.1) THEN 40.85
MCMVAR = MCMVAR+1 40.85
JGENR = MCMVAR 40.85
ALOCMP = .TRUE. 40.97
ENDIF 40.85
IF (IVTYPE.EQ.61 .AND. JGSXW.LE.1) THEN 40.85
MCMVAR = MCMVAR+1 40.85
JGSXW = MCMVAR 40.85
ALOCMP = .TRUE. 40.97
ENDIF 40.85
IF (IVTYPE.EQ.62 .AND. JREDS.LE.1) THEN 40.85
MCMVAR = MCMVAR+1 40.85
JREDS = MCMVAR 40.85
ALOCMP = .TRUE. 40.97
ENDIF 40.85
IF (IVTYPE.EQ.63 .AND. JRSXQ.LE.1) THEN 40.85
MCMVAR = MCMVAR+1 40.85
JRSXQ = MCMVAR 40.85
ALOCMP = .TRUE. 40.97
ENDIF 40.85
IF (IVTYPE.EQ.64 .AND. JRSXT.LE.1) THEN 40.85
MCMVAR = MCMVAR+1 40.85
JRSXT = MCMVAR 40.85
ALOCMP = .TRUE. 40.97
ENDIF 40.85
IF (IVTYPE.EQ.65 .AND. JTRAN.LE.1) THEN 40.85
MCMVAR = MCMVAR+1 40.85
JTRAN = MCMVAR 40.85
ALOCMP = .TRUE. 40.97
ENDIF 40.85
IF (IVTYPE.EQ.66 .AND. JTSXG.LE.1) THEN 40.85
MCMVAR = MCMVAR+1 40.85
JTSXG = MCMVAR 40.85
ALOCMP = .TRUE. 40.97
ENDIF 40.85
IF (IVTYPE.EQ.67 .AND. JTSXT.LE.1) THEN 40.85
MCMVAR = MCMVAR+1 40.85
JTSXT = MCMVAR 40.85
ALOCMP = .TRUE. 40.97
ENDIF 40.85
IF (IVTYPE.EQ.68 .AND. JTSXS.LE.1) THEN 40.85
MCMVAR = MCMVAR+1 40.85
JTSXS = MCMVAR 40.85
ALOCMP = .TRUE. 40.97
ENDIF 40.85
IF (IVTYPE.EQ.69 .AND. JRADS.LE.1) THEN 40.85
MCMVAR = MCMVAR+1 40.85
JRADS = MCMVAR 40.85
ALOCMP = .TRUE. 40.97
ENDIF 40.85
IF (IVTYPE.EQ.72 .AND. JDSXT.LE.1) THEN 40.35
MCMVAR = MCMVAR+1 40.35
JDSXT = MCMVAR 40.35
ALOCMP = .TRUE. 40.35
ENDIF 40.35
IF (IVTYPE.EQ.74 .AND. JDSXM.LE.1) THEN 40.65
MCMVAR = MCMVAR+1 40.65
JDSXM = MCMVAR 40.65
ALOCMP = .TRUE. 40.97
ENDIF 40.65
IF (IVTYPE.EQ.75 .AND. JDSXL.LE.1) THEN 40.88
MCMVAR = MCMVAR+1 40.88
JDSXL = MCMVAR 40.88
ALOCMP = .TRUE. 40.88
ENDIF 40.88
#ifdef SWAN_MODEL
IF (IVTYPE.EQ.76 .AND. JDBOT.LE.1) THEN !PSD 09/21/2011
MCMVAR = MCMVAR+1 !PSD 09/21/2011
JDBOT = MCMVAR !PSD 09/21/2011
ALOCMP = .TRUE. !PSD 09/21/2011
ENDIF !PSD 09/21/2011
#endif
IF (IVTYPE.EQ.7 .OR. IVTYPE.EQ.9 .OR. 40.85
& IVTYPE.EQ.54 .OR. IVTYPE.EQ.55 .OR. 40.85
& IVTYPE.EQ.56 .OR. IVTYPE.EQ.57 .OR. 40.85
& IVTYPE.GE.60 ) LADDS = .TRUE. 40.85
CALL INKEYW ('STA', ' ') 40.00
IF (KEYWIS('UNIT')) THEN
CALL MSGERR (1, 'UNIT is ignored in this version') 40.00
ENDIF
ELSE IF (IVTYPE.LT.170) THEN 41.62
! add all 10 partitions of requested partition parameter
DO IVT = IVTYPE, IVTYPE+9 41.62
NVAR = NVAR+1 41.62
ALLOCATE(TMP) 41.62
TMP%I = IVT 41.62
TMP%R = DFAC 41.62
NULLIFY(TMP%NEXTI) 41.62
CURR%NEXTI => TMP 41.62
CURR => TMP 41.62
ENDDO 41.62
CALL INKEYW ('STA', ' ') 40.00
IF (KEYWIS('UNIT')) THEN
CALL MSGERR (1, 'UNIT is ignored in this version') 40.00
ENDIF
ENDIF
GOTO 80
ENDIF
90 IF (NVAR.GT.0) THEN 40.31
ALLOCATE(ORQTMP%IVTYP(NVAR)) 40.31
CURR => FRST%NEXTI 40.31
DO JJ = 1, NVAR 40.31
ORQTMP%IVTYP(JJ) = CURR%I 40.31
CURR => CURR%NEXTI 40.31
END DO 40.31
DEALLOCATE(TMP) 40.31
END IF 40.31
IF ( RTYPE.EQ.'TABC') THEN
ALLOCATE(ORQTMP%FAC(NVAR))
ORQTMP%FAC=1.
ELSE
ALLOCATE(ORQTMP%FAC(0)) 40.31
ENDIF
IF (IVTYPE .EQ. 98) THEN 30.00
IF (NSTATM.EQ.0) CALL MSGERR (3,
& 'time information not allowed in stationary mode')
NSTATM = 1
CALL INCTIM (ITMOPT, 'TBEG', ORQTMP%OQR(1), 'REQ', 0D0) 40.31 30.00
CALL INITVD ('DELT', ORQTMP%OQR(2), 'REQ', 0D0) 40.31 30.00
ENDIF
ORQTMP%OQI(3) = NVAR 40.31
NULLIFY(ORQTMP%NEXTORQ) 40.31
IF ( .NOT.LORQ ) THEN 40.31
#ifdef SWAN_MODEL
ORQDATZ_MOD(ng)%FORQ = ORQTMP 40.31
CORQ => ORQDATZ_MOD(ng)%FORQ 40.31
#else
FORQ = ORQTMP 40.31
CORQ => FORQ 40.31
#endif
LORQ = .TRUE. 40.31
ELSE 40.31
CORQ%NEXTORQ => ORQTMP 40.31
CORQ => ORQTMP 40.31
END IF 40.31
GOTO 800
ENDIF
!
! PLOT plot iso lines and/or vector fields
!
! --------------------------------------------------------------------------
IF (KEYWIS ('PLO')) THEN
CALL MSGERR(2,'Keyword PLO... is no longer maintained') 40.31
GOTO 800
ENDIF
!
! --------------------------------------------------------------------------
! SPECout 'sname' SPEC1D/SPEC2D ABS/REL 'fname' &
! (MONth ESCAle MDGRID COMPress NOAUX) (NOT documented) &
! (OUTPUT [tbegspc] [deltspc] SEC/MIN/HR/DAY)
! --------------------------------------------------------------------------
! SPEC output of spectra
IF (KEYWIS ('SPEC')) THEN
#ifdef SWAN_MODEL
CALL SWNMPS (PSNAME, STYPE, MIP, IERR, ng)
#else
CALL SWNMPS (PSNAME, STYPE, MIP, IERR) 40.31
#endif
IF (IERR.NE.0) GOTO 800
!
! output points exist
!
ALLOCATE(ORQTMP) 40.31
NREOQ = NREOQ + 1 40.31
IF (NREOQ.GT.MAX_OUTP_REQ) CALL MSGERR (2, 40.31 40.13
& 'too many output requests') 40.13
!
CALL INKEYW ('STA', 'SPEC2D') 20.67
IF (KEYWIS ('FS1D') .OR. KEYWIS('SPEC1D')) THEN 20.67
RTYPE = 'SPE1' 20.28
ELSE
CALL IGNORE ('SFD') 20.28
CALL IGNORE ('SPEC2D') 20.67
RTYPE = 'SPEC'
ENDIF
CALL INKEYW ('STA', 'ABS') 40.03
IF (KEYWIS ('REL')) THEN 40.03
RTYPE(3:3) = 'R' 20.28
ELSE
CALL IGNORE ('ABS') 40.03
ENDIF
ORQTMP%OQR(1) = -1. 40.31
ORQTMP%OQR(2) = -1. 40.31
ORQTMP%RQTYPE = RTYPE 40.31
CALL INCSTR ('FNAME', FILENM, 'REQ', ' ')
NREF = 0
! --- append node number to FILENM in case of 40.30
! parallel computing 40.30
IF ( PARLL ) THEN 40.30
ILPOS = INDEX ( FILENM, ' ' )-1 40.30
WRITE(FILENM(ILPOS+1:ILPOS+4),33) INODE 40.30
END IF 40.30
!PUN FILENM = TRIM(LOCALDIR)//DIRCH2//TRIM(FILENM) 40.95
ORQTMP%PSNAME = PSNAME 40.31
ORQTMP%OQI(1) = NREF 40.31
ORQTMP%OQI(2) = NREOQ 40.31
OUTP_FILES(NREOQ) = FILENM 40.31 40.13
!
CALL INKEYW ('STA', ' ') 41.40
! declare monthly netCDF file 41.40
! store in oqi(4) differ from idla of block! 41.40
ORQTMP%OQI(4) = 0 41.40
IF (KEYWIS('MON')) THEN 41.40
ORQTMP%OQI(4) = ORQTMP%OQI(4) + 1 41.40
ENDIF 41.40
CALL INKEYW ('STA', ' ') 41.40
IF (KEYWIS('ESCA')) THEN 41.40
ORQTMP%OQI(4) = ORQTMP%OQI(4) + 2 41.40
ENDIF 41.40
CALL INKEYW ('STA', ' ')
IF (KEYWIS('COMP')) THEN
ORQTMP%OQI(4) = ORQTMP%OQI(4) + 4
ENDIF
CALL INKEYW ('STA', ' ')
IF (KEYWIS('MDGRID')) THEN
ORQTMP%OQI(4) = ORQTMP%OQI(4) + 8
ENDIF
CALL INKEYW ('STA', ' ')
IF (KEYWIS('NOAUX')) THEN
ORQTMP%OQI(4) = ORQTMP%OQI(4) + 16
ENDIF
CALL INKEYW ('STA', ' ')
!
NVAR = 0 40.31
ORQTMP%OQI(3) = NVAR 40.31
ALLOCATE(ORQTMP%IVTYP(0)) 40.31
ALLOCATE(ORQTMP%FAC(0)) 40.31
! read types of variables to be printed in the table
CALL INKEYW ('STA', ' ') 30.00
IF (KEYWIS ('OUT')) THEN 40.03
IF (NSTATM.EQ.0) CALL MSGERR (3,
& 'time information not allowed in stationary mode')
NSTATM = 1
CALL INCTIM (ITMOPT, 'TBEG', ORQTMP%OQR(1), 'REQ', 0D0) 40.31 30.00
CALL INITVD ('DELT', ORQTMP%OQR(2), 'REQ', 0D0) 40.31 30.00
IF (NSTATM.EQ.0) CALL MSGERR (2,
& 'time input not allowed in stationary mode')
ENDIF
NULLIFY(ORQTMP%NEXTORQ) 40.31
IF ( .NOT.LORQ ) THEN 40.31
#ifdef SWAN_MODEL
ORQDATZ_MOD(ng)%FORQ = ORQTMP 40.31
CORQ => ORQDATZ_MOD(ng)%FORQ 40.31
#else
FORQ = ORQTMP 40.31
CORQ => FORQ 40.31
#endif
LORQ = .TRUE. 40.31
ELSE 40.31
CORQ%NEXTORQ => ORQTMP 40.31
CORQ => ORQTMP 40.31
END IF 40.31
GOTO 800
END IF
! --------------------------------------------------------------------------
! NESTout 'sname' 'fname' &
! (OUTPUT [tbegnst] [deltnst] SEC/MIN/HR/DAY)
! --------------------------------------------------------------------------
! NEST output for nesting of models VER. 20.63
IF (KEYWIS ('NEST')) THEN 40.00
!
! ======================================================================
!
! NESTout 'sname' 'fname' &
!
! | -> Sec |
! OUTput [tbegnst] [deltnst] < MIn >
! | HR |
! | DAy |
!
! =======================================================================
!
IF (ONED) THEN 32.02
CALL MSGERR (2,' Illegal keyword (NEST) in'// 32.02
& ' combination with 1D-computation') 32.02
GOTO 800 32.02
ELSE 32.02
#ifdef SWAN_MODEL
CALL SWNMPS (PSNAME, STYPE, MIP, IERR, ng)
#else
CALL SWNMPS (PSNAME, STYPE, MIP, IERR) 40.31
#endif
IF (IERR.NE.0) GOTO 800
IF (STYPE .NE. 'N') THEN
CALL MSGERR(2,'Set of output locations is not correct type')
GOTO 800
ENDIF
! output points exist
ALLOCATE(ORQTMP) 40.31
NREOQ = NREOQ + 1 40.31
IF (NREOQ.GT.MAX_OUTP_REQ) CALL MSGERR (2, 40.31 40.13
& 'too many output requests') 40.13
ORQTMP%OQR(1) = -1. 40.31
ORQTMP%OQR(2) = -1. 40.31
RTYPE = 'SPRC' 40.00
ORQTMP%RQTYPE = RTYPE 40.31
CALL INCSTR ('FNAME', FILENM, 'REQ', ' ')
NREF = 0
! --- append node number to FILENM in case of 40.30
! parallel computing 40.30
IF ( PARLL ) THEN 40.30
ILPOS = INDEX ( FILENM, ' ' )-1 40.30
WRITE(FILENM(ILPOS+1:ILPOS+4),33) INODE 40.30
END IF 40.30
!PUN FILENM = TRIM(LOCALDIR)//DIRCH2//TRIM(FILENM) 40.95
ORQTMP%PSNAME = PSNAME 40.31
ORQTMP%OQI(1) = NREF 40.31
ORQTMP%OQI(2) = NREOQ 40.31
OUTP_FILES(NREOQ) = FILENM 40.31 40.13
NVAR = 0 40.31
ORQTMP%OQI(3) = NVAR 40.31
! scale spectra and do not store auxillary variables
IF ( INDEX( FILENM, '.NC' ).NE.0 .OR.
& INDEX (FILENM, '.nc' ).NE.0 )
& ORQTMP%OQI(4) = 18
ALLOCATE(ORQTMP%IVTYP(0)) 40.31
ALLOCATE(ORQTMP%FAC(0)) 40.31
!
CALL INKEYW ('STA', ' ') 30.00
IF (KEYWIS ('OUT')) THEN 40.03
IF (NSTATM.EQ.0) CALL MSGERR (3,
& 'time information not allowed in stationary mode')
NSTATM = 1
CALL INCTIM (ITMOPT, 'TBEG', ORQTMP%OQR(1), 'REQ', 0D0) 40.31 30.00
CALL INITVD ('DELT', ORQTMP%OQR(2), 'REQ', 0D0) 40.31 30.00
IF (NSTATM.EQ.0) CALL MSGERR (2,
& 'time input not allowed in stationary mode')
ENDIF
!
NULLIFY(ORQTMP%NEXTORQ) 40.31
IF ( .NOT.LORQ ) THEN 40.31
#ifdef SWAN_MODEL
ORQDATZ_MOD(ng)%FORQ = ORQTMP 40.31
CORQ => ORQDATZ_MOD(ng)%FORQ 40.31
#else
FORQ = ORQTMP 40.31
CORQ => FORQ 40.31
#endif
LORQ = .TRUE. 40.31
ELSE 40.31
CORQ%NEXTORQ => ORQTMP 40.31
CORQ => ORQTMP 40.31
END IF 40.31
GOTO 800
ENDIF 32.02
ENDIF
! -------------------------------------------------------
! command not found:
RETURN
800 FOUND = .TRUE.
RETURN
!* end of subroutine SWREOQ **
END
!***********************************************************************
! *
INTEGER FUNCTION SIRAY (DP, XP1, YP1, XP2, YP2, XX, YY, BOTDEP, 30.70
& BOTLEV, WATLEV) 30.70
! *
!***********************************************************************
!
USE OCPCOMM4 40.41
USE SWCOMM2 40.41
USE SWCOMM3 40.41
!
!
! --|-----------------------------------------------------------|--
! | Delft University of Technology |
! | Faculty of Civil Engineering |
! | Environmental Fluid Mechanics Section |
! | P.O. Box 5048, 2600 GA Delft, The Netherlands |
! | |
! | Programmers: The SWAN team |
! --|-----------------------------------------------------------|--
!
!
! SWAN (Simulating WAves Nearshore); a third generation wave model
! Copyright (C) 1993-2017 Delft University of Technology
!
! This program is free software; you can redistribute it and/or
! modify it under the terms of the GNU General Public License as
! published by the Free Software Foundation; either version 2 of
! the License, or (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! A copy of the GNU General Public License is available at
! http://www.gnu.org/copyleft/gpl.html#SEC3
! or by writing to the Free Software Foundation, Inc.,
! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
!
!
! 0. AUTHORS
!
! 30.72: IJsbrand Haagsma
! 40.41: Marcel Zijlema
!
! 1. UPDATE
!
! 00.00, Mar. 87: heading added, name of routine changed from
! IRAAI in SIRAY
! 30.72, Oct. 97: logical function EQREAL introduced for floating point
! comparisons
! 30.70, Nov. 97: changed into INTEGER function
! test output added
! arguments BOTDEP, BOTLEV, WATLEV added
! 40.03, Nov. 99: X2= etc. moved out of IF-ENDIF group
! 40.41, Oct. 04: common blocks replaced by modules, include files removed
!
! 2. PURPOSE
!
! Searching the first point on a ray where the depth is DP
!
! 3. METHOD
!
! ---
!
! 4. PARAMETERLIST
!
! DP REAL input depth
! XP1 REAL input X-coordinate start point of ray
! YP1 REAL input Y-coordinate start point of ray
! XP2 REAL input X-coordinate end point of ray
! YP2 REAL input Y-coordinate end point of ray
! XX REAL input X-coordinate point with depth DP
! YY REAL input Y-coordinate point with depth DP
!
! 5. SUBROUTINES CALLING
!
! SWREPS (SWAN/READ)
!
! 6. SUBROUTINES USED
!
! SVALQI (SWAN/READ)
!
! 7. ERROR MESSAGES
!
! ---
!
! 8. REMARKS
!
! ---
!
! 9. STRUCTURE
!
! ----------------------------------------------------------------
! Give SIRAY initial value 0
! Compute stepsize, raylength and number of steps along the ray
! Compute bottom coordinates of startpoint as number of meshes
! Call SVALQI to interpolate depth in startpoint of ray
! For every step along the ray do
! Compute coordinates of the intermediate point in problem
! grid and bottom grid
! Call SVALQI to interpolate the depth for this point
! If the required depth is in the interval, then
! Compute coordinates of the point with depth DP
! Set SIRAY 1
! Else
! Coordinates and depth at start of new interval are values
! at end of old interval
! ----------------------------------------------------------------
! 10. SOURCE TEXT
!
LOGICAL EQREAL, BOTDEP 30.72
REAL BOTLEV(*), WATLEV(*) 30.70
SAVE IENT
DATA IENT/0/
CALL STRACE (IENT,'SIRAY')
!
SIRAY = 0
DIFDEP = 1e+10
DSTEP = MIN(DXG(1), DYG(1))
RAYLEN = SQRT ((XP2-XP1)*(XP2-XP1) + (YP2-YP1)*(YP2-YP1))
NSTEP = 1 + INT(1.5*RAYLEN/DSTEP + 0.5) 30.70
!
DO 10 JJ = 0, NSTEP 30.70
X3 = XP1 + REAL(JJ)*(XP2-XP1)/REAL(NSTEP)
Y3 = YP1 + REAL(JJ)*(YP2-YP1)/REAL(NSTEP)
IF (BOTDEP) THEN
D3 = SVALQI (X3, Y3, 1, BOTLEV, 1, 0, 0) 30.70
ELSE
D3 = SVALQI (X3, Y3, 1, BOTLEV, 1, 0, 0) + WLEV 30.70
IF (LEDS(7).GE.2) 30.70
& D3 = D3 + SVALQI (X3, Y3, 7, WATLEV, 1, 0, 0) 30.70
ENDIF
IF (ITEST.GE.160) WRITE (PRTEST, 14) X3+XOFFS, Y3+YOFFS, D3 30.70
14 FORMAT (' SIRAY, scan point', 2(1X,F8.0), 1X, F8.2) 30.70
IF (ABS(D3-DP).LT.DIFDEP) THEN 10.20
DIFDEP=ABS(D3-DP) 10.20
JDMINMAX=JJ 10.20
ENDIF
IF (JJ.GT.0) THEN
IF ((DP-D2)*(DP-D3).LE.0) THEN 40.03
IF (EQREAL(D2,D3)) THEN 30.72
XX = X2
YY = Y2
ELSE
XX = X2+(X3-X2)*(D2-DP)/(D2-D3)
YY = Y2+(Y3-Y2)*(D2-DP)/(D2-D3)
ENDIF
SIRAY = 1
GOTO 20
ENDIF 40.03
ENDIF 40.03
X2 = X3
Y2 = Y3
D2 = D3
10 CONTINUE
!
! exact depth not found, take closest value:
!
X3 = XP1 + REAL(JDMINMAX)*(XP2-XP1)/REAL(NSTEP) 10.20
Y3 = YP1 + REAL(JDMINMAX)*(YP2-YP1)/REAL(NSTEP) 10.20
XX = X3 10.20
YY = Y3 10.20
!
20 IF (ITEST.GE.140) WRITE (PRTEST, 24) XX+XOFFS, YY+YOFFS 30.70
24 FORMAT (' SIRAY, result ', 2(1X,F8.0)) 30.70
RETURN
! * end of function SIRAY *
END
!************************************************************************
! *
#ifdef SWAN_MODEL
SUBROUTINE SWNMPS (PSNAME, PSTYPE, MIP, IERR, ng)
#else
SUBROUTINE SWNMPS (PSNAME, PSTYPE, MIP, IERR) 40.31
#endif
! *
!************************************************************************
!
USE OCPCOMM1 40.41
USE OCPCOMM4 40.41
USE SWCOMM1 40.41
USE OUTP_DATA 40.31
!
!
! --|-----------------------------------------------------------|--
! | Delft University of Technology |
! | Faculty of Civil Engineering |
! | Environmental Fluid Mechanics Section |
! | P.O. Box 5048, 2600 GA Delft, The Netherlands |
! | |
! | Programmers: The SWAN team |
! --|-----------------------------------------------------------|--
!
!
! SWAN (Simulating WAves Nearshore); a third generation wave model
! Copyright (C) 1993-2017 Delft University of Technology
!
! This program is free software; you can redistribute it and/or
! modify it under the terms of the GNU General Public License as
! published by the Free Software Foundation; either version 2 of
! the License, or (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! A copy of the GNU General Public License is available at
! http://www.gnu.org/copyleft/gpl.html#SEC3
! or by writing to the Free Software Foundation, Inc.,
! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
!
!
! 0. Authors
! 40.41: Marcel Zijlema
!
! 1. UPDATE
!
! Oct. 1996, ver. 30.50: new subr.
! 40.41, Oct. 04: common blocks replaced by modules, include files removed
!
! 2. PURPOSE
!
! Read name of set of output points; get type and number of
! points in the set
!
! 3. METHOD
!
!
! 4. PARAMETERLIST
!
! PSNAME char output name
! PSTYPE char output type
! MIP int output number of points
!
! 5. SUBROUTINES CALLING
!
! SPREOQ
!
! 6. SUBROUTINES USED
!
! INCSTR (Ocean Pack)
!
! 7. ERROR MESSAGES
!
! ---
!
! 8. REMARKS
!
! ---
!
! 9. STRUCTURE
!
!
! 10. SOURCE TEXT
!
#ifdef SWAN_MODEL
INTEGER, INTENT(IN) :: ng
#endif
INTEGER MIP 40.31
CHARACTER PSNAME *(*), PSTYPE *1 40.31
TYPE(OPSDAT), POINTER :: CUOPS 40.31
SAVE IENT
DATA IENT/0/
CALL STRACE (IENT,'SWNMPS')
!
IERR = 0
CALL INCSTR ('SNAME', PSNAME, 'STA', 'BOTTGRID')
IF (LENCST.GT.8) CALL MSGERR (2, 'SNAME is too long')
#ifdef SWAN_MODEL
CUOPS => OPSDATZ_MOD(ng)%FOPS
#else
CUOPS => FOPS 40.31
#endif
DO 40.31
IF (CUOPS%PSNAME.EQ.PSNAME) EXIT 40.31
IF (.NOT.ASSOCIATED(CUOPS%NEXTOPS)) THEN 40.31
CALL MSGERR(2, 'Set of output locations is not known') 40.31
GOTO 900 40.31
END IF 40.31
CUOPS => CUOPS%NEXTOPS 40.31
END DO 40.31
PSTYPE = CUOPS%PSTYPE 40.31
IF (PSTYPE.EQ.'F' .OR. PSTYPE.EQ.'H') THEN 40.31
MIP = CUOPS%OPI(1) * CUOPS%OPI(2) 40.31
! get direction of frame in case of coordinates plotting
ALPQ = CUOPS%OPR(5) 40.31
ELSE
MIP = CUOPS%MIP 40.31
ALPQ = 0. 40.31
ENDIF
800 IF (ITEST.GE.100) WRITE (PRTEST, 802) PSNAME, PSTYPE, MIP
802 FORMAT (' exit SWNMPS, name:', A8, ' type:', A1,
& ' num of p:', I5)
RETURN
900 PSTYPE = ' '
MIP = 0
IERR = 1
RETURN
END
!************************************************************************
! *
SUBROUTINE SVARTP (IVTYPE)
! *
!************************************************************************
!
USE SWCOMM1 40.41
!
!
! --|-----------------------------------------------------------|--
! | Delft University of Technology |
! | Faculty of Civil Engineering |
! | Environmental Fluid Mechanics Section |
! | P.O. Box 5048, 2600 GA Delft, The Netherlands |
! | |
! | Programmers: The SWAN team |
! --|-----------------------------------------------------------|--
!
!
! SWAN (Simulating WAves Nearshore); a third generation wave model
! Copyright (C) 1993-2017 Delft University of Technology
!
! This program is free software; you can redistribute it and/or
! modify it under the terms of the GNU General Public License as
! published by the Free Software Foundation; either version 2 of
! the License, or (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! A copy of the GNU General Public License is available at
! http://www.gnu.org/copyleft/gpl.html#SEC3
! or by writing to the Free Software Foundation, Inc.,
! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
!
!
! 0. Authors
!
! 32.02: Roeland Ris & Cor van der Schelde
! 40.03: Nico Booij
! 40.04: Annette Kieftenburg
!
! 1. Updates
!
! 10.09, Aug. 94: output quantity RPER added
! 20.61, Sep. 95: quantities TM02 and FWID added
! 20.67, Dec. 95: FWID renamed FSPR (freq. spread)
! 32.02, Feb. 98: 1D-version introduced
! 40.00, Apr. 98: subr simplified using new array OVKEYW
! 40.03, Sep. 00: inconsistency with manual corrected
!
! 2. Purpose
!
! Converting keyword into integer
!
! 3. Method
!
! This subroutine determines an integer value indicating the
! required output variable from the keyword denoting the same
! for storage in array with output requests.
!
! 4. PARAMETERLIST
!
! IVTYPE INT output type number output variable
!
! 5. Subroutines calling
!
! SPROUT
!
! 6. Subroutines used
!
! KEYWIS (Ocean Pack)
!
! 10. Error messages
!
! ---
!
! 11. Remarks
!
! ---
!
! 12. Structure
!
! -----------------------------------------------------------------
! If the keyword is equal to given string, then
! IVTYPE is given integer value
! -----------------------------------------------------------------
!
! 13. Source text
!
LOGICAL KEYWIS
SAVE IENT
DATA IENT/0/
CALL STRACE (IENT,'SVARTP')
!
IVTYPE = 0
!
CALL INKEYW ('STA', 'ZZZZ')
! check if given keyword corresponds to output quantity
DO IVT = NMOVAR, 1, -1
! loop in reverse order to check more specific names first
! e.g. HSWE before HS
IF (KEYWIS (OVKEYW(IVT))) THEN 40.00
IVTYPE = IVT 40.00
GOTO 40
ENDIF
ENDDO
! aliases:
IF (KEYWIS ('PPER')) IVTYPE = 12 40.00
IF (KEYWIS ('RPER')) IVTYPE = 28 40.00
IF (KEYWIS ( 'DTM')) IVTYPE = 31 40.00
IF (KEYWIS ('FWID')) IVTYPE = 33 40.00
! keyword OUTPUT means that output times will be entered 40.00
IF (KEYWIS ('OUT')) IVTYPE = 98 40.03
! keyword ZZZZ means end of list of output quantities 40.00
IF (KEYWIS ('ZZZZ')) IVTYPE = 999
!
IF (IVTYPE .EQ. 0) CALL WRNKEY
!
40 RETURN
! end of subroutine SVARTP *
END
!************************************************************************
! *
#ifdef SWAN_MODEL
SUBROUTINE SWBOUN ( XCGRID, YCGRID, KGRPNT, XYTST, KGRBND, ng)
#else
SUBROUTINE SWBOUN ( XCGRID, YCGRID, KGRPNT, XYTST, KGRBND ) 40.31
#endif
! *
!************************************************************************
!
USE OCPCOMM2 40.41
USE OCPCOMM4 40.41
USE SWCOMM1 40.41
USE SWCOMM2 40.41
USE SWCOMM3 40.41
USE M_BNDSPEC 40.31
USE SwanGriddata 40.80
USE SwanGridobjects 40.80
USE SwanCompdata 40.80
!
!
! --|-----------------------------------------------------------|--
! | Delft University of Technology |
! | Faculty of Civil Engineering |
! | Environmental Fluid Mechanics Section |
! | P.O. Box 5048, 2600 GA Delft, The Netherlands |
! | |
! | Programmers: The SWAN team |
! --|-----------------------------------------------------------|--
!
!
! SWAN (Simulating WAves Nearshore); a third generation wave model
! Copyright (C) 1993-2017 Delft University of Technology
!
! This program is free software; you can redistribute it and/or
! modify it under the terms of the GNU General Public License as
! published by the Free Software Foundation; either version 2 of
! the License, or (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! A copy of the GNU General Public License is available at
! http://www.gnu.org/copyleft/gpl.html#SEC3
! or by writing to the Free Software Foundation, Inc.,
! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
!
!
! 0. Authors
!
! 30.73: Nico Booij
! 30.81: Annette Kieftenburg
! 30.82: IJsbrand Haagsma
! 30.90: IJsbrand Haagsma (Equivalence version)
! 34.01: Jeroen Adema
! 40.02: IJsbrand Haagsma
! 40.03, 40.13: Nico Booij
! 40.05: Ekaterini E. Kriezi
! 40.31: Marcel Zijlema
! 40.41: Marcel Zijlema
! 40.80: Marcel Zijlema
! 40.92: Marcel Zijlema
! 41.14: Nico Booij
!
! 1. Updates
!
! 30.73, Nov. 97: New subroutine, replacing code in subr. SWREAD (file SWANPRE1)
! 30.90, Oct. 98: Introduced EQUIVALENCE POOL-arrays
! 30.82, Oct. 98: Updated description several arrays
! 30.81, Nov. 98: Adjustment for 1-D case of new boundary conditions
! 34.01, Feb. 99: Introducing STPNOW
! 30.81, Apr. 99: Prevent negative powers for cosine directional spreading (DSPR);
! prevented DSPR > 360 and DSPR < 0 (except for exception value).
! 30.82, July 99: Used EQREAL for real equality comparisons
! 40.05, Aug 00: WW3 boundary nesting command, in Swan nesting option
! adding of a new option (same as WW3 command)
! 40.03, Sep. 00: inconsistency with manual corrected
! 40.02, Oct. 00: WWIII added as keyword (will appear in the manual)
! 40.13, Nov. 01: determination of side corrected (iside=3)
! 40.31, Nov. 03: removing POOL-mechanism, reconsideration of this subroutine
! 40.41, Oct. 04: common blocks replaced by modules, include files removed
! 40.80, Jun. 07: extension to unstructured grids
! 40.92, Jun. 08: changes with respect to boundary polygons
! 41.14, Jul. 10: call SwanBndStruc added
!
! 2. Purpose
!
! Reading and processing BOUNDARY command
!
! 3. Method
!
!
! 4. Argument variables
!
! i XCGRID: Coordinates of computational grid in x-direction 30.82
! i YCGRID: Coordinates of computational grid in y-direction 30.82
!
#ifdef SWAN_MODEL
INTEGER, INTENT(in) :: ng
#endif
REAL XCGRID(MXC,MYC), YCGRID(MXC,MYC) 30.82
!
! KGRBND int inp grid indices of boundary points 40.31
! KGRPNT int inp indirect addresses of grid points
! XYTST int inp ix, iy of test points
!
INTEGER KGRPNT(MXC,MYC)
INTEGER XYTST(*), KGRBND(*)
!
! 5. Parameter variables
!
!
! 6. Local variables
!
INTEGER IENT,KOUNTR,IX1,IY1,IX2,IY2
INTEGER MM,IX,IY,ISIDM,ISIDE,KC,KC2,KC1,IX3,IY3,MP
INTEGER IP,II,NBSPSS,NFSEQ,IKO,IKO2,IBSPC1,IBSPC2
INTEGER VM 40.80
INTEGER, DIMENSION(:), ALLOCATABLE :: IARR1, IARR2 40.92
REAL CRDP, CRDM, SOMX, SOMY
REAL XP,YP,XC,YC,RR,DIRSI,COSDIR,SINDIR,DIRSID,DIRREF
REAL RLEN1,RDIST,RLEN2,XC1,YC1,XC2,YC2,W1
LOGICAL KEYWIS, LOCGRI, CCW, BPARF, BOUNPT,DONALL
LOGICAL LFRST1, LFRST2, LFRST3 40.31
INTEGER NUMP
LOGICAL, SAVE :: LBFILS = .FALSE. 40.31
LOGICAL, SAVE :: LBS = .FALSE. 40.31
#if defined SWAN_MODEL
LOGICAL, SAVE, POINTER :: LBGP
#else
LOGICAL, SAVE :: LBGP = .FALSE. 40.31
#endif
TYPE(BSPCDAT), POINTER :: BFLTMP 40.31
TYPE(BSPCDAT), SAVE, POINTER :: CUBFL 40.31
TYPE(BSDAT), POINTER :: BSTMP 40.31
TYPE(BSDAT), SAVE, POINTER :: CUBS 40.31
#if !defined SWAN_MODEL
TYPE(BGPDAT), POINTER :: BGPTMP 40.31
#endif
TYPE XYPT 40.31
INTEGER :: JX, JY
TYPE(XYPT), POINTER :: NEXTXY
END TYPE XYPT
TYPE(XYPT), TARGET :: FRST 40.31
TYPE(XYPT), POINTER :: CURR, TMP 40.31
CHARACTER(80) :: MSGSTR 40.80
TYPE(verttype), DIMENSION(:), POINTER :: vert 40.80
TYPE(facetype), DIMENSION(:), POINTER :: face 40.80
!
! 8. Subroutines used
!
! Ocean Pack command reading routines
! BOUNPT
!
LOGICAL STPNOW 34.01
LOGICAL EQREAL
!
! 9. Subroutines calling
!
! SWREAD
!
! 10. Error messages
!
!
! 11. Remarks
!
! data concerning boundary files are stored in array BFILES
! see subr BCFILE for details
!
! 12. Structure
!
! -----------------------------------------------------------------
! Read keyword
! Case keyword =
! 'SHAPE': Read spectral shape parameters
! 'WAMN': Read filename
! Open WAM nesting file
! Put file characteristics into array BFILES
! 'WW3N': Read filename
! Open WW3 nesting file
! Put file characteristics into array BFILES
! 'NEST': Read filename
! Call BCFILE to obtain file characteristics
! 'SIDE': read side of boundary
! 'SEG': read set of points on boundary of comp. grid
! Read keyword
! If keyword is 'UNIF'
! Then Read keyword
! If keyword is 'PAR'
! Then read integral wave parameters
! Call SSHAPE to generate spectrum
! put spectrum into array BSPECS
! Else {keyword is 'FILE'}
! Read filename
! Call BCFILE to obtain file characteristics
! Else {keyword is 'VAR'}
! Read keyword
! If keyword is 'PAR'
! Then Repeat until list is exhausted
! Read length and integral wave parameters
! Call SSHAPE to generate spectrum
! put spectrum into array BSPECS
! Else {keyword is 'FILE'}
! Repeat until list is exhausted
! Read filename
! Call BCFILE to obtain file characteristics
! -----------------------------------------------------------------
!
! 13. Source text
SAVE IENT
DATA IENT/0/
CALL STRACE (IENT,'SWBOUN')
#if defined SWAN_MODEL
LBGP=>LBGP_G(ng)
#endif
!
! point to vertex and face objects
!
vert => gridobject%vert_grid 40.80
face => gridobject%face_grid 40.80
!
IF (OPTG.EQ.5) THEN 40.80
!
! in case of unstructured grid, make list of boundary points
! in ascending order
!
CALL SwanBpntlist 40.80
IF (STPNOW()) RETURN 41.39
ELSE 41.14
!
! generate output curves BOUNDARY and BOUND_** for structured grids
!
CALL SwanBndStruc ( XCGRID, YCGRID ) 41.14
ENDIF 40.80
!
CALL INKEYW ('REQ',' ')
IF (KEYWIS ('SHAP')) THEN
!
! specification of the spectral shape
!
! =========================================================================
!
! | JONswap [gamma] |
! | | | -> PEAK |
! BOUndspec SHAPe < PM > < > &
! | | | MEAN |
! | GAUSs [sigfr] |
! | |
! | BIN |
!
! | DEGRees |
! DSPR < >
! | -> POWer |
!
! =========================================================================
!
CALL INKEYW ('STA', 'JON')
IF (KEYWIS ('JON')) THEN
FSHAPE = 2
CALL INREAL ('GAMMA', PSHAPE(1), 'STA', 3.3) 40.00
ELSE IF (KEYWIS ('BIN')) THEN
FSHAPE = 3
ELSE IF (KEYWIS ('PM')) THEN
FSHAPE = 1
ELSE IF (KEYWIS ('GAUS')) THEN
FSHAPE = 4
CALL INREAL ('SIGFR', SIGMAG, 'STA', 0.01)
! convert from Hz to rad/s:
PSHAPE(2) = PI2 * SIGMAG 40.00
ENDIF
! PEAK or MEAN frequency
CALL INKEYW ('STA', ' ')
IF (KEYWIS('MEAN')) THEN
FSHAPE = -FSHAPE
ELSE
CALL IGNORE ('PEAK')
ENDIF
! directional distribution given by DEGR or by POWER
CALL IGNORE ('DSPR')
CALL INKEYW ('STA', 'POW')
IF (KEYWIS('DEGR')) THEN
DSHAPE = 1
ELSE
CALL IGNORE ('POW')
DSHAPE = 2
ENDIF
IF (ITEST.GE.30) WRITE (PRINTF,6100) FSHAPE, DSHAPE
6100 FORMAT (' Shape of inc. spectrum, Freq:', I2, ' ; Dir:', I2)
!
ELSE IF (KEYWIS ('WAMN')) THEN
!
! SWAN in WAM nesting 30.04
!
! =======================================================================
!
! |-> CRAY |
! | UNFormatted < > |
! | | WKstat | |
! | |
! BOUndnest2 WAMNest 'fname' < > [xgc] [ygc] [lwdate]
! | |
! | FREE |
!
! =======================================================================
!
IF (MXC .LE. 0 .AND. OPTG.NE.5) THEN 40.80
CALL MSGERR(3, ' command CGRID must precede this command') 40.80
GOTO 900
ENDIF
IF (MCGRD .LE. 1 .AND. nverts .LE. 0) THEN 40.80
CALL MSGERR(3,
& ' command READ BOT or READ UNSTRUC must precede this command') 40.80
GOTO 900
ENDIF
!
IF (OPTG.EQ.5) THEN 40.80
CALL MSGERR(2,
& ' WAM b.c. are not supported in unstructured grid') 40.80
GOTO 900 40.80
ENDIF 40.80
!
NBFILS = NBFILS + 1
ALLOCATE(BFLTMP) 40.31
CALL INCSTR ('FNAME',FILENM,'REQ', ' ')
#ifdef SWAN_MODEL
CALL BCWAMN (FILENM, 'NEST', BFLTMP, LBGP,
& XCGRID, YCGRID, KGRPNT, XYTST, ng)
#else
CALL BCWAMN (FILENM, 'NEST', BFLTMP, LBGP, 40.31
& XCGRID, YCGRID, KGRPNT, XYTST) 40.31
#endif
IF (STPNOW()) RETURN 34.01
NULLIFY(BFLTMP%NEXTBSPC) 40.31
IF ( .NOT.LBFILS ) THEN 40.31
FBNDFIL = BFLTMP 40.31
CUBFL => FBNDFIL 40.31
LBFILS = .TRUE. 40.31
ELSE 40.31
CUBFL%NEXTBSPC => BFLTMP 40.31
CUBFL => BFLTMP 40.31
END IF 40.31
!
ELSE IF (KEYWIS('WW3').OR.KEYWIS('WWIII')) THEN 40.02
!
! SWAN in WaveWatch nesting 40.05
!
! =======================================================================
! | UNFormatted | | -> CLOS |
! BOUndnest3 WW3 'fname' < > < > [xgc] [ygc]
! | FREe | | OPEN |
! =======================================================================
!
IF (MXC .LE. 0 .AND. OPTG.NE.5) THEN 40.80
CALL MSGERR(3, ' command CGRID must precede this command') 40.80
GOTO 900
ENDIF
IF (MCGRD .LE. 1 .AND. nverts .LE. 0) THEN 40.80
CALL MSGERR(3,
& ' command READ BOT or READ UNSTRUC must precede this command') 40.80
GOTO 900
ENDIF
!
IF (OPTG.EQ.5) THEN 40.80
CALL MSGERR(2,
& ' WWIII b.c. are not supported in unstructured grid') 40.80
GOTO 900 40.80
ENDIF 40.80
!
NBFILS = NBFILS + 1
ALLOCATE(BFLTMP) 40.31
CALL INCSTR ('FNAME',FILENM,'REQ', ' ')
#ifdef SWAN_MODEL
CALL BCWW3N (FILENM, 'NEST', BFLTMP, LBGP, 40.31 40.05
& XCGRID, YCGRID, KGRPNT, XYTST, KGRBND, 40.31 40.05
& ng) 40.31 40.05
#else
CALL BCWW3N (FILENM, 'NEST', BFLTMP, LBGP, 40.31 40.05
& XCGRID, YCGRID, KGRPNT, XYTST, KGRBND) 40.31 40.05
#endif
IF (STPNOW()) RETURN
NULLIFY(BFLTMP%NEXTBSPC) 40.31
IF ( .NOT.LBFILS ) THEN 40.31
FBNDFIL = BFLTMP 40.31
CUBFL => FBNDFIL 40.31
LBFILS = .TRUE. 40.31
ELSE 40.31
CUBFL%NEXTBSPC => BFLTMP 40.31
CUBFL => BFLTMP 40.31
END IF 40.31
!
ELSE IF (KEYWIS ('NE')) THEN
!
! Nesting SWAN model in larger SWAN model
! ==========================================
! | -> CLOS | 40.05
! BOUndnest1 NEst 'fname' < >
! | OPEN | 40.05
! ==========================================
!
IF (MXC .LE. 0 .AND. OPTG.NE.5) THEN 40.80
CALL MSGERR(3, ' command CGRID must precede this command') 40.80
GOTO 900
ENDIF
IF (MCGRD .LE. 1 .AND. nverts .LE. 0) THEN 40.80
CALL MSGERR(3,
& ' command READ BOT or READ UNSTRUC must precede this command') 40.80
GOTO 900
ENDIF
!
NBFILS = NBFILS + 1
ALLOCATE(BFLTMP) 40.31
CALL INCSTR ('FNAME',FILENM,'REQ', ' ')
! if keyword is OPEN then
! DONALL is TRUE and the nesting boundary remain open
! else (default case)
! DONALL is FALSE and boundary is close and interpolation between
! the last and the first point will be done
CALL INKEYW ('STA', 'CLOS') 40.05
IF (KEYWIS('OPEN')) THEN 40.05
DONALL = .TRUE. 40.05
ELSE IF (KEYWIS('CLOS')) THEN 40.05
DONALL = .FALSE. 40.05
ELSE 40.05
CALL WRNKEY 40.05
ENDIF 40.05
#ifdef SWAN_MODEL
CALL BCFILE (FILENM, 'NEST', BFLTMP, LBGP, 40.31
& XCGRID, YCGRID, KGRPNT, XYTST, KGRBND, 40.31
& DONALL, ng) 40.05
#else
CALL BCFILE (FILENM, 'NEST', BFLTMP, LBGP, 40.31
& XCGRID, YCGRID, KGRPNT, XYTST, KGRBND, 40.31
& DONALL) 40.05
#endif
IF (STPNOW()) RETURN 34.01
NULLIFY(BFLTMP%NEXTBSPC) 40.31
IF ( .NOT.LBFILS ) THEN 40.31
FBNDFIL = BFLTMP 40.31
CUBFL => FBNDFIL 40.31
LBFILS = .TRUE. 40.31
ELSE 40.31
CUBFL%NEXTBSPC => BFLTMP 40.31
CUBFL => BFLTMP 40.31
END IF 40.31
!
ELSE
!
! parametric or file boundary condition
!
! ======================================================================
!
! | North |
! | NW |
! | West |
! | SW | | -> CCW |
! | -> SIDE < South > | [k] < > |
! | | SE | | CLOCKWise | |
! | | East | |
! | | NE | |
! BOUndary < > &
! | | -> XY < [x] [y] > | |
! | SEGment < > |
! | IJ < [i] [j] > | < [k] > |
!
!
! | PAR [hs] [per] [dir] [dd] |
! | UNIForm < > |
! | | FILE 'fname' [seq] | |
! < >
! | | PAR < [len] [hs] [per] [dir] [dd] > | |
! | VARiable < > |
! | FILE < [len] 'fname' [seq] > |
!
! ======================================================================
!
IF (MXC .LE. 0 .AND. OPTG.NE.5) THEN 40.80
CALL MSGERR(3, ' command CGRID must precede this command') 40.80
GOTO 900
ENDIF
IF (MCGRD .LE. 1 .AND. nverts .LE. 0) THEN 40.80
CALL MSGERR(3,
& ' command READ BOT or READ UNSTRUC must precede this command') 40.80
GOTO 900
ENDIF
!
! first define side or segment
!
! *** definition of boundary segment ***
!
CALL INKEYW ('REQ',' ')
IF (KEYWIS ('STAT')) THEN
CALL MSGERR (1, 'keyword STAT ignored')
CALL INKEYW ('REQ',' ')
ENDIF
KOUNTR = 0
FRST%JX = 0 40.31
FRST%JY = 0 40.31
NULLIFY(FRST%NEXTXY) 40.31
CURR => FRST 40.31
IF (KEYWIS ('SEG')) THEN
IERR = 0
CALL INKEYW ('STA','XY')
IF (KEYWIS('XY') .OR. KEYWIS ('LOC')) THEN
LOCGRI = .TRUE.
ELSE IF (KEYWIS('IJ') .OR. KEYWIS ('GRI')) THEN
LOCGRI = .FALSE.
ELSE
CALL WRNKEY
ENDIF
IX1 = 1
IY1 = 1
LFRST1 = .TRUE. 40.31
! loop over points describing the segment
DO
IF (LOCGRI) THEN
CALL READXY ('XP','YP',XP,YP, 'REP', -1.E10, -1.E10)
IF (XP.LT.-.9E10) GOTO 42
IF (OPTG.NE.5) THEN 40.80
! --- structured grid
!
CALL CVMESH (XP, YP, XC, YC, KGRPNT, XCGRID, YCGRID,
& KGRBND) 40.00
IX2 = NINT(XC) + 1
IY2 = NINT(YC) + 1 40.00
IF (.NOT.BOUNPT(IX2,IY2,KGRPNT)) THEN
CALL MSGERR (2, 'invalid boundary point')
WRITE (PRTEST, 38) XP+XOFFS, YP+YOFFS, XC, YC, 40.00
& IX2, IY2 40.00
38 FORMAT (' segment point ', 2F10.2,
& ' grid ', 2F8.2, 2I4)
ENDIF
ELSE 40.80
! --- unstructured grid
!
CALL SwanFindPoint ( XP, YP, IX2 ) 40.80
IF ( IX2.LT.0 ) THEN 40.80
WRITE (MSGSTR, '(A,F12.4,A,F12.4,A)') 40.80
& ' Boundary point (',XP+XOFFS,',',YP+YOFFS, 40.80
& ') not part of computational grid' 40.80
CALL MSGERR( 2, TRIM(MSGSTR) ) 40.80
ENDIF 40.80
IF ( vert(IX2)%atti(VMARKER) /= 1 ) THEN 40.80
WRITE (MSGSTR, '(A,F12.4,A,F12.4,A)') 40.80
& ' Vertex (',XP+XOFFS,',',YP+YOFFS, 40.80
& ') is not a valid boundary point' 40.80
CALL MSGERR( 2, TRIM(MSGSTR) ) 40.80
ENDIF 40.80
ENDIF 40.80
ELSE
IF (OPTG.NE.5) THEN 40.80
CALL ININTG ('I' , IX2, 'REP', -1) 40.03
IF (IX2 .LT. 0) GOTO 42 40.00
CALL ININTG ('J' , IY2, 'REQ', 0) 40.03
IX2 = IX2 + 1 40.00
IY2 = IY2 + 1
ELSE 40.80
CALL ININTG ('K' , IX2, 'REP', -1) 40.03
IF (IX2 .LT. 0) GOTO 42 40.00
IF (IX2.LE.0 .OR. IX2.GT.nverts) THEN 40.80
WRITE (MSGSTR,'(I4,A)') IX2, 40.80
& ' is not a valid vertex index' 40.80
CALL MSGERR( 2, TRIM(MSGSTR) ) 40.80
ELSEIF ( vert(IX2)%atti(VMARKER) /= 1 ) THEN 40.80
WRITE (MSGSTR,'(A,I4,A)') ' Vertex with index ',IX2, 40.80
& ' is not a valid boundary point' 40.80
CALL MSGERR( 2, TRIM(MSGSTR) ) 40.80
ENDIF 40.80
ENDIF 40.80
ENDIF
IF (ITEST.GE.80 .AND. OPTG.NE.5) WRITE (PRTEST, 38) 40.00
& XCGRID(IX2,IY2)+XOFFS, 40.00
& YCGRID(IX2,IY2)+YOFFS, XC, YC, IX2-1, IY2-1 40.00
!
! --- generate intermediate points on the segment
IF ( OPTG.NE.5 ) THEN 40.80
! --- structured grid 40.80
!
IF (IX2 .GT. 0 .AND. IX2 .LE. MXC .AND.
& IY2 .GT. 0 .AND. IY2 .LE. MYC) THEN
IF (LFRST1) THEN
MM = 1
LFRST1 = .FALSE.
ELSE
MM = MAX (ABS(IX2-IX1), ABS(IY2-IY1))
ENDIF
DO IP = 1, MM
RR = REAL(IP) / REAL(MM)
!
IF (.NOT. ONED) THEN 30.81
IX = IX1 + NINT(RR*REAL(IX2-IX1))
IY = IY1 + NINT(RR*REAL(IY2-IY1))
ELSE 30.81
IX = IX1 + NINT(RR*REAL(IX2-IX1)) 30.81
IY = IY1 30.81
END IF 30.81
!
IF (ITEST.GE.80) WRITE (PRTEST, *) ' b. point ',
& RR, IX, IY
IF (KGRPNT(IX,IY) .GT. 1) THEN
KOUNTR = KOUNTR + 1
ALLOCATE(TMP) 40.31
TMP%JX = IX 40.31
TMP%JY = IY 40.31
NULLIFY(TMP%NEXTXY) 40.31
CURR%NEXTXY => TMP 40.31
CURR => TMP 40.31
ENDIF
ENDDO
ELSE
MSGSTR ='' 41.14
write (MSGSTR, 117) IX2-1, IY2-1 41.14
117 format ('(',2I5, ') is outside computational grid') 41.14
CALL MSGERR (2, MSGSTR)
ENDIF
IY1 = IY2
ELSE 40.80
! --- unstructured grid 40.80
!
IF (LFRST1) THEN 40.80
IXB1 = vert(IX2)%atti(BINDX) 40.80
JBG = vert(IX2)%atti(BPOL) 40.92
DET = 1. 40.92
LFRST1 = .FALSE. 40.80
ELSE 40.80
IXB1 = vert(IX1)%atti(BINDX) 40.80
JBG = vert(IX1)%atti(BPOL) 40.92
!
! 1) the wave spectrum along the given segment can be
! imposed in counterclockwise or clockwise direction
! 2) content of array blist is ordered in counterclockwise
! manner for sea/mainland boundary (JBG=1) and
! clockwise for island boundary (JBG>1)
! 3) therefore, determine orientation by means of the
! determinant of two endpoints of the given segment
! and an arbitrary point inside domain
!
! first endpoint of segment
X1 = vert(IX1)%attr(VERTX) 40.80
Y1 = vert(IX1)%attr(VERTY) 40.80
!
! second endpoint of segment
X2 = vert(IX2)%attr(VERTX) 40.80
Y2 = vert(IX2)%attr(VERTY) 40.80
!
! an arbitrary internal point 40.92
DX=0.1*mingsiz
DY=0.1*mingsiz
DO IP=1,4
X3 = X1 - DX
Y3 = Y1 - DY
CALL SwanFindPoint ( X3, Y3, IX )
IF ( JBG>1 .AND. IX.LT.0 ) THEN
X3 = X1 + DX
Y3 = Y1 + DY
EXIT
ELSEIF ( JBG==1 .AND. IX.GT.0 ) THEN
EXIT
ENDIF
IF ( MOD(IP,2).EQ.0 ) THEN
DX = -DX
ELSE
DY = -DY
ENDIF
ENDDO
!
DET= (Y3-Y1)*(X2-X1)-(Y2-Y1)*(X3-X1) 40.80
IF (DET.GT.0.) THEN 40.80
! take next boundary point in counterclockwise
! direction
IXB1 = MOD(IXB1,nbpt(JBG))+1 40.92 40.80
ELSE 40.80
! take next boundary point in clockwise direction
IXB1 = nbpt(JBG)-MOD(nbpt(JBG)+1-IXB1,nbpt(JBG)) 40.92 40.80
ENDIF 40.80
ENDIF 40.80
IXB2 = vert(IX2)%atti(BINDX) 40.80
!
! determine order of counting
IF (IXB1.GT.IXB2 ) THEN 40.80
IF (DET.LT.0.) THEN 40.92
IXI = -1 40.80
ELSE 40.92
IXI = 1 40.92
IXB2 = IXB2+nbpt(JBG) 40.92
ENDIF 40.92
ELSE 40.80
IF (DET.GT.0.) THEN 40.92
IXI = 1 40.80
ELSE 40.92
IXI = -1 40.92
IXB1 = IXB1+nbpt(JBG) 40.92
ENDIF 40.92
ENDIF 40.80
!
DO IPP = IXB1, IXB2, IXI 40.92 40.80
IP = MOD(IPP,nbpt(JBG)) 40.92
IF (IP.EQ.0) IP = nbpt(JBG) 40.92
KOUNTR = KOUNTR + 1 40.80
IX = blist(IP,JBG) 40.92 40.80
vert(IX)%atti(VBC) = 1 40.80
ALLOCATE(TMP) 40.80
TMP%JX = IX 40.80
NULLIFY(TMP%NEXTXY) 40.80
CURR%NEXTXY => TMP 40.80
CURR => TMP 40.80
ENDDO 40.80
ENDIF 40.80
IX1 = IX2
END DO
42 IF (KOUNTR.EQ.0)
& CALL MSGERR(1,'No points on the boundaries found')
IF (LFRST1) CALL MSGERR (1,
& 'At least two points needed for a segment') 40.81
ELSE
! boundary condition on one side of the computational grid
IF (OPTG.EQ.3) THEN 40.80 40.31
CALL MSGERR(2, 40.80 40.31
& ' keyword SIDE should not be used for curvilinear grid') 40.80 40.31
END IF 40.31
CALL IGNORE ('SIDE')
! *** specification of side for which boundary ***
! *** condition is given ***
IF (OPTG.NE.5) THEN 40.80
CALL INKEYW ('REQ',' ')
IF (KEYWIS ('NW')) THEN
DIRSI = 45.
ELSE IF (KEYWIS ('SW')) THEN
DIRSI = 135.
ELSE IF (KEYWIS ('SE')) THEN
DIRSI = -135.
ELSE IF (KEYWIS ('NE')) THEN
DIRSI = -45.
ELSE IF (KEYWIS ('N')) THEN
DIRSI = 0.
ELSE IF (KEYWIS ('W')) THEN
DIRSI = 90.
ELSE IF (KEYWIS ('S')) THEN
DIRSI = 180.
ELSE IF (KEYWIS ('E')) THEN
DIRSI = -90.
ELSE
CALL WRNKEY
ENDIF
ELSE 40.80
CALL ININTG ('K', VM, 'REQ', 0) 40.80
ENDIF 40.80
!
! --- go along boundary clockwise or counterclockwise (default)
!
CALL INKEYW ('STA', 'CCW')
IF (KEYWIS('CLOCKW')) THEN
CCW = .FALSE.
ELSE
CALL IGNORE ('CCW')
CCW = .TRUE.
ENDIF
!
! select side in the chosen direction
!
IF ( OPTG.NE.5 ) THEN 40.80
CRDM = -1.E10
ISIDM = 0
IF (ONED) THEN 40.00
COSDIR = COS(PI*(DNORTH+DIRSI)/180.)
SINDIR = SIN(PI*(DNORTH+DIRSI)/180.)
DO ISIDE = 1, 4
SOMX = 0.
SOMY = 0.
NUMP = 0
IF (ISIDE.EQ.2) THEN
KC = KGRPNT(MXC,1)
IF (KC.GT.1) THEN
SOMX = XCGRID(MXC,1)
SOMY = YCGRID(MXC,1)
NUMP = 1
ENDIF
ELSE IF (ISIDE.EQ.4) THEN
KC = KGRPNT(1,1)
IF (KC.GT.1) THEN
SOMX = XCGRID(1,1)
SOMY = YCGRID(1,1)
NUMP = 1
ENDIF
ENDIF
IF (NUMP.GT.0) THEN
CRDP = COSDIR*SOMX + SINDIR*SOMY
! side with largest CRDP is the one selected
IF (CRDP.GT.CRDM) THEN
CRDM = CRDP
ISIDM = ISIDE
ENDIF
ENDIF
ENDDO
ELSE 40.00
DO ISIDE = 1, 4
SOMX = 0.
SOMY = 0.
NUMP = 0
IF (ISIDE.EQ.1) THEN
DO IX = 1, MXC
KC2 = KGRPNT(IX,1)
IF (IX.GT.1) THEN
IF (KC1.GT.1 .AND. KC2.GT.1) THEN 40.00
! if both grid points at ends of a step are valid, then
! take DX and DY into account when determining direction
SOMX = SOMX + XCGRID(IX,1)-XCGRID(IX-1,1)
SOMY = SOMY + YCGRID(IX,1)-YCGRID(IX-1,1)
NUMP = NUMP + 1
ENDIF
ENDIF
KC1 = KC2 40.03
ENDDO
ELSE IF (ISIDE.EQ.2) THEN
DO IY = 1, MYC
KC2 = KGRPNT(MXC,IY)
IF (IY.GT.1) THEN
IF (KC1.GT.1 .AND. KC2.GT.1) THEN 40.00
SOMX = SOMX + XCGRID(MXC,IY)-XCGRID(MXC,IY-1)
SOMY = SOMY + YCGRID(MXC,IY)-YCGRID(MXC,IY-1)
NUMP = NUMP + 1
ENDIF
ENDIF
KC1 = KC2 40.03
ENDDO
ELSE IF (ISIDE.EQ.3) THEN 40.00
DO IX = 1, MXC
KC2 = KGRPNT(IX,MYC)
IF (IX.GT.1) THEN
IF (KC1.GT.1 .AND. KC2.GT.1) THEN 40.00
SOMX = SOMX + XCGRID(IX-1,MYC)-XCGRID(IX,MYC) 40.13
SOMY = SOMY + YCGRID(IX-1,MYC)-YCGRID(IX,MYC) 40.13
NUMP = NUMP + 1
ENDIF
ENDIF
KC1 = KC2 40.03
ENDDO
ELSE IF (ISIDE.EQ.4) THEN
DO IY = 1, MYC
KC2 = KGRPNT(1,IY)
IF (IY.GT.1) THEN
IF (KC1.GT.1 .AND. KC2.GT.1) THEN 40.00
SOMX = SOMX + XCGRID(1,IY-1)-XCGRID(1,IY)
SOMY = SOMY + YCGRID(1,IY-1)-YCGRID(1,IY)
NUMP = NUMP + 1
ENDIF
ENDIF
KC1 = KC2 40.03
ENDDO
ENDIF
IF (NUMP.GT.0) THEN
DIRSID = ATAN2(SOMY,SOMX)
DIRREF = PI*(DNORTH+DIRSI)/180.
IF (CVLEFT) THEN
CRDP = COS(DIRSID - 0.5*PI - DIRREF)
ELSE
CRDP = COS(DIRSID + 0.5*PI - DIRREF)
ENDIF
! side with largest CRDP is the one selected
IF (CRDP.GT.CRDM) THEN
CRDM = CRDP
ISIDM = ISIDE
ENDIF
ENDIF
IF (ITEST.GE.60) WRITE (PRTEST, 151) ISIDE, NUMP,
& SOMX, SOMY, DIRSID*180/PI, DIRREF*180/PI, CRDP, CVLEFT 40.13
151 FORMAT (' side ', 2I4, 2(1X,E11.4), 2(1X,F5.0), 2X,
& F6.3, 2X, L1) 40.13
ENDDO
ENDIF 40.00
IF (ISIDM.EQ.0) THEN
CALL MSGERR (2, 'No open boundary found')
ENDIF
!
90 IF (ISIDM.EQ.1) THEN
IX1 = 1
IY1 = 1
IX2 = MXC
IY2 = 1
ELSE IF (ISIDM.EQ.2) THEN
IX1 = MXC
IY1 = 1
IX2 = MXC
IY2 = MYC
ELSE IF (ISIDM.EQ.3) THEN
IX1 = MXC
IY1 = MYC
IX2 = 1
IY2 = MYC
ELSE IF (ISIDM.EQ.4) THEN
IX1 = 1
IY1 = MYC
IX2 = 1
IY2 = 1
ENDIF
IF (.NOT.CCW .EQV. CVLEFT) THEN
! swap end points
IX3 = IX1
IY3 = IY1
IX1 = IX2
IY1 = IY2
IX2 = IX3
IY2 = IY3
ENDIF
IF (ITEST.GE.50) WRITE (PRINTF, 112) ISIDM,
& IX1-1, IY1-1, XCGRID(IX1,IY1)+XOFFS, YCGRID(IX1,IY1)+YOFFS, 40.00
& IX2-1, IY2-1, XCGRID(IX2,IY2)+XOFFS, YCGRID(IX2,IY2)+YOFFS 40.00
112 FORMAT (' Selected side:', I2, ' from ', 2I4, 2F9.0, 40.00
& ' to ', 2I4, 2F9.0) 40.00
MP = MAX(ABS(IX2-IX1),ABS(IY2-IY1))
DO IP = 0, MP
IF (MP.EQ.0) THEN 40.00
RR = 0.
ELSE
RR = REAL(IP) / REAL(MP)
ENDIF
IX = IX1 + NINT(RR*REAL(IX2-IX1))
IY = IY1 + NINT(RR*REAL(IY2-IY1))
IF (KGRPNT(IX,IY) .GT. 1) THEN
KOUNTR = KOUNTR + 1
ALLOCATE(TMP) 40.31
TMP%JX = IX 40.31
TMP%JY = IY 40.31
NULLIFY(TMP%NEXTXY) 40.31
CURR%NEXTXY => TMP 40.31
CURR => TMP 40.31
ENDIF
ENDDO
ELSE 40.80
! unstructured grid
!
DO JBG = 1, nbpol 40.92
!
! first boundary polyogon is assumed an outer one
! (sea/mainland boundary) and hence, content of blist
! is ordered in counterclockwise manner
!
IF ( JBG==1 .EQV. CCW ) THEN 40.92 40.80
IXB1 = 1 40.80
IXB2 = nbpt(JBG) 40.92 40.80
IXI = 1 40.80
ELSE 40.80
IXB1 = nbpt(JBG) 40.92 40.80
IXB2 = 1 40.80
IXI = -1 40.80
ENDIF 40.80
!
ALLOCATE(IARR1(SUM(nbpt)))
K = 0
DO IP = IXB1, IXB2, IXI 40.92
IX = blist(IP,JBG) 40.92
IF ( vmark(IX) == VM ) THEN 40.92
K = K+1 40.92
IARR1(K) = IP 40.92
ENDIF
ENDDO
!
IF ( K/=0 ) THEN 40.92
!
ALLOCATE(IARR2(K)) 40.92
IARR2(1:K) = IARR1(1:K) 40.92
ISH = 0 40.92
DO IPP = 2, K 40.92
IF ( IARR2(IPP)/=IARR2(IPP-1)+IXI ) THEN 40.92
ISH = IPP-1 40.92
EXIT 40.92
ENDIF 40.92
ENDDO 40.92
IARR2 = CSHIFT(IARR2,ISH) 40.92
!
DO IPP = 1, K 40.92
IP = IARR2(IPP) 40.92
IX = blist(IP,JBG) 40.92 40.80
KOUNTR = KOUNTR + 1 40.80
vert(IX)%atti(VBC) = 1 40.80
ALLOCATE(TMP) 40.80
TMP%JX = IX 40.80
NULLIFY(TMP%NEXTXY) 40.80
CURR%NEXTXY => TMP 40.80
CURR => TMP 40.80
ENDDO 40.80
DEALLOCATE(IARR2) 40.92
!
ENDIF 40.92
DEALLOCATE(IARR1) 40.92
!
ENDDO 40.92
!
ENDIF 40.80
ENDIF
!
! *** boundary condition from file, 1-d or 2-d spectrum
!
CURR => FRST%NEXTXY 40.31
CALL INKEYW ('REQ',' ')
IF (KEYWIS('UNIF') .OR. KEYWIS('CON') .OR. KEYWIS('PAR')) THEN
CALL INKEYW('STA', 'PAR')
IF (KEYWIS('PAR')) THEN
CALL INREAL ('HS', SPPARM(1), 'REQ', 0.)
CALL INKEYW ('STA', ' ')
CALL INREAL ('PER', SPPARM(2), 'REQ', 0.)
CALL INREAL ('DIR', SPPARM(3), 'REQ', 0.)
IF (DSHAPE.EQ.1) THEN
CALL INREAL ('DD', SPPARM(4), 'STA', 30.)
IF ((SPPARM(4).GT.360. .OR. SPPARM(4).LT. 0.).AND. 30.81
& .NOT.(EQREAL(SPPARM(4),OVEXCV(16)))) THEN 30.82
CALL MSGERR (2,'Directional spreading is less than '// 30.81
& '0 or larger than 360 degrees, and no '// 30.81
& 'exception value') 30.81
END IF 30.81
ELSE
CALL INREAL ('DD', SPPARM(4), 'STA', 2.)
IF (SPPARM(4).LE. 0.) THEN 30.81
CALL MSGERR (2, 30.81
& 'Power of cosine is less or equal to zero') 30.81
END IF 30.81
IF (.NOT.LSPNAR .AND.
& SPPARM(4)*DDIR**2/2. .GT. 1.) THEN 40.03
CALL MSGERR (2, 40.03
& 'distribution too narrow to be represented properly') 40.03
WRITE (PRINTF, 142) SQRT(2./SPPARM(4))*180./PI 40.03
142 FORMAT (' Advise: choose Dtheta < ', F8.3, ' degr') 40.03
LSPNAR = .TRUE.
END IF 40.03
ENDIF
NBSPEC = NBSPEC + 1
IF (ITEST.GE.80) WRITE (PRTEST,*) ' bound. spectr.',
& NBSPEC, (SPPARM(II), II=1,4)
NBSPSS = NBSPEC
ALLOCATE(BSTMP) 40.31
BSTMP%NBS = NBSPEC 40.31
BSTMP%FSHAPE = FSHAPE 40.31
BSTMP%DSHAPE = DSHAPE 40.31
BSTMP%SPPARM(1:4) = SPPARM(1:4) 40.31
NULLIFY(BSTMP%NEXTBS) 40.31
IF ( .NOT.LBS ) THEN 40.31
FBS = BSTMP 40.31
CUBS => FBS 40.31
LBS = .TRUE. 40.31
ELSE 40.31
CUBS%NEXTBS => BSTMP 40.31
CUBS => BSTMP 40.31
END IF 40.31
ELSE IF (KEYWIS('FILE') .OR. KEYWIS('SPEC')) THEN
CALL INCSTR ('FNAME',FILENM,'REQ', ' ')
! generate new set of file data
NBFILS = NBFILS + 1
NBSPSS = NBSPEC
ALLOCATE(BFLTMP) 40.31
#ifdef SWAN_MODEL
CALL BCFILE (FILENM, 'PNTS', BFLTMP, LBGP, 40.31
& XCGRID, YCGRID, KGRPNT, XYTST, KGRBND, 40.31
& DONALL, ng) 40.05
#else
CALL BCFILE (FILENM, 'PNTS', BFLTMP, LBGP, 40.31
& XCGRID, YCGRID, KGRPNT, XYTST, KGRBND, 40.31
& DONALL) 40.05
#endif
IF (STPNOW()) RETURN 34.01
NULLIFY(BFLTMP%NEXTBSPC) 40.31
IF ( .NOT.LBFILS ) THEN 40.31
FBNDFIL = BFLTMP 40.31
CUBFL => FBNDFIL 40.31
LBFILS = .TRUE. 40.31
ELSE 40.31
CUBFL%NEXTBSPC => BFLTMP 40.31
CUBFL => BFLTMP 40.31
END IF 40.31
CALL ININTG('SEQ', NFSEQ, 'STA', 1)
NBSPSS = NBSPSS + NFSEQ
ENDIF
DO IKO = 1, KOUNTR
IX = CURR%JX 40.31
IF (OPTG.NE.5) IY = CURR%JY 40.80 40.31
CURR => CURR%NEXTXY 40.31
#ifdef SWAN_MODEL
! ALLOCATE(BGPDATZ_MOD(ng)%FBGP)
! ALLOCATE(BGPDATZ_MOD(ng)%CUBGP)
ALLOCATE(BGPDATZ_MOD(ng)%BGPTMP)
IF (OPTG.NE.5) THEN 40.80
BGPDATZ_MOD(ng)%BGPTMP%BGP(1) = KGRPNT(IX,IY)
ELSE 40.80
BGPDATZ_MOD(ng)%BGPTMP%BGP(1) = IX
ENDIF 40.80
BGPDATZ_MOD(ng)%BGPTMP%BGP(2) = 1
BGPDATZ_MOD(ng)%BGPTMP%BGP(3) = 1000
BGPDATZ_MOD(ng)%BGPTMP%BGP(4) = NBSPSS
BGPDATZ_MOD(ng)%BGPTMP%BGP(5) = 0
BGPDATZ_MOD(ng)%BGPTMP%BGP(6) = 1
NULLIFY(BGPDATZ_MOD(ng)%BGPTMP%NEXTBGP)
IF ( .NOT.LBGP ) THEN 40.31
BGPDATZ_MOD(ng)%FBGP = BGPDATZ_MOD(ng)%BGPTMP
BGPDATZ_MOD(ng)%CUBGP => BGPDATZ_MOD(ng)%FBGP
LBGP = .TRUE. 40.31
ELSE 40.31
BGPDATZ_MOD(ng)%CUBGP%NEXTBGP => BGPDATZ_MOD(ng)%BGPTMP
BGPDATZ_MOD(ng)%CUBGP => BGPDATZ_MOD(ng)%BGPTMP
END IF 40.31
#else
ALLOCATE(BGPTMP) 40.31
IF (OPTG.NE.5) THEN 40.80
BGPTMP%BGP(1) = KGRPNT(IX,IY) 40.31
ELSE 40.80
BGPTMP%BGP(1) = IX 40.80
ENDIF 40.80
BGPTMP%BGP(2) = 1 40.31
BGPTMP%BGP(3) = 1000 40.31
BGPTMP%BGP(4) = NBSPSS 40.31
BGPTMP%BGP(5) = 0 40.31
BGPTMP%BGP(6) = 1 40.31
NULLIFY(BGPTMP%NEXTBGP) 40.31
IF ( .NOT.LBGP ) THEN 40.31
FBGP = BGPTMP 40.31
CUBGP => FBGP 40.31
LBGP = .TRUE. 40.31
ELSE 40.31
CUBGP%NEXTBGP => BGPTMP 40.31
CUBGP => BGPTMP 40.31
END IF 40.31
#endif
ENDDO
NBGRPT = NBGRPT + KOUNTR
ELSE IF (KEYWIS('VAR')) THEN
CALL INKEYW('STA', 'PAR')
IF (KEYWIS('PAR')) THEN
BPARF = .TRUE.
ELSE IF (KEYWIS('FILE')) THEN
BPARF = .FALSE.
ENDIF
RLEN1 = -1.E20
IKO = 1
RDIST = 0.
IBSPC1 = 1
LFRST1 = .TRUE.
LFRST2 = .TRUE.
DO
IF (LFRST1) THEN
CALL INREAL('LEN', RLEN2, 'REQ', 0.)
LFRST1 = .FALSE.
ELSE
CALL INREAL('LEN', RLEN2, 'STA', 1.E20)
ENDIF
IF (RLEN2.LT.0.9E20) THEN
IF (IKO.GT.KOUNTR) THEN
CALL MSGERR(1,
& 'Length of segment short, boundary values ignored') 40.00
WRITE (PRINTF, 332) RDIST, RLEN2
332 FORMAT (' segment length=', F9.2, '; [len]=', F9.2)
ENDIF
IF (BPARF) THEN
CALL INREAL ('HS', SPPARM(1), 'REQ', 0.)
CALL INKEYW ('STA', ' ')
CALL INREAL ('PER', SPPARM(2), 'REQ', 0.)
CALL INREAL ('DIR', SPPARM(3), 'REQ', 0.)
IF (DSHAPE.EQ.1) THEN
CALL INREAL ('DD', SPPARM(4), 'STA', 30.)
IF ((SPPARM(4).GT.360. .OR. SPPARM(4).LT. 0.).AND. 30.81
& .NOT.(EQREAL(SPPARM(4),OVEXCV(16)))) THEN 30.82
CALL MSGERR (2,'Directional spreading is less ' // 30.81
& 'than 0 or larger than 360 '// 30.81
& 'degrees and no exception value') 30.81
END IF 30.81
ELSE
CALL INREAL ('DD', SPPARM(4), 'STA', 2.)
IF (SPPARM(4).LE. 0.) THEN 30.81
CALL MSGERR (2,'Power of cosine is less or equal '// 30.81
& 'to zero') 30.81
END IF 30.81
IF (.NOT.LSPNAR .AND.
& SPPARM(4)*DDIR**2/2. .GT. 1.) THEN
CALL MSGERR (2,
& 'distribution too narrow to be represented properly')
WRITE (PRINTF, 142) SQRT(2./SPPARM(4))*180./PI
LSPNAR = .TRUE.
END IF
ENDIF
NBSPEC = NBSPEC + 1
IBSPC2 = NBSPEC
ALLOCATE(BSTMP) 40.31
BSTMP%NBS = NBSPEC 40.31
BSTMP%FSHAPE = FSHAPE 40.31
BSTMP%DSHAPE = DSHAPE 40.31
BSTMP%SPPARM(1:4) = SPPARM(1:4) 40.31
NULLIFY(BSTMP%NEXTBS) 40.31
IF ( .NOT.LBS ) THEN 40.31
FBS = BSTMP 40.31
CUBS => FBS 40.31
LBS = .TRUE. 40.31
ELSE 40.31
CUBS%NEXTBS => BSTMP 40.31
CUBS => BSTMP 40.31
END IF 40.31
ELSE
IF (LFRST2) THEN
CALL INCSTR ('FNAME', FILENM, 'REQ', ' ')
LFRST2 = .FALSE.
ELSE
CALL INCSTR ('FNAME', FILENM, 'STA', ' ')
ENDIF
IF (FILENM.NE.' ') THEN
! generate new set of file data
NBFILS = NBFILS + 1
NBSPSS = NBSPEC
ALLOCATE(BFLTMP) 40.31
#ifdef SWAN_MODEL
CALL BCFILE (FILENM, 'PNTS', BFLTMP, LBGP, 40.31
& XCGRID, YCGRID, KGRPNT, XYTST, KGRBND, 40.31
& DONALL, ng) 40.05
#else
CALL BCFILE (FILENM, 'PNTS', BFLTMP, LBGP, 40.31
& XCGRID, YCGRID, KGRPNT, XYTST, KGRBND, 40.31
& DONALL) 40.05
#endif
IF (STPNOW()) RETURN 34.01
NULLIFY(BFLTMP%NEXTBSPC) 40.31
IF ( .NOT.LBFILS ) THEN 40.31
FBNDFIL = BFLTMP 40.31
CUBFL => FBNDFIL 40.31
LBFILS = .TRUE. 40.31
ELSE 40.31
CUBFL%NEXTBSPC => BFLTMP 40.31
CUBFL => BFLTMP 40.31
END IF 40.31
ENDIF
CALL ININTG ('SEQ', NFSEQ, 'STA', 1)
IBSPC2 = NBSPSS + NFSEQ
IF (IBSPC2.GT.NBSPEC)
& CALL MSGERR (1,'too large value for SEQ')
ENDIF
ELSE
IF (IKO.GT.KOUNTR) GOTO 360 40.00
ENDIF
LFRST3 = .TRUE.
DO
IX = CURR%JX 40.31
IF (OPTG.NE.5) THEN 40.80
IY = CURR%JY 40.31
XC2 = XCGRID(IX,IY)
YC2 = YCGRID(IX,IY)
ELSE 40.80
XC2 = xcugrd(IX) 40.80
YC2 = ycugrd(IX) 40.80
ENDIF 40.80
IF (.NOT.LFRST3) THEN
RDIST = RDIST + SQRT ((XC2-XC1)**2 + (YC2-YC1)**2)
ENDIF
LFRST3 = .FALSE.
XC1 = XC2
YC1 = YC2
IF (RDIST.GT.RLEN2) GOTO 340
#ifdef SWAN_MODEL
ALLOCATE(BGPDATZ_MOD(ng)%BGPTMP)
! ALLOCATE(BGPDATZ_MOD(ng)%FBGP)
! ALLOCATE(BGPDATZ_MOD(ng)%CUBGP)
IF (OPTG.NE.5) THEN 40.80
BGPDATZ_MOD(ng)%BGPTMP%BGP(1) = KGRPNT(IX,IY)
ELSE 40.80
BGPDATZ_MOD(ng)%BGPTMP%BGP(1) = IX
ENDIF 40.80
BGPDATZ_MOD(ng)%BGPTMP%BGP(1) = KGRPNT(IX,IY)
BGPDATZ_MOD(ng)%BGPTMP%BGP(2) = 1
W1 = (RLEN2-RDIST)/(RLEN2-RLEN1)
BGPDATZ_MOD(ng)%BGPTMP%BGP(3) = NINT(1000.*W1)
BGPDATZ_MOD(ng)%BGPTMP%BGP(4) = IBSPC1
BGPDATZ_MOD(ng)%BGPTMP%BGP(5) = NINT(1000.*(1.-W1))
BGPDATZ_MOD(ng)%BGPTMP%BGP(6) = IBSPC2
NULLIFY(BGPDATZ_MOD(ng)%BGPTMP%NEXTBGP)
IF ( .NOT.LBGP ) THEN 40.31
BGPDATZ_MOD(ng)%FBGP => BGPDATZ_MOD(ng)%BGPTMP
BGPDATZ_MOD(ng)%CUBGP => BGPDATZ_MOD(ng)%FBGP
LBGP = .TRUE. 40.31
ELSE 40.31
BGPDATZ_MOD(ng)%CUBGP%NEXTBGP => BGPDATZ_MOD(ng)%BGPTMP
BGPDATZ_MOD(ng)%CUBGP => BGPDATZ_MOD(ng)%BGPTMP
END IF 40.31
#else
ALLOCATE(BGPTMP) 40.31
IF (OPTG.NE.5) THEN 40.80
BGPTMP%BGP(1) = KGRPNT(IX,IY) 40.31
ELSE 40.80
BGPTMP%BGP(1) = IX 40.80
ENDIF 40.80
BGPTMP%BGP(2) = 1 40.31
W1 = (RLEN2-RDIST)/(RLEN2-RLEN1)
BGPTMP%BGP(3) = NINT(1000.*W1) 40.31
BGPTMP%BGP(4) = IBSPC1 40.31
BGPTMP%BGP(5) = NINT(1000.*(1.-W1)) 40.31
BGPTMP%BGP(6) = IBSPC2 40.31
NULLIFY(BGPTMP%NEXTBGP) 40.31
IF ( .NOT.LBGP ) THEN 40.31
FBGP = BGPTMP 40.31
CUBGP => FBGP 40.31
LBGP = .TRUE. 40.31
ELSE 40.31
CUBGP%NEXTBGP => BGPTMP 40.31
CUBGP => BGPTMP 40.31
END IF 40.31
#endif
IKO = IKO + 1
IF (IKO.GT.KOUNTR) GOTO 340 40.00
IF (.NOT.ASSOCIATED(CURR%NEXTXY)) EXIT 40.31
CURR => CURR%NEXTXY 40.31
ENDDO
! boundary values have been assigned, read new parameters
340 IF (RLEN2.GT.0.9E20) GOTO 360 40.00
RLEN1 = RLEN2
IBSPC1 = IBSPC2
ENDDO
! update NBGRPT = number of boundary grid points
360 NBGRPT = NBGRPT + KOUNTR 40.00
ELSE
CALL WRNKEY
ENDIF
IF (ASSOCIATED(TMP)) DEALLOCATE(TMP) 40.31
ENDIF
900 RETURN
END
!*********************************************************************
! *
#ifdef SWAN_MODEL
SUBROUTINE BCFILE (FBCNAM, BCTYPE, BSPFIL, LBGP, 40.31
& XCGRID, YCGRID, KGRPNT, 40.31
& XYTST, KGRBND, DONALL, ng) 40.31 40.05
#else
SUBROUTINE BCFILE (FBCNAM, BCTYPE, BSPFIL, LBGP, 40.31
& XCGRID, YCGRID, KGRPNT, 40.31
& XYTST, KGRBND, DONALL) 40.31 40.05
#endif
! *
!*********************************************************************
!
USE OCPCOMM1 40.41
USE OCPCOMM2 40.41
USE OCPCOMM4 40.41
USE SWCOMM2 40.41
USE SWCOMM3 40.41
USE SWCOMM4 40.41
USE M_BNDSPEC 40.31
!
IMPLICIT NONE
!
!
! --|-----------------------------------------------------------|--
! | Delft University of Technology |
! | Faculty of Civil Engineering |
! | Environmental Fluid Mechanics Section |
! | P.O. Box 5048, 2600 GA Delft, The Netherlands |
! | |
! | Programmers: The SWAN team |
! --|-----------------------------------------------------------|--
!
!
! SWAN (Simulating WAves Nearshore); a third generation wave model
! Copyright (C) 1993-2017 Delft University of Technology
!
! This program is free software; you can redistribute it and/or
! modify it under the terms of the GNU General Public License as
! published by the Free Software Foundation; either version 2 of
! the License, or (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! A copy of the GNU General Public License is available at
! http://www.gnu.org/copyleft/gpl.html#SEC3
! or by writing to the Free Software Foundation, Inc.,
! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
!
!
! 0. Authors
!
! 30.73: Nico Booij
! 30.90: IJsbrand Haagsma (Equivalence version)
! 34.01: Jeroen Adema
! 40.03, 40.13: Nico Booij
! 40.05: Ekaterini E. Kriezi
! 40.31: Marcel Zijlema
! 40.41: Marcel Zijlema
!
! 1. Updates
!
! 30.73, Dec. 97: New subroutine
! 30.90, Oct. 98: Introduced EQUIVALENCE POOL-arrays
! 34.01, Feb. 99: Introducing STPNOW
! 40.03, June 00: function EQCSTR used to compare strings
! July 00: option LONLAT for location coordinates introduced
! 40.05, Aug. 00: replace the source text related with the grid points
! interpolation coef. with a new subroutine BC_POINTS
! 40.13, Jan. 01: ! is now allowed as comment sign in a boundary file
! checking coordinates only for nesting situation
! remove declarations of unused variables
! Nov. 01: initial size of BSPAUX array enlarged
! 40.31, Nov. 03: removing POOL-mechanism, reconsideration of this
! subroutine
! 40.41, Oct. 04: common blocks replaced by modules, include files removed
! 40.41, Nov. 04: small corrections
!
! 2. Purpose
!
! Reads file data for boundary condition
!
! 3. Method
!
!
! 4. Argument variables
!
#ifdef SWAN_MODEL
INTEGER, INTENT(in) :: ng
#endif
REAL XCGRID(MXC,MYC), YCGRID(MXC,MYC)
!
INTEGER KGRPNT(MXC,MYC) 40.31
INTEGER XYTST(*), KGRBND(*) 40.31
!
! FBCNAM char inp filename of boundary data file
! BCTYPE char inp if value is "NEST": nesting b.c.
! XCGRID real inp x-coordinate of computational grid points
! YCGRID real inp y-coordinate of computational grid points
! KGRPNT int inp indirect addresses of grid points
! XYTST int inp ix, iy of test points
!
! DONALL: logic arguments declare if the nesting boundary is open or close
! it is defined by the users
!
LOGICAL, INTENT(INOUT) :: DONALL 40.05
!
CHARACTER FBCNAM *(*), BCTYPE *(*)
TYPE(BSPCDAT) :: BSPFIL 40.31
LOGICAL :: LBGP 40.31
!
! 5. Parameter variables
!
!
! 6. Local variables
!
INTEGER :: ISTATF, NDSL, NDSD, IOSTAT, IERR, NBOUNC, NANG, NFRE
INTEGER :: IBOUNC, DORDER
INTEGER :: IENT,IOPTT
INTEGER :: NHEDF, NHEDT, NHEDS, IFRE , IANG
INTEGER :: NQUANT, IQUANT, IBC, II, NBGRPT_PREV,IIPT2
REAL :: XP, YP, XP2, YP2
REAL :: FREQHZ, DIRDEG, DIRRD1,DIRRAD, EXCV
CHARACTER BTYPE *4, HEDLIN *80
!
! NBGRPT_PREV is the prevous number of NBGRPT
! IIPT2 counter use for the chekinf if there are grid points on nested boundary
!
! 8. Subroutines Used
!
! Ocean Pack command reading routines
! SWBCPT : boundary points interpolation
!
LOGICAL STPNOW, EQCSTR 40.03
!
! 9. Subroutines calling
!
! SWREAD
!
! 10. Error messages
!
!
! 11. Remarks
!
!
! This subroutine reads the heading of the file to determine locations
! of boundary spectra, spectral frequencies and directions etc.
! Reading and processing of spectral energy densities is done during
! computation by subroutine RESPEC (file Swanmain.for)
!
! data concerning boundary files are stored in array BFILED
! there is a subarray for each file; it contains:
! 1. status; 0: stationary, 1: nonstat, -1: exhausted
! 2. time of boundary values read one before last
! 3. time of boundary values read last
! 4. NDSL: unit ref. num. of file containing filenames
! 5. NDSD: unit ref. num. of file containing data
! 6. time coding option for reading time from data file
! 8. number of locations for which spectra are in the file
! 9. order of reading directional information
! 10. number of spectral directions of spectra on file
! 12. number of spectral frequencies
! 14. number of heading lines per file
! 15. number of heading lines per time step
! 16. number of heading lines per spectrum
! 17. =1: energy dens., =2: variance density
! 18. =1: Cartesian direction, =2: Nautical dir. 40.00
! 19. =1: direction spread in degr, =2: Power of Cos. 40.00
!
!
! 12. Structure
!
! -----------------------------------------------------------------
! Open boundary condition data file
! Read type of file from first line of file
! Case filetype is:
! TPAR: make filetype TPAR
! SWAN: make filetype SWAN
! If b.c. type is NEST
! Then calculate data on grid points
! put into array BGRIDP
! -----------------------------------------------------------
! Read spectral directions from file into array BSPDIR
! Read spectral frequencies from file into array BSPFRQ
! -----------------------------------------------------------------
! Put file characteristics into array BFILED
! -----------------------------------------------------------------
!
! 13. Source text
!
LOGICAL CCOORD 40.03
SAVE IENT
DATA IENT /0/
CALL STRACE (IENT, 'BCFILE')
!
NDSL = 0
IIPT2 = 0 40.05
! open data file
NDSD = 0
IOSTAT = 0
CALL FOR (NDSD, FILENM, 'OF', IOSTAT)
IF (STPNOW()) RETURN 34.01
!
! --- initialize array BFILED of BSPFIL 40.31
BSPFIL%BFILED = 0 40.31
!
! start reading from the data file
READ (NDSD, '(A)') HEDLIN
IF (EQCSTR(HEDLIN,'TPAR')) THEN 40.03
BTYPE = 'TPAR'
ISTATF = 1
IOPTT = 1
NBOUNC = 1
NANG = 1
NFRE = 1
NHEDF = 0
NHEDT = 0
NHEDS = 0
DORDER = 0
ALLOCATE(BSPFIL%BSPFRQ(NFRE)) 40.41
ALLOCATE(BSPFIL%BSPDIR(NANG)) 40.41
IF (NSTATM.EQ.0) CALL MSGERR (3,
& 'time information not allowed in stationary mode')
NSTATM = 1
ELSE IF (EQCSTR(HEDLIN,'SWAN')) THEN 40.03
NHEDF = 0
10 READ (NDSD, '(A)') HEDLIN
IF (ITEST.GE.60) WRITE (PRTEST,11) HEDLIN 40.00
! skip heading lines starting with comment sign ($ as in command file)
IF (HEDLIN(1:1).EQ.COMID .OR. HEDLIN(1:1).EQ.'!') GOTO 10 40.13
IF (EQCSTR(HEDLIN,'TIME')) THEN 40.03
IF (NSTATM.EQ.0) CALL MSGERR (3,
& 'nonstationary boundary condition not allowed '//
& 'in stationary mode')
NSTATM = 1
ISTATF = 1
BTYPE = 'SWNT'
READ (NDSD, *) IOPTT
READ (NDSD, '(A)') HEDLIN
IF (ITEST.GE.60) WRITE (PRTEST,11) HEDLIN
11 FORMAT (' heading line: ', A)
NHEDF = 2
NHEDT = 1
ELSE
ISTATF = 0
BTYPE = 'SWNS'
NHEDT = 0
ENDIF
!
! read geographical locations
!
! read number of boundary points
CCOORD = .TRUE. 40.03
IF (EQCSTR(HEDLIN,'LOC')) THEN 40.03
IF (BCTYPE.EQ.'NEST' .AND. KSPHER.EQ.1) CALL MSGERR (3, 40.13
& 'Boundary locations are Cartesian, while comp. is spherical') 40.03
ELSE IF (EQCSTR(HEDLIN,'LONLAT')) THEN 40.03
IF (BCTYPE.EQ.'NEST' .AND. KSPHER.EQ.0) CALL MSGERR (3, 40.13
& 'Boundary locations are spherical, while comp. is Cartesian') 40.03
ELSE
! set CCOORD to False to indicate that no locations are defined 40.03
CCOORD = .FALSE. 40.03
ENDIF
IF (CCOORD) THEN
READ (NDSD, *) NBOUNC
DO IBOUNC = 1, NBOUNC
IERR = 0
CALL REFIXY (NDSD, XP, YP, IERR)
IF (ITEST.GE.80) THEN
WRITE (PRTEST, *) ' B. spectrum ', IBOUNC, XP+XOFFS,
& YP+YOFFS, IERR 40.03
ENDIF
! in case of nesting coordinates on file are used to
! determine interpolation coefficients
! in other cases coordinates are ignored
IF (BCTYPE .EQ. 'NEST') THEN
XP2 = XP
YP2 = YP
!
! --- interpolate the boundaries points to the grid points of
! the SWAN computational grid
!
NBGRPT_PREV = NBGRPT 40.05
#ifdef SWAN_MODEL
CALL SWBCPT ( LBGP, XCGRID, YCGRID, 40.41 40.31 40.05
& KGRPNT, XYTST, KGRBND,XP2,YP2,IBOUNC, 40.05
& NBOUNC,DONALL, ng ) 40.05
#else
CALL SWBCPT ( LBGP, XCGRID, YCGRID, 40.41 40.31 40.05
& KGRPNT, XYTST, KGRBND,XP2,YP2,IBOUNC, 40.05
& NBOUNC,DONALL ) 40.05
#endif
! check if the grid points are on nested boundary.
! if not, stop the calculation and give an error message
IF (NBGRPT.NE.NBGRPT_PREV) THEN 40.05
IIPT2 = IIPT2+1 40.05
ENDIF 40.05
ENDIF
ENDDO
!
IF ((BCTYPE .EQ. 'NEST').AND. (IIPT2.EQ.0)) CALL MSGERR (2,
& 'no grid points on nested boundary') 40.05
!
NHEDF = NHEDF + 2 + NBOUNC
IF (ITEST.GE.60) WRITE (PRTEST,16) NBOUNC
16 FORMAT (I6, ' boundary locations')
READ (NDSD, '(A)') HEDLIN
IF (ITEST.GE.60) WRITE (PRTEST,11) HEDLIN
ELSE
IF (BCTYPE .EQ. 'NEST') THEN
CALL MSGERR (3, 'this file is not a true nesting file')
ENDIF
NBOUNC = 1
ENDIF
!
! read spectral resolution information
!
! number of spectral frequencies
IF (EQCSTR(HEDLIN(2:5),'FREQ')) THEN 40.03
READ (NDSD, *) NFRE
ALLOCATE(BSPFIL%BSPFRQ(NFRE)) 40.31
DO IFRE = 1, NFRE
! read frequency in Hz and convert to radians/sec
READ (NDSD, *) FREQHZ
BSPFIL%BSPFRQ(IFRE) = PI2 * FREQHZ 40.31
ENDDO
READ (NDSD, '(A)') HEDLIN
IF (ITEST.GE.60) WRITE (PRTEST,11) HEDLIN 40.00
NHEDF = NHEDF + 2 + NFRE
ELSE
NFRE = 0
IF (BCTYPE.EQ.'NEST') THEN
CALL MSGERR (3, 'file is not a true nesting file')
ENDIF
ENDIF
IF (ITEST.GE.60) WRITE (PRTEST,19) NFRE 40.00
19 FORMAT (I6, ' boundary frequencies')
! number of spectral directions
IF (EQCSTR(HEDLIN(2:4),'DIR')) THEN 40.03
READ (NDSD, *) NANG
ALLOCATE(BSPFIL%BSPDIR(NANG)) 40.31
DO IANG = 1, NANG
! read direction in degr and convert to radians
READ (NDSD, *) DIRDEG
IF (EQCSTR(HEDLIN,'N')) THEN 40.03
DIRDEG = 180. + DNORTH - DIRDEG
ENDIF
DIRRAD = DIRDEG * PI / 180.
! reverse order if second direction is smaller than first
IF (IANG.EQ.1) THEN
DIRRD1 = DIRRAD
ELSE IF (IANG.EQ.2) THEN
IF (DIRRAD.LT.DIRRD1) THEN
DORDER = -1
BSPFIL%BSPDIR(NANG) = DIRRD1 40.31
ELSE
DORDER = 1
ENDIF
DIRRD1 = DIRRAD
ELSE
IF (DORDER.LT.0.) THEN
IF (DIRRAD.GT.DIRRD1) CALL MSGERR (3,
& 'spectral directions in file not in right order')
ELSE
IF (DIRRAD.LT.DIRRD1) CALL MSGERR (3,
& 'spectral directions in file not in right order')
ENDIF
DIRRD1 = DIRRAD
ENDIF
IF (DORDER.LT.0) THEN
BSPFIL%BSPDIR(NANG+1-IANG) = DIRRAD 40.31
ELSE
BSPFIL%BSPDIR(IANG) = DIRRAD 40.31
ENDIF
ENDDO
READ (NDSD, '(A)') HEDLIN
IF (ITEST.GE.60) WRITE (PRTEST,11) HEDLIN
NHEDF = NHEDF + 2 + NANG
NHEDS = 1
ELSE
NANG = 0
ALLOCATE(BSPFIL%BSPDIR(NANG)) 40.41
NHEDS = 1
DORDER = 0
ENDIF
IF (ITEST.GE.60) WRITE (PRTEST,23) NANG 40.00
23 FORMAT (I6, ' boundary directions')
!
! read quantities (name, unit, exc. value)
!
IF (EQCSTR(HEDLIN,'QUANT')) THEN
READ (NDSD, *) NQUANT
IF (.NOT.((NQUANT.EQ.1 .AND. NANG.GT.0) .OR.
& (NQUANT.EQ.3 .AND. NANG.EQ.0))) THEN
CALL MSGERR (2, 'incompatible data on b.c. file')
WRITE (PRINTF, 31) NQUANT, NANG
31 FORMAT (I3, ' quantities; ', I5, ' directions')
ENDIF
DO IQUANT = 1, NQUANT
READ (NDSD, '(A)') HEDLIN
! if first quantity is 'EnDens' divide by Rho*Grav
IF (IQUANT.EQ.1) THEN
IF ( EQCSTR(HEDLIN,'ENDENS')) THEN 40.03
! quantity on file is energy density
BSPFIL%BFILED(17) = 1 40.31
ELSE IF ( EQCSTR(HEDLIN,'VADENS')) THEN 40.03
! quantity on file is variance density
BSPFIL%BFILED(17) = 2 40.31
ELSE
CALL MSGERR (2,
& 'Incorrect quantity in b.c.file: ' // HEDLIN(1:10)) 40.03
BSPFIL%BFILED(17) = 2 40.31
ENDIF
ELSE IF (IQUANT.EQ.2) THEN 40.00
! if second quantity is 'NDIR' transform from Nautical to Cartesian dir.
IF ( EQCSTR(HEDLIN,'NDIR')) THEN 40.03
! quantity on file is Nautical direction
BSPFIL%BFILED(18) = 2 40.31
ELSE IF (EQCSTR(HEDLIN,'CDIR')) THEN 40.03
! quantity on file is Cartesian direction
BSPFIL%BFILED(18) = 1 40.31
ELSE
CALL MSGERR (2,
& 'Incorrect quantity in b.c.file: ' // HEDLIN(1:10)) 40.03
BSPFIL%BFILED(18) = 1 40.31
ENDIF
ELSE IF (IQUANT.EQ.3) THEN 40.00
! if third quantity is 'DSPRP' or 'POWER' power is given,
! otherwise calculate power from dir. spread in degrees
IF (EQCSTR(HEDLIN,'DSPRP') .OR.
& EQCSTR(HEDLIN,'POWER')) THEN 40.03
! quantity on file is power of cos
BSPFIL%BFILED(19) = 2 40.31
ELSE IF (EQCSTR(HEDLIN,'DSPR') .OR.
& EQCSTR(HEDLIN,'DEGR')) THEN 40.03
! quantity on file is Directional spread in degr
BSPFIL%BFILED(19) = 1 40.31
ELSE
CALL MSGERR (2,
& 'Incorrect quantity in b.c.file: ' // HEDLIN(1:10)) 40.03
BSPFIL%BFILED(19) = 1 40.31
ENDIF
ENDIF
! check Unit and Exception value
READ (NDSD, '(A)') HEDLIN
IF (IQUANT.EQ.3 .AND. EQCSTR(HEDLIN,'DEGR')) THEN
IF (BSPFIL%BFILED(19).NE.1) THEN 40.31
CALL MSGERR (2, 'incompatible options in boundary file')
BSPFIL%BFILED(19) = 1 40.31
ENDIF
ENDIF
IF (IQUANT.EQ.1) THEN 40.41
READ (NDSD, *) EXCV
BSPFIL%BFILED(11) = NINT(EXCV)
ELSE
READ (NDSD, '(A)') HEDLIN
END IF
ENDDO
NHEDF = NHEDF + 2 + 3*NQUANT
ENDIF
IF (ITEST.GE.60) WRITE (PRTEST,28) NQUANT 40.00
28 FORMAT (I6, ' quantities')
ELSE
CALL MSGERR (3, 'unsupported boundary data file')
ENDIF
!
ALLOCATE(BSPFIL%BSPLOC(NBOUNC)) 40.31
DO IBC = 1, NBOUNC
BSPFIL%BSPLOC(IBC) = NBSPEC + IBC 40.31
ENDDO
NBSPEC = NBSPEC + NBOUNC
!
! store file reading parameters in array BFILED
!
BSPFIL%BFILED(1) = ISTATF 40.31
BSPFIL%BFILED(2) = -999999999 40.31
BSPFIL%BFILED(3) = -999999999 40.31
BSPFIL%BFILED(4) = NDSL 40.31
BSPFIL%BFILED(5) = NDSD 40.31
BSPFIL%BFILED(6) = IOPTT 40.31
CALL COPYCH (BTYPE, 'T', BSPFIL%BFILED(7), 1, IERR) 40.31
BSPFIL%BFILED(8) = NBOUNC 40.31
BSPFIL%BFILED(9) = DORDER 40.31
BSPFIL%BFILED(10) = NANG 40.31
BSPFIL%BFILED(12) = NFRE 40.31
! ordering of data on file
BSPFIL%BFILED(13) = 0 40.31
! number of heading lines: per file, per time, per spectrum
BSPFIL%BFILED(14) = NHEDF 40.31
BSPFIL%BFILED(15) = NHEDT 40.31
BSPFIL%BFILED(16) = NHEDS 40.31
!
IF (ITEST.GE.80) WRITE(PRINTF,81) NBFILS, NBSPEC,
& (BSPFIL%BFILED(II), II=1,16) 40.31
81 FORMAT (' array BFILED: ', 2I4, 2(/,8I10))
!
RETURN
! end of subroutine BCFILE
END
!*********************************************************************
! *
#ifdef SWAN_MODEL
SUBROUTINE BCWAMN (FBCNAM, BCTYPE, BSPFIL, LBGP,
& XCGRID, YCGRID, KGRPNT, XYTST, ng)
#else
SUBROUTINE BCWAMN (FBCNAM, BCTYPE, BSPFIL, LBGP, 40.31
& XCGRID, YCGRID, KGRPNT, XYTST) 40.31
#endif
! *
!*********************************************************************
USE OCPCOMM2 40.41
USE OCPCOMM4 40.41
USE SWCOMM2 40.41
USE SWCOMM3 40.41
USE SWCOMM4 40.41
USE M_BNDSPEC 40.31
USE M_PARALL
IMPLICIT NONE 40.13
!
!
! --|-----------------------------------------------------------|--
! | Delft University of Technology |
! | Faculty of Civil Engineering |
! | Environmental Fluid Mechanics Section |
! | P.O. Box 5048, 2600 GA Delft, The Netherlands |
! | |
! | Programmers: The SWAN team |
! --|-----------------------------------------------------------|--
!
!
! SWAN (Simulating WAves Nearshore); a third generation wave model
! Copyright (C) 1993-2017 Delft University of Technology
!
! This program is free software; you can redistribute it and/or
! modify it under the terms of the GNU General Public License as
! published by the Free Software Foundation; either version 2 of
! the License, or (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! A copy of the GNU General Public License is available at
! http://www.gnu.org/copyleft/gpl.html#SEC3
! or by writing to the Free Software Foundation, Inc.,
! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
!
!
! 0. Authors
!
! 30.73: Nico Booij
! 30.90: IJsbrand Haagsma (Equivalence version)
! 34.01: Jeroen Adema
! 40.03: Nico Booij
! 40.13: N. Booij
! 40.31: Marcel Zijlema
! 40.41: Marcel Zijlema
! 40.61: Roop Lalbeharry
!
! 1. Updates
!
! 30.73, Jan. 98: new subroutine, based on older version by Weimin Luo
! 30.90, Oct. 98: Introduced EQUIVALENCE POOL-arrays
! 34.01, Feb. 99: Introducing STPNOW
! 40.03, Nov. 99: THD (first spectral direction in radians) added in
! expression for RBSDIR (directions of boundary spectrum)
! 40.03, Aug. 00: correction WAM nest with spherical SWAN
! 40.13, May 01: order of boundary points in WAM nesting file differed
! from order assumed in SWAN
! 40.31, Nov. 03: removing POOL-mechanism, reconsideration of this
! subroutine
! 40.41, Oct. 04: common blocks replaced by modules, include files removed
! 40.61, Nov. 06: variables USNEW, THWNEW no longer written in WAM4.5
!
! 2. PURPOSE
!
! reads file data for WAM nesting boundary condition
!
! 3. METHOD
!
!
! 4. Argument variables
!
! FBCNAM char inp filename of boundary data file
! BCTYPE char inp if value is "NEST": nesting b.c.
! XCGRID real inp x-coordinate of computational grid points
! YCGRID real inp y-coordinate of computational grid points
! KGRPNT int inp indirect addresses of grid points
! XYTST int inp ix, iy of test points
!
! 7. Common blocks used
!
!
! 5. SUBROUTINES CALLING
!
! SWBOUN
!
! 6. SUBROUTINES USED
!
! Ocean Pack command reading routines
!
#ifdef SWAN_MODEL
INTEGER, INTENT(in) :: ng
#endif
LOGICAL :: STPNOW 34.01
! 7. ERROR MESSAGES
!
! ---
!
! 8. REMARKS
!
! data concerning boundary files are stored in array BFILED
! there is a subarray for each file; it contains:
! 1. status; 0: stationary, 1: nonstat, -1: exhausted
! 2. time of boundary values read one before last
! 3. time of boundary values read last
! 4. NDSL: unit ref. num. of file containing filenames
! 5. NDSD: unit ref. num. of file containing data
! 6. time coding option for reading time from data file
! 8. number of locations for which spectra are in the file
! 9. order of reading directional information
! 10. number of spectral directions of spectra on file
! 12. number of spectral frequencies
! 14. number of heading lines per file
! 15. number of heading lines per time step
! 16. number of heading lines per spectrum
! 17. =1: energy dens., =2: variance density
!
!
! 9. STRUCTURE
!
! -----------------------------------------------------------------
! Open file containing filnames
! Read data file name
! Open boundary condition data file
! Read number of b.points, frequencies and directions
! Generate spectral directions from file into array BSPDIR
! Generate spectral frequencies from file into array BSPFRQ
! For all boundary spectra do
! read location from data file
! transform into local cartesian or spherical coordinates 40.13
! -----------------------------------------------------------------
! Determine spatial step size in WAM nesting file 40.13
! For all spatial points in WAM file do 40.13
! For all other spatial points in WAM file do 40.13
! If the two points are neighbours 40.13
! Then For all computational grid points on boundary do
! if point is located between nest file grid points
! calculate interpolation coefficients
! and put these into array BGRIDP
! -----------------------------------------------------------------
! Write file characteristics into array BFILED
! -----------------------------------------------------------------
!
! 10. SOURCE TEXT
!
INTEGER KGRPNT(MXC,MYC), XYTST(*)
REAL XCGRID(MXC,MYC), YCGRID(MXC,MYC)
TYPE(BSPCDAT) :: BSPFIL 40.31
LOGICAL :: LBGP 40.31
CHARACTER FBCNAM *(*), BCTYPE *(*)
!
! local variables
!
INTEGER ISTATF, NDSL, NDSD, IOSTAT, IERR, NBOUNC, NANG, NFRE,
& IBOUNC, IX1, IY1, IX2, IY2, IXP, IYP, IP, MIP, INDXGR,
& DORDER, IOPTT
! ISTATF if >0 file contains nonstationary data
! NDSL unit ref num of namelist file
! NDSD unit ref num of data file
! IOSTAT io status
! IERR error status
! NBOUNC number of boundary locations
! NANG number of directions on file
! NFRE number of frequencies on file
! IBOUNC counter of boundary spectra
! IX1
! IY1
! IX2
! IY2
! IXP
! IYP
! IP
! MIP
! INDXGR counter of boundary grid points
! DORDER if <0 order of reading directions is reversed
! IOPTT time reading option
INTEGER :: IIPT1=0, IIPT2=0
! local and overall number of interpolated boundary grid points
INTEGER :: NHEDF ! number of heading lines at begin of file 40.13
INTEGER :: NHEDT ! number of heading lines per time step 40.13
INTEGER :: NHEDS ! number of heading lines 40.13
INTEGER :: IBC, IDW, ISW, IFRE, II, ISIDE, IHD ! counters
INTEGER :: IBNC1, IBNC2 ! counters of nesting points
INTEGER :: IBSP1, IBSP2 ! counters of nesting points
REAL XP, YP, XP1, YP1, XP2, YP2, RR, RX, RY, RL2,
& XANG, XFRE, THD, FR1, CO, XBOU, XDELC,
& XLON, XLAT, XDATE, EMEAN, THQ, FMEAN
! XP problem coordinate of a comp. grid point on the boundary
! YP problem coordinate of a comp. grid point on the boundary
! XP1 problem coordinate of a boundary location
! YP1 problem coordinate of a boundary location
! XP2 problem coordinate of a boundary location
! YP2 problem coordinate of a boundary location
! RR
! RX vector connecting two boundary locations
! RY vector connecting two boundary locations
! RL2 length **2 of vector connecting two boundary locations
DOUBLE PRECISION, ALLOCATABLE :: XPWAM(:), YPWAM(:)
REAL, ALLOCATABLE :: SPAUX(:) 40.31
! locations of nesting points 40.13
DOUBLE PRECISION :: DXWAM, DYWAM ! spatial step sizes in nesting file 40.13
DOUBLE PRECISION :: DXTEST, DYTEST ! distance between two nesting points 40.13
REAL :: DISXY ! dim.less distance 40.13
REAL :: PHI ! direction of vector (RX,RY) 40.13
REAL :: DPHI ! difference in direction 40.13
REAL :: EPS ! tolerance 40.13
REAL :: W2 ! interpolation coefficient 40.13
CHARACTER (LEN=4) :: BTYPE ! type of boundary cond.
CHARACTER (LEN=14) :: CDATE ! date-time
CHARACTER (LEN=80) :: HEDLIN ! heading line
DOUBLE PRECISION :: DDATE, XLON0, XLAT0
! DDATE date-time
! XLON0 longitude of origin of computational grid
! XLAT0 latitude of origin of computational grid
#if !defined SWAN_MODEL
TYPE(BGPDAT), POINTER :: BGPTMP 40.31
#endif
! subroutines used
LOGICAL :: KEYWIS
INTEGER, SAVE :: IENT = 0 40.13
CALL STRACE (IENT, 'BCWAMN')
!
ISTATF = 1
IOPTT = 6
NDSL = 0
! open file with list of names
CALL FOR (NDSL, FILENM,'OF',IOSTAT)
IF (STPNOW()) RETURN 34.01
READ (NDSL,'(A36)') FILENM
CALL INKEYW ('REQ', ' ')
IF (KEYWIS('FRE')) THEN
BTYPE = 'WAMF'
ELSE IF (KEYWIS('UNF')) THEN
CALL INKEYW ('REQ', ' ')
IF (KEYWIS('WK')) THEN
BTYPE = 'WAMW'
ELSE
CALL IGNORE ('CRAY')
BTYPE = 'WAMC'
ENDIF
ENDIF
! open WAM data file
NDSD=0
IOSTAT = 0
IF (BTYPE.EQ.'WAMF') THEN
CALL FOR(NDSD,FILENM,'OF',IOSTAT)
IF (STPNOW()) RETURN 34.01
ELSE
CALL FOR(NDSD,FILENM,'OU',IOSTAT)
IF (STPNOW()) RETURN 34.01
ENDIF
!
! --- initialize array BFILED of BSPFIL 40.31
BSPFIL%BFILED = 0 40.31
!
! read spherical coordinates of point corresponding to
! [xpc], [ypc] in Cartesian coordinates
! not necessary if SWAN uses spherical coordinates 40.03
! if not given first point in data file is assumed
CALL INDBLE('XGC',XLON0,'STA',-999.D0) 40.01
CALL INDBLE('YGC',XLAT0,'STA',-999.D0) 40.01
CALL ININTG('LWDATE',LWDATE,'STA',12) 41.13
!
! start reading from the data file
!
! read resolution information from WAM input
!
IF (BTYPE.EQ.'WAMF') THEN
READ (NDSD,*) XANG, XFRE, THD, FR1, CO, XBOU, XDELC
ELSE
! Cray and workstation version
READ (NDSD) XANG, XFRE, THD, FR1, CO, XBOU, XDELC
ENDIF
!
! number of WAM boundary points
NBOUNC = NINT(XBOU)
! number of direction of WAM spectrum
NANG = NINT(XANG)
DORDER = -1
! number of frequencies of WAM spectrum
NFRE = NINT(XFRE)
! number of heading lines: per file, per time, per spectrum
NHEDF = 1
NHEDT = 0
NHEDS = 1
IF (ITEST.GE.80) THEN
WRITE(PRINTF,*) ' Number of frequencies in WAM:',NFRE
WRITE(PRINTF,*) ' Number of directions in WAM:',NANG
WRITE(PRINTF,*) ' Lowest frequency in WAM:',FR1
WRITE(PRINTF,*) ' fi/fi-1 in WAM:',CO
ENDIF
!
! convert WAM wave directions to SWAN convention
! apparently WAM uses direction TO which waves propagate !!
!
ALLOCATE(BSPFIL%BSPDIR(NANG)) 40.31
DO IDW = NANG,1,-1
BSPFIL%BSPDIR(NANG-IDW+1) = DNORTH*DEGRAD - 40.31 30.90
& THD - REAL(IDW-1)*PI2/REAL(NANG) 40.03
ENDDO
IF (ITEST.GE.50) WRITE (PRTEST,132) NANG,
& (BSPFIL%BSPDIR(IDW)*180./PI, IDW=1,NANG) 40.31 30.90
132 FORMAT (' WAMNEST dirs ', I3, (/, 20F6.0))
!
! calculate WAM angular frequency array
!
ALLOCATE(BSPFIL%BSPFRQ(NFRE)) 40.31
BSPFIL%BSPFRQ(1) = PI2*FR1 40.31 30.90
DO ISW = 2, NFRE
BSPFIL%BSPFRQ(ISW) = CO * BSPFIL%BSPFRQ(ISW-1) 40.31 30.90
ENDDO
IF (ITEST.GE.50) WRITE (PRTEST,133) NFRE,
& (BSPFIL%BSPFRQ(ISW)*180./PI, ISW=1,NFRE) 40.31 30.90
133 FORMAT (' WAMNEST freqs ', I3, (/, 20F6.2))
IF (NBOUNC.EQ.1) CALL MSGERR (3,
& 'WAM nest does not work with only one nesting point') 40.13
! allocate arrays XPWAM and YPWAM
ALLOCATE (XPWAM(1:NBOUNC), YPWAM(1:NBOUNC)) 40.13
ALLOCATE (SPAUX(NANG*NFRE)) 40.31
! read geographical locations and determine DXWAM and DYWAM 40.13
IIPT2 = 0 40.03
DXWAM = 180.
DYWAM = 180.
DO IBOUNC = 1, NBOUNC
IF (BTYPE.EQ.'WAMF') THEN
! read boundary point coordinates from file
READ(NDSD,*) XLON, XLAT, DDATE, EMEAN,
& THQ, FMEAN
IF (IBOUNC.EQ.1 .AND. ITEST.GE.80) WRITE (PRTEST, *) 40.13
& ' WAMNEST starting time ', DDATE 40.13
! read spectral densities but ignore them for the moment
DO IFRE=1,NFRE
READ(NDSD,*) (SPAUX(II), II=1,NANG) 40.31 30.90
ENDDO
ELSE IF (BTYPE.EQ.'WAMC') THEN
! read boundary point coordinates from file
READ(NDSD) XLON, XLAT, XDATE, EMEAN,
& THQ, FMEAN
IF (IBOUNC.EQ.1 .AND. ITEST.GE.80) WRITE (PRTEST, *) 40.13
& ' WAMNEST starting time ', XDATE 40.13
! read spectral densities but ignore them for the moment
READ(NDSD) (SPAUX(II), II=1,NANG*NFRE) 40.31 30.90
ELSE
! read boundary point coordinates from file
READ(NDSD) XLON, XLAT, CDATE(1:LWDATE), EMEAN, THQ, FMEAN 41.13
IF (IBOUNC.EQ.1 .AND. ITEST.GE.80) WRITE (PRTEST, *) 40.13
& ' WAMNEST starting time ', CDATE(1:LWDATE) 41.13 40.13
! read spectral densities but ignore them for the moment
READ(NDSD) (SPAUX(II), II=1,NANG*NFRE) 40.31 30.90
ENDIF
IF (ITEST.GE.50) WRITE (PRINTF, 178) IBOUNC, XLON, XLAT 40.13
178 FORMAT (' boundary spectrum ', I3, ' at ', 2F12.4) 40.13
XPWAM(IBOUNC) = XLON 40.13
YPWAM(IBOUNC) = XLAT 40.13
! determine DXWAM and DYWAM 40.13
IF (IBOUNC.GT.1) THEN 40.13
IF (ABS(XPWAM(IBOUNC)-XPWAM(IBOUNC-1)).GT.1.E-6) 40.13
& DXWAM = MIN (DXWAM, ABS(XPWAM(IBOUNC)-XPWAM(IBOUNC-1))) 40.13
IF (ABS(YPWAM(IBOUNC)-YPWAM(IBOUNC-1)).GT.1.E-6) 40.13
& DYWAM = MIN (DYWAM, ABS(YPWAM(IBOUNC)-YPWAM(IBOUNC-1))) 40.13
ENDIF
IF (KSPHER.EQ.0) THEN 33.09
! determine lower left corner of WAM nesting grid if not given by the user
IF (IBOUNC.EQ.1) THEN
IF (XLON0.LT.-900.) THEN
XLON0 = XLON
XLAT0 = XLAT
ENDIF
ENDIF
ENDIF
ENDDO 40.13
IF (ITEST.GE.50) WRITE (PRINTF, 182) DXWAM, DYWAM 40.13
182 FORMAT (' WAM step sizes: ', 2F12.4) 40.13
EPS = 0.01 * MIN(DXWAM,DYWAM) 40.13
! determine interpolation coefficients for all couples of 40.13
! neighbouring WAM nest points 40.13
DO IBNC1 = 1, NBOUNC
160 DO IBNC2 = IBNC1+1, NBOUNC 40.13
DXTEST = ABS(XPWAM(IBNC1)-XPWAM(IBNC2)) 40.13
DYTEST = ABS(YPWAM(IBNC1)-YPWAM(IBNC2)) 40.13
IF ((DXTEST.LT.EPS .AND. ABS(DYTEST-DYWAM).LT.EPS) .OR. 40.13
& (DYTEST.LT.EPS .AND. ABS(DXTEST-DXWAM).LT.EPS)) THEN 40.13
! points IBNC1 and IBNC2 are neighbours 40.13
IF (KSPHER.EQ.0) THEN 33.09
! transform to local Cartesian coordinates
XP1 = XPC + LENDEG*COS(PI*XLAT0/180.)*(XPWAM(IBNC1)-XLON0) 40.13
YP1 = YPC + LENDEG*(YPWAM(IBNC1)-XLAT0) 40.13
XP2 = XPC + LENDEG*COS(PI*XLAT0/180.)*(XPWAM(IBNC2)-XLON0) 40.13
YP2 = YPC + LENDEG*(YPWAM(IBNC2)-XLAT0) 40.13
ELSE
XP1 = XPWAM(IBNC1) - XOFFS 40.13
YP1 = YPWAM(IBNC1) - YOFFS 40.13
XP2 = XPWAM(IBNC2) - XOFFS 40.13
YP2 = YPWAM(IBNC2) - YOFFS 40.13
ENDIF
! Determine interpolation coefficients
IBSP1 = NBSPEC+IBNC1 40.13
IBSP2 = NBSPEC+IBNC2 40.13
IIPT1 = 0 40.03
RX = XP2 - XP1
RY = YP2 - YP1
RL2 = RX**2 + RY**2
IF (RL2.GT.0.) THEN
RX = RX/RL2
RY = RY/RL2
! check whether direction of (RX,RY) corresponds to ALPC + k * 90 degr
PHI = ATAN2(RY,RX)
DPHI = MOD(PHI-ALPC+1.25*PI,0.5*PI)-0.25*PI
IF (ABS(DPHI) .LT. 0.1) THEN
! loop over boundary of comp. grid, select points between
! (XP1,YP1) and (XP2,YP2)
DO ISIDE = 1, 4
IF (ISIDE.EQ.1) THEN
IX1 = 1
IY1 = 1
IX2 = MXC
IY2 = 1
MIP = MXC
ELSE IF (ISIDE.EQ.2) THEN
IX1 = MXC
IY1 = 1
IX2 = MXC
IY2 = MYC
MIP = MYC
ELSE IF (ISIDE.EQ.3) THEN
IX1 = MXC
IY1 = MYC
IX2 = 1
IY2 = MYC
MIP = MXC
ELSE IF (ISIDE.EQ.4) THEN
IX1 = 1
IY1 = MYC
IX2 = 1
IY2 = 1
MIP = MYC
ENDIF
DO IP = 1, MIP-1
RR = REAL(IP-1) / REAL(MIP-1)
IXP = IX1 + NINT(RR*REAL(IX2-IX1))
IYP = IY1 + NINT(RR*REAL(IY2-IY1))
INDXGR = KGRPNT(IXP,IYP)
IF (INDXGR.GT.1) THEN
XP = XCGRID(IXP,IYP)
YP = YCGRID(IXP,IYP)
! DISXY is relative distance from (XP,YP) to line
! (XP1,YP1) to (XP2,YP2)
DISXY = ABS(RX*(YP-YP1)-RY*(XP-XP1))
IF (DISXY.LT.0.1) THEN
! W2 is relative length of projection on line
! (XP1,YP1) to (XP2,YP2)
W2 = RX*(XP-XP1)+RY*(YP-YP1)
IF (W2.GT.-0.001 .AND. W2.LT.1.001) THEN
IF (W2.LT.0.01) W2 = 0.
IF (W2.GT.0.99) W2 = 1.
IF (ITEST.GE.80) WRITE (PRTEST, 223) IXP, IYP,
& XP+XOFFS, YP+YOFFS, W2, IBNC1, IBNC2 40.13
223 FORMAT (' B.pnt', 2I5, 2F14.4, F6.3,
& ' from ', 2I3) 40.13
NBGRPT = NBGRPT + 1
IIPT1 = IIPT1 + 1 40.03
IIPT2 = IIPT2 + 1 40.03
#ifdef SWAN_MODEL
ALLOCATE(BGPDATZ_MOD(ng)%BGPTMP)
! ALLOCATE(BGPDATZ_MOD(ng)%FBGP)
! ALLOCATE(BGPDATZ_MOD(ng)%CUBGP)
BGPDATZ_MOD(ng)%BGPTMP%BGP(1) = INDXGR
! next item indicates type of boundary condition
BGPDATZ_MOD(ng)%BGPTMP%BGP(2) = 1
BGPDATZ_MOD(ng)%BGPTMP%BGP(3) = NINT(1000.*W2)
BGPDATZ_MOD(ng)%BGPTMP%BGP(4) = IBSP2
BGPDATZ_MOD(ng)%BGPTMP%BGP(5) = NINT(1000. * &
& (1.-W2))
BGPDATZ_MOD(ng)%BGPTMP%BGP(6) = IBSP1
NULLIFY(BGPDATZ_MOD(ng)%BGPTMP%NEXTBGP)
IF ( .NOT.LBGP ) THEN
BGPDATZ_MOD(ng)%FBGP=>BGPDATZ_MOD(ng)%BGPTMP
BGPDATZ_MOD(ng)%CUBGP=>BGPDATZ_MOD(ng)%FBGP
LBGP = .TRUE.
ELSE
BGPDATZ_MOD(ng)%CUBGP%NEXTBGP => &
& BGPDATZ_MOD(ng)%BGPTMP
BGPDATZ_MOD(ng)%CUBGP => &
& BGPDATZ_MOD(ng)%BGPTMP
END IF
#else
ALLOCATE(BGPTMP) 40.31
BGPTMP%BGP(1) = INDXGR 40.31
! next item indicates type of boundary condition
BGPTMP%BGP(2) = 1 40.31
BGPTMP%BGP(3) = NINT(1000. * W2) 40.31
BGPTMP%BGP(4) = IBSP2 40.31
BGPTMP%BGP(5) = NINT(1000. * (1.-W2)) 40.31
BGPTMP%BGP(6) = IBSP1 40.31
NULLIFY(BGPTMP%NEXTBGP) 40.31
IF ( .NOT.LBGP ) THEN 40.31
FBGP = BGPTMP 40.31
CUBGP => FBGP 40.31
LBGP = .TRUE. 40.31
ELSE 40.31
CUBGP%NEXTBGP => BGPTMP 40.31
CUBGP => BGPTMP 40.31
END IF 40.31
#endif
! test output if point is a test point
IF (NPTST.GT.0) THEN
DO IPTST = 1, NPTST
IF (IXP.EQ.XYTST(2*IPTST-1)+MXF-1 .AND.
& IYP.EQ.XYTST(2*IPTST )+MYF-1)
& WRITE (PRTEST, 223) IXP, IYP,
& XP+XOFFS, YP+YOFFS, W2, IBSP2, IBSP1
ENDDO
ENDIF
ENDIF
ENDIF
ENDIF
ENDDO
ENDDO
ENDIF
ENDIF
IF (IIPT1.EQ.0) THEN
WRITE (PRINTF, 218) XP1+XOFFS, YP1+YOFFS,
& XP2+XOFFS, YP2+YOFFS
218 FORMAT (' Warning: no grid points on interval from ', 40.03
& 2F14.4, ' to ', 2F14.4)
ENDIF
ENDIF
ENDDO 40.13
! first nesting point may have two valid neighbours 40.13
IF (IBNC1.EQ.1 .AND. IBNC2.EQ.2) GOTO 160 40.13
ENDDO
IF (IIPT2.EQ.0) CALL MSGERR (2,
& 'no grid points on nested boundary') 40.03
IF (ITEST.GE.60) WRITE (PRTEST,16) NBOUNC
16 FORMAT (I6, ' boundary locations')
! deallocate arrays XPWAM, YPWAM and SPAUX
DEALLOCATE (XPWAM, YPWAM, SPAUX) 40.31 40.13
ALLOCATE(BSPFIL%BSPLOC(NBOUNC)) 40.31
DO IBC = 1, NBOUNC
BSPFIL%BSPLOC(IBC) = NBSPEC + IBC 40.31
ENDDO
NBSPEC = NBSPEC + NBOUNC
!
! store file reading parameters in array BFILED
!
BSPFIL%BFILED(1) = ISTATF 40.31
BSPFIL%BFILED(2) = -999999999 40.31
BSPFIL%BFILED(3) = -999999999 40.31
BSPFIL%BFILED(4) = NDSL 40.31
BSPFIL%BFILED(5) = NDSD 40.31
BSPFIL%BFILED(6) = IOPTT 40.31
CALL COPYCH (BTYPE, 'T', BSPFIL%BFILED(7), 1, IERR) 40.31
BSPFIL%BFILED(8) = NBOUNC 40.31
BSPFIL%BFILED(9) = DORDER 40.31
BSPFIL%BFILED(10) = NANG 40.31
BSPFIL%BFILED(11) = 0 40.31
BSPFIL%BFILED(12) = NFRE 40.31
! ordering of data on file
BSPFIL%BFILED(13) = 0 40.31
! number of heading lines: per file, per time, per spectrum
BSPFIL%BFILED(14) = NHEDF 40.31
BSPFIL%BFILED(15) = NHEDT 40.31
BSPFIL%BFILED(16) = NHEDS 40.31
! quantity on file is variance density
BSPFIL%BFILED(17) = 2 40.31
!
IF (ITEST.GE.80) WRITE(PRINTF,81) NBFILS, NBSPEC,
& (BSPFIL%BFILED(II), II=1,16) 40.31
81 FORMAT (' array BFILED: ', 2I4, 2(/,8I10))
!
! Rewind input file for proper start
REWIND (NDSD)
! read heading line
IF (BTYPE.EQ.'WAMF') THEN
DO IHD = 1, BSPFIL%BFILED(14) 40.31
READ (NDSD, '(A)') HEDLIN
IF (ITEST.GE.80) WRITE (PRINTF, 212) HEDLIN
212 FORMAT (' heading line: ', A)
ENDDO
ELSE
DO IHD = 1, BSPFIL%BFILED(14) 40.31
READ (NDSD)
ENDDO
ENDIF
RETURN
END SUBROUTINE BCWAMN
!*********************************************************************
! *
#ifdef SWAN_MODEL
SUBROUTINE BCWW3N (FBCNAM, BCTYPE, BSPFIL, LBGP, 40.31
& XCGRID, YCGRID, KGRPNT, 40.31
& XYTST, KGRBND, ng) 40.31
#else
SUBROUTINE BCWW3N (FBCNAM, BCTYPE, BSPFIL, LBGP, 40.31
& XCGRID, YCGRID, KGRPNT, 40.31
& XYTST, KGRBND) 40.31
#endif
! *
!*********************************************************************
!
USE OCPCOMM2 40.41
USE OCPCOMM4 40.41
USE SWCOMM2 40.41
USE SWCOMM3 40.41
USE SWCOMM4 40.41
USE M_BNDSPEC 40.31
!
IMPLICIT NONE
!
!
! --|-----------------------------------------------------------|--
! | Delft University of Technology |
! | Faculty of Civil Engineering |
! | Environmental Fluid Mechanics Section |
! | P.O. Box 5048, 2600 GA Delft, The Netherlands |
! | |
! | Programmers: The SWAN team |
! --|-----------------------------------------------------------|--
!
!
! SWAN (Simulating WAves Nearshore); a third generation wave model
! Copyright (C) 1993-2017 Delft University of Technology
!
! This program is free software; you can redistribute it and/or
! modify it under the terms of the GNU General Public License as
! published by the Free Software Foundation; either version 2 of
! the License, or (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! A copy of the GNU General Public License is available at
! http://www.gnu.org/copyleft/gpl.html#SEC3
! or by writing to the Free Software Foundation, Inc.,
! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
!
!
! 0. Authors
!
! 40.05 : Ekaterini E. Kriezi
! 40.13 : Nico Booij
! 40.31 : Marcel Zijlema
! 40.41 : Marcel Zijlema
!
! 1. Updates
!
! 40.05, Aug. 00: new subroutine
! 40.13, Jan. 01: remove declarations of unused variables
! 40.31, Nov. 03: removing POOL-mechanism, reconsideration this
! subroutine
! 40.41, Oct. 04: common blocks replaced by modules, include files removed
!
! 2. Purpose
!
! reads file data for WaveWatch III boundary condition
!
! 3. Method
!
! open boundaries files
! read from ASCII files the points where the energy density is given and
! interpolate them to the grid points of the SWAN computational grid
!
! 4. Argument variables
!
#ifdef SWAN_MODEL
INTEGER, INTENT(IN) :: ng
#endif
INTEGER, INTENT(IN) :: KGRPNT(MXC,MYC)
! indirect addresses of computational grid points
INTEGER, INTENT(IN) :: KGRBND(*)
! array of boundary grid points
INTEGER, INTENT(IN) :: XYTST(*)
! array of (ix,iy) of test points
REAL, INTENT(IN) :: XCGRID(MXC,MYC), YCGRID(MXC,MYC)
! coordinates of computational grid points
! FBCNAM char inp filename of boundary data file
! BCTYPE char inp boundary condition type, is 'WW3N' in this case
!
CHARACTER FBCNAM *(*), BCTYPE *(*)
TYPE(BSPCDAT) :: BSPFIL 40.31
LOGICAL :: LBGP 40.31
!
! 5. Parameter variables
!
! --
!
! 6. Local variables
!
! IENT number of entries into this subroutine
! IBC spectrum counter
!
INTEGER :: IENT, IBC
!
REAL, ALLOCATABLE :: FRQ_ARRAY(:), DIR_ARRAY(:)
!
! IHD counter of heading lines
! WWDATE date in boundary file
! WWTIME time in boundary file
!
INTEGER :: WWDATE, WWTIME
!
! ISTATF if >0 file contains nonstationary data
! NDSL unit ref num of namelist file
! NDSD unit ref num of data file
! IOSTAT io status
! IERR error status
! NBOUNC number of boundary locations
! NANG number of directions on file
! NFRE number of frequencies on file
! DORDER if <0 order of reading directions is reversed
! IOPTT time reading option
! IBOUNC counter of boundary points
! IGRBND counter of boundary grid(swan grid) points
! II counter
! NHEDF number of heading lines per file
! NHEDT number of heading lines per time step
! NHEDS number of heading lines per spectrum
!
INTEGER :: ISTATF, NDSL, NDSD, IOSTAT, IERR
INTEGER :: NBOUNC, NANG, NFRE
INTEGER :: IBOUNC
INTEGER :: DORDER, IOPTT
INTEGER :: NHEDF, NHEDT, NHEDS, NBGRPT_PREV
INTEGER :: IHD, IFRE, IANG, II, IIPT2
!
! DONALL : logic arguments declare if the boundary is open or close
!
LOGICAL :: DONALL
!
! DUM_A real number used for reading a file but not used in any calculation
! XLON longitude
! XLAT latitude
! XP2 problem coordinate of a boundary location
! YP2 problem coordinate of a boundary location
! DIRRD1
! NBGRPT_PREV is the prevous number of NBGRPT
! IIPT2 counter use for the chekinf if there are grid points on nested boundary
!
REAL :: DUM_A, XLON, XLAT,XP2,YP2,DIRRD1
!
CHARACTER (LEN=4) :: BTYPE
! type of boundary cond.
CHARACTER (LEN=21) :: HEDLINT
! WW3 version
CHARACTER (LEN=30) :: GNAME
! name of test case readed from b. file
CHARACTER (LEN=10) :: PTNME
! name of b. point
! XLON0 longitude of origin of computational grid
! XLAT0 latitude of origin of computational grid
!
DOUBLE PRECISION :: XLON0, XLAT0
!
! FBCNAM char inp filename of boundary data file
! BCTYPE char inp if value is "NEST": nesting b.c.
! XCGRID real inp x-coordinate of computational grid points
! YCGRID real inp y-coordinate of computational grid points
! KGRPNT int inp indirect addresses of grid points
! XYTST int inp ix, iy of test points
!
! 8. Subroutines used
!
! Ocean Pack command reading routines
! SWBCPT, STPNOW
!
LOGICAL :: STPNOW
LOGICAL :: KEYWIS
!
! 9. Subroutines calling
!
! SWREAD
!
! 10. Error messages
!
! ---
!
! 11. Remarks
!
! data concerning boundary files are stored in array BFILED
! there is a subarray for each file; it contains:
! 1. status; 0: stationary, 1: nonstat, -1: exhausted
! 2. time of boundary values read one before last
! 3. time of boundary values read last
! 4. NDSL: unit ref. num. of file containing filenames
! 5. NDSD: unit ref. num. of file containing data
! 6. time coding option for reading time from data file
! 8. number of locations for which spectra are in the file
! 9. order of reading directional information
! 10. number of spectral directions of spectra on file
! 12. number of spectral frequencies
! 14. number of heading lines per file
! 15. number of heading lines per time step
! 16. number of heading lines per spectrum
! 17. =1: energy dens., =2: variance density, =3 variance energy density (k)
! 18. =1: Cartesian direction, =2: Nautical dir.
! 19. =1: direction spread in degr, =2: Power of Cos.
! 20. depth of boundary points
!
! 12. Structure
!
! -----------------------------------------------------------------
! Unformatted WW3 point output transfer file -- b.c. type is WW3U.
! Formatted WW3 point output transfer file -- b.c. type is WW3F.
! -----------------------------------------------------------
!
! Read spectral directions from file and write them into
! array BSPDIR
! Read spectral frequencies from fileand write them into
! array BSPFRQ
! For all boundary points do
! read location from data file
! transform into local cartesian coordinates (if nesesery)
! Then calculate data on grid points
!
! -----------------------------------------------------------------
! Put file characteristics into array BFILED
! -----------------------------------------------------------------
!
! 13. Source text
!
SAVE IENT
DATA IENT /0/
CALL STRACE (IENT, 'BCWW3N')
!
! Process required UNFormatted/FREe keyword
CALL INKEYW ('REQ', ' ')
IF (KEYWIS('FRE')) THEN
BTYPE = 'WW3F'
ELSE IF (KEYWIS('UNF')) THEN
BTYPE = 'WW3U'
ELSE
CALL WRNKEY
CALL MSGERR (4, 'The BOUndnest3 WW3 command requires '//
& 'UNFormatted or FREe as the first keyword.' )
ENDIF
IF (STPNOW()) RETURN
!
! Process optional CLOS/OPEN keyword
! if keyword is OPEN (boundary is not a closed contour) then
! DONALL is TRUE and the nesting boundary remain open
! else (default case)
! DONALL is FALSE and boundary is close and interpolation
! between the last and the first point will be done
CALL INKEYW ('STA', 'CLOS')
IF (KEYWIS('OPEN')) THEN
DONALL = .TRUE.
ELSE IF (KEYWIS('CLOS')) THEN
DONALL = .FALSE.
ELSE
CALL WRNKEY
ENDIF
IF (STPNOW()) RETURN
!
! NDSL unit ref number for namelist files
NDSL = 0
ISTATF = 1
! number of heading lines: per file, per time, per spectrum
NHEDF = 0
NHEDT = 0
NHEDS = 0
DORDER = -1
IOPTT = 1
IIPT2 = 0
!
! open data file NDSD unit ref number for data files
NDSD = 0
IOSTAT = 0
IF (BTYPE.EQ.'WW3F') THEN
CALL FOR (NDSD, FILENM , 'OF', IOSTAT)
ELSE
CALL FOR (NDSD, FILENM , 'OU', IOSTAT)
ENDIF
IF (STPNOW()) RETURN
!
! Read header
IF (BTYPE.EQ.'WW3F') THEN
READ (NDSD, 1944) HEDLINT, NFRE, NANG, NBOUNC, GNAME
ELSE
READ (NDSD) HEDLINT, NFRE, NANG, NBOUNC, GNAME
ENDIF
IF (HEDLINT .NE. 'WAVEWATCH III SPECTRA')
& CALL MSGERR (3, 'file is not a WW3 spectral file')
IF (NBOUNC.LT.2) CALL MSGERR
& (3, 'SWAN need at least 2 boundary points for nesting')
!
! --- initialize array BFILED of BSPFIL 40.31
BSPFIL%BFILED = 0 40.31
!
! read frequencies from WW3 boundary file
!
ALLOCATE (FRQ_ARRAY(1:NFRE), DIR_ARRAY(1:NANG) )
!
! read frequency
! FRQ_ARRAY(IFRE) = SIG(IK)/(2*PI)
!
IF (BTYPE.EQ.'WW3F') THEN
READ (NDSD,1945) (FRQ_ARRAY(IFRE) ,IFRE=1,NFRE)
ELSE
READ (NDSD) (FRQ_ARRAY(IFRE) ,IFRE=1,NFRE)
ENDIF
!
ALLOCATE(BSPFIL%BSPFRQ(NFRE)) 40.31
DO IFRE = 1, NFRE
BSPFIL%BSPFRQ(IFRE) = FRQ_ARRAY(IFRE)*2*PI 40.31
ENDDO
!
IF (ITEST.GE.60) THEN
WRITE(PRTEST,*) ' HEDLINT ',' NFRE ',' NANG ',' NBOUNC ',
& ' GNAME'
WRITE (PRTEST,*) HEDLINT, NFRE, NANG, NBOUNC, GNAME
WRITE (PRTEST,*) 'Frequencies read from boundary file ', FILENM
WRITE (PRTEST,*) (FRQ_ARRAY(IFRE),IFRE = 1,NFRE)
ENDIF
!
! read direction from WW3 boundary file
! DIR_ARRAY(IANG) = MOD(2.5*PI-TH(ITH),TPI)
! there are in radians but is not in right order related to SWAN
!
IF (BTYPE.EQ.'WW3F') THEN
READ (NDSD,1946) (DIR_ARRAY(IANG),IANG=1,NANG)
ELSE
READ (NDSD) (DIR_ARRAY(IANG),IANG=1,NANG)
ENDIF
!
! put values in right order. The value of the DIR_ARRAY(i) should be
! smaller that the DIR_ARRAY(i-1)
! in the opposite situation make DIR_ARRAY(i) = DIR_ARRAY(i) - 2*PI
!
DIR_ARRAY(:) = PI*DNORTH/180 - DIR_ARRAY(:) 40.15
ALLOCATE(BSPFIL%BSPDIR(NANG)) 40.31
DO IANG = 1, NANG
IF (IANG.EQ.1) THEN
BSPFIL%BSPDIR(1) = DIR_ARRAY(IANG) 40.31
DIRRD1 = BSPFIL%BSPDIR(1) 40.31
ELSE
IF (DIR_ARRAY(IANG).LT.DIRRD1) THEN
BSPFIL%BSPDIR(IANG) = 2*PI+DIR_ARRAY(IANG) 40.31
DIRRD1 = BSPFIL%BSPDIR(IANG) 40.31
ELSE
BSPFIL%BSPDIR(IANG) = DIR_ARRAY(IANG) 40.31
DIRRD1 = BSPFIL%BSPDIR(IANG) 40.31
ENDIF
ENDIF
ENDDO
IF(ITEST.GE.60) THEN
WRITE (PRTEST,*) 'Directions read from boundary file ',
& FILENM
WRITE (PRTEST,1946) (DIR_ARRAY(IANG),IANG = 1,NANG)
ENDIF
!
! Time
IF (BTYPE.EQ.'WW3F') THEN
READ (NDSD, 900) WWDATE,WWTIME
ELSE
READ (NDSD) WWDATE,WWTIME
ENDIF
!
! Read from boundary file info about the boundary points(b.p): name of b. p.,
! geographical location of b.p., depth, wind u-velocity and direction at the b.p.
! current velocity and direction at the b.p.
!
! If DONALL = .TRUE. boundary data correspond to an open boundary otherwise
! it is continue the interpolation of the grid point between the last and the
! first point
!
DO IBOUNC = 1, NBOUNC
IERR = 0
!
! latitude = XLAT
! longitude = XLON
! A real which is not used in the computation
!
IF (BTYPE.EQ.'WW3F') THEN
READ (NDSD,901) PTNME, XLAT, XLON, DUM_A, DUM_A,
& DUM_A, DUM_A, DUM_A
ELSE
READ (NDSD) PTNME, XLAT, XLON, DUM_A, DUM_A,
& DUM_A, DUM_A, DUM_A
ENDIF
! Pass over the lines where the energy spectra is written in the boundary file.
! The energy spectra is going to be read later, in the subroutine RESPEC
!
IF (BTYPE.EQ.'WW3F') THEN
READ (NDSD,902) ((DUM_A, IFRE = 1,NFRE),IANG = 1,NANG)
ELSE
READ (NDSD) ((DUM_A, IFRE = 1,NFRE),IANG = 1,NANG)
ENDIF
!
IF (ITEST.GE.80) THEN
WRITE (PRTEST, *) ' B. spectrum WW3 ', IBOUNC, XLON,
& XLAT, IERR
ENDIF
!
! in case of nesting coordinates on file are used to determine interpolation
! coefficients
!
IF (KSPHER.EQ.0) THEN
!
! if SWAN uses Cartesian coordinates, then transform the spherical coordinates
! of the boundary point to local Cartesian coordinates
!
IF (IBOUNC.EQ.1) THEN
CALL INDBLE('XGC',XLON0,'REQ',-999.D0)
CALL INDBLE('YGC',XLAT0,'REQ',-999.D0)
IF (XLON0.LT.-900.) THEN
XLON0 = (XOFFS -XPC)/LENDEG
XLAT0 = (YOFFS-YPC)/LENDEG
ENDIF
ENDIF
!
XP2 = XPC + LENDEG*COS(PI*XLAT0/180.)*(XLON-XLON0)
YP2 = YPC + LENDEG*(XLAT-XLAT0)
!
ELSE
XP2 = XLON-XOFFS
YP2 = XLAT-YOFFS
ENDIF
!
! --- interpolate the boundaries points to the grid points of
! the SWAN computational grid
!
NBGRPT_PREV = NBGRPT
#ifdef SWAN_MODEL
CALL SWBCPT ( LBGP, XCGRID, YCGRID, 40.41 40.31
& KGRPNT, XYTST, KGRBND,XP2,YP2,IBOUNC,
& NBOUNC, DONALL, ng )
#else
CALL SWBCPT ( LBGP, XCGRID, YCGRID, 40.41 40.31
& KGRPNT, XYTST, KGRBND,XP2,YP2,IBOUNC,
& NBOUNC, DONALL )
#endif
! check if the grid points are on nested boundary.
! if not, stop the calculation and give an error message
IF (NBGRPT.NE.NBGRPT_PREV) THEN
IIPT2 = IIPT2+1
ENDIF
ENDDO
!
IF (IIPT2.EQ.0) CALL MSGERR (2,
& 'no grid points on nested boundary')
!
IF (ITEST.GE.60) WRITE (PRTEST,16) NBOUNC
16 FORMAT (I6, ' boundary locations')
!
! quantity on file is energy density
BSPFIL%BFILED(17) = 1 40.31
!
! number of heading lines: per file, per time, per spectrum
IF (BTYPE.EQ.'WW3F') THEN
NHEDF = NHEDF + CEILING(NFRE/8.) + CEILING(NANG/7.)+1
! NHEDT: calculated in the RBFILE subroutine for each time step
NHEDS = 2
ELSE
NHEDF = 3
NHEDT = 0
NHEDS = 1
ENDIF
!
ALLOCATE(BSPFIL%BSPLOC(NBOUNC)) 40.31
DO IBC = 1, NBOUNC
BSPFIL%BSPLOC(IBC) = NBSPEC + IBC 40.31
ENDDO
!
NBSPEC = NBSPEC + NBOUNC
!
! store file reading parameters in array BFILED
!
BSPFIL%BFILED(1) = ISTATF 40.31
BSPFIL%BFILED(2) = -999999999 40.31
BSPFIL%BFILED(3) = -999999999 40.31
BSPFIL%BFILED(4) = NDSL 40.31
BSPFIL%BFILED(5) = NDSD 40.31
BSPFIL%BFILED(6) = IOPTT 40.31
CALL COPYCH (BTYPE, 'T', BSPFIL%BFILED(7), 1, IERR) 40.31
BSPFIL%BFILED(8) = NBOUNC 40.31
BSPFIL%BFILED(9) = DORDER 40.31
BSPFIL%BFILED(10) = NANG 40.31
BSPFIL%BFILED(11) = 0 40.31
BSPFIL%BFILED(12) = NFRE 40.31
! ordering of data on file
BSPFIL%BFILED(13) = 0 40.31
! number of heading lines: per file, per time, per spectrum
BSPFIL%BFILED(14) = NHEDF 40.31
BSPFIL%BFILED(15) = NHEDT 40.31
BSPFIL%BFILED(16) = NHEDS 40.31
! quantity on file is energy density (k)
BSPFIL%BFILED(17) = 3 40.31
!
IF (ITEST.GE.80) WRITE(PRINTF,81) NBFILS, NBSPEC,
& (BSPFIL%BFILED(II), II=1,16) 40.31
!
! Rewind input file for proper start
REWIND (NDSD)
! read per file heading lines
IF (BTYPE.EQ.'WW3U') THEN
DO IHD = 1, BSPFIL%BFILED(14)
READ (NDSD)
ENDDO
ENDIF
81 FORMAT (' array BFILED: ', 2I4, 2(/,8I10))
900 FORMAT (I8.8,I7.6)
901 FORMAT (1X,A10,1X,2F7.2,F10.1,2(F7.2,F6.1))
902 FORMAT (7E11.3)
1944 FORMAT (1X,A21,1X,1X,3I6,1X,1X,A30,1X)
1945 FORMAT (8E10.3)
1946 FORMAT (7E11.3)
DEALLOCATE (FRQ_ARRAY,DIR_ARRAY)
RETURN
END SUBROUTINE BCWW3N
!***********************************************************************
!
#ifdef SWAN_MODEL
SUBROUTINE SWBCPT ( LBGP, XCGRID, YCGRID, 40.41 40.31
& KGRPNT, XYTST, KGRBND,XP2,YP2,IBOUNC,
& NBOUNC,DONALL, ng )
#else
SUBROUTINE SWBCPT ( LBGP, XCGRID, YCGRID, 40.41 40.31
& KGRPNT, XYTST, KGRBND,XP2,YP2,IBOUNC,
& NBOUNC,DONALL )
#endif
!
!************************************************************************
!
USE OCPCOMM4 40.41
USE SWCOMM2 40.41
USE SWCOMM3 40.41
USE SWCOMM4 40.41
USE M_BNDSPEC
USE M_PARALL
USE SwanGriddata 40.80
USE SwanGridobjects 40.80
!
IMPLICIT NONE
!
!
! --|-----------------------------------------------------------|--
! | Delft University of Technology |
! | Faculty of Civil Engineering |
! | Environmental Fluid Mechanics Section |
! | P.O. Box 5048, 2600 GA Delft, The Netherlands |
! | |
! | Programmers: The SWAN team |
! --|-----------------------------------------------------------|--
!
!
! SWAN (Simulating WAves Nearshore); a third generation wave model
! Copyright (C) 1993-2017 Delft University of Technology
!
! This program is free software; you can redistribute it and/or
! modify it under the terms of the GNU General Public License as
! published by the Free Software Foundation; either version 2 of
! the License, or (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! A copy of the GNU General Public License is available at
! http://www.gnu.org/copyleft/gpl.html#SEC3
! or by writing to the Free Software Foundation, Inc.,
! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
!
!
! 0. Authors
!
! 30.73, 40.13: Nico Booij
! 40.05: Ekaterini E. Kriezi
! 40.31: Tim Campbell and John Cazes
! 40.31: Marcel Zijlema
! 40.41: Marcel Zijlema
! 41.14: Nico Booij
!
! 1. Updates
!
! 40.05, Aug. 00: remove the code to a separate subroutine
! 40.13, Jan. 01: remove declarations of unused variables
! 40.31, Jul. 03: initializations XP0, XP1, YP0, YP1
! 40.31, Nov. 03: removing POOL mechanism
! 40.41, Oct. 04: common blocks replaced by modules, include files removed
! 41.14, Jul. 10: error in nesting unstructured grid corrected
!
! 2. Purpose
!
! interpolation of own boundary points to nesting boundary points
!
! 3. Method
!
! calculate interpolation coefficients between the nesting boundary grid and
! the SWAN computational grid
!
! 4. Argument variables
!
! NBOUNC: max number of boundaries points
! IBOUNC: counter
!
!
#ifdef SWAN_MODEL
INTEGER, INTENT(in) :: ng
#endif
INTEGER, INTENT(IN) :: KGRPNT(MXC,MYC) ! indirect addresses of computational grid points
INTEGER, INTENT(IN) :: KGRBND(*) ! array of boundary grid points
INTEGER, INTENT(IN) :: XYTST(*) ! array of (ix,iy) of test points
!
INTEGER, INTENT(IN) :: IBOUNC,NBOUNC
!
REAL :: XP2, YP2 ! coordinates of a point in spectral file 41.14
REAL, INTENT(IN) :: XCGRID(MXC,MYC), YCGRID(MXC,MYC) ! coordinates of computational grid points
!
! DONALL : logic arguments declare if the nesting boundary is open or close
! it is defined by the users
!
LOGICAL, INTENT(INOUT) :: DONALL
LOGICAL :: LBGP 40.31
!
! 5. Parameter variables
!
! --
!
! 6. Local variables
!
! XP1 problem coordinate of a boundary location
! YP1 problem coordinate of a boundary location
! XP2 problem coordinate of a boundary location
! YP2 problem coordinate of a boundary location
! DISXY distance in (x,y)-space
! W2 is relative length of projection on line
! IIPT1 counter checking the grid points related to the nesting boundary
!
INTEGER, SAVE :: IBSP0 = 1, IBSP1 = 1, IENT = 0
INTEGER :: IBSP2,IGRBND,INDXGR
INTEGER :: IXP,IYP,IIPT1
!
REAL, SAVE :: XP0=0., XP1=0., YP0=0., YP1=0. 40.31
REAL :: XP, YP, RX, RY, RL2
REAL :: DX1P, DY1P, DXP2, DYP2, DXCIRC(3)
REAL :: DISXY, DOTR1, DOTR2, W2
#if !defined SWAN_MODEL
TYPE(BGPDAT), POINTER :: BGPTMP 40.31
#endif
!
TYPE(verttype), DIMENSION(:), POINTER :: vert 40.80
!
! 7. Common blocks used
!
!
! 8. Subroutines Used
!
!
! 9. Subroutines calling
!
! BCFILE : open and read Swan nesting files
! BCWW3N : open and read WW3 nesting files
!
! 10. Error messages
!
! ---
!
! 11. Remarks
!
! 12. Structure
!
! For all computational grid points on boundary do
! if point is located between nest file grid points
! calculate interpolation coefficients
! if DONALL is TRUE
! the nesting boundary remain open
! else DONALL is FALSE (default case)
! boundary is close, it do interpolation between the last and the first point
! put interpolation coefficients into array BGRIDP
!
! 13. Source text
!
CALL STRACE (IENT, 'SWBCPT') 40.41
!
IF (NBOUNC.EQ.1) CALL MSGERR (2, 41.14
& 'Nesting procedure does not work if file has only 1 spectrum') 41.14
!
! point to vertices
!
vert => gridobject%vert_grid 40.80
!
IBSP2 = NBSPEC+IBOUNC
IIPT1 = 0
!
201 IF (IBOUNC.EQ.1) THEN
! first point found in a spectral input file 41.14
XP0 = XP2
YP0 = YP2
IBSP0 = IBSP2
IIPT1 = 1 40.41
ELSE
! RX, RY difference vector between consecutive points of spectral file 41.14
IF (KSPHER.EQ.0) THEN
RX = XP2 - XP1
ELSE
DXCIRC(1) = ( XP2 - XP1)-360.0
DXCIRC(2) = ( XP2 - XP1)
DXCIRC(3) = ( XP2 - XP1)+360.0
RX = DXCIRC(MINLOC(ABS(DXCIRC),1))
ENDIF
RY = YP2 - YP1
RL2 = RX**2 + RY**2
IF (RL2.GT.0.) THEN
RX = RX/RL2
RY = RY/RL2
! WRITE(PRINTF,'(A,2I6,6F12.4)') 'BC_SEARCH_1: ',IBSP1,IBSP2,
! & XP1+XOFFS,YP1+YOFFS,XP2+XOFFS,YP2+YOFFS,RX,RY
!
! loop over boundary of computational grid, select boundary points
! between (XP1,YP1) and (XP2,YP2)
!
IF (OPTG.EQ.5) THEN 40.80
#if !defined SWAN_MODEL
DO IXP = 1, nverts 40.80
IF ( vert(IXP)%atti(VMARKER) == 1 .AND. 40.80
& vert(IXP)%atti(VBC) == 0 ) THEN 40.80
XP = vert(IXP)%attr(VERTX) 41.14
YP = vert(IXP)%attr(VERTY) 41.14
!
IF (KSPHER.EQ.0) THEN
DX1P = XP - XP1
DY1P = YP - YP1
DXP2 = XP2 - XP
DYP2 = YP2 - YP
ELSE
! compute delta_lon that allows for either, both,
! or neither XP,XP1 to be -180 to 180 or 0 to 360
DXCIRC(1) = ( XP - XP1)-360.0
DXCIRC(2) = ( XP - XP1)
DXCIRC(3) = ( XP - XP1)+360.0
DX1P = DXCIRC(MINLOC(ABS(DXCIRC),1))
DY1P = ( YP - YP1 )
DXCIRC(1) = ( XP2 - XP)-360.0
DXCIRC(2) = ( XP2 - XP)
DXCIRC(3) = ( XP2 - XP)+360.0
DXP2 = DXCIRC(MINLOC(ABS(DXCIRC),1))
DYP2 = ( YP2 - YP )
ENDIF
!
! DISXY is relative distance from (XP,YP) to line
! (XP1,YP1) to (XP2,YP2) with respect to the length of that line
! DOTR1 is relative length of projection on line (XP1,YP1) to (XP2,YP2)
!
DISXY = ABS ( RX*DY1P - RY*DX1P ) 41.14
DOTR1 = RX*DX1P + RY*DY1P
DOTR2 = RX*DXP2 + RY*DYP2
! WRITE(PRINTF,'(A,I6,5F12.4)') 'BC_SEARCH_2: ',IXP,
! & XP+XOFFS,YP+YOFFS,DOTR1,DOTR2,DISXY
!
! check if boundary point is between (XP1,YP1) and (XP2,YP2)
IF ( DOTR1.GE.0.AND.DOTR2.GE.0.AND.DISXY.LE.0.1 ) THEN
W2 = DOTR1
IF (W2.LT.0.001) W2 = 0. 41.14
IF (W2.GT.0.999) W2 = 1. 41.14
IF (ITEST.GE.80) WRITE (PRTEST, *) ' B.pnt',
& IXP, XP, YP, W2, IBSP2, 1.-W2, IBSP1 41.14
NBGRPT = NBGRPT + 1
IIPT1 = IIPT1 + 1
! WRITE(PRINTF,'(A,3I6,2(F6.3,I6))') 'BC_SEARCH_3: ',
! & IXP,NBGRPT,IIPT1,1.-W2,IBSP1,W2,IBSP2
!
ALLOCATE(BGPTMP) 40.31
BGPTMP%BGP(1) = IXP 40.31
! next item indicates type of boundary condition
BGPTMP%BGP(2) = 1 40.31
BGPTMP%BGP(3) = NINT(1000. * W2) 40.31
BGPTMP%BGP(4) = IBSP2 40.31
BGPTMP%BGP(5) = NINT(1000. * (1.-W2)) 40.31
BGPTMP%BGP(6) = IBSP1 40.31
vert(IXP)%atti(VBC) = 1 40.80
NULLIFY(BGPTMP%NEXTBGP) 40.80
IF ( .NOT.LBGP ) THEN 40.80
FBGP = BGPTMP 40.80
CUBGP => FBGP 40.80
LBGP = .TRUE. 40.80
ELSE 40.80
CUBGP%NEXTBGP => BGPTMP 40.80
CUBGP => BGPTMP 40.80
ENDIF 40.80
ENDIF 41.14
ENDIF 40.80
ENDDO 40.80
#endif
ELSE
!
! KGRBND grid addresses on boundary points, NGRBND number of grid points
! on computational grid boundary
!
DO IGRBND = 1, NGRBND
IXP = KGRBND(2*IGRBND-1)
IYP = KGRBND(2*IGRBND)
!
IF (IXP.GT.0 .AND.IYP.GT.0) THEN
INDXGR = KGRPNT(IXP,IYP)
XP = XCGRID(IXP,IYP)
YP = YCGRID(IXP,IYP)
!
IF (KSPHER.EQ.0) THEN
DX1P = XP - XP1
DY1P = YP - YP1
DXP2 = XP2 - XP
DYP2 = YP2 - YP
ELSE
! compute delta_lon that allows for either, both,
! or neither XP,XP1 to be -180 to 180 or 0 to 360
DXCIRC(1) = ( XP - XP1)-360.0
DXCIRC(2) = ( XP - XP1)
DXCIRC(3) = ( XP - XP1)+360.0
DX1P = DXCIRC(MINLOC(ABS(DXCIRC),1))
DY1P = ( YP - YP1 )
DXCIRC(1) = ( XP2 - XP)-360.0
DXCIRC(2) = ( XP2 - XP)
DXCIRC(3) = ( XP2 - XP)+360.0
DXP2 = DXCIRC(MINLOC(ABS(DXCIRC),1))
DYP2 = ( YP2 - YP )
ENDIF
!
! DISXY is relative distance from (XP,YP) to line
! (XP1,YP1) to (XP2,YP2) with respect to the length of that line
! DOTR1 is relative length of projection on line (XP1,YP1) to (XP2,YP2)
!
DISXY = ABS( RX*DY1P - RY*DX1P )
DOTR1 = RX*DX1P + RY*DY1P
DOTR2 = RX*DXP2 + RY*DYP2
! WRITE(PRINTF,'(A,2I6,5F12.4)') 'BC_SEARCH_2: ',IXP,IYP,
! & XP+XOFFS,YP+YOFFS,DOTR1,DOTR2,DISXY
!
! check if boundary point is between (XP1,YP1) and (XP2,YP2)
IF ( DOTR1.GE.0.AND.DOTR2.GE.0.AND.DISXY.LE.0.1 ) THEN
W2 = DOTR1
IF (W2.LT.0.001) W2 = 0.
IF (W2.GT.0.999) W2 = 1.
IF (ITEST.GE.80) WRITE (PRTEST, *) ' B.pnt',
& IXP, XP, YP, W2, IBSP2, 1.-W2, IBSP1 40.41
NBGRPT = NBGRPT + 1
IIPT1 = IIPT1 + 1
! WRITE(PRINTF,'(A,4I6,2(F6.3,I6))') 'BC_SEARCH_3: ',
! & IXP,IYP,NBGRPT,IIPT1,1.-W2,IBSP1,W2,IBSP2
!
#ifdef SWAN_MODEL
ALLOCATE(BGPDATZ_MOD(ng)%BGPTMP)
! ALLOCATE(BGPDATZ_MOD(ng)%FBGP)
! ALLOCATE(BGPDATZ_MOD(ng)%CUBGP)
BGPDATZ_MOD(ng)%BGPTMP%BGP(1) = INDXGR
! next item indicates type of boundary condition
BGPDATZ_MOD(ng)%BGPTMP%BGP(2) = 1
BGPDATZ_MOD(ng)%BGPTMP%BGP(3) = NINT(1000.*W2)
BGPDATZ_MOD(ng)%BGPTMP%BGP(4) = IBSP2
BGPDATZ_MOD(ng)%BGPTMP%BGP(5) = NINT(1000. * &
& (1.-W2))
BGPDATZ_MOD(ng)%BGPTMP%BGP(6) = IBSP1
NULLIFY(BGPDATZ_MOD(ng)%BGPTMP%NEXTBGP)
IF ( .NOT.LBGP ) THEN
BGPDATZ_MOD(ng)%FBGP=>BGPDATZ_MOD(ng)%BGPTMP
BGPDATZ_MOD(ng)%CUBGP=>BGPDATZ_MOD(ng)%FBGP
LBGP = .TRUE.
ELSE
BGPDATZ_MOD(ng)%CUBGP%NEXTBGP => &
& BGPDATZ_MOD(ng)%BGPTMP
BGPDATZ_MOD(ng)%CUBGP => &
& BGPDATZ_MOD(ng)%BGPTMP
END IF
#else
ALLOCATE(BGPTMP) 40.31
BGPTMP%BGP(1) = INDXGR 40.31
! next item indicates type of boundary condition
BGPTMP%BGP(2) = 1 40.31
BGPTMP%BGP(3) = NINT(1000. * W2) 40.31
BGPTMP%BGP(4) = IBSP2 40.31
BGPTMP%BGP(5) = NINT(1000. * (1.-W2)) 40.31
BGPTMP%BGP(6) = IBSP1 40.31
NULLIFY(BGPTMP%NEXTBGP) 40.31
IF ( .NOT.LBGP ) THEN 40.31
FBGP = BGPTMP 40.31
CUBGP => FBGP 40.31
LBGP = .TRUE. 40.31
ELSE 40.31
CUBGP%NEXTBGP => BGPTMP 40.31
CUBGP => BGPTMP 40.31
END IF 40.31
#endif
!
! test output if point is a test point
!
IF (NPTST.GT.0) THEN
DO IPTST = 1, NPTST
IF (IXP.EQ.XYTST(2*IPTST-1)+MXF-1 .AND.
& IYP.EQ.XYTST(2*IPTST )+MYF-1)
& WRITE (PRTEST, 223)
& IXP-1,IYP-1, XP+XOFFS, YP+YOFFS, W2, IBSP2,
& IBSP1
223 FORMAT (' B.pnt', 2I5, 2F9.0, F6.3, 2I3)
ENDDO
ENDIF
ENDIF
ENDIF
ENDDO
ENDIF
ENDIF
ENDIF
!
! IF (IIPT1.EQ.0) THEN
! WRITE (PRINTF, 218) XP1+XOFFS, YP1+YOFFS,
! & XP2+XOFFS, YP2+YOFFS
! 218 FORMAT (' Warning: no grid points on interval from ', 2F12.4,
! & ' to ', 2F12.4)
! ENDIF
!
XP1 = XP2
YP1 = YP2
IBSP1 = IBSP2
!
IF (IBOUNC.EQ.NBOUNC) THEN
IF (.NOT. DONALL) THEN
!
! process grid points between last and first boundary point
!
DONALL = .TRUE.
XP2 = XP0
YP2 = YP0
IBSP2 = IBSP0
GOTO 201
ENDIF
ENDIF
RETURN
!
END SUBROUTINE SWBCPT
!
!*********************************************************************
! *
LOGICAL FUNCTION BOUNPT (IX,IY,KGRPNT)
! *
!*********************************************************************
!
USE SWCOMM3 40.41
!
!
! --|-----------------------------------------------------------|--
! | Delft University of Technology |
! | Faculty of Civil Engineering |
! | Environmental Fluid Mechanics Section |
! | P.O. Box 5048, 2600 GA Delft, The Netherlands |
! | |
! | Programmers: The SWAN team |
! --|-----------------------------------------------------------|--
!
!
! SWAN (Simulating WAves Nearshore); a third generation wave model
! Copyright (C) 1993-2017 Delft University of Technology
!
! This program is free software; you can redistribute it and/or
! modify it under the terms of the GNU General Public License as
! published by the Free Software Foundation; either version 2 of
! the License, or (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! A copy of the GNU General Public License is available at
! http://www.gnu.org/copyleft/gpl.html#SEC3
! or by writing to the Free Software Foundation, Inc.,
! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
!
!
! 0. Authors
!
! 40.00, 40.03: Nico Booij
!
! 1. UPDATE
!
! Feb. 1998, ver. 40.00: new subroutine
! 40.03, Sep. 00: inconsistency with manual corrected
!
! 2. PURPOSE
!
! determine whether a grid point is a point where a boundary condition
! can be applied
!
! 3. METHOD
!
!
! 4. PARAMETERLIST
!
! IX, IY int inp grid point indices
! KGRPNT int inp indirect addresses of grid points
!
! 5. SUBROUTINES CALLING
!
! BCFILE
!
! 6. SUBROUTINES USED
!
! ---
!
! 7. ERROR MESSAGES
!
! ---
!
! 8. REMARKS
!
! KGRPNT(IX,IY)=1 means that (IX,IY) is not an active grid point
!
! 9. STRUCTURE
!
! -----------------------------------------------------------------
! Make BOUNPT = False
! If the grid point is not active
! Then return
! -----------------------------------------------------------------
! If grid point is on the outer boundary
! Then make BOUNPT = True
! return
! -----------------------------------------------------------------
! If a neighbouring grid point is inactive
! Then make BOUNPT = True
! return
! -----------------------------------------------------------------
!
! 10. SOURCE TEXT
!
INTEGER IX,IY,KGRPNT(MXC,MYC)
SAVE IENT
DATA IENT/0/
CALL STRACE (IENT, 'BOUNPT')
!
BOUNPT = .FALSE.
!
IF (IX.LE.0) RETURN
IF (IY.LE.0) RETURN
IF (IX.GT.MXC) RETURN
IF (IY.GT.MYC) RETURN
!
! If the grid point is not active
! Then return
!
IF (KGRPNT(IX,IY).LE.1) RETURN
!
! If grid point is on the outer boundary
! Then make BOUNPT = True
! return
!
IF (IX.EQ.1) THEN
BOUNPT = .TRUE.
RETURN
ENDIF
IF (IX.EQ.MXC) THEN
BOUNPT = .TRUE.
RETURN
ENDIF
IF (IY.EQ.1) THEN
BOUNPT = .TRUE.
RETURN
ENDIF
IF (IY.EQ.MYC) THEN
BOUNPT = .TRUE.
RETURN
ENDIF
!
! If a neighbouring grid point is inactive
! Then make BOUNPT = True
! return
!
IF (KGRPNT(IX-1,IY).LE.1) THEN
BOUNPT = .TRUE.
RETURN
ENDIF
IF (KGRPNT(IX+1,IY).LE.1) THEN
BOUNPT = .TRUE.
RETURN
ENDIF
IF (KGRPNT(IX,IY-1).LE.1) THEN
BOUNPT = .TRUE.
RETURN
ENDIF
IF (KGRPNT(IX,IY+1).LE.1) THEN
BOUNPT = .TRUE.
RETURN
ENDIF
RETURN
END
!*********************************************************************
! *
#ifdef SWAN_MODEL
SUBROUTINE RETSTP (LXYTST, XYTST, KGRPNT, KGRBND, XCGRID, YCGRID, 40.80
& SPCSIG, SPCDIR, ng) 40.31
#else
SUBROUTINE RETSTP (LXYTST, XYTST, KGRPNT, KGRBND, XCGRID, YCGRID, 40.80
& SPCSIG, SPCDIR) 40.31
#endif
! *
!*********************************************************************
!
USE OCPCOMM2 40.95
USE OCPCOMM4 40.41
USE SWCOMM1 40.41
USE SWCOMM2 40.41
USE SWCOMM3 40.41
USE SWCOMM4 40.41
USE OUTP_DATA 40.31
USE M_PARALL 40.31
USE SwanGriddata 40.80
!PUN USE SIZES 40.95
!
!
! --|-----------------------------------------------------------|--
! | Delft University of Technology |
! | Faculty of Civil Engineering |
! | Environmental Fluid Mechanics Section |
! | P.O. Box 5048, 2600 GA Delft, The Netherlands |
! | |
! | Programmers: The SWAN team |
! --|-----------------------------------------------------------|--
!
!
! SWAN (Simulating WAves Nearshore); a third generation wave model
! Copyright (C) 1993-2017 Delft University of Technology
!
! This program is free software; you can redistribute it and/or
! modify it under the terms of the GNU General Public License as
! published by the Free Software Foundation; either version 2 of
! the License, or (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! A copy of the GNU General Public License is available at
! http://www.gnu.org/copyleft/gpl.html#SEC3
! or by writing to the Free Software Foundation, Inc.,
! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
!
!
! 0. Authors
!
! 30.82: IJsbrand Haagsma
! 40.00, 40.13: Nico Booij
! 34.01: Jeroen Adema
! 40.04: Annette Kieftenburg
! 40.30: Marcel Zijlema
! 40.31: Marcel Zijlema
! 40.41: Marcel Zijlema
! 40.80: Marcel Zijlema
!
! 1. Updates
!
! 40.00, Apr. 98: New subroutine
! 30.82, Oct. 98: Updated description of several variables
! 34.01, Feb. 99: Introducing STPNOW
! 40.03, Dec. 99: XOFFS and YOFFS introduced in write statements
! May 00: ITMOPT written to heading of file instead of 1
! 40.04, Aug. 00: Added error message if testpoints are defined
! before bottom grid is read
! 40.13, Jan. 01: two output strings corrected
! May 01: two incorrect units changed from m2/2 to m2/s
! 40.30, Mar. 03: introduction distributed-memory approach using MPI
! 40.31, Dec. 03: removing POOL-mechanism
! 40.41, Oct. 04: common blocks replaced by modules, include files removed
! 40.80, Jun. 07: extension to unstructured grids
!
! 2. PURPOSE
!
! read test points, generate output point set 'TESTPNTS',
! read source term filenames
!
! 3. METHOD
!
!
! 4. Argument variables
!
! i SPCDIR: (*,1); spectral directions (radians) 30.82
! (*,2); cosine of spectral directions 30.82
! (*,3); sine of spectral directions 30.82
! (*,4); cosine^2 of spectral directions 30.82
! (*,5); cosine*sine of spectral directions 30.82
! (*,6); sine^2 of spectral directions 30.82
! i SPCSIG: Relative frequencies in computational domain in sigma-space 30.82
! i XCGRID: Coordinates of computational grid in x-direction 30.82
! i YCGRID: Coordinates of computational grid in y-direction 30.82
!
#if defined SWAN_MODEL
INTEGER, INTENT(IN) :: ng
#endif
REAL SPCDIR(MDC,6) 30.82
REAL SPCSIG(MSC) 30.82
REAL XCGRID(MXC,MYC), YCGRID(MXC,MYC) 30.82
!
! i LXYTST: Maximum length of array XYTST 40.80
! i XYTST : Grid point indices of test points 30.82
!
! MPTST : Maximum number of test points 30.82
!
INTEGER LXYTST, MPTST 40.80 30.82
INTEGER XYTST(LXYTST) 40.80 30.82
!
! 5. SUBROUTINES CALLING
!
! SWREAD
!
! 6. SUBROUTINES USED
!
LOGICAL STPNOW 34.01
!
! 7. Common blocks used
!
!
! 8. REMARKS
!
!
! 9. STRUCTURE
!
! -----------------------------------------------------------------
! Repeat
! read (i,j) identifying a test point
! store values in array XYTST
! -----------------------------------------------------------------
! Generate output point set 'TESTPNTS'
! write coordinates of test points into array OUTDA
! -----------------------------------------------------------------
! If 1D output of source terms is requested
! Then open file
! write general data into the file
! -----------------------------------------------------------------
! If 2D output of source terms is requested
! Then open file
! write general data into the file
! -----------------------------------------------------------------
!
! 10. SOURCE TEXT
!
INTEGER KGRPNT(MXC,MYC), KGRBND(*) 40.31
LOGICAL KEYWIS, LOCGRI 40.00
#if !defined SWAN_MODEL
TYPE(OPSDAT), POINTER :: OPSTMP 40.31
#endif
SAVE IENT
DATA IENT /0/
CALL STRACE (IENT, 'RETSTP')
!
IF (OPTG.NE.5) THEN 40.80
MPTST = LXYTST/2 40.80
ELSE 40.80
MPTST = LXYTST 40.80
ENDIF 40.80
CALL INKEYW ('STA','IJ') 40.00
IF (MCGRD.GT.1 .OR. nverts.GT.0) THEN 40.80 40.04
IF (KEYWIS('XY')) THEN
LOCGRI = .TRUE.
ELSE IF (KEYWIS('IJ')) THEN
LOCGRI = .FALSE.
ELSE
CALL WRNKEY
ENDIF
ELSE 40.04
CALL MSGERR(3,
& 'command READ BOT or READ UNSTRUC must precede command TEST') 40.80
ENDIF 40.04
!
10 IF (LOCGRI) THEN
CALL READXY ('X','Y',XP,YP, 'REP', -1.E10, -1.E10) 40.03
IF (XP.LT.-.9E10) THEN
LXDMP = 0
GOTO 60
ELSE
IF (OPTG.NE.5) THEN 40.80
CALL CVMESH (XP, YP, XC, YC, KGRPNT, XCGRID, YCGRID, KGRBND) 40.00
IF (XC.LT.0.) THEN 40.31
IF (XP.GE.XCGMIN .AND. XP.LE.XCGMAX .AND. 40.31
& YP.GE.YCGMIN .AND. YP.LE.YCGMAX ) THEN 40.31
GOTO 50 40.31
ELSE 40.31
GOTO 40 40.31
END IF 40.31
END IF 40.31
LXDMP = NINT(XC) + MXF -1 40.31
LYDMP = NINT(YC) + MYF -1 40.31
IF (ITEST.GE.30) WRITE (PRTEST, 14) XP+XOFFS, YP+YOFFS, 40.03
& LXDMP, LYDMP
14 FORMAT (' test point ', 2F12.2, ' to grid point ', 2I4)
ELSE 40.80
CALL SwanFindPoint ( XP, YP, K ) 40.80
IF ( K.LT.0 ) THEN 40.80
IF (XP.GE.XCGMIN .AND. XP.LE.XCGMAX .AND. 40.80
& YP.GE.YCGMIN .AND. YP.LE.YCGMAX ) THEN 40.80
GOTO 50 40.80
ELSE 40.80
GOTO 40 40.80
END IF 40.80
END IF 40.80
LXDMP = K 40.80
IF (ITEST.GE.30) WRITE (PRTEST,15) XP+XOFFS,YP+YOFFS,LXDMP 40.80
15 FORMAT (' test point ', 2F12.2, ' to vertex ', I6) 40.80
ENDIF 40.80
ENDIF
ELSE
CALL ININTG ('I' , LXDMP, 'REP', -1) 40.03
IF (LXDMP .LT. 0) GOTO 60
IF (OPTG.NE.5) CALL ININTG ('J' , LYDMP, 'REQ', 0) 40.80 40.03
ENDIF
!
IF (OPTG.NE.5) THEN 40.80
IF (LXDMP.GE.0 .AND. LXDMP.LE.MXCGL-1 .AND. 40.31
& LYDMP.GE.0 .AND. LYDMP.LE.MYCGL-1) THEN 40.31
LXDMP = LXDMP - MXF + 1 40.31
LYDMP = LYDMP - MYF + 1 40.31
IF (LXDMP.GE.0 .AND. LXDMP.LE.MXC-1 .AND.
& LYDMP.GE.0 .AND. LYDMP.LE.MYC-1) THEN
IF (KGRPNT(LXDMP+1,LYDMP+1) .GT. 1) THEN
NPTST = NPTST + 1
XYTST(2*NPTST-1) = LXDMP+1
XYTST(2*NPTST) = LYDMP+1
GOTO 50
ENDIF
ELSE 40.31
GOTO 50 40.31
ENDIF 40.31
ENDIF
ELSE 40.80
IF (LXDMP.GE.1 .AND. LXDMP.LE.nverts) THEN 40.80
NPTST = NPTST + 1 40.80
XYTST(NPTST) = LXDMP 40.80
GOTO 50 40.80
ENDIF 40.80
ENDIF 40.80
!
40 CALL MSGERR (1, 'test point is not active') 40.80
WRITE (PRINTF, *) XP+XOFFS, YP+YOFFS 40.03
50 IF (NPTST.LE.MPTST) GOTO 10
CALL MSGERR (2, 'Too many test points')
!
! generate output point set 'TESTPNTS'
!
#ifdef SWAN_MODEL
60 ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP) 40.31
! ALLOCATE(OPSDATZ_MOD(ng)%COPS)
! ALLOCATE(OPSDATZ_MOD(ng)%FOPS)
OPSDATZ_MOD(ng)%OPSTMP%PSNAME = 'TESTPNTS' 40.31
OPSDATZ_MOD(ng)%OPSTMP%PSTYPE = 'P' 40.31
OPSDATZ_MOD(ng)%OPSTMP%MIP = NPTST 40.31
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP%XP(NPTST)) 40.31
ALLOCATE(OPSDATZ_MOD(ng)%OPSTMP%YP(NPTST)) 40.31
IF (OPTG.NE.5) THEN 40.80
DO IPTST = 1, NPTST 40.80
LXDMP = XYTST(2*IPTST-1) 40.00
LYDMP = XYTST(2*IPTST) 40.00
OPSDATZ_MOD(ng)%OPSTMP%XP(IPTST) = XCGRID(LXDMP,LYDMP) 40.31
OPSDATZ_MOD(ng)%OPSTMP%YP(IPTST) = YCGRID(LXDMP,LYDMP) 40.31
ENDDO 40.80
ELSE 40.80
DO IPTST = 1, NPTST 40.80
K = XYTST(IPTST) 40.80
OPSDATZ_MOD(ng)%OPSTMP%XP(IPTST) = xcugrd(K) 40.31
OPSDATZ_MOD(ng)%OPSTMP%YP(IPTST) = ycugrd(K) 40.31
ENDDO 40.80
ENDIF 40.80
NULLIFY(OPSDATZ_MOD(ng)%OPSTMP%NEXTOPS) 40.31
IF ( .NOT.LOPS ) THEN 40.31
OPSDATZ_MOD(ng)%FOPS = OPSDATZ_MOD(ng)%OPSTMP 40.31
OPSDATZ_MOD(ng)%COPS => OPSDATZ_MOD(ng)%FOPS 40.31
LOPS = .TRUE. 40.31
ELSE 40.31
OPSDATZ_MOD(ng)%COPS%NEXTOPS => OPSDATZ_MOD(ng)%OPSTMP 40.31
OPSDATZ_MOD(ng)%COPS => OPSDATZ_MOD(ng)%OPSTMP 40.31
END IF 40.31
#else
60 ALLOCATE(OPSTMP) 40.31
OPSTMP%PSNAME = 'TESTPNTS' 40.31
OPSTMP%PSTYPE = 'P' 40.31
OPSTMP%MIP = NPTST 40.31
ALLOCATE(OPSTMP%XP(NPTST)) 40.31
ALLOCATE(OPSTMP%YP(NPTST)) 40.31
IF (OPTG.NE.5) THEN 40.80
DO IPTST = 1, NPTST 40.80
LXDMP = XYTST(2*IPTST-1) 40.00
LYDMP = XYTST(2*IPTST) 40.00
OPSTMP%XP(IPTST) = XCGRID(LXDMP,LYDMP) 40.31
OPSTMP%YP(IPTST) = YCGRID(LXDMP,LYDMP) 40.31
ENDDO 40.80
ELSE 40.80
DO IPTST = 1, NPTST 40.80
K = XYTST(IPTST) 40.80
OPSTMP%XP(IPTST) = xcugrd(K) 40.80
OPSTMP%YP(IPTST) = ycugrd(K) 40.80
ENDDO 40.80
ENDIF 40.80
NULLIFY(OPSTMP%NEXTOPS) 40.31
IF ( .NOT.LOPS ) THEN 40.31
FOPS = OPSTMP 40.31
COPS => FOPS 40.31
LOPS = .TRUE. 40.31
ELSE 40.31
COPS%NEXTOPS => OPSTMP 40.31
COPS => OPSTMP 40.31
END IF 40.31
#endif
!
! open output file for test output of wave parameters 40.00
!
CALL INKEYW ('STA', ' ') 40.00
IF (KEYWIS('PAR')) THEN 40.00
CALL INCSTR ('FNAME', FILENM, 'STA', 'SWSRCPA') 40.00
! --- append node number to FILENM in case of 40.30
! parallel computing 40.30
IF ( PARLL ) THEN 40.30
ILPOS = INDEX ( FILENM, ' ' )-1 40.30
WRITE(FILENM(ILPOS+1:ILPOS+4),99) INODE 40.30
99 FORMAT('-',I3.3) 40.30
END IF 40.30
!PUN FILENM = TRIM(LOCALDIR)//DIRCH2//TRIM(FILENM) 40.95
IERR = 0 40.00
CALL FOR (IFPAR, FILENM, 'UF', IERR) 40.00
IF (STPNOW()) RETURN 34.01
WRITE (IFPAR, 101) 1 40.00
101 FORMAT ('SWAN', I4, T41,
& 'Swan standard spectral file, version') 40.00
WRITE (IFPAR, 111) VERTXT 40.03
111 FORMAT ('$ Data produced by SWAN version ', A) 40.03
WRITE (IFPAR, 113) PROJID, PROJNR 40.03
113 FORMAT ('$ Project: ', A, '; run number: ', A)
IF (NSTATM.EQ.1) THEN
WRITE (IFPAR, 102) 'TIME', 'time-dependent data'
102 FORMAT (A, T41, A) 40.00
WRITE (IFPAR, 103) ITMOPT, 'time coding option' 40.03
103 FORMAT (I6, T41, A) 40.00
ELSE
WRITE (IFPAR, 102) 'ITER', 'iteration-dependent data'
WRITE (IFPAR, 103) 0
ENDIF
IF (KSPHER.EQ.0) THEN
WRITE (IFPAR, 102) 'LOCATIONS', 'locations in x-y-space'
ELSE
WRITE (IFPAR, 102) 'LONLAT',
& 'locations in longitude, latitude'
ENDIF
WRITE (IFPAR, 103) NPTST, 'number of locations'
IF (OPTG.NE.5) THEN 40.80
DO 110 IPTST = 1, NPTST
LXDMP = XYTST(2*IPTST-1) 40.00
LYDMP = XYTST(2*IPTST) 40.00
WRITE (IFPAR, 106) XCGRID(LXDMP,LYDMP)+XOFFS,
& YCGRID(LXDMP,LYDMP)+YOFFS 40.00
110 CONTINUE
ELSE 40.80
DO IPTST = 1, NPTST 40.80
K = XYTST(IPTST) 40.80
WRITE (IFPAR, 106) xcugrd(K)+XOFFS, ycugrd(K)+YOFFS 40.80
ENDDO 40.80
ENDIF 40.80
106 FORMAT (2(1X,F12.2))
IF(IWCAP.NE.8)THEN 40.88
WRITE (IFPAR, 132) 11 40.32 40.55 40.00
ELSE
WRITE (IFPAR, 132) 12
ENDIF
132 FORMAT ('QUANT', /, I6, T41, 'number of quantities in table') 40.00
WRITE (IFPAR, 102) OVSNAM(10), OVLNAM(10) 40.00
WRITE (IFPAR, 102) OVUNIT(10), 'unit' 40.00
WRITE (IFPAR, 104) OVEXCV(10), 'exception value' 40.00
104 FORMAT (F14.6, T41, A) 40.00
WRITE (IFPAR, 102) OVSNAM(28), OVLNAM(28) 40.41 40.00
WRITE (IFPAR, 102) OVUNIT(28), 'unit' 40.41 40.00
WRITE (IFPAR, 104) OVEXCV(28), 'exception value' 40.41 40.00
WRITE (IFPAR, 102) 'Swind', 'wind source term (of var. dens.)' 40.00
WRITE (IFPAR, 102) 'm2/s', 'unit' 40.00
WRITE (IFPAR, 104) OVEXCV(7),'exception value' 40.00
WRITE (IFPAR, 102) 'Swcap', 'whitecapping dissipation' 40.00
WRITE (IFPAR, 102) 'm2/s', 'unit' 40.00
WRITE (IFPAR, 104) OVEXCV(7),'exception value' 40.00
IF(IWCAP.EQ.8)THEN 40.88
WRITE (IFPAR, 102) 'Sswell', 'swell dissipation' 40.88
WRITE (IFPAR, 102) 'm2/s', 'unit' 40.88
WRITE (IFPAR, 104) OVEXCV(7),'exception value' 40.88
ENDIF 40.88
WRITE (IFPAR, 102) 'Sfric', 'bottom friction dissipation' 40.00
WRITE (IFPAR, 102) 'm2/s', 'unit' 40.00
WRITE (IFPAR, 104) OVEXCV(7),'exception value' 40.00
WRITE (IFPAR, 102) 'Svege', 'vegetation dissipation' 40.55
WRITE (IFPAR, 102) 'm2/s', 'unit' 40.55
WRITE (IFPAR, 104) OVEXCV(7),'exception value' 40.55
WRITE (IFPAR, 102) 'Sturb', 'turbulent dissipation' 40.35
WRITE (IFPAR, 102) 'm2/s', 'unit' 40.35
WRITE (IFPAR, 104) OVEXCV(7),'exception value' 40.35
WRITE (IFPAR, 102) 'Smud', 'fluid mud dissipation' 40.59
WRITE (IFPAR, 102) 'm2/s', 'unit' 40.59
WRITE (IFPAR, 104) OVEXCV(7),'exception value' 40.59
WRITE (IFPAR, 102) 'Ssurf', 'surf breaking dissipation' 40.00
WRITE (IFPAR, 102) 'm2/s', 'unit' 40.00
WRITE (IFPAR, 104) OVEXCV(7),'exception value' 40.00
WRITE (IFPAR, 102) 'Snl3', 'total absolute 3-wave interaction' 40.13
WRITE (IFPAR, 102) 'm2/s', 'unit' 40.13
WRITE (IFPAR, 104) OVEXCV(7),'exception value' 40.00
WRITE (IFPAR, 102) 'Snl4', 'total absolute 4-wave interaction' 40.13
WRITE (IFPAR, 102) 'm2/s', 'unit' 40.13
WRITE (IFPAR, 104) OVEXCV(7),'exception value' 40.00
ENDIF
!
! open output file for source terms if requested
!
CALL INKEYW ('STA', ' ') 40.00
IF (KEYWIS('S1D')) THEN 40.00
CALL INCSTR ('FNAME', FILENM, 'STA', 'SWSRC1D') 40.00
! --- append node number to FILENM in case of 40.30
! parallel computing 40.30
IF ( PARLL ) THEN 40.30
ILPOS = INDEX ( FILENM, ' ' )-1 40.30
WRITE(FILENM(ILPOS+1:ILPOS+4),99) INODE 40.30
END IF 40.30
!PUN FILENM = TRIM(LOCALDIR)//DIRCH2//TRIM(FILENM) 40.95
IERR = 0 40.00
CALL FOR (IFS1D, FILENM, 'UF', IERR) 40.00
IF (STPNOW()) RETURN 34.01
WRITE (IFS1D, 101) 1
WRITE (IFS1D, 111) VERTXT 40.03
WRITE (IFS1D, 113) PROJID, PROJNR 40.03
IF (NSTATM.EQ.1) THEN
WRITE (IFS1D, 102) 'TIME', 'time-dependent data'
WRITE (IFS1D, 103) ITMOPT, 'time coding option' 40.03
ELSE
WRITE (IFS1D, 102) 'ITER', 'iteration-dependent data'
WRITE (IFS1D, 103) 0
ENDIF
IF (KSPHER.EQ.0) THEN
WRITE (IFS1D, 102) 'LOCATIONS', 'locations in x-y-space'
ELSE
WRITE (IFS1D, 102) 'LONLAT',
& 'locations in longitude, latitude'
ENDIF
WRITE (IFS1D, 103) NPTST, 'number of locations'
IF (OPTG.NE.5) THEN 40.80
DO 210 IPTST = 1, NPTST 40.00
LXDMP = XYTST(2*IPTST-1) 40.00
LYDMP = XYTST(2*IPTST) 40.00
WRITE (IFS1D, 106) XCGRID(LXDMP,LYDMP)+XOFFS, 40.00
& YCGRID(LXDMP,LYDMP)+YOFFS 40.00
210 CONTINUE 40.00
ELSE 40.80
DO IPTST = 1, NPTST 40.80
K = XYTST(IPTST) 40.80
WRITE (IFS1D, 106) xcugrd(K)+XOFFS, ycugrd(K)+YOFFS 40.80
ENDDO 40.80
ENDIF 40.80
IF (ICUR.GT.0) THEN
WRITE (IFS1D, 102) 'RFREQ', 'relative frequencies in Hz' 40.00
ELSE
WRITE (IFS1D, 102) 'AFREQ', 'absolute frequencies in Hz' 40.00
ENDIF
WRITE (IFS1D, 103) MSC, 'number of frequencies' 40.00
DO 220 IS = 1, MSC 40.00
WRITE (IFS1D, 214) SPCSIG(IS)/PI2 40.00
214 FORMAT (F10.4) 40.00
220 CONTINUE 40.00
IF(IWCAP.NE.8)THEN 40.88
WRITE (IFS1D, 132) 10 40.55
ELSE
WRITE (IFS1D, 132) 11
ENDIF
WRITE (IFS1D, 102) 'VaDens', 'variance densities' 40.00
WRITE (IFS1D, 102) 'm2/Hz', 'unit' 40.00
WRITE (IFS1D, 104) 0., 'exception value' 40.00
WRITE (IFS1D, 102) 'Swind', 'wind source term' 40.00
WRITE (IFS1D, 102) 'm2', 'unit' 40.00
WRITE (IFS1D, 104) OVEXCV(7),'exception value' 40.00
WRITE (IFS1D, 102) 'Swcap', 'whitecapping dissipation' 40.00
WRITE (IFS1D, 102) 'm2', 'unit' 40.00
WRITE (IFS1D, 104) OVEXCV(7),'exception value' 40.00
IF(IWCAP.EQ.8) THEN
WRITE (IFS1D, 102) 'Sswell', 'swell dissipation' 40.88
WRITE (IFS1D, 102) 'm2', 'unit' 40.88
WRITE (IFS1D, 104) OVEXCV(7),'exception value' 40.88
ENDIF
WRITE (IFS1D, 102) 'Sfric', 'bottom friction dissipation' 40.00
WRITE (IFS1D, 102) 'm2', 'unit' 40.00
WRITE (IFS1D, 104) OVEXCV(7),'exception value' 40.00
WRITE (IFS1D, 102) 'Svege', 'vegetation dissipation' 40.55
WRITE (IFS1D, 102) 'm2', 'unit' 40.55
WRITE (IFS1D, 104) OVEXCV(7),'exception value' 40.55
WRITE (IFS1D, 102) 'Sturb', 'turbulent dissipation' 40.35
WRITE (IFS1D, 102) 'm2', 'unit' 40.35
WRITE (IFS1D, 104) OVEXCV(7),'exception value' 40.35
WRITE (IFS1D, 102) 'Smud', 'fluid mud dissipation' 40.59
WRITE (IFS1D, 102) 'm2', 'unit' 40.59
WRITE (IFS1D, 104) OVEXCV(7),'exception value' 40.59
WRITE (IFS1D, 102) 'Ssurf', 'surf breaking dissipation' 40.00
WRITE (IFS1D, 102) 'm2', 'unit' 40.00
WRITE (IFS1D, 104) OVEXCV(7),'exception value' 40.00
WRITE (IFS1D, 102) 'Snl3', 'triad interactions' 40.00
WRITE (IFS1D, 102) 'm2', 'unit' 40.00
WRITE (IFS1D, 104) OVEXCV(7),'exception value' 40.00
WRITE (IFS1D, 102) 'Snl4', 'quadruplet interactions' 40.00
WRITE (IFS1D, 102) 'm2', 'unit' 40.00
WRITE (IFS1D, 104) OVEXCV(7),'exception value' 40.00
ENDIF
! 2D source terms
CALL INKEYW ('STA', ' ') 40.00
IF (KEYWIS('S2D')) THEN 40.00
CALL INCSTR ('FNAME', FILENM, 'STA', 'SWSRC2D') 40.00
! --- append node number to FILENM in case of 40.30
! parallel computing 40.30
IF ( PARLL ) THEN 40.30
ILPOS = INDEX ( FILENM, ' ' )-1 40.30
WRITE(FILENM(ILPOS+1:ILPOS+4),99) INODE 40.30
END IF 40.30
!PUN FILENM = TRIM(LOCALDIR)//DIRCH2//TRIM(FILENM) 40.95
IERR = 0 40.00
CALL FOR (IFS2D, FILENM, 'UF', IERR) 40.00
IF (STPNOW()) RETURN 34.01
WRITE (IFS2D, 101) 1
WRITE (IFS2D, 111) VERTXT 40.03
WRITE (IFS2D, 113) PROJID, PROJNR 40.03
IF (NSTATM.EQ.1) THEN
WRITE (IFS2D, 102) 'TIME', 'time-dependent data'
WRITE (IFS2D, 103) ITMOPT, 'time coding option' 40.03
ELSE
WRITE (IFS2D, 102) 'ITER', 'iteration-dependent data'
WRITE (IFS2D, 103) 0
ENDIF
IF (KSPHER.EQ.0) THEN
WRITE (IFS2D, 102) 'LOCATIONS', 'locations in x-y-space'
ELSE
WRITE (IFS2D, 102) 'LONLAT',
& 'locations in longitude, latitude'
ENDIF
WRITE (IFS2D, 103) NPTST, 'number of locations'
IF (OPTG.NE.5) THEN 40.80
DO 310 IPTST = 1, NPTST 40.00
LXDMP = XYTST(2*IPTST-1) 40.00
LYDMP = XYTST(2*IPTST) 40.00
WRITE (IFS2D, 106) XCGRID(LXDMP,LYDMP)+XOFFS, 40.00
& YCGRID(LXDMP,LYDMP)+YOFFS 40.00
310 CONTINUE 40.00
ELSE 40.80
DO IPTST = 1, NPTST 40.80
K = XYTST(IPTST) 40.80
WRITE (IFS2D, 106) xcugrd(K)+XOFFS, ycugrd(K)+YOFFS 40.80
ENDDO 40.80
ENDIF 40.80
IF (ICUR.GT.0) THEN
WRITE (IFS2D, 102) 'RFREQ', 'relative frequencies in Hz' 40.00
ELSE
WRITE (IFS2D, 102) 'AFREQ', 'absolute frequencies in Hz' 40.00
ENDIF
WRITE (IFS2D, 103) MSC, 'number of frequencies' 40.00
DO 320 IS = 1, MSC 40.00
WRITE (IFS2D, 214) SPCSIG(IS)/PI2 40.00
320 CONTINUE 40.00
! full 2-D spectrum
WRITE (IFS2D, 102) 'CDIR',
& 'spectral Cartesian directions in degr' 40.00
WRITE (IFS2D, 103) MDC, 'number of directions'
DO 330 ID = 1, MDC 40.00
WRITE (IFS2D, 324) SPCDIR(ID,1)*180./PI 30.82
324 FORMAT (F10.4) 40.00
330 CONTINUE 40.00
IF(IWCAP.NE.8)THEN 40.88
WRITE (IFS2D, 132) 10 40.55
ELSE
WRITE (IFS2D, 132) 11
ENDIF
WRITE (IFS2D, 102) 'VaDens', 'variance densities' 40.00
WRITE (IFS2D, 102) 'm2/Hz/degr', 'unit' 40.00
WRITE (IFS2D, 104) 0., 'exception value' 40.00
WRITE (IFS2D, 102) 'Swind', 'wind source term' 40.00
WRITE (IFS2D, 102) 'm2/degr','unit' 40.00
WRITE (IFS2D, 104) OVEXCV(7),'exception value' 40.00
WRITE (IFS2D, 102) 'Swcap', 'whitecapping dissipation' 40.00
WRITE (IFS2D, 102) 'm2/degr','unit' 40.00
WRITE (IFS2D, 104) OVEXCV(7),'exception value' 40.00
IF(IWCAP.EQ.8) THEN
WRITE (IFS2D, 102) 'Sswell', 'swell dissipation' 40.88
WRITE (IFS2D, 102) 'm2/degr','unit' 40.88
WRITE (IFS2D, 104) OVEXCV(7),'exception value' 40.88
ENDIF
WRITE (IFS2D, 102) 'Sfric', 'bottom friction dissipation' 40.00
WRITE (IFS2D, 102) 'm2/degr','unit' 40.00
WRITE (IFS2D, 104) OVEXCV(7),'exception value' 40.00
WRITE (IFS2D, 102) 'Svege', 'vegetation dissipation' 40.55
WRITE (IFS2D, 102) 'm2/degr','unit' 40.55
WRITE (IFS2D, 104) OVEXCV(7),'exception value' 40.55
WRITE (IFS2D, 102) 'Sturb', 'turbulent dissipation' 40.35
WRITE (IFS2D, 102) 'm2/degr','unit' 40.35
WRITE (IFS2D, 104) OVEXCV(7),'exception value' 40.35
WRITE (IFS2D, 102) 'Smud', 'fluid mud dissipation' 40.59
WRITE (IFS2D, 102) 'm2/degr','unit' 40.59
WRITE (IFS2D, 104) OVEXCV(7),'exception value' 40.59
WRITE (IFS2D, 102) 'Ssurf', 'surf breaking dissipation' 40.00
WRITE (IFS2D, 102) 'm2/degr','unit' 40.00
WRITE (IFS2D, 104) OVEXCV(7),'exception value' 40.00
WRITE (IFS2D, 102) 'Snl3', 'triad interactions' 40.00
WRITE (IFS2D, 102) 'm2/degr','unit' 40.00
WRITE (IFS2D, 104) OVEXCV(7),'exception value' 40.00
WRITE (IFS2D, 102) 'Snl4', 'quadruplet interactions' 40.00
WRITE (IFS2D, 102) 'm2/degr','unit' 40.00
WRITE (IFS2D, 104) OVEXCV(7),'exception value' 40.00
ENDIF
RETURN
! end of subroutine RETSTP
END