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 / Matfn5.for < prev    next >
Encoding:
Text File  |  1991-04-13  |  7.2 KB  |  303 lines
  1.       SUBROUTINE MATFN5
  2.       IMPLICIT NONE
  3. C
  4. C FILE HANDLING AND OTHER I/O
  5. C
  6.       INCLUDE MATLAB$KOM:SIZEPARMS.INC
  7.       INCLUDE MATLAB$KOM:VSTK.KOM
  8.       INCLUDE MATLAB$KOM:ALFS.KOM
  9.       INCLUDE MATLAB$KOM:RECU.KOM
  10.       INCLUDE MATLAB$KOM:IOP.KOM
  11.       INCLUDE MATLAB$KOM:COM.KOM
  12. C
  13.       INTEGER I, IMG, IPLTYP, J, JOB, K, M, MN, N
  14.       INTEGER L, L2, LL, LS, LUN, LUNIT, LW
  15.       INTEGER EOL, CH, BLANK, FLAG, TOP2, PLUS, MINUS,
  16.      .        QUOTE, SEMI, LRAT, MRAT, ID(4)
  17.       DOUBLE PRECISION EPS, B, S, T
  18.       LOGICAL TEXT
  19. C
  20.       DOUBLE PRECISION FLOP, WASUM, DFLOAT
  21. C
  22.       DATA EOL / 99 /, BLANK / 36 /, PLUS / 41 /, MINUS / 42 /
  23.       DATA QUOTE / 49 /, SEMI / 39 /, LRAT / 5 /, MRAT / 100 /
  24. C
  25. C
  26.       IF (DDT.EQ.1) WRITE (WTE, 100) FIN
  27. 100   FORMAT (' MATFN5', I4)
  28. C
  29. C FUNCTIONS/FIN
  30. C     EXEC SAVE LOAD PRIN DIAR DISP BASE LINE CHAR PLOT RAT  DEBU
  31. C      1    2    3    4    5    6    7    8    9   10   11   12
  32. C
  33.       L = LSTK(TOP)
  34.       M = MSTK(TOP)
  35.       N = NSTK(TOP)
  36.       IF (FIN.GT.5) GO TO 15
  37. C
  38. C ***      CONVERT FILE NAME
  39.       MN = M*N
  40.       FLAG = 3
  41.       IF (SYM.EQ.SEMI) FLAG = 0
  42.       IF (RHS.LT.2) GO TO 12
  43.       FLAG = IDINT (STKR(L))
  44.       TOP2 = TOP
  45.       TOP = TOP-1
  46.       L = LSTK(TOP)
  47.       MN = MSTK(TOP)*NSTK(TOP)
  48. 12    CONTINUE
  49.       LUN = -1
  50.       IF (MN.EQ.1 .AND. STKR(L).LT.10.0D0) LUN = IDINT (STKR(L))
  51.       IF (LUN.GE.0) GO TO 15
  52.       DO 14 J = 1, 32
  53.         LS = L+J-1
  54.         IF (J.LE.MN) CH = IDINT(STKR(LS))
  55.         IF (J.GT.MN) CH = BLANK
  56.         IF (CH.LT.0 .OR. CH.GE.ALFL) CALL ERROR (38)
  57.         IF (ERR.GT.0) RETURN
  58.         IF (CASE.EQ.0) BUF(J) = ALFA(CH+1)
  59.         IF (CASE.EQ.1) BUF(J) = ALFB(CH+1)
  60. 14    CONTINUE
  61. C
  62. 15    CONTINUE
  63.       GO TO (20, 30, 35, 25, 27, 60, 65, 70, 50, 80, 40, 95), FIN
  64. C
  65. C ***      EXEC
  66. 20    CONTINUE
  67.       IF (LUN.EQ.0) GO TO 23
  68.       K = LPT(6)
  69.       LIN(K+1) = LPT(1)
  70.       LIN(K+2) = LPT(3)
  71.       LIN(K+3) = LPT(6)
  72.       LIN(K+4) = PTZ
  73.       LIN(K+5) = RIO
  74.       LIN(K+6) = LCT(4)
  75.       LPT(1) = K+7
  76.       LCT(4) = FLAG
  77.       PTZ = PT-4
  78.       IF (RIO.EQ.RTE) RIO = 12
  79.       RIO = RIO+1
  80.       IF (LUN.GT.0) RIO = LUN
  81.       IF (LUN.LT.0) CALL FILES (RIO, BUF)
  82.       IF (FLAG.GE.4) WRITE (WTE, 22)
  83. 22    FORMAT (' PAUSE MODE. ENTER BLANK LINES.')
  84.       SYM = EOL
  85.       MSTK(TOP) = 0
  86.       GO TO 99
  87. C
  88. C ***      EXEC(0)
  89. 23    CONTINUE
  90.       RIO = RTE
  91.       ERR = 99
  92.       GO TO 99
  93. C
  94. C ***      PRINT
  95. 25    CONTINUE
  96.       K = WTE
  97.       WTE = LUN
  98.       IF (LUN.LT.0) WTE = 7
  99.       IF (LUN.LT.0) CALL FILES (WTE, BUF)
  100.       L = LCT(2)
  101.       LCT(2) = 9999
  102.       IF (RHS.GT.1) CALL PRINT (SYN, TOP2)
  103.       LCT(2) = L
  104.       WTE = K
  105.       MSTK(TOP) = 0
  106.       GO TO 99
  107. C
  108. C ***      DIARY
  109. 27    CONTINUE
  110.       WIO = LUN
  111.       IF (LUN.LT.0) WIO = 8
  112.       IF (LUN.LT.0) CALL FILES (WIO, BUF)
  113.       MSTK(TOP) = 0
  114.       GO TO 99
  115. C
  116. C ***      SAVE
  117. 30    CONTINUE
  118.       IF (LUN.LT.0) LUNIT = 1
  119.       IF (LUN.LT.0) CALL FILES (LUNIT, BUF)
  120.       IF (LUN.GT.0) LUNIT = LUN
  121.       K = LSIZE-4
  122.       IF (K.LT.BOT) K = LSIZE
  123.       IF (RHS.EQ.2) K = TOP2
  124.       IF (RHS.EQ.2) CALL PUTID (IDSTK(1,K), SYN)
  125. 32    CONTINUE
  126.       L = LSTK(K)
  127.       M = MSTK(K)
  128.       N = NSTK(K)
  129.       DO 34 I = 1, 4
  130.         J = IDSTK(I,K)+1
  131.         BUF(I) = ALFA(J)
  132. 34    CONTINUE
  133.       IMG = 0
  134.       IF (WASUM (M*N, STKI(L), STKI(L), 1).NE.0.0D0) IMG = 1
  135.       IF (FE.EQ.0) CALL SAVLOD (LUNIT, BUF, M, N, IMG,
  136.      .                          0, STKR(L), STKI(L))
  137.       K = K-1
  138.       IF (K.GE.BOT) GO TO 32
  139.       CALL FILES (-LUNIT, BUF)
  140.       MSTK(TOP) = 0
  141.       GO TO 99
  142. C
  143. C ***      LOAD
  144. 35    CONTINUE
  145.       IF (LUN.LT.0) LUNIT = 2
  146.       IF (LUN.LT.0) CALL FILES (LUNIT, BUF)
  147.       IF (LUN.GT.0) LUNIT = LUN
  148. 36    CONTINUE
  149.       JOB = LSTK(BOT)-L
  150.       IF (FE.EQ.0) CALL SAVLOD (LUNIT, ID, MSTK(TOP), NSTK(TOP),
  151.      .                          IMG, JOB, STKR(L), STKI(L))
  152.       MN = MSTK(TOP)*NSTK(TOP)
  153.       IF (MN.EQ.0) GO TO 39
  154.       IF (IMG.EQ.0) CALL RSET (MN, 0.0D0, STKI(L), 1)
  155.       DO 38 I = 1, 4
  156.         J = 0
  157. 37      CONTINUE
  158.         J = J+1
  159.         IF (ID(I).NE.ALFA(J) .AND. J.LE.BLANK) GO TO 37
  160.         ID(I) = J-1
  161. 38    CONTINUE
  162.       SYM = SEMI
  163.       RHS = 0
  164.       CALL STACKP (ID)
  165.       TOP = TOP+1
  166.       GO TO 36
  167. C
  168. 39    CONTINUE
  169.       CALL FILES (-LUNIT, BUF)
  170.       MSTK(TOP) = 0
  171.       GO TO 99
  172. C
  173. C ***      RAT
  174. 40    CONTINUE
  175.       IF (RHS.EQ.2) GO TO 44
  176.       MN = M*N
  177.       L2 = L
  178.       IF (LHS.EQ.2) L2 = L+MN
  179.       LW = L2+MN
  180.       ERR = LW+LRAT-LSTK(BOT)
  181.       IF (ERR.GT.0) CALL ERROR (17)
  182.       IF (ERR.GT.0) RETURN
  183.       IF (LHS.EQ.2) TOP = TOP+1
  184.       LSTK(TOP) = L2
  185.       MSTK(TOP) = M
  186.       NSTK(TOP) = N
  187.       CALL RSET (LHS*MN, 0.0D0, STKI(L), 1)
  188.       DO 42 I = 1, MN
  189.         CALL RAT (STKR(L), LRAT, MRAT, S, T, STKR(LW))
  190.         STKR(L) = S
  191.         STKR(L2) = T
  192.         IF (LHS.EQ.1) STKR(L) = FLOP (S/T)
  193.         L = L+1
  194.         L2 = L2+1
  195. 42    CONTINUE
  196.       GO TO 99
  197. C
  198. 44    CONTINUE
  199.       MRAT = IDINT (STKR(L))
  200.       LRAT = IDINT (STKR(L-1))
  201.       TOP = TOP-1
  202.       MSTK(TOP) = 0
  203.       GO TO 99
  204. C
  205. C ***      CHAR
  206. 50    CONTINUE
  207.       K = IABS (IDINT (STKR(L)))
  208.       IF (M*N.NE.1 .OR. K.GE.ALFL) CALL ERROR (36)
  209.       IF (ERR.GT.0) RETURN
  210.       CH = ALFA(K+1)
  211.       IF (STKR(L).LT.0.0D0) CH = ALFB(K+1)
  212.       WRITE (WTE, 51) CH
  213. 51    FORMAT (' REPLACE CHARACTER ', A1)
  214.       READ (RTE, 52) CH
  215. 52    FORMAT (A1)
  216.       IF (STKR(L).GE.0.0D0) ALFA(K+1) = CH
  217.       IF (STKR(L).LT.0.0D0) ALFB(K+1) = CH
  218.       MSTK(TOP) = 0
  219.       GO TO 99
  220. C
  221. C ***      DISP
  222. 60    CONTINUE
  223.       WRITE (WTE, 61)
  224.       IF (WIO.NE.0) WRITE (WIO, 61)
  225. 61    FORMAT (1X, 80A1)
  226.       IF (RHS.EQ.2) GO TO 65
  227.       MN = M*N
  228.       TEXT = .TRUE.
  229.       DO 62 I = 1, MN
  230.         LS = L+I-1
  231.         CH = IDINT (STKR(LS))
  232.         TEXT = TEXT .AND. (CH.GE.0) .AND. (CH.LT.ALFL)
  233.         TEXT = TEXT .AND. (DFLOAT (CH).EQ.STKR(LS))
  234. 62    CONTINUE
  235.       DO 64 I = 1, M
  236.         DO 63 J = 1, N
  237.           LS = L+I-1+(J-1)*M
  238.           IF (STKR(LS).EQ.0.0D0) CH = BLANK
  239.           IF (STKR(LS).GT.0.0D0) CH = PLUS
  240.           IF (STKR(LS).LT.0.0D0) CH = MINUS
  241.           IF (TEXT) CH = IDINT (STKR(LS))
  242.           BUF(J) = ALFA(CH+1)
  243. 63      CONTINUE
  244.         WRITE (WTE, 61) (BUF(J), J = 1, N)
  245.         IF (WIO.NE.0) WRITE (WIO, 61) (BUF(J), J = 1, N)
  246. 64    CONTINUE
  247.       MSTK(TOP) = 0
  248.       GO TO 99
  249. C
  250. C ***      BASE
  251. 65    CONTINUE
  252.       IF (RHS.NE.2) CALL ERROR (39)
  253.       IF (STKR(L).LE.1.0D0) CALL ERROR (36)
  254.       IF (ERR.GT.0) RETURN
  255.       B = STKR(L)
  256.       L2 = L
  257.       TOP = TOP-1
  258.       RHS = 1
  259.       L = LSTK(TOP)
  260.       M = MSTK(TOP)*NSTK(TOP)
  261.       EPS = STKR(VSIZE-4)
  262.       DO 66 I = 1, M
  263.         LS = L2+(I-1)*N
  264.         LL = L+I-1
  265.         CALL BASE (STKR(LL), B, EPS, STKR(LS), N)
  266. 66    CONTINUE
  267.       CALL RSET (M*N, 0.0D0, STKI(L2), 1)
  268.       CALL WCOPY (M*N, STKR(L2), STKI(L2), 1, STKR(L), STKI(L), 1)
  269.       MSTK(TOP) = N
  270.       NSTK(TOP) = M
  271.       CALL STACK1 (QUOTE)
  272.       IF (FIN.EQ.6) GO TO 60
  273.       GO TO 99
  274. C
  275. C ***      LINES
  276. 70    CONTINUE
  277.       LCT(2) = IDINT (STKR(L))
  278.       MSTK(TOP) = 0
  279.       GO TO 99
  280. C
  281. C ***      PLOT
  282. 80    CONTINUE
  283.       IF (RHS.EQ.1)THEN
  284.         IPLTYP = 0
  285.       ELSE
  286.         IPLTYP = 1
  287.         TOP = TOP-1
  288.       ENDIF
  289.       CALL PLOT (TOP, MSTK(TOP), NSTK(TOP), IPLTYP)
  290.       GO TO 99
  291. C
  292. C ***      DEBUG
  293. 95    CONTINUE
  294.       DDT = IDINT (STKR(L))
  295.       WRITE (WTE, 96) DDT
  296. 96    FORMAT (' DEBUG ', I4)
  297.       MSTK(TOP) = 0
  298.       GO TO 99
  299. C
  300. 99    CONTINUE
  301.       RETURN
  302.       END
  303.