![[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.