linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
fdc6b051c9e38d3b472a1dc574c3035709d292b1
sics/difrac/freefm.f
cvs fdc6b051c9 Initial revision
2000-02-07 10:38:55 +00:00

263 lines
8.5 KiB
Fortran
Raw Blame History

This file contains invisible Unicode characters
This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
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

Reference in New Issue View Git Blame Copy Permalink