Google
 

Trailing-Edge - PDP-10 Archives - decus_20tap1_198111 - decus/20-0001/mout.for
There is 1 other file named mout.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
C **************************************************
C *                                                *
C *      SUBROUTINE  MOUT (INDEX,RETCD)            *
C *                                                *
C **************************************************
C
C
C THIS ROUTINE OUTPUTS VALUE OF A MULTIPLE PRECISION VARIABLE
C
C
C
C     RETCD    MEANING
C
C      1         O.K.
C      2         ERROR
C
C
C  MODIFICATION CLASSES:  M1,M3
C  MODIFIED 2-DEC-77 P.B.    ADD IPRT(100) TO RUN ON DECSYSTEM-20
C
C
C
C
C MOUT CALLS
C
C  ERRMSG    PRINTS ERROR MESSAGES
C  PRTCON    CONVERTS 1-10 TO PRINTABLE 1,2,...9,0
C
C
C
C
C MOUT IS CALLED BY VAROUT
C
C
C
C
C
C
C      VARIABLE        USE
C
C    BVEC(3)      HOLDS BASE VALUES TO BE INDEXED BY IBASE AND PRINTED
C                 UNDER I2 FORMAT.
C    DIGITS(16,3) PRINTABLE ASCII DIGITS.
C    FORHEX       HOLDS OUTPUT FORMAT STATEMENT WHEN OUTPUTTING HEXADECIMAL
C                 NUMBERS (SEPARATES GROUPS OF 4 DIGITS WITH COMMAS).
C    FORMAT       HOLDS OUTPUT FORMAT STATEMENT WHEN OUTPUTTING NUMBERS WITH
C                 COMMAS EVERY 3 DIGITS. FIRST PART IS USED WHEN LESS THAN
C                 4 DIGITS OR HEXADECIMAL AND EXACTLY 4 DIGITS IS OUTPUT.
C    I,I1,I2      TEMPORARY VALUES
C    IBASE        CODES BASE: 1=BASE 10, 2=BASE 8, 3=BASE 16
C    IGRP         NUMBER OF COMMAS NEEDED TO SEPARATE DIGITS.
C    INDEX        POINTER TO VARIABLE TO BE OUTPUT.
C    LOG1         LOGICAL*1 USED AS ARGUMENT IN PRTCON CALLS.
C    NONE         NUMBER OF DIGITS TO BE PRINTED.
C    RPAR         ')'
C    SIGN(2)      VECTOR USED TO PRINT APPROPRIATE SIGN ('+' OR '-')
C    TYPE         HOLDS TYPE OF EACH VARIABLE.
C
C
C
C
	SUBROUTINE MOUT(INDEX,RETCD)
C
C
C INDEX POINTS TO AN ELEMENT IN VBLS TO BE OUTPUT
C (A MULTIPLE PRECISION NUMBER BASE 10, 8, OR 16)
C
C
C
	INTEGER*2 TYPE(27),RETCD,VLEN(9)
	INTEGER*2 BVEC(3)
	INTEGER*2 I,I1,I2
	INTEGER*2 IBASE,INDEX,NONE,IGRP
C
C
	LOGICAL*1 VBLS(100,27),LOG1
	LOGICAL*1 PRTCON
	LOGICAL*1 SIGN(2),FORMAT(24),FORHEX(24),RPAR
	LOGICAL*1 IPRT(100)
C
C
	COMMON /V/ TYPE,VBLS,VLEN
C
C
	DATA BVEC/10,8,16/
	DATA SIGN/' ','-'/, RPAR/')'/
	DATA FORMAT/'(', '1', 'X', ',', '1', 'A', '1', ',', ' ',
     2  'A', '1', ',', ' ', ' ', '(', ' ', ''',''', ' ', ',', '3',
     3  'A', '1', ')', ')'/
C
C
	DATA FORHEX/'(', '1', 'X', ',', '1', 'A', '1', ',', ' ',
     2  'A', '1', ',', ' ', ' ', '(', ' ', ''',''', ' ', ',', '4',
     3  'A', '1', ')', ')'/
C
C
C SET DEFAULT RETURN CODE (O.K.)
	RETCD=1
C
C IBASE = 1  IF BASE 10,   2 IF BASE 8,   3 IF BASE 16
	IBASE=TYPE(INDEX)-4
C
C
C
C MAKE SURE THE VARIABLE IS DEFINED
	IF(TYPE(INDEX).NE.0)GO TO 10
	STOP 10
