Trailing-Edge
-
PDP-10 Archives
-
BB-D480G-SB_FORTRAN10_V11.0_short
-
mthcdx.mac
There are 9 other files named mthcdx.mac in the archive. Click here to see a list.
SEARCH MTHPRM
TV MTHCDX COMPLEX DOUBLE PRECISION ROUTINES ,1(4100)
;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1979, 1987
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
SUBTTL REVISION HISTORY
COMMENT \
***** Begin Revision History *****
1351 EDS 18-Mar-81 Q10-04786
Fix TWOSEG and RELOC problems.
1404 EGM 6-Apr-81 --------
Separate CDX and CGX routines, add GFL checks to CDX routines.
1405 DAW 6-Apr-81
Support extended addressing.
1464 DAW 12-May-81
Error messages.
***** Begin Version 6A *****
2055 TGS 10-May-82 10-32471
Fix typo in CDLOG so STOR POPJs instead of POPing P and
plowing into YZRO.
***** Begin Mathlib *****
3200 JLC 10-May-82
Mathlib integration. Change all LERRs to $LCALLs. Change
TWOSEG/RELOC to SEGMENT macros.
***** Begin Version 1A *****
3240 RVM 30-Mar-83
CDSQRT used an old standard for register names, this edit
updated the routine to be more modern. Also, memory
locations allocated but not used were deleted.
3246 The double precision sine and cosine functions destroy the
input variables. The result field gets written over the
input variable in some cases.
3247 10-33795 MRB 24-May-83
Fix in CDLOG.
3255 20-19901 MRB 23-Jan-84
The CDLOG routine is returning an incorrect value for the case
(0,0) returns (+inifinity,0) should be (-infinity,0).
***** End Revision History *****
***** Begin Version 10 *****
4100 MRB 16-Apr-84
Change name of CDLOG routine to CDLOG.
(include a symbol named CDLOG equivalenced to CDLOG.)
\
PRGEND
TITLE CDABS COMPLEX ABSOLUTE VALUE FUNCTION
; (DOUBLE PRECISION FLOATING POINT)
SUBTTL IMSL, INC. JUNE 1, 1979
;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1979, 1987
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
SEARCH MTHPRM
NOSYM
ENTRY CDABS
EXTERN CDABS.
CDABS=CDABS.
PRGEND
TITLE CDABS. COMPLEX ABSOLUTE VALUE FUNCTION
; (DOUBLE PRECISION FLOATING POINT)
SUBTTL IMSL, INC. JUNE 1, 1979
;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1979, 1987
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
;CDABS(Z) IS CALCULATED AS FOLLOWS
; LET Z = X + I*Y
; V = MAX(ABS(X),ABS(Y))
; W = MIN(ABS(X),ABS(Y))
; THEN
; CDABS = V*SQRT(1.0 + (W/V)**2)
;THE RANGE OF DEFINITION FOR CDABS IS THE REPRESENTABLE REAL NUMBERS.
; AN OVERFLOW CAN OCCUR, IN WHICH CASE CDABS = + MACHINE INFINITY.
;REQUIRED (CALLED) ROUTINES: DSQRT
;REGISTERS T2, T3, T2, AND T5 WERE SAVED, USED, AND RESTORED
;THE ROUTINE HAS THE FOLLOWING CALLING SEQUENCE:
; XMOVEI L,ARG
; PUSHJ P,CDABS
;THE ROUTINE IS CALLED WITH A DOUBLE PRECISION VECTOR.
;THE REAL PART OF THE ARGUMENT IS EXPECTED TO BE STORED IN THE
;FIRST DOUBLE PRECISION WORD. THE IMAGINARY PART OF THE ARGUMENT
;IS EXPECTED TO BE STORED IN THE SECOND DOUBLE PRECISION WORD.
;THE HIGH ORDER PART OF THE ANSWER IS RETURNED IN T0
;THE LOW ORDER PART OF THE ANSWER IS RETURNED IN T1
SEARCH MTHPRM
SEGMENT CODE
SALL
HELLO (CDABS,.) ;ENTRY TO MODULUS ROUTINE
PUSH P,T2
PUSH P,T3
XMOVEI T2,@(L)
DMOVE T0,(T2) ;ABS(X)
JUMPGE T0,XPOS ;IF X IS NEGATIVE
DMOVN T0,T0 ;X = -X
XPOS: DMOVE T2,2(T2) ;ABS(Y)
JUMPGE T2,YPOS ;IF Y IS NEGATIVE
DMOVN T2,T2 ;Y = -Y
;OBTAIN MAX(ABS(X),ABS(Y))IN T2 AND MIN IN T0.
;ONLY THE HIGH WORDS ARE COMPARED, WHICH CAN RESULT IN THE MAX AND MIN
;BEING INTERCHANGED IF |X| AND |Y| ARE VERY NEARLY EQUAL. THIS IS OK.
;IT CAN RESULT IN SMALLER/LARGER BEING SLIGHTLY GREATER THAN 1.
YPOS: CAMG T0,T2 ;COMPARE |X|HI WITH |Y|HI
JRST LT ;|X| GREATER, NO EXCHANGE NECESSARY
EXCH T2,T0 ;EXCHANGE ABS(X) AND ABS(Y)
EXCH T3,T1 ;
LT: JUMPE T2,RET ;Z = 0, HENCE CDABS = O
DFDV T0,T2 ;U/V
JFCL ANS ;NO OVERFLOW, RATIO NEGLIGIBLE IF UNDERFLOW.
CAMG T0,TWOM32 ;IF RATIO .LE. 2**(-32)
JRST ANS ; RATIO IS NEGLIGIBLE.
DFMP T0,T0 ;**2
DFAD T0,ONE ;+1.0
DMOVEM T0,TEMP
FUNCT DSQRT.,<TEMP> ;SQUARE ROOT IS IN AC T0
DFMP T0,T2 ;*V
JFCL OVFL ;NO UNDERFLOW, GET MESSAGE ON OVERFLOW
RET: POP P,T3
POP P,T2
GOODBY (1) ;RETURN
OVFL: $LCALL ROV,RET
; LERR (LIB,%,<CDABS: result overflow>,RET)
ANS: DMOVE T0,T2 ;ANSWER = ABS(LARGER) TO T0
POP P,T3
POP P,T2
GOODBY (1) ;RETURN
ONE: DOUBLE 201400000000,000000000000
TWOM32: 141400000000 ;2**(-32)
SEGMENT DATA
TEMP: DOUBLE 0,0 ;TEMPORARY STORAGE USED FOR SQRT CALL
PRGEND
TITLE CDEXP COMPLEX EXPONENTIAL FUNCTION
; (DOUBLE PRECISION FLOATING POINT)
SUBTTL IMSL, INC. JUNE 1, 1979
;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1979, 1987
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
SEARCH MTHPRM
NOSYM
ENTRY CDEXP
EXTERN CDEXP.
CDEXP=CDEXP.
PRGEND
TITLE CDEXP. COMPLEX EXPONENTIAL FUNCTION
; (DOUBLE PRECISION FLOATING POINT)
SUBTTL IMSL, INC. JUNE 1, 1979
;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1979, 1987
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;CDEXP(Z), WHERE Z = X + I*Y, IS CALCULATED AS FOLLOWS
; CDEXP FIRST CHECKS THE TYPE OF THE ARGUMENT SO THAT THE
; APPROPRIATE RESULT (DOUBLE PRECISION OR EXTENDED
; PRECISION) IS RETURNED.
; CDEXP(Z) = DEXP(X)*(DCOS(Y)+I*DSIN(Y))
;THE RANGE OF DEFINITION FOR CDEXP IS AS FOLLOWS
;FOR Z = X+I*Y, IF DABS(Y) .GT. 6746518850.429 THE RESULT IS SET TO
; (0.0,0.0) AND AN ERROR MESSAGE IS RETURNED.
;FOR X.LT.-89.415986 THE RESULT IS SET TO (0.0,0.0) AND AN ERROR
; MESSAGE IS RETURNED.
;FOR X .GT. 88.029692;
; IF Y = 0.0, THE RESULT IS SET TO (+INFINITY,0.0) AND AN
; ERROR MESSAGE IS RETURNED.
; IF 88.029 < X < 176.058, AND A COMPONENT OF THE RESULT
; IS OUT OF RANGE, THEN AN ERROR MESSAGE IS RETURNED AND
; ONLY THAT COMPONENT IS SET TO +INFINITY.
; IF X/2. IS .GT. 88.029692, THE DABS(DREAL(RESULT)) IS SET TO
; +INFINITY AND DABS(DIMAG(RESULT)) IS SET TO +INFINITY AND
; AN ERROR MESSAGE IS RETURNED.
;REQUIRED (CALLED) ROUTINES: DEXP,DSIN,DCOS
;REGISTERS T2, T3, T4, AND T5 WERE SAVED, USED, AND RESTORED
;THE ROUTINE HAS THE FOLLOWING CALLING SEQUENCE:
; XMOVEI L,ARG
; PUSHJ P,CDEXP
;THE ROUTINE IS CALLED WITH TWO DOUBLE PRECISION VECTORS.
;THE REAL PART OF THE ARGUMENT IS EXPECTED TO BE STORED IN THE
;FIRST DOUBLE PRECISION WORD OF THE FIRST VECTOR.
;THE IMAGINARY PART OF THE ARGUMENT IS EXPECTED TO BE STORED IN THE
;SECOND DOUBLE PRECISION WORD OF THE FIRST VECTOR.
;THE REAL PART OF THE SOLUTION IS RETURNED IN THE FIRST DOUBLE
;PRECISION WORD OF THE SECOND VECTOR.
;THE IMAGINARY PART OF THE SOLUTION IS RETURNED IN THE SECOND DOUBLE
;PRECISION WORD OF THE SECOND VECTOR.
SEARCH MTHPRM
FSRCH
SEGMENT CODE
SALL
HELLO (CDEXP.,CDEXP) ;ENTRY TO CDEXP ROUTINE
IFN FTGFL,<
LDB T1,[POINTR 0(L),ARGTYP] ;GET FIRST ARG TYPE
CAIN T1,TP%DPX ;G FLOATING?
JRST CGEXP## ;YES
> ;END FTGFL
PUSH P,T2 ;SAVE REGISTER T2
PUSH P,T3 ;SAVE REGISTER T3
PUSH P,T4 ;SAVE REGISTER T4
XMOVEI T2,@(L) ;GET ADDRESS OF Z
DMOVE T0,(T2) ;X=DREAL(Z)
DMOVE T2,2(T2) ;Y=IMAG(Z)
DMOVEM T2,YSAVE ;SAVE Y
JUMPGE T2,YPOS
DMOVN T2,T2
YPOS: CAMGE T2,YMAXH ;IF HI OF Y < YMAXH
JRST YOK ; GO TO YOK
CAME T2,YMAXH ;IF HI OF Y > YMAXH
JRST ERR1 ; GO TO ERR1
CAMG T3,YMAXL ;IF LO OF Y .LE. YMAXL
JRST YOK ; GO TO YOK
ERR1: $LCALL AIZ
; LERR (LIB,%,<entry CDEXP; DIMAG(arg) too large in absolute value; result=(0.0,0.0)>)
SETZ T0, ;REAL PART OF SOLUTION IS ZERO
SETZ T1,
SETZ T2, ;IMAG PART OF SOLUTION IS ZERO
SETZ T3,
XMOVEI T4,@1(L) ;GET ADDRESS OF 2ND ARGUMENT
DMOVEM T0,(T4) ;SAVE REAL PART OF RESULT
DMOVEM T2,2(T4) ;SAVE IMAG PART OF RESULT
POP P,T4 ;RESTORE ACCUMULATORS
POP P,T3
POP P,T2
GOODBY (1)
YOK: PUSH P,T5 ;SAVE ANOTHER REGISTER
DMOVEM T0,XSAVE ;SAVE X
CAMLE T0,NEGH ;IF HI OF X > NEGH
JRST XOK ; GO TO XOK
CAME T0,NEGH ;IF HI OF X < NEGH
JRST ZER ; GO TO ZER
CAML T1,NEGL ;IF LO OF X .GE. NEGL
JRST XOK ; GO TO XOK
ZER: SETZ T0, ;DREAL PART OF SOLUTION IS ZERO
SETZ T1,
SETZ T2, ;IMAG PART OF SOLUTION IS ZERO
SETZ T3,
JRST YCHK ;CHECK Y
XOK: FUNCT DCOS.,<YSAVE> ;DCOSY=DCOS(Y)
DMOVEM T0,DCOSY
FUNCT DSIN.,<YSAVE> ;DSINY=DSIN(Y)
DMOVEM T0,DSINY
DMOVE T4,XSAVE ;T4=X
CAMG T4,XMAXH ;IF X IS NOT TOO LARGE
JRST ALG ;GO TO ALG
SKIPN YSAVE ;ELSE, IF Y=0
JRST ERR0 ;GO TO ERR
CAMGE T4,TBIGH ;IF HI OF S < TBIGH
JRST SOK ; GO TO SOK
CAME T4,TBIGH ;IF HI OF S > TBIGH
JRST STIM ; GO TO STIM
CAMLE T5,TBIGL ;IF LO OF S > TBIGL
JRST STIM ; GO TO STIM
SOK: FSC T4,-1 ;ELSE, S=X/2
DMOVEM T4,DEXPX
FUNCT DEXP.,<DEXPX> ;T=EXP(S)
DMOVE T2,T0
DFMP T2,DSINY ;V=T*DSINY
JUMPGE T2,VPOS ;IF V IS NEGATIVE
DMOVN T2,T2 ;NEGATE IT
VPOS: HRLOI T4,377777 ;G3=XMAX
SETO T5,
DFDV T4,T0 ;Q=XMAX/T
DMOVEM T4,QH ;SAVE Q
CAMLE T2,T4 ;IF V .GT. Q
JRST STIM ;THEN GO TO STIM
CAME T2,QH ;IF V .LT. Q
JRST GETI ;THEN GO TO GETI
CAMG T3,QL ;IF V .LE. Q
JRST GETI ;THEN GO TO GETI
STIM: HRLOI T2,377777 ;ELSE, SET IMAG SOLUTION TO XMAX
SETO T3,
; LERR (LIB,%,<entry CDEXP; DREAL(arg) too large; DIMAG(result)=+infinity>)
$LCALL RTI
JRST D2
GETI: DFMP T2,T0 ;IRES = V*T
D2: SKIPGE DSINY ;IF SINY IS LESS THAN 0.0
DMOVN T2,T2 ;THEN NEGATE IRES
MOVE T4,XSAVE
CAMGE T4,TBIGH ;IF HI OF S < TBIGH
JRST OKS ; GO TO OKS
CAME T4,TBIGH ;IF HI OF S > TBIGH
JRST ERR0 ; GO TO ERR
CAMLE T5,TBIGL ;IF LO OF S > TBIGL
JRST ERR0 ; GO TO ERR
OKS: DMOVE T4,T0
DFMP T0,DCOSY ;V = T*DCOSY
JUMPGE T0,VOK ;IF V IS NEGATIVE
DMOVN T0,T0 ;NEGATE IT
VOK: CAMLE T0,QH ;IF V .GT. Q
JRST ERR0 ;THEN GO TO ERR
CAME T0,QH ;IF V .LT. Q
JRST LAB ;THEN GO TO LAB
CAMG T1,QL ;IF V IS .LE. Q
JRST LAB ;THEN GO TO LAB
ERR0: HRLOI T0,377777 ;RRES=XMAX
SETO T1,
; LERR (LIB,%,<entry CDEXP; DREAL(arg) too large; DREAL(result)=+infinity>)
$LCALL RTR
JRST DD2
LAB: DFMP T0,T4 ;RRES = V*T
DD2: SKIPGE DCOSY ;IF DCOSY .LT. 0.0
DMOVN T0,T0 ;THEN NEGATE RRES
XMOVEI T4,@1(L) ;GET ADDRESS OF 2ND ARGUMENT
DMOVEM T0,(T4) ;SAVE REAL PART OF RESULT
DMOVEM T2,2(T4) ;SAVE IMAG PART OF RESULT
POP P,T5 ;RESTORE ACCUMULATORS
POP P,T4
POP P,T3
POP P,T2
GOODBY (1) ;RETURN
ALG: FUNCT DEXP.,<XSAVE> ;DEXPX = DEXP(X)
DMOVE T2,T0
DFMP T2,DSINY ;IRES = DEXPX*DSINY
JFCL
DFMP T0,DCOSY ;RRES = DEXPX*DCOSY
JFCL
JUMPN T2,RCHK ;IF IRES .NE. 0.0
;THEN GO CHECK RRES
YCHK: SKIPN YSAVE ;IF Y .EQ. 0
JRST RCHK ;THEN GO CHECK RRES
; LERR (LIB,%,<entry CDEXP; underflow has occurred; DIMAG(result)=0.0>)
$LCALL IPU
RCHK: JUMPN T0,RET ;IF R = 0.0
; LERR (LIB,%,<entry CDEXP; underflow has occurred; DREAL(result)=0.0>)
$LCALL RPU
RET: XMOVEI T4,@1(L) ;GET ADDRESS OF 2ND ARGUMENT
DMOVEM T0,(T4) ;SAVE REAL PART OF RESULT
DMOVEM T2,2(T4) ;SAVE IMAG PART OF RESULT
POP P,T5 ;RESTORE ACCUMULATORS
POP P,T4
POP P,T3
POP P,T2
GOODBY (1) ;RETURN
YMAXH: 241622077325 ;HIGH ORDER PART OF YMAX
YMAXL: 011556457065 ;LOW ORDER PART OF YMAX
TBIGH: 210540074636 ;176.059383862226109
TBIGL: 077042573256
NEGH: 570232254036 ;-89.415986292232944914
NEGL: 301750634730
XMAXH: 207540074636 ;88.029691
SEGMENT DATA
QH: 0
QL: 0
DSINY: DOUBLE 0,0
DCOSY: DOUBLE 0,0
XSAVE: DOUBLE 0,0
DEXPX: DOUBLE 0,0
YSAVE: DOUBLE 0,0
PRGEND
TITLE CDLOG COMPLEX LOG FUNCTION
; (DOUBLE PRECISION FLOATING POINT)
SUBTTL Mike Boucher/MRB 16-Apr-84
;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1984, 1987
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
SEARCH MTHPRM
NOSYM
ENTRY CDLOG
EXTERN CDLOG.
CDLOG=CDLOG.
PRGEND
TITLE CDLOG COMPLEX NATURAL LOG FUNCTION
; (DOUBLE PRECISION FLOATING POINT)
SUBTTL Mary Payne 8-Sep-80
;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1979, 1987
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;CDLOG(Z) IS CALCULATED AS FOLLOWS
; CDLOG FIRST CHECKS THE TYPE OF THE ARGUMENT SO THAT THE
; APPROPRIATE RESULT (D OR G) IS RETURNED.
; LET Z = X + I*Y
; IF Y IS NOT ZERO, THEN
; CDLOG(Z) = U + I*V
; U = (1/2) * (DLOG (X**2 + Y**2))
; V = DATAN2(Y,X)
; IF X IS NOT ZERO AND Y IS ZERO, THEN
; IF X IS POSITIVE, CDLOG(Z) = DLOG(X)
; IF X IS NEGATIVE, CDLOG(Z) = DLOG(ABS(X)) + I*PI
; IF X AND Y ARE ZERO, THEN
; CDLOG(Z) = +MACHINE INFINITY
; AND AN ERROR MESSAGE IS RETURNED
;REQUIRED (CALLED) ROUTINES: DLOG, DATAN, DATAN2
;REGISTERS T2, T3, T4, AND T5 WERE SAVED, USED, AND RESTORED
;THE ROUTINE HAS THE FOLLOWING CALLING SEQUENCE:
; XMOVEI L,ARG
; PUSHJ P,CDLOG
;THE ROUTINE IS CALLED WITH TWO DOUBLE PRECISION VECTORS.
;THE REAL PART OF THE ARGUMENT IS EXPECTED TO BE STORED IN THE
;FIRST DOUBLE PRECISION WORD OF THE FIRST VECTOR.
;THE IMAGINARY PART OF THE ARGUMENT IS EXPECTED TO BE STORED IN THE
;SECOND DOUBLE PRECISION WORD OF THE FIRST VECTOR.
;THE REAL PART OF THE SOLUTION IS RETURNED IN THE FIRST DOUBLE
;PRECISION WORD OF THE SECOND VECTOR.
;THE IMAGINARY PART OF THE SOLUTION IS RETURNED IN THE SECOND DOUBLE
;PRECISION WORD OF THE SECOND VECTOR.
SEARCH MTHPRM
SEGMENT CODE
SALL
HELLO (CDLOG.) ;ENTRY TO CDLOG ROUTINE
IFN FTGFL,<
LDB T1,[POINT 4,0(L),12] ;GET FIRST ARG TYPE
CAIN T1,TP%DPX ;G FLOATING?
JRST CGLOG## ;YES
> ;END FTGFL
PUSH P,T2 ;SAVE ACCUMULATORS
PUSH P,T3
PUSH P,T4
XMOVEI T2,@(L) ;GET ADDRESS OF ARG
DMOVE T0,(T2) ;OBTAIN REAL PART OF ARGUMENT
DMOVE T2,2(T2) ;OBTAIN IMAG PART OF ARGUMENT
JUMPE T2,YZRO ;Y = 0 IS A SPECIAL CASE
JUMPE T0,XZRO ;X = 0 IS A SPECIAL CASE
PUSH P,T5 ;SAVE ANOTHER REGISTER
DMOVEM T0,TT0 ;SAVE COPIES OF X AND
DMOVEM T2,TT2 ; Y FOR FUTURE REFERENCE
JUMPGE T0,XPLUS ;IF X < 0
DMOVN T0,T0 ; NEGATE IT
XPLUS: JUMPGE T2,YPLUS ;IF Y < 0
DMOVN T2,T2 ; NEGATE IT
YPLUS: DMOVEM T0,TT4 ;SAVE MAGNITUDES OF
DMOVEM T2,TT6 ; X AND Y
AND T0,MASK ;ISOLATE EXPONENT FIELDS
AND T2,MASK ; OF X AND Y
SUB T2,T0 ;EXPONENT OF Y - EXPONENT OF X
CAML T2,P32 ;IF DIFFERENCE > 32
JRST BIG ; |Y/X| IS LARGE
CAMGE T2,M32 ;IF DIFFERENCE < -32
JRST SMALL ; |Y/X| IS SMALL
FUNCT DATN2.,<TT2,TT0> ;NO EXCEPTIONS CAN OCCUR
XMOVEI T4,@1(L) ;GET POINTER AND STORE
DMOVEM T0,2(T4) ; IMAGINARY PART OF RESULT
DMOVE T4,TT4 ;RECOVER |X|
DMOVE T2,TT6 ;RECOVER |Y|
CAML T4,T2 ;IF |X|HI .GE. |Y|HI,
JRST NOXCH ;NO EXCHANGE NECESSARY
EXCH T4,T2 ;|X|HI .LT. |Y|HI. LARGER = A
EXCH T5,T3 ; TO T4. SMALLER = B TO T2
NOXCH: MOVE T1,T4 ;HI OF LARGER TO T1
LSH T1,-33 ;ISOLATE ITS BIASED EXPONENT
SUBI T1,200 ; AND UNBIAS IT
JUMPLE T1,LE ;IF UNBIASED EXPONENT POSITIVE,
SUBI T1,1 ; DECREMENT IT
LE: MOVN T1,T1 ;NEGATE SCALE INDEX
FSC T4,(T1) ;SCALE A TO [1/2,2) AND B BY
FSC T2,(T1) ; SAME FACTOR. NO EXCEPTIONS
LSH T1,1 ;MULTIPLY NEGATED SCALE INDEX BY 2
DMOVEM T4,BIGGER ;SAVE SCALED LARGER OF |X| AND |Y|
DFMP T4,T4 ;SQUARE LARGER. NO EXCEPTIONS
DFMP T2,T2 ;SQUARE SMALLER. NO EXCEPTIONS
DFAD T4,T2 ;GET SCALED SQUARE OF MODULUS
CAMLE T4,RT2 ;IF T4 .GT. SQRT(2)HI
JRST MORE ; GO TO MORE SCALING
CAMGE T4,RT2O2 ;IF T4 .LT. SQRT(1/2)HI
JRST MORE ; GO TO MORE SCALING
JUMPN T1,JOIN ;IF SCALE INDEX NOT 0, GO TO JOIN
MOVEM T1,NN ; ELSE STORE 0 FOR FUTURE USE
;At this point the scale index is zero, which means that (A**2 + B**2)
;is unscaled. Also (A**2 + B**2) is between SQRT(1/2) and SQRT(2),
;which implies that a damaging loss of significance can occur in the
;calculation of (A**2 + B**2 - 1), which is one factor of Z, used
;in the rational approximation. Growth of error due to loss of
;significance can be avoided by calculating instead
;
; (A - 1) * (A + 1) + B**2
;
;which is done in the following lines of code:
DMOVE T4,BIGGER ;RECOVER LARGER
DMOVE T0,T4 ; AND COPY INTO T0
DFSB T0,ONE ;GET A - 1
DFAD T4,ONE ;AND A + 1
DFMP T4,T0 ;AND THEIR PRODUCT
DFAD T2,T4 ;T2 NOW HAS A**2 + B**2 - 1
DMOVE T4,T2 ;COPY IT INTO T4
DFAD T2,TWO ;GET DENOMINATOR OF Z IN T2
FSC T4,1 ; AND NUMERATOR IN T4
JRST MERGE ;MERGE FOR RATIONAL APPROX
;The following code applies to scaled values of (A**2 + B**2) lying
;outside the interval (SQRT(1/2),SQRT(2)); it carries out more
;scaling to get the scaled (A**2 + B**2) inside this interval.
MORE: MOVE T2,T4 ;HI OF T4 TO T2 FOR RESCALING
LSH T2,-33 ;ISOLATE ITS BIASED EXPONENT
SUBI T2,200 ;UNBIAS THE EXPONENT
MOVN T2,T2 ; AND NEGATE IT
FSC T4,(T2) ;T4 NOW IN [1/2,1)
ADD T1,T2 ;TOTAL NEGATED SCALE INDEX TO T1
CAML T4,RT2O2 ;IF T4 .GT. SQRT(1/2)
JRST JOIN ; SCALING IS DONE
FSC T4,1 ;SCALE T4 TO [1,SQRT(2)]
ADDI T1,1 ; AND INCREMENT NEGATED INDEX
;At this point the scaled (A**2 + B**2) is in the interval
;[SQRT(1/2),SQRT(2)]. T1 contains the negative of the index
;necessary to compensate later for the scaling. In the following
;lines of code, the index, together with its proper sign is
;temporarily stored. Then a rational approximation is used to
;evaluate the natural log of the scaled (A**2 + B**2).
JOIN: MOVNM T1,NN ;RESTORE SIGN OF INDEX AND SAVE
DMOVE T2,T4 ;GET COPY OF SCALED (A**2 + B**2)
FSC T4,1 ; AND MULTIPLY BY 2
DFSB T4,TWO ;SUBTRACT TWO TO GET NUMERATOR
DFAD T2,ONE ;ADD 1 TO GET DENOMINATOR OF Z
;The following code is taken from the DLOG routine. The constants
;A0, A1, A2, B0, B1, and B2 are those given in the DLOG routine.
;Note that all tests restricting the scaled (A**2 + B**2) to
;the interval (SQRT(1/2),SQRT(2)) have been carried out only
;on the "high" words of these limiting values. This is
;adequate for the validity of the approximation to be used,
;since only low order bits, and not the order of magnitude,
;of the error bound of the approximation are affected.
MERGE: DFDV T4,T2 ;Z = ZNUM / ZDEN. NO EXCEPTIONS
DMOVEM T4,SAVEZ ;SAVE A COPY OF Z
DFMP T4,T4 ;W = Z**2
DMOVE T0,T4 ; AND MAKE COPY
DFAD T4,B2 ;FORM B(W) = W + B2
DFMP T4,T0 ; * W
DFAD T4,B1 ; + B1
DFMP T4,T0 ; * W
DFAD T4,B0 ; + B0
DMOVE T2,T0 ;MAKE ANOTHER COPY OF 2
DFMP T0,A2 ;FORM A(W) = W * A2
DFAD T0,A1 ; + A1
DFMP T0,T2 ; * W
DFAD T0,A0 ; + A0
DFDV T0,T4 ;R(Z) = A(W) / B(W)
DFMP T0,SAVEZ ; * Z
DFMP T0,T2 ; * W
JFCL ;NO OVERFLOW, UNDERFLOW WON'T HURT
;As indicated in the DLOG routine, Z still needs to be added into R(Z).
;To increase accuracy, this addition is deferred until after the
;addition, below, of NN * LN(2))LO to the part of R(Z) so far
;obtained.
FLTR T2,NN ;RECOVER SCALE INDEX
JUMPN T2,REST ;IF NN = 0,
DFAD T0,SAVEZ ; COMPLETE R(Z) BY ADDING IN Z
JRST DONE ;GO STORE RESULT AND RESTORE REGISTERS
;The following lines of code complete the calculation of the real
;part for NN not zero. The real part is the sum of NN*(LN(2)HI),
;Z, R(Z), and NN*(LN(2)LO). Of these terms the first is guaranteed
;to have the largest magnitude. THe second has magnitude larger
;than the third by a factor of at least 2**7, and the last has
;magnitude smaller than the first by at least a factor of 2**(-10).
;The maximum value of |Z| is about 2/7, and this is the worst case
;from the point of view of accuracy, because it is only slightly
;smaller than (LN(2)HI). The calculation of Z is accurate to a
;small multiple of its LSB, and hence the calculation of the sum
;is limited to a small multiple of ITS LSB. Note that if |Z| is
;appreciably less than its bound of 2/7, the error bound of the
;sum decreases towards its LSB/2. THe overall accuracy will be
;maximized by summing the terms in the reverse order in which
;they are listed above.
REST: SETZ T3, ;GET DFLOAT(NN)
DMOVE T4,T2 ;GET COPY IN T4
DFMP T4,C2 ;GET NN * LN(2)LO
DFMP T2,C1 ;GET NN * LN(2)HI
DFAD T0,T4 ;R(Z) + NN * LN(2)LO
DFAD T0,SAVEZ ; + Z
DFAD T0,T2 ; + NN * LN(2)HI
DONE: FSC T0,-1 ;DIVIDE BY 2 TO GET LOG OF MODULUS
DMOVEM T0,@1(L) ;STORE REAL PART OF RESUUT
POP P,T5
POP P,T4
POP P,T3
POP P,T2
POPJ P, ;DONE
BIG: FUNCT DLOG.,<TT6> ;GET LN(|Y|)
DMOVE T2,DPIO2 ;IMAGINARY PART NEAR +/- PI/2
SKIPGE TT2 ; + FOR Y POSITIVE
DMOVN T2,T2 ; - FOR Y NEGATIVE
DMOVE T4,TT0 ;[3247]RECOVER X
DFDV T4,TT2 ;[3247]GET X/Y. NO OVERFLOW
JFCL UND1 ; UNDERFLOW IS POSSIBLE
DMOVN T4,T4 ;[3247]GET -X/Y
JRST SMERG ;MERGE WITH SMALL
SMALL: FUNCT DLOG.,<TT4> ;GET LN(|X|)
SETZ T2, ;IMAGINARY PART IS NEAR
SETZ T3, ; 0 OR +/- PI
SKIPGE TT0 ;0 FOR X POSITIVE
DMOVE T2,CPI ; +/-PI FOR X NEGATIVE
SKIPGE TT2 ; + PI FOR Y POSITIVE
DMOVN T2,T2 ; - PI FOR Y NEGATIVE
DMOVE T4,TT2 ;[3247]RECOVER Y
DFDV T4,TT0 ;[3247]GET Y/X. NO OVERFLOW
JFCL UND2 ; UNDERFLOW IS POSSIBLE
SMERG: DFAD T2,T4 ;SMALL CORRECTION FOR IMAG
DFMP T4,T4 ;GET (Y/X)**2. NO OVERFLOW
JFCL UND1 ; INDERFLOW IS POSSIBLE
FSC T4,-1 ;(1/2)*(Y/X)**2. NO OVERFLOW
JFCL UND1 ; UNDERFLOW IS POSSIBLE
DFAD T0,T4 ;REAL = LN(|X|) + (1/2)*(Y/X)**2
JRST STOR ;NO EXCEPTIONS. GO STORE RESULTS
UND2: JUMPN T2,UND1 ;NO MESSAGE IF |IMAG| NEAR PI OR PI/2
; LERR (LIB,%,<CDLOG: Imaginary part underflow>)
$LCALL IPU
UND1: JUMPN T0,STOR ;NO MESSAGE IF LN NOT ZERO
; LERR (LIB,%,<CDLOG: Real part underflow>)
$LCALL RPU
STOR: XMOVEI T4,@1(L) ;GET ADRESS FOR RESULTS
DMOVEM T0,(T4) ;STORE REAL PART
DMOVEM T2,2(T4) ;STORE IMAGINARY PART
POP P,T5 ;RESTORE REGISTERS T5
POP P,T4
POP P,T3
POP P,T2 ;THROUGH T2
POPJ P, ;RETURN
YZRO: JUMPE T0,XYZRO ;X = Y = 0 IS A SPECIAL CASE
JUMPGE T0,RPOS ;Y IS 0, X ISN'T. IF X < 0
DMOVN T0,T0 ;X=ABS(X)
DMOVE T2,CPI ;V=PI
RPOS: DMOVEM T0,TT0 ;MOVE X TO MEMORY
FUNCT DLOG.,<TT0> ;COMPUTE U=DLOG(X); NO EXCEPTIONS
JRST DONE1
XZRO: DMOVE T0,T2 ;X IS 0, Y ISN'T. COPY Y TO T0
DMOVE T2,DPIO2 ;IMAG PART IS +/- PI/2
JUMPGE T0,YPOS ;IF Y < 0,
DMOVN T0,T0 ; MAKE IT POSITIVE, AND
DMOVN T2,T2 ; MAKE IMAG PART NEGATIVE
YPOS: DMOVEM T0,TT0 ;PREPARE TO GET LOG
FUNCT DLOG.,<TT0> ;GET LOG(|Y|), NO EXCEPTIONS
DONE1: XMOVEI T4,@1(L) ;GET THE ADDRESS OF THE SECOND ARGUMENT
DMOVEM T0,(T4) ;SAVE THE REAL PART OF THE ANSWER
DMOVEM T2,2(T4) ;SAVE THE IMAG PART OF THE ANSWER
POP P,T4
POP P,T3 ;RESTORE ACCUMULATORS
POP P,T2
POPJ P, ;RETURN
XYZRO: $LCALL ZIZ
;LERR (LIB,%,<CDLOG: arg is (0.0,0.0); result=(-infinity,0.0)>);[3255]
HRLOI T0,777777 ;[3255]REAL ANSWER IS NEGATIVE INFINITY
SETO T1, ;
XMOVEI T4,@1(L) ;GET THE ADDRESS OF THE SECOND ARGUMENT
DMOVEM T0,(T4) ;SAVE THE REAL PART OF THE ANSWER
DMOVEM T2,2(T4) ;SAVE THE IMAG PART OF THE ANSWER
POP P,T4
POP P,T3 ;RESTORE ACCUMULATORS
POP P,T2
POPJ P, ;RETURN
;CONSTANTS
ONE: EXP 201400000000,000000000000 ;1.0
TWO: EXP 202400000000,000000000000 ;2.0
MASK: EXP 377000000000 ;EXPONENT MASK
P32: EXP 040000000000 ;HIGH 9 BITS = 40 OCTAL
M32: EXP 740000000000 ;HIGH 9 BITS = -40 OCTAL
CPI: EXP 202622077325,021026430215 ;PI
DPIO2: EXP 201622077325,021026430215 ;PI / 2
RT2O2: EXP 200552023632 ;SQRT(2) / 2
RT2: EXP 201552023632 ;SQRT(2)
A0: EXP 570377400073,123045145570 ;-.641249434237455811D2
A1: EXP 205406111210,005527754477 ;.163839435630215342D2
A2: EXP 577153575223,052241327104 ;-.789561128874912573D0
B0: EXP 565177200130,374467610432 ;-.769499321084948798D3
B1: EXP 211470020376,205223175724 ;.312032220919245328D3
B2: EXP 571342517755,046030761117 ;-.356679777390346462D2
B3: EXP 576400000000,000000000000 ;-.1D1
C1: EXP 200543000000,000000000000 ;LN(2)HI
C2: EXP 613102775750,347571527450 ;LN(2)LO
;DATA
SEGMENT DATA
TT0: BLOCK 2 ;FOR DATN2 AND DLOG CALLS
TT2: BLOCK 2 ;FOR ATAN2 CALL
TT4: BLOCK 2 ;FOR ABS(X)
TT6: BLOCK 2 ;FOR ABS(Y)
NN: BLOCK 2 ;FOR SCALE INDEX
BIGGER: BLOCK 2
SAVEZ: BLOCK 2
PRGEND
TITLE CDSIN COMPLEX SINE FUNCTION
; (DOUBLE PRECISION)
SUBTTL IMSL, INC. JUNE 1, 1979
;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1979, 1987
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
SEARCH MTHPRM
NOSYM
ENTRY CDSIN
EXTERN CDSIN.
CDSIN=CDSIN.
PRGEND
TITLE CDCOS COMPLEX COSINE FUNCTION
; (DOUBLE PRECISION)
SUBTTL IMSL, INC. JUNE 1, 1979
;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1979, 1987
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
SEARCH MTHPRM
NOSYM
ENTRY CDCOS
EXTERN CDCOS.
CDCOS=CDCOS.
PRGEND
TITLE CDSIN. COMPLEX SINE AND COSINE ROUTINES
; (DOUBLE PRECISION)
SUBTTL IMSL, INC. JUNE 1, 1979
;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1979, 1987
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;CDSIN(Z) AND CDCOS(Z), WHERE Z = X + I*Y, ARE CALCULATED AS FOLLOWS
; CDSIN FIRST CHECKS THE TYPE OF THE ARGUMENT SO THAT THE
; APPROPRIATE RESULT (DOUBLE PRECISION OR EXTENDED
; PRECISION) WILL BE RETURNED.
; CDSIN(Z) =DSIN(X)*DCOSH(Y) + I*DCOS(X)*DSINH(Y)
; CDCOS(Z) =DCOS(X)*DCOSH(Y) - I*DSIN(X)*DSINH(Y)
; THE FUNCTIONS DSINH AND DCOSH ARE CODED IN LINE.
; THE REAL PART OF CDSIN AND THE IMAGINARY PART OF CDCOS CANNOT UNDERFLOW
; BECAUSE COSH(Y) IS NEVER LESS THAN 1.
; THE OTHER PART OF THE RESULT MAY UNDERFLOW; IF THIS HAPPENS IT IS SET TO 0
; AND A MESSAGE IS PROVIDED.
;THE RANGE OF DEFINITION FOR CDSIN AND CDCOS IS AS FOLLOWS
;FOR
; Z = X+I*Y. IF DABS(X) > ((2**31)*PI - PI/2) THE RESULT IS SET TO 0.0 AND
; AN ERROR MESSAGE IS RETURNED.
;FOR DABS(Y) > 88.029692 CALCULATIONS PROCEED AS FOLLOWS:
; FOR THE REAL PART OF THE RESULT
; LET T = ABS(DSIN(X)), THEN
; FOR T = 0.0 THE REAL PART OF THE RESULT IS SET TO 0.0
; FOR DLOG(T) + DABS(Y) - DLOG(2.0) > 88.722839 THE REAL PART OF THE
; RESULT IS SET TO PLUS OR MINUS MACHINE INFINITY AND
; AN ERROR MESSAGE IS RETURNED. (88.722839=88.029692+LN2)
; FOR THE IMAGINARY PART OF THE RESULT
; LET T = DABS(DCOS(X)), THEN
; FOR T = 0.0 THE IMAGINARY PART OF THE RESULT IS SET TO 0.0
; FOR DLOG(T) + DABS(Y) - DLOG(2.0) > 88.722839 THE IMAGINARY PART OF THE
; RESULT IS SET TO PLUS OR MINUS MACHINE INFINITY AND
; AN ERROR MESSAGE IS RETURNED. (88.722839=88.029692+LN2)
;REQUIRED (CALLED) ROUTINES: DSIN,DCOS,DEXP,DLOG
;REGISTERS T2, T3, T4, AND T5 WERE SAVED, USED, AND RESTORED
;THE ROUTINE HAS THE FOLLOWING CALLING SEQUENCE:
; XMOVEI L,ARG
; PUSHJ P,CDSIN
; OR
; PUSHJ P,CDCOS
;THE ROUTINE IS CALLED WITH TWO DOUBLE PRECISION VECTORS.
;THE REAL PART OF THE ARGUMENT IS EXPECTED TO BE STORED IN THE
;FIRST DOUBLE PRECISION WORD OF THE FIRST VECTOR.
;THE IMAGINARY PART OF THE ARGUMENT IS EXPECTED TO BE STORED IN THE
;SECOND DOUBLE PRECISION WORD OF THE FIRST VECTOR.
;THE REAL PART OF THE SOLUTION IS RETURNED IN THE FIRST DOUBLE
;PRECISION WORD OF THE SECOND VECTOR.
;THE IMAGINARY PART OF THE SOLUTION IS RETURNED IN THE SECOND DOUBLE
;PRECISION WORD OF THE SECOND VECTOR.
SEARCH MTHPRM
FSRCH
SEGMENT CODE
SALL
HELLO (CDCOS.,CDCOS) ;ENTRY TO CDCOS ROUTINE
IFN FTGFL,<
LDB T1,[POINTR 0(L),ARGTYP] ;GET FIRST ARG TYPE
CAIN T1,TP%DPX ;G FLOATING?
JRST CGCOS## ;YES
> ;END FTGFL
PUSH P,T5
MOVEI T5,1 ;SET FLAG TO 1 FOR CDCOS
JRST STRT ;GO TO CDSIN ROUTINE
HELLO (CDSIN.,CDSIN) ;ENTRY TO CMPLX SINE ROUTINE
IFN FTGFL,<
LDB T1,[POINTR 0(L),ARGTYP] ;GET FIRST ARG TYPE
CAIN T1,TP%DPX ;G FLOATING?
JRST CGSIN## ;YES
> ;END FTGFL
PUSH P,T5
BEG: SETZI T5, ;SET FLAG TO 0 FOR CDSIN
STRT: PUSH P,T2
PUSH P,T3
PUSH P,T4
XMOVEI T2,@(L) ;GET ADDRESS OF ARG
DMOVE T0,(T2) ;X = REAL(Z)
DMOVE T3,T0 ;MOVE REAL PART OF ARG TO T4,T5
JUMPGE T3,XPOS ;IF REAL PART OF ARG < 0
DMOVN T3,T3 ;REAL PART=ABS(REAL PART)
XPOS: CAMLE T3,XMAXH ;IF ABS(X) IS TOO LARGE
JRST ERR1 ;GO TO ERR1
CAME T3,XMAXH ;IF ABS(X) IS LESS THAN XMAXH
JRST XOK ;GO TO XOK
CAMG T4,XMAXL ;IF ABS(X) IS NOT TOO LARGE
JRST XOK ;GO TO XOK
ERR1: $LCALL ARZ
;LERR (LIB,%,<CDSIN or CDCOS; DABS(DREAL(arg)) too large; result = (0.0,0.0)>)
SETZI T0, ;SET REAL(RESULT) TO 0.0
SETZ T1,
SETZI T2, ;SET IMAG(RESULT) TO 0.0
SETZ T3,
XMOVEI T4,@1(L) ;GET ADDRESS OF 2ND ARGUMENT
DMOVEM T0,(T4) ;SAVE REAL PART OF RESULT
DMOVEM T2,2(T4) ;SAVE IMAGINARY PART OF RESULT
POP P,T4 ;RESTORE ACCUMULATORS
POP P,T3
POP P,T2
POP P,T5
GOODBY (1) ;RETURN
XOK: DMOVE T2,2(T2) ;Y = IMAG(Z)
DMOVEM T2,YSAVE ;SAVE Y
DMOVEM T0,ARGSAV
FUNCT DSIN.,<ARGSAV> ;CALCULATE DSIN(X)
DMOVEM T0,SX ;SX = DSIN(X)
FUNCT DCOS.,<ARGSAV> ;CALCULATE DCOS(X)
DMOVEM T0,CX ;CX = DCOS(X)
JUMPE T5,NOSWT ;IF THIS IS THE CDSIN ROUTINE
;THEN GO TO NOSWT
DMOVN T2,SX ;OTHERWISE, PUT -DSIN(X)
EXCH T2,CX ;IN CX, AND COS(X)
EXCH T3,CXL
DMOVEM T2,SX ;IN SX.
NOSWT: DMOVE T2,YSAVE ;GET A COPY OF Y
NE: JUMPG T2,YPOS ;IF Y IS NEGATIVE
DMOVN T2,T2 ;NEGATE IT
YPOS: CAMGE T2,XHI ;IF HI OF AY < XHI
JRST YSMALL ; GO TO YSMALL
CAME T2,XHI ;IF HI OF AY > XHI
JRST OVFL ; GO TO OVFL
CAMLE T3,XLO ;IF LO OF AY > XLO
JRST OVFL ; GO TO OVFL
YSMALL: CAMG T2,TWOM31 ;IF ABS(Y) .LE. 2**(-31)
JRST EASY ; GO TO EASY CODE.
CAMGE T2,ONE ;IS ABS(Y) .GE. ONE?
JRST LSTH1 ; BRANCH IF NOT
DMOVEM T2,ARGSAV ;GET COPY OF ABS(Y)
FUNCT DEXP.,<ARGSAV> ;GET EXP(ABS(Y))
DMOVE T4,ONE ;GET EXP(-ABS(Y)) BY
DFDV T4,T0 ; RECIPROCATION.
DFSB T0,T4 ;T0 GETS
FSC T0,-1 ; SINH(ABS(Y))
JRST CCCC ;TO REST OF CALCULATION
LSTH1: DMOVNM T2,ARGSAV ;GET -ABS(Y)
FUNCT DEXP.,<ARGSAV> ; EXP(-ABS(Y))
DMOVE T4,T0
DFMP T2,T2 ;SS = AY**2
DMOVEM T2,TEMP ;SAVE A COPY OF SS
DFAD T2,Q2 ;XDEN = Q2 +SS
DFMP T2,TEMP ;*SS
DFAD T2,Q1 ;+Q1
DFMP T2,TEMP ;*SS
DFAD T2,Q0 ;+Q0
DMOVE T0,TEMP ;SAVE A COPY OF SS
DFMP T0,RP3 ;XNUM = RP3*SS
DFAD T0,RP2 ;+RP2
DFMP T0,TEMP ;*SS
DFAD T0,RP1 ;+RP1
DFMP T0,TEMP ;*SS
DFAD T0,RP0 ;+RP0
DFDV T0,T2 ;XNUM/XDEN
DMOVN T2,ARGSAV ;GET AY BACK
DFMP T0,TEMP ;*SS
DFMP T0,ARGSAV ;*AY
DFAD T0,T2 ;+AY
CCCC: DMOVE T2,T0
DFAD T0,T4 ;CC = SS+(1/T)
DMOVE T4,YSAVE ;RESTORE Y
JUMPGE T4,YOK ;IF Y IS LESS THAN 0.0
DMOVN T2,T2 ;THEN NEGATE SS
YOK: DFMP T0,SX ;GET REAL PART OF RESULT
DFMP T2,CX ;GET IMAG PART OF RESULT
JFCL IMUND ;UNDERFLOW POSSIBLE
XMOVEI T4,@1(L) ;GET ADDRESS OF 2ND ARGUMENT
DMOVEM T0,(T4) ;SAVE REAL PART OF RESULT
DMOVEM T2,2(T4) ;SAVE IMAGINARY PART OF RESULT
POP P,T4 ;RESTORE ACCUMULATORS
POP P,T3
POP P,T2
POP P,T5
GOODBY (1) ;RETURN
OVFL: DMOVE T0,SX ;T=SX
JUMPE T0,GOTR ;IF T IS EQUAL TO 0.
JUMPG T0,SXPOS ;IF SX IS NEGATIVE
DMOVN T0,T0 ;NEGATE SX
SXPOS: DMOVEM T0,ARGSAV ;OTHERWISE
FUNCT DLOG.,<ARGSAV> ;CALCULATE LOG(T)
DFAD T0,T2 ;T = LOG(T)+AY
DFAD T0,LN2 ;T = T-LOG(2.0)
CAMGE T0,XHI ;IF HI OF T < XHI
JRST CONTIN ; GO TO CONTIN
CAME T0,XHI ;IF HI OF T > XHI
JRST ERR2 ; GO TO ERR2
CAMG T1,XLO ;IF LO OF T .LE. XLO
JRST CONTIN ; GO TO CONTIN
ERR2: $LCALL AIR
;LERR (LIB,%,<CDSIN or CDCOS; DABS(DIMAG(arg)) too large; DREAL(result) = infinity>)
HRLOI T0,377777 ;REAL PART OF RESULT SET TO INFINITY
SETO T1, ;SET SECOND WORD
JRST SKP2 ;SKIP NEXT 2 INSTRUCTIONS
CONTIN: DMOVEM T0,ARGSAV
FUNCT DEXP.,<ARGSAV> ;RRES = EXP(T)
SKP2: SKIPGE SX ;IF SX IS LESS THAN 0.
DMOVN T0,T0 ;THEN NEGATE RRES
GOTR: SKIPN T4,CX ;IF CX = 0,
JRST IMAG0 ;THEN PREPARE TO RETURN
MOVE T5,CXL ;OTHERWISE GET LOWER WORD
DMOVEM T0,SX ;SAVE RRES
JUMPGE T4,TPOS ;IF T IS NEGATIVE
DMOVN T4,T4 ;THEN GET ABS(T)
TPOS: DMOVEM T4,ARGSAV
FUNCT DLOG.,<ARGSAV> ;CALCULATE T=LOG(T)
DFAD T2,T0 ;T = T+AY
DFAD T2,LN2 ;T = T-LOG(2)
CAMGE T2,XHI ;IF HI OF T < XHI
JRST CONTN2 ; GO TO CONTN2
CAME T2,XHI ;IF HI OF T > XHI
JRST ERR3 ;GO TO ERR3
CAMG T3,XLO ;IF LO OF T .LE. XLO
JRST CONTN2 ; GO TO CONTN2
ERR3: $LCALL AII
;LERR (LIB,%,CDSIN or CDCOS; DABS(DIMAG(arg)) too large; DIMAG(result) = infinity)
HRLOI T2,377777 ;SET IRES TO INFINITY
SETO T3,
JRST SKP3 ;SKIP NEXT 3 INSTRUCTIONS
CONTN2: DMOVEM T2,ARGSAV
FUNCT DEXP.,<ARGSAV> ;IRES = EXP(T)
DMOVE T2,T0
SKP3: DMOVE T0,SX
MOVE T4,YSAVE
XOR T4,CX ;T4 HAS THE SIGN OF CX*Y
JUMPGE T4,RET ;IF T4 IS LESS THAN 0.
DMOVN T2,T2 ;THEN NEGATE IRES
JRST RET ;RETURN
IMAG0: SETZ T2, ;SET IMAGINARY PART
SETZ T3, ; OF RESULT TO ZERO.
JRST RET ;RETURN
EASY: DMOVE T2,YSAVE ;GET SIGNED VALUE OF Y
DFMP T2,CX ;SINH(Y)*COS(X) = Y*COS(X)
JFCL IMUND ;UNDERFLOW POSSIBLE.
DMOVE T0,SX ;COSH(Y)*SIN(X) = SIN(X).
RET: XMOVEI T4,@1(L) ;[3246]GET ADDRESS OF 2ND ARGUMENT
DMOVEM T0,(T4) ;SAVE REAL PART OF RESULT
DMOVEM T2,2(T4) ;SAVE IMAGINARY PART OF RESULT
POP P,T4
POP P,T3
POP P,T2
POP P,T5
GOODBY (1)
IMUND: $LCALL IPU,RET
; LERR (LIB,%,<CDSIN or CDCOS: imaginary part underflow>,RET)
TWOM31: 142400000000 ;2**(-31)
LN2: DOUBLE 577235067500,101343020625 ;-(NATURAL LOG OF 2.0)
XHI: 207540074636 ;88.029691931113054295
XLO: 077042573256 ;
XMAXH: 241622077325 ;HIGH ORDER OF 2**31 * PI
XMAXL: 012605434744 ;LOW ORDER OF 2**31 * PI
ONE: DOUBLE 201400000000,000000000000
RP0: DOUBLE 223527442325,224632030652 ;.35181283430177117881D+6
RP1: DOUBLE 216551270255,245012217565 ;.11563521196851768270D+5
RP2: DOUBLE 210507410130,341337112321 ;.16375798202630751372D+3
RP3: DOUBLE 200624234756,033744032643 ;.78966127417357099479D+0
Q0: DOUBLE 551376246137,320314355210 ;-.21108770058106271242D+7
Q1: DOUBLE 220432412710,355457306744 ;.36162723109421836460D+5
Q2: DOUBLE 566352207437,215500015770 ;-.27773523119650701667D+3
SEGMENT DATA
CX: 0
CXL: 0
SX: DOUBLE 0,0
YSAVE: DOUBLE 0,0
ARGSAV: DOUBLE 0,0
TEMP: DOUBLE 0,0
PRGEND
TITLE CDSQRT COMPLEX SQUARE ROOT FUNCTION
; (DOUBLE PRECISION FLOATING POINT)
SUBTTL IMSL, INC. JUNE 1, 1979
;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1979, 1987
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
SEARCH MTHPRM
NOSYM
ENTRY CDSQRT
EXTERN CDSQT.
CDSQRT=CDSQT.
PRGEND
TITLE CDSQT. COMPLEX SQUARE ROOT FUNCTION
; (DOUBLE PRECISION FLOATING POINT)
SUBTTL IMSL, INC. JUNE 1, 1979
;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1979, 1987
;ALL RIGHTS RESERVED.
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
; LET Z = X + I*Y
; THEN THE ANSWER CDSQRT(Z) = U + I*V IS DEFINED AS FOLLOWS
; CDSQRT FIRST CHECKS THE TYPE OF THE ARGUMENT SO THAT THE
; APPROPRIATE RESULT (DOUBLE PRECISION OR EXTENDED
; PRECISION) IS RETURNED.
; IF X >= 0.0, THEN
; U = DSQRT((DABS(X)+CDABS(Z))/2.0)
; V = Y/(2.0*U)
; IF X < 0.0 AND Y >= 0.0, THEN
; U = Y/(2.0*V)
; V = DSQRT((DABS(X)+CDABS(Z))/2.0)
; IF X AND Y ARE BOTH < 0.0, THEN
; U = Y/(2.0*V)
; V = -DSQRT((DABS(X)+CDABS(Z))/2.0)
; THE RESULT IS IN THE RIGHT HALF PLANE, THAT IS, THE POLAR ANGLE OF THE
; RESULT LIES IN THE INTERVAL [-PI/2,+PI/2].
;REQUIRED (CALLED) ROUTINES: DSQRT
;REGISTERS T2, T3, T4, T5, P1, P3, AND P4 WERE SAVED, USED, AND RESTORED
;THE ROUTINE HAS THE FOLLOWING CALLING SEQUENCE:
; XMOVEI L,ARG
; PUSHJ P,CDSQRT
;THE ROUTINE IS CALLED WITH TWO DOUBLE PRECISION VECTORS.
;THE REAL PART OF THE ARGUMENT IS EXPECTED TO BE STORED IN THE
;FIRST DOUBLE PRECISION WORD OF THE FIRST VECTOR.
;THE IMAGINARY PART OF THE ARGUMENT IS EXPECTED TO BE STORED IN THE
;SECOND DOUBLE PRECISION WORD OF THE FIRST VECTOR.
;THE REAL PART OF THE SOLUTION IS RETURNED IN THE FIRST DOUBLE
;PRECISION WORD OF THE SECOND VECTOR.
;THE IMAGINARY PART OF THE SOLUTION IS RETURNED IN THE SECOND DOUBLE
;PRECISION WORD OF THE SECOND VECTOR.
;[3240] Use the new names of the preserved registers, P1-P4,
;[3240] rather than the old names G1-G4.
SEARCH MTHPRM
FSRCH
SEGMENT CODE
SALL
HELLO (CDSQT.,CDSQRT) ;ENTRY TO COMPLEX SQUARE ROOT ROUTINE.
IFN FTGFL,<
LDB T1,[POINTR 0(L),ARGTYP] ;GET FIRST ARG TYPE
CAIN T1,TP%DPX ;G FLOATING?
JRST CGSQRT## ;YES
> ;END FTGFL
PUSH P,T2 ;SAVE ACCUMULATORS
PUSH P,T3
XMOVEI T2,@0(L) ;PICK UP ADDRESS OF ARGUMENT
DMOVE T0,(T2) ;PICK UP X IN AC T0.
DMOVE T2,2(T2) ;PICK UP Y IN AC T2.
PUSH P,T4 ;SAVE AC T4.
PUSH P,T5
JUMPE T2,ZREAL ;JUMP IF Y=0
JUMPE T0,ZIMAG ;JUMP IF X=0
DMOVE T4,T0 ;DABS(X) TO AC T4.
JUMPGE T0,XPOS ;IF X IS NEGATIVE
DMOVN T4,T4 ;NEGATE
XPOS: PUSH P,P1 ;SAVE REGISTER P1.
PUSH P,P3 ;SAVE REGISTER P3
PUSH P,P4 ;SAVE REGISTER P4
DMOVEM T0,XSAVE ;SAVE X IN XSAVE
DMOVEM T2,YSAVE ;SAVE Y IN YSAVE
DMOVE P3,T2 ;DABS(Y) TO AC P3.
JUMPGE T2,YPOS ;IF Y IS NEGATIVE
DMOVN P3,T2 ;NEGATE IT
YPOS: HRRZI P1,1 ;SET P1 TO 1
CAML T4,P3 ;IF ABS(X) > ABS(Y)
JRST DWN ;THEN GO TO DWN
;IF HIGH WORDS OF |X| AND |Y| ARE EQUAL,
; DON'T BOTHER DECIDING WHETHER TO EXCHANGE
; THEM. IF |X| AND |Y| ARE NEARLY EQUAL,
; THEIR MAX AND MIN MAY BE SWITCHED BELOW.
; THIS MEANS THAT S/L MAY BE SLIGHTLY GREATER
; THAN 1, BUT THIS DOES NOT HURT.
XCHNG: EXCH T4,P3 ;PUT MAX(ABS(X),ABS(Y)) IN T4
EXCH T5,P4 ;AND MIN(ABS(X),ABS(Y)) IN P3,P4
SETZ P1, ;SET P1 TO 0
DWN: DFDV P3,T4 ;CALC S/L.
JFCL ;NO UNDERFLOW ERROR MESSAGE ALLOWED.
DFMP P3,P3 ;CALC (S/L)**2.
JFCL ;NO UNDERFLOW ERROR MESSAGE ALLOWED.
DFAD P3,ONE ;HAVE (1+(S/L)**2) IN AC P3.
DMOVEM P3,TEMP
FUNCT DSQRT.,<TEMP> ;CALC. THE DSQRT OF
;(1+(S/L)**2)=1+EPS.
JUMPE P1,YGTX ;GO TO YGTX IF DABS(Y) > DABS(X).
XGTY: DFAD T0,ONE ;CALC. 2 + EPS.
FSC T0,-1 ;CALC. 1+EPS/2.
DMOVEM T0,TEMP ;PUT IN TEMP FOR
FUNCT DSQRT.,<TEMP> ;CALL TO DSQRT
DMOVE P3,T0 ;SAVE DSQRT(1+EPS/2) IN AC P3.
DMOVEM T4,TEMP
FUNCT DSQRT.,<TEMP> ;CALC.
DFMP T0,P3 ;CALC. DSQRT(DABS(X)*(1+EPS/2)).
JRST OUT1 ;GO TO REST OF CALC.
YGTX: CAIGE T4,201400 ;IF DABS(Y)>1, GO TO POSSIBLE OVERFLOW CASE.
JRST YXSMAL ;ELSE, GO TO POSSIBLE UNDERFLOW.
FSC T0,-3 ;CALC. (1+EPS)/8
DFMP T4,T0 ;CALC. DABS(Y)*(1+EPS)/8
DMOVE T0,XSAVE ;DABS(X) TO AC T0
JUMPGE T0,NXT
DMOVN T0,T0
NXT: FSC T0,-3 ;CALC. DABS(X)/8
JFCL ;SUPPRESS UNDERFLOW ERROR MESSAGE.
DFAD T0,T4 ;CALC.(DABS(X)/8)+(DABS(Y)*(1+EPS)/8).
DMOVEM T0,TEMP
FUNCT DSQRT.,<TEMP> ;CALC.
FSC T0,1 ;DSQRT(DABS(X)/2 + (DABS(Y)*(1+EPS)/2)).
OUT1: JUMPGE T2,POSY
DMOVN T2,T2
POSY: DFDV T2,T0 ;DIVIDE DABS(Y)/2 BY THE
JFCL UNDFL
FSC T2,-1 ;SQRT TERM.
JFCL UNDFL
JRST SIGNS ;GO TO REST OF CALC.
YXSMAL: DFMP T0,T4 ;DABS(Y)*(1+EPS) = CDABS(Z).
DMOVE P3,XSAVE ;DABS(X) TO AC P3.
JUMPGE P3,XOK ;IF X IS NEGATIVE
DMOVN P3,P3 ;NEGATE IT
XOK: DFAD P3,T0 ;GET |X| + CDABS(Z)
FSC P3,1 ;MULTIPLY ARG BY 2
DMOVEM P3,TEMP ;SAVE FOR DSQRT
FUNCT DSQRT.,<TEMP> ;CALC. DSQRT OF 2 * (|X| + CDABS(Z))
DMOVE P3,T0 ;GET DSQRT((|X| + CDABS(Z))*2)
FSC T0,-1 ;GET DSQRT((|X| + CDABS(Z))/2)
DFDV T4,P3 ;GET |Y| / DSQRT (2 * (|X| + CDABS(Z)))
DMOVE T2,T4 ;PUT A TEMP ANSWER IN AC T2.
SIGNS: SKIPL XSAVE ;IF NEGATIVE X, SWITCH REAL & IMAG
JRST OK ; PARTS OF RESULT
EXCH T2,T0 ;EXCHANGE
EXCH T1,T3 ;EXCHANGE
;SET UP THE REAL AND
;THE IMAGINARY ANSWERS WITH
OK: SKIPGE YSAVE ;THE APPROPRIATE
DMOVN T2,T2 ;SIGNS.
XMOVEI T4,@1(L) ;GET THE ADDRESS OF THE SECOND ARGUMENT
DMOVEM T0,(T4) ;SAVE REAL PART OF RESULT
DMOVEM T2,2(T4) ;SAVE IMAG PART OF RESULT
POP P,P4 ;RESTORE AC P4
POP P,P3 ;RESTORE AC P3
POP P,P1 ;RESTORE AC P1
POP P,T5 ;RESTORE AC T5
POP P,T4 ;RESTORE AC T4
POP P,T3 ;RESTORE AC T3
POP P,T2 ;RESTORE AC T2
GOODBY (1) ;RETURN
ZREAL: JUMPE T0,DONE ;Y = 0, HOW ABOUT X?
MOVE T4,T0 ;X NOT ZERO, SAVE IT.
JUMPGE T0,POSX ;GET DABS(X) FOR DSQRT
DMOVN T0,T0
POSX: DMOVEM T0,TEMP
FUNCT DSQRT.,<TEMP> ;T0,T1 GET DSQRT(DABS(X))
JUMPG T4,DONE ;T0,T1 AND T2,T3 OK FOR X .GE. 0
EXCH T0,T2 ;INTERCHANGE FOR X<0
EXCH T1,T3 ;
JRST DONE ;FINISHED
ZIMAG: MOVE T4,T2 ;X=0, SAVE Y
JUMPGE T2,PSY ;IF Y < 0
DMOVN T2,T2 ; NEGATE IT
PSY: FSC T2,-1 ;GET |Y|/2
DMOVEM T2,TEMP ; AND STORE IT FOR DSQRT
FUNCT DSQRT.,<TEMP> ;T0,T1 GETS DSQRT(DABS(Y/2))
DMOVE T2,T0 ;T2,T3 ALSO
JUMPG T4,DONE ;DONE IF Y > 0
DMOVN T2,T2 ;NEGATE IMAGINARY PART IF Y < 0
DONE: XMOVEI T4,@1(L) ;GET THE ADDRESS OF THE SECOND ARGUMENT
DMOVEM T0,(T4) ;SAVE REAL PART OF RESULT
DMOVEM T2,2(T4) ;SAVE IMAG PART OF RESULT
POP P,T5 ;RESTORE ACCUMULATORS
POP P,T4
POP P,T3
POP P,T2 ;RESTORE AC T2.
GOODBY (1) ;RETURN
UNDFL: SKIPGE XSAVE ;DOES RESULT HAVE REAL & IMAG PARTS SWITCHED?
$LCALL RPU,UFCONT
; LERR (LIB,%,<CDSQRT: real part underflow>,UFCONT)
$LCALL IPU
; LERR (LIB,%,<CDSQRT: imaginary part underflow>)
UFCONT: SETZB T2,T3 ;STORE 0 FOR RESULT OF UNDERFLOW
JRST SIGNS
ONE: DOUBLE 201400000000,000000000000 ;1.0D0
SEGMENT DATA
TEMP: DOUBLE 0,0 ;TEMPORARY STORAGE FOR DSQRT ARGS
XSAVE: DOUBLE 0,0
YSAVE: DOUBLE 0,0
END