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 / stack2.for < prev    next >
Encoding:
Text File  |  1991-04-13  |  7.8 KB  |  317 lines
  1.       SUBROUTINE STACK2 (OP)
  2.       IMPLICIT NONE
  3. C
  4. C BINARY AND TERNARY OPERATIONS
  5. C
  6.       INTEGER OP
  7. C
  8.       INCLUDE MATLAB$KOM:SIZEPARMS.INC
  9.       INCLUDE MATLAB$KOM:VSTK.KOM
  10.       INCLUDE MATLAB$KOM:RECU.KOM
  11.       INCLUDE MATLAB$KOM:IOP.KOM
  12.       INCLUDE MATLAB$KOM:COM.KOM
  13. C
  14.       DOUBLE PRECISION SR, SI, E1, ST, E2
  15.       INTEGER I, J, K, K1, K2, KEXP, M, M2, MN, N, N2, NEXP
  16.       INTEGER L, L1, L2, L3, LL, LS
  17.       INTEGER PLUS, MINUS, STAR, DSTAR, SLASH, BSLASH, DOT, COLON
  18. C
  19.       DOUBLE PRECISION WDOTUR, WDOTUI, FLOP, DFLOAT
  20. C
  21.       DATA PLUS / 41 /, MINUS / 42 /, STAR / 43 /, DSTAR / 54 /
  22.       DATA SLASH / 44 /, BSLASH / 45 /, DOT / 47 /, COLON / 40 /
  23. C
  24. C
  25.       IF (DDT.EQ.1) WRITE (WTE, 100) OP
  26. 100   FORMAT (' STACK2', I4)
  27.       L2 = LSTK(TOP)
  28.       M2 = MSTK(TOP)
  29.       N2 = NSTK(TOP)
  30.       TOP = TOP-1
  31.       L = LSTK(TOP)
  32.       M = MSTK(TOP)
  33.       N = NSTK(TOP)
  34.       FUN = 0
  35.       IF (OP.EQ.PLUS) GO TO 01
  36.       IF (OP.EQ.MINUS) GO TO 03
  37.       IF (OP.EQ.STAR) GO TO 05
  38.       IF (OP.EQ.DSTAR) GO TO 30
  39.       IF (OP.EQ.SLASH) GO TO 20
  40.       IF (OP.EQ.BSLASH) GO TO 25
  41.       IF (OP.EQ.COLON) GO TO 60
  42.       IF (OP.GT.2*DOT) GO TO 80
  43.       IF (OP.GT.DOT) GO TO 70
  44. C
  45. C ***      ADDITION
  46. 01    CONTINUE
  47.       IF (M.LT.0) GO TO 50
  48.       IF (M2.LT.0) GO TO 52
  49.       IF (M.NE.M2) CALL ERROR (8)
  50.       IF (ERR.GT.0) RETURN
  51.       IF (N.NE.N2) CALL ERROR (8)
  52.       IF (ERR.GT.0) RETURN
  53.       CALL WAXPY (M*N, 1.0D0, 0.0D0, STKR(L2), STKI(L2), 1,
  54.      .                               STKR(L), STKI(L), 1)
  55.       GO TO 99
  56. C
  57. C ***      SUBTRACTION
  58. 03    CONTINUE
  59.       IF (M.LT.0) GO TO 54
  60.       IF (M2.LT.0) GO TO 56
  61.       IF (M.NE.M2) CALL ERROR (9)
  62.       IF (ERR.GT.0) RETURN
  63.       IF (N.NE.N2) CALL ERROR (9)
  64.       IF (ERR.GT.0) RETURN
  65.       CALL WAXPY (M*N, -1.0D0, 0.0D0, STKR(L2), STKI(L2), 1,
  66.      .                                STKR(L), STKI(L), 1)
  67.       GO TO 99
  68. C
  69. C ***      MULTIPLICATION
  70. 05    CONTINUE
  71.       IF (M2*M2*N2.EQ.1) GO TO 10
  72.       IF (M*N.EQ.1) GO TO 11
  73.       IF (M2*N2.EQ.1) GO TO 10
  74.       IF (N.NE.M2) CALL ERROR (10)
  75.       IF (ERR.GT.0) RETURN
  76.       MN = M*N2
  77.       LL = L+MN
  78.       ERR = LL+M*N+M2*N2-LSTK(BOT)
  79.       IF (ERR.GT.0) CALL ERROR (17)
  80.       IF (ERR.GT.0) RETURN
  81.       CALL WCOPY (M*N+M2*N2, STKR(L), STKI(L), -1,
  82.      .                       STKR(LL), STKI(LL), -1)
  83.       DO 09 J = 1, N2
  84.         DO 08 I = 1, M
  85.           K1 = L+MN+(I-1)
  86.           K2 = L2+MN+(J-1)*M2
  87.           K = L+(I-1)+(J-1)*M
  88.           STKR(K) = WDOTUR (N, STKR(K1), STKI(K1),
  89.      .                      M, STKR(K2), STKI(K2), 1)
  90.           STKI(K) = WDOTUI (N, STKR(K1), STKI(K1),
  91.      .                      M, STKR(K2), STKI(K2), 1)
  92. 08      CONTINUE
  93. 09    CONTINUE
  94.       NSTK(TOP) = N2
  95.       GO TO 99
  96. C
  97. C ***      MULTIPLICATION BY SCALAR
  98. 10    CONTINUE
  99.       SR = STKR(L2)
  100.       SI = STKI(L2)
  101.       L1 = L
  102.       GO TO 13
  103. C
  104. 11    CONTINUE
  105.       SR = STKR(L)
  106.       SI = STKI(L)
  107.       L1 = L+1
  108.       MSTK(TOP) = M2
  109.       NSTK(TOP) = N2
  110. 13    CONTINUE
  111.       MN = MSTK(TOP)*NSTK(TOP)
  112.       CALL WSCAL (MN, SR, SI, STKR(L1), STKI(L1), 1)
  113.       IF (L1.NE.L) CALL WCOPY (MN, STKR(L1), STKI(L1), 1,
  114.      .                             STKR(L), STKI(L), 1)
  115.       GO TO 99
  116. C
  117. C ***      RIGHT DIVISION
  118. 20    CONTINUE
  119.       IF (M2*N2.EQ.1) GO TO 21
  120.       IF (M2.EQ.N2) FUN = 1
  121.       IF (M2.NE.N2) FUN = 4
  122.       FIN = -1
  123.       RHS = 2
  124.       GO TO 99
  125. C
  126. 21    CONTINUE
  127.       SR = STKR(L2)
  128.       SI = STKI(L2)
  129.       MN = M*N
  130.       DO 22 I = 1, MN
  131.         LL = L+I-1
  132.         CALL WDIV (STKR(LL), STKI(LL), SR, SI, STKR(LL), STKI(LL))
  133.         IF (ERR.GT.0) RETURN
  134. 22    CONTINUE
  135.       GO TO 99
  136. C
  137. C ***      LEFT DIVISION
  138. 25    CONTINUE
  139.       IF (M*N.EQ.1) GO TO 26
  140.       IF (M.EQ.N) FUN = 1
  141.       IF (M.NE.N) FUN = 4
  142.       FIN = -2
  143.       RHS = 2
  144.       GO TO 99
  145. C
  146. 26    CONTINUE
  147.       SR = STKR(L)
  148.       SI = STKI(L)
  149.       MSTK(TOP) = M2
  150.       NSTK(TOP) = N2
  151.       MN = M2*N2
  152.       DO 27 I = 1, MN
  153.         LL = L+I-1
  154.         CALL WDIV (STKR(LL+1), STKI(LL+1), SR, SI, STKR(LL), STKI(LL))
  155.         IF (ERR.GT.0) RETURN
  156. 27    CONTINUE
  157.       GO TO 99
  158. C
  159. C ***      POWER
  160. 30    CONTINUE
  161.       IF (M2*N2.NE.1) CALL ERROR (30)
  162.       IF (ERR.GT.0) RETURN
  163.       IF (M.NE.N) CALL ERROR (20)
  164.       IF (ERR.GT.0) RETURN
  165.       NEXP = IDINT (STKR(L2))
  166.       IF (STKR(L2).NE.DFLOAT (NEXP)) GO TO 39
  167.       IF (STKI(L2).NE.0.0D0) GO TO 39
  168.       IF (NEXP.LT.2) GO TO 39
  169.       MN = M*N
  170.       ERR = L2+MN+N-LSTK(BOT)
  171.       IF (ERR.GT.0) CALL ERROR (17)
  172.       IF (ERR.GT.0) RETURN
  173.       CALL WCOPY (MN, STKR(L), STKI(L), 1, STKR(L2), STKI(L2), 1)
  174.       L3 = L2+MN
  175.       DO 36 KEXP = 2, NEXP
  176.         DO 35 J = 1, N
  177.           LS = L+(J-1)*N
  178.           CALL WCOPY (N, STKR(LS), STKI(LS), 1, STKR(L3), STKI(L3), 1)
  179.           DO 34 I = 1, N
  180.             LS = L2+I-1
  181.             LL = L+I-1+(J-1)*N
  182.             STKR(LL) = WDOTUR (N, STKR(LS), STKI(LS),
  183.      .                         N, STKR(L3), STKI(L3), 1)
  184.             STKI(LL) = WDOTUI (N, STKR(LS), STKI(LS),
  185.      .                         N, STKR(L3), STKI(L3), 1)
  186. 34        CONTINUE
  187. 35      CONTINUE
  188. 36    CONTINUE
  189.       GO TO 99
  190. C
  191. C ***      NONINTEGER OR NONPOSITIVE POWER, USE EIGENVECTORS
  192. 39    CONTINUE
  193.       FUN = 2
  194.       FIN = 0
  195.       GO TO 99
  196. C
  197. C ***      ADD OR SUBTRACT SCALAR
  198. 50    CONTINUE
  199.       IF (M2.NE.N2) CALL ERROR (8)
  200.       IF (ERR.GT.0) RETURN
  201.       M = M2
  202.       N = N2
  203.       MSTK(TOP) = M
  204.       NSTK(TOP) = N
  205.       SR = STKR(L)
  206.       SI = STKI(L)
  207.       CALL WCOPY (M*N, STKR(L+1), STKI(L+1), 1, STKR(L), STKI(L), 1)
  208.       GO TO 58
  209. C
  210. 52    CONTINUE
  211.       IF (M.NE.N) CALL ERROR (8)
  212.       IF (ERR.GT.0) RETURN
  213.       SR = STKR(L2)
  214.       SI = STKI(L2)
  215.       GO TO 58
  216. C
  217. 54    CONTINUE
  218.       IF (M2.NE.N2) CALL ERROR (9)
  219.       IF (ERR.GT.0) RETURN
  220.       M = M2
  221.       N = N2
  222.       MSTK(TOP) = M
  223.       NSTK(TOP) = N
  224.       SR = STKR(L)
  225.       SI = STKI(L)
  226.       CALL WCOPY (M*N, STKR(L+1), STKI(L+1), 1, STKR(L), STKI(L), 1)
  227.       CALL WRSCAL (M*N, -1.0D0, STKR(L), STKI(L), 1)
  228.       GO TO 58
  229. C
  230. 56    CONTINUE
  231.       IF (M.NE.N) CALL ERROR (9)
  232.       IF (ERR.GT.0) RETURN
  233.       SR = -STKR(L2)
  234.       SI = -STKI(L2)
  235.       GO TO 58
  236. C
  237. 58    CONTINUE
  238.       DO 59 I = 1, N
  239.         LL = L+(I-1)*(N+1)
  240.         STKR(LL) = FLOP (STKR(LL)+SR)
  241.         STKI(LL) = FLOP (STKI(LL)+SI)
  242. 59    CONTINUE
  243.       GO TO 99
  244. C
  245. C ***      COLON
  246. 60    CONTINUE
  247.       E2 = STKR(L2)
  248.       ST = 1.0D0
  249.       N = 0
  250.       IF (RHS.LT.3) GO TO 61
  251.       ST = STKR(L)
  252.       TOP = TOP-1
  253.       L = LSTK(TOP)
  254.       IF (ST.EQ.0.0D0) GO TO 63
  255. 61    CONTINUE
  256.       E1 = STKR(L)
  257. C
  258. C ***      CHECK FOR CLAUSE
  259.       IF (RSTK(PT).EQ.3) GO TO 64
  260.       ERR = L+MAX0 (3, IDINT ((E2-E1)/ST))-LSTK(BOT)
  261.       IF (ERR.GT.0) CALL ERROR (17)
  262.       IF (ERR.GT.0) RETURN
  263. 62    CONTINUE
  264.       IF (ST.GT.0.0D0 .AND. STKR(L).GT.E2) GO TO 63
  265.       IF (ST.LT.0.0D0 .AND. STKR(L).LT.E2) GO TO 63
  266.       N = N+1
  267.       L = L+1
  268.       STKR(L) = E1+DFLOAT (N)*ST
  269.       STKI(L) = 0.0D0
  270.       GO TO 62
  271. C
  272. 63    CONTINUE
  273.       NSTK(TOP) = N
  274.       MSTK(TOP) = 1
  275.       IF (N.EQ.0) MSTK(TOP) = 0
  276.       GO TO 99
  277. C
  278. C ***      FOR CLAUSE
  279. 64    CONTINUE
  280.       STKR(L) = E1
  281.       STKR(L+1) = ST
  282.       STKR(L+2) = E2
  283.       MSTK(TOP) = -3
  284.       NSTK(TOP) = -1
  285.       GO TO 99
  286. C
  287. C ***      ELEMENTWISE OPERATIONS
  288. 70    CONTINUE
  289.       OP = OP-DOT
  290.       IF (M.NE.M2 .OR. N.NE.N2) CALL ERROR (10)
  291.       IF (ERR.GT.0) RETURN
  292.       MN = M*N
  293.       DO 72 I = 1, MN
  294.         J = L+I-1
  295.         K = L2+I-1
  296.         IF (OP.EQ.STAR) CALL WMUL (STKR(J), STKI(J), STKR(K),
  297.      .                             STKI(K), STKR(J), STKI(J))
  298.         IF (OP.EQ.SLASH) CALL WDIV (STKR(J), STKI(J), STKR(K),
  299.      .                              STKI(K), STKR(J), STKI(J))
  300.         IF (OP.EQ.BSLASH) CALL WDIV (STKR(K), STKI(K), STKR(J),
  301.      .                               STKI(J), STKR(J), STKI(J))
  302.         IF (ERR.GT.0) RETURN
  303. 72    CONTINUE
  304.       GO TO 99
  305. C
  306. C ***      KRONECKER
  307. 80    CONTINUE
  308.       FIN = OP-2*DOT-STAR+11
  309.       FUN = 6
  310.       TOP = TOP+1
  311.       RHS = 2
  312.       GO TO 99
  313. C
  314. 99    CONTINUE
  315.       RETURN
  316.       END
  317.