![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to sys.cms 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.cms CVS log | Up to [Research Unix] / researchv10dc / cmd / matlab |
1.1 root 1: C PROGRAM MAIN
2: CALL ERRSET(208,1000000,-1,1)
3: CALL ERRSET(207,1000000,0,1)
4: CALL MATLAB(0)
5: STOP
6: END
7: SUBROUTINE FILES(LUNIT,NAME,IOSTAT)
8: INTEGER LUNIT,NAME(32)
9: C
10: C SYSTEM DEPENDENT ROUTINE TO ALLOCATE FILES
11: C THIS VERSION FOR IBM CMS
12: C LUNIT = LOGICAL UNIT NUMBER
13: C NAME = FILE NAME, 1 CHARACTER PER WORD
14: C
15: LOGICAL NAML(2),LL
16: DOUBLE PRECISION NAM8
17: EQUIVALENCE (NAML(1),NAM8),(L,LL)
18: C
19: L = -LUNIT
20: IF (LUNIT .LT. 0) REWIND L
21: IF (LUNIT .LT. 0) RETURN
22: C
23: K1 = 2**24
24: K2 = 2**30
25: K3 = 2**7
26: DO 10 I = 1,8
27: IF( NAME(I) .GT. 0 ) NAME(I) = NAME(I)/K1
28: IF( NAME(I) .LT. 0 ) NAME(I) = ((NAME(I)+K2)+K2)/K1+K3
29: 10 CONTINUE
30: NAM8 = 0.0D0
31: DO 20 I = 1,4
32: L = K1*NAME(I)
33: NAML(1) = NAML(1) .OR. LL
34: L = K1*NAME(I+4)
35: NAML(2) = NAML(2) .OR. LL
36: K1 = K1/256
37: 20 CONTINUE
38: IF( LUNIT .EQ. 1 ) REWIND 1
39: IF( LUNIT .EQ. 1 ) CALL CMSCMD(IRTURN,'FILEDEF ','01 ',
40: $ 'DISK ',NAM8,'MATLAB ','A1 ')
41: IF( LUNIT .EQ. 2 ) REWIND 2
42: IF( LUNIT .EQ. 2 ) CALL CMSCMD(IRTURN,'FILEDEF ','02 ',
43: $ 'DISK ',NAM8,'MATLAB ','A1 ')
44: IF( LUNIT .EQ. 11 ) REWIND 11
45: IF( LUNIT .EQ. 11 ) CALL CMSCMD(IRTURN,'FILEDEF ','11 ',
46: $ 'DISK ',NAM8,'MATLAB ','A1 ')
47: RETURN
48: END
49: SUBROUTINE SAVLOD(LUNIT,ID,M,N,IMG,JOB,XREAL,XIMAG)
50: INTEGER LUNIT,ID(4),M,N,IMG,JOB
51: DOUBLE PRECISION XREAL(1),XIMAG(1)
52: C
53: C IMPLEMENT SAVE AND LOAD
54: C LUNIT = LOGICAL UNIT NUMBER
55: C ID = NAME, FORMAT 4A1
56: C M, N = DIMENSIONS
57: C IMG = NONZERO IF XIMAG IS NONZERO
58: C JOB = 0 FOR SAVE
59: C = SPACE AVAILABLE FOR LOAD
60: C XREAL, XIMAG = REAL AND OPTIONAL IMAGINARY PARTS
61: C
62: C SYSTEM DEPENDENT FORMATS
63: 101 FORMAT(4A1,3I4)
64: 102 FORMAT(4Z18)
65: C
66: IF (JOB .GT. 0) GO TO 20
67: C
68: C SAVE
69: 10 WRITE(LUNIT,101) ID,M,N,IMG
70: DO 15 J = 1, N
71: K = (J-1)*M+1
72: L = J*M
73: WRITE(LUNIT,102) (XREAL(I),I=K,L)
74: IF (IMG .NE. 0) WRITE(LUNIT,102) (XIMAG(I),I=K,L)
75: 15 CONTINUE
76: RETURN
77: C
78: C LOAD
79: 20 READ(LUNIT,101,END=30) ID,M,N,IMG
80: IF (M*N .GT. JOB) GO TO 30
81: DO 25 J = 1, N
82: K = (J-1)*M+1
83: L = J*M
84: READ(LUNIT,102,END=30) (XREAL(I),I=K,L)
85: IF (IMG .NE. 0) READ(LUNIT,102,END=30) (XIMAG(I),I=K,L)
86: 25 CONTINUE
87: RETURN
88: C
89: C END OF FILE
90: 30 M = 0
91: N = 0
92: RETURN
93: END
94: SUBROUTINE FORMZ(LUNIT,X,Y)
95: DOUBLE PRECISION X,Y
96: C
97: C SYSTEM DEPENDENT ROUTINE TO PRINT WITH Z FORMAT
98: C
99: IF (Y .NE. 0.0D0) WRITE(LUNIT,10) X,Y
100: IF (Y .EQ. 0.0D0) WRITE(LUNIT,10) X
101: 10 FORMAT(2Z18)
102: RETURN
103: END
104: DOUBLE PRECISION FUNCTION FLOP(X)
105: DOUBLE PRECISION X
106: C SYSTEM DEPENDENT FUNCTION
107: C COUNT AND POSSIBLY CHOP EACH FLOATING POINT OPERATION
108: C FLP(1) IS FLOP COUNTER
109: C FLP(2) IS NUMBER OF PLACES TO BE CHOPPED
110: C
111: INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
112: COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
113: C
114: DOUBLE PRECISION MASK(13),XX,MM
115: LOGICAL LX(2),LM(2)
116: EQUIVALENCE (LX(1),XX),(LM(1),MM)
117: DATA MASK / ZFFFFFFFFFFFFFFF0,ZFFFFFFFFFFFFFF00,
118: $ ZFFFFFFFFFFFFF000,ZFFFFFFFFFFFF0000,ZFFFFFFFFFFF00000,
119: $ ZFFFFFFFFFF000000,ZFFFFFFFFF0000000,ZFFFFFFFF00000000,
120: $ ZFFFFFFF000000000,ZFFFFFF0000000000,ZFFFFF00000000000,
121: $ ZFFFF000000000000,ZFFF0000000000000/
122: C
123: FLP(1) = FLP(1) + 1
124: K = FLP(2)
125: FLOP = X
126: IF (K .LE. 0) RETURN
127: FLOP = 0.0D0
128: IF (K .GE. 14) RETURN
129: XX = X
130: MM = MASK(K)
131: LX(1) = LX(1) .AND. LM(1)
132: LX(2) = LX(2) .AND. LM(2)
133: FLOP = XX
134: RETURN
135: END
136: SUBROUTINE XCHAR(NAME,K)
137: INTEGER NAME(1),K
138: C
139: C SYSTEM DEPENDENT ROUTINE TO HANDLE SPECIAL CHARACTERS
140: C
141: LOGICAL NAML(2),LL
142: DOUBLE PRECISION NAM8
143: EQUIVALENCE (NAML(1),NAM8),(L,LL)
144: DATA IXCHAR /1H!/
145: IF( NAME(1) .NE. IXCHAR ) WRITE(6,30) NAME(1)
146: 30 FORMAT(1X,A1,' is not a MATLAB character.')
147: IF( NAME(1) .NE. IXCHAR ) RETURN
148: DO 5 I = 2,9
149: NAME(I-1) = NAME(I)
150: 5 CONTINUE
151: K1 = 2**24
152: K2 = 2**30
153: K3 = 2**7
154: DO 10 I = 1,8
155: IF( NAME(I) .GT. 0 ) NAME(I) = NAME(I)/K1
156: IF( NAME(I) .LT. 0 ) NAME(I) = ((NAME(I)+K2)+K2)/K1+K3
157: 10 CONTINUE
158: NAM8 = 0.0D0
159: DO 20 I = 1,4
160: L = K1*NAME(I)
161: NAML(1) = NAML(1) .OR. LL
162: L = K1*NAME(I+4)
163: NAML(2) = NAML(2) .OR. LL
164: K1 = K1/256
165: 20 CONTINUE
166: CALL CMSCMD(IRTURN,NAM8)
167: K = 99
168: RETURN
169: END
170: SUBROUTINE USER(A,M,N,S,T)
171: DOUBLE PRECISION A(M,N),S,T
172: C
173: INTEGER A3(9)
174: DATA A3 /-149,537,-27,-50,180,-9,-154,546,-25/
175: IF (A(1,1) .NE. 3.0D0) RETURN
176: DO 10 I = 1, 9
177: A(I,1) = A3(I)
178: 10 CONTINUE
179: M = 3
180: N = 3
181: RETURN
182: END
183: SUBROUTINE PROMPT(PAUSE)
184: INTEGER PAUSE
185: C
186: C ISSUE MATLAB PROMPT WITH OPTIONAL PAUSE
187: C
188: INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),RIO,WIO,RTE,WTE,HIO
189: COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,RIO,WIO,RTE,WTE,HIO
190: WRITE(WTE,10)
191: IF (WIO .NE. 0) WRITE(WIO,10)
192: 10 FORMAT(/1X,'<>')
193: IF (PAUSE .EQ. 1) READ(RTE,20) DUMMY
194: 20 FORMAT(A1)
195: RETURN
196: END
197: SUBROUTINE PLOT(LUNIT,X,Y,N,P,K,BUF)
198: DOUBLE PRECISION X(N),Y(N),P(1)
199: INTEGER BUF(79)
200: C
201: C PLOT X VS. Y ON LUNIT
202: C IF K IS NONZERO, THEN P(1),...,P(K) ARE EXTRA PARAMETERS
203: C BUF IS WORK SPACE
204: C
205: DOUBLE PRECISION XMIN,YMIN,XMAX,YMAX,DY,DX,Y1,Y0
206: INTEGER AST,BLANK,H,W
207: DATA AST/1H*/,BLANK/1H /,H/20/,W/79/
208: C
209: C H = HEIGHT, W = WIDTH
210: C
211: XMIN = X(1)
212: XMAX = X(1)
213: YMIN = Y(1)
214: YMAX = Y(1)
215: DO 10 I = 1, N
216: XMIN = DMIN1(XMIN,X(I))
217: XMAX = DMAX1(XMAX,X(I))
218: YMIN = DMIN1(YMIN,Y(I))
219: YMAX = DMAX1(YMAX,Y(I))
220: 10 CONTINUE
221: DX = XMAX - XMIN
222: IF (DX .EQ. 0.0D0) DX = 1.0D0
223: DY = YMAX - YMIN
224: WRITE(LUNIT,35)
225: DO 40 L = 1, H
226: DO 20 J = 1, W
227: BUF(J) = BLANK
228: 20 CONTINUE
229: Y1 = YMIN + (H-L+1)*DY/H
230: Y0 = YMIN + (H-L)*DY/H
231: JMAX = 1
232: DO 30 I = 1, N
233: IF (Y(I) .GT. Y1) GO TO 30
234: IF (L.NE.H .AND. Y(I).LE.Y0) GO TO 30
235: J = 1 + (W-1)*(X(I) - XMIN)/DX
236: BUF(J) = AST
237: JMAX = MAX0(JMAX,J)
238: 30 CONTINUE
239: WRITE(LUNIT,35) (BUF(J),J=1,JMAX)
240: 35 FORMAT(1X,79A1)
241: 40 CONTINUE
242: RETURN
243: END
244: SUBROUTINE EDIT(BUF,N)
245: INTEGER BUF(N)
246: C
247: C CALLED AFTER INPUT OF A SINGLE BACKSLASH
248: C BUF CONTAINS PREVIOUS INPUT LINE, ONE CHAR PER WORD
249: C ENTER LOCAL EDITOR IF AVAILABLE
250: C OTHERWISE JUST
251: RETURN
252: END
253:
254: TITLE 'CMSCMD: INTERFACE TO EXECUTE A CMS COMMAND:: 6/13/79'
255: ***********************************************************************
256: *
257: * COMMENTS TO JACK DONGARRA APPLIED MATHEMATICS DIVISION
258: * ARGONNE NATIONAL LABORATORY. D-247, EXT 7246
259: *
260: * CMSCMD WILL EXECUTE A CMS COMMAND WHEN CALLED FROM FORTRAN.
261: *
262: * THE CALLING SEQUENCE IS:
263: * CALL CMSCMD(IRET,'COMMAND ','ARG1 ',ARG2',.....,'ARGN')
264: *
265: * WHERE <IRET> IS INTEGER*4, THE RETURN CODE FROM <CMSCMD>.
266: * IRET CONTAINS THE RETURN CODE FROM THE CMS COMMAND,
267: * UNLESS MORE THAN 30 <ARG> FIELDS WHERE PASSED,
268: * WHEN IT WILL BE -31.
269: *
270: * ALL THE REMAINING ARGUMENTS MUST BE LITERALS. THEY MUST
271: * NOT CONTAIN LEADING OR EMBEDDED SPACES. IF LESS THAN 8
272: * CHARACTERS LONG THEY SHOULD HAVE AT LEAST 1 TRAILING SPACE.
273: * COMPILERS PAD LITERALS DIFFERENTLY, SO IT IS SAFEST TO
274: * ALWAYS APPEND A TRAILING SPACE NO MATTER WHAT THE LENGTH
275: * OF THE LITERAL. FOR SOME COMPILERS <CMSCMD> WILL WORK
276: * CORRECTLY WITHOUT TRAILING SPACES. THE ARGUMENTS MAY, OF
277: * COURSE, BE ARRAYS OF TYPE "LOGICAL".
278: *
279: * <COMMAND> IS THE NAME OF THE CMS COMMAND TO BE EXECUTED.
280: *
281: * <ARG1>
282: * TO
283: * <ARGN> ARE THE ARGUMENTS TO BE PASSED TO THE CMS COMMAND.
284: * UP TO 30 SUCH ARGUMENTS MAY BE PASSED.
285: * NOTE THAT SINCE CMS DOES NOT DO ANY FURTHER
286: * TOKENIZATION AN ARGUMENT CONSISTING SOLELY OF SPACES
287: * WILL HAVE A NULL VALUE.
288: *
289: ***********************************************************************
290: SPACE 3
291: CMSCMD CSECT 0
292: USING *,15
293: B SAVEREGS
294: DC AL1(6)
295: DC C'CMSCMD'
296: SAVEREGS STM 14,12,12(13) SAVE CALLERS REGS IN OWN SAVE AREA
297: ST 13,SAVEAREA+4 STORE CHAIN BACK ADDRESS
298: LR 12,13
299: LA 13,SAVEAREA
300: ST 13,8(12)
301: DROP 15
302: BALR 10,0 ESTABLISH BASE REG
303: USING *,10
304: LA 4,ARGLIST-8 R4->CMS ARG LIST
305: L 5,=F'-31' -31 IS RETURN CODE FOR BAD ARGS
306: * R1 CONTAINS ADDRESS OF LIST OF CALLING ARG ADDRESSES
307: L 2,0(0,1) R2 CONTAINS ADDR OF RETURN CODE (ARG1)
308: SR 3,3 R3 IS CALLING ARG COUNTER...SET TO ZERO
309: NEXTARG LA 4,8(0,4) STEP R4 TO NEXT CMS ARG
310: CLI 0(1),X'80' WAS THIS FLAGGED AS LAST ARG?
311: BE GOCMS YES..GO AND CALL CMS ROUTINE
312: LA 1,4(0,1) NO...STEP CALLING ARG PTR
313: LA 3,1(0,3) INCREMENT ARG COUNTER
314: C 3,VAL31 >31?
315: BH EXIT YES..LEAVE WITH RETURN CODE = -31
316: MVC 0(8,4),BLANKS NO...BLANK OUT CMS ARG
317: LA 6,8(0,0) SET R6=8 FOR COUNT OF 8 BYTES
318: L 7,0(0,1) R7->CALLING ARG STRING
319: LR 8,4 R8->CMS ARG STRING
320: COPYLOOP CLI 0(7),X'00' NULL BYTE?
321: BE NEXTARG YES..END OF STRING
322: CLI 0(7),X'40' NO...IS IT A SPACE?
323: BE NEXTARG YES..END OF STRING
324: MVC 0(1,8),0(7) NO...COPY BYTE
325: LA 7,1(0,7) INCREMENT R7, R8
326: LA 8,1(0,8)
327: BCT 6,COPYLOOP
328: B NEXTARG
329: GOCMS MVC 0(8,4),NULLARG SET TRAILING NULL ARG FOR CMS
330: SR 5,5 HOPE FOR SUCCESS...RETURN CODE=0
331: LA 1,ARGLIST
332: SVC 202
333: DC AL4(ERROR)
334: B EXIT
335: ERROR LR 5,15 PICK UP CMS RETURN CODE
336: EXIT ST 5,0(0,2) PASS BACK RETURN CODE
337: L 13,4(13) RESTORE CALLER SAVEAREA PTR
338: LM 14,12,12(13) RESTORE CALLERS REGS
339: BR 14 AND RETURN
340: SPACE 5
341: NULLARG DC 8X'FF'
342: BLANKS DC CL8' '
343: ARGLIST DS 32D FOR COMMAND NAME, PLUS UP TO 30 ARGS,
344: * AND TRAILING NULL ARG EXPECTED BY CMS
345: VAL31 DC F'31'
346: SAVEAREA DS 24F
347: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.