Directory of image this file is from
This file as a plain text file

	COMMON/A/ FI(9),PL,Q,TOD,SL,XY(2,9),GAMR(9),DY(9),RSB(3,9)
	2,R(3,9),C(9,9),IGA,WD,TID,P(6,9),RSN(3,9),RBH(3,9),BT,E(3,9)
	COMMON/B/ RE,RI,DI,X(21,4),RL(21),RRR(21),FFI(21)
	DIMENSION KTP(7),PHID(3),XCL(3,12),ANG(3,6),XYZ(3,7,6),
	2FL(3,6),GAM(7),KTR(6),RAD(3,6),DIA(3,6),TH(6),UM(3),UMK(3),
	3EN(3),UA(3),EU(3),EV(3),EW(3),YCL(3),RIS(3,7),EIS(3,7),XIS(3)
C------DATA VALUES ASSIGNMENT
	PI=3.14159
	DTR=PI/180.
	RTD=1./DTR
	TID=.019
	TOD=.030
	AL=3.289
	RE=.5E8
	WD=.014
	TD=.032
	DCL=.0025
	RI=PI*(D**4)/64.
	CD=.00
	FLR=1.625
	Q=0.
	PL=0.0
	SL=0.
	ENN=.125
	EMM=.2005
	AC=.510
	I0=2
	FI0=0.0
	PSI=PI/2.
	TOL=.1E-6
	TH(1)=0.0
	TH(2)=.030
	TH(3)=.030
	TH(4)=.094
	TH(5)=.030
	TH(6)=0.0
	DO 45 I=1,7
45	DY(I)=.045-(I-1)*.015
	GAM(1)=31.5781
	GAM(2)=330.9301
	GAM(3)=63.4400
	GAM(4)=0.0
	GAM(5)=299.1013
	GAM(6)=91.0496
	GAM(7)=270.
	DO 46 I=1,7
46	GAMR(I)=GAM(I)*DTR
	KTP(1)=1
	KTP(2)=2
	KTP(3)=6
	KTP(4)=7
	KTP(5)=3
	KTP(6)=5
	KTP(7)=4
	KTR(1)=7
	KTR(2)=5
	KTR(3)=2
	KTR(4)=1
	KTR(5)=3
	KTR(6)=6
	PHID(1)=14.2601
	PHID(2)=24.2763
	PHID(3)=0.0
C------FIND FREE LENGTH WHERE CMIN=DESIRED SPACING
	HEL=AL*.5
	XD=1.5
	K2=1
	I2=0
1	I=1
2	PHI=PHID(I)*DTR*.5
	K1=1
	I1=0
	FIC=.8*PHI
3	CALL BEND(I0,PHI,FI0,FIC,PHI,PSI,HEL,P,R1,R2)
	Y1=X(2,3)
	CALL ITER8(I,K1,FIC,XM1,Y1,YM1,XD,DF,I1,TOL)
	IF(I1) 4,4,5
4	FIC=FIC+DF
	GO TO 3
5	ANG(I,1)=PHI-FIC
	FL(I,1)=RL(2)
	RAD(I,1)=RRR(2)
	XCL(I,1)=X(2,3)
	XCL(I,2)=X(2,4)
	IF(I-1) 6,6,7
6	ANG(I,3)=PHI
	FL(I,3)=HEL
	RAD(I,3)=RRR(3)
	XCL(I,5)=X(3,3)+DCL*SIN(PHI)
	XCL(I,6)=X(3,4)-DCL*COS(PHI)
	XCL(3,1)=X(2,3)
	XCL(3,5)=XCL(1,5)
	I=2
	GO TO 2
C------BOTH LENGTHS = XD; ASSIGN SOLENOID #'S TO THE VALUES
7	JJ=1
	DO 8 II=1,6
	IF(II.GT.4) JJ=2
	I=KTP(II)
	FI(I)=ANG(JJ,1)
	XY(1,I)=XCL(JJ,1)
8	XY(2,I)=XCL(JJ,2)
	FI(4)=0.0
	XY(1,4)=XD
	XY(2,4)=0.0
C------COMPUTE THE SPACINGS
	DO 60 I=1,5
	NA=KTR(I)
	NB=KTR(I+1)
	CALL CORD(NA,NB)
