ocpmix.f90 File Reference

Go to the source code of this file.

Functions/Subroutines
real function	dttime (INTTIM)
subroutine	inar2d (ARR, MGA, NDSL, NDSD, IDFM, RFORM, IDLA, VFAC, NHED, NHEDF)
subroutine	strace (IENT, SUBNAM)
subroutine	msgerr (LEV, STRING)
logical function	stpnow ()
subroutine	for (IUNIT, DDNAME, SF, IOSTAT)
logical function	eqreal (REAL1, REAL2)
subroutine	dtreti (TSTRNG, IOPT, TIMESC)

Function/Subroutine Documentation

dtreti()

subroutine dtreti	(	character, dimension(*)	TSTRNG,
		integer	IOPT,
		real	TIMESC
	)

Definition at line 1306 of file ocpmix.f90.

!                                                                *
!*****************************************************************
!
      IMPLICIT NONE
!
!
!   --|-----------------------------------------------------------|--
!     | Delft University of Technology                            |
!     | Faculty of Civil Engineering                              |
!     | Environmental Fluid Mechanics Section                     |
!     | P.O. Box 5048, 2600 GA  Delft, The Netherlands            |
!     |                                                           |
!     | Programmers: R.C. Ris, N. Booij,                          |
!     |              IJ.G. Haagsma, A.T.M.M. Kieftenburg,         |
!     |              M. Zijlema, E.E. Kriezi,                     |
!     |              R. Padilla-Hernandez, L.H. Holthuijsen       |
!   --|-----------------------------------------------------------|--
!
!
!     SWAN (Simulating WAves Nearshore); a third generation wave model
!     Copyright (C) 2004-2005  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
!
!  1. UPDATES
!
!  2. PURPOSE
!
!  3. METHOD
!
!  4. ARGUMENT VARIABLES
!
!     IOPT   : input    option number
!
      INTEGER IOPT
!
!     TIMESC : output   time in seconds from given reference day REFDAY
!
      REAL    TIMESC
!
!     TSTRNG : input    time string
!
      CHARACTER  TSTRNG *(*)
!
!  5. PARAMETER VARIABLES
!
!  6. LOCAL VARIABLES
!
!     ITIME  : ??
!
      INTEGER ITIME(6)
!
!     DTTIME : Gives time in seconds from a reference day it also initialises the
!              reference day
!
      REAL    DTTIME
!
!  8. SUBROUTINE USED
!
!     DTSTTI   (installation dependent subroutines)
!
!  9. SUBROUTINES CALLING
!
! 10. ERROR MESSAGES
!
! 11. REMARKS
!
! 12. STRUCTURE
!
! 13. SOURCE TEXT
!
      CALL dtstti (iopt, tstrng, itime)
      timesc = dttime(itime)
      RETURN

Here is the call graph for this function:

Here is the caller graph for this function:

dttime()

real function dttime

(

integer, dimension(6)

INTTIM

)

Definition at line 32 of file ocpmix.f90.

!                                                                  *
!*******************************************************************
!
      USE ocpcomm1                                                        
      USE ocpcomm2                                                        
      USE ocpcomm3                                                        
      USE ocpcomm4                                                        
!
      IMPLICIT NONE
!
!
!   --|-----------------------------------------------------------|--
!     | Delft University of Technology                            |
!     | Faculty of Civil Engineering                              |
!     | Environmental Fluid Mechanics Section                     |
!     | P.O. Box 5048, 2600 GA  Delft, The Netherlands            |
!     |                                                           |
!     | Programmers: R.C. Ris, N. Booij,                          |
!     |              IJ.G. Haagsma, A.T.M.M. Kieftenburg,         |
!     |              M. Zijlema, E.E. Kriezi,                     |
!     |              R. Padilla-Hernandez, L.H. Holthuijsen       |
!   --|-----------------------------------------------------------|--
!
!
!     SWAN (Simulating WAves Nearshore); a third generation wave model
!     Copyright (C) 2004-2005  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.74: IJsbrand Haagsma (Include version)
!     40.41: Marcel Zijlema
!
!  1. Updates
!
!      9705, May  97: month number is checked
!     30.74, Nov. 97: Prepared for version with INCLUDE statements
!     40.41, Oct. 04: common blocks replaced by modules, include files removed
!
!  2. Purpose
!
!     DTTIME gives time in seconds from a reference day
!            it also initialises the reference day
!
!  3. Method
!
!     every fourth year is a leap-year, but not the century-years, however
!     also leap-years are: year 0, 1000, 2000 etc.
!     1 jan of year 0 is daynumber 1.
!
!  4. Argument variables
!
!     INTTIM(1): year
!           (2): month
!           (3): day
!           (4): hour
!           (5): minute
!           (6): second
!
      INTEGER INTTIM(6)                                                   
!
!  5. PARAMETER VARIABLES
!
!  6. LOCAL VARIABLES
!
!     IDYMON : number of days of each month (February counts as 28 days)
!     IYEAR  : number of years after substacking the centuries
!     IYRM1  : ??
!     IDNOW  : ??
!     I      : ??
!     II     : ??
!
      INTEGER IDYMON(12), IYEAR, IYRM1, IDNOW, I, II
!
!     LEAPYR : Whether year in INTTIM(1) is a leapyear
!     LOGREF : ??
!
      LOGICAL LEAPYR, LOGREF
