#include "swancpp.h" ! OCEAN PACK command reading routines ! ! Contents of this file: ! RDINIT ! NWLINE ! INKEYW ! INREAL ! INDBLE ! ININTG ! INCSTR ! INCTIM ! ININTV ! INITVD ! LEESEL ! GETKAR ! PUTKAR ! UPCASE ! KEYWIS ! WRNKEY ! IGNORE ! RDHMS ! !**************************************************************** ! * SUBROUTINE RDINIT ! * !**************************************************************** ! USE OCPCOMM1 40.41 USE OCPCOMM2 40.41 USE OCPCOMM3 40.41 USE OCPCOMM4 40.41 ! 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.41: Marcel Zijlema ! ! 1. UPDATES ! ! 40.41, Oct. 04: common blocks replaced by modules, include files removed ! ! 2. PURPOSE ! ! Initialises the command reading system ! ! 3. METHOD ! ! 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,'RDINIT') KAR = ';' KARNR = LINELN + 1 40.00 ELTYPE = 'USED' BLANK = ' ' RETURN END !**************************************************************** ! * SUBROUTINE NWLINE ! * !**************************************************************** ! USE OCPCOMM1 40.41 USE OCPCOMM2 40.41 USE OCPCOMM3 40.41 USE OCPCOMM4 40.41 ! 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 ! ! 34.01: IJsbrand Haagsma ! 40.03: Nico Booij ! 40.41: Marcel Zijlema ! ! 1. UPDATES ! ! 34.01, Feb. 99: Changed STOP statement in a MSGERR(4,'message') ! 40.03, Apr. 99: length of command lines changed from 80 to LINELN (=120) ! name of input file included in error message ! 40.41, Oct. 04: common blocks replaced by modules, include files removed ! ! 2. PURPOSE ! ! Jumps to reading of the next input line, ! if the end of the previous one is reached. ! ! 3. METHOD ! ! 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,'NWLINE') 5 IF ((ELTYPE.EQ.'USED').OR.(ELTYPE.EQ.'EOR')) CALL LEESEL IF (ELTYPE.EQ.'EOF') GOTO 90 IF (ELTYPE.EQ.'KEY' .AND. KEYWRD.NE.' ') GOTO 50 IF (ELTYPE.EQ.'INT') GOTO 50 IF (ELTYPE.EQ.'REAL') GOTO 50 IF (ELTYPE.EQ.'CHAR') GOTO 50 IF (KARNR.LE.LINELN) GOTO 50 40.03 ! The end of the previous line is reached, there are no more ! unprocessed data items on that line. ! Jump to new line can take place. WRITE (PRINTF,9) ' ' 9 FORMAT (A4) KARNR=0 KAR=' ' ELTYPE='USED' GOTO 5 90 IF (ITEST.GE.10) THEN INQUIRE (UNIT=INPUTF, NAME=FILENM) 40.03 WRITE (PRINTF, *) ' end of input file '//FILENM 40.03 ENDIF 50 RETURN END !**************************************************************** ! * SUBROUTINE INKEYW (KONT, CSTA) ! * !**************************************************************** ! USE OCPCOMM1 40.41 USE OCPCOMM2 40.41 USE OCPCOMM3 40.41 USE OCPCOMM4 40.41 ! 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.41: Marcel Zijlema ! ! 1. UPDATES ! ! ver 30.70, Jan. 1998: data type 'OTHR' is condidered ! 40.41, Oct. 04: common blocks replaced by modules, include files removed ! ! 2. PURPOSE ! ! this subroutine reads a keyword. ! ! 3. METHOD ! ! 4. ARGUMENT VARIABLES ! ! KONT : action to be taken if no keyword is found in input: ! 'REQ' (required) error message ! 'STA' (standard) the value of csta is assigned to keywrd. ! ! CSTA : see above. ! CHARACTER CSTA *(*), KONT *(*) ! ! 5. PARAMETER VARIABLES ! ! 6. LOCAL VARIABLES ! ! IENT : Number of entries into this subroutine ! LENS : length of default string (CSTA) ! INTEGER IENT, LENS ! ! 8. SUBROUTINE USED ! ! 9. SUBROUTINES CALLING ! ! 10. ERROR MESSAGES ! ! 11. REMARKS ! ! 12. STRUCTURE ! ! 13. SOURCE TEXT ! SAVE IENT DATA IENT/0/ CALL STRACE ( IENT, 'INKEYW') ! ! if necessary, a new data item is read. ! IF (ELTYPE.EQ.'KEY' .AND. KEYWRD.EQ.' ') GOTO 510 IF (ELTYPE.EQ.'KEY') GOTO 900 IF (ELTYPE.EQ.'EOR') GOTO 510 IF (ELTYPE.EQ.'USED') GOTO 510 GOTO 520 510 CALL LEESEL 520 IF (ELTYPE.EQ.'KEY') GOTO 900 ! KEYWORD IS READ IF ((KONT.EQ.'STA').OR.(KONT.EQ.'NSKP')) THEN LENS = LEN(CSTA) IF (LENS.GE.8) THEN KEYWRD = CSTA(1:8) ELSE KEYWRD = ' ' KEYWRD(1:LENS) = CSTA ENDIF GOTO 900 ENDIF ! at the end of the input 'STOP' is generated. IF (ELTYPE.EQ.'EOF') THEN KEYWRD='STOP' CALL MSGERR (2, 'STOP statement is missing') GOTO 900 ENDIF ! ---------------------------------------------------------- ! Data appear where a keyword is expected. ! The user must be informed. ! ---------------------------------------------------------- IF (ELTYPE.EQ.'EOR') THEN KEYWRD = ' ' GOTO 900 ENDIF IF (ELTYPE.EQ.'INT') THEN CALL MSGERR (2, 'Data field skipped:'//ELTEXT) GOTO 510 ENDIF IF (ELTYPE.EQ.'REAL') THEN CALL MSGERR (2, 'Data field skipped:'//ELTEXT) GOTO 510 ENDIF IF (ELTYPE.EQ.'CHAR' .OR. ELTYPE.EQ.'OTHR') THEN 30.70 CALL MSGERR (2, 'Data field skipped:'//ELTEXT) GOTO 510 ENDIF IF (ELTYPE.EQ.'EMPT') THEN CALL MSGERR (2, 'Empty data field skipped') GOTO 510 ENDIF CALL MSGERR (3, 'Error subr. INKEYW') ! ---------------------------------------------------------- 900 IF (ITEST.GE.10) WRITE (PRINTF,910) KEYWRD 910 FORMAT (' KEYWORD: ',A8) RETURN END !**************************************************************** ! * SUBROUTINE INREAL (NAAM, R, KONT, RSTA) ! * !**************************************************************** ! USE OCPCOMM1 40.41 USE OCPCOMM2 40.41 USE OCPCOMM3 40.41 USE OCPCOMM4 40.41 ! 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.82: IJsbrand Haagsma ! 40.41: Marcel Zijlema ! ! 1. UPDATES ! ! 20.04, Aug. 93: logical CHGVAL is introduced it is made True if ! user changes value of an input parameter via INREAL ! 30.82, Sep. 98: To avoid errors using the Cray-cf90 compiler ! introduced a dummy ! 40.41, Oct. 04: common blocks replaced by modules, include files removed ! ! 2. PURPOSE ! ! Reads a REAL number in free format. ! ! 3. METHOD ! ! Uses the function INDBLE to read the number ! ! 4. ARGUMENT VARIABLES ! ! R : The value of the variable that is to be read. ! RSTA : Reference value needed for KONT='STA'or 'RQI' ! REAL R, RSTA ! ! KONT : What to do with the variable? ! ='REQ' : variable is required ! ='UNC' : if no variable, then variable will not be changed ! ='STA' : if no variable, then variable will get value of RSTA ! ='RQI' : variable may not have the value of RSTA ! ='REP' : (REPEAT) ! ='NSKP': (NO SKIP) if data item is of different type, ! value is left unchanged ! NAAM : Name of the variable according to the user manual. ! CHARACTER NAAM *(*), KONT *(*) ! ! 5. PARAMETER VARIABLES ! ! DRSTA : Double precision variant of RSTA ! RDBL : Double precision variant of R ! DOUBLE PRECISION RDBL, DRSTA ! ! IENT : Number of entries into this subroutine ! INTEGER IENT ! ! 6. LOCAL VARIABLES ! ! 8. SUBROUTINE USED ! ! 9. SUBROUTINES CALLING ! ! 10. ERROR MESSAGES ! ! 11. REMARKS ! ! 12. STRUCTURE ! ! 13. SOURCE TEXT ! SAVE IENT DATA IENT /0/ CALL STRACE ( IENT, 'INREAL') ! RDBL = DBLE(R) DRSTA = DBLE(RSTA) 30.82 CALL INDBLE (NAAM, RDBL, KONT, DRSTA) 30.82 ! ! RDBL may have changed due to the value of KONT ! R = REAL(RDBL) RETURN ! ! End of subroutine INREAL ! END ! !**************************************************************** ! * SUBROUTINE INDBLE (NAAM, R, KONT, RSTA) ! * !**************************************************************** ! USE OCPCOMM1 40.41 USE OCPCOMM2 40.41 USE OCPCOMM3 40.41 USE OCPCOMM4 40.41 ! 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.72: IJsbrand Haagsma ! 40.03: Nico Booij ! 40.41: Marcel Zijlema ! ! 1. UPDATES ! ! 30.72, Oct. 97: Introduced logical function EQREAL for floating point ! comparisons ! 20.05, Aug. 93: NEW subroutine for double prec. data ! 40.03, Feb. 00: local copy of NAAM used in error message ! 40.41, Oct. 04: common blocks replaced by modules, include files removed ! ! 2. PURPOSE ! ! Reads a DOUBLE PRECISION number, in free format. ! ! 3. METHOD ! ! 4. ARGUMENT VARIABLES ! ! R : THE VARIABLE THAT IS TO BE READ. ! RSTA : SEE ABOVE ! DOUBLE PRECISION R, RSTA ! ! KONT : What to do with the variable? ! ='REQ'; Value in input file is required ! ='UNC'; If no value, then variable will not be changed ! ='STA'; If no value, then variable will get value of RSTA ! ='RQI'; Variable may not have the value of RSTA ! ='REP' (repeat) ! ='NSKP' (no skip) if data item is of different type, ! value is left unchanged. ! NAAM : name of the variable according to the user's manual. ! CHARACTER KONT *(*), NAAM *(*) ! ! 5. PARAMETER VARIABLES ! ! 6. LOCAL VARIABLES ! ! IENT : Number of entries into this subroutine ! LENNM : length of string NAAM ! INTEGER IENT, LENNM ! ! NAAM_L : local copy of NAAM 40.03 ! CHARACTER (LEN=40) :: NAAM_L 40.03 ! ! EQREAL : ! LOGICAL EQREAL 30.72 ! ! 8. SUBROUTINE USED ! ! 9. SUBROUTINES CALLING ! ! 10. ERROR MESSAGES ! ! 11. REMARKS ! ! 12. STRUCTURE ! ! 13. SOURCE TEXT ! SAVE IENT DATA IENT /0/ CALL STRACE ( IENT, 'INDBLE') ! ! if necessary, a new data item is read ! CHGVAL = .FALSE. NAAM_L = NAAM 40.03 IF (ELTYPE.EQ.'USED') CALL LEESEL ! consider type of data item IF (ELTYPE.EQ.'KEY') THEN ! find out whether in input is written: NAAM=... LENNM = LEN(NAAM) IF (NAAM.NE.ELTEXT(1:LENNM)) GOTO 20 ELTYPE = 'USED' CALL LEESEL IF (ELTYPE.EQ.'REAL') GOTO 12 IF (ELTYPE.EQ.'INT') GOTO 14 GOTO 50 ENDIF ! if type is 'REAL' or 'INT', its value is assigned to R 12 IF (ELTYPE.EQ.'REAL') THEN R = ELREAL ELTYPE = 'USED' IF (.NOT.EQREAL(REAL(R),REAL(RSTA))) CHGVAL = .TRUE. 30.72 GOTO 80 ENDIF 14 IF (ELTYPE.EQ.'INT') THEN R = DBLE(ELINT) ELTYPE = 'USED' IF (.NOT.EQREAL(REAL(R),REAL(RSTA))) CHGVAL = .TRUE. 30.72 GOTO 80 ENDIF IF (ELTYPE.EQ.'EOR') THEN ! find out whether end of repeat is reached, ! if so make R=RSTA. IF (KONT.NE.'REP') GOTO 20 ELTYPE='USED' GOTO 70 ENDIF IF (ELTYPE.EQ.'EOF') GOTO 20 IF (ELTYPE.EQ.'EMPT') THEN ELTYPE='USED' GOTO 20 ENDIF IF (ELTYPE.EQ.'ERR') GOTO 50 IF (ELTYPE.EQ.'CHAR' .OR. ELTYPE.EQ.'OTHR') THEN 30.04 IF (KONT.EQ.'NSKP') GOTO 70 CALL MSGERR (3, & 'Wrong type of data for variable '//NAAM_L) 40.03 WRITE (PRINTF,18) NAAM, ELTEXT(1:LENCST) 18 FORMAT (' -> ',A, ' item=', A) ELTYPE='USED' GOTO 70 20.01 ENDIF CALL MSGERR (3, 'Error subr. INREAL') WRITE (PRINTF, '(1X,A,A)') ELTYPE, KONT ! ------------------------------------------------------------- ! data item of different type is read, action according to KONT ! ------------------------------------------------------------- 20 IF (KONT.EQ.'REQ') GOTO 30 IF (KONT.EQ.'REP') GOTO 70 IF (KONT.EQ.'RQI') GOTO 28 IF (KONT.EQ.'STA') GOTO 70 IF (KONT.EQ.'NSKP') GOTO 70 IF (KONT.EQ.'UNC') GOTO 80 ! CALL MSGERR (3, 'Error subr. INREAL') WRITE (PRINTF, '(1X,A,A)') ELTYPE, KONT GOTO 70 ! 28 IF (.NOT.EQREAL(REAL(R),REAL(RSTA))) GOTO 80 30.72 30 CALL MSGERR (3, 'No value for variable '//NAAM_L) 40.03 WRITE (PRINTF,18) NAAM, ELTEXT(1:LENCST) GOTO 70 ! 50 CALL MSGERR (3, 'Read error with variable '//NAAM_L) 40.03 WRITE (PRINTF,18) NAAM, ELTEXT(1:LENCST) ELTYPE='USED' ! 70 R = RSTA 80 IF (ITEST.GE.10) WRITE (PRINTF, 85) NAAM, R 85 FORMAT (1X,A8,'=',D12.4) RETURN END !**************************************************************** ! * SUBROUTINE ININTG (NAAM, IV, KONT, ISTA) ! * !**************************************************************** ! USE OCPCOMM1 40.41 USE OCPCOMM2 40.41 USE OCPCOMM3 40.41 USE OCPCOMM4 40.41 ! 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.03: Nico Booij ! 40.41: Marcel Zijlema ! ! 1. UPDATES ! ! 20.04, August 1993: logical CHGVAL is introduced ! it is made True if user changes value ! of an input parameter via ININTG ! 40.03, Feb. 00: local copy of NAAM used in error message ! 40.41, Oct. 04: common blocks replaced by modules, include files removed ! ! 2. PURPOSE ! ! Reads an integer number, in free format ! ! 3. METHOD ! ! 4. ARGUMENT VARIABLES ! ! IV : integer variable which is to be assigned a value ! ISTA : default value ! INTEGER IV, ISTA ! ! NAAM : name of the variable according to the user manual ! KONT : What to do with the variable? ! ='REQ'; error message if no value is found in the input file ! ='UNC'; If no value, then variable will not be changed ! ='STA'; If no value, then variable will get default value ! ='RQI'; Variable may not have the value of RSTA ! ='REP' (repeat) ! ='NSKP' (no skip) if data item is of different type, ! value is left unchanged. ! CHARACTER NAAM *(*), KONT *(*) ! ! 5. PARAMETER VARIABLES ! ! PARAMETERS: SEE SUBR. INREAL ! ! 6. LOCAL VARIABLES ! ! IENT : Number of entries into this subroutine ! LENNM : length of the string NAAM ! INTEGER IENT, LENNM ! ! NAAM_L : local copy of NAAM 40.03 ! CHARACTER (LEN=40) :: NAAM_L 40.03 ! ! 8. SUBROUTINE USED ! ! 9. SUBROUTINES CALLING ! ! 10. ERROR MESSAGES ! ! 11. REMARKS ! ! 12. STRUCTURE ! ! 13. SOURCE TEXT ! SAVE IENT DATA IENT /0/ CALL STRACE ( IENT, 'ININTG') ! CHGVAL = .FALSE. NAAM_L = NAAM 40.03 ! IF NECESSARY, A NEW DATA ITEM IS READ IF (ELTYPE.EQ.'USED') CALL LEESEL ! CONSIDER TYPE OF DAT ITEM. IF (ELTYPE.EQ.'EOR') GOTO 14 IF (ELTYPE.EQ.'KEY') GOTO 16 IF (ELTYPE.EQ.'EOF') GOTO 20 IF (ELTYPE.EQ.'EMPT') GOTO 18 IF (ELTYPE.EQ.'ERR') GOTO 50 IF (ELTYPE.EQ.'CHAR') GOTO 40 IF (ELTYPE.EQ.'OTHR') GOTO 40 IF (ELTYPE.EQ.'REAL') GOTO 40 ! TYPE IS 'INT', VALUE IS ASSIGNED 12 IV=ELINT IF (IV.NE.ISTA) CHGVAL = .TRUE. ELTYPE='USED' GOTO 80 14 IF (KONT.NE.'REP') GOTO 20 ELTYPE='USED' GOTO 70 20.01 16 LENNM = LEN(NAAM) IF (NAAM.NE.ELTEXT(1:LENNM)) GOTO 20 CALL LEESEL IF (ELTYPE.EQ.'INT') GOTO 12 GOTO 50 18 ELTYPE='USED' 20 IF (KONT.EQ.'REQ') GOTO 30 IF (KONT.EQ.'REP') GOTO 70 IF (KONT.EQ.'RQI') GOTO 28 IF (KONT.EQ.'STA') GOTO 70 IF (KONT.EQ.'NSKP') GOTO 70 GOTO 80 28 IF (IV.NE.ISTA) GOTO 80 30 CALL MSGERR (2, 'No value for variable '//NAAM_L) 40.03 GOTO 70 20.01 40 IF (KONT.EQ.'NSKP') GOTO 70 CALL MSGERR (2, 'Wrong type of data for variable '//NAAM_L) 40.03 WRITE (PRINTF,41) NAAM, ELTEXT(1:LENCST) 30.04 41 FORMAT (' -> ',A8, ' item read=', A) ELTYPE='USED' GOTO 70 20.01 50 CALL MSGERR (2, 'Read error with variable '//NAAM_L) 40.03 WRITE (PRINTF,41) NAAM, ELTEXT(1:LENCST) 30.04 ELTYPE='USED' 70 IV=ISTA 20.01 80 IF (ITEST.GE.10) WRITE (PRINTF, 85) NAAM, IV 85 FORMAT (1X,A8,'=',I6) RETURN END !**************************************************************** ! * SUBROUTINE INCSTR (NAAM, C, KONT, CSTA) ! * !**************************************************************** ! USE OCPCOMM1 40.41 USE OCPCOMM2 40.41 USE OCPCOMM3 40.41 USE OCPCOMM4 40.41 ! 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.03: Nico Booij ! 40.41: Marcel Zijlema ! ! 1. UPDATES ! ! 20.04, August 1993: logical CHGVAL is introduced ! it is made True if user changes value ! of an input parameter via INCSTR ! 40.03, Feb. 00: local copy of NAAM used in error message ! 40.41, Oct. 04: common blocks replaced by modules, include files removed ! ! 2. PURPOSE ! ! Reads a string in free format ! ! 3. METHOD ! ! 4. ARGUMENT VARIABLES ! ! NAAM : name of the variable according to the user manual ! KONT : What to do with the variable? ! ='REQ'; error message if no value is found in the input file ! ='UNC'; If no value, then variable will not be changed ! ='STA'; If no value, then variable will get default value ! ='RQI'; Variable may not have the value of CSTA ! ='REP' (repeat) ! ='NSKP' (no skip) if data item is of different type, ! value is left unchanged. ! C : string that is to be read from input file ! CSTA : default value of the string ! CHARACTER NAAM *(*), KONT *(*), C *(*), CSTA *(*) ! ! 5. PARAMETER VARIABLES ! ! Parameters: see program documentation. ! ! 6. LOCAL VARIABLES ! ! IENT : Number of entries into this subroutine ! LENNM : length of the string NAAM ! LENW : length of the string C ! NS : length of the string CSTA ! INTEGER IENT, LENNM, LENW, NS ! ! NAAM_L : local copy of NAAM 40.03 ! CHARACTER (LEN=40) :: NAAM_L 40.03 ! ! 8. SUBROUTINE USED ! ! 9. SUBROUTINES CALLING ! ! 10. ERROR MESSAGES ! ! 11. REMARKS ! ! 12. STRUCTURE ! ! 13. SOURCE TEXT ! SAVE IENT DATA IENT /0/ CALL STRACE ( IENT, 'INCSTR') ! CHGVAL = .FALSE. NAAM_L = NAAM 40.03 LENW = LEN(C) ! IF NECESSARY, A NEW DATA ITEM IS READ. IF (ELTYPE.EQ.'USED') CALL LEESEL ! CONSIDER TYPE OF DATA ITEM. IF (ELTYPE.EQ.'KEY') THEN ! FIND OUT WHETHER IN INPUT IS WRITTEN: NAAM=.... LENNM = LEN(NAAM) IF (NAAM.NE.ELTEXT(1:LENNM)) GOTO 20 ELTYPE = 'USED' CALL LEESEL IF (ELTYPE.EQ.'CHAR') GOTO 12 GOTO 50 ENDIF 12 IF (ELTYPE.EQ.'CHAR') THEN ! TYPE IS 'CHAR', VALUE IS ASSIGNED. IF (LENCST.GT.LENW) THEN CALL MSGERR (2, & 'too long string given for: '//NAAM_L) 40.03 WRITE (PRINTF, 13) NAAM, ELTEXT(1:LENCST) 13 FORMAT (' name=', A, ' string=', A) ENDIF C = ELTEXT(1:LENW) IF (C.NE.CSTA) CHGVAL = .TRUE. ELTYPE='USED' GOTO 80 ENDIF IF (ELTYPE.EQ.'EOR') THEN ! END OF REPEAT GROUP, STANDARD VALUE IS ASSIGNED. IF (KONT.NE.'REP') GOTO 20 ELTYPE='USED' GOTO 70 ENDIF IF (ELTYPE.EQ.'EOF') GOTO 20 IF (ELTYPE.EQ.'EMPT') THEN ELTYPE='USED' GOTO 20 ENDIF IF (ELTYPE.EQ.'ERR') GOTO 50 IF (ELTYPE.EQ.'INT') GOTO 40 IF (ELTYPE.EQ.'REAL') GOTO 40 IF (ELTYPE.EQ.'OTHR') GOTO 40 30.04 CALL MSGERR (3, 'Error subr. INCSTR') WRITE (PRINTF, '(1X,A,1X,A)') ELTYPE, KONT GOTO 80 ! -------------------------------------------------------- ! No value provided, action is taken according to 'KONT'. ! -------------------------------------------------------- 20 IF (KONT.EQ.'REQ') GOTO 30 IF (KONT.EQ.'REP') GOTO 70 IF (KONT.EQ.'RQI') GOTO 28 IF (KONT.EQ.'STA') GOTO 70 IF (KONT.EQ.'NSKP') GOTO 70 IF (KONT.EQ.'UNC') GOTO 80 CALL MSGERR (3, 'Error subr. INCSTR') WRITE (PRINTF, '(1X,A,1X,A)') ELTYPE, KONT GOTO 70 20.01 ! 28 IF (C(1:LENW).NE.CSTA(1:LENW)) GOTO 80 30 CALL MSGERR (3, 'No value for variable '//NAAM_L) 40.03 GOTO 70 20.01 40 IF (KONT.EQ.'NSKP') GOTO 70 CALL MSGERR (3, 'Wrong type of data for variable '//NAAM_L) 40.03 WRITE (PRINTF,41) NAAM, ELTEXT(1:LENCST) 41 FORMAT (' -> ',A8) ELTYPE='USED' GOTO 70 20.01 50 CALL MSGERR (3, 'Read error with variable '//NAAM_L) 40.03 WRITE (PRINTF,41) NAAM, ELTEXT(1:LENCST) ELTYPE='USED' ! 70 NS = LEN(CSTA) IF (NS.LT.LENW) THEN C(1:NS) = CSTA(1:NS) C(NS+1:LENW) = ' ' LENCST = NS ELSE C(1:LENW) = CSTA(1:LENW) LENCST = LENW ENDIF 80 IF (ITEST.GE.10) WRITE (PRINTF, 85) TRIM(NAAM), C, LENCST 40.03 85 FORMAT (1X, A, ' = ', A, 4X, 'length:', I3) RETURN END !**************************************************************** ! * SUBROUTINE INCTIM (IOPTIM, NAAM, RV, KONT, RSTA) ! * !**************************************************************** ! USE OCPCOMM1 40.41 USE OCPCOMM2 40.41 USE OCPCOMM3 40.41 USE OCPCOMM4 40.41 ! 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.72: IJsbrand Haagsma ! 40.03: Nico Booij ! 40.41: Marcel Zijlema ! ! 1. UPDATES ! ! 30.72, Oct. 97: Introduced logical function EQREAL for floating point ! comparisons ! 30.04, Mar. 95: New subroutine ! 40.03, Feb. 00: local copy of NAAM used in error message ! 40.41, Oct. 04: common blocks replaced by modules, include files removed ! ! 2. PURPOSE ! ! Reads and interprets a time string ! ! 3. METHOD ! ! 4. ARGUMENT VARIABLES ! ! IOPTIM int inp time reading option (see subr DTSTTI) ! ! INTEGER IOPTIM ! ! RV : variable that is to be assigned a value ! RSTA : default value ! REAL*8 RV, RSTA ! ! NAAM : name of the variable according to the user manual ! KONT : What to do with the variable? ! ='REQ'; error message if no value is found in the input file ! ='UNC'; If no value, then variable will not be changed ! ='STA'; If no value, then variable will get default value ! ='RQI'; Variable may not have the value of RSTA ! ='REP' (repeat) ! ='NSKP' (no skip) if data item is of different type, ! value is left unchanged. ! CHARACTER NAAM *(*), KONT *(*) ! ! 5. PARAMETER VARIABLES ! ! PARAMETERS: SEE PROGRAM DOCUMENTATION. ! ! 6. LOCAL VARIABLES ! ! IENT : Number of entries into this subroutine ! LENMN : length of the string NAAM ! INTEGER IENT, LENNM ! ! NAAM_L : local copy of NAAM 40.03 ! CHARACTER (LEN=40) :: NAAM_L 40.03 ! ! EQDBLE : logical function, True if arguments are equal ! LOGICAL EQDBLE 30.72 ! ! 8. SUBROUTINE USED ! ! 9. SUBROUTINES CALLING ! ! 10. ERROR MESSAGES ! ! 11. REMARKS ! ! 12. STRUCTURE ! ! 13. SOURCE TEXT ! SAVE IENT DATA IENT /0/ CALL STRACE ( IENT, 'INCTIM') ! CHGVAL = .FALSE. NAAM_L = NAAM 40.03 ! If necessary, a new data item is read. IF (ELTYPE.EQ.'USED') CALL LEESEL ! Consider type of data item. IF (ELTYPE.EQ.'KEY') THEN ! find out whether in input is written: NAAM=.... LENNM = LEN(NAAM) IF (NAAM.NE.ELTEXT(1:LENNM)) GOTO 20 ELTYPE = 'USED' CALL LEESEL IF (ELTYPE.EQ.'CHAR' .OR. ELTYPE.EQ.'OTHR' & .OR. ELTYPE.EQ.'REAL' .OR. ELTYPE.EQ.'INT') GOTO 12 GOTO 50 ENDIF 12 IF (ELTYPE.EQ.'CHAR' .OR. ELTYPE.EQ.'OTHR' & .OR. ELTYPE.EQ.'REAL' .OR. ELTYPE.EQ.'INT') THEN ! TYPE IS 'CHAR' etc., time is read from string CALL DTRETI (ELTEXT(1:LENCST), IOPTIM, RV) IF (.NOT.EQDBLE(RV,RSTA)) CHGVAL = .TRUE. 30.72 ELTYPE='USED' GOTO 80 ENDIF IF (ELTYPE.EQ.'EOR') THEN ! end of repeat group, standard value is assigned. IF (KONT.NE.'REP') GOTO 20 ELTYPE='USED' GOTO 70 ENDIF IF (ELTYPE.EQ.'EOF') GOTO 20 IF (ELTYPE.EQ.'EMPT') THEN ELTYPE='USED' GOTO 20 ENDIF IF (ELTYPE.EQ.'ERR') GOTO 50 IF (ELTYPE.EQ.'INT') GOTO 40 IF (ELTYPE.EQ.'REAL') GOTO 40 CALL MSGERR (3, 'Error subr. INCTIM') 40.00 WRITE (PRINTF, '(1X,A,1X,A)') ELTYPE, KONT GOTO 80 ! -------------------------------------------------------- ! no value provided, action is taken according to 'KONT'. ! -------------------------------------------------------- 20 IF (KONT.EQ.'REQ') GOTO 30 IF (KONT.EQ.'REP') GOTO 70 IF (KONT.EQ.'RQI') GOTO 28 IF (KONT.EQ.'STA') GOTO 70 IF (KONT.EQ.'NSKP') GOTO 70 IF (KONT.EQ.'UNC') GOTO 80 CALL MSGERR (3, 'Error subr. INCTIM') 40.00 WRITE (PRINTF, '(1X,A,1X,A)') ELTYPE, KONT GOTO 70 20.01 ! 28 IF (.NOT.EQDBLE(RV,RSTA)) GOTO 80 30 CALL MSGERR (3, 'No value for variable '//NAAM_L) 40.03 WRITE (PRINTF,31) NAAM, ELTEXT(1:LENCST) 31 FORMAT (' -> ',A, ' item read=', A) GOTO 70 20.01 40 IF (KONT.EQ.'NSKP') GOTO 70 CALL MSGERR (3, 'Wrong type of data for variable '//NAAM_L) 40.03 WRITE (PRINTF,31) NAAM, ELTEXT(1:LENCST) ELTYPE='USED' GOTO 70 20.01 50 CALL MSGERR (3, 'Read error with variable '//NAAM_L) 40.03 WRITE (PRINTF,31) NAAM, ELTEXT(1:LENCST) ELTYPE='USED' ! 70 RV =RSTA 80 IF (ITEST.GE.10) WRITE (PRINTF, 85) NAAM, ELTEXT(1:LENCST), RV 85 FORMAT (1X, A, ' = ', A, 4X, 't in sec:', F10.0) RETURN END !******************************************************************* ! * SUBROUTINE ININTV (NAME, RVAR, KONT, RSTA) 30.09 ! * !******************************************************************* ! USE OCPCOMM1 40.41 USE OCPCOMM2 40.41 USE OCPCOMM3 40.41 USE OCPCOMM4 40.41 ! 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.41: Marcel Zijlema ! ! 1. UPDATES ! ! Dec 1995, ver 30.09 : new subroutine ! 40.41, Oct. 04: common blocks replaced by modules, include files removed ! ! 2. PURPOSE ! ! Read a time interval in the form: number DAY/HR/MIN/SEC ! ! 3. METHOD ! ! 4. ARGUMENT VARIABLES ! ! NAAM : name of the variable according to the user manual ! KONT : What to do with the variable? ! ='REQ'; error message if no value is found in the input file ! ='UNC'; If no value, then variable will not be changed ! ='STA'; If no value, then variable will get default value ! ='RQI'; Variable may not have the value of RSTA ! ='REP' (repeat) ! ='NSKP' (no skip) if data item is of different type, ! value is left unchanged. ! CHARACTER NAME *(*), KONT *(*) ! ! RSTA : default value ! RVAR : variable that is to be assigned a value ! REAL RSTA, RVAR ! ! 5. PARAMETER VARIABLES ! ! 6. LOCAL VARIABLES ! ! IENT : Number of entries into this subroutine ! INTEGER IENT ! ! FAC : a factor, value depends on unit of time used ! RI : auxiliary variable ! REAL FAC, RI ! ! KEYWIS : logical function, True if keyword encountered is equal to ! keyword in user manual ! LOGICAL KEYWIS ! ! 8. SUBROUTINE USED ! ! 9. SUBROUTINES CALLING ! ! 10. ERROR MESSAGES ! ! 11. REMARKS ! ! 12. STRUCTURE ! ! ------------------------------------------------------------- ! Call INREAL to read number of time units ! If a value was read ! Then Read time unit ! Case time unit is ! DAY: Fac = 24*3600 ! HR: Fac = 3600 ! MI: Fac = 60 ! SEC: Fac = 1 ! Else Fac = 1 ! ------------------------------------------------------------- ! Interval in seconds = Fac * number of time units ! ------------------------------------------------------------- ! ! 13. SOURCE TEXT ! SAVE IENT DATA IENT /0/ CALL STRACE (IENT, 'ININTV') 30.09 ! CALL INREAL (NAME, RI, KONT, RSTA) IF (CHGVAL) THEN CALL INKEYW ('STA', 'S') IF (KEYWIS('DA')) THEN FAC = 24.*3600. ELSE IF (KEYWIS('HR')) THEN FAC = 3600. ELSE IF (KEYWIS('MI')) THEN FAC = 60. ELSE CALL IGNORE ('S') FAC = 1. ENDIF ELSE FAC = 1. ENDIF RVAR = FAC * RI RETURN ! end of subroutine ININTV 30.09 END !******************************************************************* ! * SUBROUTINE INITVD (NAME, RVAR, KONT, RSTA) ! * !******************************************************************* ! 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: 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. UPDATES ! ! July 2015: copied from ININTV, adapted to double precision ! ! 2. PURPOSE ! ! Read a time interval in the form: number DAY/HR/MIN/SEC ! ! 3. METHOD ! ! 4. ARGUMENT VARIABLES ! ! NAAM : name of the variable according to the user manual ! KONT : What to do with the variable? ! ='REQ'; error message if no value is found in the input file ! ='UNC'; If no value, then variable will not be changed ! ='STA'; If no value, then variable will get default value ! ='RQI'; Variable may not have the value of RSTA ! ='REP' (repeat) ! ='NSKP' (no skip) if data item is of different type, ! value is left unchanged. ! CHARACTER NAME *(*), KONT *(*) ! ! RSTA : default value ! RVAR : variable that is to be assigned a value ! REAL*8 RSTA, RVAR ! ! 5. PARAMETER VARIABLES ! ! 6. LOCAL VARIABLES ! ! IENT : Number of entries into this subroutine ! INTEGER IENT ! ! FAC : a factor, value depends on unit of time used ! RI : auxiliary variable ! REAL*8 FAC, RI ! ! KEYWIS : logical function, True if keyword encountered is equal to ! keyword in user manual ! LOGICAL KEYWIS ! ! 8. SUBROUTINE USED ! ! 9. SUBROUTINES CALLING ! ! 10. ERROR MESSAGES ! ! 11. REMARKS ! ! 12. STRUCTURE ! ! ------------------------------------------------------------- ! Call INREAL to read number of time units ! If a value was read ! Then Read time unit ! Case time unit is ! DAY: Fac = 24*3600 ! HR: Fac = 3600 ! MI: Fac = 60 ! SEC: Fac = 1 ! Else Fac = 1 ! ------------------------------------------------------------- ! Interval in seconds = Fac * number of time units ! ------------------------------------------------------------- ! ! 13. SOURCE TEXT ! SAVE IENT DATA IENT /0/ CALL STRACE (IENT, 'INITVD') ! CALL INDBLE (NAME, RI, KONT, RSTA) IF (CHGVAL) THEN CALL INKEYW ('STA', 'S') IF (KEYWIS('DA')) THEN FAC = 24.*3600. ELSE IF (KEYWIS('HR')) THEN FAC = 3600. ELSE IF (KEYWIS('MI')) THEN FAC = 60. ELSE CALL IGNORE ('S') FAC = 1. ENDIF ELSE FAC = 1. ENDIF RVAR = FAC * RI RETURN ! end of subroutine INITVD END !**************************************************************** ! * SUBROUTINE LEESEL ! * !**************************************************************** ! USE OCPCOMM1 40.41 USE OCPCOMM2 40.41 USE OCPCOMM3 40.41 USE OCPCOMM4 40.41 ! 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.13: Nico Booij ! 40.41: Marcel Zijlema ! ! 1. UPDATES ! ! Jan. 1994, mod. 20.05: ELREAL is made double precision ! 40.13, Jan. 01: ! is now added as comment sign ! 40.41, Oct. 04: common blocks replaced by modules, include files removed ! ! 2. PURPOSE ! ! reads a new data item from the string 'KAART'. ! type of the item is determined, and the contents appears ! in ELTEXT, ELINT, or ELREAL, as the case may be. ! the following types are distinguished: ! 'KEY' keyword ! 'INT' integer or real number ! 'REAL' real number ! 'CHAR' character string enclosed in quotes ! 'EMPT' empty data field ! 'OTHR' non-empty data item not recognized as real, int or char, ! possibly a time string ! 'EOF' end of input file ! ! 'EOR' end of repeat, or end of record ! 'ERR' error ! 'USED' used, item last read is processed already. ! ! 3. METHOD ! ! difference between comment signs $ and !: 40.13 ! everything on an input line behind a ! is ignored ! text between two $-signs (on one line) is intepreted as comment ! text behind two $-signs is intepreted as valid input ! ! 4. ARGUMENT VARIABLES ! ! 5. PARAMETER VARIABLES ! ! 6. LOCAL VARIABLES ! ! IENT : Number of entries into this subroutine ! IRK : auxiliary value used to detect errors ! ISIGN1 : sign of mantissa part ! ISIGN2 : sign of exponent part ! ISTATE : state of the number reading process ! J : counter ! JJ : counter ! JKAR : counts the number of characters in the data field ! NREP : repetition number ! NUM1 : value of integer part of mantissa ! NUM2 : exponent value ! INTEGER IENT, IRK, ISIGN1, ISIGN2, ISTATE, J, JJ, JKAR, NREP, & NUM1, NUM2 ! ! RMANT : real mantissa value ! DOUBLE PRECISION RMANT ! ! QUOTE : the quote character ! CHARACTER QUOTE *1 ! ! 8. SUBROUTINE USED ! ! 9. SUBROUTINES CALLING ! ! 10. ERROR MESSAGES ! ! 11. REMARKS ! ! 12. STRUCTURE ! ! 13. SOURCE TEXT ! SAVE IENT, QUOTE, NREP 40.00 DATA QUOTE/''''/ , IENT/0/, NREP/1/ CALL STRACE ( IENT, 'LEESEL') ! IF (NREP.GT.1) THEN NREP = NREP - 1 GOTO 190 ENDIF ! ! initialisations ! 2 NREP = 1 DO 4 J=1,LINELN,4 40.00 ELTEXT(J:J+3) = ' ' 4 CONTINUE JKAR = 1 ELINT=0 ELREAL=0. ! ! start processing data item ! IF (KARNR.EQ.0) GOTO 12 ! process a new character 10 IF (KAR.EQ.'!' .OR. KARNR.GT.LINELN) THEN 40.13 ! end of the line is reached, if repetition factor is >1 ! the data item is assumed to be empty IF (NREP.GT.1) GOTO 28 ! end of the line is reached, if no repetition factor appears ! the data item is assumed to be of type 'EOR' ELTYPE='EOR' IF (KAR.EQ.'!') KARNR = LINELN+1 40.13 GOTO 190 ENDIF ! skip leading blanks or Tab characters 11 IF (KAR.NE.' ' .AND. KAR.NE.TABC) GOTO 20 12 CALL GETKAR ! end of input file was reached IF (ELTYPE.EQ.'EOF') THEN ! generate keyword STOP ELTEXT='STOP' GOTO 190 ENDIF GOTO 10 ! if character is comma, empty data field 20 IF (KAR.NE.',') GOTO 30 CALL GETKAR 28 ELTYPE='EMPT' GOTO 190 ! Notice: jump to label 28 (empty data field) ! if after repetition a comment, a keyword, end of record etc. is found. ! -------------------------------------------------------- ! see whether end of repeat (; or /) is marked 30 IF (INDEX(';/',KAR).GT.0) THEN 40.00 IF (NREP.GT.1) GOTO 28 ELTYPE='EOR' CALL GETKAR GOTO 190 ENDIF ! ( marks the beginning of a data item group; is ignored 38 IF (KAR.EQ.'(') GOTO 12 ! -------------------------------------------------------- ! comment; data enclosed in comment identifiers is interpreted as comment 40 IF (KAR.EQ.COMID) THEN IF (NREP.GT.1) GOTO 28 41 CALL GETKAR IF (KARNR.GT.LINELN) GOTO 10 40.00 IF (KAR.NE.COMID) GOTO 41 GOTO 12 ENDIF ! ------------------------------------------------------- ! if item is a number, read this integer or real number ! ! integer number: SIGN1]NUM1 ! real: SIGN1]NUM1].]MANT]E]SIGN2]NUM2 ! ISTATE = 10 9 8 7 6 5 4 3 ! SIGN1, SIGN2: + OR - ! NUM1, NUM2, MANT: series of digits ! ------------------------------------------------------- 50 IF (INDEX('+-.0123456789',KAR).EQ.0) GOTO 80 NUM1=0 NUM2=0 ISIGN1=1 ISIGN2=1 ISTATE=10 IRK=0 RMANT=0. ELTYPE='INT' IF (INDEX('+-',KAR).EQ.0) GOTO 52 ISTATE=9 IF (KAR.EQ.'-') ISIGN1=-1 CALL PUTKAR (ELTEXT, KAR, JKAR) CALL GETKAR ! **** part before decimal point **** 52 IF (INDEX('0123456789',KAR).EQ.0) GOTO 54 IRK=1 ISTATE=8 NUM1=10*NUM1+INDEX('123456789',KAR) CALL PUTKAR (ELTEXT, KAR, JKAR) CALL GETKAR GOTO 52 54 IF (KAR.NE.'.') GOTO 56 ISTATE=7 ELTYPE='REAL' CALL PUTKAR (ELTEXT, KAR, JKAR) CALL GETKAR 56 JJ=-1 ! **** part after decimal point **** 57 IF (INDEX('0123456789',KAR).EQ.0) GOTO 58 IRK=1 ISTATE=6 RMANT = RMANT + DBLE(INDEX('123456789',KAR))*1.D1**JJ 20.05 JJ=JJ-1 CALL PUTKAR (ELTEXT, KAR, JKAR) CALL GETKAR GOTO 57 58 IF (ISTATE.GE.9 .OR. IRK.EQ.0) GOTO 120 ! **** exponent part **** IF (INDEX('DdEe^',KAR).EQ.0) GOTO 66 ISTATE=5 IRK=0 IF (ELTYPE.EQ.'INT') ELTYPE='REAL' CALL PUTKAR (ELTEXT, KAR, JKAR) CALL GETKAR IF (INDEX('+-',KAR).EQ.0) GOTO 62 IF (KAR.EQ.'-') ISIGN2=-1 ISTATE=4 CALL PUTKAR (ELTEXT, KAR, JKAR) CALL GETKAR 62 IF (INDEX('0123456789',KAR).EQ.0) GOTO 66 IRK=1 ISTATE=3 NUM2=10*NUM2+INDEX('123456789',KAR) CALL PUTKAR (ELTEXT, KAR, JKAR) CALL GETKAR GOTO 62 ! **** a number is put together **** 66 IF (IRK.EQ.0) GOTO 120 IF (INDEX('+-.',KAR).GE.1) ELTYPE='OTHR' ISTATE=2 IF (ITEST.GE.330) WRITE (PRINTF,699) ELTYPE, ISIGN1, NUM1, & RMANT, ISIGN2, NUM2 699 FORMAT (1X, A4, 2I6, F12.9, 2I6) IF (ELTYPE.EQ.'REAL') ELREAL = & ISIGN1*(DBLE(NUM1)+RMANT) * 1.D1**(ISIGN2*NUM2) 20.05 IF (ELTYPE.EQ.'INT') ELINT = ISIGN1*NUM1 LENCST = JKAR - 1 30.03 ! skip trailing blanks 67 IF (KAR.NE.' ' .AND. KAR.NE.TABC) GOTO 68 ISTATE=1 CALL GETKAR GOTO 67 ! If a * is encountered now, it is interpreted as a repetition factor. 68 IF (KAR.EQ.'*') THEN IF (ELTYPE.EQ.'INT' .AND. ELINT.GT.0) THEN NREP = ELINT ELINT = 0 CALL GETKAR GOTO 10 ELSE CALL MSGERR (2, 'Wrong repetition factor') CALL GETKAR GOTO 190 ENDIF ENDIF 69 IF (KAR.EQ.',') THEN CALL GETKAR GOTO 190 ENDIF IF (ISTATE.EQ.1) GOTO 190 IF (INDEX(' ;',KAR).NE.0 .OR. KAR.EQ.TABC) THEN GOTO 190 ENDIF ! number is not followed by , blank or tab; type is made OTHR: GOTO 120 ! ---------------------------------------------------------- ! a character string is read; it start and ends with a quote ! ---------------------------------------------------------- 80 IF (KAR.EQ.QUOTE) THEN 40.00 ELTYPE='CHAR' LENCST = 0 30.02 JJ=1 82 CALL GETKAR ! end of the string: end of record or closing quote IF (KARNR.GT.LINELN) GOTO 190 40.00 IF (KAR.EQ.QUOTE) THEN CALL GETKAR ! new character is not a quote; end of the string IF (KAR.NE.QUOTE) GOTO 88 ! double quote is read as a single quote; continue ENDIF ! put the character into ELTEXT 84 ELTEXT(JJ:JJ) = KAR LENCST = JJ JJ=JJ+1 GOTO 82 ! process characters behind the string 87 CALL GETKAR ! skip trailing blanks 88 IF (KAR.EQ.' ' .OR. KAR.EQ.TABC) GOTO 87 IF (KAR.NE.',') GOTO 190 CALL GETKAR GOTO 190 ENDIF ! ------------------------------------------------------- ! a keyword is read ! a keyword starts with a letter (upper or lower case) ! ------------------------------------------------------- 90 CALL UPCASE (KAR) IF (INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',KAR).GT.0) THEN 40.00 IF (NREP.GT.1) GOTO 28 ELTYPE='KEY' ISTATE=2 JJ=1 92 ELTEXT(JJ:JJ) = KAR LENCST = JJ 30.02 CALL GETKAR CALL UPCASE (KAR) JJ=JJ+1 ! next characters: letters, digits or - _ . IF (INDEX('ABCDEFGHIJKLMNOPQRSTUVWXYZ',KAR).GE.1) GOTO 92 IF (INDEX('0123456789-_.',KAR).GE.1) GOTO 92 ! keyword is read KEYWRD = ELTEXT(1:8) ! trailing blanks or tab char are skipped 94 IF (KAR.NE.' ' .AND. KAR.NE.TABC) GOTO 96 CALL GETKAR GOTO 94 ! closure character : or = is processed 96 IF (INDEX('=:',KAR).EQ.0) GOTO 190 CALL GETKAR GOTO 190 ENDIF ! -------------------------------------------------- ! continuation symbol is read ! -------------------------------------------------- 100 IF (INDEX('_&',KAR).EQ.0) GOTO 120 IF (NREP.GT.1) GOTO 28 110 KARNR=0 GOTO 12 ! -------------------------------------------------- ! other type of data ! -------------------------------------------------- 120 ELTYPE='OTHR' 122 ELTEXT(JKAR:JKAR) = KAR 30.04 LENCST = JKAR 30.02 JKAR=JKAR+1 CALL GETKAR IF (INDEX(' ,;', KAR).GE.1 .OR. KAR.EQ.TABC) GOTO 126 GOTO 122 126 CALL GETKAR ! 127 CALL MSGERR (3, 'Read error in: ') ! WRITE (PRINTF,129) ELTEXT ! 129 FORMAT (A) 40.00 ! RETURN ! -------------------------------------------------- ! test output and return to calling program ! -------------------------------------------------- 190 IF (ITEST.GE.120) WRITE (PRTEST, 199) KAR, KARNR, ELTYPE, ELREAL, & ELINT, NREP, ELTEXT(1:LENCST) 199 FORMAT (' test LEESEL: ', A1, 1X, I4, 1X, A4, D12.4, 2I6, 2X, A) 20.05 RETURN END !**************************************************************** ! * SUBROUTINE GETKAR ! * !**************************************************************** ! USE OCPCOMM1 40.41 USE OCPCOMM2 40.41 USE OCPCOMM3 40.41 USE OCPCOMM4 40.41 ! 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.13: Nico Booij ! 40.41: Marcel Zijlema ! ! 1. UPDATES ! ! 40.13, Jan. 2001: TRIM used to limit output ! 40.41, Oct. 04: common blocks replaced by modules, include files removed ! ! 2. PURPOSE ! ! This procedure reads a next character (KAR) from the string KAART. ! The position of this character in KAART is indicated by KARNR. ! If needed, a new input line is read. ! At the end of the input file ELTYPE is made 'EOF'. ! ! 3. METHOD ! ! 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, 'GETKAR') IF (KARNR.EQ.0) THEN READ (INPUTF, 7, END=20) KAART 7 FORMAT (A) 40.00 IF (ITEST.GE.-10) WRITE (PRINTF, 8) TRIM(KAART) 40.13 8 FORMAT (1X,A) 40.00 KARNR=1 ENDIF IF (KARNR.GT.LINELN) THEN 40.00 KAR=';' GOTO 90 ENDIF KAR = KAART(KARNR:KARNR) KARNR=KARNR+1 GOTO 90 ! end of file is encountered 20 ELTYPE='EOF' KAR='@' 90 IF (ITEST.GE.320) WRITE (PRINTF, 99) ELTYPE, KAR, KARNR 99 FORMAT (' Test GETKAR', 2X, A4, 2X, A1, I4) RETURN ! end of subroutine GETKAR END !**************************************************************** ! * SUBROUTINE PUTKAR (LTEXT, KARR, JKAR) ! * !**************************************************************** ! USE OCPCOMM1 40.41 USE OCPCOMM2 40.41 USE OCPCOMM3 40.41 USE OCPCOMM4 40.41 ! 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.41: Marcel Zijlema ! ! 1. UPDATES ! ! 40.41, Oct. 04: common blocks replaced by modules, include files removed ! ! 2. PURPOSE ! ! this procedure inserts a character (KARR) usually read by GETKAR ! into the string LTEXT, usually equal to ELTEXT, in the place ! JKAR. After this JKAR is increased by 1. ! ! 3. METHOD ! ! 4. ARGUMENT VARIABLES ! ! JKAR : counts the number of characters in a data field ! INTEGER JKAR ! ! LTEXT : a character string; after a number of calls it should ! contain the character representation of a data field ! KARR : character to be inserted into LTEXT ! CHARACTER LTEXT *(*), KARR *1 ! ! 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, 'PUTKAR') IF (JKAR.GT.LEN(LTEXT)) CALL MSGERR (2, 'PUTKAR, string too long') LTEXT(JKAR:JKAR) = KARR LENCST = JKAR JKAR = JKAR + 1 RETURN ! end of subroutine PUTKAR END !**************************************************************** ! * SUBROUTINE UPCASE (CHARST) ! * !**************************************************************** ! USE OCPCOMM1 40.41 USE OCPCOMM2 40.41 USE OCPCOMM3 40.41 USE OCPCOMM4 40.41 ! 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.41: Marcel Zijlema ! ! 1. UPDATES ! ! 40.41, Oct. 04: common blocks replaced by modules, include files removed ! ! 2. PURPOSE ! ! changes all characters of the string CHARST from lower to ! upper case ! ! 3. METHOD ! ! 4. ARGUMENT VARIABLES ! ! CHARST : a character string ! CHARACTER*(*) CHARST 40.31 ! ! 5. PARAMETER VARIABLES ! ! 6. LOCAL VARIABLES ! ! IC : sequence number of a character in the string CHARST ! IENT : Number of entries into this subroutine ! KK : position of a character in a given string ! LLCC : length of the given character string ! INTEGER IC, IENT, KK, LLCC ! ! ABCUP : A to Z upper case characters ! ABCLO : a to z lower case characters ! CC : a character ! CHARACTER ABCUP *26, ABCLO *26, CC *1 ! ! 8. SUBROUTINE USED ! ! 9. SUBROUTINES CALLING ! ! 10. ERROR MESSAGES ! ! 11. REMARKS ! ! 12. STRUCTURE ! ! 13. SOURCE TEXT ! SAVE IENT DATA IENT /0/ DATA ABCUP /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ DATA ABCLO /'abcdefghijklmnopqrstuvwxyz'/ CALL STRACE (IENT, 'UPCASE') ! LLCC = LEN (CHARST) DO 10 IC = 1, LLCC CC = CHARST(IC:IC) KK = INDEX (ABCLO, CC) IF (KK.NE.0) CHARST(IC:IC) = ABCUP(KK:KK) 10 CONTINUE RETURN ! end of subroutine UPCASE END !**************************************************************** ! * LOGICAL FUNCTION EQCSTR (STR1, STR2) ! * !**************************************************************** ! USE OCPCOMM1 40.41 USE OCPCOMM2 40.41 USE OCPCOMM3 40.41 USE OCPCOMM4 40.41 ! 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.41: Marcel Zijlema ! ! 1. UPDATES ! ! 40.41, Oct. 04: common blocks replaced by modules, include files removed ! ! 2. PURPOSE ! ! EQCSTR is assigned the value true if the two strings are the same ! (case-insensitive) ! ! 3. METHOD ! ! both strings are converted to upper case and then compared ! the length of string 2 gives the number of significant characters ! ! 4. ARGUMENT VARIABLES ! CHARACTER (LEN=*) :: STR1, STR2 ! two character strings to be compared ! ! 5. PARAMETER VARIABLES ! ! 6. LOCAL VARIABLES ! INTEGER, SAVE :: IENT = 0 ! IENT : Number of entries into this subroutine INTEGER :: IC, LLCC ! IC : sequence number of a character in the string ! LLCC : length of the given character string CHARACTER (LEN=1) :: CC1, CC2 ! a character, one from STR1 the other from STR2 ! ! 8. SUBROUTINE USED ! ! 9. SUBROUTINES CALLING ! ! 10. ERROR MESSAGES ! ! 11. REMARKS ! ! 12. STRUCTURE ! ! 13. SOURCE TEXT ! CALL STRACE (IENT, 'UPCASE') ! EQCSTR = .TRUE. LLCC = LEN (STR2) IF (LEN(STR1).LT.LLCC) THEN EQCSTR = .FALSE. GOTO 90 ENDIF DO IC = 1, LLCC CC1 = STR1(IC:IC) CALL UPCASE (CC1) CC2 = STR2(IC:IC) CALL UPCASE (CC2) IF (CC1.NE.CC2) THEN EQCSTR = .FALSE. GOTO 90 ENDIF ENDDO 90 RETURN END function EQCSTR !**************************************************************** ! * LOGICAL FUNCTION KEYWIS (STRING) ! * !**************************************************************** ! USE OCPCOMM1 40.41 USE OCPCOMM2 40.41 USE OCPCOMM3 40.41 USE OCPCOMM4 40.41 ! 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.41: Marcel Zijlema ! ! 1. UPDATES ! ! 40.00, July ! 40.41, Oct. 04: common blocks replaced by modules, include files removed ! ! 2. PURPOSE ! ! This procedure tests whether a keyword given by the user ! coincides with a keyword known in the program (i.e. string). ! if so, keywis is made .True., otherwise it is .False. ! also ELTYPE is made 'USED', so that next element can be read. ! ! 3. METHOD ! ! 4. ARGUMENT VARIABLES ! ! STRING : a keyword which is compared with a keyword found in the input file ! CHARACTER STRING *(*) ! ! 5. PARAMETER VARIABLES ! ! 6. LOCAL VARIABLES ! ! IENT : Number of entries into this subroutine ! J : counter ! LENSS : length of the keyword STRING ! INTEGER IENT, J, LENSS ! ! KAR1 : a character of the keyword appearing in the input file ! KAR2 : corresponding character in the STRING ! CHARACTER KAR1 *1, KAR2 *1 ! ! 8. SUBROUTINE USED ! ! 9. SUBROUTINES CALLING ! ! 10. ERROR MESSAGES ! ! 11. REMARKS ! ! 12. STRUCTURE ! ! 13. SOURCE TEXT ! SAVE IENT DATA IENT /0/ CALL STRACE (IENT, 'KEYWIS') ! KEYWIS = .FALSE. IF (ELTYPE.EQ.'USED') GOTO 30 ! KEYWIS=.TRUE. LENSS = LEN (STRING) DO 20 J=1, LENSS KAR1 = KEYWRD(J:J) KAR2 = STRING(J:J) IF (KAR1.NE.KAR2 .AND. KAR2.NE.' ') THEN 40.00 KEYWIS=.FALSE. GOTO 30 ENDIF 20 CONTINUE IF (ELTYPE.EQ.'KEY') ELTYPE = 'USED' 30 RETURN END !**************************************************************** ! * SUBROUTINE WRNKEY ! * !**************************************************************** ! USE OCPCOMM1 40.41 USE OCPCOMM2 40.41 USE OCPCOMM3 40.41 USE OCPCOMM4 40.41 ! 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.41: Marcel Zijlema ! ! 1. UPDATES ! ! 40.41, Oct. 04: common blocks replaced by modules, include files removed ! ! 2. PURPOSE ! ! THIS PROCEDURE PRODUCES AN ERROR MESSAGE ! IT IS CALLED IF AN ILLEGAL KEYWORD IS FOUND IN THE ! USER'S INPUT. IT MAKES ELTYPE = 'USED' ! ! 3. METHOD ! ! 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, 'WRNKEY') ! CALL MSGERR (2, 'Illegal keyword: '//KEYWRD) ELTYPE = 'USED' RETURN END !**************************************************************** ! * SUBROUTINE IGNORE (STRING) ! * !**************************************************************** ! USE OCPCOMM1 40.41 USE OCPCOMM2 40.41 USE OCPCOMM3 40.41 USE OCPCOMM4 40.41 ! 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.41: Marcel Zijlema ! ! 1. UPDATES ! ! 40.41, Oct. 04: common blocks replaced by modules, include files removed ! ! 2. PURPOSE ! ! This procedure calls subroutine INKEYW to read a keyword. ! if this keyword is equal to string, eltype is made 'USED'. ! it is used if a keyword can occur in the input which ! does not lead to any action. ! ! 3. METHOD ! ! 4. ARGUMENT VARIABLES ! ! STRING : keyword (if appearing in input file) that can be ignored ! CHARACTER STRING *(*) ! ! 5. PARAMETER VARIABLES ! ! 6. LOCAL VARIABLES ! ! IENT : Number of entries into this subroutine ! INTEGER IENT ! ! KEYWIS : logical function ! LOGICAL KEYWIS ! ! 8. SUBROUTINE USED ! ! 9. SUBROUTINES CALLING ! ! 10. ERROR MESSAGES ! ! 11. REMARKS ! ! 12. STRUCTURE ! ! 13. SOURCE TEXT ! SAVE IENT DATA IENT /0/ CALL STRACE (IENT, 'IGNORE') ! CALL INKEYW ('STA', 'XXXX') IF (KEYWIS(STRING)) RETURN IF (KEYWIS('XXXX')) RETURN IF (ITEST.GE.60) WRITE (PRINTF, 5) KEYWRD, ELTYPE 5 FORMAT (' NOT IGNORED: ', A, 2X, A) RETURN END