[pdp8.git] / sw / os8 / v3d / sources / fortran / all / expic.ra

/
/EXPIC
/INTEGER OR REAL RAISED TO COMPLEX
/
/ VERSION 5A 4-26-77 MH
/
/(A)^(C+I*D)
/A=0 YIELDS 0
/D=0 MEANS USE EXP3 TO CALCULATE A^C
/C+D=0 YIELDS 1.0
/ENTER + EXIT IN STARTE
	SECT	#EXPIC
	DPCHK
	EXTERN	#CAC
	EXTERN	EXP
	EXTERN	COS
	EXTERN	SIN
	EXTERN	ALOG
	EXTERN	EXP3
	EXTERN	SQRT
	BASE	0
EXPIC,	JA	.
	FSTA	C,0
	STARTF
	FLDA	0	/BASE
	FSTA	A,0
	BASE	.+2000
	XTA	0
	FSTA	T1		/SAVE XR 0
	FLDA	A
	JNE	EX1	/A NOT 0
	STARTE		/A=B=0
	FCLA
EX,	FSTA	#CAC		/RESULT = 0
	JA	EXPIC
EX1,	FLDA	C		/C+D=0?
	JNE	EX2
	FLDA	D
	JNE	EX2
	STARTE
	FLDA	FP1		/RESULT = 1 IF C=D=0
	JA	EX
EX2,	FLDA	D
	JNE	EX3		/USE EXP3 IF D=0
	JSR	EXP3
	JA	.+6
	JA	A
	JA	C
	FSTA	A
	STARTE
	FLDA	A		/RETURN AS REAL PART
	JA	EX
/
/LOGR=ALOG(SQRT(A*A))
EX3,	FLDA	A
	FMUL	A
	FSTA	LOGR
	JSR	SQRT
	JA	.+4
	JA	LOGR
	FSTA	LOGR
	JSR	ALOG
	JA	.+4
	JA	LOGR
	FSTA	LOGR
/ARG=C+D*LOGR
	FLDA	D
	FMUL	LOGR
	FADD	C
	FSTA	ARG
/
/CALCULATE SIN AND COS OF ARG. SAVE SIGN OF EACH
	JSR	SIN
	JA	.+4
	JA	ARG
	FSTA	SINE
	JSR	COS
	JA	.+4
	JA	ARG
	FSTA	CSINE
/CALL C*LOGR-D
	FLDA	C
	FMUL	LOGR
	FSUB	D
	FSTA	REST
/REAL = EXP(REST+ALOG(CSINE))
	FLDA	CSINE	/REAL
	JLT	.+6
	LDX	0,1		/=1 IF POSITIVE
	JA	.+3
	FNEG
	JSA	DO
	JXN	.+3,0		/SKIP IF POS
	FNEG
	FSTA	C
	FLDA	SINE		/IMAG
	JLT	.+6
	LDX	0,1
	JA	.+5
	LDX	0,0
	FNEG
	JSA	DO
	JXN	.+3,0
	FNEG			/RESTORE SIGN
	FSTA	D
	FLDA	T1		/RESTORE XR0
	ATX	0
	STARTE
	FLDA	C
	FSTA	#CAC
	JA	EXPIC
/
DO,	JA	.
	FSTA	LOGR
	JSR	ALOG
	JA	.+4
	JA	LOGR
	FADD	REST
	FSTA	ARG
	JSR	EXP
	JA	.+4
	JA	ARG
	FSTA	ARG
	FLDA	LOGR		/CHECK SIGN
	JGE	DOX
	FLDA	ARG
	FNEG
	FSTA	ARG
DOX,	FLDA	ARG
	JA	DO
A,	F 0.0
C,	F 0.0
D,	F 0.0
LOGR,	F 0.0
ARG,	F 0.0
SINE,	F 0.0
CSINE,	F 0.0
REST,	F 0.0
FP1,	F 1.0
	F 0.0