60	CALL CORD(NA,4)
	CALL CORD(6,4)
	CMIN=19.
	DO 61 I=1,7
	DO 61 J=1,7
	IF(C(I,J).EQ.0.0) GO TO 61
	IF(C(I,J).LT.CMIN) CMIN=C(I,J)
61	CONTINUE
	CALL ITER8(3,K2,XD,XM2,CMIN,YM2,CD,DX2,I2,TOL)
	IF(I2) 9,9,10
9	XD=XD+DX2
	GO TO 1
10	DO 64 I=1,7
	DO 64 J=1,7
	IF(C(I,J).EQ.0.0) GO TO 64
	WRITE(5,62) I,J,C(I,J)
62	FORMAT(' C(',I1,',',I1,') = ',F10.5)
64	CONTINUE
	CALL DATE(A1,A2)
	CALL TIME(A3,A4)
	WRITE(5,63) A1,A2,A3,A4,CMIN,XD
63	FORMAT(//,3X,2A5,3X,2A5,/
	2' CMIN = ',F10.5,10X,'DIST. FROM JEWEL BACK = ',F10.5)
C------NOW THE X&Y COORDINATES OF THE GUIDE TUBES ARE KNOWN AT THE
C    POINT WHERE THE SPACING = CD
C------MEASURE BACKWARD 30 THOU. FROM THERE
	XD=XD+.030
	I=1
100	PHI=PHID(I)*DTR*.5
	K3=1
	I3=0
	FIC=.8*PHI
11	CALL BEND(I0,PHI,FI0,FIC,PHI,PSI,HEL,P,R1,R2)
	FL(I,2)=RL(2)
	DP=DCL*(.25*AL+.5*FL(I,1)-FL(I,2))/(.25*AL-.5*FL(I,1))
	XCL(I,3)=X(2,3)-DP*SIN(ANG(I,2))
	Y3=XCL(I,3)
	CALL ITER8(I,K3,FIC,XM3,Y3,YM3,XD,DF,I3,TOL)
	IF(I3) 12,12,13
12	FIC=FIC+DF
	GO TO 11
13	ANG(I,2)=PHI-FIC
	RAD(I,2)=RRR(2)
	XCL(I,4)=X(2,4)+DP*COS(ANG(I,2))
	IF(I-1) 14,14,15
14	I=2
	XCL(3,3)=Y3
	GO TO 100
C------COMPUTE THE COORDINATES OF REAR END OF TUBE
15	I=1
55	K4=1
	I4=0
	PHI=PHID(I)*DTR*.5
	FIC=.8*PHI
58	CALL BEND(I0,PHI,FI0,FIC,PHI,PSI,HEL,P,R1,R2)
	Y4=RL(4)
	FLD=FLR+FL(I,1)
	CALL ITER8(4,K4,FIC,XM4,Y4,YM4,FLD,DF,I4,TOL)
	IF(I4) 56,56,57
56	FIC=FIC+DF
	GO TO 58
57	FL(I,6)=RL(4)
	ANG(I,6)=PHI+FIC
	RAD(I,6)=RRR(4)
	XCL(I,11)=X(4,3)
	XCL(I,12)=X(4,4)
	IF(I-1) 59,59,21
59	I=2
	XCL(3,11)=XCL(3,1)+FLR
	GO TO 55
C------MEASURE FORWARDS 30 THOU FROM THERE
21	XD=XCL(2,11)-.030
	I=1
200	PHI=PHID(I)*DTR*.5
	K9=1
	I9=0
	FIC=.8*PHI
211	CALL BEND(I0,PHI,FI0,FIC,PHI,PSI,HEL,P,R1,R2)
	ANG(I,5)=PHI+FIC
	XCL(I,9)=X(4,3)-DCL*SIN(ANG(I,5))
	Y9=XCL(I,9)
	CALL ITER8(9,K9,FIC,XM9,Y9,YM9,XD,DF,I9,TOL)
	IF(I9) 212,212,213
212	FIC=FIC+DF
	GO TO 211
213	FL(I,5)=RL(4)
	RAD(I,5)=RRR(4)
	XCL(I,10)=X(4,4)+DCL*COS(ANG(I,5))
	IF(I-1) 214,214,215
214	I=2
	XCL(3,9)=Y9
	GO TO 200
C------COMPUTE CENTER COORDINATES FOR LARGE ANGLE WIRE
215	XD=XCL(3,5)
	PHI=PHID(2)*DTR*.5
	K8=1
	I8=0
	FIC=.05