!
!     REFDAY  day number of the reference day; the reference time is 0:00
!            of the reference day; the first day entered is used as
!             reference day.
!
!
!  8. SUBROUTINE USED
!
!  9. SUBROUTINES CALLING
!
! 10. ERROR MESSAGES
!
! 11. REMARKS
!
! 12. STRUCTURE
!
! 13. SOURCE TEXT
!
      SAVE logref, idymon
      DATA idymon /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/
      DATA logref /.false./
!
      iyear = inttim(1)
      iyrm1 = iyear-1
      leapyr=(mod(iyear,4) == 0 .AND. mod(iyear,100) /= 0) .OR.     &
              mod(iyear,1000) == 0
      idnow=0
      IF(inttim(2) > 12)THEN                                           
        WRITE (printf, 8) inttim(2), (inttim(ii), ii=1,6)                 
   8    FORMAT (' erroneous month ', i2, ' in date/time ', 6i4)           
      ELSE IF(inttim(2) > 1)THEN                                       
        DO 10 i = 1,inttim(2)-1
          idnow=idnow+idymon(i)
  10    CONTINUE
      ENDIF                                                               
      idnow=idnow+inttim(3)
      IF(leapyr .AND. inttim(2) > 2) idnow=idnow+1
      idnow = idnow + iyear*365 + iyrm1/4 - iyrm1/100 + iyrm1/1000 + 1
      IF(iyear == 0) idnow=idnow-1
      IF(.NOT.logref)THEN
        refday = idnow
        logref = .true.
        dttime = 0.
      ELSE
        dttime = real(idnow-refday) * 24.*3600.
      ENDIF
      dttime = dttime + 3600.*real(inttim(4)) + 60.*real(inttim(5)) +     &
               REAL(INTTIM(6))
      RETURN

eqreal()

logical function eqreal	(	real	REAL1,
		real	REAL2
	)

Definition at line 1177 of file ocpmix.f90.

!                                                                      *
!***********************************************************************
!
    USE ocpcomm1                                                        
    USE ocpcomm2                                                        
    USE ocpcomm3                                                        
    USE ocpcomm4                                                        
!
    IMPLICIT NONE
!
!
!   --|-----------------------------------------------------------|--
!     | Delft University of Technology                            |
!     | Faculty of Civil Engineering                              |
!     | Environmental Fluid Mechanics Section                     |
!     | P.O. Box 5048, 2600 GA  Delft, The Netherlands            |
!     |                                                           |
!     | Programmers: R.C. Ris, N. Booij,                          |
!     |              IJ.G. Haagsma, A.T.M.M. Kieftenburg,         |
!     |              M. Zijlema, E.E. Kriezi,                     |
!     |              R. Padilla-Hernandez, L.H. Holthuijsen       |
!   --|-----------------------------------------------------------|--
!
!
!     SWAN (Simulating WAves Nearshore); a third generation wave model
!     Copyright (C) 2004-2005  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.60 Nico Booij
!     40.04 Annette Kieftenburg
!     40.41: Marcel Zijlema
!
!  1. Updates
!
!     30.72, Oct. 97: Changed from EXCYES to make floating point point comparisons
!     30.60, July 97: new subroutine (EXCYES)
!     40.04, Aug. 00: introduced EPSILON and TINY
!     40.41, Oct. 04: common blocks replaced by modules, include files removed
!
!  2. Purpose
!
!     to determine whether a value (usually a value read from file)
!     is an exception value or not
!     Later (30.72) used to make comparisons of floating points within reasonable bounds
!
!  3. Method (updated...)
!
!     Checks whether ABS(REAL1-REAL2) .LE. TINY(REAL1) or whether this        40.04
!     difference is .LE. then EPS (= EPSILON(REAL1)*ABS(REAL1-REAL2) )        40.04
!
!  4. Argument variables
!
!     REAL1  : input    value that is to be tested
!     REAL2  : input    given exception value
!
    REAL      REAL1, REAL2
!
!  5. Parameter variables
!
!  6. Local variables
!
!     EPS    : Small number (related to REAL1 and its difference with REAL2)
!     IENT   : Number of entries into this subroutine
!
    REAL      EPS
    INTEGER   IENT
!
!  8. Subroutines used
!
!  9. Subroutines calling
!
!     SWREAD
!     SWDIM
!     SIRAY
!     SWBOUN
!     SWODDC
!     SWOEXD
!     SWOEXA
!     SWOEXF
!     SWPLOT
!     SWSPEC
!     ISOLIN
!     SNYPT2
!     INCTIM
!     INDBLE
!
! 10. Error messages
!
! 11. Remarks
!
! 12. Structure
!
! 13. Source text
!
    SAVE ient
    DATA ient/0/
    CALL strace(ient,'EQREAL')
    eqreal = .false.
!
    eps = epsilon(real1)*abs(real1-real2)                                  
    IF (eps ==0) eps = tiny(real1)                                         
    IF (abs(real1-real2) .GT. tiny(real1)) THEN                            
      IF (abs(real1-real2) .LT. eps) eqreal = .true.                       
    ELSE                                                                   
      eqreal = .true.                                                      
    ENDIF                                                                  
    RETURN

Here is the call graph for this function:

for()

subroutine for	(	integer	IUNIT,
		character, dimension(lenfnm)	DDNAME,
		character	SF,
		integer	IOSTAT
	)

Definition at line 835 of file ocpmix.f90.

