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