SUBROUTINE POLRT(XCOF,COF,M,ZERO,IER) DIMENSION XCOF(7),COF(7) COMPLEX ZERO(6) DOUBLE PRECISION XO,YO,X,Y,XPR,YPR,UX,UY,V,YT,XT,U,XT2,YT2,SUMSQ, / DX,DY,TEMP,ALPHA,xcof,cof COMMON /AUXI/ IANI(20),INTR,INT1,IOUT,KRE,IREFR,LAY,NDER,IPRINT, 1 MPRINT,NTR,ISQRT,NAUX,ISOUR,MAUX,MREG,MDIM,IPOL,mscon,lout, 2 IAMP,MTRNS,ICOEF,IAD,IRHO,ISHEAR,IAC,IRT,mori C IFIT=0 N=M IER=0 IF(XCOF(N+1)) 10,25,10 10 IF(N) 15,15,32 C 15 IER=1 20 RETURN C 25 IER=4 GO TO 20 C 30 IER=2 GO TO 20 32 IF(N-36) 35,35,30 35 NX=N NXX=N+1 N2=1 KJ1=N+1 DO 40 L=1,KJ1 MT=KJ1-L+1 40 COF(MT)=XCOF(L) C 45 XO=.00500101 YO=0.01000101 C IN=0 50 X=XO C XO=-10.0*YO YO=-10.0*X C X=XO Y=YO IN=IN+1 GO TO 59 55 IFIT=1 XPR=X YPR=Y C 59 ICT=0 60 UX=0.0 UY=0.0 V =0.0 YT=0.0 XT=1.0 U=COF(N+1) IF(U) 65,130,65 65 DO 70 I=1,N L=N-I+1 TEMP=COF(L) XT2=X*XT-Y*YT YT2=X*YT+Y*XT if(dabs(yt2).gt.0..and.dabs(yt2).lt.1.0d-30) 1write(lout,1000)ict,y,yt,yt2 1000 format(i5,3e15.5) if(dabs(yt2).gt.0..and.dabs(yt2).lt.1.0d-30)ict=500 if(dabs(yt2).gt.0..and.dabs(yt2).lt.1.0d-30)go to 80 U=U+TEMP*XT2 V=V+TEMP*YT2 FI=I UX=UX+FI*XT*TEMP UY=UY-FI*YT*TEMP XT=XT2 70 YT=YT2 SUMSQ=UX*UX+UY*UY IF(SUMSQ) 75,110,75 75 DX=(V*UY-U*UX)/SUMSQ X=X+DX DY=-(U*UY+V*UX)/SUMSQ Y=Y+DY 78 IF(DABS(DY)+DABS(DX)-1.0D-05) 100,80,80 C 80 ICT=ICT+1 IF(ICT-500) 60,85,85 85 IF(IFIT) 100,90,100 90 IF(N-5) 50,95,95 C 95 IER=3 GO TO 20 100 DO 105 L=1,NXX MT=KJ1-L+1 TEMP=XCOF(MT) XCOF(MT)=COF(L) 105 COF(L)=TEMP ITEMP=N N=NX NX=ITEMP IF(IFIT) 120,55,120 110 IF(IFIT) 115,50,115 115 X=XPR Y=YPR 120 IFIT=0 if(dabs(x)-1.0D-5)121,121,122 121 x=0. 122 IF(DABS(Y)-1.0D-4*DABS(X))135,125,125 125 ALPHA=X+X SUMSQ=X*X+Y*Y N=N-2 GO TO 140 130 X=0.0 NX=NX-1 NXX=NXX-1 135 Y=0.0 SUMSQ=0.0 ALPHA=X N=N-1 140 COF(2)=COF(2)+ALPHA*COF(1) 145 DO 150 L=2,N 150 COF(L+1)=COF(L+1)+ALPHA*COF(L)-SUMSQ*COF(L-1) 155 ZERO(N2)=CMPLX(X,Y) N2=N2+1 IF(SUMSQ) 160,165,160 160 Y=-Y SUMSQ=0.0 GO TO 155 165 IF(N) 20,20,45 END