home *** CD-ROM | disk | FTP | other *** search
/ The Fred Fish Collection 1.5 / ffcollection-1-5-1992-11.iso / ff_progs / libs / matlab.lzh / MATLAB / MATLAB.LZH / Source / MatLab / clause.for < prev    next >
Encoding:
Text File  |  1991-04-13  |  5.2 KB  |  205 lines
  1.       SUBROUTINE CLAUSE
  2.       IMPLICIT NONE
  3. C
  4.       INCLUDE MATLAB$KOM:SIZEPARMS.INC
  5.       INCLUDE MATLAB$KOM:VSTK.KOM
  6.       INCLUDE MATLAB$KOM:RECU.KOM
  7.       INCLUDE MATLAB$KOM:IOP.KOM
  8.       INCLUDE MATLAB$KOM:COM.KOM
  9. C
  10.       INTEGER FOR(4), WHILE(4), IFF(4), ELSE(4), ENND(4)
  11.       INTEGER DO(4), THENN(4)
  12.       INTEGER SEMI, EQUAL, EOL, BLANK, COMMA, LESS, GREAT, NAME, R, OP
  13.       INTEGER I, J, L, M, N, LJ, L2, KOUNT
  14.       DOUBLE PRECISION E1, E2
  15. C
  16.       DOUBLE PRECISION DFLOAT
  17.       LOGICAL EQID
  18. C
  19.       DATA FOR   / 15, 24, 27, 36 /, WHILE / 32, 17, 18, 21 /
  20.       DATA IFF   / 18, 15, 36, 36 /, ELSE  / 14, 21, 28, 14 /
  21.       DATA ENND  / 14, 23, 13, 36 /, DO    / 13, 24, 36, 36 /
  22.       DATA THENN / 29, 17, 14, 23 /
  23.       DATA SEMI  / 39 /, EQUAL / 46 /, EOL   / 99 /, BLANK / 36 /
  24.       DATA COMMA / 48 /, LESS  / 50 /, GREAT / 51 /, NAME  / 1 /
  25. C
  26. C
  27.       R = -FIN-10
  28.       FIN = 0
  29.       IF (DDT.EQ.1) WRITE (WTE, 100) PT, RSTK(PT), R
  30. 100   FORMAT (' CLAUSE', 3I4)
  31.       IF (R.LT.1 .OR. R.GT.6) GO TO 01
  32.       GO TO (02, 30, 30, 80, 99, 90), R
  33. 01    CONTINUE
  34.       R = RSTK(PT)
  35.       GO TO (99, 99, 05, 40, 45, 99, 99, 99, 99, 99,
  36.      .       99, 99, 15, 55, 99, 99, 99), R
  37. C
  38. C ***      FOR
  39. 02    CONTINUE
  40.       CALL GETSYM
  41.       IF (SYM.NE.NAME) CALL ERROR (34)
  42.       IF (ERR.GT.0) RETURN
  43.       PT = PT+2
  44.       CALL PUTID (IDS(1,PT), SYN)
  45.       CALL GETSYM
  46.       IF (SYM.NE.EQUAL) CALL ERROR (34)
  47.       IF (ERR.GT.0) RETURN
  48.       CALL GETSYM
  49.       RSTK(PT) = 3
  50. C *CALL* EXPR
  51.       RETURN
  52. C
  53. 05    CONTINUE
  54.       PSTK(PT-1) = 0
  55.       PSTK(PT) = LPT(4)-1
  56.       IF (EQID (SYN, DO)) SYM = SEMI
  57.       IF (SYM.EQ.COMMA) SYM = SEMI
  58.       IF (SYM.NE.SEMI) CALL ERROR (34)
  59.       IF (ERR.GT.0) RETURN
  60. 10    CONTINUE
  61.       J = PSTK(PT-1)
  62.       LPT(4) = PSTK(PT)
  63.       SYM = SEMI
  64.       CHAR = BLANK
  65.       J = J+1
  66.       L = LSTK(TOP)
  67.       M = MSTK(TOP)
  68.       N = NSTK(TOP)
  69.       LJ = L+(J-1)*M
  70.       L2 = L+M*N
  71.       IF (M.NE.-3) GO TO 12
  72.       LJ = L+3
  73.       L2 = LJ
  74.       STKR(LJ) = STKR(L)+DFLOAT (J-1)*STKR(L+1)
  75.       STKI(LJ) = 0.0
  76.       IF (STKR(L+1).GT.0.0D0 .AND. STKR(LJ).GT.STKR(L+2)) GO TO 20
  77.       IF (STKR(L+1).LT.0.0D0 .AND. STKR(LJ).LT.STKR(L+2)) GO TO 20
  78.       M = 1
  79.       N = J
  80. 12    CONTINUE
  81.       IF (J.GT.N) GO TO 20
  82.       IF (TOP+1.GE.BOT) CALL ERROR (18)
  83.       IF (ERR.GT.0) RETURN
  84.       TOP = TOP+1
  85.       LSTK(TOP) = L2
  86.       MSTK(TOP) = M
  87.       NSTK(TOP) = 1
  88.       ERR = L2+M-LSTK(BOT)
  89.       IF (ERR.GT.0) CALL ERROR (17)
  90.       IF (ERR.GT.0) RETURN
  91.       CALL WCOPY (M, STKR(LJ), STKI(LJ), 1, STKR(L2), STKI(L2), 1)
  92.       RHS = 0
  93.       CALL STACKP (IDS(1,PT))
  94.       IF (ERR.GT.0) RETURN
  95.       PSTK(PT-1) = J
  96.       PSTK(PT) = LPT(4)
  97.       RSTK(PT) = 13
  98. C *CALL* PARSE
  99.       RETURN
  100. C
  101. 15    CONTINUE
  102.       GO TO 10
  103. C
  104. 20    CONTINUE
  105.       MSTK(TOP) = 0
  106.       NSTK(TOP) = 0
  107.       RHS = 0
  108.       CALL STACKP (IDS(1,PT))
  109.       IF (ERR.GT.0) RETURN
  110.       PT = PT-2
  111.       GO TO 80
  112. C
  113. C ***      WHILE OR IF
  114. 30    CONTINUE
  115.       PT = PT+1
  116.       CALL PUTID (IDS(1,PT), SYN)
  117.       PSTK(PT) = LPT(4)-1
  118. 35    CONTINUE
  119.       LPT(4) = PSTK(PT)
  120.       CHAR = BLANK
  121.       CALL GETSYM
  122.       RSTK(PT) = 4
  123. C *CALL* EXPR
  124.       RETURN
  125. C
  126. 40    CONTINUE
  127.       IF (SYM.NE.EQUAL .AND. SYM.NE.LESS .AND. SYM.NE.GREAT)
  128.      .      CALL ERROR (35)
  129.       IF (ERR.GT.0) RETURN
  130.       OP = SYM
  131.       CALL GETSYM
  132.       IF (SYM.EQ.EQUAL .OR. SYM.EQ.GREAT) OP = OP+SYM
  133.       IF (OP.GT.GREAT) CALL GETSYM
  134.       PSTK(PT) = 256*PSTK(PT)+OP
  135.       RSTK(PT) = 5
  136. C *CALL* EXPR
  137.       RETURN
  138. C
  139. 45    CONTINUE
  140.       OP = MOD (PSTK(PT), 256)
  141.       PSTK(PT) = PSTK(PT)/256
  142.       L = LSTK(TOP-1)
  143.       E1 = STKR(L)
  144.       L = LSTK(TOP)
  145.       E2 = STKR(L)
  146.       TOP = TOP-2
  147.       IF (EQID (SYN, DO).OR.EQID (SYN, THENN)) SYM = SEMI
  148.       IF (SYM.EQ.COMMA) SYM = SEMI
  149.       IF (SYM.NE.SEMI) CALL ERROR (35)
  150.       IF (ERR.GT.0) RETURN
  151.       IF (OP.EQ.EQUAL         .AND. E1.EQ.E2) GO TO 50
  152.       IF (OP.EQ.LESS          .AND. E1.LT.E2) GO TO 50
  153.       IF (OP.EQ.GREAT         .AND. E1.GT.E2) GO TO 50
  154.       IF (OP.EQ.(LESS+EQUAL)  .AND. E1.LE.E2) GO TO 50
  155.       IF (OP.EQ.(GREAT+EQUAL) .AND. E1.GE.E2) GO TO 50
  156.       IF (OP.EQ.(LESS+GREAT)  .AND. E1.NE.E2) GO TO 50
  157.       PT = PT-1
  158.       GO TO 80
  159. C
  160. 50    CONTINUE
  161.       RSTK(PT) = 14
  162. C *CALL* PARSE
  163.       RETURN
  164. C
  165. 55    CONTINUE
  166.       IF (EQID (IDS(1,PT), WHILE)) GO TO 35
  167.       PT = PT-1
  168.       IF (EQID (SYN, ELSE)) GO TO 80
  169.       RETURN
  170. C
  171. C ***      SEARCH FOR MATCHING END OR ELSE
  172. 80    CONTINUE
  173.       KOUNT = 0
  174.       CALL GETSYM
  175. 82    CONTINUE
  176.       IF (SYM.EQ.EOL) RETURN
  177.       IF (SYM.NE.NAME) GO TO 83
  178.       IF (EQID (SYN, ENND).AND.KOUNT.EQ.0) RETURN
  179.       IF (EQID (SYN, ELSE).AND.KOUNT.EQ.0) RETURN
  180.       IF (EQID (SYN, ENND).OR.EQID (SYN, ELSE)) KOUNT = KOUNT-1
  181.       IF (EQID (SYN, FOR).OR.EQID (SYN, WHILE).OR.EQID (SYN, IFF))
  182.      .      KOUNT = KOUNT+1
  183. 83    CONTINUE
  184.       CALL GETSYM
  185.       GO TO 82
  186. C
  187. C ***      EXIT FROM LOOP
  188. 90    CONTINUE
  189.       IF (DDT.EQ.1) WRITE (WTE, 190) (RSTK(I), I = 1, PT)
  190. 190   FORMAT (' EXIT  ', 10I4)
  191.       IF (RSTK(PT).EQ.14) PT = PT-1
  192.       IF (PT.LE.PTZ) RETURN
  193.       IF (RSTK(PT).EQ.14) PT = PT-1
  194.       IF (PT-1.LE.PTZ) RETURN
  195.       IF (RSTK(PT).EQ.13) TOP = TOP-1
  196.       IF (RSTK(PT).EQ.13) PT = PT-2
  197.       GO TO 80
  198. C
  199. 99    CONTINUE
  200.       CALL ERROR (22)
  201.       IF (ERR.GT.0) RETURN
  202. C
  203.       RETURN
  204.       END
  205.