C* SFSCL - CLASSIFY FORTRAN STATEMENTS SUBROUTINE SFSCL(K,ITYP,IPS,IPE) C TO CLASSIFY USAS FORTRAN RECORDS INTO 36 CLASSES C C SPECIFICATION REAL K(3) DIMENSION IPS(2), IPE(2), IP(2), JPOS(2) C C USAS FORTRAN RECORD CLASSIFIER -CLASS- C C LANGUAGE C USAS FORTRAN (BUT NEARLY ALL USAS FORTRAN) C INPUT C K - PROPERLY INITIALIZED FILE ID BLOCK C FILE ASSUMED TO BE CYTOS ORDER C IPS(1) - RECORD NUMBER OF FORTRAN RECORD TO SCAN C IPS(2) - CHARACTER POSITION OF RECORD TO START SCAN C OUTPUT C ITYP-AN INTEGER TYPE CODE FROM 1 TO 46 C IPS - 2-WORD STARTING POSITION OF FORTRAN RECORD C IPS(1) - RECORD NUMBER C IPS(1) IS NEGATIVE IF EOF ENCOUNTERED C IPS(2) - CHARACTER POSITION IN THAT RECORD(PAST KEY) C IPE- 2 WORD END POSITION OF FORTRAN STATEMENT C IPE(1) - 32767 (RECORD NO. IF LOGICAL IF) C IPE(2) - 0 (CHARACTER POSITION IF LOGICAL IF) C ERROR EXITS C NONE C INCLUDE 'CLSA2.COM/LIST' C C CHECK FOR COMMENT IPE(1)=32767 IPE(2)=0 CALL SFSGS (K,IPS,IP,IPE,0) CALL GNXCF (JCH) IF (JCH) 101,101,103 101 IPS(1) = JCH GO TO 70 103 IF(IPS(2)-1) 5,104,5 104 CONTINUE IF (JCH-KC) 2,1,2 1 JTYP=1 GO TO 55 C CHECK FOR VALID STATEMENT NUMBER 2 DO 203 I=1,5 IF (JCH-KBLNK) 201,203,201 201 IF (ISPC (JCH)) 203, 202, 202 202 JTYP=36 GO TO 55 203 CALL GNXCF (JCH) C CHECK FOR CONTINUATION RECORD IF (JCH-KBLNK) 3,499,3 3 IF (JCH-KZERO) 4,499,4 4 JTYP=2 GO TO 55 C INITIALIZE THE LOOP 499 CALL GNXCF (JCH) IPS(2)=7 5 JSW=0 ISW=0 JEQ=0 JCMA=0 JHOLL=0 JSAVE=KBLNK ICHR=0 C C ASSIGNMENT SCAN LOOP 501 CONTINUE IF (JCH) 261,261,502 502 IF (JCH-KBLNK) 6,26,6 C IT'S NOT BLANK,IS HOLLERITH SWITCH ON 6 IF (JHOLL) 12,12,7 7 IF (ISPC (JCH)) 10, 8, 8 C FIRST TIME, NO INTEGER MEANS NOT HOLLERITH 8 IF (JHOLL-1) 11,11,9 C OTHERWISE LOOK FOR THE H 9 IF (JCH-KH) 11,32,11 C STILL FITS HOLLERITH CONSTANT SYNTAX 10 JHOLL=JHOLL+1 GO TO 25 C NOT A HOLLERITH CONSTANT, SET SWITCH OFF 11 JHOLL=0 C TEST OTHER CHARACTERS 12 IF (JCH-KLPAR) 13,20,13 13 IF (JCH-KRPAR) 14,18,14 14 IF (JCH-KCMA) 15,22,15 15 IF (JCH-KEQ) 16,23,16 16 IF (JCH-KSLSH) 17,21,17 17 IF (JCH-KASTK) 25,21,25 C RIGTH PAREN FOUND 18 JSW=JSW-1 IF (JSW) 19,19,25 C SET SWITCH TO ALLOW ONLY ONE MORE NON-BLANK CHARACTER 19 ISW=1 GO TO 26 C LEFT PAREN FOUND 20 JSW=JSW+1 C SET HOLLERITH SWITCH FOR ( 8 / * 21 JHOLL=1 GO TO 25 C COMMA FOUND CHECK LEVEL 22 IF (JSW) 30,30,21 C EQUALS SIGN FOUND, CHECK LEVEL 23 IF (JSW) 24,24,32 24 JEQ=1 C TEST IF TERMINATED BY SWITCH SET 25 IF (ISW) 26,26,27 C END OF ASSIGNMENT SCAN LOOP 26 CONTINUE CALL GNXCF (JCH) GO TO 501 261 CONTINUE GO TO 28 C SAVE LAST CHARACTER IF TERMINATED EARLY 27 JSAVE=JCH JPOS(1)=IP(1) JPOS(2)=IP(2)-1 C C LEAVE SCAN AND COME HERE IF C NO MORE CHARACTERS C ONE HON-BLANK CHARACTER AFTER A RIGHT PAREN C NOT A DO MIGHT BE ASSIGNMENT 28 IF (JEQ) 32,32,29 29 JTYP=3 GO TO 310 30 JCMA=1 IF (JEQ) 32,32,31 31 JTYP=10 C C CHECK FOR PARAMETER STATEMENT 310 CONTINUE CALL SFSGS (K, IPS, IP, IPE, 0) DO 315 I=1,9 312 CALL GNXCF (JCH) IF (JCH .LE. 0) GO TO 316 IF (JCH .EQ. KBLNK) GO TO 312 IF (JCH .NE. KPARM(I)) GO TO 316 315 CONTINUE JTYP = 52 316 GO TO 55 C 32 J=1 CALL SFSGS(K,IPS,IP,IPE,0) 33 CALL GNXCF(JCH) IF (JCH) 38,38,331 331 IF (JCH-KBLNK) 34,37,34 34 CALL SMCHR(KALP,J,ICHR,1,1) IF (JCH-ICHR) 35,36,35 35 J=KFAL(J) IF (J) 39,39,34 36 J=KSUC(J) IF (J) 39,39,37 37 CONTINUE GO TO 33 38 JCH=KBLNK GO TO 35 39 JTYP=-J IF (JTYP-5) 55,45,40 40 IF (JTYP-8) 55,43,41 41 IF (JTYP-22) 55,42,42 42 IF (JTYP-26) 47,47,55 43 IF (ISPC (JSAVE)) 55, 44, 44 44 JTYP=9 IPE(1)=JPOS(1) IPE(2)=JPOS(2) GO TO 55 45 IF (JCMA) 55,55,46 46 JTYP=6 GO TO 55 47 JPOS(1)=IPS(1) JPOS(2)=11 CALL SFSGS(K,JPOS,IP,IPE,0) CALL GNXCF(JCH) GO TO 52 48 CALL GNXCF (JCH) IF (JCH) 55,55,49 49 IF (JCH-KBLNK) 50,48,50 50 CALL SMCHR(KF,ISW,ICHR,1,1) IF (JCH-ICHR) 51,53,51 51 IF (ISW-1) 52,48,52 52 ISW=1 GO TO 50 53 ISW=ISW+1 IF (ISW-8) 48,48,54 54 ITYP=34 GO TO 68 55 ITYP=JTYP CALL ICSGC (KSTRT,ITYP,I,JTYP) IF (JTYP) 70,70,60 60 CALL SFSGS (K,IPS,IP,IPE,0) DO 65 I=1,JTYP 63 CALL GNXCF (JCH) IF (JCH) 202,202,631 631 CONTINUE IF (JCH-KBLNK) 65,63,65 65 CONTINUE 68 IPS(1)=IP(1) IPS(2)=IP(2) 70 RETURN END