263 lines
8.5 KiB
Fortran
263 lines
8.5 KiB
Fortran
C-----------------------------------------------------------------------
|
|
C
|
|
C Free format numeric input routine for NRCVAX
|
|
C
|
|
C Routine to get 20 reals and 20 integers from free form input.
|
|
C The routine works in two stages from a character input string.
|
|
C First commas are removed from the string and substituted with blanks,
|
|
C redundant blanks are removed and only numeric characters allowed.
|
|
C The division / is retained and fractions are interpreted later.
|
|
C Second, the cleaned up string is interpreted to give the numbers.
|
|
C
|
|
C Normal input is from the terminal with IUNIT = ITR, but IUNIT can
|
|
C also be the unit number for a file.
|
|
C
|
|
C If IUNIT .GE. 1000 then it is assumed that the input string is
|
|
C already in OCHAR and no read is performed.
|
|
C
|
|
C If IUNIT .GE. 2000 no read is performed and IUNIT is returned as
|
|
C a 0 if no error or 1 if an error is detected.
|
|
C
|
|
C If the input unit is ITR (the terminal) and the first character is
|
|
C a question mark (?) the routine exits to the system monitor.
|
|
C
|
|
C The routine can also interpret fractions e.g 5/4 = 1.25 and E format
|
|
C
|
|
C-----------------------------------------------------------------------
|
|
SUBROUTINE FREEFM (IUNIT)
|
|
COMMON /IOUASS/ IOUNIT(12)
|
|
CHARACTER*100 COUT(20)
|
|
COMMON /IOUASC/ COUT
|
|
COMMON /INFREE/ IFREE(20),RFREE(20),ICFLAG
|
|
COMMON /FREECH/ OCHAR
|
|
CHARACTER OCHAR*100,NCHAR*100,LAST*1,THIS*1,COMMA*1,BLANK*1,
|
|
$ NUMS*17,CZERO*1
|
|
DATA COMMA/','/,BLANK/' '/,NUMS/' 0123456789.,+-/E'/,CZERO/'0'/
|
|
IZERO = ICHAR(CZERO)
|
|
ITR = IOUNIT(5)
|
|
ITP = IOUNIT(6)
|
|
IBYLEN = IOUNIT(12)
|
|
C-----------------------------------------------------------------------
|
|
C If IUNIT .lt. 1000 it is the input unit number
|
|
C If it is between 1000 and 2000 the string OCHAR has already been read
|
|
C and it is merely to be interpreted.
|
|
C If IUNIT .ge. 2000 an error flag may be returned in IUNIT.
|
|
C-----------------------------------------------------------------------
|
|
IF (IUNIT .LT. 1000) THEN
|
|
IREAD = IUNIT
|
|
ELSE
|
|
IERROR = 0
|
|
GO TO 105
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Read a character string. Only 80 for IBM terminals !!!
|
|
C-----------------------------------------------------------------------
|
|
100 IF (IUNIT .EQ. ITR) CALL GWRITE (ITP,'$')
|
|
OCHAR = ' '
|
|
IF (IREAD .EQ. ITR) THEN
|
|
CALL GETLIN (OCHAR)
|
|
ELSE
|
|
READ (IREAD,10000,END=250) OCHAR(1:80)
|
|
ENDIF
|
|
IF (IREAD .EQ. ITR .AND. OCHAR(1:1) .EQ. '?') STOP
|
|
C-----------------------------------------------------------------------
|
|
C Find the last non-blank character
|
|
C-----------------------------------------------------------------------
|
|
105 ICFLAG = 1
|
|
DO 110 I = 1,100
|
|
J = 101 - I
|
|
IF (OCHAR(J:J) .NE. BLANK) GO TO 120
|
|
110 CONTINUE
|
|
ICFLAG = 0
|
|
120 IF (OCHAR(J:J) .NE. COMMA) THEN
|
|
J = J + 1
|
|
OCHAR(J:J) = COMMA
|
|
ENDIF
|
|
LEN = J
|
|
C-----------------------------------------------------------------------
|
|
C Check for valid characters. 0 to 9 . , + - blank or E
|
|
C-----------------------------------------------------------------------
|
|
DO 140 I = 1,LEN
|
|
DO 130 J = 1,17
|
|
IF (OCHAR(I:I) .EQ. NUMS(J:J)) GO TO 140
|
|
130 CONTINUE
|
|
IF (IUNIT .GE. 2000) THEN
|
|
OCHAR(I:I) = BLANK
|
|
GO TO 140
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Get a corrected input string
|
|
C-----------------------------------------------------------------------
|
|
WRITE (COUT,11000)
|
|
GO TO 100
|
|
140 CONTINUE
|
|
C-----------------------------------------------------------------------
|
|
C Clean up the string
|
|
C-----------------------------------------------------------------------
|
|
NCHAR = ' '
|
|
LAST = COMMA
|
|
NNEW = 1
|
|
DO 150 NOLD = 1,LEN
|
|
THIS = OCHAR(NOLD:NOLD)
|
|
IF (THIS .EQ. '+') THEN
|
|
IF (LAST .NE. COMMA .AND. LAST .NE. BLANK) THEN
|
|
NCHAR(NNEW:NNEW) = BLANK
|
|
NNEW = NNEW + 1
|
|
ENDIF
|
|
GO TO 150
|
|
ENDIF
|
|
IF (THIS .EQ. '-') THEN
|
|
IF (LAST .NE. COMMA .AND. LAST .NE. BLANK) THEN
|
|
NCHAR(NNEW:NNEW) = BLANK
|
|
NNEW = NNEW + 1
|
|
ENDIF
|
|
NCHAR(NNEW:NNEW) = THIS
|
|
NNEW = NNEW + 1
|
|
GO TO 150
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Treat the case not a comma or blank
|
|
C-----------------------------------------------------------------------
|
|
IF (THIS .NE. BLANK .AND. THIS .NE. COMMA) THEN
|
|
NCHAR(NNEW:NNEW) = THIS
|
|
NNEW = NNEW + 1
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Treat the case of this character is a comma
|
|
C-----------------------------------------------------------------------
|
|
IF (THIS .EQ. COMMA) THEN
|
|
IF (LAST .EQ. COMMA .OR. LAST .EQ. BLANK) THEN
|
|
NCHAR(NNEW:NNEW) = '0'
|
|
NNEW = NNEW + 1
|
|
NCHAR(NNEW:NNEW) = BLANK
|
|
NNEW = NNEW + 1
|
|
ENDIF
|
|
IF (LAST .NE. COMMA .AND. LAST .NE. BLANK) THEN
|
|
NCHAR(NNEW:NNEW) = BLANK
|
|
NNEW = NNEW + 1
|
|
ENDIF
|
|
ENDIF
|
|
C-----------------------------------------------------------------------
|
|
C Treat the case of this character is a blank
|
|
C-----------------------------------------------------------------------
|
|
IF (THIS .EQ. BLANK) THEN
|
|
IF (LAST .NE. BLANK .AND. LAST .NE. COMMA) THEN
|
|
NCHAR(NNEW:NNEW) = BLANK
|
|
NNEW = NNEW + 1
|
|
ENDIF
|
|
ENDIF
|
|
LAST = THIS
|
|
150 CONTINUE
|
|
C-----------------------------------------------------------------------
|
|
C Now extract the 20 pairs of values
|
|
C-----------------------------------------------------------------------
|
|
DO 200 I = 1,20
|
|
IFREE(I) = 0
|
|
200 RFREE(I) = 0.0
|
|
IPT = 0
|
|
IFIELD = 0
|
|
IDIV = 0
|
|
210 ISIGN = 1
|
|
NUM = 0
|
|
DEC = 1.0
|
|
IDEC = 0
|
|
IC = 0
|
|
220 IPT = IPT + 1
|
|
IF (IPT .GT. NNEW) THEN
|
|
IF (IUNIT .GE. 2000) IUNIT = IERROR
|
|
RETURN
|
|
ENDIF
|
|
THIS = NCHAR(IPT:IPT)
|
|
IF (THIS .EQ. ' ') GO TO 230
|
|
IF (THIS .EQ. '/') THEN
|
|
IDIV = 1
|
|
GO TO 230
|
|
ENDIF
|
|
IF (THIS .EQ. 'E') THEN
|
|
IDIV = 3
|
|
GO TO 230
|
|
ENDIF
|
|
IF (THIS .EQ. '-') THEN
|
|
IF (IC .NE. 0) THEN
|
|
WRITE (COUT,12000)
|
|
IF (IUNIT .GE. 2000) GO TO 240
|
|
GO TO 100
|
|
ENDIF
|
|
ISIGN = -1
|
|
GO TO 220
|
|
ENDIF
|
|
IF (THIS .EQ. '.') THEN
|
|
IF (IDEC .EQ. 1) THEN
|
|
WRITE (COUT,13000)
|
|
IF (IUNIT .GE. 2000) GO TO 240
|
|
GO TO 100
|
|
ENDIF
|
|
IDEC = 1
|
|
GO TO 220
|
|
ENDIF
|
|
IC = ICHAR(THIS) - IZERO
|
|
NUM = 10*NUM + IC
|
|
IF (NUM .GT. 2147483647) THEN
|
|
WRITE (COUT,14000)
|
|
IF (IUNIT .GE. 2000) GO TO 240
|
|
GO TO 100
|
|
ENDIF
|
|
IF (IDEC .NE. 0) DEC = 10.0*DEC
|
|
GO TO 220
|
|
C-----------------------------------------------------------------------
|
|
C Work out the number and put it away
|
|
C-----------------------------------------------------------------------
|
|
230 NUM = ISIGN*NUM
|
|
RNUM = NUM/DEC
|
|
IF (IDIV .EQ. 1) THEN
|
|
TOP = NUM
|
|
IDIV = 2
|
|
GO TO 210
|
|
ENDIF
|
|
IF (IDIV .EQ. 2) THEN
|
|
BOT = NUM
|
|
RNUM = TOP/BOT
|
|
NUM = RNUM
|
|
IDIV = 0
|
|
ENDIF
|
|
IF (IDIV .EQ. 3) THEN
|
|
TOP = RNUM
|
|
IDIV = 4
|
|
GO TO 210
|
|
ENDIF
|
|
IF (IDIV .EQ. 4) THEN
|
|
BOT = 10.0**NUM
|
|
RNUM = TOP*BOT
|
|
IDIV = 0
|
|
ENDIF
|
|
IFIELD = IFIELD + 1
|
|
IFREE(IFIELD) = RNUM
|
|
IF (IDEC .EQ. 0) IFREE(IFIELD) = NUM
|
|
RFREE(IFIELD) = RNUM
|
|
GO TO 210
|
|
C-----------------------------------------------------------------------
|
|
C Set the error flag for REFIN calls
|
|
C-----------------------------------------------------------------------
|
|
240 WRITE (COUT,10000) OCHAR(1:LEN)
|
|
CALL GWRITE (ITP,' ')
|
|
IERROR = 1
|
|
IUNIT = IERROR
|
|
RETURN
|
|
250 CALL SETIOU (JUNK,JUNK,JUNK,ITR,ITP,IBYLEN)
|
|
IF (IREAD .EQ. ITR) THEN
|
|
OCHAR = ' '
|
|
REWIND IREAD
|
|
GO TO 105
|
|
ELSE
|
|
WRITE (COUT,15000) IREAD
|
|
CALL GWRITE (ITP,' ')
|
|
STOP
|
|
ENDIF
|
|
10000 FORMAT (A)
|
|
11000 FORMAT (' TYPO -- Numeric characters only. Try again please.')
|
|
12000 FORMAT (' TYPO -- Minus sign incorrect. Try again please.')
|
|
13000 FORMAT (' TYPO -- Too many decimal points. Try again please.')
|
|
14000 FORMAT (' TYPO -- Too many digits in number. Try again please.')
|
|
15000 FORMAT (' Unexpected EOF on Unit',I3,'. Job Aborted.'/'%')
|
|
END
|