V10/cmd/matlab/sys.cms
C PROGRAM MAIN
CALL ERRSET(208,1000000,-1,1)
CALL ERRSET(207,1000000,0,1)
CALL MATLAB(0)
STOP
END
SUBROUTINE FILES(LUNIT,NAME,IOSTAT)
INTEGER LUNIT,NAME(32)
C
C SYSTEM DEPENDENT ROUTINE TO ALLOCATE FILES
C THIS VERSION FOR IBM CMS
C LUNIT = LOGICAL UNIT NUMBER
C NAME = FILE NAME, 1 CHARACTER PER WORD
C
LOGICAL NAML(2),LL
DOUBLE PRECISION NAM8
EQUIVALENCE (NAML(1),NAM8),(L,LL)
C
L = -LUNIT
IF (LUNIT .LT. 0) REWIND L
IF (LUNIT .LT. 0) RETURN
C
K1 = 2**24
K2 = 2**30
K3 = 2**7
DO 10 I = 1,8
IF( NAME(I) .GT. 0 ) NAME(I) = NAME(I)/K1
IF( NAME(I) .LT. 0 ) NAME(I) = ((NAME(I)+K2)+K2)/K1+K3
10 CONTINUE
NAM8 = 0.0D0
DO 20 I = 1,4
L = K1*NAME(I)
NAML(1) = NAML(1) .OR. LL
L = K1*NAME(I+4)
NAML(2) = NAML(2) .OR. LL
K1 = K1/256
20 CONTINUE
IF( LUNIT .EQ. 1 ) REWIND 1
IF( LUNIT .EQ. 1 ) CALL CMSCMD(IRTURN,'FILEDEF ','01 ',
$ 'DISK ',NAM8,'MATLAB ','A1 ')
IF( LUNIT .EQ. 2 ) REWIND 2
IF( LUNIT .EQ. 2 ) CALL CMSCMD(IRTURN,'FILEDEF ','02 ',
$ 'DISK ',NAM8,'MATLAB ','A1 ')
IF( LUNIT .EQ. 11 ) REWIND 11
IF( LUNIT .EQ. 11 ) CALL CMSCMD(IRTURN,'FILEDEF ','11 ',
$ 'DISK ',NAM8,'MATLAB ','A1 ')
RETURN
END
SUBROUTINE SAVLOD(LUNIT,ID,M,N,IMG,JOB,XREAL,XIMAG)
INTEGER LUNIT,ID(4),M,N,IMG,JOB
DOUBLE PRECISION XREAL(1),XIMAG(1)
C
C IMPLEMENT SAVE AND LOAD
C LUNIT = LOGICAL UNIT NUMBER
C ID = NAME, FORMAT 4A1
C M, N = DIMENSIONS
C IMG = NONZERO IF XIMAG IS NONZERO
C JOB = 0 FOR SAVE
C = SPACE AVAILABLE FOR LOAD
C XREAL, XIMAG = REAL AND OPTIONAL IMAGINARY PARTS
C
C SYSTEM DEPENDENT FORMATS
101 FORMAT(4A1,3I4)
102 FORMAT(4Z18)
C
IF (JOB .GT. 0) GO TO 20
C
C SAVE
10 WRITE(LUNIT,101) ID,M,N,IMG
DO 15 J = 1, N
K = (J-1)*M+1
L = J*M
WRITE(LUNIT,102) (XREAL(I),I=K,L)
IF (IMG .NE. 0) WRITE(LUNIT,102) (XIMAG(I),I=K,L)
15 CONTINUE
RETURN
C
C LOAD
20 READ(LUNIT,101,END=30) ID,M,N,IMG
IF (M*N .GT. JOB) GO TO 30
DO 25 J = 1, N
K = (J-1)*M+1
L = J*M
READ(LUNIT,102,END=30) (XREAL(I),I=K,L)
IF (IMG .NE. 0) READ(LUNIT,102,END=30) (XIMAG(I),I=K,L)
25 CONTINUE
RETURN
C
C END OF FILE
30 M = 0
N = 0
RETURN
END
SUBROUTINE FORMZ(LUNIT,X,Y)
DOUBLE PRECISION X,Y
C
C SYSTEM DEPENDENT ROUTINE TO PRINT WITH Z FORMAT
C
IF (Y .NE. 0.0D0) WRITE(LUNIT,10) X,Y
IF (Y .EQ. 0.0D0) WRITE(LUNIT,10) X
10 FORMAT(2Z18)
RETURN
END
DOUBLE PRECISION FUNCTION FLOP(X)
DOUBLE PRECISION X
C SYSTEM DEPENDENT FUNCTION
C COUNT AND POSSIBLY CHOP EACH FLOATING POINT OPERATION
C FLP(1) IS FLOP COUNTER
C FLP(2) IS NUMBER OF PLACES TO BE CHOPPED
C
INTEGER SYM,SYN(4),BUF(256),CHAR,FLP(2),FIN,FUN,LHS,RHS,RAN(2)
COMMON /COM/ SYM,SYN,BUF,CHAR,FLP,FIN,FUN,LHS,RHS,RAN
C
DOUBLE PRECISION MASK(13),XX,MM
LOGICAL LX(2),LM(2)
EQUIVALENCE (LX(1),XX),(LM(1),MM)
DATA MASK / ZFFFFFFFFFFFFFFF0,ZFFFFFFFFFFFFFF00,
$ ZFFFFFFFFFFFFF000,ZFFFFFFFFFFFF0000,ZFFFFFFFFFFF00000,
$ ZFFFFFFFFFF000000,ZFFFFFFFFF0000000,ZFFFFFFFF00000000,
$ ZFFFFFFF000000000,ZFFFFFF0000000000,ZFFFFF00000000000,
$ ZFFFF000000000000,ZFFF0000000000000/
C
FLP(1) = FLP(1) + 1
K = FLP(2)
FLOP = X
IF (K .LE. 0) RETURN
FLOP = 0.0D0
IF (K .GE. 14) RETURN
XX = X
MM = MASK(K)
LX(1) = LX(1) .AND. LM(1)
LX(2) = LX(2) .AND. LM(2)
FLOP = XX
RETURN
END
SUBROUTINE XCHAR(NAME,K)
INTEGER NAME(1),K
C
C SYSTEM DEPENDENT ROUTINE TO HANDLE SPECIAL CHARACTERS
C
LOGICAL NAML(2),LL
DOUBLE PRECISION NAM8
EQUIVALENCE (NAML(1),NAM8),(L,LL)
DATA IXCHAR /1H!/
IF( NAME(1) .NE. IXCHAR ) WRITE(6,30) NAME(1)
30 FORMAT(1X,A1,' is not a MATLAB character.')
IF( NAME(1) .NE. IXCHAR ) RETURN
DO 5 I = 2,9
NAME(I-1) = NAME(I)
5 CONTINUE
K1 = 2**24
K2 = 2**30
K3 = 2**7
DO 10 I = 1,8
IF( NAME(I) .GT. 0 ) NAME(I) = NAME(I)/K1
IF( NAME(I) .LT. 0 ) NAME(I) = ((NAME(I)+K2)+K2)/K1+K3
10 CONTINUE
NAM8 = 0.0D0
DO 20 I = 1,4
L = K1*NAME(I)
NAML(1) = NAML(1) .OR. LL
L = K1*NAME(I+4)
NAML(2) = NAML(2) .OR. LL
K1 = K1/256
20 CONTINUE
CALL CMSCMD(IRTURN,NAM8)
K = 99
RETURN
END
SUBROUTINE USER(A,M,N,S,T)
DOUBLE PRECISION A(M,N),S,T
C
INTEGER A3(9)
DATA A3 /-149,537,-27,-50,180,-9,-154,546,-25/
IF (A(1,1) .NE. 3.0D0) RETURN
DO 10 I = 1, 9
A(I,1) = A3(I)
10 CONTINUE
M = 3
N = 3
RETURN
END
SUBROUTINE PROMPT(PAUSE)
INTEGER PAUSE
C
C ISSUE MATLAB PROMPT WITH OPTIONAL PAUSE
C
INTEGER DDT,ERR,FMT,LCT(4),LIN(1024),LPT(6),RIO,WIO,RTE,WTE,HIO
COMMON /IOP/ DDT,ERR,FMT,LCT,LIN,LPT,RIO,WIO,RTE,WTE,HIO
WRITE(WTE,10)
IF (WIO .NE. 0) WRITE(WIO,10)
10 FORMAT(/1X,'<>')
IF (PAUSE .EQ. 1) READ(RTE,20) DUMMY
20 FORMAT(A1)
RETURN
END
SUBROUTINE PLOT(LUNIT,X,Y,N,P,K,BUF)
DOUBLE PRECISION X(N),Y(N),P(1)
INTEGER BUF(79)
C
C PLOT X VS. Y ON LUNIT
C IF K IS NONZERO, THEN P(1),...,P(K) ARE EXTRA PARAMETERS
C BUF IS WORK SPACE
C
DOUBLE PRECISION XMIN,YMIN,XMAX,YMAX,DY,DX,Y1,Y0
INTEGER AST,BLANK,H,W
DATA AST/1H*/,BLANK/1H /,H/20/,W/79/
C
C H = HEIGHT, W = WIDTH
C
XMIN = X(1)
XMAX = X(1)
YMIN = Y(1)
YMAX = Y(1)
DO 10 I = 1, N
XMIN = DMIN1(XMIN,X(I))
XMAX = DMAX1(XMAX,X(I))
YMIN = DMIN1(YMIN,Y(I))
YMAX = DMAX1(YMAX,Y(I))
10 CONTINUE
DX = XMAX - XMIN
IF (DX .EQ. 0.0D0) DX = 1.0D0
DY = YMAX - YMIN
WRITE(LUNIT,35)
DO 40 L = 1, H
DO 20 J = 1, W
BUF(J) = BLANK
20 CONTINUE
Y1 = YMIN + (H-L+1)*DY/H
Y0 = YMIN + (H-L)*DY/H
JMAX = 1
DO 30 I = 1, N
IF (Y(I) .GT. Y1) GO TO 30
IF (L.NE.H .AND. Y(I).LE.Y0) GO TO 30
J = 1 + (W-1)*(X(I) - XMIN)/DX
BUF(J) = AST
JMAX = MAX0(JMAX,J)
30 CONTINUE
WRITE(LUNIT,35) (BUF(J),J=1,JMAX)
35 FORMAT(1X,79A1)
40 CONTINUE
RETURN
END
SUBROUTINE EDIT(BUF,N)
INTEGER BUF(N)
C
C CALLED AFTER INPUT OF A SINGLE BACKSLASH
C BUF CONTAINS PREVIOUS INPUT LINE, ONE CHAR PER WORD
C ENTER LOCAL EDITOR IF AVAILABLE
C OTHERWISE JUST
RETURN
END
TITLE 'CMSCMD: INTERFACE TO EXECUTE A CMS COMMAND:: 6/13/79'
***********************************************************************
*
* COMMENTS TO JACK DONGARRA APPLIED MATHEMATICS DIVISION
* ARGONNE NATIONAL LABORATORY. D-247, EXT 7246
*
* CMSCMD WILL EXECUTE A CMS COMMAND WHEN CALLED FROM FORTRAN.
*
* THE CALLING SEQUENCE IS:
* CALL CMSCMD(IRET,'COMMAND ','ARG1 ',ARG2',.....,'ARGN')
*
* WHERE <IRET> IS INTEGER*4, THE RETURN CODE FROM <CMSCMD>.
* IRET CONTAINS THE RETURN CODE FROM THE CMS COMMAND,
* UNLESS MORE THAN 30 <ARG> FIELDS WHERE PASSED,
* WHEN IT WILL BE -31.
*
* ALL THE REMAINING ARGUMENTS MUST BE LITERALS. THEY MUST
* NOT CONTAIN LEADING OR EMBEDDED SPACES. IF LESS THAN 8
* CHARACTERS LONG THEY SHOULD HAVE AT LEAST 1 TRAILING SPACE.
* COMPILERS PAD LITERALS DIFFERENTLY, SO IT IS SAFEST TO
* ALWAYS APPEND A TRAILING SPACE NO MATTER WHAT THE LENGTH
* OF THE LITERAL. FOR SOME COMPILERS <CMSCMD> WILL WORK
* CORRECTLY WITHOUT TRAILING SPACES. THE ARGUMENTS MAY, OF
* COURSE, BE ARRAYS OF TYPE "LOGICAL".
*
* <COMMAND> IS THE NAME OF THE CMS COMMAND TO BE EXECUTED.
*
* <ARG1>
* TO
* <ARGN> ARE THE ARGUMENTS TO BE PASSED TO THE CMS COMMAND.
* UP TO 30 SUCH ARGUMENTS MAY BE PASSED.
* NOTE THAT SINCE CMS DOES NOT DO ANY FURTHER
* TOKENIZATION AN ARGUMENT CONSISTING SOLELY OF SPACES
* WILL HAVE A NULL VALUE.
*
***********************************************************************
SPACE 3
CMSCMD CSECT 0
USING *,15
B SAVEREGS
DC AL1(6)
DC C'CMSCMD'
SAVEREGS STM 14,12,12(13) SAVE CALLERS REGS IN OWN SAVE AREA
ST 13,SAVEAREA+4 STORE CHAIN BACK ADDRESS
LR 12,13
LA 13,SAVEAREA
ST 13,8(12)
DROP 15
BALR 10,0 ESTABLISH BASE REG
USING *,10
LA 4,ARGLIST-8 R4->CMS ARG LIST
L 5,=F'-31' -31 IS RETURN CODE FOR BAD ARGS
* R1 CONTAINS ADDRESS OF LIST OF CALLING ARG ADDRESSES
L 2,0(0,1) R2 CONTAINS ADDR OF RETURN CODE (ARG1)
SR 3,3 R3 IS CALLING ARG COUNTER...SET TO ZERO
NEXTARG LA 4,8(0,4) STEP R4 TO NEXT CMS ARG
CLI 0(1),X'80' WAS THIS FLAGGED AS LAST ARG?
BE GOCMS YES..GO AND CALL CMS ROUTINE
LA 1,4(0,1) NO...STEP CALLING ARG PTR
LA 3,1(0,3) INCREMENT ARG COUNTER
C 3,VAL31 >31?
BH EXIT YES..LEAVE WITH RETURN CODE = -31
MVC 0(8,4),BLANKS NO...BLANK OUT CMS ARG
LA 6,8(0,0) SET R6=8 FOR COUNT OF 8 BYTES
L 7,0(0,1) R7->CALLING ARG STRING
LR 8,4 R8->CMS ARG STRING
COPYLOOP CLI 0(7),X'00' NULL BYTE?
BE NEXTARG YES..END OF STRING
CLI 0(7),X'40' NO...IS IT A SPACE?
BE NEXTARG YES..END OF STRING
MVC 0(1,8),0(7) NO...COPY BYTE
LA 7,1(0,7) INCREMENT R7, R8
LA 8,1(0,8)
BCT 6,COPYLOOP
B NEXTARG
GOCMS MVC 0(8,4),NULLARG SET TRAILING NULL ARG FOR CMS
SR 5,5 HOPE FOR SUCCESS...RETURN CODE=0
LA 1,ARGLIST
SVC 202
DC AL4(ERROR)
B EXIT
ERROR LR 5,15 PICK UP CMS RETURN CODE
EXIT ST 5,0(0,2) PASS BACK RETURN CODE
L 13,4(13) RESTORE CALLER SAVEAREA PTR
LM 14,12,12(13) RESTORE CALLERS REGS
BR 14 AND RETURN
SPACE 5
NULLARG DC 8X'FF'
BLANKS DC CL8' '
ARGLIST DS 32D FOR COMMAND NAME, PLUS UP TO 30 ARGS,
* AND TRAILING NULL ARG EXPECTED BY CMS
VAL31 DC F'31'
SAVEAREA DS 24F
END