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 / stackg.for < prev    next >
Encoding:
Text File  |  1991-04-13  |  2.9 KB  |  122 lines
  1.       SUBROUTINE STACKG (ID)
  2.       IMPLICIT NONE
  3. C
  4. C GET VARIABLES FROM 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 I, J, K, L, L2, L3, LI, LJ, LK, LL, LS, M, MK, MN, MNK, N
  14. C
  15.       LOGICAL EQID
  16. C
  17. C
  18.       IF (DDT.EQ.1) WRITE (WTE, 100) ID
  19. 100   FORMAT (' STACKG', 4I4)
  20.       CALL PUTID (IDSTK(1,BOT-1), ID)
  21.       K = LSIZE+1
  22. 10    CONTINUE
  23.       K = K-1
  24.       IF (.NOT.EQID (IDSTK(1,K), ID)) GO TO 10
  25.       IF (K.GE.LSIZE-1 .AND. RHS.GT.0) GO TO 98
  26.       IF (K.EQ.BOT-1) GO TO 98
  27.       LK = LSTK(K)
  28.       IF (RHS.EQ.1) GO TO 40
  29.       IF (RHS.EQ.2) GO TO 60
  30.       IF (RHS.GT.2) CALL ERROR (21)
  31.       IF (ERR.GT.0) RETURN
  32.       L = 1
  33.       IF (TOP.GT.0) L = LSTK(TOP)+MSTK(TOP)*NSTK(TOP)
  34.       IF (TOP+1.GE.BOT) CALL ERROR (18)
  35.       IF (ERR.GT.0) RETURN
  36.       TOP = TOP+1
  37. C
  38. C ***      LOAD VARIABLE TO TOP OF STACK
  39.       LSTK(TOP) = L
  40.       MSTK(TOP) = MSTK(K)
  41.       NSTK(TOP) = NSTK(K)
  42.       MN = MSTK(K)*NSTK(K)
  43.       ERR = L+MN-LSTK(BOT)
  44.       IF (ERR.GT.0) CALL ERROR (17)
  45.       IF (ERR.GT.0) RETURN
  46. C
  47. C ***      IF RAND, MATFN6 GENERATES RANDOM NUMBER
  48.       IF (K.EQ.LSIZE) GO TO 97
  49.       CALL WCOPY (MN, STKR(LK), STKI(LK), 1, STKR(L), STKI(L), 1)
  50.       GO TO 99
  51. C
  52. C ***      VECT(ARG)
  53. 40    CONTINUE
  54.       IF (MSTK(TOP).EQ.0) GO TO 99
  55.       L = LSTK(TOP)
  56.       MN = MSTK(TOP)*NSTK(TOP)
  57.       MNK = MSTK(K)*NSTK(K)
  58.       IF (MSTK(TOP).LT.0) MN = MNK
  59.       DO 50 I = 1, MN
  60.         LL = L+I-1
  61.         LS = LK+I-1
  62.         IF (MSTK(TOP).GT.0) LS = LK+IDINT (STKR(LL))-1
  63.         IF (LS.LT.LK .OR. LS.GE.LK+MNK) CALL ERROR (21)
  64.         IF (ERR.GT.0) RETURN
  65.         STKR(LL) = STKR(LS)
  66.         STKI(LL) = STKI(LS)
  67. 50    CONTINUE
  68.       MSTK(TOP) = 1
  69.       NSTK(TOP) = 1
  70.       IF (MSTK(K).GT.1) MSTK(TOP) = MN
  71.       IF (MSTK(K).EQ.1) NSTK(TOP) = MN
  72.       GO TO 99
  73. C
  74. C ***      MATRIX(ARG,ARG)
  75. 60    CONTINUE
  76.       TOP = TOP-1
  77.       L = LSTK(TOP)
  78.       IF (MSTK(TOP+1).EQ.0) MSTK(TOP) = 0
  79.       IF (MSTK(TOP).EQ.0) GO TO 99
  80.       L2 = LSTK(TOP+1)
  81.       M = MSTK(TOP)*NSTK(TOP)
  82.       IF (MSTK(TOP).LT.0) M = MSTK(K)
  83.       N = MSTK(TOP+1)*NSTK(TOP+1)
  84.       IF (MSTK(TOP+1).LT.0) N = NSTK(K)
  85.       L3 = L2+N
  86.       MK = MSTK(K)
  87.       MNK = MSTK(K)*NSTK(K)
  88.       DO 70 J = 1, N
  89.       DO 70 I = 1, M
  90.         LI = L+I-1
  91.         IF (MSTK(TOP).GT.0) LI = L+IDINT (STKR(LI))-1
  92.         LJ = L2+J-1
  93.         IF (MSTK(TOP+1).GT.0) LJ = L2+IDINT (STKR(LJ))-1
  94.         LS = LK+LI-L+(LJ-L2)*MK
  95.         IF (LS.LT.LK .OR. LS.GE.LK+MNK) CALL ERROR (21)
  96.         IF (ERR.GT.0) RETURN
  97.         LL = L3+I-1+(J-1)*M
  98.         STKR(LL) = STKR(LS)
  99.         STKI(LL) = STKI(LS)
  100. 70    CONTINUE
  101.       MN = M*N
  102.       CALL WCOPY (MN, STKR(L3), STKI(L3), 1, STKR(L), STKI(L), 1)
  103.       MSTK(TOP) = M
  104.       NSTK(TOP) = N
  105.       GO TO 99
  106. C
  107. 97    CONTINUE
  108.       FIN = 7
  109.       FUN = 6
  110.       RETURN
  111. C
  112. 98    CONTINUE
  113.       FIN = 0
  114.       RETURN
  115. C
  116. 99    CONTINUE
  117.       FIN = -1
  118.       FUN = 0
  119. C
  120.       RETURN
  121.       END
  122.