22300 #include "rundecs.h"
22310    (*  COPYRIGHT 1983 C.H.LINDSEY, UNIVERSITY OF MANCHESTER  *)
22320 (**)
22330 PROCEDURE ERRORR(N: INTEGER);EXTERN;
22340 PROCEDURE GARBAGE(ANOBJECT: OBJECTP);EXTERN;
22350 FUNCTION SAFEACCESS(LOCATION: OBJECTP): UNDRESSP; EXTERN;
22360 (**)
22370 (**)
22380 FUNCTION CRCOMPLEX(REPART,IMAGPART: REAL): OBJECTP;
22390   VAR NEWCOMPLEX: OBJECTP;
22400     BEGIN
22410     ENEW(NEWCOMPLEX, STRUCTCONST+2*SZREAL);
22420     WITH NEWCOMPLEX^ DO
22430       BEGIN
22440 (*-02() FIRSTWORD := SORTSHIFT * ORD(STRUCT); ()-02*)
22450 (*+02() PCOUNT:=0; SORT:=STRUCT; ()+02*)
22460       LENGTH := STRUCTCONST+2*SZREAL;
22470       DBLOCK := COMPLEX;
22480       RE := REPART;
22490       IM := IMAGPART
22500       END;
22510     CRCOMPLEX := NEWCOMPLEX
22520     END;
22530 (**)
22540 (**)
22550 FUNCTION WIDREAL(REA: REAL): OBJECTP;
22560 (*PWIDEN+2*)
22570     BEGIN
22580     WIDREAL := CRCOMPLEX(REA,0.0)
22590     END;
22600 (**)
22610 (**)
22620 FUNCTION CPLUS(LEFT,RIGHT: OBJECTP): OBJECTP;
22630   VAR NEWOBJ: OBJECTP;
22640     BEGIN
22650     IF FPTST(LEFT^) THEN NEWOBJ := LEFT
22660     ELSE IF FPTST(RIGHT^) THEN NEWOBJ := RIGHT
22670       ELSE NEWOBJ := CRCOMPLEX(0.0,0.0);
22680     WITH NEWOBJ^ DO
22690       BEGIN
22700       RE := LEFT^.RE+RIGHT^.RE;
22710       IM := LEFT^.IM+RIGHT^.IM
22720       END;
22730     IF (FPTST(LEFT^)) AND (FPTST(RIGHT^)) THEN GARBAGE(RIGHT);
22740     CPLUS := NEWOBJ
22750     END;
22760 (**)
22770 (**)
22780 FUNCTION CMINUS(LEFT,RIGHT: OBJECTP): OBJECTP;
22790   VAR NEWOBJ: OBJECTP;
22800     BEGIN
22810     IF FPTST(LEFT^) THEN NEWOBJ := LEFT
22820     ELSE IF FPTST(RIGHT^) THEN NEWOBJ := RIGHT
22830       ELSE NEWOBJ := CRCOMPLEX(0.0,0.0);
22840     WITH NEWOBJ^ DO
22850       BEGIN
22860       RE := LEFT^.RE-RIGHT^.RE;
22870       IM := LEFT^.IM-RIGHT^.IM
22880       END;
22890     IF (FPTST(LEFT^)) AND (FPTST(RIGHT^)) THEN GARBAGE(RIGHT);
22900     CMINUS := NEWOBJ
22910     END;
22920 (**)
22930 (**)
22940 FUNCTION CTIMS(LEFT,RIGHT: OBJECTP): OBJECTP;
22950   VAR NEWOBJ: OBJECTP;
22960       TEMPREAL: REAL;
22970     BEGIN
22980     IF FPTST(LEFT^) THEN NEWOBJ := LEFT
22990     ELSE IF FPTST(RIGHT^) THEN NEWOBJ := RIGHT
23000       ELSE NEWOBJ := CRCOMPLEX(0.0,0.0);
23010     TEMPREAL := LEFT^.RE*RIGHT^.RE-LEFT^.IM*RIGHT^.IM;
23020     WITH NEWOBJ^ DO
23030       BEGIN
23040       IM := LEFT^.RE*RIGHT^.IM+LEFT^.IM*RIGHT^.RE;
23050       RE := TEMPREAL
23060       END;
23070     IF (FPTST(LEFT^)) AND (FPTST(RIGHT^)) THEN GARBAGE(RIGHT);
23080     CTIMS := NEWOBJ
23090     END;
23100 (**)
23110 (**)
23120 FUNCTION CDIV(LEFT,RIGHT: OBJECTP): OBJECTP;
23130   VAR NEWOBJ: OBJECTP;
23140       TEMPREAL,RIGHTSQR: REAL;
23150     BEGIN
23160     IF FPTST(LEFT^) THEN NEWOBJ := LEFT
23170     ELSE IF FPTST(RIGHT^) THEN NEWOBJ := RIGHT
23180       ELSE NEWOBJ := CRCOMPLEX(0.0,0.0);
23190     RIGHTSQR := SQR(RIGHT^.RE)+SQR(RIGHT^.IM);
23200     TEMPREAL := (LEFT^.RE*RIGHT^.RE+LEFT^.IM*RIGHT^.IM)/RIGHTSQR;
23210     WITH NEWOBJ^ DO
23220       BEGIN
23230       IM := (LEFT^.IM*RIGHT^.RE-LEFT^.RE*RIGHT^.IM)/RIGHTSQR;
23240       RE := TEMPREAL
23250       END;
23260     IF (FPTST(LEFT^)) AND (FPTST(RIGHT^)) THEN GARBAGE(RIGHT);
23270     CDIV := NEWOBJ
23280     END;
23290 (**)
23300 (**)
23310 FUNCTION CNEGI(CNUMB: OBJECTP): OBJECTP;
23320   VAR NEWOBJ: OBJECTP;
23330     BEGIN
23340     IF FPTST(CNUMB^) THEN NEWOBJ := CNUMB
23350     ELSE NEWOBJ := CRCOMPLEX(0.0,0.0);
23360     WITH NEWOBJ^ DO
23370       BEGIN
23380       RE := -CNUMB^.RE;
23390       IM := -CNUMB^.IM
23400       END;
23410     CNEGI := NEWOBJ
23420     END;
23430 (**)
23440 (**)
23450 FUNCTION CCONJ(CNUMB: OBJECTP): OBJECTP;
23460   VAR NEWOBJ: OBJECTP;
23470     BEGIN
23480     IF FPTST(CNUMB^) THEN NEWOBJ := CNUMB
23490     ELSE NEWOBJ := CRCOMPLEX(0.0,0.0);
23500     WITH NEWOBJ^ DO
23510       BEGIN
23520       RE := CNUMB^.RE;
23530       IM := -CNUMB^.IM
23540       END;
23550     CCONJ := NEWOBJ
23560     END;
23570 (**)
23580 (**)
23590 FUNCTION CRE(CNUMB: OBJECTP): REAL;
23600     BEGIN
23610     CRE := CNUMB^.RE;
23620     IF FPTST(CNUMB^) THEN GARBAGE(CNUMB)
23630     END;
23640 (**)
23650 (**)
23660 FUNCTION CIM(CNUMB: OBJECTP): REAL;
23670     BEGIN
23680     CIM := CNUMB^.IM;
23690     IF FPTST(CNUMB^) THEN GARBAGE(CNUMB)
23700     END;
23710 (**)
23720 (**)
23730 FUNCTION CABSI(CNUMB: OBJECTP): REAL;
23740     BEGIN
23750     WITH CNUMB^ DO
23760       CABSI := SQRT(SQR(RE)+SQR(IM));
23770     IF FPTST(CNUMB^) THEN GARBAGE(CNUMB)
23780     END;
23790 (**)
23800 (**)
23810 FUNCTION ARG(CNUMB: OBJECTP): REAL;
23820   VAR RESULT: REAL;
23830     BEGIN
23840     WITH CNUMB^ DO
23850       IF (RE<>0.0) OR (IM<>0.0) THEN
23860         IF ABS(RE)>ABS(IM) THEN
23870           RESULT := ARCTAN(IM/RE)+HALFPI.ACTUALPI*(1-ORD(RE>0.0))*2*(1-2*ORD(IM<0.0))
23880           ELSE RESULT := -ARCTAN(RE/IM)+HALFPI.ACTUALPI*(ORD(IM>0.0)-ORD(IM<0.0))
23890       ELSE ERRORR(RARG);
23900     ARG := RESULT
23910     END;
23920 (**)
23930 (**)
23940 FUNCTION CARG(CNUMB: OBJECTP): REAL;
23950     BEGIN
23960     CARG := ARG(CNUMB);
23970     IF FPTST(CNUMB^) THEN GARBAGE(CNUMB)
23980     END;
23990 (**)
24000 (**)
24010 FUNCTION CPOW(CNUMB: OBJECTP;POW: INTEGER): OBJECTP;
24020   VAR NEWOBJ: OBJECTP;
24030     CMOD,CMODPOW,NTHETA: REAL;
24040     NEGPOW: BOOLEAN;
24050     BEGIN
24060     IF FPTST(CNUMB^) THEN NEWOBJ := CNUMB
24070       ELSE NEWOBJ := CRCOMPLEX(0.0,0.0);
24080     WITH CNUMB^ DO
24090       CMOD := SQRT(SQR(RE)+SQR(IM));
24100     IF CMOD<>0.0 THEN
24110       BEGIN
24120       NEGPOW := POW<0;
24130       POW := ABS(POW);
24140       NTHETA := POW*ARG(CNUMB);
24150       CMODPOW := 1;
24160       WHILE POW<>0 DO
24170         BEGIN
24180         IF POW MOD 2=1 THEN CMODPOW := CMODPOW*CMOD;
24190         CMOD := SQR(CMOD);
24200         POW := POW DIV 2
24210         END;
24220       WITH NEWOBJ^ DO
24230         BEGIN
24240         RE := COS(NTHETA)*CMODPOW;
24250         IM := SIN(NTHETA)*CMODPOW;
24260         IF NEGPOW THEN
24270           BEGIN
24280           CMOD := SQR(RE)+SQR(IM);
24290           RE := RE/CMOD;
24300           IM := -IM/CMOD
24310           END
24320         END
24330       END
24340       ELSE WITH NEWOBJ^ DO
24350         BEGIN
24360         RE := 0.0;
24370         IM := 0.0
24380         END;
24390     CPOW := NEWOBJ;
24400     END;
24410 (**)
24420 (**)
24430 FUNCTION CEQ(LEFT,RIGHT: OBJECTP): INTEGER;
24440   VAR EQUALS: BOOLEAN;
24450     BEGIN
24460     EQUALS := (LEFT^.RE=RIGHT^.RE) AND (LEFT^.IM=RIGHT^.IM);
24470     IF FPTST(LEFT^) THEN GARBAGE(LEFT);
24480     IF FPTST(RIGHT^) THEN GARBAGE(RIGHT);
24490     IF EQUALS THEN CEQ := TRUEVAL ELSE CEQ := 0
24500     END;
24510 (**)
24520 (**)
24530 FUNCTION CNE(LEFT,RIGHT: OBJECTP): INTEGER;
24540   VAR NOTEQUAL: BOOLEAN;
24550     BEGIN
24560     NOTEQUAL := (LEFT^.RE<>RIGHT^.RE) OR (LEFT^.IM<>RIGHT^.IM);
24570     IF FPTST(LEFT^) THEN GARBAGE(LEFT);
24580     IF FPTST(RIGHT^) THEN GARBAGE(RIGHT);
24590     IF NOTEQUAL THEN CNE := TRUEVAL ELSE CNE := 0
24600     END;
24610 (**)
24620 (**)
24630 FUNCTION CPLUSAB(DESTINATION,INCREMENT: OBJECTP): OBJECTP;
24640   VAR REALPTR: UNDRESSP;
24650     BEGIN
24660     REALPTR := SAFEACCESS(DESTINATION);
24670     REALPTR^.FIRSTREAL := REALPTR^.FIRSTREAL+INCREMENT^.RE;
24680     REALPTR := INCPTR(REALPTR,SZREAL);
24690     REALPTR^.FIRSTREAL := REALPTR^.FIRSTREAL+INCREMENT^.IM;
24700     IF FPTST(INCREMENT^) THEN GARBAGE(INCREMENT);
24710     CPLUSAB := DESTINATION
24720     END;
24730 (**)
24740 (**)
24750 FUNCTION CMINAB(DESTINATION,DECREMENT: OBJECTP): OBJECTP;
24760   VAR REALPTR: UNDRESSP;
24770     BEGIN
24780     REALPTR := SAFEACCESS(DESTINATION);
24790     REALPTR^.FIRSTREAL := REALPTR^.FIRSTREAL-DECREMENT^.RE;
24800     REALPTR := INCPTR(REALPTR,SZREAL);
24810     REALPTR^.FIRSTREAL := REALPTR^.FIRSTREAL-DECREMENT^.IM;
24820     IF FPTST(DECREMENT^) THEN GARBAGE(DECREMENT);
24830     CMINAB := DESTINATION
24840     END;
24850 (**)
24860 (**)
24870 FUNCTION CTIMSAB(DESTINATION,FACTOR: OBJECTP): OBJECTP;
24880   VAR REALPTR,IMAGPTR: UNDRESSP;
24890       TEMPREAL: REAL;
24900     BEGIN
24910     REALPTR := SAFEACCESS(DESTINATION);
24920     IMAGPTR := INCPTR(REALPTR,SZREAL);
24930     TEMPREAL := REALPTR^.FIRSTREAL*FACTOR^.RE-IMAGPTR^.FIRSTREAL*FACTOR^.IM;
24940     IMAGPTR^.FIRSTREAL := REALPTR^.FIRSTREAL*FACTOR^.IM+IMAGPTR^.FIRSTREAL*FACTOR^.RE;
24950     REALPTR^.FIRSTREAL := TEMPREAL;
24960     IF FPTST(FACTOR^) THEN GARBAGE(FACTOR);
24970     CTIMSAB := DESTINATION
24980     END;
24990 (**)
25000 (**)
25010 FUNCTION CDIVAB(DESTINATION,DIVISOR: OBJECTP): OBJECTP;
25020   VAR REALPTR,IMAGPTR: UNDRESSP;
25030       TEMPREAL,DIVISORSQR: REAL;
25040     BEGIN
25050     REALPTR := SAFEACCESS(DESTINATION);
25060     IMAGPTR := INCPTR(REALPTR,SZREAL);
25070     DIVISORSQR := SQR(DIVISOR^.RE)+SQR(DIVISOR^.IM);
25080     TEMPREAL := (REALPTR^.FIRSTREAL*DIVISOR^.RE+IMAGPTR^.FIRSTREAL*DIVISOR^.IM)/DIVISORSQR;
25090     IMAGPTR^.FIRSTREAL := (IMAGPTR^.FIRSTREAL*DIVISOR^.RE-REALPTR^.FIRSTREAL*DIVISOR^.IM)/DIVISORSQR;
25100     REALPTR^.FIRSTREAL := TEMPREAL;
25110     IF FPTST(DIVISOR^) THEN GARBAGE(DIVISOR);
25120     CDIVAB := DESTINATION
25130     END;
25140 (**)
25150 (**)
25160 (*-02()
25170 BEGIN (* OF A68 *)
25180 END (* OF A68 *);
25190 ()-02*)
25200 (*+01()
25210 BEGIN (* OF MAIN PROGRAM  *)
25220 END (* OF MAIN PROGRAM  *).
25230 ()+01*)