PDP-10 Archive: decus/20-0001/contyp.for from decuslib20-01

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