X-Git-Url: http://gitweb.hachti.de/?a=blobdiff_plain;f=sw%2Fos8%2Fv3d%2Fsources%2Ffortran%2Fall%2Fexpic.ra;fp=sw%2Fos8%2Fv3d%2Fsources%2Ffortran%2Fall%2Fexpic.ra;h=7c2d22c6bce5e97ec6888799b8a417c2e73b5604;hb=81e70d488b71bf995c459ca3a02c025993460ffa;hp=0000000000000000000000000000000000000000;hpb=07ec0278333ed187ac242dedcff13c56cf1b0b91;p=pdp8.git

diff --git a/sw/os8/v3d/sources/fortran/all/expic.ra b/sw/os8/v3d/sources/fortran/all/expic.ra
new file mode 100644
index 0000000..7c2d22c
--- /dev/null
+++ b/sw/os8/v3d/sources/fortran/all/expic.ra
@@ -0,0 +1,142 @@
+/
+/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
+