C********************************************************** C* PLTTER GEAR-LIKE / SCHWARZ CHRISTOFFEL PLTTER *** C********************************************************** SUBROUTINE PLTTER (PAPER,SCAL,DMESH,INC,INR, & FN,TITLE,ITITLE,IFOOT, & PLTCLR,CIRCLR,RADCLR, & N,C,Z,WC,W,BETA,NPTSQ,QW) C C GENERATES A SEQUENCE OF DISSPLA PLOT COMMANDS C C CALLING SEQUENCE: C C PAPER PHYSICAL SIZE (RADIUS) OF PAGE FOR THE PLOT C C SCAL SCALE FACTOR FOR CONSTRUCTING PLOT. ANY POINTS C FOR WHICH THE MODULUS IS GREATER THAN C PAPER/|SCAL| WILL BE TRUNCATED. C C IF SCAL IS GREATER THAN 0, THEN THE SCAL C WILL BE TREATED AS ABSOLUTE. C IF SCAL IS LESS THAN 0, THEN C 1) IF THE PLOT IS UNBOUNDED THEN, C SCAL WILL BE TREATED AS C ABSOLUTE C 2) IF THE PLOT IS BOUNDED THEN, C SCAL WILL BE RECALCULATED SO C THAT THE ENTIRE PLOT WILL BE C DISPLAYED. C C DMESH MAXIMUM MESH SIZE FOR VALUES OF THETA C ALONG ANY OF THE SIDES OF THE PLOT/ C C INC DETERMINES WHETHER THE CIRCULAR LEVEL SETS WILL C BE PLOTTED IN ADDITION TO THE BOUNDARY CURVE. C C INR DETERMINES WHETHER THE RADIAL LEVEL SETS WILL C BE PLOTTED IN ADDITION TO THE BOUNDARY CURVE. C C TITLE CHARACTER VARIABLE HOLDING TITLE FOR LABELING C ON PLOT. C C PLTCLR PEN COLOR FOR PLOT C C CIRCLR PEN COLOR FOR LEVEL SETS C C RADCLR PEN COLOR FOR ORTHOGONAL RADIALS C C ALL OTHER PARAMETERS AS IN GLSOLV / SCSOLV C IMPLICIT REAL*8 (A,B,D-H,O-V,X,Y), COMPLEX*16 (C,W,Z) DIMENSION Z(0:N),W(0:N),BETA(0:N),QW(1),TH(0:20) DATA D0,DH,D1,D2,D4 /0.D0,0.5D0,1.D0,2.D0,4.D0/ DATA C0,C1,CI /(0.D0,0.D0),(1.D0,0.D0),(0.D0,1.D0)/ CHARACTER*40 FN,FNPS,TITLE CHARACTER*8 PLTCLR,CIRCLR,RADCLR REAL*4 SPAPER,SSCAL,SMAX,XP,YP,XOFF,HT PI = D4*DATAN(D1) C FNPS = FN//'_FOR.PS' 50 WRITE (6,30) FNPS READ (5,10) IP C IF (IP.EQ.1) THEN CALL REGIS (2,1) ELSEIF (IP.EQ.2) THEN CALL POSTS (8.5,11,0.005,%ref(FNPS)) ELSEIF (IP.EQ.3) THEN CALL CALCMP (8,6,111) ELSEIF (IP.EQ.4) THEN CALL TEKALL (4010,120,0,1,0) ELSEIF (IP.EQ.9) THEN RETURN ELSE GOTO 50 ENDIF C IPOLE = 0 DO 100 I = 1,N IF (BETA(I).LE.-D1) IPOLE = 1 100 CONTINUE C IF (IPOLE.EQ.0) THEN TMAX = D0 DO 200 I = 1,N ABSWI = BOXNRM(W(I)) IF (ABSWI.GT.TMAX) TMAX = ABSWI 200 CONTINUE ENDIF C IF (PAPER.LT.D1) PAPER = D1 IF (PAPER.GT.D4) PAPER = D4 C IF (SCAL.LT.D0) THEN SCAL = DABS(SCAL) IF (IPOLE.EQ.0) SCAL = PAPER/TMAX ENDIF C TMAXH = PAPER/SCAL + DH C SPAPER = PAPER SSCAL = SCAL SMAX = SPAPER/SSCAL C CALL PAGE (10,10) CALL SETDEV (99,99) CALL NOBRDR CALL SIMPLX CALL AREA2D (SPAPER*2.0,SPAPER*2.0) CALL XNAME (' $',100) CALL YNAME (' $',100) CALL XTICKS (2) CALL YTICKS (2) CALL XREVTK CALL YREVTK CALL GRAF (-SMAX,1./SSCAL,SMAX,-SMAX,1./SSCAL,SMAX) CALL XNONUM CALL YNONUM CALL XGRAXS (-SMAX,1./SSCAL,SMAX,SPAPER*2.0, & ' ',-1,0.0,SPAPER*2.0) CALL YGRAXS (-SMAX,1./SSCAL,SMAX,SPAPER*2.0, & ' ',-1,SPAPER*2.0,0.0) IF (ITITLE.EQ.1) THEN CALL HEADIN (%ref(TITLE//' FORWARD MAP$'),100,1.,1) ENDIF IF (IFOOT.EQ.1) THEN CALL HEIGHT (0.10) XOFF = (2.0*PAPER - 2.5*(0.10/0.14) - 0.5)/2.0 CALL KBMAP ('!',92) CALL MESSAG ('!Z! = 0.30, 0.45, 0.60, 0.75, 0.90$', & 100,XOFF,-0.6) ENDIF C CALL THETA (N,Z,TH) C CALL SETCLR (%ref(PLTCLR)) C XP = DREAL(WC)*SCAL + PAPER YP = DIMAG(WC)*SCAL + PAPER CALL STRTPT (XP,YP) CALL CONNPT (XP,YP) C I = N WI = WMAP (Z(N),N,C0,WC,0,N,C,Z,BETA,NPTSQ,QW) ABSWI = BOXNRM(WI) IF (ABSWI.LE.TMAXH) THEN XP = DREAL(WI)*SCAL + PAPER YP = DIMAG(WI)*SCAL + PAPER CALL STRTPT (XP,YP) IPEN = 2 ELSE IPEN = 3 ENDIF C NEPTS = 5 DO 400 I = 1,N NPTS = 25 TMESH = (TH(I)-TH(I-1))/DFLOAT(NPTS) IF (TMESH.GT.DMESH) THEN NPTS = IDINT((TH(I)-TH(I-1))/DMESH) + 3 TMESH = (TH(I)-TH(I-1))/DFLOAT(NPTS) ENDIF C DO 450 J = 0,NEPTS-1 TT = TH(I-1) + TMESH/DFLOAT(2**(NEPTS-J)) ZZ = CDEXP(CI*TT) WZ = WMAP (ZZ,0,C0,WC,0,N,C,Z,BETA,NPTSQ,QW) ABSWZ = BOXNRM(WZ) IF (ABSWZ.LE.TMAXH) THEN XP = DREAL(WZ)*SCAL + PAPER YP = DIMAG(WZ)*SCAL + PAPER IF (IPEN.EQ.2) THEN CALL CONNPT (XP,YP) ELSE CALL STRTPT (XP,YP) IPEN = 2 ENDIF ELSE IPEN = 3 ENDIF 450 CONTINUE C DO 500 J = 1,NPTS-1 TT = TH(I-1) + DFLOAT(J)*TMESH ZZ = CDEXP(CI*TT) WZ = WMAP (ZZ,0,C0,WC,0,N,C,Z,BETA,NPTSQ,QW) ABSWZ = BOXNRM(WZ) IF (ABSWZ.LE.TMAXH) THEN XP = DREAL(WZ)*SCAL + PAPER YP = DIMAG(WZ)*SCAL + PAPER IF (IPEN.EQ.2) THEN CALL CONNPT (XP,YP) ELSE CALL STRTPT (XP,YP) IPEN = 2 ENDIF ELSE IPEN = 3 ENDIF 500 CONTINUE C DO 550 J = 1,NEPTS TT = TH(I) - TMESH/DFLOAT((2**J)) ZZ = CDEXP(CI*TT) WZ = WMAP (ZZ,0,C0,WC,0,N,C,Z,BETA,NPTSQ,QW) ABSWZ = BOXNRM(WZ) IF (ABSWZ.LE.TMAXH) THEN XP = DREAL(WZ)*SCAL + PAPER YP = DIMAG(WZ)*SCAL + PAPER IF (IPEN.EQ.2) THEN CALL CONNPT (XP,YP) ELSE CALL STRTPT (XP,YP) IPEN = 2 ENDIF ELSE IPEN = 3 ENDIF 550 CONTINUE C IF (BETA(I).GT.-D1) THEN WI = WMAP (Z(I),I,C0,WC,0,N,C,Z,BETA,NPTSQ,QW) ABSWI = BOXNRM(WI) IF (ABSWI.LE.TMAXH) THEN XP = DREAL(WI)*SCAL + PAPER YP = DIMAG(WI)*SCAL + PAPER IF (IPEN.EQ.2) THEN CALL CONNPT (XP,YP) ELSE CALL STRTPT (XP,YP) IPEN = 2 ENDIF ELSE IPEN = 3 ENDIF ELSE IPEN = 3 ENDIF 400 CONTINUE C TWN = DIMAG(CDLOG(W(N))) SWN = CDABS(W(N)) C HT = 0.10 CALL HEIGHT (HT) XP = 1.1*SWN*DCOS(TWN)*SCAL + PAPER - HT/2.0 YP = 1.1*SWN*DSIN(TWN)*SCAL + PAPER - HT/2.0 CALL MESSAG ('W',1,XP,YP) CALL HEIGHT (0.07) YP = YP - HT/2.0 CALL INTNO (N,'ABUT',YP) C IF (INC.EQ.1) THEN C CALL SETCLR (%ref(CIRCLR)) C DO 600 I = 1,5 RAD = 0.15D0*DFLOAT(I+1) ZZ = DCMPLX(RAD,D0) WZ = WMAP (ZZ,0,C0,WC,0,N,C,Z,BETA,NPTSQ,QW) ZD = ZZ WD = WZ ABSWZ = BOXNRM(WZ) IF (ABSWZ.LE.TMAXH) THEN XP = DREAL(WZ)*SCAL + PAPER YP = DIMAG(WZ)*SCAL + PAPER CALL STRTPT (XP,YP) IPEN = 2 ELSE IPEN = 3 ENDIF C DENOM = DFLOAT(I*60) DO 700 J = 1,I*60 ARG = DFLOAT(J)*D2*PI/DENOM ZZ = RAD*CDEXP(CI*ARG) WZ = WMAP (ZZ,0,ZD,WD,0,N,C,Z,BETA,NPTSQ,QW) ZD = ZZ WD = WZ ABSWZ = BOXNRM(WZ) IF (ABSWZ.LE.TMAXH) THEN XP = DREAL(WZ)*SCAL + PAPER YP = DIMAG(WZ)*SCAL + PAPER IF (IPEN.EQ.2) THEN CALL CONNPT (XP,YP) ELSE CALL STRTPT (XP,YP) IPEN = 2 ENDIF ELSE IPEN = 3 ENDIF 700 CONTINUE C 600 CONTINUE C ENDIF C IF (INR.EQ.1) THEN C CALL SETCLR (%ref(RADCLR)) C DO 800 I = 1,N C XP = DREAL(WC)*SCAL + PAPER YP = DIMAG(WC)*SCAL + PAPER CALL STRTPT (XP,YP) IPEN = 2 C ARG = TH(I) ZD = C0 WD = WC C DENOM = DFLOAT(60) DO 900 J = 1,59 RAD = DFLOAT(J)/DENOM ZZ = RAD*CDEXP(CI*ARG) WZ = WMAP (ZZ,0,ZD,WD,0,N,C,Z,BETA,NPTSQ,QW) ZD = ZZ WD = WZ ABSWZ = BOXNRM(WZ) IF (ABSWZ.LE.TMAXH) THEN XP = DREAL(WZ)*SCAL + PAPER YP = DIMAG(WZ)*SCAL + PAPER IF (IPEN.EQ.2) THEN CALL CONNPT (XP,YP) ELSE CALL STRTPT (XP,YP) IPEN = 2 ENDIF ELSE IPEN = 3 ENDIF 900 CONTINUE C IF (BETA(I).GT.-D1) THEN WI = WMAP (Z(I),I,C0,WC,0,N,C,Z,BETA,NPTSQ,QW) ABSWI = BOXNRM(WI) IF (ABSWI.LE.TMAXH) THEN XP = DREAL(WI)*SCAL + PAPER YP = DIMAG(WI)*SCAL + PAPER IF (IPEN.EQ.2) THEN CALL CONNPT (XP,YP) ENDIF ENDIF ENDIF C 800 CONTINUE C ENDIF C CALL DONEPL C C THE FOLLOWING LINE IS INSTALLED BECAUSE DISSPLA (POSTS,TEKALL) C DOES NOT CLOSE THE OUTPUT FILE FOLLOWING CALLS C CALL IOMGR (0,-102) C GOTO 50 C 30 FORMAT (//5x,' Forward Map Menu ' & //5X,'1) Regis plot ' & //5x,'2) Laser plot -----------> ',A40, & //5x,'3) Calcamp plot -----------> FOR111.DAT' & //5x,'4) Tektronics plot ' & //5x,'9) Quit ' & //5x,' Option: ') 10 FORMAT (I1) C END C********************************************************** C* PLTTR2 GEAR-LIKE / SCHWARZ CHRISTOFFEL PLTTR2 *** C********************************************************** SUBROUTINE PLTTR2 (PAPER,DMESH,INC, & FN,TITLE,ITITLE,IFOOT, & PLTCLR,CIRCLR,EPS, & N,C,Z,WC,W,BETA,NPTSQ,QW) C C GENERATES A SEQUENCE OF DISSPLA PLOT COMMANDS C C CALLING SEQUENCE: C C PAPER PHYSICAL SIZE (RADIUS) OF PAGE FOR THE PLOT C C SCAL SCALE FACTOR FOR CONSTRUCTING PLOT. ANY POINTS C FOR WHICH THE MODULUS IS GREATER THAN C PAPER/|SCAL| WILL BE TRUNCATED. C C IF SCAL IS GREATER THAN 0, THEN THE SCAL C WILL BE TREATED AS ABSOLUTE. C IF SCAL IS LESS THAN 0, THEN C 1) IF THE PLOT IS UNBOUNDED THEN, C SCAL WILL BE TREATED AS C ABSOLUTE C 2) IF THE PLOT IS BOUNDED THEN, C SCAL WILL BE RECALCULATED SO C THAT THE ENTIRE PLOT WILL BE C DISPLAYED. C C DMESH MAXIMUM MESH SIZE FOR VALUES OF THETA C ALONG ANY OF THE SIDES OF THE PLOT/ C C INC DETERMINES WHETHER THE CIRCULAR LEVEL SETS WILL C BE PLOTTED IN ADDITION TO THE BOUNDARY CURVE. C C TITLE CHARACTER VARIABLE HOLDING TITLE FOR LABELING C ON PLOT. C C PLTCLR PEN COLOR FOR PLOT C C CIRCLR PEN COLOR FOR LEVEL SETS C C EPS ERROR TOLERANCE FOR CALL TO ZMAP C C ALL OTHER PARAMETERS AS IN GLSOLV / SCSOLV C IMPLICIT REAL*8 (A,B,D-H,O-V,X,Y), COMPLEX*16 (C,W,Z) DIMENSION Z(0:N),W(0:N),BETA(0:N),QW(1),TH(0:20) DIMENSION RAD(4),RADW(0:20),ARGW(0:20) DATA D0,DH,D1,D2,D4 /0.D0,0.5D0,1.D0,2.D0,4.D0/ DATA C0,C1,CI /(0.D0,0.D0),(1.D0,0.D0),(0.D0,1.D0)/ CHARACTER*40 FN,FNPS,TITLE CHARACTER*8 PLTCLR,CIRCLR,RADCLR REAL*4 SPAPER,SSCAL,SMAX,XP,YP,XOFF,POFF,HT PI = D4*DATAN(D1) C FNPS = FN//'_INV.PS' 50 WRITE (6,30) FNPS READ (5,10) IP C IF (IP.EQ.1) THEN CALL REGIS (2,1) ELSEIF (IP.EQ.2) THEN CALL POSTS (8.5,11,0.005,%ref(FNPS)) ELSEIF (IP.EQ.3) THEN CALL CALCMP (8,6,112) ELSEIF (IP.EQ.4) THEN CALL TEKALL (4010,120,0,1,0) ELSEIF (IP.EQ.9) THEN RETURN ELSE GOTO 50 ENDIF C CALL THETA (N,Z,TH) C RADW(0) = CDABS(W(0)) ARGW(0) = DIMAG(CDLOG(W(0))) IF (ARGW(0).LT.D0) ARGW(0) = ARGW(0) + D2*PI C IPOLE = 0 RADMAX = 0.0D0 RADMIN = 1.0D9 DO 100 I = 1,N IF (BETA(I).LE.-D1) THEN IPOLE = 1 RADW(I) = 1.0D9 ARGW(I) = ARGW(I-1) ELSE RADW(I) = CDABS(W(I)) IF (BETA(I-1).LE.-D1) THEN ARGW(I) = DIMAG(CDLOG(W(I))) DO WHILE (ARGW(I).LT.(ARGW(I-1)+0.00001D0)) ARGW(I) = ARGW(I) + D2*PI ENDDO ELSE IF (DABS(RADW(I)-RADW(I-1)).GT.0.00001D0) THEN ARGW(I) = ARGW(I-1) ELSE CALL RELARG (I,AF,AW,N,TH,Z,W,BETA,NPTSQ,QW) ARGW(I) = ARGW(I-1) + AW ENDIF IF (RADW(I).GT.RADMAX) RADMAX = RADW(I) IF (RADW(I).LT.RADMIN) RADMIN = RADW(I) ENDIF 100 CONTINUE C RAD(1) = 0.25D0*RADMIN RAD(2) = 0.75D0*RADMIN IF (IPOLE.EQ.0) THEN RAD(3) = RADMIN + 0.25D0*(RADMAX-RADMIN) RAD(4) = RADMIN + 0.75D0*(RADMAX-RADMIN) ELSE IF (RADMAX.GT.(RADMIN+0.2)) THEN RAD(3) = (RADMIN + RADMAX)/2.0D0 RAD(4) = RADMAX + 5.0D0 ELSE RAD(3) = RADMAX + 1.0D0 RAD(4) = RADMAX + 6.0D0 ENDIF ENDIF C WRITE (20,20) RADMIN,RADMAX WRITE (20,21) 1,RAD(1),2,RAD(2) WRITE (20,21) 3,RAD(3),4,RAD(4) C 20 FORMAT (/4X,'RadMin = ',F14.8,4X,'Radmax =',F14.8) 21 FORMAT (/4x,I2,4X,F14.8,10X,I2,4X,F14.8) C DO 300 I = 0,N IF (BETA(I).GT.-D1) THEN WRITE (20,22) I,RADW(I),ARGW(I)/PI ELSE WRITE (20,23) I,ARGW(I)/PI ENDIF 300 CONTINUE C 22 FORMAT (/4X,'I = ',I2, & 4X,'Rad(I) = ',F16.10, & 4X,'Arg(I)/PI = ',F16.10) 23 FORMAT (/4X,'I = ',I2, & 4X,'Rad(I) = ',' INFINITY ', & 4X,'Arg(I)/PI = ',F16.10) C IF (IPOLE.EQ.0) THEN TMAX = D0 DO 200 I = 1,N ABSWI = BOXNRM(W(I)) IF (ABSWI.GT.TMAX) TMAX = ABSWI 200 CONTINUE ENDIF C IF (PAPER.LT.1.5D0) PAPER = 1.5D0 IF (PAPER.GT.4.5D0) PAPER = 4.5D0 SCAL = PAPER*2.0D0/3.0D0 C TMAXH = 2.0D0 C SPAPER = PAPER SSCAL = SCAL SMAX = SPAPER/SSCAL C IF (PAPER.EQ.1.5D0) THEN POFF = 0.5 ELSE POFF = 0.0 ENDIF C CALL PAGE (10,10) CALL SETDEV (99,99) CALL NOBRDR CALL SIMPLX CALL AREA2D (SPAPER*2.0,SPAPER*2.0) CALL XNAME (' $',100) CALL YNAME (' $',100) CALL XTICKS (2) CALL YTICKS (2) CALL XREVTK CALL YREVTK IF (PAPER.EQ.1.5D0) THEN CALL XAXCTR CALL YAXCTR ENDIF CALL GRAF (-SMAX+POFF,1./SSCAL,SMAX+POFF, & -SMAX+POFF,1./SSCAL,SMAX+POFF) CALL XNONUM CALL YNONUM CALL XGRAXS (-SMAX,1./SSCAL,SMAX,SPAPER*2.0, & ' ',-1,0.0,SPAPER*2.0) CALL YGRAXS (-SMAX,1./SSCAL,SMAX,SPAPER*2.0, & ' ',-1,SPAPER*2.0,0.0) IF (ITITLE.EQ.1) THEN CALL HEADIN (%ref(TITLE//' INVERSE MAP$'),100,1.,1) ENDIF IF (IFOOT.EQ.1) THEN CALL HEIGHT (0.10) XOFF = (2.0*PAPER - 2.2*(0.10/0.14) - 0.5)/2.0 CALL KBMAP ('!',92) CALL MESSAG ('!W! = $',100,XOFF,-0.6) DO 80 I = 1,3 CALL REALNO (RAD(I),2,'ABUT','ABUT') CALL MESSAG (',',1,'ABUT','ABUT') 80 CONTINUE CALL REALNO (RAD(4),2,'ABUT','ABUT') ENDIF C CALL THETA (N,Z,TH) C CALL SETCLR (%ref(PLTCLR)) C XP = PAPER YP = PAPER CALL STRTPT (XP,YP) CALL CONNPT (XP,YP) ZI = C1 ABSZI = BOXNRM(ZI) IF (ABSZI.LE.TMAXH) THEN XP = DREAL(ZI)*SCAL + PAPER YP = DIMAG(ZI)*SCAL + PAPER CALL STRTPT (XP,YP) IPEN = 2 ELSE IPEN = 3 ENDIF C DO 500 J = 1,180 TJ = D2*PI*DFLOAT(J)/DFLOAT(180) ZW = CDEXP(CI*TJ) ABSZW = BOXNRM(ZW) IF (ABSZW.LE.TMAXH) THEN XP = DREAL(ZW)*SCAL + PAPER YP = DIMAG(ZW)*SCAL + PAPER IF (IPEN.EQ.2) THEN CALL CONNPT (XP,YP) ELSE CALL STRTPT (XP,YP) IPEN = 2 ENDIF ELSE IPEN = 3 ENDIF 500 CONTINUE C DO 550 I = 1,N XPP = DCOS(TH(I)) YPP = DSIN(TH(I)) XP = XPP*SCAL + PAPER YP = YPP*SCAL + PAPER CALL STRTPT (XP,YP) C XPP = 1.05*XPP YPP = 1.05*YPP XP = XPP*SCAL + PAPER YP = YPP*SCAL + PAPER CALL CONNPT (XP,YP) 550 CONTINUE C HT = 0.10 CALL HEIGHT (HT) XP = 1.1*DCOS(TH(N))*SCAL + PAPER YP = 1.1*DSIN(TH(N))*SCAL + PAPER - HT/2.0 CALL MESSAG ('Z',1,XP,YP) CALL HEIGHT (0.07) YP = YP - HT/2.0 CALL INTNO (N,'ABUT',YP) C IF (INC.EQ.1) THEN C CALL SETCLR (%ref(CIRCLR)) C DO 600 IR = 1,4 C IPP = 0 ISTEPS = IDINT(360*RAD(IR)) + 1 C I = 0 IF (RADW(I).GT.RAD(IR)) THEN ITAKE = 1 IST = I ELSE ITAKE = 0 ENDIF C DO WHILE ((ITAKE.EQ.1).AND. & (ARGW(I+1).EQ.ARGW(I)).AND.(I.LT.N)) I = I+1 IF (RADW(I).GT.RAD(IR)) THEN IST = I ELSE ITAKE = 0 ENDIF ENDDO C DO WHILE (I.LT.N) C DO WHILE ((ITAKE.EQ.0).AND.(I.LT.N)) I = I+1 IF (RADW(I).GT.RAD(IR)) THEN ITAKE = 1 IST = I ENDIF ENDDO C DO WHILE ((ITAKE.EQ.1).AND.(I.LT.N)) I = I+1 IF (RADW(I).LT.RAD(IR)) THEN ITAKE = 0 IEND = I IPP = 1 ENDIF ENDDO C IF ((ITAKE.EQ.1).AND.(I.EQ.N)) THEN IEND = I IF (ARGW(IEND).EQ.ARGW(IST)) THEN IPP = 0 ELSE IPP = 1 ENDIF ENDIF C IF (IPP.EQ.1) THEN C WRITE (20,25) IR,IST,IEND 25 FORMAT (/4X,'Radius level = ',I2, & ' IST = ',I2,' IEND = ',I2) C ARGC = (ARGW(IST) + ARGW(IEND))/D2 ARGD = ARGW(IEND)-ARGW(IST) ISTHLF = IDINT(ARGD*ISTEPS/(D4*PI)) + 1 DENOM = DFLOAT(2*ISTHLF) C WW = RAD(IR)*CDEXP(CI*ARGC) IF (IR.LE.2) THEN IERR = 0 ZW = ZMAP (WW,0,C0,C0,WC,0,EPS,IERR, & N,C,Z,BETA,NPTSQ,QW) ELSE ARGZC = (TH(IST) + TH(IEND))/D2 DO 900 MD = 1,9 R = DFLOAT(MD)/10.0D0 ZC = R*CDEXP(CI*ARGZC) WC = WMAP (ZC,0,C0,WC,0, & N,C,Z,BETA,NPTSQ,QW) IF (CDABS(WC).GE.RAD(IR)) GOTO 950 900 CONTINUE 950 IERR = 0 ZW = ZMAP (WW,1,ZC,ZC,WC,0,EPS,IERR, & N,C,Z,BETA,NPTSQ,QW) ENDIF C WD = WW ZD = ZW WCC = WW ZCC = ZW C ABSZW = BOXNRM(ZW) IF (ABSZW.LE.TMAXH) THEN XP = DREAL(ZW)*SCAL + PAPER YP = DIMAG(ZW)*SCAL + PAPER CALL STRTPT (XP,YP) IPEN = 2 ELSE IPEN = 3 ENDIF C DO 700 J = 1,ISTHLF ARG = ARGC - ARGD*DFLOAT(J)/DENOM WW = RAD(IR)*CDEXP(CI*ARG) IERR = 0 ZW = ZMAP (WW,1,ZD,ZD,WD,0,EPS,IERR, & N,C,Z,BETA,NPTSQ,QW) WD = WW ZD = ZW ABSZW = BOXNRM(ZW) IF (ABSZW.LE.TMAXH) THEN XP = DREAL(ZW)*SCAL + PAPER YP = DIMAG(ZW)*SCAL + PAPER IF (IPEN.EQ.2) THEN CALL CONNPT (XP,YP) ELSE CALL STRTPT (XP,YP) IPEN = 2 ENDIF ELSE IPEN = 3 ENDIF 700 CONTINUE C WW = WCC ZW = ZCC ABSZW = BOXNRM(ZW) IF (ABSZW.LE.TMAXH) THEN XP = DREAL(ZW)*SCAL + PAPER YP = DIMAG(ZW)*SCAL + PAPER CALL STRTPT (XP,YP) IPEN = 2 ELSE IPEN = 3 ENDIF C DO 750 J = 1,ISTHLF ARG = ARGC + ARGD*DFLOAT(J)/DENOM WW = RAD(IR)*CDEXP(CI*ARG) IERR = 0 ZW = ZMAP (WW,1,ZD,ZD,WD,0,EPS,IERR, & N,C,Z,BETA,NPTSQ,QW) WD = WW ZD = ZW ABSZW = BOXNRM(ZW) IF (ABSZW.LE.TMAXH) THEN XP = DREAL(ZW)*SCAL + PAPER YP = DIMAG(ZW)*SCAL + PAPER IF (IPEN.EQ.2) THEN CALL CONNPT (XP,YP) ELSE CALL STRTPT (XP,YP) IPEN = 2 ENDIF ELSE IPEN = 3 ENDIF 750 CONTINUE C IPP = 0 C ENDIF C ENDDO C 600 CONTINUE C ENDIF C CALL DONEPL C C THE FOLLOWING LINE IS INSTALLED BECAUSE DISSPLA (POSTS,TEKALL) C DOES NOT CLOSE THE OUTPUT FILE FOLLOWING CALLS C CALL IOMGR (0,-102) C GOTO 50 C 30 FORMAT (//5x,' Reverse Map Menu ' & //5x,'1) Regis plot ' & //5x,'2) Laser plot -----------> ',A40, & //5x,'3) Calcamp plot -----------> FOR112.DAT' & //5x,'4) Tektronics plot ' & //5x,'9) Quit ' & //5x,' Option: ') 10 FORMAT (I1) C END C********************************************************** C* BOXNORM GEAR-LIKE / SCHWARZ CHRISTOFFEL BOXNORM *** C********************************************************** FUNCTION BOXNRM (W) C IMPLICIT REAL*8 (A,B,D-H,O-V,X,Y), COMPLEX*16 (C,W,Z) C BOXNRM = DMAX1(DABS(DREAL(W)),DABS(DIMAG(W))) C RETURN END