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 / stackp.for < prev    next >
Encoding:
Text File  |  1991-04-13  |  5.1 KB  |  214 lines
  1.       SUBROUTINE STACKP (ID)
  2.       IMPLICIT NONE
  3. C
  4. C PUT VARIABLES INTO STORAGE
  5. C
  6.       INTEGER ID(4)
  7. C
  8.       INCLUDE MATLAB$KOM:SIZEPARMS.INC
  9.       INCLUDE MATLAB$KOM:VSTK.KOM
  10.       INCLUDE MATLAB$KOM:IOP.KOM
  11.       INCLUDE MATLAB$KOM:COM.KOM
  12. C
  13.       INTEGER SEMI, I, IB, J, K, KM1, N, NK, NT
  14.       INTEGER L, L1, L2, LI, LJ, LK, LL, LS, LT
  15.       INTEGER M, M1, M2, MK, MN, MN1, MN2, MNK, MT
  16. C
  17.       LOGICAL EQID
  18. C
  19.       DATA SEMI / 39 /
  20. C
  21. C
  22.       IF (DDT.EQ.1) WRITE (WTE, 100) ID
  23. 100   FORMAT (' STACKP', 4I4)
  24.       IF (TOP.LE.0) CALL ERROR (1)
  25.       IF (ERR.GT.0) RETURN
  26.       CALL FUNS (ID)
  27.       IF (FIN.NE.0) CALL ERROR (25)
  28.       IF (ERR.GT.0) RETURN
  29.       M = MSTK(TOP)
  30.       N = NSTK(TOP)
  31.       IF (M.GT.0) L = LSTK(TOP)
  32.       IF (M.LT.0) CALL ERROR (14)
  33.       IF (ERR.GT.0) RETURN
  34.       IF (M.EQ.0 .AND. N.NE.0) GO TO 99
  35.       MN = M*N
  36.       LK = 0
  37.       MK = 1
  38.       NK = 0
  39.       LT = 0
  40.       MT = 0
  41.       NT = 0
  42. C
  43. C ***      DOES VARIABLE ALREADY EXIST
  44.       CALL PUTID (IDSTK(1,BOT-1), ID)
  45.       K = LSIZE+1
  46. 05    CONTINUE
  47.       K = K-1
  48.       IF (.NOT.EQID (IDSTK(1,K), ID)) GO TO 05
  49.       IF (K.EQ.BOT-1) GO TO 30
  50.       LK = LSTK(K)
  51.       MK = MSTK(K)
  52.       NK = NSTK(K)
  53.       MNK = MK*NK
  54.       IF (RHS.EQ.0) GO TO 20
  55.       IF (RHS.GT.2) CALL ERROR (15)
  56.       IF (ERR.GT.0) RETURN
  57.       MT = MK
  58.       NT = NK
  59.       LT = L+MN
  60.       ERR = LT+MNK-LSTK(BOT)
  61.       IF (ERR.GT.0) CALL ERROR (17)
  62.       IF (ERR.GT.0) RETURN
  63.       CALL WCOPY (MNK, STKR(LK), STKI(LK), 1, STKR(LT), STKI(LT), 1)
  64. C
  65. C ***      DOES IT FIT
  66. 20    CONTINUE
  67.       IF (RHS.EQ.0 .AND. MN.EQ.MNK) GO TO 40
  68.       IF (K.GE.LSIZE-3) CALL ERROR (13)
  69.       IF (ERR.GT.0) RETURN
  70. C
  71. C ***      SHIFT STORAGE
  72.       IF (K.EQ.BOT) GO TO 25
  73.       LS = LSTK(BOT)
  74.       LL = LS+MNK
  75.       CALL WCOPY (LK-LS, STKR(LS), STKI(LS), -1,
  76.      .                   STKR(LL), STKI(LL), -1)
  77.       KM1 = K-1
  78.       DO 24 IB = BOT, KM1
  79.         I = BOT+KM1-IB
  80.         CALL PUTID (IDSTK(1,I+1), IDSTK(1,I))
  81.         MSTK(I+1) = MSTK(I)
  82.         NSTK(I+1) = NSTK(I)
  83.         LSTK(I+1) = LSTK(I)+MNK
  84. 24    CONTINUE
  85. C
  86. C ***      DESTROY OLD VARIABLE
  87. 25    CONTINUE
  88.       BOT = BOT+1
  89. C
  90. C ***      CREATE NEW VARIABLE
  91. 30    CONTINUE
  92.       IF (MN.EQ.0) GO TO 99
  93.       IF (BOT-2.LE.TOP) CALL ERROR (18)
  94.       IF (ERR.GT.0) RETURN
  95.       K = BOT-1
  96.       CALL PUTID (IDSTK(1,K), ID)
  97.       IF (RHS.EQ.1) GO TO 50
  98.       IF (RHS.EQ.2) GO TO 55
  99. C
  100. C ***      STORE
  101. 40    CONTINUE
  102.       IF (K.LT.LSIZE) LSTK(K) = LSTK(K+1)-MN
  103.       MSTK(K) = M
  104.       NSTK(K) = N
  105.       LK = LSTK(K)
  106.       CALL WCOPY (MN, STKR(L), STKI(L), -1, STKR(LK), STKI(LK), -1)
  107.       GO TO 90
  108. C
  109. C ***      VECT(ARG)
  110. 50    CONTINUE
  111.       IF (MSTK(TOP-1).LT.0) GO TO 59
  112.       MN1 = 1
  113.       MN2 = 1
  114.       L1 = 0
  115.       L2 = 0
  116.       IF (N.NE.1 .OR. NK.NE.1) GO TO 52
  117.       L1 = LSTK(TOP-1)
  118.       M1 = MSTK(TOP-1)
  119.       MN1 = M1*NSTK(TOP-1)
  120.       M2 = -1
  121.       GO TO 60
  122. C
  123. 52    CONTINUE
  124.       IF (M.NE.1 .OR. MK.NE.1) CALL ERROR (15)
  125.       IF (ERR.GT.0) RETURN
  126.       L2 = LSTK(TOP-1)
  127.       M2 = MSTK(TOP-1)
  128.       MN2 = M2*NSTK(TOP-1)
  129.       M1 = -1
  130.       GO TO 60
  131. C
  132. C ***      MATRIX(ARG,ARG)
  133. 55    CONTINUE
  134.       IF (MSTK(TOP-1).LT.0 .AND. MSTK(TOP-2).LT.0) GO TO 59
  135.       L2 = LSTK(TOP-1)
  136.       M2 = MSTK(TOP-1)
  137.       MN2 = M2*NSTK(TOP-1)
  138.       IF (M2.LT.0) MN2 = N
  139.       L1 = LSTK(TOP-2)
  140.       M1 = MSTK(TOP-2)
  141.       MN1 = M1*NSTK(TOP-2)
  142.       IF (M1.LT.0) MN1 = M
  143.       GO TO 60
  144. C
  145. 59    CONTINUE
  146.       IF (MN.NE.MNK) CALL ERROR (15)
  147.       IF (ERR.GT.0) RETURN
  148.       LK = LSTK(K)
  149.       CALL WCOPY (MN, STKR(L), STKI(L), -1, STKR(LK), STKI(LK), -1)
  150.       GO TO 90
  151. C
  152. 60    CONTINUE
  153.       IF (MN1.NE.M .OR. MN2.NE.N) CALL ERROR (15)
  154.       IF (ERR.GT.0) RETURN
  155.       LL = 1
  156.       IF (M1.LT.0) GO TO 62
  157.       DO 61 I = 1, MN1
  158.         LS = L1+I-1
  159.         MK = MAX0 (MK, IDINT (STKR(LS)))
  160.         LL = MIN0 (LL, IDINT (STKR(LS)))
  161. 61    CONTINUE
  162. 62    CONTINUE
  163.       MK = MAX0 (MK, M)
  164.       IF (M2.LT.0) GO TO 64
  165.       DO 63 I = 1, MN2
  166.         LS = L2+I-1
  167.         NK = MAX0 (NK, IDINT (STKR(LS)))
  168.         LL = MIN0 (LL, IDINT (STKR(LS)))
  169. 63    CONTINUE
  170. 64    CONTINUE
  171.       NK = MAX0 (NK, N)
  172.       IF (LL.LT.1) CALL ERROR (21)
  173.       IF (ERR.GT.0) RETURN
  174.       MNK = MK*NK
  175.       LK = LSTK(K+1)-MNK
  176.       ERR = LT+MT*NT-LK
  177.       IF (ERR.GT.0) CALL ERROR (17)
  178.       IF (ERR.GT.0) RETURN
  179.       LSTK(K) = LK
  180.       MSTK(K) = MK
  181.       NSTK(K) = NK
  182.       CALL WSET (MNK, 0.0D0, 0.0D0, STKR(LK), STKI(LK), 1)
  183.       IF (NT.LT.1) GO TO 67
  184.       DO 66 J = 1, NT
  185.         LS = LT+(J-1)*MT
  186.         LL = LK+(J-1)*MK
  187.         CALL WCOPY (MT, STKR(LS), STKI(LS), -1, STKR(LL), STKI(LL), -1)
  188. 66    CONTINUE
  189. 67    CONTINUE
  190.       DO 68 J = 1, N
  191.       DO 68 I = 1, M
  192.         LI = L1+I-1
  193.         IF (M1.GT.0) LI = L1+IDINT (STKR(LI))-1
  194.         LJ = L2+J-1
  195.         IF (M2.GT.0) LJ = L2+IDINT (STKR(LJ))-1
  196.         LL = LK+LI-L1+(LJ-L2)*MK
  197.         LS = L+I-1+(J-1)*M
  198.         STKR(LL) = STKR(LS)
  199.         STKI(LL) = STKI(LS)
  200. 68    CONTINUE
  201.       GO TO 90
  202. C
  203. C ***      PRINT IF DESIRED AND POP STACK
  204. 90    CONTINUE
  205.       IF (SYM.NE.SEMI .AND. LCT(3).EQ.0) CALL PRINT (ID, K)
  206.       IF (SYM.EQ.SEMI .AND. LCT(3).EQ.1) CALL PRINT (ID, K)
  207.       IF (K.EQ.BOT-1) BOT = BOT-1
  208. 99    CONTINUE
  209.       IF (M.NE.0) TOP = TOP-1-RHS
  210.       IF (M.EQ.0) TOP = TOP-1
  211. C
  212.       RETURN
  213.       END
  214.