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