Google
 

Trailing-Edge - PDP-10 Archives - decus_20tap1_198111 - 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