home *** CD-ROM | disk | FTP | other *** search
/ RISC DISC 2 / RISC_DISC_2.iso / pd_share / program / fortran77_210 / library / f77 / artlib next >
Encoding:
Text File  |  1993-01-28  |  18.8 KB  |  640 lines
  1. *                      ARTLib Version 1.01 Date 28-Jan-1993
  2. *
  3. * Library of useful i/o routines from Alan Thawley 
  4. *   (phone +44(0)371 821009, fax +44(0)371 821323)
  5. * Copyright A.R. Thawley, 1993. These routines may be used and
  6. *   incorporated into other programs after compilation but the source
  7. *   code may not be sold or licensed without permission of the author.
  8. *
  9. * FLQUES    Asks for name of and opens input file
  10. * LENSTR    Returns length of filled portion of string
  11. * IDATE     Returns date and time in default string form
  12. * XYREAD    Read 'N' values into array 'X' then N values into array 'Y'
  13. * VAREAD    Read 'NOVAR' values into array 'X' and a possible string
  14. *             located at the 'NAMLOC' th position
  15. * SECNDS    Read in time and return it converted to seconds
  16. *
  17. * Version History
  18. *   1.0  Updated from VAX-based Fortran 66 to Fortran 77 on Acorn 
  19. *        Archimedes under Release 2 of Acorn Fortran 77 on an Acorn
  20. *        A5000 computer running RiscOS 3.1.              27-Jan-1993
  21. *
  22. *   1.01 Amended display of message reporting file opened in FLQUES.
  23. *                                                        28-Jan-1993
  24. *
  25. *      ---------------------------------------------------------------
  26. *
  27. *                          SUBROUTINE FLQUES
  28. *
  29. *      PURPOSE
  30. *        TO ASK NAME OF FILE TO BE ACCESSED AND TO OPEN THAT FILE
  31. *        IN READONLY MODE
  32. *
  33. *      AUTHOR
  34. *        A.R. THAWLEY
  35. *        8 THE COPSE, BANNISTER GREEN, FELSTED, ESSEX, ENGLAND CM6 3NP
  36. *
  37. *      ---------------------------------------------------------------
  38. *
  39.        SUBROUTINE FLQUES(ILUN,QUERY,CURDIR,FILNAM)
  40.        CHARACTER * (*) FILNAM, QUERY, CURDIR
  41.        CHARACTER * 80 INFILE, TESTR
  42.        CHARACTER * 3 ANS
  43.        CHARACTER * 1 YES, YSMALL, NO, NSMALL
  44.        INTEGER MAXLEN
  45.        PARAMETER (MAXLEN = 10)
  46.        DATA YES/'Y'/, YSMALL/'y'/, NO/'N'/, NSMALL/'n'/
  47. 100    PRINT *, QUERY
  48.        READ (*,1010) FILNAM
  49. 1010   FORMAT (A)
  50.        NOCHAR = LENSTR(FILNAM)
  51.        IF (NOCHAR .GT. 1 .AND. NOCHAR .LE. MAXLEN) GO TO 110
  52.        WRITE (*,1020) MAXLEN
  53. 1020   FORMAT (' ','Between 1 and ',I2,' letters needed. Try again!')
  54.        GO TO 100
  55. 110    IF (   (INDEX(FILNAM,':') .EQ. 0)
  56.      +   .OR. (INDEX(FILNAM,'.') .EQ. 0) ) THEN
  57.          INFILE = CURDIR(1:LENSTR(CURDIR)) // FILNAM(1:NOCHAR)
  58.        ELSE
  59.          INFILE = CURDIR(1:LENSTR(CURDIR))
  60.        ENDIF
  61.        OPEN (UNIT = ILUN, FILE = INFILE, STATUS = 'OLD', ERR=120)
  62.        READ (ILUN, 1010, ERR = 120, END = 120) TESTR
  63.        REWIND (ILUN)
  64.        WRITE (*,1040) INFILE, ILUN
  65. 1040   FORMAT (' File: ',A/' has been opened successfully'/
  66.      + ' It is being read now on LUN',I4/)
  67.        RETURN
  68. 120    WRITE (*,1050) FILNAM
  69. 1050   FORMAT (' ','Are you sure you have this file:  ',A/
  70.      + ' ','where you say it is?  If you want to enter it again'/
  71.      + ' ','type "Y", otherwise "N" ?'$)
  72.        READ (*,1060) ANS
  73. 1060   FORMAT (3A1)
  74.        IF (ANS(1:1) .EQ. YES .OR. ANS(1:1) .EQ. YSMALL) GO TO 100
  75.        IF (ANS(1:1) .NE. NO .OR. ANS(1:1) .EQ. NSMALL) GO TO 130
  76.        WRITE (*,1080)
  77. 1080   FORMAT (1H0,'Filename entry abandoned - STOPPING!')
  78.        STOP
  79. 130    WRITE (*,1070)
  80. 1070   FORMAT (' ','Try again.  The only answers allowed are',
  81.      + ' YES or NO!')
  82.        GO TO 120
  83.        END
  84. *      ---------------------------------------------------------------
  85. *
  86. *                       FUNCTION LENSTR(STRING)
  87. *
  88. * Determines length of string excluding any blank padding
  89. *
  90. * SOURCE
  91. *   "Problem Solving and Structured Programming in FORTRAN 77", 3rd edn,
  92. *   Elliot B. Koffman, Frank L. Friedman. Pub. Addison-Wesley, Reading, Mass.
  93. *   1987.
  94. *
  95. * INPUT ARGUMENTS
  96. *   STRING - string whose length is to be determined
  97. *
  98. * AUTHOR
  99. *   A.R. THAWLEY
  100. *   8 THE COPSE, BANNISTER GREEN, FELSTED, ESSEX, ENGLAND CM6 3NP
  101. *      ---------------------------------------------------------------
  102. *
  103.        INTEGER FUNCTION LENSTR(STRING)
  104.  
  105.         CHARACTER * (*) STRING
  106. *
  107. * Local declarations
  108. *
  109.         CHARACTER *1 BLANK
  110.         PARAMETER (BLANK = ' ')
  111.         INTEGER NEXT
  112. *
  113. * Start with the last character and find the first non-blank character
  114. *
  115.         DO 10 NEXT = LEN(STRING), 1, -1
  116.           IF (STRING(NEXT : NEXT) .NE. BLANK) THEN
  117.             LENSTR = NEXT
  118.             RETURN
  119.           ENDIF
  120. 10      CONTINUE
  121. *
  122. * All characters are blanks if this is reached
  123. *
  124.         LENSTR = 0
  125. *
  126.         RETURN
  127.         END
  128.  
  129. *      ---------------------------------------------------------------
  130. *                           SUBROUTINE IDATE
  131. *
  132. *      AUTHOR
  133. *        A.R. THAWLEY
  134. *        8 THE COPSE, BANNISTER GREEN, FELSTED, ESSEX, ENGLAND CM6 3NP
  135. *      ---------------------------------------------------------------
  136. *
  137.        SUBROUTINE IDATE(DATRES)
  138.        CHARACTER * (*) DATRES
  139.        INTEGER IBLOCK(8),IMAP
  140.        PARAMETER (IMAP = ?IFF)
  141.  
  142. *  String form as returned by the operating system
  143. *
  144.        IBLOCK(1) = 0
  145.        CALL OSWORD(14,IBLOCK)
  146. *
  147.        ICURR = 1
  148.        DO 100 I = 1,8
  149.          IVAR = IBLOCK(I)  
  150. *
  151.          NBITS = 0
  152.          DO 90 J = 1,4
  153.            ICHAR1 = ISHFT(IVAR,NBITS)
  154.            ICHAR1 = IAND(ICHAR1,IMAP)
  155.            DATRES(ICURR:ICURR) = CHAR(ICHAR1)
  156.            NBITS = NBITS - 8
  157.            ICURR = ICURR + 1
  158. 90       CONTINUE
  159. 100    CONTINUE
  160.        RETURN
  161.        END
  162. *      ---------------------------------------------------------------
  163. *
  164. *                        SUBROUTINE XYREAD
  165. *
  166. *      PURPOSE
  167. *        TO READ N X, Y VALUES INTO THE APPROPRIATE ARRAYS. VALUES
  168. *        MAY BE INTEGER OR DECIMAL BUT SINGLE PRECISION FLOATING POINT
  169. *        VALUES WILL BE RETURNED IN ARRAYS X AND Y.
  170. *
  171. *      USAGE
  172. *        CALL XYREAD(X,Y,N,INLUN,IERLUN,IERROR)
  173. *
  174. *      PARAMETERS
  175. *        X             VECTOR OF INDEPENDENT VARIABLE
  176. *        Y             VECTOR OF DEPENDENT VARIABLE
  177. *        N             LENGTH OF VECTORS X AND Y
  178. *        INLUN         INPUT LOGICAL CHANNEL NUMBER
  179. *        IERLUN        ERROR OUTPUT LOGICAL CHANNEL NUMBER
  180. *        IERROR        ERROR INDICATOR
  181. *                      = 1 FOR END OF FILE
  182. *                      = 2 FOR UNEXPECTED CHARACTERS
  183. *                      = 3 FOR MORE THAN 'N' X,Y VALUES FOUND
  184. *                      = 4 HARDWARE ERROR DURING FILE READ
  185. *
  186. *      METHOD
  187. *        READ N X VALUES AND THEN N Y VALUES INTO VECTORS X & Y
  188. *        BY READING LINES OF LENGTH UP TO 'LENLIN' FROM THE INPUT FILE
  189. *        AS A STRING WHICH IS THEN SCANNED FOR CHARACTERS DEFINING
  190. *        INTEGER OR FLOATING POINT FORMAT NUMBERS.
  191. *        NOTE: SCIENTIFIC FORMAT NUMBERS ARE NOT DECIPHERED.
  192. *        VALUES MAY BE ONE-PER-LINE OR AS MANY VALUES PER LINE AS WILL
  193. *        FIT SEPARATED BY COMMAS. TABS AND MULTIPLE SPACES WILL BE TREATED
  194. *        AS LINE TERMINATORS.
  195. *
  196. *      AUTHOR
  197. *        A.R. THAWLEY
  198. *        8 THE COPSE, BANNISTER GREEN, FELSTED, ESSEX, ENGLAND CM6 3NP
  199. *
  200. *      ---------------------------------------------------------------
  201. *
  202.        SUBROUTINE XYREAD(X,Y,N,INLUN,IERLUN,IERROR)
  203.        DIMENSION X(N), Y(N)
  204.        INTEGER LENLIN
  205.        PARAMETER (LENLIN = 250)
  206.        CHARACTER * 1 PLUS, MINUS, BLANK, COMMA, DECPNT, KAR
  207.        CHARACTER * 1 NULL, LINEI, LIN1P1, TAB
  208.        CHARACTER * 1 NUM(10)
  209.        CHARACTER * (LENLIN) LINE
  210.        LOGICAL LINEND
  211.        INTEGER INT, IFR, MAXINT
  212.        PARAMETER (MAXINT = 214748364)
  213.        PARAMETER (PLUS = '+', MINUS = '-', BLANK = ' ', COMMA = ',')
  214.        PARAMETER (DECPNT = '.')
  215.        DATA NUM /'0','1','2','3','4','5','6','7','8','9'/
  216.        NULL = CHAR(0)
  217.        TAB = CHAR(9)
  218.        IERROR = 0
  219.        NOTOT = 2 * N
  220.        NOVAR = 0
  221. *
  222. *  READ IN LINE
  223. *
  224. 100    READ (INLUN,1000,ERR=8025,END=8015) LINE
  225. 1000   FORMAT (A250)
  226.        NCHARS = LENSTR(LINE)
  227. *
  228. *      WRITE (*,9000) NCHARS
  229. *9000  FORMAT (1H0,'SUBR. XYREAD'/1H0,'NUMBER OF CHARACTERS = ',I4)
  230. *      WRITE (*, 9010) LINE
  231. *9010  FORMAT (1H ,'LINE 9010.  READ IN FOLLOWING LINE:'/1H0,A250)
  232. *
  233.        IF (NCHARS .EQ. 0) GO TO 100
  234.        KARCNT = 1
  235.        LINEND = .FALSE.
  236. 105    DO 120 I = KARCNT,NCHARS
  237.          LINEI = LINE(I:I)
  238. *
  239. *  LOOK FOR COMMA, NULLS, BLANKS OR TABS AT END OF LINE
  240. *
  241. *      WRITE (*,9020) I, LINEI, ICHAR(LINEI)
  242. *9020  FORMAT (1H ,I4,'TH CHARACTER IS: "',A1,'"!  ASCII = ',I4)
  243. *
  244.          IF (LINEI .NE. BLANK .AND. LINEI .NE. NULL .AND.
  245.      +         LINEI .NE. TAB) GO TO 110
  246. *
  247. *      WRITE (*,9030)
  248. *9030  FORMAT (1H ,'MUST BE A BLANK, NULL OR A TAB TO REACH HERE!')
  249. *
  250.          IF (I .EQ. KARCNT) GO TO 100
  251. *
  252. *  NO MORE CHARACTERS IN LINE?
  253. *
  254.          LINEND = .TRUE.
  255.          IF (I .EQ. NCHARS .OR. LINEI .EQ. TAB) GO TO 125
  256.          LIN1P1 = LINE(I+1:I+1)
  257.          IF (LIN1P1 .EQ. BLANK .OR. LIN1P1 .EQ. NULL .OR.
  258.      +         LIN1P1 .EQ. TAB) GO TO 125
  259. 110      IF (LINEI .EQ. COMMA) GO TO 125
  260. 120    CONTINUE
  261. *
  262. *  CHECK FOR SIGN
  263. *
  264. 125    SIGNAL = 1.0
  265.        LINEI = LINE(KARCNT:KARCNT)
  266.        IF (LINEI .EQ. PLUS) GO TO 130
  267.        IF (LINEI .NE. MINUS) GO TO 140
  268.        SIGNAL = -1.0
  269. 130    KARCNT = KARCNT + 1
  270. *
  271. *  WHEN COMMA FOUND SET VALUE INTO X OR Y
  272. *
  273. 140    INT = 0.0
  274.        IFR = 0.0
  275.        IFRCNT = 0
  276.        DO 170 J = KARCNT, I - 1
  277.          KAR = LINE(J:J)
  278.          IF (KAR .EQ. DECPNT) GO TO 180
  279.          DO 150 K = 1,10
  280.            IF (KAR .EQ. NUM(K)) GO TO 160
  281. 150      CONTINUE
  282. *
  283. *  ERROR IN INTEGER PART, PRINT OUT OFFENDING LINE
  284. *
  285.          IERROR = 2
  286.          WRITE (IERLUN,1010) LINE
  287.          WRITE (*,1010) LINE
  288. 1010   FORMAT (1H0,'THIS LINE CONTAINS NON-NUMERIC CHARACTER(S)'/
  289.      +     1H ,A250)
  290.          RETURN
  291. 160      INT = 10 * INT + (K - 1)
  292. *
  293. * REAL (FLOATING POINT) VERSION OF 160 IS:
  294. *      INT = AINT(INT * 10.0 + FLOAT(K - 1))
  295. *
  296. *
  297. *  CHECK FOR OVERFLOW
  298. *
  299.          IF (INT .GT. MAXINT) GO TO 8000
  300. 170    CONTINUE
  301. *
  302. *  DECODE FRACTIONAL PART OF NUMBER
  303. *
  304. 180    KARCNT = J + 1
  305.        IF (KARCNT .GE. I) GO TO 215
  306.        DO 210 J = KARCNT, I - 1
  307.          KAR = LINE(J:J)
  308.          DO 190 K = 1,10
  309.            IF (KAR .EQ. NUM(K)) GO TO 200
  310. 190      CONTINUE
  311. *
  312. *  ERROR IN FRACTIONAL PART OF NUMBER, PRINT OUT OFFENDING LINE
  313. *
  314.          IERROR = 2
  315.          WRITE (IERLUN,1010) LINE
  316.          WRITE (*,1010) LINE
  317.          RETURN
  318. 200      IFR = 10 * IFR + (K - 1)
  319. *
  320. * REAL (FLOATING POINT) VERSION OF 200 IS:
  321. *      IFR = AINT(IFR * 10.0 + FLOAT(K - 1))
  322. *
  323. *
  324. *  CHECK FOR OVERFLOW
  325. *
  326. *      WRITE (*,9060) INT, IFR
  327. *9060  FORMAT (1H ,'AT PRESENT INT = ',I8,', IFR = ',I8)
  328. *
  329.          IF (IFR .GT. MAXINT) GO TO 8000
  330.          IFRCNT = IFRCNT + 1
  331. 210    CONTINUE
  332. 215    NOVAR = NOVAR + 1
  333.        IF (NOVAR .LE. NOTOT) GO TO 218
  334.        WRITE (IERLUN,1020) N
  335.        WRITE (*,1020) N
  336. 1020   FORMAT (1H0,'THERE ARE MORE THAN ',I4,
  337.      + ' POINTS IN THIS BATCH.  CONTINUING:')
  338.        RETURN
  339. 218    TEMP = SIGN((FLOAT(INT) + (FLOAT(IFR)/(10.0 ** IFRCNT))),SIGNAL)
  340. *
  341. * REAL (FLOATING POINT) VERSION OF 218 IS:
  342. *      TEMP = SIGN((INT + (IFR(10.0 ** IFRCNT))),SIGNAL)
  343. *
  344.        IF (NOVAR .GT. N) GO TO 220
  345.        X(NOVAR) = TEMP
  346.        GO TO 225
  347. 220    Y(NOVAR - N) = TEMP
  348. 225    KARCNT = I + 1
  349.        IF (NOVAR .EQ. NOTOT) RETURN
  350.        IF (LINEND .OR. KARCNT .GT. NCHARS) GO TO 100
  351.        GO TO 105
  352. *
  353. *  FATAL ERROR SINCE TOO MANY DIGITS IN THE INTEGER OR FRACTIONAL
  354. *  PART OF ONE OF THE NUMBERS IN THE LINE
  355. *
  356. 8000   WRITE (IERLUN,8010) LINE
  357.        WRITE (*,8010) LINE
  358. 8010   FORMAT (1H0,'THIS LINE CONTAINS NUMBERS WITH TOO MANY DIGITS:'/
  359.      + 1H ,A250/
  360.      + 1H0,'FATAL ERROR IN SUBR. XYREAD. CORRECT DATA AND START AGAIN')
  361.        CLOSE (UNIT=INLUN)
  362.        CLOSE (UNIT=IERLUN)
  363.        STOP
  364. *
  365. *  NON-FATAL ERROR MESSAGES
  366. *
  367. *
  368. *  RETURN WITH END OF FILE:  ERROR FLAG = 1
  369. *
  370. 8015   IERROR = 1
  371.        RETURN
  372. *
  373. *  RETURN WITH ERROR DURING FILE READ:  ERROR FLAG = 4
  374. *
  375. 8025   IERROR = 4
  376.        RETURN
  377.        END
  378. *      ---------------------------------------------------------------
  379. *
  380. *                      SUBROUTINE VAREAD
  381. *
  382. *      PURPOSE
  383. *        TO READ NOVAR VALUES INTO THE ARRAY X. VALUES MAY BE
  384. *        INTEGER OR DECIMAL BUT SINGLE PRECISION FLOATING POINT
  385. *        VALUES WILL BE RETURNED IN ARRAY X, TOGETHER WITH THE NUMBER
  386. *        OF VALUES FOUND IN INTEGER VARIABLE NOVAR.
  387. *
  388. *      USAGE
  389. *        CALL VAREAD(X,NAME,NOVAR,NAMLOC,INLUN,IERLUN,IERROR)
  390. *
  391. *      PARAMETERS
  392. *        X             VECTOR OF NOVAR VARIABLES
  393. *        NAME          RETURNED CHARACTER VARIABLE FOR A FORMAT GROUP
  394. *                        OF UP TO 'MAXNAM' CHARACTERS
  395. *                        WHERE (MAXNAM = LENGTH OF NAME)
  396. *        NOVAR         NUMBER OF VARIABLES FOUND
  397. *        NAMLOC        POSITION OF EXPECTED 'A' FORMAT GROUP
  398. *                      (MAXIMUM OF 'MAXNAM' CHARACTERS BEFORE A COMMA)
  399. *        INLUN         INPUT LOGICAL UNIT NUMBER
  400. *        IERLUN        ERROR OUTPUT LOGICAL UNIT NUMBER
  401. *        IERROR        ERROR INDICATOR
  402. *                      = 1 FOR END OF FILE
  403. *                      = 2 FOR UNEXPECTED CHARACTERS
  404. *                      = 3  - NOT USED
  405. *                      = 4 HARDWARE ERROR DURING FILE READ
  406. *
  407. *      METHOD
  408. *        READ LINE AND ASSIGN VALUES TO VARIABLES FOUND
  409. *        VALUES MUST BE SEPARATED BY COMMAS.
  410. *        TABS AND MULTIPLE SPACES WILL BE TREATED AS LINE TERMINATORS.
  411. *
  412. *      AUTHOR
  413. *        A.R. THAWLEY
  414. *        8 THE COPSE, BANNISTER GREEN, FELSTED, ESSEX, ENGLAND CM6 3NP
  415. *      ---------------------------------------------------------------
  416. *
  417.        SUBROUTINE VAREAD(X,NAME,NOVAR,NAMLOC,INLUN,IERLUN,IERROR)
  418.        DIMENSION  X(*)
  419.        INTEGER LENLIN, MAXNAM, NAMLOC, INLUN, IERLUN, IERROR
  420.        PARAMETER (LENLIN = 250)
  421.        CHARACTER * 1 PLUS, MINUS, BLANK, COMMA, DECPNT, KAR
  422.        CHARACTER * 1 NULL, LINEI, LIN1P1, TAB
  423.        CHARACTER * 1 NUM(10)
  424.        CHARACTER * (LENLIN) LINE
  425.        CHARACTER * (*) NAME
  426.        LOGICAL LINEND
  427.        INTEGER INT, IFR, MAXINT
  428.        PARAMETER (MAXINT = 214748364)
  429.        PARAMETER (PLUS = '+', MINUS = '-', BLANK = ' ', COMMA = ',')
  430.        PARAMETER (DECPNT = '.')
  431.        DATA NUM /'0','1','2','3','4','5','6','7','8','9'/
  432.        NULL = CHAR(0)
  433.        TAB = CHAR(9)
  434.        MAXNO = LENLIN/2
  435.        MAXNAM = LEN(NAME)
  436.        IERROR = 0
  437.        NOVAR = 0
  438.        L = NAMLOC
  439. *
  440. *  READ IN LINE
  441. *
  442. 100    READ (INLUN,1000,ERR=8025,END=8015) LINE
  443. 1000   FORMAT (A250)
  444.        NCHARS = LENSTR(LINE)
  445. *
  446. *       WRITE (IERLUN,9000) NCHARS
  447. *       WRITE (*,9000) NCHARS
  448. *9000   FORMAT (1H ,'SUBROUTINE VAREAD'/1H0,'NUMBER OF CHARS = ',I4)
  449. *       WRITE (IERLUN,9005) NOVAR, NAMLOC
  450. *       WRITE (*,9005) NOVAR, NAMLOC
  451. *9005   FORMAT (1H ,'NOVAR = ',I4,', NAMLOC = ',I4) 
  452. *       WRITE (IERLUN,9010) LINE
  453. *       WRITE (*,9010) LINE
  454. *9010   FORMAT (1H ,'LINE 9010.  READ IN THE FOLLOWING LINE:'/1H0,A250)
  455. *
  456.        IF (NCHARS .EQ. 0) GO TO 100
  457.        KARCNT = 1
  458.        LINEND = .FALSE.
  459. 105    DO 120 I = KARCNT,NCHARS
  460.          LINEI = LINE(I:I)
  461. *
  462. *  LOOK FOR COMMA, NULLS, BLANKS OR TABS AT END OF LINE
  463. *
  464. *        WRITE (IERLUN,9020) I, LINEI, ICHAR(LINEI)
  465. *        WRITE (*,9020) I, LINEI, ICHAR(LINEI)
  466. *9020  FORMAT (1H ,I4,'TH CHARACTER IS: ',A1,'!  ASCII = ',I4)
  467. *
  468.          IF (LINEI .NE. BLANK .AND. LINEI .NE. NULL .AND. 
  469.      +         LINEI .NE. TAB) GO TO 110
  470. *
  471. *        WRITE (IERLUN,9030)
  472. *        WRITE (*,9030)
  473. *9030  FORMAT (1H ,'MUST BE A NULL, BLANK OR TAB TO REACH HERE'
  474. *     + 1H ,' (LINE 9030)')
  475. *
  476.          IF (NOVAR .EQ. L-1) GO TO 110
  477. *
  478. *         IF (I .EQ. 1) GO TO 100
  479. *
  480. *  NO MORE CHARACTERS IN LINE
  481. *
  482.          IF (I .EQ. KARCNT) RETURN
  483.          LINEND = .TRUE.
  484.          IF (I .EQ. NCHARS .OR. LINEI .EQ. TAB) GO TO 125
  485.          LIN1P1 = LINE(I+1:I+1)
  486.          IF (LIN1P1 .EQ. BLANK .OR. LIN1P1 .EQ. NULL .OR.
  487.      +         LIN1P1 .EQ. TAB) GO TO 125
  488. 110      IF (LINEI .EQ. COMMA) GO TO 125
  489. 120    CONTINUE
  490. *
  491. *  CHECK FOR SIGN
  492. *
  493. 125    IF (NOVAR .EQ. L-1) GO TO 220
  494.        SIGNAL = 1.0
  495.        LINEI = LINE(KARCNT:KARCNT)
  496.        IF (LINEI .EQ. PLUS) GO TO 130
  497.        IF (LINEI .NE. MINUS) GO TO 140
  498.        SIGNAL = -1.0
  499. 130    KARCNT = KARCNT + 1
  500. *
  501. *  WHEN COMMA FOUND SET VALUE INTO X
  502. *
  503. 140    INT = 0.0
  504.        IFR = 0.0
  505.        IFRCNT = 0
  506.        DO 170 J = KARCNT, I - 1
  507.          KAR = LINE(J:J)
  508.          IF (KAR .EQ. DECPNT) GO TO 180
  509.          DO 150 K = 1,10
  510.            IF (KAR .EQ. NUM(K)) GO TO 160
  511. 150      CONTINUE
  512. *
  513. *  ERROR, PRINT OUT OFFENDING LINE
  514. *
  515.          IERROR = 2
  516.          WRITE (IERLUN,1010) LINE
  517.          WRITE (*,1010) LINE
  518. 1010   FORMAT (1H0,
  519.      + 'THIS LINE CONTAINS UNEXPECTED NON-NUMERIC CHARACTER(S)'/
  520.      + 1H ,A250)
  521.          RETURN
  522. 160      INT = 10 * INT + (K - 1)
  523. *
  524. * REAL (FLOATING POINT) VERSION OF 160 IS:
  525. *      INT = AINT(INT * 10.0 + FLOAT(K - 1))
  526. *
  527. *
  528. *  CHECK FOR OVERFLOW
  529. *
  530.          IF (INT .GT. MAXINT) GO TO 8000
  531. 170    CONTINUE
  532. *
  533. *  DECODE FRACTIONAL PART OF NUMBER
  534. *
  535. 180    KARCNT = J + 1
  536.        IF (KARCNT .GE. I) GO TO 215
  537.        DO 210 J = KARCNT, I - 1
  538.          KAR = LINE(J:J)
  539.          DO 190 K = 1,10
  540.            IF (KAR .EQ. NUM(K)) GO TO 200
  541. 190      CONTINUE
  542.          IERROR = 2
  543.          WRITE (IERLUN,1010) LINE
  544.          WRITE (*,1010) LINE
  545.          RETURN
  546. 200      IFR = 10 * IFR + (K - 1)
  547. *
  548. * REAL (FLOATING POINT) VERSION OF 200 IS:
  549. *      IFR = AINT(IFR * 10.0 + FLOAT(K - 1))
  550. *
  551. *
  552. *  CHECK FOR OVERFLOW
  553. *
  554.          IF (IFR .GT. MAXINT) GO TO 8000
  555.          IFRCNT = IFRCNT + 1
  556. 210    CONTINUE
  557. 215    NOVAR = NOVAR + 1
  558.        IF (NOVAR .LE. MAXNO) GO TO 218
  559.        WRITE (IERLUN,1030) MAXNO
  560. 1030   FORMAT (1H0,'THE MAXIMUM NUMBER OF NUMERIC VALUES ABLE TO BE',
  561.      + ' RETURNED TO THE CALLING PROGRAM BY SUBROUTINE VAREAD,'/
  562.      + 1H ,'I.E. ',I4,
  563.      + ', HAS BEEN EXCEEDED - CONTINUING WITHOUT ERROR RETURN.')
  564. 218    X(NOVAR) = 
  565.      +   SIGN((FLOAT(INT) + (FLOAT(IFR)/(10. ** IFRCNT))),SIGNAL)
  566. *
  567. * REAL (FLOATING POINT) VERSION OF 218 IS:
  568. *    X(NOVAR) = SIGN((INT + IFR/(10. ** IFRCNT)),SIGNAL)
  569. *
  570.        GO TO 226
  571. *
  572. *  PACK CHARACTERS INTO AN 'MAXNAM' CHARACTER VECTOR, NAME, WHICH
  573. *  WILL BE RETURNED AS A CHARACTER VARIABLE
  574. *
  575. 220    JJ = 0
  576.        DO 230 J = KARCNT,I-1
  577.          JJ = JJ + 1
  578.          IF (JJ .GT. MAXNAM) GO TO 225
  579.          NAME(JJ:JJ) = LINE(J:J)
  580. 230    CONTINUE
  581.        IF (JJ .GE. MAXNAM) GO TO 225
  582. *
  583. *  PACK 'NAME' WITH SPACES
  584. *
  585.        DO 240 K = JJ+1,MAXNAM
  586.          NAME(K:K) = BLANK
  587. 240    CONTINUE
  588. *
  589. *  RESET L SO THAT TEST TO SEE IF PRESENT VARIABLE (NOVAR) POSITION
  590. *  IS THAT OF ALPHANUMERIC WILL ALWAYS FAIL
  591. *
  592. 225    L = L - 1
  593. 226    KARCNT = I + 1
  594.        IF (KARCNT .GT. NCHARS) RETURN
  595.        IF (LINEND) RETURN
  596.        GO TO 105
  597. *
  598. *  FATAL ERROR SINCE TOO MANY DIGITS IN THE INTEGER OR FRACTIONAL
  599. *  PART OF ONE OF THE NUMBERS IN THE LINE
  600. *
  601. 8000   WRITE (IERLUN,8010) LINE
  602. 8010   FORMAT (1H0,
  603.      + 'THIS LINE CONTAINS NUMBER(S) WITH TOO MANY DIGITS: '/
  604.      + 1H ,A250/
  605.      + 1H0,'FATAL ERROR IN SUBR. VAREAD.  ',
  606.      + 'CORRECT DATA AND START AGAIN!')
  607.        CLOSE (UNIT=INLUN)
  608.        CLOSE (UNIT=IERLUN)
  609.        STOP
  610. *
  611. *  RETURN WITH END OF FILE:  ERROR FLAG = 1
  612. *
  613. 8015   IERROR = 1
  614.        RETURN
  615. *
  616. *  RETURN WITH ERROR DURING FILE READ:  ERROR FLAG = 4
  617. *
  618. 8025   IERROR = 4
  619.        RETURN
  620.        END
  621. *      ---------------------------------------------------------------
  622. *
  623. *                        FUNCTION SECNDS
  624. *
  625. *  PURPOSE
  626. *    TO READ IN TIMER AND RETURN IT CONVERTED TO SECONDS
  627. *
  628. *      AUTHOR
  629. *        A.R. THAWLEY
  630. *        8 THE COPSE, BANNISTER GREEN, FELSTED, ESSEX, ENGLAND CM6 3NP
  631. *
  632. *      ---------------------------------------------------------------
  633. *
  634.        REAL FUNCTION SECNDS()
  635.        INTEGER TIME(0:1)
  636.        CALL OSWORD(1, TIME)
  637.        TEMP = TIME(0)
  638.        SECNDS = TEMP/100.0
  639.        END
  640.