!                                                                *
!*****************************************************************
!
   USE ocpcomm1                                                        
   USE ocpcomm2                                                        
   USE ocpcomm3                                                        
   USE ocpcomm4                                                        
!
   IMPLICIT NONE
!
!
!   --|-----------------------------------------------------------|--
!     | Delft University of Technology                            |
!     | Faculty of Civil Engineering                              |
!     | Environmental Fluid Mechanics Section                     |
!     | P.O. Box 5048, 2600 GA  Delft, The Netherlands            |
!     |                                                           |
!     | Programmers: R.C. Ris, N. Booij,                          |
!     |              IJ.G. Haagsma, A.T.M.M. Kieftenburg,         |
!     |              M. Zijlema, E.E. Kriezi,                     |
!     |              R. Padilla-Hernandez, L.H. Holthuijsen       |
!   --|-----------------------------------------------------------|--
!
!
!     SWAN (Simulating WAves Nearshore); a third generation wave model
!     Copyright (C) 2004-2005  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.13: Nico Booij
!     30.70: Nico Booij
!     30.82: IJsbrand Haagsma
!     34.01: IJsbrand Haagsma
!     40.00, 40.03: Nico Booij
!     40.41: Marcel Zijlema
!
!  1. Updates
!
!     30.13, Jan. 96: new structure
!     30.70, Feb. 98: terminating error if input file does not exist
!     30.82, Nov. 98: Introduced recordlength of 1000 for new files to
!                     avoid errors on the Cray-J90
!     34.01, Feb. 99: STOP statement removed
!     40.00, Feb. 99: DIRCH2 replaces DIRCH1 in filenames
!     40.03, May  00: modification for Linux: local copy of filename
!     40.41, Oct. 04: common blocks replaced by modules, include files removed
!
!  1. PURPOSE
!
!     General open file routine.
!
!  2. METHOD
!
!     FORTRAN 77 OPEN option.
!                INQUIRE
!
!  3. METHOD
!
!  4. ARGUMENT VARIABLES
!
!       IUNIT   int     input   =0 : get free unit number
!                               >0 : fixed unit number
!                       output  allocated unit number
!       DDNAME  char    input   ddname/filename string (empty if IUNIT>0)
!       SF      char*2  input   file qualifiers
!                               1st char: O(ld),N(ew),S(cratch),U(nknown)
!                               2nd char: F(ormatted),U(nformatted)
!       IOSTAT  int     input   0 : Full messages printed
!                               -1: Only error messages printed
!                               -2: No messages printed
!                       output  error indicator
!
   INTEGER   IUNIT, IOSTAT
   CHARACTER DDNAME*(LENFNM), SF*2                                     
!
!  5. PARAMETER VAR. (CONSTANTS)
!
!     Error codes:
!
!       IOSTAT = IESUCC No errors
!       IOSTAT > 0      I/O error
!       IOSTAT = IENUNF No free unit number found
!       IOSTAT = IEUNBD Specified unit number out of bounds
!       IOSTAT = IENODD No filename supplied with IUNIT=0
!       IOSTAT = IEDDNM Incorrect filename supplied with IUNIT>0
!       IOSTAT = IEEXST Specified unit number does not exist
!       IOSTAT = IEOPEN Specified unit number already opened
!       IOSTAT = IESTAT Error in file qualifiers
!       IOSTAT = IENSCR Named scratch file
!       IOSTAT = IENSIO No specified I/O error
!
   INTEGER  IESUCC, IENUNF, IEUNBD, IENODD,                     &
            IEDDNM, IEEXST, IEOPEN, IESTAT, IENSCR
   parameter(iesucc=  0,ienunf= -1,ieunbd= -2,ienodd= -3,      &
              ieddnm= -4,ieexst= -5,ieopen= -6,iestat= -7,      &
          ienscr=-12)
!
!  EMPTY    blank string
!
   CHARACTER  EMPTY*(*)
   parameter(empty= '        ')
!
!  6. LOCAL VARIABLES
!
!     IENT      number of entries into this subroutine
!     IFO       format index
!     IFUN      free unit number
!     II        counter
!     IOSTTM    aux. error index
!     IS        file status index
!     IUTTM     aux. unit number
!
   INTEGER   IENT, IFO, IFUN, II, IOSTTM, IS, IUTTM
!
!     EXIST     if true, file exists
!     OPENED    if true, file is opened
!
   LOGICAL   EXIST, OPENED
!
!     S
!     F
!     FILTTM   auxiliary
!     FISTAT   file status, values: OLD, NEW, UNKNOWN
!     FORM     formatting, values: FORMATTED, UNFORMATTED
!     DDNAME_L local copy of DDNAME                                       
!
   CHARACTER S, F, FILTTM *(LENFNM), DDNAME_L *(LENFNM)                
   CHARACTER *11 FISTAT(4),FORM(2)
