DOUBLE PRECISION FREAD 0020 DIMENSION IA(80),X(200),IX(200) 0030 DATA IAST/'*'/ 0040 DATA ICOL/81/ 0050 C 0060 C ...COMPLETE DATA DECK READ 3 TIMES (PROVIDE 3 COPIES) 0070 C READ AND PRINT DATA DECK OF 10 CARDS IN 'A' FORMAT 0080 C 0090 PRINT 10 0100 10 FORMAT(1H1) 0110 DO 100 I=1,10 0120 READ 20,(IA(L),L=1,80) 0130 20 FORMAT(80A1) 0140 PRINT 30,(IA(L),L=1,80) 0150 30 FORMAT(10X,80A1) 0160 100 CONTINUE 0170 C 0180 C ...ATTEMPT ILLEGAL REREAD 0190 C 0200 XX=FREAD(3,IOUT,ICOL) 0210 C 0220 C ...READ AND PRINT DATA DECK USING FREAD(2,IOUT,ICOL) 0230 C 0240 PRINT 10 0250 DO 200 I=1,200 0260 X(I)=FREAD(2,IOUT,ICOL) 0270 IF(IOUT.EQ.IAST) GOTO 250 0280 PRINT 150,X(I),IOUT 0290 150 FORMAT(50X,E20.10,A5) 0300 200 CONTINUE 0310 250 CONTINUE 0320 C 0330 C ...REREAD LAST CARD USING FREAD(0,IOUT,ICOL) 0340 C 0350 ICOL=1 0360 255 XX=FREAD(0,IOUT,ICOL) 0370 IF(IOUT.EQ.IAST) GOTO 260 0380 PRINT 150,XX,IOUT 0390 GOTO 255 0400 C 0410 C ...SKIP TO END OF THIS CARD, AND ALL OF NEXT CARD 0420 C 0430 260 ICOL=81 0440 SKIP=FREAD(0,IOUT,ICOL) 0450 ICOL=81 0460 C 0470 C ...READ AND PRINT DATA DECK AS INTEGER VARIABLE, USING 0480 C FREAD(2,IOUT,ICOL) 0490 C 0500 PRINT 10 0510 DO 300 I=1,200 0520 IX(I)=FREAD(2,IOUT,ICOL) 0530 IF(IOUT.EQ.IAST) GOTO 350 0540 PRINT 275,IX(I),IOUT 0550 275 FORMAT(50X,I20,A5) 0560 300 CONTINUE 0570 C 0580 C ...CARRY ON REREADING USING FREAD(1,IOUT,ICOL) AND 0590 C REREAD USING FREAD(3,IOUT,ICOL) 0600 C 0610 350 XX=FREAD(1,IOUT,ICOL) 0620 PRINT 150,XX,IOUT 0630 XX=FREAD(3,IOUT,ICOL) 0640 PRINT 150,XX,IOUT 0650 IF(IOUT.NE.IAST) GOTO 350 0660 RETURN 0670 END 0680 C*********************************************************************** 0690 C* * 0700 C* ******* * 0710 C* *FREAD* * 0720 C* ******* * 0730 C* * 0740 C* FUNCTION FOR READING FROM CARDS FORMAT FREE * 0750 C* * 0760 C* R.L.PARKER (SEE BEDFORD INSTITUTE COMPUTER * 0770 C* NOTE 1969-8-C FOR DETAILS) * 0780 C* * 0790 C* MODIFICATIONS BY D.E.WELLS UNB JAN 1971 * 0800 C* * 0810 C* *********** * 0820 C* *ARGUMENTS* * 0830 C* *********** * 0840 C* * 0850 C* INPUT IN =0 NO PRINT * 0860 C* =1 PRINT MESSAGE AND BAD NUMBERS ONLY * 0870 C* =2 PRINT ALL * 0880 C* =3 REREAD LAST NUMBER AND PRINT * 0890 C* * 0900 C* OUTPUT IOUT=0 IF SUCCESSFUL READ * 0910 C* = FIRST BAD CHARACTER IF ERROR HIT * 0920 C* * 0930 C* COLUMN COUNTER ICOL AVAILABLE AS ARGUMENT * 0940 C* USUALLY LEFT UNTOUCHED BY USER * 0950 C* HOWEVER FOR FLEXIBILITY IT CAN BE SET WHEN FUNCTION CALLED * 0960 C* ICOL=81 WILL SKIP TO END OF CURRENT CARD * 0970 C* ICOL.LT.81 WILL SKIP BACK OR FORWARD TO THAT COLUMN * 0980 C* * 0990 C* ************************ * 1000 C* *POSSIBLE MODIFICATIONS* * 1010 C* ************************ * 1020 C* * 1030 C* IF 'IN' NOT REQUIRED - * 1040 C* DROP FROM PARAMETER LISTS IN FUNCTION STATEMENT AND IN ALL * 1050 C* CALLING STATEMENTS * 1060 C* INITIALIZE TO DESIRED VALUE ( 0 1 2 OR 3) USING EITHER * 1070 C* DATA STATEMENT ( E.G. 'DATA IN/1/ ' ) OR * 1080 C* REPLACEMENT STATEMENT (E.G. 'IN=2 ' ) * 1090 C* * 1100 C* IF ' IOUT' NOT REQUIRED - * 1110 C* DROP FROM PARAMETER LISTS IN FUNCTION STATEMENT AND IN ALL * 1120 C* CALLING STATEMENTS * 1130 C* * 1140 C* IF 'ICOL' NOT REQUIRED - * 1150 C* DROP FROM PARAMETER LISTS IN FUNCTION STATEMENT AND IN ALL * 1160 C* CALLING STATEMENTS * 1170 C* INITIALIZE TO 81 USING DATA STATEMENT ( DATA ICOL/81/ ) * 1180 C* * 1190 C* NB - FORTRAN FUNCTIONS MUST HAVE AT LEAST ONE ARGUMENT * 1200 C* * 1210 C* IF DOUBLE PRECISION DATA EXPECTED (MORE THAN SEVEN DIGITS) - * 1220 C* ADD TO BOTH FUNCTION AND TO CALLING PROGRAM THE STATEMENT * 1230 C* ' DOUBLE PRECISION FREAD ' * 1240 C* * 1250 C*********************************************************************** 1260 FUNCTION FREAD(IN,IOUT,ICOL) 1270 DOUBLE PRECISION FREAD 1280 DOUBLE PRECISION X,XX,B 1290 DIMENSION IA(80),IDIGIT(17) 1300 DATA IDIGIT/1H0,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9, 1310 1 1H ,1H, ,1H.,1HE,1HD,1H-,1H+/ 1320 DATA IE/3/ 1330 C 1340 C ...TEST FOR REREAD MODE (IN=3) 1350 C 1360 IF(IN.GE.3) GOTO(400,410,860),IE 1370 IOUT=0 1380 C 1390 C ...TEST FOR EMPTY CARD BUFFER. READ NEW CARD IF EMPTY 1400 C 1410 IF(ICOL.GT.80) GOTO 201 1420 C 1430 C ...IE=1 UNTIL FIRST 'E' OR 'D' FOUND. THEN 1440 C IE=NUMBER OF 'E' OR 'D' CHARACTERS FOUND + 1 1450 C IC1=SUBSCRIPT OF FIRST CHARACTER IN FREAD CALL 1460 C B=POWER OF 10 BY WHICH FRACTIONAL PART MUST BE DIVIDED 1470 C 1480 100 IE=1 1490 IC1=ICOL 1500 B=1.0 1510 C 1520 C ...RETURN HERE TO PICK UP EXPONENT 1530 C IDEC=1 UNTIL FIRST '.' FOUND. THEN 1540 C IDEC=NUMBER OF '.' + NUMBER OF 'E' OR 'D' FOUND + 2 1550 C X=ABSOLUTE VALUE OF NUMBER EVALUATED (FREAD) 1560 C SIGN=SIGN OF NUMBER EVALUATED (FREAD) 1570 C NC=LENGTH OF LEGAL CHARACTER LIST (IDIGIT). EITHER 15 OR 17 1580 C 1590 110 IDEC=1 1600 X=0.0 1610 SIGN=+1.0 1620 NC=17 1630 C 1640 C ...IGNORE LEADING SPACES AND COMMAS 1650 C 1660 DO 150 IC=ICOL,80 1670 IF(IA(IC).NE.IDIGIT(11).AND.IA(IC).NE.IDIGIT(12)) GOTO 202 1680 150 CONTINUE 1690 C 1700 C ...END OF CARD. ERROR IF EXPONENTIAL PART EXPECTED 1710 C 1720 ICOL=ICOL-1 1730 IF(IE.GT.1) GOTO 800 1740 C 1750 C ...NO ERROR. READ ANOTHER CARD 1760 C 1770 201 READ 2000,(IA(J),J=1,80) 1780 2000 FORMAT(80A1) 1790 ICOL=1 1800 GO TO 100 1810 C 1820 C ...NO MORE LEADING SPACES OR COMMAS 1830 C 1840 C START TESTING CHARACTER BY CHARACTER UNTIL TERMINATING 1850 C SPACE OR COMMA FOUND 1860 C 1870 202 DO 290 ICOL=IC,80 1880 JA=IA(ICOL) 1890 C 1900 C ...COMPARE EACH CHARACTER TO LIST OF LEGAL CHARACTERS (IDIGIT) 1910 C 1920 DO 205 I=1,NC 1930 IF(JA.EQ.IDIGIT(I)) GOTO 206 1940 205 CONTINUE 1950 C ...ERROR - CHARACTER NOT ON IDIGIT LIST 1960 C 1970 GO TO 800 1980 C ...CHARACTER ON LIST. TEST WHETHER NUMERAL 1990 C 2000 206 J=I-9 2010 IF(J.LE.0) GOTO 25 2020 GOTO(25,300,300,210,310,310,220,290),J 2030 C 2040 C ...CHARACTER = '.' ERROR IF PREVIOUS '.' OR 'E' OR 'D' FOUND 2050 C 2060 210 IDEC=IDEC+IE 2070 IF(IDEC.GT.2) GOTO 800 2080 GOTO 290 2090 C 2100 C ...CHARACTER = '-' RESET 'SIGN' AND SHORTEN IDIGIT LIST 2110 C 2120 220 SIGN=-1.0 2130 GO TO 290 2140 C 2150 C ...CHARACTER IS NUMERAL 2160 C 2170 25 DIGIT=I-1 2180 GOTO(251,252,800),IDEC 2190 C 2200 C ...ASSEMBLE INTEGRAL PART OF NUMBER 2210 C 2220 251 X=10.0D0*X+DIGIT 2230 GO TO 290 2240 C 2250 C ...ASSEMBLE FRACTIONAL PART OF NUMBER 2260 C 2270 252 B=B/10.0D0 2280 X=X+B*DIGIT 2290 C 2300 C ...CHARACTER = '+' SHORTEN IDIGIT LIST 2310 C 2320 290 NC=15 2330 C 2340 C ...NO TERMINATING SPACE OR COMMA BEFORE END OF CARD FOUND 2350 C 2360 ICOL=81 2370 C 2380 C ...CHARACTER IS TERMINATING SPACE OR COMMA. TEST FOR E OR F FORMAT 2390 C 2400 300 GO TO(400,410),IE 2410 C 2420 C ...TERMINATING CHARACTER IS 'E' OR 'D'. SET XX=MANTISSA 2430 C 2440 310 IE=IE+1 2450 XX=X*SIGN 2460 C 2470 C ...ERROR IF NO MANTISSA 2480 C 2490 IF(ICOL.EQ.IC) GOTO 800 2500 ICOL=ICOL+3-IE 2510 GO TO (110,110,800),IE 2520 C 2530 C ...TERMINATION OF F FORMAT 2540 C 2550 400 FREAD=X*SIGN 2560 GO TO 500 2570 C 2580 C ...TERMINATION OF E FORMAT 2590 C 2600 410 IX=X*SIGN 2610 FREAD=XX*10.0D0**IX 2620 C 2630 C ...PRINT IF IN=2 OR 3 2640 C 2650 500 IC2=ICOL-1 2660 IF (IN .GT.1) PRINT 5000,(IA(J),J=IC1,IC2) 2670 5000 FORMAT (10X,80A1) 2680 RETURN 2690 C 2700 C ...ERROR HANDLING 2710 C 2720 800 IOUT=IA(ICOL) 2730 C 2740 C ...SEARCH FOR NEXT TERMINATING BLANK OR COMMA 2750 C 2760 DO 810 I=ICOL,80 2770 IF(IA(I).EQ.IDIGIT(11).OR.IA(I).EQ.IDIGIT(12)) GO TO 815 2780 810 CONTINUE 2790 I=81 2800 815 ICOL=I 2810 C 2820 C ...PRINT ERROR MESSAGE IF N=2 OR 3 2830 C 2840 IF(IN.EQ.0) GOTO 850 2850 IC2=ICOL-1 2860 PRINT 820,IOUT,(IA(J),J=IC1,IC2) 2870 820 FORMAT(25H MALFORMED NUMBER DUE TO ,A1,4H IN ,80A1) 2880 C 2890 C ...EVALUATE FREAD AND RETURN 2900 C 2910 850 GO TO(400,410,400),IE 2920 C 2930 C ...ILLEGAL REREAD ERROR 2940 C 2950 860 PRINT 870 2960 870 FORMAT(25H ILLEGAL REREAD ATTEMPTED ) 2970 FREAD=0. 2980 RETURN 2990 END 3000