![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to sys.prime CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10dc / cmd / matlab|
Return to sys.prime CVS log | Up to [Research Unix] / researchv10dc / cmd / matlab |
1.1 root 1: C PROGRAM MAIN
2: C
3: C ******** THIS DRIVER WAS SET UP FOR THE PRIME 400 AT
4: C ******** THE CENTER FOR SCIENTIFIC COMPUTATION AND INTERACTIVE GRAPHICS
5: C ******** DREXEL UNIVERSITY
6: C ******** PHILADELPHIA, PA 19104
7: C
8: C THIS PROGRAM AND ASSOCIATED SUBROUTINES SHOULD BE COMPILED
9: C USING THE LONG INTEGER OPTION.
10: C
11: INTEGER*2 I
12: LOGICAL L,CLOS$A
13: CALL MATLAB(0)
14: I4=4
15: DO 100 I=1,12
16: L = CLOS$A(I)
17: 100 CONTINUE
18: CALL EXIT
19: END
20: SUBROUTINE FILES(LUNIT,NAME,IOSTAT)
21: INTEGER LUNIT,NAME(32)
22: INTEGER*2 I1,I2,I3,I4,I5,I8,ITYPE,ICODE,IUNIT,I16
23: INTEGER*4 NAM8(2)
24: DATA I1,I3,I4,I5,I8,I16/1,3,4,5,8,16/
25: C
26: C SYSTEM DEPENDENT ROUTINE TO ALLOCATE FILES
27: C LUNIT = LOGICAL UNIT NUMBER
28: C NAME = FILE NAME, 1 CHARACTER PER WORD
29: C
30: C MODIFY SUBROUTINE MATLAB SO THAT RTE = 1 AND WTE = 1
31: C ATTACH UNIT 9 TO HELP FILE
32: C
33: L = -LUNIT
34: IF (LUNIT .LT. 0) REWIND L
35: IF (LUNIT .LT. 0) RETURN
36: C
37: ENCODE(8,10,NAM8) (NAME(I),I=1,8)
38: 10 FORMAT(8A1)
39: IUNIT = LUNIT-4
40: CALL SRCH$$(I4,NAM8,0,IUNIT,ITYPE,ICODE)
41: CALL SRCH$$(I3,NAM8,I8,IUNIT,ITYPE,ICODE)
42: RETURN
43: END
44: SUBROUTINE SAVLOD(LUNIT,ID,M,N,IMG,JOB,XREAL,XIMAG)
45: INTEGER LUNIT,ID(4),M,N,IMG,JOB
46: DOUBLE PRECISION XREAL(1),XIMAG(1)
47: C
48: C IMPLEMENT SAVE AND LOAD
49: C LUNIT = LOGICAL UNIT NUMBER
50: C ID = NAME, FORMAT 4A1
51: C M, N = DIMENSIONS
52: C IMG = NONZERO IF XIMAG IS NONZERO
53: C JOB = 0 FOR SAVE
54: C = SPACE AVAILABLE FOR LOAD
55: C XREAL, XIMAG = REAL AND OPTIONAL IMAGINARY PARTS
56: C
57: C SYSTEM DEPENDENT FORMATS
58: 101 FORMAT(4A1,3I4)
59: 102 FORMAT(4D25.18)
60: C
61: IF (JOB .GT. 0) GO TO 20
62: C
63: C SAVE
64: 10 WRITE(LUNIT,101) ID,M,N,IMG
65: DO 15 J = 1, N
66: K = (J-1)*M+1
67: L = J*M
68: WRITE(LUNIT,102) (XREAL(I),I=K,L)
69: IF (IMG .NE. 0) WRITE(LUNIT,102) (XIMAG(I),I=K,L)
70: 15 CONTINUE
71: RETURN
72: C
73: C LOAD
74: 20 READ(LUNIT,101,END=30) ID,M,N,IMG
75: IF (M*N .GT. JOB) GO TO 30
76: DO 25 J = 1, N
77: K = (J-1)*M+1
78: L = J*M
79: READ(LUNIT,102,END=30) (XREAL(I),I=K,L)
80: IF (IMG .NE. 0) READ(LUNIT,102,END=30) (XIMAG(I),I=K,L)
81: 25 CONTINUE
82: RETURN
83: C
84: C END OF FILE
85: 30 M = 0
86: N = 0
87: RETURN
88: END
89: SUBROUTINE FORMZ(LUNIT,X,Y)
90: DOUBLE PRECISION X,Y,XHEX(2),YHEX(2)
91: INTEGER*2 I4
92: DATA I4/4/
93: C
94: C SYSTEM DEPENDENT ROUTINE TO PRINT WITH Z FORMAT
95: C
96: CALL HEXCHR(X,I4,XHEX)
97: IF(Y.EQ.0.D0)GO TO 20
98: CALL HEXCHR(Y,I4,YHEX)
99: WRITE(LUNIT,10)XHEX,YHEX
100: RETURN
101: 20 WRITE(LUNIT,10)XHEX
102: RETURN
103: 10 FORMAT(2A8,4X,2A8)
104: END
105: SUBROUTINE HEXCHR(VALUE,VALWDS,STRING)
106: C* VALUE IS THE VALUE TO BE CONVERTED TO HEXADECIMAL. ANY NUMBER OF WORDS.
107: C* VALWDS IS THE NUMBER OF WORDS IN THE VALUE TO BE TRANSLATED:
108: C*
109: C* INTEGER*2 -- 1
110: C* INTEGER*4 -- 2
111: C* REAL*4 -- 2
112: C* REAL*8 -- 4
113: C*
114: C**===> ETC.
115: C* STRING IS AN ARRAY INTO WHICH THE CHARACTERS WILL BE PACKED.
116: C* (IT DOESN'T MATTER WHAT KIND OF ARRAY IT IS).
117: C*
118: C*
119: C* WARNING: IF THE STRING PROVIDED IS NOT LONG ENOUGH (IT HAS TO BE TWICE
120: C* AS LONG IN TERMS OF BITS OR WORDS AS THE VALUE ARRAY), THERE
121: C* IS NO WAY TO DETECT IF IT RUNS OFF AND DESTROYS OTHER MEMORY.
122: C* (THIS IS PRIME STANDARD, BY THE WAY.)
123: C* ALSO, ANYTHING BEYOND THE 2*VALWDS ELEMENT OF THE STRING ARRAY
124: C* IS MEANINGLESS.
125: C*
126: C*
127:
128:
129:
130: INTEGER*2 VALUE(1),STRING(1),VALWDS,ONE,TWO,THREE,FOUR,I
131: DO 10 I=1,VALWDS
132: STRING(2*I-1) = 0
133: STRING(2*I) = 0
134: ONE = RS(LT(VALUE(I),4),12)
135: TWO = RS(LT(RT(VALUE(I),12),8),8)
136: THREE = RS(LT(RT(VALUE(I),8),12),4)
137: FOUR = RT(VALUE(I),4)
138: IF (ONE .LE. :011) STRING(2*I-1) =
139: + OR(LS(OR(:260,ONE),8),STRING(2*I-1))
140: IF (ONE .GT. :011) STRING(2*I-1) =
141: + OR(LS(ONE + :267,8),STRING(2*I-1))
142: IF (TWO .LE. :011) STRING(2*I-1) =
143: + OR(TWO,:260,STRING(2*I-1))
144: IF (TWO .GT. :011) STRING(2*I-1) =
145: + OR(TWO+ :267,STRING(2*I-1))
146: IF (THREE .LE. :011) STRING(2*I) =
147: + OR(LS(OR(:260,THREE),8),STRING(2*I))
148: IF (THREE .GT. :011) STRING(2*I) =
149: + OR(LS(THREE + :267,8),STRING(2*I))
150: IF (FOUR .LE. :011) STRING(2*I) =
151: + OR(FOUR,:260,STRING(2*I))
152: IF (FOUR .GT. :011) STRING(2*I) =
153: + OR(FOUR+ :267,STRING(2*I))
154: 10 CONTINUE
155: RETURN
156: END
157: DOUBLE PRECISION FUNCTION FLOP(X)
158: DOUBLE PRECISION X
159: C SYSTEM DEPENDENT FUNCTION
160: C COUNT AND POSSIBLY CHOP EACH FLOATING POINT OPERATION
161: C FLP(1) IS FLOP COUNTER
162: C FLP(2) IS NUMBER OF PLACES TO BE CHOPPED
163: C
164: INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
165: COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
166: C
167: DOUBLE PRECISION MASK(11),XX,MM
168: INTEGER*4 MAS(2,11),LX(2),LM(2)
169: C LOGICAL LX(4),LM(4)
170: EQUIVALENCE (LX(1),XX),(LM(1),MM),(MASK,MAS)
171: C
172: C *** THESE ARE THE MASKS TO CHOP HEX DIGITS ON THE PRIME 400 ***
173: C
174: DATA MAS /-:00000000001,-:00003600001,
175: $ -:00000000001,-:00077600001,
176: $ -:00000000001,-:01777600001,
177: $ -:00000000001,-:37777600001,
178: $ -:00000000020,:00000177777,
179: $ -:00000000400,:00000177777,
180: $ -:00000010000,:00000177777,
181: $ -:00000200000,:00000177777,
182: $ -:00004000000,:00000177777,
183: $ -:00100000000,:00000177777,
184: $ -:02000000000,:00000177777/
185: FLP(1) = FLP(1) + 1
186: K = FLP(2)
187: FLOP = X
188: IF (K .LE. 0) RETURN
189: FLOP = 0.0D0
190: IF (K .GE. 12) RETURN
191: XX = X
192: MM = MASK(K)
193: LX(1) = AND(LX(1),LM(1))
194: LX(2) = AND(LX(2),LM(2))
195: FLOP = XX
196: RETURN
197: END
198: SUBROUTINE XCHAR(BUF,K)
199: INTEGER BUF(1),K
200: C
201: C SYSTEM DEPENDENT ROUTINE TO HANDLE SPECIAL CHARACTERS
202: C
203: WRITE(6,10) BUF(1)
204: 10 FORMAT(1X,A1,' is not a MATLAB character.')
205: RETURN
206: END
207: SUBROUTINE USER(A,M,N,S,T)
208: DOUBLE PRECISION A(M,N),S,T
209: C
210: INTEGER A3(9)
211: DATA A3 /-149,537,-27,-50,180,-9,-154,546,-25/
212: IF (A(1,1) .NE. 3.0D0) RETURN
213: DO 10 I = 1, 9
214: A(I,1) = A3(I)
215: 10 CONTINUE
216: M = 3
217: N = 3
218: RETURN
219: END
220: SUBROUTINE PROMPT(PAUSE)
221: INTEGER PAUSE
222: C
223: C ISSUE MATLAB PROMPT WITH OPTIONAL PAUSE
224: C
225: INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),RIO,WIO,RTE,WTE,HIO
226: COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,RIO,WIO,RTE,WTE,HIO
227: WRITE(WTE,10)
228: IF (WIO .NE. 0) WRITE(WIO,10)
229: 10 FORMAT(/1X,'<>')
230: IF (PAUSE .EQ. 1) READ(RTE,20) DUMMY
231: 20 FORMAT(A1)
232: RETURN
233: END
234: SUBROUTINE PLOT(LUNIT,X,Y,N,P,K,BUF)
235: DOUBLE PRECISION X(N),Y(N),P(1)
236: INTEGER BUF(79)
237: C
238: C PLOT X VS. Y ON LUNIT
239: C IF K IS NONZERO, THEN P(1),...,P(K) ARE EXTRA PARAMETERS
240: C BUF IS WORK SPACE
241: C
242: DOUBLE PRECISION XMIN,YMIN,XMAX,YMAX,DY,DX,Y1,Y0
243: INTEGER AST,BLANK,H,W
244: DATA AST/1H*/,BLANK/1H /,H/20/,W/79/
245: C
246: C H = HEIGHT, W = WIDTH
247: C
248: XMIN = X(1)
249: XMAX = X(1)
250: YMIN = Y(1)
251: YMAX = Y(1)
252: DO 10 I = 1, N
253: XMIN = DMIN1(XMIN,X(I))
254: XMAX = DMAX1(XMAX,X(I))
255: YMIN = DMIN1(YMIN,Y(I))
256: YMAX = DMAX1(YMAX,Y(I))
257: 10 CONTINUE
258: DX = XMAX - XMIN
259: IF (DX .EQ. 0.0D0) DX = 1.0D0
260: DY = YMAX - YMIN
261: WRITE(LUNIT,35)
262: DO 40 L = 1, H
263: DO 20 J = 1, W
264: BUF(J) = BLANK
265: 20 CONTINUE
266: Y1 = YMIN + (H-L+1)*DY/H
267: Y0 = YMIN + (H-L)*DY/H
268: JMAX = 1
269: DO 30 I = 1, N
270: IF (Y(I) .GT. Y1) GO TO 30
271: IF (L.NE.H .AND. Y(I).LE.Y0) GO TO 30
272: J = 1 + (W-1)*(X(I) - XMIN)/DX
273: BUF(J) = AST
274: JMAX = MAX0(JMAX,J)
275: 30 CONTINUE
276: WRITE(LUNIT,35) (BUF(J),J=1,JMAX)
277: 35 FORMAT(1X,79A1)
278: 40 CONTINUE
279: RETURN
280: END
281: SUBROUTINE EDIT(BUF,N)
282: INTEGER BUF(N)
283: C
284: C CALLED AFTER INPUT OF A SINGLE BACKSLASH
285: C BUF CONTAINS PREVIOUS INPUT LINE, ONE CHAR PER WORD
286: C ENTER LOCAL EDITOR IF AVAILABLE
287: C OTHERWISE JUST
288: RETURN
289: END
290: DOUBLE PRECISION FUNCTION DSINH(X)
291: IMPLICIT DOUBLE PRECISION (A-Z)
292: DATA A0/-.139005324307231D6/,
293: $ A1/-.180697428204813D5/,
294: $ A2/-.404150536907816D3/,
295: $ B0/-.139005324307231D6/,
296: $ B1/+.509781123072247D4/,
297: $ B2/-.954080394016126D2/
298: IF (DABS(X) .LT. 0.5D0) GO TO 10
299: E = DEXP(X)
300: DSINH = 0.5D0*(E-1.0D0/E)
301: RETURN
302: 10 Y = X*X
303: P = ((A2*Y)+A1)*Y+A0
304: Q = ((Y+B2)*Y+B1)*Y+B0
305: DSINH = X*P/Q
306: RETURN
307: END
308: DOUBLE PRECISION FUNCTION DCOSH(X)
309: IMPLICIT DOUBLE PRECISION (A-Z)
310: E = DEXP(X)
311: DCOSH = 0.5D0*(E+1.0D0/E)
312: RETURN
313: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.