linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

PSI sics-cvs-psi_pre-ansto

Browse Source
This commit is contained in:
koennecke
2003-06-13 00:00:00 +00:00
committed by Douglas Clowes
parent 2e3ddfb6c6
commit 3ffd0d8af4
1099 changed files with 318432 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

262
difrac/freefm.f Normal file
View File

@@ -0,0 +1,262 @@
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