Trailing-Edge
-
PDP-10 Archives
-
decuslib20-01
-
decus/20-0001/contyp.for
There is 1 other file named contyp.for in the archive. Click here to see a list.
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 * *
C * SUBROUTINE CONTYP *
C * *
C **************************************************
C
C
C CONVERTS CONSTANT IN STACK(I,INDEX) FROM OLDTYP TO NEWTYP
C IF OLDTYP.EQ.NEWTYP A RETURN IS MADE IMMEDIATELY.
C NOTE THAT TYPE(INDEX) IS NOT CHANGED BY THIS ROUTINE
C TYPE CODES:
C
C 0 NO CHANGE
C 1 ASCII
C 2 DECIMAL
C 3 HEXADECIMAL
C 4 INTEGER
C 5 M10
C 6 M8
C 7 M16
C 8 OCTAL
C 9 REAL
C
C RETCD MEANING
C
C 1 O.K.
C 2 ERROR
C
C
C
C
C
C MODIFY CLASSES: M3,M4,M8
C
C
C
C CONTYP CALLS:
C
C ERRMSG PRINTS OUT ERROR MESSAGES
C MULCON CONVERTS MULTIPLE PRECISION TO MULTIPLE PRECISION
C OF A DIFFERENT BASE
C
C
C
C CONTYP IS CALLED BY
C
C CALUN CALCULATES UNARY OPERATIONS
C CALBIN CALCULATES BINARY OPERATIONS
C
C
C
C
C VARIABLE USE
C
C BASE HOLDS BASE OR POWERS OF THAT BASE (INTEGER*4).
C BASVEC HOLDS LEGAL BASES: 8,10, AND 16
C EIGHT(8) LOGICAL*1 ARRAY TO PICK OFF REAL*8 VALUES.
C FOUR(4) LOGICAL*1 ARRAY TO PICK OFF INTEGER*4 VALUES.
C I,J,M TEMPORARY VALUES.
C IBASE HOLDS BASE OF A NUMBER WHEN BASE HOLDS THE POWERS
C OF THAT BASE.
C IEND HOLDS THE NUMBER OF MULTIPLE PRECISION DIGITS THAT
C WILL BE PICKED UP WHEN CONVERTING TO INTEGER*4.
C INDEX POINTER TO VARIABLE BEING CONVERTED.
C INT HOLDS INTEGER*4 VALUES EQUIVALENCED TO VECTOR FOUR.
C IS TEMPORARILY HOLDS MULTIPLE PRECISION BASE 8 OR BASE
C 16 DIGITS.
C IS2 TEMPORARILY HOLDS A DIGIT VALUE WHEN CHECKING MULTIPLE
C PRECISION BASE 8 AND BASE 16 NUMBERS TO SEE IF THEY
C ARE TOO LARGE TO FIT IN INTEGER*4.
C ISGN USED WHEN DETERMINING THE MAXIMUM NUMBER THAT CAN BE
C HELD BY INTEGER*4. 1=POSITIVE, 2= NEGATIVE. ALSO HOLDS
C 0 OR 7 FOR BASE 8 MAXIMUM NUMBER CHECK. HOLDS 0 OR 15
C FOR BASE 16 MAXIMUM NUMBER CHECK.
C K TEMPORARILY HOLDS INTEGER*4 VALUES.
C NEWTYP NEW DATA TYPE REQUESTED.
C OLDTYP DATA TYPE OF THE VARIABLE TO BE CONVERTED.
C RBASE BASE WHEN CONVERTING FROM MULTIPLE PRECISION TO REAL*8.
C REAL HOLDS REAL*8 VALUES. EQUIVALENCED TO ARRAY EIGHT.
C RETCD RETURN CODE. 1=O.K. 2=ERROR.
C RPOWER HOLDS POWERS OF RBASE WHEN CONVERTING FROM MULTIPLE
C PRECISION TO REAL*8.
C STACK(I,INDEX) HOLDS VARIABLE TO BE CONVERTED.
C
C
C
C
C
SUBROUTINE CONTYP (STACK,INDEX,OLDTYP,NEWTYP,RETCD)
C
REAL*8 REAL,RBASE,RPOWER,DFLOAT
C
INTEGER*4 K,INT,BASE
C
INTEGER*2 OLDTYP,NEWTYP,RETCD,BASVEC(3)
INTEGER*2 MAX10(10,2)
INTEGER*2 I,M,J
INTEGER*2 ISGN,IS,IS2
C
LOGICAL*1 EIGHT(8),FOUR(4)
LOGICAL*1 STACK(100,40)
C
EQUIVALENCE (FOUR,INT),(REAL,EIGHT)
C
DATA BASVEC/10,8,16/
DATA MAX10/2,1,4,7,4,8,3,6,4,7,2,1,4,7,4,8,3,6,4,8/
C
C
C SET DEFAULT RETURN CODE
RETCD=1
IF(OLDTYP.GT.0)GO TO 910
C
C VARIABLE UNDEFINED
CALL ERRMSG(16)
RETCD=2
RETURN
C
C
C
910 IF(NEWTYP.EQ.0) RETURN
IF (OLDTYP.EQ.NEWTYP) RETURN
GOTO (1000,2000,3000,3000,4000,5000,6000,3000,2000), OLDTYP
STOP 1000
C
C
C
C
C
C
C **************************************************
C ************** OLDTYP = ASCII ******************
C **************************************************
C
C START BY CONVERTING TO INTEGER*4
1000 CONTINUE
C
C
C IF INTEGER, HEXADECIMAL OR OCTAL, ALMOST DONE
DO 1002 I=2,100
1002 STACK(I,INDEX)=0
IF (NEWTYP.EQ.3.OR.NEWTYP.EQ.4.OR.NEWTYP.EQ.8) RETURN
C
C
C
DO 1008 I=1,4
1008 FOUR(I)=STACK(I,INDEX)
IF (NEWTYP.EQ.2.OR.NEWTYP.EQ.9) GOTO 1200
C
C
C MULTIPLE PRECISION
1010 BASE=BASVEC (NEWTYP-4)
STACK(100,INDEX)=0
IF (INT.GE.0) GOTO 1014
STACK(100,INDEX)=1
1014 DO 1020 I=1,99
K=INT/BASE
STACK(I,INDEX)=IABS(INT-K*BASE)
INT=K
1020 CONTINUE
RETURN
C
C
C DECIMAL OR REAL
1200 REAL=DFLOAT(INT)
DO 1210 I=1,8
1210 STACK(I,INDEX)=EIGHT(I)
RETURN
C
C
C
C **************************************************
C ********* OLDTYP = DECIMAL OR REAL *************
C **************************************************
C
2000 IF (NEWTYP.EQ.2.OR.NEWTYP.EQ.9) RETURN
C
C
DO 2002 I=1,8
2002 EIGHT(I)=STACK(I,INDEX)
C
C
C ZERO STACK(I,INDEX)
DO 2004 I=1,100
2004 STACK(I,INDEX)=0
C
C
C CONVERT TO INTEGER
C MAKE SURE CONVERSION DOESN'T BLOW UP
IF(REAL.LT.-2147483648.D0.OR.REAL.GT.2147483647.D0)
1 GOTO 6050
C
C
C
2007 INT=REAL
C
C SEE IF NEWTYP IS MULTIPLE PRECISION
IF (NEWTYP.GE.5.AND.NEWTYP.LE.7) GOTO 1010
DO 2008 I=1,4
2008 STACK(I,INDEX)=FOUR(I)
C
C RETURN IF TYPE IS INTEGER, HEX, OR OCTAL
IF (NEWTYP.EQ.3.OR.NEWTYP.EQ.4.OR.NEWTYP.EQ.8) RETURN
C
C ASCII SO CLEAR OUT BYES 2,3, AND 4
2009 DO 2010 I=2,4
2010 STACK(I,INDEX)=0
RETURN
C
C
C
C
C
C
C **************************************************
C ******* OLDTYP = INTEGER, HEX, OR OCTAL ********
C **************************************************
C
3000 IF (NEWTYP.EQ.3.OR.NEWTYP.EQ.4.OR.NEWTYP.EQ.8) RETURN
DO 3002 I=1,4
3002 FOUR(I)=STACK(I,INDEX)
C
C SEE IF NEWTYP IS ASCII
IF (NEWTYP.EQ.1) GOTO 2009
C
C IF NOT REAL*8 THEN IT IS MULTIPLE PRECISION (PROCESS AT 1010)
IF (NEWTYP.NE.2.AND.NEWTYP.NE.9) GOTO 1010
C
C PROCESS AS REAL*8
GOTO 1200
C
C
C
C
C
C
C
C
C **************************************************
C ************* OLDTYP = M10 *********************
C **************************************************
C
4000 CONTINUE
IF (NEWTYP.NE.1) GOTO 4020
C
C
C ASCII
IBASE=10
4004 INT=0
BASE=1
DO 4005 I=1,3
INT=INT+BASE*STACK(I,INDEX)
4005 BASE=BASE*IBASE
DO 4010 I=2,100
4010 STACK(I,INDEX)=0
STACK(1,INDEX)=FOUR(1)
RETURN
C
C
C
C
4020 IF (NEWTYP.NE.3.AND.NEWTYP.NE.4.AND.NEWTYP.NE.8) GOTO 4099
C
C CONVERT TO INTEGER,HEX OR OCTAL
4021 IBASE=10
INT=0
IF (STACK(100,INDEX).NE.0) GOTO 4080
BASE=1
C
C SEE IF NUMBER EXCEEDS MAXIMUM THAT CAN BE HELD IN INTEGER*4
4026 DO 4027 I=11,99
IF(STACK(I,INDEX).NE.0)GO TO 6050
4027 CONTINUE
ISGN=1
IF(BASE.EQ.-1)ISGN=2
J=11
DO 4030 I=1,10
J=J-1
IF (STACK(J,INDEX).EQ.MAX10(I,ISGN)) GOTO 4030
IF (STACK(J,INDEX).GT.MAX10(I,ISGN)) GOTO 6050
GOTO 4032
4030 CONTINUE
4032 IEND=10
C
C
C MAKE THE CALCULATIONS WHICH CONVERT FROM MULTIPLE
C PRECISION TO INTEGER*4
4040 DO 4045 I=1,IEND
INT=INT+STACK(I,INDEX)*BASE
4045 IF (I.NE.IEND) BASE=BASE*IBASE
DO 4050 I=5,99
4050 STACK(I,INDEX)=0
C
4052 DO 4055 I=1,4
4055 STACK(I,INDEX)=FOUR(I)
RETURN
C
C
C
C
C IF NUMBER IS NEGATIVE
4080 BASE=-1
STACK(100,INDEX)=0
GOTO 4026
C
C
C
C
C
C
4099 IF (NEWTYP.NE.2.AND.NEWTYP.NE.9) GOTO 4200
C
C
C MULTIPLE PRECISION TO REAL OR DECIMAL
4100 REAL=0.D0
RBASE=1.D0
RPOWER=DFLOAT(BASVEC(OLDTYP-4))
IF (STACK(100,INDEX).NE.0) RBASE=-1.D0
C
C
C FIND HIGH ORDER DIGIT
DO 4120 I=1,99
K=100-I
IF (STACK(K,INDEX).NE.0) GOTO 4122
4120 CONTINUE
K=1
C
C
C CALCULATE REAL*8 VALUE
4122 DO 4128 I=1,K
M=STACK(I,INDEX)
REAL=REAL+DFLOAT(M)*RBASE
IF (I.NE.K) RBASE=RBASE*RPOWER
4128 CONTINUE
C
C PROPERLY UPDATE STACK
DO 4134 I=9,100
4134 STACK(I,INDEX)=0
DO 4136 I=1,8
4136 STACK(I,INDEX)=EIGHT(I)
RETURN
C
C
C
4200 CONTINUE
C
C CONVERT TO ANOTHER BASE BUT STILL AS MULTIPLE PRECISION
CALL MULCON (STACK,INDEX,OLDTYP,NEWTYP,RETCD)
RETURN
C
C
C
C
C
C
C
C
C **************************************************
C ************** OLDTYP = M8 *********************
C **************************************************
C
5000 CONTINUE
C
C
C NEWTYP=ASCII
IBASE=8
IF (NEWTYP.NE.1) GOTO 5020
GOTO 4004
C
C
C
C
5020 CONTINUE
IF (NEWTYP.NE.3.AND.NEWTYP.NE.4.AND.NEWTYP.NE.8) GOTO 4099
C
C CONVERT TO INTEGER, HEX OR OCTAL
INT=0
BASE=1
IF (STACK(100,INDEX).EQ.0) GOTO 5025
BASE=-1
STACK(100,INDEX)=0
C
C SEE IF NUMBER EXCEEDS MAXIMUM THAT CAN BE HELD IN INTEGER*4
5025 DO 5027 I=12,99
IF(STACK(I,INDEX).NE.0)GO TO 6050
5027 CONTINUE
C
C MAXIMUM NUMBERS ARE -20000000000 AND +17777777777
IS=STACK(11,INDEX)
IS2=1
IF(BASE.EQ.-1)IS2=2
IF(IS.GT.IS2)GO TO 6050
IF(IS.LT.IS2)GO TO 5031
ISGN=7
IF(BASE.LT.0)ISGN=0
J=11
DO 5030 I=1,10
J=J-1
IF (STACK(J,INDEX).EQ.ISGN) GOTO 5030
IF (STACK(J,INDEX).GT.ISGN) GOTO 6050
GOTO 5031
5030 CONTINUE
5031 IEND=11
GO TO 4040
C
C
C
C
C
C
C
C
C
C
C
C
C
C **************************************************
C *************** OLDTYP = M16 *******************
C **************************************************
C
6000 CONTINUE
IBASE=16
INT=0
BASE=1
IF (NEWTYP.NE.1) GOTO 6020
C
C
C ASCII
DO 6010 I=3,100
6010 STACK(I,INDEX)=0
STACK(1,INDEX)=STACK(2,INDEX)*16+STACK(1,INDEX)
STACK(2,INDEX)=0
RETURN
C
C
C
6020 CONTINUE
IF (NEWTYP.NE.3.AND.NEWTYP.NE.4.AND.NEWTYP.NE.8) GOTO 4099
C
C CONVERT TO INTEGER, HEX OR OCTAL
INT=0
BASE=1
IF (STACK(100,INDEX).EQ.0) GOTO 6025
BASE=-1
STACK(100,INDEX)=0
C
C SEE IF MAX. EXCEEDED
6025 DO 6027 I=9,99
IF(STACK(I,INDEX).NE.0)GO TO 6050
6027 CONTINUE
C MAXIMUM NUMBERS ARE +7FFFFFFF AND -80000000
IS=STACK(8,INDEX)
IS2=7
IF(BASE.EQ.-1)IS2=8
IF(IS.GT.IS2)GO TO 6050
IF(IS.LT.IS2)GO TO 6031
ISGN=15
IF(BASE.LE.0)ISGN=0
J=8
DO 6030 I=1,7
J=J-1
IF (STACK(J,INDEX).EQ.ISGN) GOTO 6030
IF (STACK(J,INDEX).GT.ISGN) GOTO 6050
GOTO 6031
6030 CONTINUE
6031 IEND=8
GO TO 4040
C
C
C
C
C
C ***** ERROR RETURN ******
6050 RETCD=2
C ILLEGAL CONVERSION ATTEMPTED.
CALL ERRMSG(26)
RETURN
C
C
C
C
C
C
C
C
END