123	CALL BEND(I0,PHI,FI0,FIC,PHI,PSI,HEL,P,R1,R2)
	ANG(2,3)=PHI+FIC
	XCL(2,5)=X(4,3)+DCL*SIN(ANG(2,3))
	Y8=XCL(2,5)
	CALL ITER8(8,K8,FIC,XM8,Y8,YM8,XD,DF,I8,TOL)
	IF(I8) 124,124,125
124	FIC=FIC+DF
	GO TO 123
125	FL(2,3)=RL(4)
	RAD(2,3)=RRR(2)
	XCL(2,6)=X(4,4)-DCL*COS(ANG(2,3))
C------COMPUTE COORDINATES OF THE INTERMEDIATE SUPPORT
	XD=.5*XCL(1,1)
C	XD=.623
	I=1
20	PHI=PHID(I)*DTR*.5
	K6=1
	I6=0
	FIC=.9*PHI
111	CALL BEND(I0,PHI,FI0,FIC,PHI,PSI,HEL,P,R1,R2)
	Y6=X(2,3)
	CALL ITER8(I,K6,FIC,XM6,Y6,YM6,XD,DF,I6,TOL)
	IF(I6) 112,112,113
112	FIC=FIC+DF
	GO TO 111
113	FL(I,4)=RL(2)
	ANG(I,4)=PHI-FIC
	XCL(I,7)=X(2,3)
	XCL(I,8)=X(2,4)
	RAD(I,4)=RRR(2)
	IF(I-1) 22,22,74
22	I=2
	XCL(3,7)=XD
	XCL(3,8)=0.0
	ANG(3,4)=0.0
	GO TO 20
C------COMPUTE THE HOLE DIAMETERS
74	DO 65 I=2,5
	DD=TD
	IF(I.EQ.4) DD=WD
	II=2*I
	DO 68 J=1,2
	PH=ANG(J,I)
	RD=RAD(J,I)
	SNP=SIN(PH)
	FDF1=ASIN(SNP+TH(I)/(2.*RD))
	D1=2.*RD*SIN((FDF1-PH)/2.)
	YB=SQRT(D1**2-.25*TH(I)**2)+DD/(2.*COS(FDF1))
	IF(I-4) 66,67,66
C------ANGLED HOLE
67	YA=((TH(I)-WD*SNP)*SNP-DD)/(2.*COS(PH))
	DIA(J,I)=(YB-YA)*COS(PH)
	XIS(J)=.5*(YB+YA)
	GO TO 68
C------PERPENDICULAR HOLE
66	FDF2=ASIN(SNP-TH(I)/(2.*RD))
	D2=2.*RD*SIN((PH-FDF2)/2.)
	YA=SQRT(D2**2-.25*TH(I)**2)-DD/(2.*COS(FDF2))
	DIA(J,I)=(YB-YA)
	XCL(J,II)=XCL(J,II)+.5*(YB+YA)
68	DIA(3,I)=DD
65	XCL(3,II)=0.0
	XIS(3)=0.0
C-------COMPUTE R AND E VECTORS FOR MACHINE COORD.
	JJ=1
	DO 81 II=1,7
	IF(II.GT.4) JJ=2
	IF(II.GT.6) JJ=3
	I=KTP(II)
	CC=COS(ANG(JJ,4))
	S=SIN(ANG(JJ,4))
	CG=COS(GAMR(I))
	SG=SIN(GAMR(I))
	EIS(1,I)=CC
	EIS(2,I)=S*CG
	EIS(3,I)=S*SG
	RIS(1,I)=XCL(JJ,7)+.5*TH(4)
	RIS(2,I)=(XCL(JJ,8)+XIS(JJ))*CG + DY(I)
81	RIS(3,I)=(XCL(JJ,8)+XIS(JJ))*SG
C------PRINT THE UNTRANSFORMED COORDINATES
	GO TO 678
	WRITE(5,75) AL,WD,TID,TOD
75	FORMAT(///,' WIRE ACTIVE L',T20,'WIRE DIA',T35,'TUBE ID',
	2T50,'TUBE OD',/,4(F10.5,5X))
	DO 79 I=1,2
	DO 79 J=1,6
