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 / factor.for < prev    next >
Encoding:
Text File  |  1991-04-13  |  6.4 KB  |  285 lines
  1.       SUBROUTINE FACTOR
  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 SEMI, EOL, BLANK, R, ID(4), EXCNT, LPAREN, RPAREN
  11.       INTEGER STAR, DSTAR, COMMA, LESS, GREAT, QUOTE, NUM, NAME, ALFL
  12.       INTEGER L, N, LN, K, J, LS, I
  13. C
  14.       DOUBLE PRECISION DFLOAT
  15. C
  16.       DATA DSTAR / 54 /, SEMI / 39 /, EOL / 99 /, BLANK / 36 /
  17.       DATA STAR / 43 /, COMMA / 48 /, LPAREN / 37 /, RPAREN / 38 /
  18.       DATA LESS / 50 /, GREAT / 51 /, QUOTE / 49 /, NUM / 0 /
  19.       DATA NAME / 1 /, ALFL / 52 /
  20. C
  21. C
  22.       IF (DDT.EQ.1) WRITE (WTE, 100) PT, RSTK(PT), SYM
  23. 100   FORMAT (' FACTOR', 3I4)
  24.       R = RSTK(PT)
  25.       GO TO (99, 99, 99, 99, 99, 99, 99, 01, 01, 25,
  26.      .       45, 65, 99, 99, 99, 55, 75, 32, 37), R
  27. C
  28. 01    CONTINUE
  29.       IF (SYM.EQ.NUM .OR. SYM.EQ.QUOTE .OR. SYM.EQ.LESS) GO TO 10
  30.       IF (SYM.EQ.GREAT) GO TO 30
  31.       EXCNT = 0
  32.       IF (SYM.EQ.NAME) GO TO 40
  33.       ID(1) = BLANK
  34.       IF (SYM.EQ.LPAREN) GO TO 42
  35.       CALL ERROR (2)
  36.       IF (ERR.GT.0) RETURN
  37. C
  38. C ***      PUT SOMETHING ON THE STACK
  39. 10    CONTINUE
  40.       L = 1
  41.       IF (TOP.GT.0) L = LSTK(TOP)+MSTK(TOP)*NSTK(TOP)
  42.       IF (TOP+1.GE.BOT) CALL ERROR (18)
  43.       IF (ERR.GT.0) RETURN
  44.       TOP = TOP+1
  45.       LSTK(TOP) = L
  46.       IF (SYM.EQ.QUOTE) GO TO 15
  47.       IF (SYM.EQ.LESS) GO TO 20
  48. C
  49. C ***      SINGLE NUMBER, GETSYM STORED IT IN STKI
  50.       MSTK(TOP) = 1
  51.       NSTK(TOP) = 1
  52.       STKR(L) = STKI(VSIZE)
  53.       STKI(L) = 0.0D0
  54.       CALL GETSYM
  55.       GO TO 60
  56. C
  57. C ***      STRING
  58. 15    CONTINUE
  59.       N = 0
  60.       LPT(4) = LPT(3)
  61.       CALL GETCH
  62. C
  63. 16    CONTINUE
  64.       IF (CHAR.EQ.QUOTE) GO TO 18
  65. C
  66. 17    CONTINUE
  67.       LN = L+N
  68.       IF (CHAR.EQ.EOL) CALL ERROR (31)
  69.       IF (ERR.GT.0) RETURN
  70.       STKR(LN) = DFLOAT (CHAR)
  71.       STKI(LN) = 0.0D0
  72.       N = N+1
  73.       CALL GETCH
  74.       GO TO 16
  75. C
  76. 18    CONTINUE
  77.       CALL GETCH
  78.       IF (CHAR.EQ.QUOTE) GO TO 17
  79.       IF (N.LE.0) CALL ERROR (31)
  80.       IF (ERR.GT.0) RETURN
  81.       MSTK(TOP) = 1
  82.       NSTK(TOP) = N
  83.       CALL GETSYM
  84.       GO TO 60
  85. C
  86. C ***      EXPLICIT MATRIX
  87. 20    CONTINUE
  88.       MSTK(TOP) = 0
  89.       NSTK(TOP) = 0
  90. C
  91. 21    CONTINUE
  92.       TOP = TOP+1
  93.       LSTK(TOP) = LSTK(TOP-1)+MSTK(TOP-1)*NSTK(TOP-1)
  94.       MSTK(TOP) = 0
  95.       NSTK(TOP) = 0
  96.       CALL GETSYM
  97. C
  98. 22    CONTINUE
  99.       IF (SYM.EQ.SEMI .OR. SYM.EQ.GREAT .OR. SYM.EQ.EOL) GO TO 27
  100.       IF (SYM.EQ.COMMA) CALL GETSYM
  101.       PT = PT+1
  102.       RSTK(PT) = 10
  103. C *CALL* EXPR
  104.       RETURN
  105. C
  106. 25    CONTINUE
  107.       PT = PT-1
  108.       TOP = TOP-1
  109.       IF (MSTK(TOP).EQ.0) MSTK(TOP) = MSTK(TOP+1)
  110.       IF (MSTK(TOP).NE.MSTK(TOP+1)) CALL ERROR (5)
  111.       IF (ERR.GT.0) RETURN
  112.       NSTK(TOP) = NSTK(TOP)+NSTK(TOP+1)
  113.       GO TO 22
  114. C
  115. 27    CONTINUE
  116.       IF (SYM.EQ.SEMI .AND. CHAR.EQ.EOL) CALL GETSYM
  117.       CALL STACK1 (QUOTE)
  118.       IF (ERR.GT.0) RETURN
  119.       TOP = TOP-1
  120.       IF (MSTK(TOP).EQ.0) MSTK(TOP) = MSTK(TOP+1)
  121.       IF (MSTK(TOP).NE.MSTK(TOP+1) .AND. MSTK(TOP+1).GT.0)
  122.      .      CALL ERROR (6)
  123.       IF (ERR.GT.0) RETURN
  124.       NSTK(TOP) = NSTK(TOP)+NSTK(TOP+1)
  125.       IF (SYM.EQ.EOL) CALL GETLIN
  126.       IF (SYM.NE.GREAT) GO TO 21
  127.       CALL STACK1 (QUOTE)
  128.       IF (ERR.GT.0) RETURN
  129.       CALL GETSYM
  130.       GO TO 60
  131. C
  132. C ***      MACRO STRING
  133. 30    CONTINUE
  134.       CALL GETSYM
  135.       IF (SYM.EQ.LESS .AND. CHAR.EQ.EOL) CALL ERROR (28)
  136.       IF (ERR.GT.0) RETURN
  137.       PT = PT+1
  138.       RSTK(PT) = 18
  139. C *CALL* EXPR
  140.       RETURN
  141. C
  142. 32    CONTINUE
  143.       PT = PT-1
  144.       IF (SYM.NE.LESS .AND. SYM.NE.EOL) CALL ERROR (37)
  145.       IF (ERR.GT.0) RETURN
  146.       IF (SYM.EQ.LESS) CALL GETSYM
  147.       K = LPT(6)
  148.       LIN(K+1) = LPT(1)
  149.       LIN(K+2) = LPT(2)
  150.       LIN(K+3) = LPT(6)
  151.       LPT(1) = K+4
  152. C
  153. C ***      TRANSFER STACK TO INPUT LINE
  154.       K = LPT(1)
  155.       L = LSTK(TOP)
  156.       N = MSTK(TOP)*NSTK(TOP)
  157.       DO 34 J = 1, N
  158.         LS = L+J-1
  159.         LIN(K) = IDINT (STKR(LS))
  160.         IF (LIN(K).LT.0 .OR. LIN(K).GE.ALFL) CALL ERROR (37)
  161.         IF (ERR.GT.0) RETURN
  162.         IF (K.LT.1024) K = K+1
  163.         IF (K.EQ.1024) WRITE (WTE, 33) K
  164. 33      FORMAT (' INPUT BUFFER LIMIT IS ', I4, ' CHARACTERS.')
  165. 34    CONTINUE
  166.       TOP = TOP-1
  167.       LIN(K) = EOL
  168.       LPT(6) = K
  169.       LPT(4) = LPT(1)
  170.       LPT(3) = 0
  171.       LPT(2) = 0
  172.       LCT(1) = 0
  173.       CHAR = BLANK
  174.       CALL GETSYM
  175.       PT = PT+1
  176.       RSTK(PT) = 19
  177. C *CALL* EXPR
  178.       RETURN
  179. C
  180. 37    CONTINUE
  181.       PT = PT-1
  182.       K = LPT(1)-4
  183.       LPT(1) = LIN(K+1)
  184.       LPT(4) = LIN(K+2)
  185.       LPT(6) = LIN(K+3)
  186.       CHAR = BLANK
  187.       CALL GETSYM
  188.       GO TO 60
  189. C
  190. C ***      FUNCTION OR MATRIX ELEMENT
  191. 40    CONTINUE
  192.       CALL PUTID (ID, SYN)
  193.       CALL GETSYM
  194.       IF (SYM.EQ.LPAREN) GO TO 42
  195.       RHS = 0
  196.       CALL FUNS (ID)
  197.       IF (FIN.NE.0) CALL ERROR (25)
  198.       IF (ERR.GT.0) RETURN
  199.       CALL STACKG (ID)
  200.       IF (ERR.GT.0) RETURN
  201.       IF (FIN.EQ.7) GO TO 50
  202.       IF (FIN.EQ.0) CALL PUTID (IDS(1,PT+1), ID)
  203.       IF (FIN.EQ.0) CALL ERROR (4)
  204.       IF (ERR.GT.0) RETURN
  205.       GO TO 60
  206. C
  207. 42    CONTINUE
  208.       CALL GETSYM
  209.       EXCNT = EXCNT+1
  210.       PT = PT+1
  211.       PSTK(PT) = EXCNT
  212.       CALL PUTID (IDS(1,PT), ID)
  213.       RSTK(PT) = 11
  214. C *CALL* EXPR
  215.       RETURN
  216. C
  217. 45    CONTINUE
  218.       CALL PUTID (ID, IDS(1,PT))
  219.       EXCNT = PSTK(PT)
  220.       PT = PT-1
  221.       IF (SYM.EQ.COMMA) GO TO 42
  222.       IF (SYM.NE.RPAREN) CALL ERROR (3)
  223.       IF (ERR.GT.0) RETURN
  224.       IF (SYM.EQ.RPAREN) CALL GETSYM
  225.       IF (ID(1).EQ.BLANK) GO TO 60
  226.       RHS = EXCNT
  227.       CALL STACKG (ID)
  228.       IF (ERR.GT.0) RETURN
  229.       IF (FIN.EQ.0) CALL FUNS (ID)
  230.       IF (FIN.EQ.0) CALL ERROR (4)
  231.       IF (ERR.GT.0) RETURN
  232. C
  233. C ***      EVALUATE MATRIX FUNCTION
  234. 50    CONTINUE
  235.       PT = PT+1
  236.       RSTK(PT) = 16
  237. C     *CALL* MATFN
  238.       RETURN
  239. C
  240. 55    CONTINUE
  241.       PT = PT-1
  242.       GO TO 60
  243. C
  244. C ***      CHECK FOR QUOTE (TRANSPOSE) AND ** (POWER)
  245. 60    CONTINUE
  246.       IF (SYM.NE.QUOTE) GO TO 62
  247.       I = LPT(3)-2
  248.       IF (LIN(I).EQ.BLANK) GO TO 90
  249.       CALL STACK1 (QUOTE)
  250.       IF (ERR.GT.0) RETURN
  251.       CALL GETSYM
  252. 62    CONTINUE
  253.       IF (SYM.NE.STAR .OR. CHAR.NE.STAR) GO TO 90
  254.       CALL GETSYM
  255.       CALL GETSYM
  256.       PT = PT+1
  257.       RSTK(PT) = 12
  258. C *CALL* FACTOR
  259.       GO TO 01
  260. C
  261. 65    CONTINUE
  262.       PT = PT-1
  263.       CALL STACK2 (DSTAR)
  264.       IF (ERR.GT.0) RETURN
  265.       IF (FUN.NE.2) GO TO 90
  266. C
  267. C ***      MATRIX POWER, USE EIGENVECTORS
  268.       PT = PT+1
  269.       RSTK(PT) = 17
  270. C *CALL* MATFN
  271.       RETURN
  272. C
  273. 75    CONTINUE
  274.       PT = PT-1
  275. C
  276. 90    CONTINUE
  277.       RETURN
  278. C
  279. 99    CONTINUE
  280.       CALL ERROR (22)
  281.       IF (ERR.GT.0) RETURN
  282. C
  283.       RETURN
  284.       END
  285.