C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS). Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details
SUBROUTINE FFISTR( LINE,MFIELD,IDCONT,NFIELD,KVALUE,CVALUE,IVALUE,
* RVALUE )
CHARACTER*(*) LINE,CVALUE(MFIELD)
CHARACTER*32 CFIELD
INTEGER KVALUE(MFIELD),IVALUE(MFIELD)
REAL RVALUE(MFIELD)
INTEGER TABC
TABC = 9
************************************************************************
C FREFLD INPUT SYSTEM - ANSI FORTRAN - USER INTERFACE ROUTINE
C DESCRIPTION:
C This routine is the main parsing routine of the SUPES Free Field
C Input system. It parses a CHARACTER string into data fields, and
C returns the CHARACTER, REAL, and INTEGER value for each field. A
C value which indicates whether the character and numeric values
C were explicitly defined by a valid string or simply set to a
C default blank or zero is also returned.
C FORMAL PARAMETERS:
C LINE CHARACTER Input string.
C MFIELD INTEGER Maximum number of data fields to be returned.
C IDCONT INTEGER Continuation flag ( 0 = NO continuation )
C NFIELD INTEGER Number of data fields found.
C KVALUE INTEGER Translation states of the data fields:
C -1 = This is a null field.
C 0 = This is a non-numeric field.
C 1 = This is a REAL numeric field.
C 2 = This is an INTEGER numeric field.
C CVALUE CHARACTER Character values of the data fields.
C RVALUE REAL Floating-point values of the data fields.
C IVALUE INTEGER Integer values of the data fields.
C ROUTINES CALLED:
C STRIPB Strip leading/trailing blanks from a string.
C EXUPCS Convert a string to ANSI FORTRAN character set.
C QUOTED Process a quoted string.
************************************************************************
C Initialize output arrays to their default values and zero field
C counter, unless IDCONT indicates that this is a continuation record.
IF ( IDCONT .EQ. 0 ) THEN
DO 300 I = 1 , MFIELD
KVALUE(I) = -1
CVALUE(I) = ' '
RVALUE(I) = 0.
IVALUE(I) = 0
300 CONTINUE
NFIELD = 0
END IF
IDCONT = 0
************************************************************************
C Isolate the effective portion of the input line. At the end
C of this phase LINE(ILEFT:ISTOP) will represent this portion.
C The continuation flag IDCONT will indicate whether or not a
C continuation line is to follow this record. Exit at any
C point where the effective portion of the line becomes null.
ILEFT = 1
ISTOP = LEN ( LINE )
C Now start processing fields.
C Upper range of loop is a dummy maximum.
c Had to fix more VAX FORTRAN specific stuff. We'll try this only
c for a short while. JRR.
DO 1 IFLD = 1, ISTOP
CALL STRIPB( LINE(ILEFT:ISTOP), IL, ISTOP )
ISTOP = ISTOP + ILEFT - 1
ILEFT = IL + ILEFT - 1
IF ( ILEFT .GT. ISTOP ) THEN
C Remainder of line is null.
RETURN
ELSE IF ( LINE(ILEFT:ILEFT) .EQ. '$' ) THEN
C Rest is comment.
RETURN
ELSE IF ( LINE(ILEFT:ILEFT) .EQ. '*' ) THEN
C Continuation.
IDCONT = 1
RETURN
ELSE IF ( LINE(ILEFT:ILEFT) .EQ. '''' ) THEN
C This is the beginning of a quoted string. Call a special handler.
CALL QUOTED ( LINE(ILEFT:ISTOP), IL, IRIGHT )
IF ( IRIGHT .NE. 0 ) IRIGHT = IRIGHT + ILEFT - 1
ILEFT = IL+ ILEFT - 1
ELSE IF ( INDEX ( ',=', LINE(ILEFT:ILEFT) ) .NE. 0 ) THEN
C This is a null field.
IRIGHT = 0
ELSE
C Find the end of this token.
C Valid delimiters, are ' ', '*', ',', '=', '$'.
IBLNK = INDEX ( LINE(ILEFT:ISTOP), ' ' ) + ILEFT - 2
IAST = INDEX ( LINE(ILEFT:ISTOP), '*' ) + ILEFT - 2
ICOMA = INDEX ( LINE(ILEFT:ISTOP), ',' ) + ILEFT - 2
IEQLS = INDEX ( LINE(ILEFT:ISTOP), '=' ) + ILEFT - 2
IDOLR = INDEX ( LINE(ILEFT:ISTOP), '$' ) + ILEFT - 2
ITAB = INDEX ( LINE(ILEFT:ISTOP), CHAR(TABC)) + ILEFT - 2
IF ( IBLNK .LT. ILEFT ) IBLNK = ISTOP + 1
IF ( IAST .LT. ILEFT ) IAST = ISTOP + 1
IF ( ICOMA .LT. ILEFT ) ICOMA = ISTOP + 1
IF ( IEQLS .LT. ILEFT ) IEQLS = ISTOP + 1
IF ( IDOLR .LT. ILEFT ) IDOLR = ISTOP + 1
IF ( ITAB .LT. ILEFT ) ITAB = ISTOP + 1
IRIGHT = MIN ( IBLNK, IAST, ICOMA, IEQLS, IDOLR,
$ ITAB, ISTOP )
C Convert data to standard character set -
CALL EXUPCS( LINE(ILEFT:IRIGHT) )
END IF
C Process this field.
C Don't process this field unless there is room in the data arrays -
NFIELD = NFIELD + 1
IF ( NFIELD .LE. MFIELD ) THEN
C Calculate the effective length of this field -
LFIELD = IRIGHT - ILEFT + 1
IF ( LFIELD .LE. 0 ) THEN
C This is a null field; skip it -
ELSE IF ( LFIELD .GT. 32 ) THEN
C This field exceeds the maximum allowable numeric
C field size; define only the character value -
CVALUE(NFIELD) = LINE(ILEFT:IRIGHT)
KVALUE(NFIELD) = 0
ELSE
C Define the character value for this field,
C then right-justify and attempt numeric translations -
CVALUE(NFIELD) = LINE(ILEFT:IRIGHT)
KVALUE(NFIELD) = 0
CFIELD = ' '
IJUST = 32 - LFIELD + 1
CFIELD(IJUST:32) = LINE(ILEFT:IRIGHT)
C See if a digit is present in this field.
C If there is no digit present, then do not accept
C this token as a valid real or integer value.
C This is needed, since some systems accept a token like
C "E", "Q", "INF", ... as a valid real number even though
C no digit appears in the token.
IF ( INDEX(CFIELD(IJUST:32),'0').NE.0 .OR.
1 INDEX(CFIELD(IJUST:32),'1').NE.0 .OR.
2 INDEX(CFIELD(IJUST:32),'2').NE.0 .OR.
3 INDEX(CFIELD(IJUST:32),'3').NE.0 .OR.
4 INDEX(CFIELD(IJUST:32),'4').NE.0 .OR.
5 INDEX(CFIELD(IJUST:32),'5').NE.0 .OR.
6 INDEX(CFIELD(IJUST:32),'6').NE.0 .OR.
7 INDEX(CFIELD(IJUST:32),'7').NE.0 .OR.
8 INDEX(CFIELD(IJUST:32),'8').NE.0 .OR.
9 INDEX(CFIELD(IJUST:32),'9').NE.0 ) THEN
C ... One more check. If the field contains a digit, but starts with
C 'D' or 'E', several systems will interpret this as a valid
C Integer and/or real number. This is not the desired behavior
IF (CFIELD(IJUST:IJUST) .NE. 'D' .AND.
& CFIELD(IJUST:IJUST) .NE. 'E') THEN
IDIG = 1
ELSE
IDIG = 0
END IF
ELSE
IDIG = 0
END IF
C ... It should not be necessary to initialize ITRANS, but the gcc-4.0.0 gfortran
C Does not correctly set ITRANS after the first execution if it is non-zero.
C It seems to work correctly if initialized to zero.
ITRANS = 0
READ( CFIELD,3000,IOSTAT=ITRANS ) RFIELD
IF ( IDIG .EQ. 1 .AND. ITRANS .EQ. 0 ) THEN
C This field has a valid floating-point value -
RVALUE(NFIELD) = RFIELD
KVALUE(NFIELD) = 1
END IF
READ( CFIELD,4000,IOSTAT=ITRANS ) IFIELD
IF ( IDIG .EQ. 1 .AND. ITRANS .EQ. 0 ) THEN
C This field has a valid integer value -
IVALUE(NFIELD) = IFIELD
KVALUE(NFIELD) = 2
ELSE IF ( KVALUE(NFIELD) .EQ. 1 .AND.
* ABS ( RVALUE(NFIELD) ) .LE. 1.E9 ) THEN
C This field has a valid real that did not automatically
C Translate to an integer. Try to convert the real to an
C integer.
IFIELD = RVALUE(NFIELD)
RFIELD = IFIELD
IF ( RFIELD .EQ. RVALUE(NFIELD) ) THEN
C Successful conversion of real to integer.
IVALUE(NFIELD) = IFIELD
KVALUE(NFIELD) = 2
END IF
END IF
END IF
END IF
C Remove any trailing delimiters before looping.
IF ( IRIGHT .GT. 0 ) ILEFT = MAX ( ILEFT, IRIGHT ) + 1
IF ( ILEFT .GT. ISTOP ) RETURN
CALL STRIPB( LINE(ILEFT:ISTOP), IL, ISTOP )
ISTOP = ISTOP + ILEFT - 1
ILEFT = IL + ILEFT - 1
IF ( ILEFT .GT. ISTOP ) RETURN
IF ( INDEX ( ',=', LINE(ILEFT:ILEFT) ) .NE. 0 )
* ILEFT = ILEFT + 1
IF ( ILEFT .GT. ISTOP ) RETURN
1 continue
c The end of the VAX FORTRAN DO Loop that I commented out. jrr.
c END DO
3000 FORMAT( F32.0 )
4000 FORMAT( I32 )
END