C
C
C DETERMINE THE NUMBER OF DIGITS TO BE PRINTED.
10	DO 20 I=2,100
	NONE=101-I
	IF(VBLS(NONE,INDEX).NE.0)GO TO 30
20	CONTINUE
	NONE=1
C
C NONE POINTS TO THE NUMBER OF DIGITS TO BE PRINTED
30	IF(NONE.GT.4.OR.(NONE.EQ.4.AND.IBASE.NE.3)) GOTO 50
C
C
C **************************************************
C ****** ONLY 1,2, OR 3 DIGITS (4 IF HEX) **********
C **************************************************
	LOG1=NONE
C
C PUT IN NUMBER OF DIGITS.
	FORMAT(9)=PRTCON(LOG1,1)
C
C END FORMAT STATEMENT.
	FORMAT(13)=RPAR
40	CONTINUE
C
C
C
C ///// WRITE NON-HEXADECIMAL NUMBER /////
	DO 45 I=1,NONE
45	IPRT(I) = PRTCON(VBLS(NONE+1-I,INDEX),IBASE)

	WRITE(1,FORMAT) SIGN(VBLS(100,INDEX)+1),(IPRT(I),I=1,NONE)
	GO TO 10000
C
C
C MORE THAN 3 DIGITS SO USE COMMAS TO SEPARATE GROUPS
50	IF(IBASE.EQ.3) GO TO 200
C
C
C ******************************************************
C **  DECIMAL OR OCTAL NUMBER WITH MORE THAN 3 DIGITS **
C ******************************************************
C
C FIRST CALCULATE THE NUMBER OF COMMAS NEEDED.
	IGRP=NONE/3
	LOG1=NONE-IGRP*3
	IF(LOG1.NE.0)GO TO 55
	IGRP=IGRP-1
	LOG1=3
C
C CONVERT GROUP COUNT TO PRINTABLE ASCII FOR FORMAT STATEMENT.
55	I1=IGRP/10
	I2=IGRP-I1*10
	FORMAT(9)=PRTCON(LOG1,1)
	LOG1=I1
	FORMAT(13)=PRTCON(LOG1,1)
	LOG1=I2
	FORMAT(14)=PRTCON(LOG1,1)
	GO TO 40
C
C
C
C
C **************************************************
C *** HEXADECIMAL NUMBER WITH MORE THAN 4 DIGITS ***
C **************************************************
C
C CALCULATE THE NUMBER OF COMMAS NEEDED.
200	IGRP=NONE/4
	LOG1=NONE-IGRP*4
	IF(LOG1.NE.0)GO TO 210
	IGRP=IGRP-1
	LOG1=4
C
C CONVERT GROUPT COUNT TO ASCII FOR FORMAT STATEMENT.
210	I1=IGRP/10
	I2=IGRP-I1*10
	FORHEX(9)=PRTCON(LOG1,1)
	LOG1=I1
	FORHEX(13)=PRTCON(LOG1,1)
	LOG1=I2
	FORHEX(14)=PRTCON(LOG1,1)
C
C
C ///// WRITE OUT HEXADECIMAL NUMBER /////
	DO 220 I=1,NONE
220	IPRT(I) = PRTCON(VBLS(NONE+1-I,INDEX),IBASE)
	WRITE(1,FORHEX) SIGN(VBLS(100,INDEX)+1),
     2  (IPRT(I),I=1,NONE)
	GO TO 10000
C
C
C
C
C *************************
C **** EXIT PROCESSING ****
C *************************
10000	CONTINUE
	WRITE(1,10010) BVEC(IBASE)
10010	FORMAT(' (BASE ',I2,')')
	RETURN
	END
C
C
C **********************************
C *                                *
C *    INTERNAL FUNCTION PRTCON    *
C *                                *
C **********************************
C CALLED BY MOUT ONLY
C CONVERTS 0 TO APPROPRIATE NUMBER FOR PRINTING WITH VECTOR DIGITS
	FUNCTION PRTCON(L1,IBASE)
	INTEGER*2 BASE(3)
	INTEGER*2 K
	LOGICAL*1 L1,PRTCON,DIGITS(16,3)
	COMMON /DIGV/ DIGITS
	DATA BASE /10,8,16/
	PRTCON=L1
	IF(L1.EQ.0)PRTCON=BASE(IBASE)
	K=PRTCON
	PRTCON=DIGITS(K,IBASE)
	RETURN
	END