!
!  4. SUBROUTINES USED
!
!
!  5. ERROR MESSAGES
!
!       and error messages added using MSGERR
!
!
!  6. REMARKS
!
!       Free unit number search interval: FUNLO<=IUNIT<=FUNHI
!       FUNLO, FUNHI, IUNMIN and IUNMAX were initialized by OCPINI,
!       they are transmitted via module OCPCOMM4
!
!  7. STRUCTURE
!
!       ----------------------------------------------------------------
!       Check file qualifiers
!       ----------------------------------------------------------------
!       If IUNIT = 0
!       Then If DDNAME = ' '
!            Then error message
!            Else Inquire to find if file exists and is opened,
!                 and if so, to find correct unit number
!                 If file is not opened
!                 Then get a free unit number, assign value to IUNIT
!                      open the file
!                 Else assign correct unit number to IUNIT
!       Else Inquire to find if file exists and is opened,
!                   and if so, to find correct filename
!            If file with unit nr IUNIT is already open
!            Then If filename does not correspond to DDNAME
!                 Then Close file with old filename and unit IUNIT
!                      Open file with new filename DDNAME and unit IUNIT
!            Else If DDNAME is not empty
!                 Then Open file with new filename DDNAME and unit IUNIT
!                 Else Open file with unit IUNIT
!       ----------------------------------------------------------------
!
!  8. SOURCE TEXT
!
   SAVE      ient, ifun
!
   DATA fistat(1),fistat(2) / 'OLD','NEW'/                            &
        fistat(3),fistat(4) / 'SCRATCH','UNKNOWN'/                    &
    form(1),form(2) / 'FORMATTED','UNFORMATTED'/
!
   DATA ient /0/, ifun /0/
   CALL strace (ient, 'FOR')
!
   IF(itest >= 80) WRITE (prtest, 2) iunit, ddname, sf, iostat
2  FORMAT (' Entry FOR: ', i3, 1x, a36, a2, i7)
   ddname_l = ddname                                                   
!
!     check file qualifiers
!
   IF((iunit /= 0) .AND. ((iunit < iunmin) .OR. (iunit > iunmax)))THEN
     IF(iostat > -2) CALL msgerr (3, 'Unit number out of range')
     iostat= ieunbd
     RETURN
   END IF
!
   s   = sf(1:1)
   f   = sf(2:2)
   is  = index('ONSU',s)
   ifo = index('FU',f)
   IF((is == 0) .OR. (ifo == 0))THEN
     IF(iostat > -2) CALL msgerr (3,'Error in file qualifiers')
     iostat= iestat
     RETURN
   END IF
!
   IF((s == 'S') .AND. (ddname /= empty))THEN
     IF(iostat > -2) CALL msgerr (3, 'Named scratch file')
     iostat= ienscr
     RETURN
   END IF
!
   IF(ddname /= empty)THEN                                           
!       directory separation character is replaced in filenames           
     DO ii = 1, len(ddname)
       IF(ddname(ii:ii) == dirch1) ddname(ii:ii) = dirch2             
     ENDDO
   ENDIF
!
   IF(iunit == 0)THEN
     IF(ddname == empty)THEN
       IF(iostat > -1) CALL msgerr (3, 'No filename given')
       iostat= ienodd
       RETURN
     ELSE