79	ANG(I,J)=ANG(I,J)*RTD
	DO 77 I=1,3
	TUBL=FL(I,6)-FL(I,1)
	WRITE(5,80) PHID(I),TUBL
80	FORMAT(////,' UNTRANSFORMED COORDINATES FOR PHI = ',F10.5,
	25X,'TUBE LENGTH = ',F10.5)
77	WRITE(5,78)((XCL(I,2*N-1),XCL(I,2*N),FL(I,N),ANG(I,N),RAD(I,N))
	2,N=1,6)
78	FORMAT(//,T5,'X',T15,'Y',T25,'FREE L',T35,'ANGLE',T45,
	2'RADIUS',//,' TUBE END',/,5F10.5,//,' FRONT SUP.',/
	3,5F10.5,//,' CENTER SUP.',/,5F10.5,//,' FRNT. WIRE SUP.',
	4/,5F10.5,//,' REAR SUP.',/,5F10.5//,' TUBE BACK',/
	5,5F10.5)
C------ASSIGN WIRE NUMBERS, TRANSFORM, AND PRINT
678	CONTINUE
	S5S=5.*SIN(.25*PI)
	JJ=1
	DO 16 II=1,7
	IF(II.GT.4) JJ=2
	IF(II.GT.6) JJ=3
	I=KTP(II)
	CC=COS(GAMR(I))
	S=SIN(GAMR(I))
	PHID(JJ)=ANG(JJ,4)*RTD
	WRITE(5,17) I,PHID(JJ),GAM(I)
17	FORMAT(////,' WIRE NUMBER ',I1,/,T5,'PHI',T20,'GAMMA',
	2/,2F15.5)
	DO 76 K=1,6
	KK=2*K-1
	XYZ(1,I,K)=XCL(JJ,KK)
	XYZ(2,I,K)=XCL(JJ,KK+1)*CC+DY(I)
76	XYZ(3,I,K)=XCL(JJ,KK+1)*S
C	WRITE(5,18)(((XYZ(L,I,N),L=1,3),FL(JJ,N),DIA(JJ,N),TH(N))
	2,N=1,6)
18	FORMAT(//,T5,'X',T15,'Y',T25,'Z',T35,'FREE L',T45,'DIA',
	2T55,'THICKNS',//,' TUBE END',/,6F10.5,//,' FRONT SUP.',/
	3,6F10.5,//,' CENTER SUP.',/,6F10.5,//,' FRNT. WIRE SUP.',
	4/,6F10.5,//,' REAR SUP.',/,6F10.5//,' TUBE BACK',/
	5,6F10.5)
C-------COMPUTE MACHINE COORDINATES
	UM(1)=EMM
	UM(2)=0.0
	UM(3)=0.0
	UA(1)=0.0
	UA(2)=-AC
	UA(3)=0.0
	DO 402 K=1,3
402	UMK(K)=-(RIS(K,4)+UA(K)+UM(K)+ENN*EIS(K,I)-RIS(K,I))
	EU(1)=0.0
	EU(2)=S
	EU(3)=-CC
	DO 403 K=1,3
403	EW(K)=EIS(K,I)
	CALL CROSS(EW,EU,EN)
	SM=0.0
	DO 404 K=1,3
404	SM=SM+EN(K)**2
	DO 405 K=1,3
405	EV(K)=EN(K)/SQRT(ABS(SM))
	CALL DOT(UMK,EU,RU)
	CALL DOT(UMK,EV,RV)
	CALL DOT(UMK,EW,RW)
	WRITE(5,406) (RIS(K,I),K=1,3),RU,RV,RW
406	FORMAT(//,'  INTERMED. SUP. MACHINE COORD.',/
	3,T5,'X',T15,'Y',T25,'Z',/,3F10.5,//
	2,T5,'U',T15,'V',T25,'W',/,3F10.5)
	S5P=5.*SIN(DTR*ANG(JJ,4))
	S5G=5.*ABS(S)
	IF(S5G.GT.S5S) GO TO 407
	WRITE(5,408) S5P,S5G
408	FORMAT(//,'  5 X SIN PHI',T20,'5 X SIN GAM',/,2F15.5)
	GO TO 16
407	C5G=5.*ABS(CC)
	WRITE(5,409) S5P,C5G
409	FORMAT(//,'  5 X SIN PHI',T20,'5 X COS GAM',/,2F15.5)
16	CONTINUE
	END