C********************************************************************** C SUBROUTINE FREE IS FOR FREE FORM INPUT TO FORTRAN PROGAMS. IT IS NOT C AS GENERAL AS A SYSTEM SUPPLIED FREE FORM INPUT ROUTINE BUT WILL C HANDLE NUMERIC OR ALPHAMERIC FIELDS. THE INPUT DEVICE MAY VARY BUT C EACH LOGICAL RECORD IS ASSUMED TO BE A CARD IMAGE. INPUT MAY BE FROM C CARDS,TAPE,DISK OR TERMINAL. C ALL DISTINCT FIELDS MUST BE SEPERATED FROM ONE ANOTHER BY EITHER A C BLANK SPACE OR A COMMA. ALPHAMERIC FIELDS MUST ALSO BE ENCLOSED IN C ASTERISKS TO SIGNAL THEIR NATURE. CONSEQUENTLY APOSTROPHES CAN NOT C BE USED IN FIELDS HOWEVER NUMBERS CAN BE PART OF AN ALPHA FIELD. C CONTINUATION CARDS CAN BE USED BY MAKING THE LAST CHARACTER ON A C CARD A DOLLAR SIGN-$. IT MUST BE SEPARATED BY A BLANK FROM THE PRE- C CEEDING FIELD BUT NOT ENCLOSED IN ASTERISKS. NO FIELD CAN BE SPLIT C BETWEEN CARDS. CONTINUATION CARDS ARE ONLY LIMITED BY THE USERS C DESIGNATED ARRAY SIZE FOR DATA TRANSFER. C FOR NUMERIC FIELDS INCLUDE SIGNS, IF NO DECIMAL POINT IS GIVEN, ONE C WILL BE ASSUMED AT THE RIGHT OF THE NUMBER. NUMERIC INPUT MAY USE C SCIENTIFIC NOTATION IN EITHER 'E' OR 'D' FORM. IF USED THERE IS NO C BETWEEN THE LETTER AND THE EXPONENT. FOR EXAMPLE 1.E10 IS LEGAL BUT C 1.E 10 IS NOT. C C CALLING ARGUMENTS: C MAXDIM MAXIMUM NUMBER OF ELEMENTS FOR DATA C ALPHA AN ARRAY DECLARED INTEGER IN THE CALLING PROGRAM. IT C MUST BE LARGE ENOUGH TO HOLD ANY ALPHAMERIC INPUT. C DATA AN ARRAY DECLARED REAL IN THE CALLING PROGRAM.IT MUST C BE LARGE ENOUGH TO HOLD THE DATA INPUT BY ONE CALL TO C FREE (MAXDIM ELEMENTS). C SYSIN THE LOGICAL UNIT NUMBER OF THE INPUT DEVICE. C NUM RETURNS THE NUMBER OF NUMERIC FIELDS DECODED AND C STORED IN DATA C NALPHA RETURNS THE NUMBER OF ALPHAMERIC CHARACTERS READ AND C STORED IN THE ARRAY 'ALPHA' C OK LOGICAL RETURNED TRUE IF ALL DECODING IS ALRIGHT. IT C IS RETURNED FALSE IF ANY PROBLEMS ARE ENCOUNTERED. C EF "END FILE" INDICATOR. IT IS RETURNED TRUE IF THE C END OF THE INPUT FILE IS ENCOUNTERED. C C NOTATION: INTEGER VARIABLES C X THE INPUT ARRAY READ AS 80A1, AND THEN DECODED. C DIGIT ARRAY STORING THE DIGITS 0-9 IN ALPHA FORM. C PLUS '+' IN ALPHA MODE C MINUS '-' IN ALPHA MODE C DEC '.' IN ALPHA MODE C COMMA ',' IN ALPHA MODE C APS AN ALPHA ASTERISK C BLANK AN ALPHA BLANK C D 'D' IN ALPHA MODE C E 'E' IN ALPHA MODE C POINT A POINTER THAT SHOWS THE CURRENT AVAILABLE PLACE IN THE C DATA ARRAY FOR STORING THE NEXT DECODED NUMBER. C APOINT A POINTER SHOWING THE CURRENT AVAILABLE PLACE IN THE ARRAY C ALPHA FOR STORING THE NEXT ALPHA CHARACTER. C XPOINT A POINTER SHOWING THE NUMERIC FIELD STARTING POINT IN C ARRAY X OR IF AN ALPHA STRING IS BEING STORED IT POINTS TO C THE CURRENT CHARACTER BEING EXAMINED IN ARRAY X. C TEMP TEMPORARY STORAGE C CONT '$' IN ALPHA MODE C LEFT AN ARRAY(1 BY 16) FOR STORING THE ELEMENTS OF A NUMERIC C FIELD TO THE LEFT OF THE DECIMAL POINT. C RIGHT AN ARRAY FOR STORING THE ELEMENTS OF A NUMERIC FIELD TO THE C RIGHT OF THE DECIMAL POINT C C NOTATION: REAL VARIABLES C LFACT ARRAY STORING CONSTANTS FOR THE DECODING OF ELEMENTS IN C A NUMERIC FIELD TO THE LEFT OF THE DECIMAL C RFACT AN ARRAY STORING CONSTANTS FOR DECODING THE ELEMENTS OF A C NUMERIC FIELD TO THE RIGHT OF THE DECIMAL C C NOTATION: LOGICAL VARIABLES C OK RETURNED TRUE TO THE CALLING PROGRAM IF THE INPUT HAS BEEN C DECODED WITH OUT PROBLEMS. RETURNED FALSE IF THE ARE C PROBLEMS DECODING INPUT. IN THIS CASE DECODING ABORTS WHEN C PROBLEM OCCURS. C RIGHTP WHILE DECODING A CHARACTER OF A NUMERIC FIELD RIGHTP IS C TRUE IF THE CHARACTER IS TO THE RIGHT OF THE DECIMAL POINT C AND RIGHTP IS FALSE IF THE CHARACTER IS TO THE LEFT OF THE C DECIMAL POINT. C EXPON TRUE IF A NUMERIC FIELD BEING DECODED HAS AN EXPONENT, C FALSE OTHERWISE. C C NOTATION: MISCELLANEOUS C SIGN THE SIGN OF A NUMERIC FIELD C NLEFT NUMBER OF CHARACTERS TO THE LEFT OF THE DECIMAL IN A C NUMERIC FIELD C NRIGHT NUMBER OF CHARACTERS TO THE RIGHT OF THE DECIMAL IN A C NUMERIC FIELD. C LPART REAL VARIABLE USED IN DECODING THE NUMBERS. C RPART REAL VARIABLE USED IN DECODING THE NUMBERS. C A NUMBER IS FIRST DECODED INTO TWO PARTS.THE PART TO THE LEFT C OF THE DECIMAL POINT IS STORED AS AN INTEGER IN LPART. THE C PART TO THE RIGHT OF THE DECIMAL POINT IS STORED IN RPART. C THESE PARTS ARE THEN COMBINED AT WHICH TIME A FLOATING C POINT NUMBER IS PRODUCED.THEN THIS NUMBER IS SCALED C ACCORDING TO THE EXPONENT VALUE IF ONE IS USED(I.E., 'D' C OR 'E' FORMAT). C NSIGN SIGN OF THE EXPONENT, IF PRESENT C NEX VALUE OF THE EXPONENT(BASE TEN), IF PRESENT C WRITTEN BY DR. KENNETH P. BURNHAM U.S.FISH AND WILDLIFE SERVICE ,1974 C*********************************************************************** SUBROUTINE FREE (MAXDIM,ALPHA,DATA,ISYSIN,NUM,NALPHA,OK,EF) C C DECLARATIONS C INTEGER*4 SYSIN INTEGER ISYSIN LOGICAL OK, RIGHTP, EXPON, EF CHARACTER*1 ALPHA(1), X(80), DIGIT(10), PLUS, MINUS, DEC, 1 COMMA, BLANK, APS, D, E, TEMP, CONT INTEGER POINT, APOINT, XPOINT, LEFT(16), RIGHT(16), MAXDIM REAL DATA(*), LPART, RPART, LFACT(16), RFACT(16) C C DATA STATEMENTS C DATA DIGIT /'0','1','2','3','4','5','6','7','8','9'/,PLUS /'+'/ DATA MINUS /'-'/,DEC /'.'/,COMMA /','/,BLANK /' '/,APS /'*'/, 1 D /'D'/ DATA E /'E'/,CONT /'$'/ C C INITIALIZE VARIABLES C SYSIN=ISYSIN LFACT(1)=1. RFACT(1)=0.1 DO 5 I=2,16 LFACT(I)=LFACT(I-1)*10. 5 RFACT(I)=RFACT(I-1)*0.1 EF=.FALSE. NUM=0 POINT=1 APOINT=1 NALPHA=0 XPOINT=1 C C READ A CARD IMAGE AS 80A1. THEN DETERMINE WHERE THE FIRST NON-BLANK C IS. C 10 READ(SYSIN,310,END=300) X 20 TEMP=X(XPOINT) IF ((TEMP.NE.BLANK).AND.(TEMP.NE.COMMA)) GO TO 30 XPOINT=XPOINT+1 IF (XPOINT.GT.80) GO TO 280 GO TO 20 C C CONTROL COMES TO 3 IF X(XPOINT) IS NOT BLANK. CHECK FOR CONTINUATION C 30 IF (TEMP.NE.CONT) GO TO 40 XPOINT=1 GO TO 10 C C CHECK FOR THE START OF AN ALPHA FILED. IF CONTROL GOES TO 7 THEN WE C HAVE THE START OF A NUMERIC FIELD. C 40 IF (TEMP.NE.APS) GO TO 70 50 XPOINT=XPOINT+1 IF (XPOINT.GT.80) GO TO 290 IF (X(XPOINT).NE.APS) GO TO 60 XPOINT=XPOINT+1 IF (XPOINT.GT.80) GO TO 280 GO TO 20 C C CHARACTER IS PART OF AN ALPHA FIELD, SAVE IT IN ALPHA(APOINT). C 60 ALPHA(APOINT)=X(XPOINT) APOINT=APOINT+1 NALPHA=NALPHA+1 GO TO 50 C C DECODE A NUMERIC FIELD, STARTING AT XPOINT. C 70 RIGHTP=.FALSE. EXPON=.FALSE. SIGN=-1. NLEFT=0 NRIGHT=0 IF (TEMP.EQ.MINUS) GO TO 100 SIGN=+1. IF (TEMP.EQ.PLUS) GO TO 100 IF (TEMP.EQ.DEC) RIGHTP=.TRUE. IF (RIGHTP) GO TO 100 C C IF CONTROL COMES HERE THEN THE FIRST CHARACTER OF THE NUMERIC FIELD C IS A DIGIT, OR AN ERROR HAS HAPPENED. C DO 80 I=1,10 IF (TEMP.EQ.DIGIT(I)) GO TO 90 80 CONTINUE GO TO 290 90 LEFT(1)=I-1 NLEFT=1 C C CHECK THE NEXT CHARACTER IN THE FIELD C 100 XPOINT=XPOINT+1 IF (XPOINT.GT.80) GO TO 230 TEMP=X(XPOINT) IF ((TEMP.EQ.BLANK).OR.(TEMP.EQ.COMMA)) GO TO 230 C C ASSUME THIS ELEMENT IS A DIGIT AND TRY TO DECODE IT C DO 110 I=1,10 IF (TEMP.EQ.DIGIT(I)) GO TO 120 110 CONTINUE C C CHARACTER IS NOT A DIGIT BUT IT IS PART OF THE FIELD, SEE IF IT IS C THE DECIMAL POINT. IF NOT,SEE IF WE HAVE AN EXPONENT TO THE NUMBER C IF ((TEMP.EQ.DEC).AND.RIGHTP) GO TO 290 IF (TEMP.EQ.DEC) RIGHTP=.TRUE. IF (TEMP.EQ.DEC) GO TO 100 IF ((TEMP.EQ.D).OR.(TEMP.EQ.E)) GO TO 140 GO TO 290 120 IF (RIGHTP) GO TO 130 NLEFT=NLEFT+1 LEFT(NLEFT)=I-1 GO TO 100 130 NRIGHT=NRIGHT+1 RIGHT(NRIGHT)=I-1 GO TO 100 C C CONTROL COMES HERE IF THE NUMBER HAS AN EXPONENT, AT THIS POINT ALL C CHARACTERS IN THE MANTISSA ARE DECODED. C FROM HERE TO STATEMENT 105 WE DECODE THE EXPONENT C 140 NSIGN=+1 150 XPOINT=XPOINT+1 IF (XPOINT.GT.80) GO TO 290 TEMP=X(XPOINT) C C CHECK THE FIRST CHARACTER AFTER THE D OR E. FIRST WE ASSUME THIS C CHARACTER IS A DIGIT. IF NOT CHECK FOR A SIGN. NOTHING ELSE IS LEGAL C DO 160 I=1,10 IF (TEMP.EQ.DIGIT(I)) GO TO 170 160 CONTINUE IF ((TEMP.NE.PLUS).AND.(TEMP.NE.MINUS)) GO TO 290 IF (TEMP.EQ.MINUS) NSIGN=-1 GO TO 150 C C CHECK CHARACTERS AFTER THE FIRST ONE IF ANY ARE PRESENT. C 170 NEX=I-1 XPOINT=XPOINT+1 IF (XPOINT.LE.80) GO TO 190 180 NEX=NEX*NSIGN EXPON=.TRUE. GO TO 230 190 TEMP=X(XPOINT) IF ((TEMP.EQ.COMMA).OR.(TEMP.EQ.BLANK)) GO TO 180 C C CONTROL COMES HERE IF THE EXPONENT HAS TWO DIGITS IN IT. C DO 200 I=1,10 IF (TEMP.EQ.DIGIT(I)) GO TO 210 200 CONTINUE GO TO 290 210 NEX=NEX*10+(I-1) NC=XPOINT+1 IF (NC.GT.80) GO TO 220 IF ((X(NC).NE.COMMA).AND.(X(NC).NE.BLANK)) GO TO 290 220 NEX=NEX*NSIGN EXPON=.TRUE. C C CONTROL COMES TO STATEMENT 24 WHEN THE NUMBER AND EXPONENT(IF ANY) C HAS BEEN DECODED. AT THIS POINT DIGITS ARE STORED IN LEFT AND RIGHT C (THE ARRAYS) AND NLEFT, AND NRIGHT ARE KNOWN. ALSO SIGN IS KNOWN. C 230 RPART=0.0 LPART=0.0 IF ((NLEFT+NRIGHT).EQ.0) GO TO 290 IF (NLEFT.EQ.0) GO TO 250 K=NLEFT DO 240 I=1,K KI1=K-I+1 240 LPART=LPART+FLOAT(LEFT(I))*LFACT(KI1) 250 IF (NRIGHT.EQ.0) GO TO 270 DO 260 I=1,NRIGHT NR1=NRIGHT-I+1 260 RPART=RPART+FLOAT(RIGHT(I))*LFACT(NR1) Q=LPART+RPART*RFACT(NRIGHT) 270 IF (NRIGHT.EQ.0) Q=LPART IF (EXPON) Q=Q*(10.**NEX) NUM=NUM+1 IF (SIGN.LT.0.) Q=-Q IF (POINT.GT.MAXDIM) THEN WRITE(0,*) 'Exceeded program dimensions on input.' WRITE(0,*) 'Aborted from Subroutine FREE.' OK=.FALSE. RETURN ENDIF DATA(POINT)=Q POINT=POINT+1 XPOINT=XPOINT+1 IF (XPOINT.GT.80) GO TO 280 GO TO 20 280 OK=.TRUE. RETURN 290 OK=.FALSE. RETURN 300 EF=.TRUE. RETURN C 310 FORMAT (80A1) END