!         Was the file opened already ?
       INQUIRE (file=ddname, iostat=iosttm, exist=exist,           &
            opened=opened, number=iuttm)
       IF(iosttm /= iesucc)THEN
         IF(iostat > -1)                                           &
       CALL msgerr (2,'Inquire failed, filename: '//ddname_l)          
         iostat = iosttm
         RETURN
       ENDIF
!         If file does not exist, print term. error
       IF(is == 1 .AND. .NOT. exist)THEN                           
         CALL msgerr (4,'File cannot be opened/does not exist: '//ddname_l)
         iostat = ieexst
       END IF
       IF(opened)THEN
         IF(iostat.GT.-1)                                          &
           CALL msgerr (2, 'File is already opened: '//ddname_l)    
         iostat = ieopen
         iunit = iuttm
         RETURN
       ENDIF
!         Assign free unit number
       IF(ifun == 0)THEN
         ifun = funlo
       ELSE
         ifun = ifun + 1
       ENDIF
       iunit = ifun
       IF(iunit > funhi)THEN
         IF(iostat > -2) CALL msgerr (3, 'All free units used')
         iostat= ienunf
       ENDIF
     END IF
     OPEN (unit=iunit,err=999,iostat=iosttm,file=ddname,              &
!/Cray     RECL=1000,                                                 &
!/SGI      RECL=1000,                                                 &
!CVIS      SHARED,                                                    &
           status=fistat(is),access='SEQUENTIAL',form=form(ifo))      
   ELSE
     INQUIRE (unit=iunit, name=filttm, iostat=iosttm,                 &
              exist=exist, opened=opened)
     IF(iosttm /= iesucc)THEN
       IF(iostat > -1)                                               &
         CALL msgerr (2,'Inquire failed, filename: '//filttm)
       iostat = iosttm
       RETURN
     ENDIF
     IF(opened)THEN
       IF(iostat > -1)THEN
         CALL msgerr (1,'File is already opened, filename: '//filttm)
       ENDIF
       IF(filttm /= ddname .AND. filttm /= empty)THEN
         IF(iostat > -2)THEN
           WRITE (printf, '(A, I4, 6A)') ' unit', iunit,              &
              ' filenames: ', filttm, ' and: ', ddname
           CALL msgerr (2, 'filename and unit number inconsistent')
         ENDIF
         iostat = ieddnm
!          close old file and open new one with given filename
         CLOSE (iunit)
         OPEN (unit=iunit,err=999,iostat=iosttm,status=fistat(is),    &
!/Cray         RECL=1000,                                             &
!/SGI          RECL=1000,                                             &
!CVIS          SHARED,                                                &
               file=ddname,access='SEQUENTIAL',form=form(ifo))
         IF(iosttm /= iesucc) iostat = iosttm
         GOTO 80
       ENDIF
       iostat = ieopen
       RETURN
     END IF
     IF(ddname /= empty)THEN
       OPEN (unit=iunit,err=999,iostat=iosttm,status=fistat(is),      &
!/Cray       RECL=1000,                                               &         
!/SGI        RECL=1000,                                               &         
!CVIS        SHARED,                                                  & 
             file=ddname,access='SEQUENTIAL',form=form(ifo))
     ELSE
       OPEN (unit=iunit,err=999,iostat=iosttm,status=fistat(is),      &
!/Cray       RECL=1000,                                               &
!/SGI        RECL=1000,                                               &
!CVIS        SHARED,                                                  &
             access='SEQUENTIAL',form=form(ifo))
     END IF
   END IF
   hiopen = ifun
80 IF(itest >= 30) WRITE (printf, 82) iunit, ddname, sf
82 FORMAT (' File opened: ', i6, 2x, a36, 2x, a2)
   RETURN
!
!  in case file cannot be opened:
!
999 IF(iostat > -2)THEN
     CALL msgerr (3, 'File open failed, filename: '//ddname_l)         
     WRITE (printf,15) ddname, iosttm, sf
15   FORMAT (' File -> ', a36, 2x, ' IOSTAT=', i6, 4x, a2)
   ENDIF
   iunit = -1
   iostat= iosttm

   RETURN

Here is the call graph for this function:

Here is the caller graph for this function:

inar2d()

subroutine inar2d	(	real, dimension(mga)	ARR,
		integer	MGA,
		integer	NDSL,
		integer	NDSD,
		integer	IDFM,
		character, dimension(*)	RFORM,
		integer	IDLA,
		real	VFAC,
		integer	NHED,
		integer	NHEDF
	)

Definition at line 182 of file ocpmix.f90.

!                                                                *
!*****************************************************************
!
   USE ocpcomm1                                                        
   USE ocpcomm2                                                        
   USE ocpcomm3                                                        
   USE ocpcomm4                                                        
!
   IMPLICIT NONE
!
!
!   --|-----------------------------------------------------------|--
!     | Delft University of Technology                            |
!     | Faculty of Civil Engineering                              |
!     | Environmental Fluid Mechanics Section                     |
!     | P.O. Box 5048, 2600 GA  Delft, The Netherlands            |
!     |                                                           |
!     | Programmers: R.C. Ris, N. Booij,                          |
!     |              IJ.G. Haagsma, A.T.M.M. Kieftenburg,         |
!     |              M. Zijlema, E.E. Kriezi,                     |
!     |              R. Padilla-Hernandez, L.H. Holthuijsen       |
!   --|-----------------------------------------------------------|--
!
!
!     SWAN (Simulating WAves Nearshore); a third generation wave model
!     Copyright (C) 2004-2005  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.74: IJsbrand Haagsma (Include version)
!     30.82: IJsbrand Haagsma
!     34.01: Jeroen Adema
!     40.00: Nico Booij
!     40.02: IJsbrand Haagsma
!     40.03: Nico Booij
!     40.08: Erick Rogers
!     40.13: Nico Booij
!     40.41: Marcel Zijlema
!
!  1. Updates
!
!     01.05, Feb. 90: Before reading values in the array are divided by VFAC,
!                     in order to retain correct values for points where no
!                     value was given
!     01.06, Apr. 91: i/o status is printed if read error occurs
!     30.72, Sept 97: Changed DO-block with one CONTINUE to DO-block with
!                     two CONTINUE's
!     30.72, Sept 97: Corrected reading of heading lines for SERIES of files
!                     in dynamic mode
!     30.74, Nov. 97: Prepared for version with INCLUDE statements
!     40.00, July 98: SWAN specific statements modified
!                     unformatted read: heading lines also read unformatted
!                     distinction between NDSD (data file) and NDSL (file list)
!     30.82, Sep. 98: Added INQUIRE statement to produce correct file name in
!                     case of a read error
!     34.01, Feb. 99: Introducing STPNOW
!     40.02, Sep. 00: Replaced computed GOTO with CASE construct
!     40.02, Sep. 00: Replaced reserved words IOSTAT with IOERR and STATUS with IERR
!     40.03, Jul. 00: END= added to READ statement for correct reading of series
!                     of files
!     40.03, Jul. 00: TRIM used to improve readability of message
!     40.13, Apr. 01: END=930 added in READ statement; corresponding error message added
!     40.08, Mar. 03: Changed an INQUIRE statement so that it does not produce
!                     misleading results.
!     40.41, Oct. 04: common blocks replaced by modules, include files removed
!
!  2. Purpose
!
!     Reads a 2d array from dataset
!     is used to read e.g. bathymetry, one component of wind velocity
!
!  3. METHOD
!
!  4. ARGUMENT VARIABLES
!
!     IDFM   : input    format index
!     IDLAM  : input    lay-out indicator
!     MXA    : input    number of points along x-side of grid
!     MYA    : input    number of points along y-side of grid
!     NDSD   : input    unit number of the file from which to read the dataset
!     NDSL   : input    unit number of the file containing the list of filenames
!     NHEDF  : input    number of heading lines in the file (first lines).
!     NHEDL  : input    number of heading lines in the file
!                       before each array
!
   INTEGER   IDFM, IDLA, MGA, NDSD, NDSL, NHED, NHEDF
!
!     ARR    : input    results appear in this array
!     RFORM  : input    format used in reading data (char. string)
!     VFAC   : input    factor by which data must be multiplied.
!
   REAL      ARR(MGA), VFAC
!
   CHARACTER RFORM *(*)
!
!  5. PARAMETER VARIABLES
!
!  6. LOCAL VARIABLES
!
!     IERR   : ??
!     IENT   : number of entries into this subroutine
!     IOERR  : input   0 : Full messages printed
!                      -1: Only error messages printed
!                      -2: No messages printed
!              output  error indicator
!     IH     : ??
!     IX     : ??
!     IY     : ??
!     NUMFIL : ??
!
   INTEGER   IERR, IENT, IOERR, IH, IX, IY, NUMFIL                     
!
!     HEDLIN : Content of a header line
!
   CHARACTER HEDLIN *80
!
!  8. SUBROUTINE USED
!
   LOGICAL STPNOW                                                      
!
!  9. SUBROUTINES CALLING
!
! 10. ERROR MESSAGES
!
! 11. REMARKS
!
! 12. STRUCTURE
!
! 13. SOURCE TEXT
!
   INTEGER IG
   SAVE ient
   DATA ient /0/
   CALL strace (ient, 'INAR2D')
!
999  IF(ndsd < 0) RETURN                                               
!     no reading from file due to open error
!
!     *** NUMFIL is the number of that is open in one time step  **
      numfil = 0                                                          
!      IF(ITEST >= 100)THEN
!        WRITE (PRINTF, 12) MXA, MYA, NDSD, IDFM, RFORM,                   40.00
!     &  IDLA, VFAC, NHED
!  12    FORMAT (' * TEST INAR2D *', 4I4, 1X, A16, I3, 1X, E12.4, I3)
!      ENDIF
!
!     Read heading lines, and print the same:
!
  11  IF (nhed.GT.0) THEN
        IF (idfm.LT.0) THEN                                               
          IF (itest.GE.30)                                      &
                  WRITE (printf, '(I3,A)') nhed, ' Heading lines'        
          DO 28 ih=1, nhed
            READ (ndsd, end=910)                                          
  28      CONTINUE
        ELSE
          DO 30 ih=1, nhed
            READ (ndsd, '(A80)', end=910) hedlin                          
            IF (ih.EQ.1) WRITE (printf, '(A)') ' **  Heading lines  **'
            WRITE (printf, '(A4,A80)') ' -> ', hedlin
  30      CONTINUE
        ENDIF
      ENDIF
!
!     divide existing values in the array by VFAC
!
      DO ig = 1, mga                                                   
        arr(ig) = arr(ig) / vfac
      END DO    
!
!     start reading of 2D-array
!
      READ(ndsd, end=910, err=920, iostat=ierr) (arr(ig), ig=1,mga)       
      GOTO 900                                                           
!
!     *** End of data file, in case SERIES next file is opened
!     *** unit = NDSD is closed before the next one is opened
!
 910  CONTINUE
      CLOSE(ndsd)
      numfil = numfil + 1
      IF (numfil .GE. 2) GO TO 911
      IF (ndsl.GT.0) THEN
        READ (ndsl, '(A)', end=930) filenm                                
        IF (idfm.NE.-1) THEN
          ioerr = 0
          CALL for (ndsd, filenm, 'OF', ioerr)                            
          IF (stpnow()) RETURN                                            
        ELSE
          ioerr = 0
          CALL for (ndsd, filenm, 'OU', ioerr)                            
          IF (stpnow()) RETURN                                            
        ENDIF
!
!       Read heading lines, and print these:
!                                                                         
  2     IF (nhedf.GT.0) THEN                                              
          IF (idfm.LT.0) THEN                                             
            IF (itest.GE.30) WRITE (printf, '(I3,A,A)') nhedf,      &
                 ' Heading lines at begin of file ', trim(filenm)        
            DO 828 ih=1, nhedf                                            
              READ (ndsd)                                                 
 828        CONTINUE
          ELSE                                                            
            WRITE (printf, '(A,A,A)') ' **  Heading lines file ',   &
           trim(filenm), ' **'                                           
            DO 830 ih=1, nhedf                                            
              READ (ndsd, '(A80)') hedlin                                 
              WRITE (printf, '(A4,A80)') ' -> ', hedlin                   
 830        CONTINUE                                                      
          ENDIF                                                           
        ENDIF                                                             
        GO TO 11
      ENDIF
!
!     error message when end of file is encountered
!
!     --- initialize FILENM so that previous value is not used            40.08
!         in case unit NDSD does not exist                                40.08
 911  filenm='DUMMY'
!     --------------------------------------------------------------------40.08
!     THIS INQUIRE STATEMENT IS PROBLEMATIC, SINCE (AT LEAST              40.08
!     SOMETIMES) NDSD HAS ALREADY BEEN CLOSED, SO THE INQUIRE             40.08
!     STATEMENT SHOULD NOT WORK.                                          40.08
!     --------------------------------------------------------------------40.08
      INQUIRE (unit=ndsd, name=filenm)
      CALL msgerr (2, 'Unexpected end of file while reading '//       &
                      trim(filenm))                                      
      ndsd = 0                                                            
      idla = -1
!     Value of IDLA=-1 signals end of file to calling program
!
      GOTO 900
!
!     --- initialize FILENM                                               
 920  filenm='DUMMY'                                                      
      INQUIRE (unit=ndsd, name=filenm)                                    
      CALL msgerr (2, 'Error while reading file '//trim(filenm))          
      WRITE (printf, 922) ierr                                            
 922  FORMAT (' i/o status ', i6)                                         
      idla = -2                                                           
!     Value of IDLA=-2 signals read error to calling program
!
!     Multiply all values in the array by VFAC
!
 900  DO ig = 1, mga                                                  
        arr(ig) = arr(ig) * vfac
      END DO    
!
 990  IF (itest.GE.100 .OR. idla.LT.0) THEN
!        DO 996 IY=MYA, 1, -1
!          WRITE (PRINTF, 994) (ARR(IX,IY), IX=1,MXA)
! 994      FORMAT ((1X, 10E12.4))
! 996    CONTINUE
      ENDIF
      RETURN

!     No more files in NDSL:
!     --- initialize FILENM                                               
 930  filenm='DUMMY'                                                      
      INQUIRE (unit=ndsl, name=filenm)                                    
      CALL msgerr (2, 'Series of input files ended in '//trim(filenm))    
      RETURN                                                              

Here is the call graph for this function:

msgerr()

subroutine msgerr	(	integer	LEV,
		character, dimension(*)	STRING
	)

Definition at line 582 of file ocpmix.f90.

!                                                                *
!*****************************************************************
!
   USE ocpcomm1                                                        
   USE ocpcomm2                                                        
   USE ocpcomm3                                                        
   USE ocpcomm4                                                        
   USE m_parall                                                        
!
   IMPLICIT NONE
!
!
!   --|-----------------------------------------------------------|--
!     | Delft University of Technology                            |
!     | Faculty of Civil Engineering                              |
!     | Environmental Fluid Mechanics Section                     |
!     | P.O. Box 5048, 2600 GA  Delft, The Netherlands            |
!     |                                                           |
!     | Programmers: R.C. Ris, N. Booij,                          |
!     |              IJ.G. Haagsma, A.T.M.M. Kieftenburg,         |
!     |              M. Zijlema, E.E. Kriezi,                     |
!     |              R. Padilla-Hernandez, L.H. Holthuijsen       |
!   --|-----------------------------------------------------------|--
!
!
!     SWAN (Simulating WAves Nearshore); a third generation wave model
!     Copyright (C) 2004-2005  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.02: IJsbrand Haagsma
!     40.03, 40.13: Nico Booij
!     40.30: Marcel Zijlema
!     40.41: Marcel Zijlema
!
!  1. UPDATES
!
!     40.03, Aug. 00: variable ERRFNM introduced in order to get correct
!                     message on UNIX system
!     40.02, Sep. 00: Removed STOP statement
!     40.13, Nov. 01: OPEN statement instead of CALL FOR
!                     to prevent recursive subroutines calling
!     40.30, Jan. 03: introduction distributed-memory approach using MPI
!     40.41, Oct. 04: common blocks replaced by modules, include files removed
!
!  2. PURPOSE
!
!     Error messages are produced by subroutine MSGERR. if necessary
!     the value of LEVERR is increased.
!     In case of a high error level an error message file is opened
!
!  3. METHOD
!
!  4. ARGUMENT VARIABLES
!
!     LEV    : indicates how severe the present error is
!     STRING : contents of the present error message
!
   INTEGER   LEV
!
   CHARACTER STRING*(*)
!
!  5. PARAMETER VARIABLES
!
!  6. LOCAL VARIABLES
!
!     IERR   : if non-zero error message file was already opened unsuccessfully
!     IERRF  : unit reference number of the error message file
!     ILPOS  : actual length of error message filename
!
   INTEGER, SAVE :: IERR=0, ierrf=0                                    
   INTEGER ILPOS                                                       
!
!     ERRM   : error message prefix
!
   CHARACTER (LEN=17) :: ERRM                                          
!
!     ERRFNM : name of error message file
!
   CHARACTER (LEN=LENFNM), SAVE :: ERRFNM = 'Errfile'                  
!
!  8. SUBROUTINE USED
!
!     ---
!
!  9. SUBROUTINES CALLING
!
! 10. ERROR MESSAGES
!
! 11. REMARKS
!
! 12. STRUCTURE
!
! 13. SOURCE TEXT
!
!
   IF(lev > leverr) leverr=lev
   IF(lev == 0)THEN
     errm = 'Message          '
   ELSE IF(lev == 1)THEN
     errm = 'Warning          '
   ELSE IF(lev == 2)THEN
     errm = 'Error            '
   ELSE IF(lev == 3)THEN
     errm = 'Severe error     '
   ELSE
     errm = 'Terminating error'
   ENDIF
   WRITE (printf,12) errm, string
12 FORMAT (' ** ', a, ': ',a)
   IF(lev > maxerr)THEN
     IF(ierrf == 0)THEN
       IF(ierr /= 0) RETURN
!
!      append node number to ERRFNM in case of                         
!      parallel computing                                              
!
       IF(parll)THEN                                                 
         ilpos = index( errfnm, ' ' )-1                              
         WRITE(errfnm(ilpos+1:ilpos+4),13) inode                      
13       FORMAT('-',i3.3)                                             
       END IF                                                          
!
       ierrf = 17                                                          
       OPEN (unit=ierrf, file=errfnm, form='FORMATTED')                    
     ENDIF
     WRITE (ierrf,14) errm, string
14   FORMAT (a, ': ',a)
   ENDIF
!
   RETURN
!

Here is the caller graph for this function:

stpnow()

logical function stpnow

(

)

Definition at line 736 of file ocpmix.f90.

!                                                                *
!*****************************************************************
!
   USE ocpcomm4                                                      
!
   IMPLICIT NONE
!
!
!   --|-----------------------------------------------------------|--
!     | Delft University of Technology                            |
!     | Faculty of Civil Engineering                              |
!     | Environmental Fluid Mechanics Section                     |
!     | P.O. Box 5048, 2600 GA  Delft, The Netherlands            |
!     |                                                           |
!     | Programmers: R.C. Ris, N. Booij,                          |
!     |              IJ.G. Haagsma, A.T.M.M. Kieftenburg,         |
!     |              M. Zijlema, E.E. Kriezi,                     |
!     |              R. Padilla-Hernandez, L.H. Holthuijsen       |
!   --|-----------------------------------------------------------|--
!
!
!     SWAN (Simulating WAves Nearshore); a third generation wave model
!     Copyright (C) 2004-2005  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, Feb. 99: IJsbrand Haagsma
!     40.41: Marcel Zijlema
!
!  1. Updates
!
!     30.82: New function
!     40.41, Oct. 04: common blocks replaced by modules, include files removed
!
!  2. Purpose
!
!     Function determines wheter the SWAN program should be stopped
!     due to a terminating error
!
!  3. Method
!
!     Compares two common variables (the maximum allowable error-level,
!     MAXERR and the actual error-level: LEVERR).
!
!  4. ARGUMENT VARIABLES
!
!  5. PARAMETER VARIABLES
!
!  6. LOCAL VARIABLES
!
!     IENT  : Number of entries into this subroutine
!
   INTEGER IENT
!
!  8. SUBROUTINE USED
!
!  9. SUBROUTINES CALLING
!
! 10. ERROR MESSAGES
!
! 11. REMARKS
!
! 12. STRUCTURE
!
! 13. SOURCE TEXT
!
   SAVE  ient
   DATA  ient /0/
   CALL  strace (ient,'STPNOW')
!
   IF(leverr >= 4)THEN
     stpnow = .true.
   ELSE
     stpnow = .false.
   END IF
   IF(maxerr == -1) stpnow = .false.
!
   RETURN

Here is the call graph for this function:

strace()

subroutine strace	(	integer	IENT,
		character, dimension(*)	SUBNAM
	)

Definition at line 468 of file ocpmix.f90.

!                                                                *
!*****************************************************************
!
   USE ocpcomm1                                                        
   USE ocpcomm2                                                        
   USE ocpcomm3                                                        
   USE ocpcomm4                                                        
   USE m_parall                                                        
!
   IMPLICIT NONE
!
!
!   --|-----------------------------------------------------------|--
!     | Delft University of Technology                            |
!     | Faculty of Civil Engineering                              |
!     | Environmental Fluid Mechanics Section                     |
!     | P.O. Box 5048, 2600 GA  Delft, The Netherlands            |
!     |                                                           |
!     | Programmers: R.C. Ris, N. Booij,                          |
!     |              IJ.G. Haagsma, A.T.M.M. Kieftenburg,         |
!     |              M. Zijlema, E.E. Kriezi,                     |
!     |              R. Padilla-Hernandez, L.H. Holthuijsen       |
!   --|-----------------------------------------------------------|--
!
!
!     SWAN (Simulating WAves Nearshore); a third generation wave model
!     Copyright (C) 2004-2005  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. UPDATES
!
!     40.41, Oct. 04: common blocks replaced by modules, include files removed
!
!  2. PURPOSE
!
!     This subroutine produces depending on the value of 'ITRACE'
!     a message containing the name 'SUBNAM'. the purpose of this
!     action is to detect the entry of a subroutine.
!
!  3. METHOD
!
!     the first executable statement of subroutine 'AAA' has to
!     be : CALL STRACE(IENT,'AAA')
!     further is necessary : DATA IENT/0/
!     IF ITRACE=0, no message
!     IF ITRACE>0, a message is printed up to ITRACE times
!
!  4. ARGUMENT VARIABLES
!
!     IENT   :  i/o    Number of entries into the calling subroutine
!
   INTEGER IENT
!
!     SUBNAM :  inp    name of the calling subroutine.
!
   CHARACTER SUBNAM *(*)
!
!  5. PARAMETER VARIABLES
!
!  6. LOCAL VARIABLES
!                                                                         40.31
!$    LOGICAL,EXTERNAL :: OMP_IN_PARALLEL                                 40.31
!
!  8. SUBROUTINE USED
!
!  9. SUBROUTINES CALLING
!
! 10. ERROR MESSAGES
!
! 11. REMARKS
!
! 12. STRUCTURE
!
! 13. SOURCE TEXT
!
   IF(itrace == 0) RETURN
   IF(ient > itrace) RETURN
!$ IF(OMP_IN_PARALLEL())THEN                                         
!$OMP MASTER                                                              
!$   IENT=IENT+1                                                      
!$   WRITE (PRTEST, 10) SUBNAM                                        
!$   IF(SCREEN /= PRINTF) WRITE (SCREEN, 10) SUBNAM                  
!$OMP END MASTER                                                          
!$ ELSE                                                                
     ient=ient+1
     WRITE (prtest, 10) subnam
     IF(screen /= printf .AND. inode == master) WRITE (screen, 10) subnam  
!$ ENDIF                                                               
10 FORMAT (' ++ trace subr: ',a)
   RETURN

Here is the caller graph for this function: