$JOB SIX-COIL PROBLEM $EXECUTE IBJOB $IBJOB GO,FIOCS $IBFTC COIL6 LIST,REF DIMENSION XA(2000),XB(2000),XC(2000),GA(2000),GB(2000),XDUM(4), 1F3(4),F5(4),F7(4),F9(4),F11(4),S(7),LT(2000),A1(7),A2(7),B1(7), 2B2(7),T(7),Y0Z(7),Z(7),Y(7),LTA(2000),R2(7),R3(7),J2(7),J3(7), 3LTB(2000),CHECK(7,6) WRITE (6,10) 10 FORMAT(1H1///////////////////////////1H ,40X,16HSIX-COIL PROBLEM/1 1H1) IRUN=1 LMTA=1 LMTB=1 ISL1=0 ISL2=0 ISL3=0 ISL4=0 ISL5=0 READ (5,20) X2,X3,MAXRUN 20 FORMAT(2(F14.7,6X),I2) C C FIND ACCEPTABLE X11 AND X12 C 30 READ (5,40) X1,XMAX,DELTAX 40 FORMAT(2(F14.7,6X),F5.3) XB(1)=X1 WRITE(6,110)X2,X3 110 FORMAT(1H1////////////////1H0,30X,61HCOMPUTATION OF SIX-COIL PROBL 1EM WITH THE FOLLOWING INPUT DATA///1H ,40X,5HX2 = ,F14.7//1H ,40X, 25HX3 = ,F14.7) IPAGE=0 120 ICNTA=0 ICNTB=0 NA=1 NB=1 NC=1 130 IPAGE=IPAGE+1 WRITE (6,140) IPAGE 140 FORMAT(1H1,110X,5HPAGE ,I4) XINT=XB(NB) IF(ISL2-1)147,147,143 143 WRITE (6,145) XINT 145 FORMAT(1H0,43X,26HFINAL COMPUTATION FOR X1= ,F14.7///) GO TO 155 147 WRITE (6,150) XINT 150 FORMAT(1H0,40X,33HINTERMEDIATE COMPUTATION FOR X1= ,F14.7///) C C LEGENDRE POLYNOMIALS C 155 WRITE (6,160) 160 FORMAT(1H ,20HLEGENDRE POLYNOMIALS) WRITE (6,170) 170 FORMAT(1H0,1HI,14X,5HF3(I),20X,5HF5(I),20X,5HF7(I),20X,5HF9(I),20X 1,6HF11(I)) XDUM(1)=XINT**2 XDUM(2)=X2**2 XDUM(3)=X3**2 DO 180 I=1,3 F3(I)=5.*XDUM(I)-1. F5(I)=(21.*XDUM(I)-14.)*XDUM(I)+1. F7(I)=((429.*XDUM(I)-495.)*XDUM(I)+135.)*XDUM(I)-5. F9(I)=(((2431.*XDUM(I)-4004.)*XDUM(I)+2002.)*XDUM(I)-308.)*XDUM(I) 1+7. F11(I)=((((29393.*XDUM(I)-62985.)*XDUM(I)+46410.)*XDUM(I)-13650.) 1*XDUM(I)+1365.)*XDUM(I)-21. 180 WRITE(6,190) I,F3(I),F5(I),F7(I),F9(I),F11(I) 190 FORMAT(1H ,I1,9X,4(E15.8,10X),E15.8) C C FIND C,D,E AND A FOR F(S) EQUATION C C2=F3(1)*F5(2)*F5(3)*F7(1)*F7(3)*F9(2)-F3(3)*F5(1)**2*F7(2)**2 1*F9(3) C1=2.*F3(3)*F5(1)*F5(2)*F7(1)*F7(2)*F9(3)-F5(3)*F7(3)*(F3(1)*F5(2) 1*F7(2)*F9(1)+F3(2)*F5(1)*F7(1)*F9(2)) C0=F3(2)*F5(1)*F5(3)*F7(2)*F7(3)*F9(1)-F3(3)*F5(2)**2*F7(1)**2 1*F9(3) D3=F7(2)*F9(2)*(F3(1)*F5(3)**2*F7(1)-F3(3)*F5(1)**2*F7(3)) D2=F3(3)*F5(1)*F5(2)*F7(1)*F7(3)*F9(2)-F3(1)*F5(3)**2*F7(2)**2 1*F9(1) D1=F3(3)*F5(1)*F5(2)*F7(2)*F7(3)*F9(1)-F3(2)*F5(3)**2*F7(1)**2 1*F9(2) D0=F7(1)*F9(1)*(F3(2)*F5(3)**2*F7(2)-F3(3)*F5(2)**2*F7(3)) E3=F3(1)*F5(1)*(F5(2)*F7(3)**2*F9(2)-F5(3)*F7(2)**2*F9(3)) E2=F3(1)*F5(2)*F5(3)*F7(1)*F7(2)*F9(3)-F3(2)*F5(1)**2*F7(3)**2 1*F9(2) E1=F3(2)*F5(1)*F5(3)*F7(1)*F7(2)*F9(3)-F3(1)*F5(2)**2*F7(3)**2 1*F9(1) E0=F3(2)*F5(2)*(F5(1)*F7(3)**2*F9(1)-F5(3)*F7(1)**2*F9(3)) WRITE (6,200) D3,E3 200 FORMAT(1H0,40X,5HD3 = ,E15.8,20X,5HE3 = ,E15.8) WRITE (6,210) C2,D2,E2 210 FORMAT(1H ,5HC2 = ,E15.8,20X,5HD2 = ,E15.8,20X,5HE2 = ,E15.8) WRITE (6,220) C1,D1,E1 220 FORMAT(1H ,5HC1 = ,E15.8,20X,5HD1 = ,E15.8,20X,5HE1 = ,E15.8) WRITE (6,230) C0,D0,E0 230 FORMAT(1H ,5HC0 = ,E15.8,20X,5HD0 = ,E15.8,20X,5HE0 = ,E15.8) A66=-D3*E3 A65=C2**2-(D2*E3+D3*E2) A64=2.*C1*C2-(D1*E3+D2*E2+D3*E1) A63=C1**2+2.*C0*C2-(D0*E3+D1*E2+D2*E1+D3*E0) A62=2.*C0*C1-(D0*E2+D1*E1+D2*E0) A61=C0**2-(D0*E1+D1*E0) A60=-D0*E0 WRITE (6,240) A66,A65,A64,A63,A62,A61,A60 240 FORMAT(1H0,6X,3HA66,16X,3HA65,16X,3HA64,16X,3HA63,16X,3HA62,16X, 13HA61,16X,3HA60/1H ,6(E15.8,4X),E15.8) C C SOLUTIONS OF F ( S ) C A=0 I=1 FA=A60 IF(FA) 270,260,270 260 S(I)=FA GO TO 440 270 FD=FA AD=A A=A+.01 280 FA=(((((A66*A+A65)*A+A64)*A+A63)*A+A62)*A+A61)*A+A60 IF(FA)300,260,290 290 IF(FD)380,310,310 300 IF(FD)310,310,380 310 IF(A-5.)270,320,320 320 IF(A-10.)330,340,340 330 FD=FA AD=A A=A+.1 GO TO 280 340 IF(I-1)350,350,370 350 IF(X1-XMAX)360,353,353 353 WRITE (6,355) 355 FORMAT(1H0,52HTHIS PROBLEM CAN NOT BE SOLVED WITH THE GIVEN VALUES 1///) GO TO 1220 360 WRITE (6,365) X1 365 FORMAT(1H0,4HX1= ,F14.7,28H IS NOT A SATISFACTORY VALUE///) X1=X1+DELTAX XB(1)=X1 GO TO 130 370 LT(NB)=I-1 GO TO 450 380 S(I)=-FD*(A-AD)/(FA-FD)+AD IC=1 390 H=((((((A66*S(I)+A65)*S(I)+A64)*S(I)+A63)*S(I)+A62)*S(I)+A61)*S(I) 1+A60)/(((((6.*A66*S(I)+5.*A65)*S(I)+4.*A64)*S(I)+3.*A63)*S(I)+2. 2*A62)*S(I)+A61) S(I)=S(I)-H IF(ABS(H)-.00000001)440,440,400 400 IF(IC-10)410,420,420 410 IC=IC+1 GO TO 390 420 WRITE (6,430) S(I),XA(NA),XB(NB) 430 FORMAT(1H0,3HS= ,F14.7,32H CONVERGES TOO SLOWLY WHEN X11= ,F14.7, 110H AND X12= ,F14.7//) GO TO 310 440 I=I+1 GO TO 310 450 WRITE (6,460) 460 FORMAT(1H0,1HI,11X,4HS(I),15X,5HA1(I),17X,5HA2(I),17X,5HB1(I),17X, 15HB2(I),17X,4HT(I)) LTD=LT(NB) DO 470 I=1,LTD A1(I)=S(I)*(F5(2)*F7(1)-S(I)*F5(1)*F7(2))/(F3(2)*F5(1)-S(I)*F3(1) 1*F5(2)) A2(I)=S(I)*(F7(2)*F9(1)-S(I)*F7(1)*F9(2))/(F5(2)*F7(1)-S(I)*F5(1) 1*F7(2)) B1(I)=F5(3)*(A1(I)*F3(1)+F7(1))*A2(I)*F5(3)*F7(1)-F7(3)*(A2(I) 1*F5(1)+F9(1))*A1(I)*F3(3)*F5(1) B2(I)=F5(1)*F7(3)*A2(I)*F5(3)*F7(1)-F7(1)*F9(3)*A1(I)*F3(3)*F5(1) T(I)=B1(I)/B2(I) 470 WRITE (6,480) I,S(I),A1(I),A2(I),B1(I),B2(I),T(I) 480 FORMAT(1H ,I1,7X,F11.7,5(7X,E15.8)) IF(ISL2-1)510,510,490 490 WRITE (6,500) 500 FORMAT(1H0,6X,4HT(J),15X,4HY(J),15X,4HZ(J),14X,5HR2(J),14X,5HR3(J) 1,14X,5HJ2(J),14X,5HJ3(J)) GO TO 530 510 WRITE (6,520) 520 FORMAT(1H0,1HJ,14X,4HT(J),20X,6HY/Z(J),20X,4HZ(J),21X,4HY(Z),21X, 14HG(J)) 530 J=1 I=1 540 IF(T(I))550,550,610 550 IF(I-LTD)560,570,570 560 I=I+1 GO TO 540 570 IF(J-1)590,590,580 580 J=J-1 IF(ISL2-1)650,750,680 590 WRITE (6,600) 600 FORMAT(1H0,23HNO POSITIVE T AVAILABLE) IF(ISL1-1)350,350,603 603 IF(LMTB-1)604,604,605 604 WRITE(6,365) XINT GO TO 713 605 IF(NB-LMTB)608,606,606 606 LMTB=LMTB-1 GO TO 770 608 LMTB=LMTB-1 DO 609 I=NB,LMTB 609 XB(I)=XB(I+1) GO TO 130 610 Y0Z(J)=-(F3(3)*F5(1)-T(I)*F3(1)*F5(3))/(F3(2)*F5(1)-S(I)*F3(1) 1*F5(2)) Z(J)=-F3(1)/(Y0Z(J)*F3(2)+F3(3)) Y(J)=Y0Z(J)*Z(J) IF(ISL2-1)620,720,660 620 GA(J)=F11(1)+Y(J)*S(I)**4*F11(2)+Z(J)*T(I)**4*F11(3) WRITE (6,630) J,T(I),Y0Z(J),Z(J),Y(J),GA(J) 630 FORMAT(1H ,I1,9X,4(E15.8,10X),E15.8) IF(I-LTD)640,650,650 640 J=J+1 I=I+1 GO TO 540 650 LTA(NA)=J ISL2=1 ISL1=1 653 IF(X1-XMAX)655,353,353 655 XA(1)=X1 X1=X1+DELTAX XB(1)=X1 GO TO 130 660 R2(J)=SQRT(S(I)) R3(J)=SQRT(T(I)) J2(J)=Y(J)*(1.-X1**2)/(R2(J)**3*(1.-X2**2)) J3(J)=Z(J)*(1.-X1**2)/(R3(J)**3*(1.-X3**3)) WRITE (6,670) T(I),Y(J),Z(J),R2(J),R3(J),J2(J),J3(J) 670 FORMAT(1H ,6(E15.8,4X),E15.8) CHECK(J,1)=F3(1)+Y(J)*F3(2)+Z(J)*F3(3) SDUM=S(I)*Y(J) TDUM=T(I)*Z(J) CHECK(J,2)=F5(1)+SDUM*F5(2)+TDUM*F5(3) SDUM=SDUM*S(I) TDUM=TDUM*T(I) CHECK(J,3)=F7(1)+SDUM*F7(2)+TDUM*F7(3) SDUM=SDUM*S(I) TDUM=TDUM*T(I) CHECK(J,4)=F9(1)+SDUM*F9(2)+TDUM*F9(3) SDUM=SDUM*S(I) TDUM=TDUM*T(I) CHECK(J,5)=F11(1)+SDUM*F11(2)+TDUM*F11(3) IF(I-LTD)640,680,680 680 IF(NB-LMTB)690,700,700 690 NB=NB+1 GO TO 130 700 WRITE(6,703) (I,I=1,5) 703 FORMAT(1H0,21HVALIDITY OF SOLUTIONS//1H ,1HJ,5(8X,9HEQUATION ,I1, 12X)) DO 705 I=1,J 705 WRITE(6,707) I,(CHECK(I,IT),IT=1,5) 707 FORMAT(1H ,I1,5(5X,E15.8)) WRITE (6,710) XINT,X2,X3 710 FORMAT(1H0,5HX1 = ,F14.7/1H ,5HX2 = ,F14.7/1H ,5HX3 = ,F14.7) 713 IF(X1-XMAX)715,1240,1240 715 IRUN=1 LMTA=1 LMTB=1 ISL1=0 ISL2=0 ISL3=0 ISL4=0 ISL5=0 XB(1)=X1 GO TO 120 720 JB=J+ICNTB GB(JB)=F11(1)+Y(J)*S(I)**4*F11(2)+Z(J)*T(I)**4*F11(3) WRITE (6,630) J,T(I),Y0Z(J),Z(J),Y(J),GB(JB) IF(I-LTD)730,750,750 730 IF(JB-2000)640,740,740 740 WRITE(6,745) 745 FORMAT(1H0,30HHELP - I AM BEING SQUEEZED OUT///) GO TO 1240 750 IF(ISL1-1)753,753,755 753 ISL1=2 XB(1)=X1 755 LTB(NB)=J IF(NB-LMTB)760,770,770 760 NB=NB+1 ICNTB=ICNTB+LTB(NB) GO TO 130 770 IPAGE=IPAGE+1 WRITE (6,140) IPAGE WRITE (6,780) IRUN 780 FORMAT(1H ,43X,32HCOMPUTED VALUES OF X13 FOR PASS ,I2//1H ,5X,3HX1 11,23X,3HX12,23X,6HG(x11),21X,6HG(X12),22X,3HX13) C C FIND X13 C LINE=4 ICNTA=0 ICNTB=0 ICNTC=0 NC=1 790 IA=1 800 IAC=IA+ICNTA IB=1 810 IBC=IB+ICNTB XC(NC)=(XB(NB)*GA(IA)-XA(NA)*GB(IB))/(GA(IA)-GB(IB)) IF(ABS(1.-XB(NB)/XC(NC))-.0000001)840,820,820 820 IF(ISL3)830,830,870 830 NC=NC+1 GO TO 870 840 ISL3=1 IF(ISL4)850,850,860 850 ISL4=1 XC(1)=XC(NC) NC=2 GO TO 870 860 NC=NC+1 870 IF(NC-2000)880,740,740 880 IF(IB-LTB(NB))890,900,900 890 IB=IB+1 GO TO 810 900 IF(IA-LTA(NA))910,920,920 910 IA=IA+1 GO TO 800 920 NC=NC-1 IF(LINE-50)950,930,930 930 IPAGE=IPAGE+1 WRITE (6,140) IPAGE WRITE (6,940) IRUN 940 FORMAT(1H ,37X,32HCOMPUTED VALUES OF,X13 FOR PASS ,I2,12H - CONTIN 1UED//1H ,5X,3HX11,23X,3HX12,23X,6HG(X11),21X,6HG(X12),22X,3HX13) GO TO 960 950 LINE=LINE+2 960 WRITE (6,970) XA(NA),XB(NB),GA(ICNTA+1),GB(ICNTB+1),XC(ICNTC+1) 970 FORMAT(1H0,2(F14.7,12X),2(E15.8,12X),E15.8) IF(LTB(NB)-1)975,975,977 973 ND=2 IA=2 IB=1 GO TO 980 975 IF(LTA(NA)-1)1070,1070,973 977 ND=2 IA=1 IB=2 980 IAC=IA+ICNTA 990 LINE=LINE+1 IBC=IB+ICNTB NDC=ND+ICNTC IF(LINE-56)1010,1010,1000 1000 IPAGE=IPAGE+1 WRITE (6,140) IPAGE WRITE (6,940) IRUN LINE=6 WRITE (6,970) XA(NA),XB(NB),GA(IAC),GB(IBC),XC(NDC) GO TO 1030 1010 WRITE (6,1020) GA(IAC),GB(IBC),XC(NDC) 1020 FORMAT(1H ,52X,2(E15.8,12X),E15.8) 1030 IF(IB-LTB(NB))1040,1050,1050 1040 IB=IB+1 ND=ND+1 GO TO 990 1050 IF(IA-LTA(NA))1060,1070,1070 1060 IA=IA+1 ND=ND+1 GO TO 980 1070 ICNTC=NC 1080 IF(NB-LMTB)1090,1100,1100 1090 ICNTB=ICNTB+LTB(NB) NB=NB+1 GO TO 790 1100 IF(ISL5)1110,1110,1120 1110 ISL5=1 LMTG=ICNTB+LTB(NB) 1120 IF(NA-LMTA)1130,1140,1140 1130 ICNTA=ICNTA+1 NA=NA+1 NB=1 GO TO 790 1140 LMTC=NC IF(IRUN-MAXRUN)1150,1200,1200 1150 IRUN=IRUN+1 C C SHIFT VALUES OVER FOR NEXT PASS C DO 1160 NB=1,LMTB XA(NB)=XB(NB) 1160 LTA(NB)=LTB(NB) DO 1170 IBC=1,LMTG 1170 GA(IBC)=GB(IBC) ISL5=0 DO 1180 NC=1,LMTC 1180 XB(NC)=XC(NC) LMTB=LMTC IF(ISL3)120,120,1190 1190 ISL2=2 GO TO 120 C C ERROR PRINTOUTS AND ENDINGS 13340 C 1200 WRITE (6,1210) MAXRUN 1210 FORMAT(1H0,34HTHIS PROBLEM WILL NOT CONVERGE IN ,I2,11H ITERATIONS 1///) GO TO 713 1220 WRITE (6,1230) 1230 FORMAT(1H0,40HTHIS OCURRED AT THE START OF THE PROGRAM///) 1240 RETURN END ~ $BLOCK BCD,0084 .5917002 .8710000 10 .2000000 .2150000 .001 ~ $IBSYS $PAUSE DONE $STOP