T1,	F 0.0
\f
Commit	Line	Data
81e70d48 PH	1	/
	2	/EXPIC
	3	/INTEGER OR REAL RAISED TO COMPLEX
	4	/
	5	/ VERSION 5A 4-26-77 MH
	6	/
	7	/(A)^(C+I*D)
	8	/A=0 YIELDS 0
	9	/D=0 MEANS USE EXP3 TO CALCULATE A^C
	10	/C+D=0 YIELDS 1.0
	11	/ENTER + EXIT IN STARTE
	12	SECT #EXPIC
	13	DPCHK
	14	EXTERN #CAC
	15	EXTERN EXP
	16	EXTERN COS
	17	EXTERN SIN
	18	EXTERN ALOG
	19	EXTERN EXP3
	20	EXTERN SQRT
	21	BASE 0
	22	EXPIC, JA .
	23	FSTA C,0
	24	STARTF
	25	FLDA 0 /BASE
	26	FSTA A,0
	27	BASE .+2000
	28	XTA 0
	29	FSTA T1 /SAVE XR 0
	30	FLDA A
	31	JNE EX1 /A NOT 0
	32	STARTE /A=B=0
	33	FCLA
	34	EX, FSTA #CAC /RESULT = 0
	35	JA EXPIC
	36	EX1, FLDA C /C+D=0?
	37	JNE EX2
	38	FLDA D
	39	JNE EX2
	40	STARTE
	41	FLDA FP1 /RESULT = 1 IF C=D=0
	42	JA EX
	43	EX2, FLDA D
	44	JNE EX3 /USE EXP3 IF D=0
	45	JSR EXP3
	46	JA .+6
	47	JA A
	48	JA C
	49	FSTA A
	50	STARTE
	51	FLDA A /RETURN AS REAL PART
	52	JA EX
	53	/
	54	/LOGR=ALOG(SQRT(A*A))
	55	EX3, FLDA A
	56	FMUL A
	57	FSTA LOGR
	58	JSR SQRT
	59	JA .+4
	60	JA LOGR
	61	FSTA LOGR
	62	JSR ALOG
	63	JA .+4
	64	JA LOGR
65	FSTA LOGR
66	/ARG=C+D*LOGR
67	FLDA D
68	FMUL LOGR
69	FADD C
70	FSTA ARG
71	/
72	/CALCULATE SIN AND COS OF ARG. SAVE SIGN OF EACH
73	JSR SIN
74	JA .+4
75	JA ARG
76	FSTA SINE
77	JSR COS
78	JA .+4
79	JA ARG
80	FSTA CSINE
81	/CALL C*LOGR-D
82	FLDA C
83	FMUL LOGR
84	FSUB D
85	FSTA REST
86	/REAL = EXP(REST+ALOG(CSINE))
87	FLDA CSINE /REAL
88	JLT .+6
89	LDX 0,1 /=1 IF POSITIVE
90	JA .+3
91	FNEG
92	JSA DO
93	JXN .+3,0 /SKIP IF POS
94	FNEG
95	FSTA C
96	FLDA SINE /IMAG
97	JLT .+6
98	LDX 0,1
99	JA .+5
100	LDX 0,0
101	FNEG
102	JSA DO
103	JXN .+3,0
104	FNEG /RESTORE SIGN
105	FSTA D
106	FLDA T1 /RESTORE XR0
107	ATX 0
108	STARTE
109	FLDA C
110	FSTA #CAC
111	JA EXPIC
112	/
113	DO, JA .
114	FSTA LOGR
115	JSR ALOG
116	JA .+4
117	JA LOGR
118	FADD REST
119	FSTA ARG
120	JSR EXP
121	JA .+4
122	JA ARG
123	FSTA ARG
124	FLDA LOGR /CHECK SIGN
125	JGE DOX
126	FLDA ARG
127	FNEG
128	FSTA ARG
129	DOX, FLDA ARG
130	JA DO
131	A, F 0.0
132	C, F 0.0
133	D, F 0.0
134	LOGR, F 0.0
135	ARG, F 0.0
136	SINE, F 0.0
137	CSINE, F 0.0
138	REST, F 0.0
139	FP1, F 1.0
140	F 0.0
141	T1, F 0.0
142	\f