Trailing-Edge
-
PDP-10 Archives
-
decuslib20-01
-
decus/20-0001/varout.for
There is 1 other file named varout.for in the archive. Click here to see a list.
C
C
C
C COPYRIGHT (c) 1977 BY
C DIGITAL EQUIPMENT CORPORTATION, MAYNARD, MASS.
C
C THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
C ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
C INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
C COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
C OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
C TRANSFERRED.
C
C THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
C AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
C CORPORATION.
C
C DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
C SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
C
C
C
C
C
C
C
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++
C + +
C + CALC VERSION X01-01 +
C + +
C + PETER BAUM 1-SEP-77 +
C + DIGITAL EQUIPMENT CORPORATION +
C + 146 MAIN STREET +
C + MAYNARD, MASSACHUSETTS 01754 +
C + +
C ++++++++++++++++++++++++++++++++++++++++++++++++++
C
C
C
C LAST MODIFIED 26-SEP-77 P.B.
C
C
C
C
C **************************************************
C * *
C * SUBROUTINE VAROUT *
C * *
C **************************************************
C
C
C
C OUTPUTS THE VALUE OF THE VARIABLE POINTED TO BY INDEX.
C
C ASCII A1 FORMAT UNLESS THE ASCII VALUE IS LESS THAN 32.
C IN SUCH CASES, 32 IS ADDED TO THE VALUE AND THE
C CHARACTER IS OUTPUT SO THAT IT IS PRECEDED BY THE
C CHARACTER '^'.
C
C DECIMAL A COMPUTED F FORMAT.
C
C HEXADECIMAL LEADING ZEROES, "BASE 16" QUE.
C
C INTEGER I12 FORMAT
C
C OCTAL LEADING ZEROES, "BASE 8" QUE
C
C REAL D25.18 FORMAT
C
C
C MODIFICATION CLASSES: M1,M4,M8
C
C
C
C VAROUT CALLS
C
C ERRMSG PRINTS OUT ERROR MESSAGES
C MOUT OUTPUTS MULTIPLE PRECISION NUMBERS
C
C
C
C
C
C VAROUT IS CALLED BY CALC AND POSTVL
C
C
C
C VARIABLE USE
C
C DEC HOLDS NUMBER OF DIGITS TO THE RIGHT OF THE
C DECIMAL POINT IN F FORMAT SPECIFICATION.
C DFORM(11) HOLDS FORMAT SPECIFICATION FOR F FORMAT
C (OUTPUTTING VALUE OF VARIABLES WITH DECIMAL DATA TYPE).
C DIGITS HOLDS THE ASCII CHARACTERS FOR VARIOUS DIGITS.
C EIGHT(8) USED TO PICK OFF REAL*8 'S FROM VBLS.
C ALSO HOLDS HEXADECIMAL DIGITS IF # IS DATA TYPE HEX.
C FOUR(4) USED TO PICK OFF INTEGER*4'S FROM VBLS.
C I,K HOLDS TEMPORARY VALUES.
C I1 HOLDS THE FIRST DIGIT IN CREATING AN F FORMAT SPECIFICATION.
C I2 HOLDS THE SECOND DIGIT IN CREATING AN F FORMAT SPEC.
C INDEX POINTS TO VARIABLE BEING OUTPUT.
C IPT POINTER FOR DFORM.
C ISV POINTER FOR VECTOR SIGN(2).
C THE VALUE. THIS IS DONE BECAUSE OTHERWISE
C SOME COMPILERS WOULD FORCE A SIGN EXTEND.
C L TEMPORARY VALUES. POINTER FOR EIGHT(8).
C LEVIN(11) HOLDS PRINTABLE ASCII CHARACTERS WHICH REPRESENT
C AN OCTAL NUMBER. EQUIVALENCED WITH EIGHT(8).
C M1 HOLDS HIGH ORDER HEXADECIMAL DIGIT.
C M2 HOLDS LOW ORDER HEXADECIMAL DIGIT.
C MAG HOLDS THE MAGNITUDE OF A REAL*8 NUMBER
C P10 REAL*8 THAT HOLDS POWERS OF 10. (DECIMAL)
C RETCD HOLDS RETURN CODE FROM CALL TO MOUT.
C RPAR ')'
C SIGN(2) HOLDS PRINTABLE ASCII CHARACTERS FOR OUTPUTTING THE
C SIGN OF A NUMBER.
C STAR1 HOLDS A SINGLE CHARACTER.
C VBLS(100,27) HOLDS VALUE FOR EACH VARIABLE.
C WIDTH WIDTH SPECIFICATION FOR F FORMAT.
C
C
C
SUBROUTINE VAROUT (INDEX)
C
C
REAL*8 REAL,MAG,P10
C
INTEGER*4 INT,L,K
C
INTEGER*2 TYPE(27),WIDTH,DEC,VLEN(9),RETCD
C
LOGICAL*1 VBLS(100,27),STAR1,EIGHT(8),FOUR(4)
LOGICAL*1 DFORM(11),DIGITS(16,3),LEVIN(11)
LOGICAL*1 SIGN(2)
LOGICAL*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
C
COMMON /V/ TYPE,VBLS,VLEN
COMMON /DIGV/ DIGITS
COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
C
EQUIVALENCE (REAL,EIGHT),(INT,FOUR),(EIGHT,LEVIN)
C
DATA SIGN/' ','-'/
DATA DFORM /'(', '1', 'X', ',', 'F', ' ', ' ', '.', ' ', ' ',
; ')'/
C
C
C
K=TYPE(INDEX)
IF (K.GT.0) GOTO 10
CALL ERRMSG (16)
GOTO 10000
10 GOTO (100,200,300,400,500,600,700,800,900),K
STOP 10
C
C
C
C
C **************************************************
C ************** ASCII ***************
C **************************************************
100 STAR1=VBLS(1,INDEX)
IF (STAR1.LT.32) GOTO 110
102 WRITE (1,103) STAR1
103 FORMAT (1X,A1)
RETURN
110 STAR1=STAR1+32
WRITE (1,112) STAR1
112 FORMAT (1X,'^',A1)
RETURN
C
C
C
C
C
C **************************************************
C **************** DECIMAL **********************
C **************************************************
200 CONTINUE
DO 208 I=1,8
208 EIGHT(I)=VBLS(I,INDEX)
MAG=DABS(REAL)
IF (MAG.LT.1.D0) GOTO 240
C
C
C COUNT THE # OF DIGITS TO THE LEFT OF THE DECIMAL POINT
P10=1.D0
DO 210 I=1,38
P10=10.D0*P10
IF (P10.GT.MAG) GOTO 212
210 CONTINUE
C
C I COUNTS THE # OF DIGITS TO THE LEFT OF THE DECIMAL POINT
I=39
212 DEC=0
WIDTH=17
IF(I.GT.15)WIDTH=I+2
IF(I.LE.15)DEC=15-I
C
C
C CREATE PROPER FORMAT STATEMENT
215 I1=WIDTH/10
I2=WIDTH-I1*10
IF (I2.EQ.0) I2=10
DFORM(6)=DIGITS(I1,1)
DFORM(7)=DIGITS(I2,1)
I1=DEC/10
I2=DEC-I1*10
IF (I1.EQ.0) I1=10
IF (I2.EQ.0) I2=10
IPT=9
IF (I1.EQ.0) GOTO 220
DFORM(9)=DIGITS(I1,1)
IPT=IPT+1
220 DFORM(IPT)=DIGITS(I2,1)
DFORM(IPT+1)=RPAR
C
C
C
C
C OUTPUT REAL USING NEWLY CREATED
C FORMAT STATEMENT HELD BY DFORM
WRITE (1,DFORM) REAL
GOTO 10000
C
C
C REAL LESS THAN 1.D0
240 P10=1.D0
DO 245 I=1,38
P10=P10*.1D0
IF (MAG.GE.P10) GOTO 250
245 CONTINUE
I=0
C
C I-1 REPRESENTS THE NUMBER OF LEADING ZEROS
250 DEC=14+I
WIDTH=DEC+3
GOTO 215
C
C
C
C
C
C **************************************************
C ************* HEXADECIMAL **********************
C **************************************************
C HEXADECIMAL
300 CONTINUE
DO 302 I=1,4
302 FOUR(I)=VBLS(I,INDEX)
ISV=1
IF (INT.LT.0) ISV=2
INT=IABS(INT)
L=8
DO 304 I=1,8
C PICK UP A VALUE, THEN USE INTEGER*2 EQUIVALENT
C TO WORK WITH SO SIGN DOESN'T GET EXTENED.
M1 = INT-INT/16*16
INT = INT/16
IF(M1.EQ.0)M1=16
EIGHT(L)=DIGITS(M1,3)
L=L-1
304 CONTINUE
WRITE (1,310) SIGN(ISV), EIGHT
310 FORMAT (1X,1A1,8A1,2X,'(BASE 16)')
GOTO 10000
C
C
C
C
C
C **************************************************
C *************** INTEGER **********************
C **************************************************
400 DO 404 I=1,4
404 FOUR(I)=VBLS(I,INDEX)
WRITE (1,410) INT
410 FORMAT (1X,I12)
GOTO 10000
C
C
C
C
C
C **************************************************
C *********** MULTIPLE PRECISION **************
C **************************************************
C MULTIPLE PRECISION
C M10
500 CONTINUE
C
C M8
600 CONTINUE
C
C M16
700 CALL MOUT (INDEX,RETCD)
GOTO 10000
C
C
C
C
C
C **************************************************
C **************** OCTAL ***********************
C **************************************************
C OCTAL
800 DO 804 I=1,4
804 FOUR(I)=VBLS(I,INDEX)
ISV=1
IF (INT.LT.0) ISV=2
K=IABS(INT)
DO 810 I=1,11
L=K-K/8*8
C TAKE ABSOLUTE VALUE IN CASE FIRST IABS DIDN'T WORK ON -2**31
L=IABS(L)
IF(L.EQ.0)L=9
LEVIN (12-I)=DIGITS(L,2)
K=K/8
810 CONTINUE
WRITE (1,820) SIGN(ISV), LEVIN
820 FORMAT (1X,1A1,11A1,2X,'(BASE 8)')
GOTO 10000
C
C
C
C
C
C **************************************************
C *************** REAL ***********************
C **************************************************
900 DO 904 I=1,8
904 EIGHT(I)=VBLS(I,INDEX)
WRITE (1,910) REAL
910 FORMAT (1X,D25.18)
10000 RETURN
END