C PROGRAM MAIN FOR VAX/VMS C For overflow handling, RTFM on Common Run-Time Library. C Also compile subroutine URAND with FORTRAN/NOCHECK. EXTERNAL UNTRAP CALL LIB$ESTABLISH(UNTRAP) CALL MATLAB(0) STOP END INTEGER FUNCTION UNTRAP(SIGARGS,MECHARGS) INTEGER SIGARGS(3),MECHARGS(5) INCLUDE 'SYS$LIBRARY:SIGDEF' INTEGER HUGE(2) DATA HUGE/'FFFF7FFF'X,'FFFFFFFF'X/ I = LIB$SIM_TRAP(SIGARGS,MECHARGS) IF (LIB$MATCH_COND (SIGARGS(2), SS$_FLTOVF)) THEN WRITE(6,10) 10 FORMAT(' ---OVERFLOW---') CALL LIB$INSV(1,0,3,SIGARGS(2)) UNTRAP = SS$_CONTINUE ELSEIF (LIB$MATCH_COND (SIGARGS(2), SS$_INTOVF)) THEN WRITE(6,12) 12 FORMAT(' ---INTEGER OVERFLOW---') CALL LIB$INSV(2,0,3,SIGARGS(2)) UNTRAP = SS$_CONTINUE ELSEIF (LIB$MATCH_COND (SIGARGS(2), SS$_ROPRAND)) THEN UNTRAP = LIB$FIXUP_FLT(SIGARGS,MECHARGS,HUGE) ELSE UNTRAP = SS$_RESIGNAL ENDIF RETURN END SUBROUTINE FILES(LUNIT,NAME,IOSTAT) INTEGER LUNIT,NAME(64),IOSTAT C C SYSTEM DEPENDENT ROUTINE TO ALLOCATE FILES C LUNIT = LOGICAL UNIT NUMBER C = 1, SAVE C = 2, LOAD C = 7, PRINT C = 8, DIARY C > 10, EXEC C < 0, CLOSE -LUNIT C = -5, SPECIAL CASE, END OF FILE DETECTED ON TERMINAL C NAME = FILE NAME, 1 CHARACTER PER WORD C NONZERO IOSTAT RETURNED FOR ERROR CONDITION C C (UNLESS CHANGED IN SUBROUTINE MATLAB, UNITS 5, 6 AND 9 ARE C USED FOR TERMINAL INPUT, TERMINAL OUTPUT AND THE HELP FILE. C THE HELP FILE IS OPENED BY SUBROUTINE HELPER.) C CHARACTER*64 NAM C IF (LUNIT .LT. 0) GO TO 30 C C FORTRAN 77 INTERNAL FILE CONVERSION FROM 64A1 TO CHARACTER*64 C WRITE(NAM,'(64A1)') NAME C C UNFORMATTED I/O FOR SAVE AND LOAD C FORMATTED I/O FOR EXEC, DIARY AND PRINT C IOSTAT = 0 IF (LUNIT .EQ. 1) OPEN(UNIT=LUNIT,FILE=NAM,FORM='UNFORMATTED', > STATUS='NEW',ERR=20,IOSTAT=IOSTAT) IF (LUNIT .EQ. 2) OPEN(UNIT=LUNIT,FILE=NAM,FORM='UNFORMATTED', > STATUS='OLD',ERR=20,IOSTAT=IOSTAT) IF (LUNIT .EQ. 7) OPEN(UNIT=LUNIT,FILE=NAM, > STATUS='NEW',ERR=20,IOSTAT=IOSTAT) IF (LUNIT .EQ. 8) OPEN(UNIT=LUNIT,FILE=NAM, > STATUS='NEW',ERR=20,IOSTAT=IOSTAT) IF (LUNIT .GT. 10) OPEN(UNIT=LUNIT,FILE=NAM, > STATUS='OLD',ERR=20,IOSTAT=IOSTAT) IF (IOSTAT .NE. 0) GO TO 20 C C REWIND ALL EXCEPT DIARY C IF (LUNIT .NE. 8) REWIND LUNIT RETURN C C ERROR ON OPEN C 20 IF (IOSTAT .EQ. 0) IOSTAT = -1 RETURN C C CLOSE FILES C 30 CLOSE(UNIT=-LUNIT) 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(14),XX,MM real mas(2,14) LOGICAL LX(2),LM(2) EQUIVALENCE (LX(1),XX),(LM(1),MM) equivalence (mask(1),mas(1)) data mas/ $ 'ffffffff'x,'fff0ffff'x, $ 'ffffffff'x,'ff00ffff'x, $ 'ffffffff'x,'f000ffff'x, $ 'ffffffff'x,'0000ffff'x, $ 'ffffffff'x,'0000fff0'x, $ 'ffffffff'x,'0000ff00'x, $ 'ffffffff'x,'0000f000'x, $ 'ffffffff'x,'00000000'x, $ 'fff0ffff'x,'00000000'x, $ 'ff00ffff'x,'00000000'x, $ 'f000ffff'x,'00000000'x, $ '0000ffff'x,'00000000'x, $ '0000fff0'x,'00000000'x, $ '0000ff80'x,'00000000'x/ C FLP(1) = FLP(1) + 1 K = FLP(2) FLOP = X IF (K .LE. 0) RETURN FLOP = 0.0D0 IF (K .GE. 15) 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(BUF,K) INTEGER BUF(1),K C C SYSTEM DEPENDENT ROUTINE TO HANDLE SPECIAL CHARACTERS C C INTEGER BACK,MASK DATA BACK/'20202008'X/,MASK/'000000FF'X/ C IF (BUF(1) .EQ. BACK) K = -1 L = BUF(1) .AND. MASK IF (K .NE. -1) WRITE(6,10) BUF(1),L 10 FORMAT(1X,1H',A1,4H' = ,Z2,' hex is not a MATLAB character.') 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