C CLSA2 - FORTRAN STATEMENT CLASSIFIER (A2) SUBROUTINE CLSA2(K,ITYP,IPS,IPE) C TO CLASSIFY USAS FORTRAN RECORDS INTO 46 CLASSES C C SPECIFICATION DIMENSION K(1) C C USAS FORTRAN RECORD CLASSIFIER -CLASS- C C LANGUAGE C USAS FORTRAN (BUT NEARLY ALL USAS FORTRAN) C INPUT C K-AN INTEGER ARRAY CONTAINING 40A2 CHARACTERS C IPS-START POSITION OF SCANNING, SHOULD BE 1 OR.GT.6 C GT 6 TO CHECK STATEMENT FOLLOWING A LOGICAL IF C OUTPUT C ITYP-AN INTEGER TYPE CODE FROM 1 TO 46 C IPS-FIRST POSITION PAST KEYWORD , IF ANY, ELSE 7 C IPE-LAST NON-BLANK CHARACTER POSITION +1 C IN THE CASE OF A LOGICAL IF, FIRST NON-BLANK POSITION PAST C RIGHT PAREN. C ERROR EXITS C NONE C INCLUDE 'CLSA2.COM/LIST' C C CHECK FOR COMMENT LENG=IRNSC(K,1,72) IPE=LENG+1 CALL ICSGC(K,IPS,IP,JCH) IF (IPS-7) 101,5,5 C101 IF (JCH-KC) 2,1,2 101 IF (.NOT. (JCH .EQ. KC .OR. JCH .EQ. KD)) GO TO 2 1 JTYP=1 GO TO 55 C CHECK FOR VALID STATEMENT NUMBER COLS 1-5 2 DO 203 I=1,5 IF (JCH-KBLNK) 201,203,201 201 IF (ICH0(JCH)) 202,203,203 202 JTYP=36 GO TO 55 203 CALL GNXCH(JCH) C CHECK FOR CONTINUATION RECORD IF (JCH-KBLNK) 3,5,3 3 IF (ICH0(JCH)) 4,5,4 4 JTYP=2 GO TO 55 C INITIALIZE THE LOOP 5 JSW=0 ISW=0 JEQ=0 JCMA=0 JHOLL=0 JSAVE=KBLNK IPS = MAX0(7, IPS) C C ASSIGNMENT SCAN LOOP DO 26 J=IP,LENG CALL GNXCH(JCH) IF (JCH-KBLNK) 6,26,6 C IT'S NOT BLANK,IS HOLLERITH SWITCH ON 6 IF (JHOLL) 12,12,7 7 IF(JCH-KAPOS) 701,32,701 701 IF (ICH0(JCH)) 8,10,10 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 GO TO 28 C SAVE LAST CHARACTER IF TERMINATED EARLY 27 JSAVE=JCH JPOS=J 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 ICHGS (K, IPS, IP) DO 315 I=1,9 312 CALL GNXCH (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 ICHGS(K,IPS,IP) 33 CALL GNXCH(JCH) IF (JCH-KBLNK) 34,37,34 34 IF (JCCHR(JCH,1,1,KALP,J,J,1)-2) 35,36,35 35 J=KFAL(J) IF (J) 39,39,34 36 J=KSUC(J) IF (J) 39,39,37 37 CONTINUE IF (IP-1-LENG) 33,33,38 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 (ICH0(JSAVE)) 44,55,55 44 JTYP=9 IPE=JPOS GO TO 55 45 IF (JCMA) 55,55,46 46 JTYP=6 GO TO 55 47 L=11 CALL ICSGC(K,L,IP,JCH) GO TO 52 48 CALL GNXCH (JCH) IF (IP-1-LENG) 49,49,55 49 IF (JCH-KBLNK) 50,48,50 50 IF(JCCHR(JCH,1,1,KF,ISW,ISW,1)-2) 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,IP,JTYP) IF (JTYP) 70,70,60 60 CALL ICHGS (K,IPS,IP) DO 65 I=1,JTYP 63 CALL GNXCH (JCH) IF (JCH-KBLNK) 65,63,65 65 CONTINUE 68 IPS=IP 70 RETURN END C* ICH0 - CHARACTER 0 COMPARE FUNCTION C C ASCII CHARACTER SET DOES NOT FOLLOW ORDER THAT EBCDIC DOES C THEREFORE VALUES .GE. Z00F0 ARE NOT NECESSARILY NUMBERS C VALUES RETURNED C 0 = ICH IS 0 C 1 = ICH IS 1-9 C -1 = ICH IS NON-NUMERIC C C C C- FUNCTION ICH0(ICHR) IF (ICHR-48) 30, 10, 20 10 ICH0 = 0 GO TO 40 20 IF (ICHR-57) 25, 25, 30 25 ICH0 = 1 GO TO 40 30 ICH0 = -1 40 RETURN END