Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

Sl_family.f90 @ 430

Last change on this file since 430 was 430, checked in by touze, 11 years ago
import madx-5.01.00
File size: 68.2 KB

Line
1	!The Polymorphic Tracking Code
2	!Copyright (C) Etienne Forest and CERN
3
4	MODULE S_FAMILY
5	USE S_FIBRE_BUNDLE
6	IMPLICIT NONE
7	public
8
9	! LINKED LIST
10	PRIVATE SURVEY_EXIST_PLANAR_L_NEW ,SURVEY_EXIST_PLANAR_IJ,MISALIGN_FIBRE_EQUAL ,SURVEY_EXIST_PLANAR_I
11	!,SURVEY_NO_PATCH
12	PRIVATE COPY_LAYOUT,COPY_LAYOUT_I,KILL_PARA_L
13	PRIVATE FIBRE_WORK,FIBRE_POL,FIBRE_BL,ADDP_ANBN,WORK_FIBRE,BL_FIBRE,layout_WORK
14	PRIVATE COPY_LAYOUT_IJ,PUT_APERTURE_FIB,REMOVE_APERTURE_FIB,PUT_APERTURE_FIBt
15	private copy_fibre
16	! old Sj_elements
17	PRIVATE SURVEY_mag !,TRANSLATE_magnet,rot_magnet
18	!END old Sj_elements
19
20	INTERFACE EL_TO_ELP
21	!LINKED
22	MODULE PROCEDURE EL_TO_ELP_L
23	END INTERFACE
24
25	INTERFACE ELP_TO_EL
26	!LINKED
27	MODULE PROCEDURE ELP_TO_EL_L
28	END INTERFACE
29
30	INTERFACE copy
31	MODULE PROCEDURE copy_fibre
32	END INTERFACE
33
34	INTERFACE SURVEY
35	! LINK LIST
36	! MODULE PROCEDURE SURVEY_NO_PATCH ! NO PATCH
37	MODULE PROCEDURE SURVEY_EXIST_PLANAR_L_NEW ! ORDINARY SURVEY STARTING AT POSITION 1
38	MODULE PROCEDURE SURVEY_FIBRE
39	MODULE PROCEDURE SURVEY_EXIST_PLANAR_IJ
40	MODULE PROCEDURE SURVEY_EXIST_PLANAR_I
41	! old Sj_elements
42	! MODULE PROCEDURE SURVEY_mag ! tracks a chart for survey
43	!END old Sj_elements
44	END INTERFACE
45
46	! INTERFACE TRACK
47	! LINK LIST
48	! MODULE PROCEDURE SURVEY_FIB
49	! MODULE PROCEDURE SURVEY_EXIST_PLANAR_IJ
50	! MODULE PROCEDURE SURVEY_EXIST_PLANAR_I
51	! old Sj_elements
52	! MODULE PROCEDURE SURVEY_mag ! tracks a chart for survey
53	!END old Sj_elements
54	! END INTERFACE
55
56	INTERFACE KILL_PARA
57	MODULE PROCEDURE KILL_PARA_L
58	END INTERFACE
59
60	INTERFACE ADD
61	MODULE PROCEDURE ADDP_ANBN
62	END INTERFACE
63
64	INTERFACE PUT_APERTURE
65	MODULE PROCEDURE PUT_APERTURE_FIB ! NEED UPGRADE
66	MODULE PROCEDURE PUT_APERTURE_FIBt ! NEED UPGRADE
67	END INTERFACE
68
69	INTERFACE REMOVE_APERTURE
70	MODULE PROCEDURE REMOVE_APERTURE_FIB ! NEED UPGRADE
71	END INTERFACE
72
73
74
75	INTERFACE ASSIGNMENT (=)
76	! LINKED
77	MODULE PROCEDURE SCAN_FOR_POLYMORPHS
78	MODULE PROCEDURE FIBRE_WORK
79	MODULE PROCEDURE MISALIGN_FIBRE_EQUAL
80	MODULE PROCEDURE FIBRE_POL
81	MODULE PROCEDURE FIBRE_BL
82	MODULE PROCEDURE BL_FIBRE
83	MODULE PROCEDURE WORK_FIBRE
84	MODULE PROCEDURE layout_WORK
85	END INTERFACE
86
87	INTERFACE EQUAL
88	! LINKED
89	MODULE PROCEDURE COPY_LAYOUT
90	END INTERFACE
91
92	INTERFACE COPY
93	! LINKED
94	MODULE PROCEDURE COPY_LAYOUT_I
95	MODULE PROCEDURE COPY_LAYOUT_IJ
96	END INTERFACE
97
98	INTERFACE TRANS
99	! LINKED
100	MODULE PROCEDURE TRANSLATE_layout
101	MODULE PROCEDURE TRANSLATE_fibre
102	MODULE PROCEDURE TRANSLATE_frame
103	END INTERFACE
104
105	INTERFACE TRANSLATE
106	! LINKED
107	MODULE PROCEDURE TRANSLATE_layout
108	MODULE PROCEDURE TRANSLATE_fibre
109	MODULE PROCEDURE TRANSLATE_frame
110	! MODULE PROCEDURE TRANSLATE_magnet !element input
111	END INTERFACE
112
113	INTERFACE ROTATE
114	! LINKED
115	MODULE PROCEDURE ROTATE_LAYOUT
116	MODULE PROCEDURE ROTATE_FIBRE
117	MODULE PROCEDURE ROTATE_FRAME
118	MODULE PROCEDURE rotate_magnet
119	END INTERFACE
120
121	INTERFACE ROTATION
122	! LINKED
123	MODULE PROCEDURE ROTATE_LAYOUT
124	MODULE PROCEDURE ROTATE_FIBRE
125	MODULE PROCEDURE ROTATE_FRAME
126	END INTERFACE
127
128
129
130	CONTAINS
131
132	! old Sj_elements
133
134	SUBROUTINE SURVEY_mag(C,el,dir,magnetframe,e_in) ! Tracks the chart through a magnet
135	IMPLICIT NONE
136	TYPE(CHART), TARGET ,optional, INTENT(INOUT):: C
137	type(element),target,intent(inout) :: el
138	! TYPE(magnet_frame), OPTIONAL :: magnetframe
139	TYPE(magnet_frame),target, OPTIONAL :: magnetframe
140	INTEGER, intent(in):: dir
141	TYPE(INNER_FRAME), OPTIONAL :: E_IN
142
143	! All PTC magnet have the same convention for the internal frame
144	! Show a user want to add a magnet with corckscrew survey
145	! his survey would have to be "caught" in this interface
146
147	SELECT CASE(EL%KIND)
148	case(kind0:kind22,KINDWIGGLER,kindpa)
149	call SURVEY_chart(C,el%p,dir,magnetframe,E_IN)
150
151	! case(kind23)
152	! call SURVEY_CHART_layout(C,el,DIR,MAGNETFRAME,E_IN)
153	case default
154	write(6,*) el%kind," not supported SURVEY_mag in S_FAMILY"
155	END SELECT
156
157	! RECURSIVE SUBROUTINE SURVEY_EXIST_PLANAR_L_NEW(PLAN,ENT,A) ! CALLS ABOVE ROUTINE FROM FIBRE #1 TO #PLAN%N : STANDARD SURVEY
158
159	end SUBROUTINE SURVEY_mag
160
161
162
163	! END old Sj_elements
164
165	!NEW
166
167	SUBROUTINE locate_mid_frame(R,mid,o,ld)
168	IMPLICIT NONE
169	TYPE(LAYOUT),target, INTENT(IN) :: R
170	TYPE(FIBRE), POINTER:: P
171	real(dp), intent(out) :: mid(3,3),o(3),ld
172	integer i
173
174
175	if(mod(R%N,2)==0) then
176	P=>R%START
177	DO I=1,R%N/2
178	P=>P%NEXT
179	ENDDO
180	mid=p%chart%f%ent
181	o=p%chart%f%a
182	else
183	P=>R%START
184	DO I=1,(R%N-1)/2
185	P=>P%NEXT
186	ENDDO
187	mid=p%chart%f%mid
188	o=p%chart%f%o
189	endif
190
191	call get_length(r,ld)
192
193
194
195
196
197	END SUBROUTINE locate_mid_frame
198
199	SUBROUTINE LOCATE_FIBRE(R,PIN,I)
200	IMPLICIT NONE
201	TYPE(LAYOUT),target, INTENT(IN) :: R
202	TYPE(FIBRE), POINTER:: P,PIN
203	INTEGER, INTENT(INOUT) :: I
204	P=>R%START
205	DO I=1,R%N
206	IF(ASSOCIATED(PIN,P) ) EXIT
207	P=>P%NEXT
208	ENDDO
209	END SUBROUTINE LOCATE_FIBRE
210
211
212	SUBROUTINE GET_FREQ(R,FREQ)
213	IMPLICIT NONE
214	TYPE(LAYOUT),target, INTENT(IN) :: R
215	REAL(DP), INTENT(OUT) :: FREQ
216	TYPE(FIBRE), POINTER:: P
217	INTEGER I
218	P=>R%START
219	FREQ=0.0_dp
220	DO I=1,R%N
221	IF(ASSOCIATED(P%MAG%FREQ)) THEN
222	IF(P%MAG%FREQ/=0.0_dp) THEN
223	IF(FREQ==0.0_dp) THEN
224	FREQ=P%MAG%FREQ
225	ELSEIF(FREQ>P%MAG%FREQ) THEN
226	FREQ=P%MAG%FREQ
227	ENDIF
228	ENDIF
229	ENDIF
230	P=>P%NEXT
231	ENDDO
232	END SUBROUTINE GET_FREQ
233
234	SUBROUTINE GET_loss(R,energy,deltap)
235	IMPLICIT NONE
236	TYPE(LAYOUT),target, INTENT(IN) :: R
237	REAL(DP), INTENT(OUT) :: energy,deltap
238	TYPE(FIBRE), POINTER:: P
239	INTEGER I
240	P=>R%START
241	energy=0.0_dp
242	deltap=0.0_dp
243	DO I=1,R%N
244	IF(P%MAG%kind==kind4) THEN
245	energy=energy+p%mag%delta_e
246	write(6,*) p%mag%name
247	ENDIF
248	P=>P%NEXT
249	ENDDO
250	P=>R%START
251	deltap=energy/p%mag%p%p0c
252	END SUBROUTINE GET_loss
253
254	SUBROUTINE GET_ALL(R,FREQ,VOLT,PHAS)
255	IMPLICIT NONE
256	TYPE(LAYOUT),target, INTENT(IN) :: R
257	REAL(DP), INTENT(OUT) :: FREQ,VOLT,PHAS
258	TYPE(FIBRE), POINTER:: P
259	INTEGER I
260	P=>R%START
261	FREQ=0.0_dp;VOLT=0.0_dp;PHAS=0.0_dp;
262	DO I=1,R%N
263	IF(ASSOCIATED(P%MAG%FREQ)) THEN
264	IF(P%MAG%FREQ/=0.0_dp) THEN
265	FREQ=TWOPI*P%MAG%FREQ/CLIGHT
266	VOLT=-P%MAG%VOLT*1e-3_dp/P%MAG%P%P0C
267	PHAS=P%MAG%PHAS
268	ENDIF
269	ENDIF
270	P=>P%NEXT
271	ENDDO
272	END SUBROUTINE GET_ALL
273
274	SUBROUTINE GET_ALL_mad_like(R,FREQ,VOLT,PHAS)
275	IMPLICIT NONE
276	TYPE(LAYOUT),target, INTENT(IN) :: R
277	REAL(DP), INTENT(OUT) :: FREQ,VOLT,PHAS
278	TYPE(FIBRE), POINTER:: P
279	INTEGER I
280	P=>R%START
281	FREQ=0.0_dp;VOLT=0.0_dp;PHAS=0.0_dp;
282	DO I=1,R%N
283	IF(ASSOCIATED(P%MAG%FREQ)) THEN
284	IF(P%MAG%FREQ/=0.0_dp) THEN
285	FREQ=P%MAG%FREQ
286	VOLT=P%MAG%VOLT
287	PHAS=-P%MAG%PHAS
288	ENDIF
289	ENDIF
290	P=>P%NEXT
291	ENDDO
292	END SUBROUTINE GET_ALL_mad_like
293
294	SUBROUTINE locate_next_cav(R,di,P)
295	IMPLICIT NONE
296	TYPE(LAYOUT),target, INTENT(INOUT) :: R
297	integer, INTENT(INout) :: di
298	TYPE(FIBRE), POINTER:: P
299	INTEGER I
300	di=1
301	if(associated(p)) P=>P%NEXT
302	DO I=1,R%N
303	if(associated(p)) then
304	IF(ASSOCIATED(P%MAG%FREQ)) THEN
305	IF(P%MAG%FREQ/=0.0_dp) THEN
306	exit
307	ENDIF
308	ENDIF
309	di=di+1
310	P=>P%NEXT
311	endif
312	ENDDO
313	END SUBROUTINE locate_next_cav
314
315	SUBROUTINE locate_all_cav(R,pos)
316	IMPLICIT NONE
317	TYPE(LAYOUT),target, INTENT(INOUT) :: R
318	TYPE(FIBRE), POINTER:: P
319	INTEGER, pointer :: pos(:)
320	integer i,ic
321	ic=0
322	P=>r%start
323	DO I=1,R%N
324	IF(ASSOCIATED(P%MAG%FREQ)) THEN
325	IF(P%MAG%FREQ/=0.0_dp) THEN
326	ic=ic+1
327	ENDIF
328	ENDIF
329	P=>P%NEXT
330	ENDDO
331	allocate(pos(ic))
332	pos=0
333	ic=0
334	P=>r%start
335	DO I=1,R%N
336	IF(ASSOCIATED(P%MAG%FREQ)) THEN
337	IF(P%MAG%FREQ/=0.0_dp) THEN
338	ic=ic+1
339	pos(ic)=i
340	ENDIF
341	ENDIF
342	P=>P%NEXT
343	ENDDO
344
345	END SUBROUTINE locate_all_cav
346
347
348	SUBROUTINE SET_FREQ(R,FREQ)
349	IMPLICIT NONE
350	TYPE(LAYOUT),target, INTENT(INOUT) :: R
351	REAL(DP), INTENT(IN) :: FREQ
352	TYPE(FIBRE), POINTER:: P
353	INTEGER I
354	P=>R%START
355	DO I=1,R%N
356	IF(ASSOCIATED(P%MAG%FREQ)) THEN
357	IF(P%MAG%FREQ/=0.0_dp) THEN
358	P%MAG%FREQ=FREQ
359	P%MAGP%FREQ=FREQ
360	ENDIF
361	ENDIF
362	P=>P%NEXT
363	ENDDO
364	END SUBROUTINE SET_FREQ
365
366	SUBROUTINE ADD_FREQ(R,FREQ)
367	IMPLICIT NONE
368	TYPE(LAYOUT),target, INTENT(INOUT) :: R
369	REAL(DP), INTENT(IN) :: FREQ
370	TYPE(FIBRE), POINTER:: P
371	INTEGER I
372	P=>R%START
373	DO I=1,R%N
374	IF(ASSOCIATED(P%MAG%FREQ)) THEN
375	IF(P%MAG%FREQ/=0.0_dp) THEN
376	P%MAG%FREQ=P%MAG%FREQ+FREQ
377	P%MAGP%FREQ=P%MAGP%FREQ+FREQ
378	ENDIF
379	ENDIF
380	P=>P%NEXT
381	ENDDO
382	END SUBROUTINE ADD_FREQ
383
384	!END NEW
385	SUBROUTINE ADDP_ANBN(EL,NM,F,V) ! EXTENDS THE ADD ROUTINES FROM THE ELEMENT(P) TO THE FIBRE
386	IMPLICIT NONE
387	TYPE(FIBRE),target, INTENT(INOUT) ::EL
388	REAL(DP), INTENT(IN) ::V
389	INTEGER, INTENT(IN) ::NM,F
390
391	CALL ADD(EL%MAG,NM,F,V)
392	CALL ADD(EL%MAGP,NM,F,V)
393
394	END SUBROUTINE ADDP_ANBN
395
396
397	SUBROUTINE PUT_APERTURE_FIB(EL,KIND,R,X,Y)
398	IMPLICIT NONE
399	REAL(DP),INTENT(IN):: R(2),X,Y
400	INTEGER,INTENT(IN):: KIND
401	TYPE(FIBRE),target,INTENT(INOUT):: EL
402
403	CALL PUT_APERTURE(EL%MAG,KIND,R,X,Y,0.0_dp,0.0_dp)
404	CALL PUT_APERTURE(EL%MAGP,KIND,R,X,Y,0.0_dp,0.0_dp)
405
406	END SUBROUTINE PUT_APERTURE_FIB
407
408	SUBROUTINE PUT_APERTURE_FIBt(EL,KIND,R,X,Y,dx,dy)
409	IMPLICIT NONE
410	REAL(DP),INTENT(IN):: R(2),X,Y,dx,dy
411	INTEGER,INTENT(IN):: KIND
412	TYPE(FIBRE),target,INTENT(INOUT):: EL
413
414	CALL PUT_APERTURE(EL%MAG,KIND,R,X,Y,dx,dy)
415	CALL PUT_APERTURE(EL%MAGP,KIND,R,X,Y,dx,dy)
416
417	END SUBROUTINE PUT_APERTURE_FIBt
418
419	SUBROUTINE REMOVE_APERTURE_FIB(EL)
420	IMPLICIT NONE
421	TYPE(FIBRE),target,INTENT(INOUT):: EL
422
423	CALL REMOVE_APERTURE_EL(EL%MAG)
424	CALL REMOVE_APERTURE_ELP(EL%MAGP)
425
426	END SUBROUTINE REMOVE_APERTURE_FIB
427
428	SUBROUTINE layout_WORK(r,S1) ! CHANGES THE ENERGY OF THE FIBRE AND TURNS THE ENERGY PATCH ON
429	IMPLICIT NONE
430	TYPE (WORK),INTENT(IN):: S1
431	TYPE(layout),target,INTENT(INOUT):: r
432	TYPE(fibre),pointer :: p
433	integer i
434
435	p=> r%start
436
437	do i=1,r%n
438	p=s1
439
440	p=>p%next
441	enddo
442
443	END SUBROUTINE layout_WORK
444
445
446	SUBROUTINE FIBRE_WORK(S2,S1) ! CHANGES THE ENERGY OF THE FIBRE AND TURNS THE ENERGY PATCH ON
447	IMPLICIT NONE
448	TYPE (WORK),INTENT(IN):: S1
449	TYPE(FIBRE),target,INTENT(INOUT):: S2
450
451	S2%MAG=S1
452	S2%MAGP=S1
453	if(S1%power/=-1) then ! just rescaling -1=ramping
454	S2%mass=S1%mass
455	S2%BETA0=S1%BETA0
456	S2%GAMMA0I=S1%GAMMA0I
457	S2%GAMBET=S1%GAMBET
458	endif
459
460
461	END SUBROUTINE FIBRE_WORK
462
463	SUBROUTINE WORK_FIBRE(S2,S1) ! SUCKS THE ENERGY OUT OF A FIBRE BY LOKING AT ELEMENT
464	IMPLICIT NONE
465	TYPE (FIBRE),target,INTENT(IN):: S1
466	TYPE(WORK),INTENT(INOUT):: S2
467
468	S2=S1%MAG
469	IF(ABS(S1%MAG%P%P0C-S1%MAGP%P%P0C)>1e-10_dp) THEN
470	W_P=0
471	W_P%NC=3
472	W_P%FC='(2(1X,A72,/),(1X,A72))'
473	W_P%C(1)=" BEWARE : ELEMENT AND ELEMENTP SEEM TO HAVE "
474	W_P%C(2)=" DIFFERENT REFERENCE ENERGIES!"
475	WRITE(W_P%C(3),'(1X,G21.14,1X,g21.14)') S1%MAG%P%P0C,S1%MAGP%P%P0C
476	! call !write_e(100)
477	ENDIF
478
479	END SUBROUTINE WORK_FIBRE
480	! S-aperture
481
482	SUBROUTINE alloc_s_aperture(S1,APERTURE) ! copy full fibre
483	IMPLICIT NONE
484	TYPE(MADX_APERTURE), OPTIONAL :: APERTURE
485	TYPE (FIBRE),target,INTENT(INout):: S1
486
487	if(associated(S1%mag%p%a)) call kill(S1%mag%p%a)
488	if(associated(S1%magp%p%a)) call kill(S1%magp%p%a)
489
490	call alloc(S1%mag%p%a,S1%mag%p%nst+1,APERTURE)
491	call alloc(S1%magp%p%a,S1%magp%p%nst+1,APERTURE)
492
493	END SUBROUTINE alloc_s_aperture
494
495	SUBROUTINE kill_s_aperture(S1) ! copy full fibre
496	IMPLICIT NONE
497	TYPE (FIBRE),INTENT(INout):: S1
498
499	if(associated(S1%mag%p%a)) call kill(S1%mag%p%a)
500	if(associated(S1%magp%p%a)) call kill(S1%magp%p%a)
501
502
503	END SUBROUTINE kill_s_aperture
504
505
506	SUBROUTINE copy_fibre(S1,S2) ! copy full fibre
507	IMPLICIT NONE
508	TYPE (FIBRE),target,INTENT(IN):: S1
509	TYPE(FIBRE),target,INTENT(INOUT):: S2
510
511	call copy(s1%mag,s2%mag)
512	call copy(s1%mag,s2%magp)
513
514	END SUBROUTINE copy_fibre
515
516	SUBROUTINE MISALIGN_FIBRE_EQUAL(S2,S1) ! MISALIGNS FULL FIBRE; FILLS IN CHART AND MAGNET_CHART
517	IMPLICIT NONE
518	REAL(DP),INTENT(IN):: S1(6)
519	TYPE(FIBRE),target,INTENT(INOUT):: S2
520
521	CALL MISALIGN_FIBRE(S2,S1)
522
523	END SUBROUTINE MISALIGN_FIBRE_EQUAL
524
525	SUBROUTINE FIND_AFFINE_SIAMESE(S2,CN,FOUND) !
526	! FIND THE ELEMENT (CN) ON WHICH THE AFFINE_FRAME IS
527	IMPLICIT NONE
528	TYPE(FIBRE),TARGET,INTENT(INOUT):: S2
529	! TYPE(AFFINE_FRAME),POINTER :: AF
530	TYPE(ELEMENT), POINTER :: C,CN
531	INTEGER K
532	LOGICAL(LP),INTENT(INOUT)::FOUND
533
534	! NULLIFY(AF)
535	! NULLIFY(CN)
536
537
538	FOUND=MY_FALSE
539	K=0
540
541	IF(ASSOCIATED(S2%MAG%SIAMESE)) THEN
542
543
544	C=>S2%MAG
545	CN=>S2%MAG%SIAMESE
546
547	IF(ASSOCIATED(C%SIAMESE_FRAME)) THEN
548	! AF=>C%SIAMESE_FRAME
549	CN=>C
550	FOUND=MY_TRUE
551	! WRITE(6,*) " HERE 1 ", FOUND
552	RETURN
553	ENDIF
554
555	DO WHILE(.NOT.ASSOCIATED(C,CN))
556	IF(ASSOCIATED(CN%SIAMESE_FRAME)) THEN
557	! AF=>CN%SIAMESE_FRAME
558	FOUND=MY_TRUE
559	! WRITE(6,*) " HERE 2 ", FOUND
560	EXIT
561	ENDIF
562	CN=>CN%SIAMESE
563	k=k+1
564	IF(K>10000)THEN
565	WRITE(6,*) " TOO MANY IN SIAMESE "
566	STOP 666
567	ENDIF
568	ENDDO
569	ENDIF
570
571	END SUBROUTINE FIND_AFFINE_SIAMESE
572
573	SUBROUTINE FIND_FRAME_SIAMESE(MAG,B,EXI,ADD) !
574	! ACTUALLY CONSTRUCTS THE AFFINE FRAME FOUND PREVIOUSLY ON MAG
575	! FROM mag%SIAMESE_FRAME%D,mag%SIAMESE_FRAME%ANGLE
576	! IF ADD=FALSE, START FROM ORIGINAL FIBRE POSITION
577	! COMPUTE B,EXI
578	IMPLICIT NONE
579	TYPE(ELEMENT), POINTER :: MAG
580	REAL(DP), INTENT(INOUT) :: B(3),EXI(3,3)
581	LOGICAL(LP), OPTIONAL, INTENT(IN) :: ADD
582	LOGICAL(LP) ADDIN
583
584	ADDIN=.FALSE.
585
586	IF(PRESENT(ADD)) ADDIN=ADD
587
588	IF(ADDIN) THEN
589	CALL INVERSE_FIND_PATCH(mag%p%F%a,mag%p%F%ENT, &
590	mag%SIAMESE_FRAME%D,mag%SIAMESE_FRAME%ANGLE,B,EXI)
591	ELSE
592	CALL INVERSE_FIND_PATCH(mag%PARENT_FIBRE%CHART%F%a,mag%PARENT_FIBRE%CHART%F%ENT, &
593	mag%SIAMESE_FRAME%D,mag%SIAMESE_FRAME%ANGLE,B,EXI)
594	ENDIF
595
596	END SUBROUTINE FIND_FRAME_SIAMESE
597
598	RECURSIVE SUBROUTINE MISALIGN_SIAMESE(S2,S1,OMEGA,BASIS,ADD,preserve_girder)
599	! SAME AS MISALIGN_FIBRE: DEFAULT IS THE O,MID OF S2
600	! UNLESS IT FINDS TYPE(AFFINE_FRAME), POINTER :: SIAMESE_FRAME ON S2%SIAMESE CHAIN
601	! ON ONE SIAMESE IN THE CHAIN
602
603	! THIS IS OVERWRITEN IF OMEGA AND BASIS ARE PRESENT
604
605
606	IMPLICIT NONE
607	REAL(DP),INTENT(IN):: S1(6)
608	REAL(DP), OPTIONAL, INTENT(IN) :: OMEGA(3),BASIS(3,3)
609	TYPE(FIBRE),TARGET,INTENT(INOUT):: S2
610	TYPE(ELEMENT), POINTER :: C,CN
611	TYPE(fibre), POINTER :: P
612	integer k
613	REAL(DP) OMEGAT(3),BASIST(3,3),B(3),EXI(3,3)
614	real(dp) a1(3),e1(3,3),a2(3),e2(3,3),dg1(3),ag1(3),mis(6)
615	LOGICAL(LP), OPTIONAL, INTENT(IN) :: ADD,preserve_girder
616	LOGICAL(LP) ADDIN,pres
617	! TYPE(AFFINE_FRAME),POINTER :: AF
618	LOGICAL(LP) FOUND
619	LOGICAL(LP) FOUNDg
620	type(element), pointer :: caf
621	! REAL(DP) D(3),ANG(3)
622
623	FOUND=.FALSE.
624	ADDIN=.FALSE.
625	pres=.FALSE.
626	if(present(preserve_girder)) pres=preserve_girder
627	CALL FIND_AFFINE_SIAMESE(S2,CN,FOUND) ! Looking for siamese WITH FRAME
628	IF(FOUND) CALL FIND_FRAME_SIAMESE(CN,B,EXI,ADD) ! FIND ACTUAL FRAME
629
630	FOUNDg=.false.
631	if(pres.and.associated(s2%mag%girders).and.(.not.addin)) then
632	CALL FIND_AFFINE_GIRDER(S2,CAF,FOUNDg)
633	if(foundg) then
634	a1=caf%girder_frame%a
635	e1=caf%girder_frame%ent
636	a2=caf%girder_frame%b
637	e2=caf%girder_frame%exi
638	! call INVERSE_FIND_PATCH(a1,e1,dg1,ag1,a2,e2)
639	call FIND_PATCH(a1,e1,a2,e2,dg1,ag1)
640	mis=0.0_dp
641	call MISALIGN_siamese(S2,MIS)
642	MIS(1:3)=DG1
643	MIS(4:6)=AG1
644
645	call MISALIGN_SIAMESE(S2,MIS,OMEGA=a1,BASIS=e1)
646	call MISALIGN_SIAMESE(S2,S1,OMEGA,BASIS,ADD=my_true,preserve_girder=my_false)
647	return
648	endif
649	endif
650
651	IF(PRESENT(ADD)) ADDIN=ADD
652
653	IF(PRESENT(OMEGA)) THEN ! Arbitrary Origin
654	OMEGAT=OMEGA
655	ELSE
656	OMEGAT=S2%CHART%F%O ! Centre of magnet otherwise
657	ENDIF
658
659	IF(PRESENT(BASIS)) THEN ! Arbitrary Basis
660	BASIST=BASIS
661	ELSE
662	BASIST=S2%CHART%F%MID ! Centre of Magnet Otherwise
663	ENDIF
664
665	IF((.NOT.PRESENT(OMEGA)).AND.(.NOT.PRESENT(BASIS))) THEN
666	IF(FOUND) THEN ! If no special basis and no special origin
667	OMEGAT=B ! and siamese is found, then it uses the siamese basis
668	BASIST=EXI ! Notice that if ADD=true, the siamese frames move with the magnets
669	ENDIF
670	ENDIF
671
672	CALL MISALIGN_FIBRE(S2,S1,OMEGAT,BASIST,ADD=ADDIN)
673	k=1
674
675	IF(ASSOCIATED(S2%MAG%SIAMESE)) THEN
676	C=>S2%MAG
677	CN=>S2%MAG%SIAMESE
678	DO WHILE(.NOT.ASSOCIATED(C,CN))
679	P=>CN%PARENT_FIBRE
680	CALL MISALIGN_FIBRE(P,S1,OMEGAT,BASIST,ADD=ADDIN)
681	CN=>CN%SIAMESE
682	k=k+1
683	ENDDO
684	ENDIF
685	! CALL MOVE_SIAMESE_FRAME(S2%MAG)
686	if(global_verbose) write(6,*) k, " magnet misaligned "
687	END SUBROUTINE MISALIGN_SIAMESE
688
689	SUBROUTINE FIND_AFFINE_GIRDER(S2,CN,FOUND) !
690	! SAME AS FIND_AFFINE_SIAMESE
691	! LOCATES MAGNET CN WHERE C%GIRDER_FRAME IS
692	IMPLICIT NONE
693	TYPE(FIBRE),TARGET,INTENT(INOUT):: S2
694	! TYPE(AFFINE_FRAME),POINTER :: AF
695	TYPE(ELEMENT), POINTER :: C,CN
696	INTEGER K
697	LOGICAL(LP),INTENT(INOUT)::FOUND
698
699	! NULLIFY(AF)
700	! NULLIFY(CN)
701
702
703	FOUND=MY_FALSE
704	K=0
705
706	IF(ASSOCIATED(S2%MAG%GIRDERS)) THEN
707	C=>S2%MAG
708	CN=>S2%MAG%GIRDERS
709
710	IF(ASSOCIATED(C%GIRDER_FRAME)) THEN
711	! AF=>C%GIRDER_FRAME
712	CN=>C
713	FOUND=MY_TRUE
714	RETURN
715	ENDIF
716
717	DO WHILE(.NOT.ASSOCIATED(C,CN))
718	IF(ASSOCIATED(CN%GIRDER_FRAME)) THEN
719	! AF=>CN%GIRDER_FRAME
720	FOUND=MY_TRUE
721	EXIT
722	ENDIF
723	CN=>CN%GIRDERS
724	k=k+1
725	IF(K>10000)THEN
726	WRITE(6,*) " TOO MANY IN GIRDER "
727	STOP 666
728	ENDIF
729	ENDDO
730	ENDIF
731
732	END SUBROUTINE FIND_AFFINE_GIRDER
733
734	SUBROUTINE FIND_FRAME_GIRDER(MAG,B,EXI,ADD) !
735	! ACTUALLY LOCATES THE FRAME
736	IMPLICIT NONE
737	TYPE(ELEMENT), POINTER :: MAG
738	REAL(DP), INTENT(INOUT) :: B(3),EXI(3,3)
739	LOGICAL(LP), OPTIONAL, INTENT(IN) :: ADD
740	LOGICAL(LP) ADDIN
741
742	ADDIN=.FALSE.
743
744	IF(PRESENT(ADD)) ADDIN=ADD
745
746	IF(.NOT.ADDIN) THEN
747	mag%GIRDER_FRAME%EXI=mag%GIRDER_FRAME%ENT ! ORIGINAL FRAME OF GIRDER
748	mag%GIRDER_FRAME%B=mag%GIRDER_FRAME%A ! ORIGINAL POSITION OF GIRDER
749	ENDIF
750	EXI=mag%GIRDER_FRAME%EXI
751	B=mag%GIRDER_FRAME%B
752
753	END SUBROUTINE FIND_FRAME_GIRDER
754
755	SUBROUTINE EXTRACT_GIRDER_FRAME(S2,A,ENT,FOUND) !
756	! USED IN PTC_GIRDER
757	IMPLICIT NONE
758	TYPE(element),TARGET,INTENT(INOUT):: S2
759	TYPE(AFFINE_FRAME),POINTER :: AF
760	TYPE(ELEMENT), POINTER :: C,CN
761	INTEGER K
762	LOGICAL(LP),INTENT(INOUT)::FOUND
763	REAL(DP),INTENT(INOUT):: ENT(3,3),A(3)
764
765	NULLIFY(AF)
766	NULLIFY(CN)
767
768
769	FOUND=MY_FALSE
770	K=0
771
772	IF(ASSOCIATED(S2%GIRDERS)) THEN
773	C=>S2
774	CN=>S2%GIRDERS
775
776	IF(ASSOCIATED(C%GIRDER_FRAME)) THEN
777	AF=>C%GIRDER_FRAME
778	CN=>C
779	FOUND=MY_TRUE
780	RETURN
781	ENDIF
782
783	DO WHILE(.NOT.ASSOCIATED(C,CN))
784	IF(ASSOCIATED(CN%GIRDER_FRAME)) THEN
785	AF=>CN%GIRDER_FRAME
786	FOUND=MY_TRUE
787	EXIT
788	ENDIF
789	CN=>CN%GIRDERS
790	k=k+1
791	IF(K>10000)THEN
792	WRITE(6,*) " TOO MANY IN GIRDER "
793	STOP 666
794	ENDIF
795	ENDDO
796	ENDIF
797
798	IF(FOUND) THEN
799	ENT=AF%ENT
800	A=AF%A
801	ENDIF
802	END SUBROUTINE EXTRACT_GIRDER_FRAME
803
804
805
806	SUBROUTINE MISALIGN_GIRDER(S2,S1,OMEGA,BASIS,ADD) !
807	! SIMILAR TO MISALIGN_SIAMESE
808	! COMMENT DIFFERENCES ONLY
809	IMPLICIT NONE
810	REAL(DP),INTENT(IN):: S1(6)
811	REAL(DP), OPTIONAL, INTENT(IN) :: OMEGA(3),BASIS(3,3)
812	TYPE(FIBRE),TARGET,INTENT(INOUT):: S2
813	TYPE(ELEMENT), POINTER :: C,CN,CAF
814	TYPE(fibre), POINTER :: P
815	integer k
816	REAL(DP) OMEGAT(3),BASIST(3,3),B(3),EXI(3,3),T_GLOBAL(3)
817	LOGICAL(LP), OPTIONAL, INTENT(IN) :: ADD
818	LOGICAL(LP) ADDIN
819	LOGICAL(LP) FOUND
820	! REAL(DP) D(3),ANG(3)
821	TYPE(MAGNET_FRAME), POINTER :: F
822
823	FOUND=.FALSE.
824	ADDIN=.FALSE.
825	CALL FIND_AFFINE_GIRDER(S2,CAF,FOUND)
826	IF(FOUND) CALL FIND_FRAME_GIRDER(CAF,B,EXI,ADD)
827
828	IF(PRESENT(ADD)) ADDIN=ADD
829
830	IF(PRESENT(OMEGA)) THEN
831	OMEGAT=OMEGA
832	ELSE
833	OMEGAT=S2%CHART%F%O
834	ENDIF
835
836	IF(PRESENT(BASIS)) THEN
837	BASIST=BASIS
838	ELSE
839	BASIST=S2%CHART%F%MID
840	ENDIF
841
842	IF((.NOT.PRESENT(OMEGA)).AND.(.NOT.PRESENT(BASIS))) THEN
843	IF(FOUND) THEN
844	OMEGAT=B
845	BASIST=EXI
846	ENDIF
847	ENDIF
848
849
850	CALL MISALIGN_FIBRE(S2,S1,OMEGAT,BASIST,ADD=ADDIN)
851	k=1
852
853	IF(ASSOCIATED(S2%MAG%GIRDERS)) THEN
854	C=>S2%MAG
855	CN=>S2%MAG%GIRDERS
856	DO WHILE(.NOT.ASSOCIATED(C,CN))
857	P=>CN%PARENT_FIBRE
858	CALL MISALIGN_FIBRE(P,S1,OMEGAT,BASIST,ADD=ADDIN)
859	CN=>CN%GIRDERS
860	k=k+1
861	ENDDO
862	ENDIF
863
864
865
866	IF(FOUND) THEN !!! THE ORIGINAL GIRDER FRAME IS STILL GIRDER_FRAME%ENT AND GIRDER_FRAME%A
867	! FINAL FRAME AFTER MISALIGNMENTS MUST BE COMPUTED
868	call alloc(f)
869	f%a=b
870	f%ent=exi
871	CALL ROTATE_FRAME(F,OMEGAT,S1(4:6),1,BASIS=BASIST)
872	CALL GEO_ROT(BASIST,S1(4:6),1)
873	CALL CHANGE_BASIS(S1(1:3),BASIST,T_GLOBAL,GLOBAL_FRAME)
874	F%A=F%A+T_GLOBAL
875	CAF%GIRDER_FRAME%EXI=F%ent
876	CAF%GIRDER_FRAME%B=F%A
877	call kill(f)
878	ENDIF
879
880	if(global_verbose) write(6,*) k, " magnet misaligned "
881	END SUBROUTINE MISALIGN_GIRDER
882
883
884
885	recursive SUBROUTINE MISALIGN_FIBRE(S2,S1,OMEGA,BASIS,ADD,preserve_girder)
886	! MISALIGNS FULL FIBRE; FILLS IN CHART AND MAGNET_CHART
887	! changed add=true add extra misalignments TO EXISTING ONES
888	! O AND MID BY DEFAUTL, OTHERWISE OMEGA AND BASIS
889	IMPLICIT NONE
890	REAL(DP),INTENT(IN):: S1(6)
891	REAL(DP), OPTIONAL, INTENT(IN) :: OMEGA(3),BASIS(3,3)
892	LOGICAL(LP), OPTIONAL, INTENT(IN) :: ADD,preserve_girder
893	TYPE(FIBRE),target,INTENT(INOUT):: S2
894	REAL(DP) ANGLE(3),T_GLOBAL(3),d(3),r(3)
895	TYPE(MAGNET_FRAME), POINTER :: F,F0
896	REAL(DP) D_IN(3),D_OUT(3),OMEGAT(3),BASIST(3,3)
897	INTEGER I
898	LOGICAL(LP) ADDIN,pres
899	LOGICAL(LP) FOUNDg
900	type(element), pointer :: caf
901	real(dp) a1(3),e1(3,3),a2(3),e2(3,3),dg1(3),ag1(3),mis(6)
902
903
904
905	ADDIN=.FALSE.
906	pres=.FALSE.
907	IF(PRESENT(ADD)) ADDIN=ADD
908	if(present(preserve_girder)) pres=preserve_girder
909
910	FOUNDg=.false.
911	if(pres.and.associated(s2%mag%girderS).and.(.not.addin)) then
912	CALL FIND_AFFINE_GIRDER(S2,CAF,FOUNDg)
913	if(foundg) then
914	a1=caf%girder_frame%a
915	e1=caf%girder_frame%ent
916	a2=caf%girder_frame%b
917	e2=caf%girder_frame%exi
918	! call INVERSE_FIND_PATCH(a1,e1,dg1,ag1,a2,e2)
919	call FIND_PATCH(a1,e1,a2,e2,dg1,ag1)
920	mis=0.0_dp
921	call MISALIGN_fibre(S2,MIS)
922	MIS(1:3)=DG1
923	MIS(4:6)=AG1
924
925	call MISALIGN_fibre(S2,MIS,OMEGA=a1,BASIS=e1)
926	call MISALIGN_fibre(S2,S1,OMEGA,BASIS,ADD=my_true,preserve_girder=my_false)
927	return
928	endif
929	endif
930
931
932
933	IF(ASSOCIATED(S2%CHART)) THEN
934	! IF(.NOT.ASSOCIATED(S2%MAG%D) ) ALLOCATE(S2%MAG%D(3))
935	! IF(.NOT.ASSOCIATED(S2%MAG%R) ) ALLOCATE(S2%MAG%R(3))
936	! IF(.NOT.ASSOCIATED(S2%MAGP%D)) ALLOCATE(S2%MAGP%D(3))
937	! IF(.NOT.ASSOCIATED(S2%MAGP%R)) ALLOCATE(S2%MAGP%R(3))
938	! DO I=1,3
939	! S2%MAG%D(I)=S1(I); S2%MAGP%D(I)=S1(I);
940	! S2%MAG%R(I)=S1(3+I); S2%MAGP%R(I)=S1(3+I);
941	! ENDDO
942	DO I=1,3
943	D(I)=S1(I); D(I)=S1(I);
944	R(I)=S1(3+I); R(I)=S1(3+I);
945	ENDDO
946	S2%CHART%D_IN=0.0_dp;S2%CHART%D_OUT=0.0_dp;
947	S2%CHART%ANG_IN=0.0_dp;S2%CHART%ANG_OUT=0.0_dp;
948	S2%MAG%MIS=.TRUE.
949	S2%MAGP%MIS=.TRUE.
950
951	! ADD CODE HERE
952	CALL ALLOC(F)
953	CALL ALLOC(F0)
954	! MOVE THE ORIGINAL INTERNAL CHART F
955	IF(ADDIN) THEN
956	F=S2%mag%p%f
957	CALL SURVEY_NO_PATCH(S2,MAGNETFRAME=F0)
958	ELSE
959	CALL SURVEY_NO_PATCH(S2,MAGNETFRAME=F0)
960	F=F0
961	ENDIF
962
963	ANGLE=r !S2%MAG%R
964	IF(PRESENT(BASIS)) THEN
965	BASIST=BASIS
966	ELSE
967	BASIST=F%MID
968	ENDIF
969	IF(PRESENT(OMEGA)) THEN
970	OMEGAT=OMEGA
971	ELSE
972	OMEGAT=F%O
973	ENDIF
974
975	CALL ROTATE_FRAME(F,OMEGAT,ANGLE,1,BASIS=BASIST)
976
977	IF(PRESENT(BASIS)) THEN ! MUST ROTATE THAT FRAME AS WELL FOR CONSISTENCY IN DEFINITION WHAT A MISALIGNMENT IS IN PTC
978	CALL GEO_ROT(BASIST,ANGLE,1)
979	ELSE
980	BASIST=F%MID ! ALREADY ROTATED
981	ENDIF
982
983	! CALL CHANGE_BASIS(S2%MAG%D,BASIST,T_GLOBAL,GLOBAL_FRAME)
984	CALL CHANGE_BASIS(D,BASIST,T_GLOBAL,GLOBAL_FRAME)
985
986
987	F%A=F%A+T_GLOBAL
988	F%O=F%O+T_GLOBAL
989	F%B=F%B+T_GLOBAL
990
991
992
993	CALL COMPUTE_ENTRANCE_ANGLE(F0%ENT,F%ENT,S2%CHART%ANG_IN)
994	CALL COMPUTE_ENTRANCE_ANGLE(F%EXI,F0%EXI,S2%CHART%ANG_OUT)
995
996	D_IN=F%A-F0%A
997	D_OUT=F0%B-F%B
998
999	! WRITE(6,*) " IN GLOBAL BASIS D_IN AND D_OUT"
1000
1001	! WRITE(6,*) D_IN
1002	! WRITE(6,*) D_OUT
1003
1004	CALL CHANGE_BASIS(D_IN,GLOBAL_FRAME,S2%CHART%D_IN,F%ENT)
1005	CALL CHANGE_BASIS(D_OUT,GLOBAL_FRAME,S2%CHART%D_OUT,F0%EXI)
1006
1007	! WRITE(6,*) " IN LOCAL BASIS D_IN AND D_OUT AS WELL AS ANGLES"
1008	! WRITE(6,) " **************************************"
1009	! WRITE(6,*) S2%CHART%ANG_IN
1010	! WRITE(6,*) S2%CHART%ANG_OUT
1011	! WRITE(6,*) S2%CHART%D_IN
1012	! WRITE(6,*) S2%CHART%D_OUT
1013
1014	! WRITE(6,) " **************************************"
1015
1016	CALL KILL(F)
1017	CALL KILL(F0)
1018	IF(ASSOCIATED(F)) deallocate(f)
1019	IF(ASSOCIATED(F0)) deallocate(f0)
1020
1021	CALL SURVEY_NO_PATCH(S2)
1022
1023	IF(ASSOCIATED(S2%T1)) THEN
1024	IF(ASSOCIATED(S2%T1%A)) THEN
1025	CALL fill_survey_ONE_FIBRE(S2)
1026	ENDIF
1027	ENDIF
1028
1029	ELSE
1030	W_P=0
1031	W_P%NC=1
1032	W_P%FC='((1X,A72))'
1033	WRITE(W_P%C(1),'(1X,A39,1X,A16)') " CANNOT MISALIGN THIS FIBRE: NO CHARTS ", S2%MAG%NAME
1034	! call !write_e(100)
1035	ENDIF
1036
1037
1038	END SUBROUTINE MISALIGN_FIBRE
1039
1040	SUBROUTINE MAD_MISALIGN_FIBRE(S2,S1) ! MISALIGNS FULL FIBRE; FILLS IN CHART AND MAGNET_CHART
1041	IMPLICIT NONE
1042	REAL(DP),INTENT(IN):: S1(6)
1043	TYPE(FIBRE),target,INTENT(INOUT):: S2
1044	REAL(DP) ENT(3,3),ENT1(3,3),ENT2(3,3),T(3),MAD_ANGLE(3),T_GLOBAL(3),ANGLE(3),MIS(6)
1045	ent=S2%CHART%F%ent
1046	T(1)=S1(1);T(2)=S1(2);T(3)=S1(3);
1047	MAD_ANGLE(1)=-S1(4)
1048	MAD_ANGLE(2)=-S1(5)
1049	MAD_ANGLE(3)=S1(6)
1050
1051	CALL CHANGE_BASIS(T,ENT,T_GLOBAL,GLOBAL_FRAME)
1052	ANGLE=0.0_dp; ANGLE(3)=MAD_ANGLE(3)
1053	ent1=ent
1054	ent2=ent
1055	CALL GEO_ROT(ENT1,ENT,ANGLE,ENT2)
1056	ANGLE=0.0_dp; ANGLE(1)=MAD_ANGLE(1)
1057	ent1=ent
1058	ent2=ent
1059	CALL GEO_ROT(ENT1,ENT,ANGLE,ENT2)
1060	ANGLE=0.0_dp; ANGLE(2)=MAD_ANGLE(2)
1061	ent1=ent
1062	ent2=ent
1063	CALL GEO_ROT(ENT1,ENT,ANGLE,ENT2)
1064
1065	CALL CHANGE_BASIS(T_GLOBAL,GLOBAL_FRAME,T,ENT)
1066	CALL COMPUTE_ENTRANCE_ANGLE(S2%CHART%F%ent,ENT,ANGLE)
1067	MIS(1:3)=T
1068	MIS(4:6)=ANGLE
1069
1070	ENT=S2%CHART%F%ent
1071	T=S2%CHART%F%A
1072	call MISALIGN_SIAMESE(S2,MIS,T,ENT)
1073	! call MISALIGN_FIBRE(S2,MIS,S2%CHART%F%A,S2%CHART%F%ent)
1074
1075	END SUBROUTINE MAD_MISALIGN_FIBRE
1076
1077	! NEW ROUTINES TO CHANGE LAYOUT using only magnets!!!!
1078
1079	SUBROUTINE TRANSLATE_girder(S2,D,ORDER,BASIS,PATCH,PREC) ! TRANSLATES A fibre
1080	IMPLICIT NONE
1081	TYPE (fibre),TARGET,INTENT(INOUT):: S2
1082	TYPE (element),pointer :: c,cn,caf
1083	REAL(DP),INTENT(IN):: D(3)
1084	REAL(DP), OPTIONAL :: BASIS(3,3)
1085	INTEGER, OPTIONAL, INTENT(IN) :: ORDER
1086	LOGICAL(LP),OPTIONAL :: PATCH
1087	REAL(DP),OPTIONAL :: PREC
1088	LOGICAL(LP) FOUND
1089	REAL(DP) exi(3,3), BASISt(3,3),b(3),t_global(3)
1090	integer k
1091
1092	FOUND=.FALSE.
1093	CALL FIND_AFFINE_girder(S2,CAF,FOUND)
1094	IF(FOUND) CALL FIND_FRAME_girder(CAF,B,EXI,ADD=my_false)
1095
1096
1097	IF(PRESENT(BASIS)) THEN
1098	BASIST=BASIS
1099	ELSE
1100	if(found) then
1101	BASIST=exi
1102	else
1103	BASIST=global_frame
1104	endif
1105	ENDIF
1106
1107	c=>s2%mag
1108	! CALL TRANSLATE_magnet(c,D,ORDER,BASIST,PATCH=.false.)
1109	CALL TRANSLATE_magnet(c,D,ORDER,BASIST,PATCH,PREC)
1110	k=1
1111
1112	IF(ASSOCIATED(S2%MAG%girderS)) THEN
1113	C=>S2%MAG
1114	CN=>S2%MAG%girderS
1115	DO WHILE(.NOT.ASSOCIATED(C,CN))
1116	! CALL TRANSLATE_magnet(cn,D,ORDER,BASIST,PATCH=.false.)
1117	CALL TRANSLATE_magnet(cn,D,ORDER,BASIST,PATCH,PREC)
1118	CN=>CN%girderS
1119	k=k+1
1120	ENDDO
1121	ENDIF
1122
1123	if(global_verbose) write(6,*) k, " magnets translated in girder "
1124
1125	! c=>s2%mag
1126	! call patch_magnet(c,PATCH,PREC)
1127	! k=1
1128	!
1129	! IF(ASSOCIATED(S2%MAG%girder)) THEN
1130	! C=>S2%MAG
1131	! CN=>S2%MAG%girder
1132	! DO WHILE(.NOT.ASSOCIATED(C,CN))
1133	! call patch_magnet(cn,PATCH,PREC)
1134	!! CN=>CN%girder
1135	! k=k+1
1136	! ENDDO
1137	! ENDIF
1138	!if(global_verbose) write(6,*) k, " magnets patched in translated in girder "
1139
1140
1141	IF(FOUND) THEN
1142	CALL CHANGE_BASIS(D,BASIST,T_GLOBAL,GLOBAL_FRAME)
1143	CAF%GIRDER_FRAME%a=CAF%GIRDER_FRAME%a+T_GLOBAL
1144	CAF%GIRDER_FRAME%B=CAF%GIRDER_FRAME%b+T_GLOBAL
1145	ENDIF
1146	! ETIENNE DOES NOT UNDERSTAND THE CODE BELOW
1147
1148	! CALL FIND_AFFINE_girder(S2,CN,FOUND)
1149
1150	! IF(FOUND) CALL FIND_FRAME_girder(CN,B,EXI,ADD=my_false)
1151
1152	END SUBROUTINE TRANSLATE_girder
1153
1154
1155	SUBROUTINE TRANSLATE_siamese(S2,D,ORDER,BASIS,PATCH,PREC) ! TRANSLATES A SIAMESE
1156	IMPLICIT NONE
1157	TYPE (fibre),TARGET,INTENT(INOUT):: S2
1158	TYPE (element),pointer :: c,cn
1159	REAL(DP),INTENT(IN):: D(3)
1160	REAL(DP), OPTIONAL :: BASIS(3,3)
1161	INTEGER, OPTIONAL, INTENT(IN) :: ORDER
1162	LOGICAL(LP),OPTIONAL :: PATCH
1163	REAL(DP),OPTIONAL :: PREC
1164	LOGICAL(LP) FOUND
1165	REAL(DP) exi(3,3), BASISt(3,3),b(3)
1166	integer k
1167
1168	FOUND=.FALSE.
1169	CALL FIND_AFFINE_SIAMESE(S2,CN,FOUND)
1170	IF(FOUND) CALL FIND_FRAME_SIAMESE(CN,B,EXI,ADD=my_false)
1171
1172
1173	IF(PRESENT(BASIS)) THEN
1174	BASIST=BASIS
1175	ELSE
1176	if(found) then
1177	BASIST=exi
1178	else
1179	BASIST=global_frame
1180	endif
1181	ENDIF
1182
1183	c=>s2%mag
1184	CALL TRANSLATE_magnet(c,D,ORDER,BASIST,PATCH,PREC)
1185	! CALL TRANSLATE_magnet(c,D,ORDER,BASIST,PATCH=.false.)
1186	k=1
1187
1188	IF(ASSOCIATED(S2%MAG%SIAMESE)) THEN
1189	C=>S2%MAG
1190	CN=>S2%MAG%SIAMESE
1191	DO WHILE(.NOT.ASSOCIATED(C,CN))
1192	CALL TRANSLATE_magnet(cn,D,ORDER,BASIST,PATCH,PREC)
1193	! CALL TRANSLATE_magnet(cn,D,ORDER,BASIST,PATCH=.false.)
1194	CN=>CN%SIAMESE
1195	k=k+1
1196	ENDDO
1197	ENDIF
1198
1199	!if(global_verbose) write(6,*) k, " magnet translated "
1200
1201	! c=>s2%mag
1202	! call patch_magnet(c,PATCH,PREC)
1203	! k=1
1204	!
1205	! IF(ASSOCIATED(S2%MAG%SIAMESE)) THEN
1206	! C=>S2%MAG
1207	! CN=>S2%MAG%SIAMESE
1208	! DO WHILE(.NOT.ASSOCIATED(C,CN))
1209	! call patch_magnet(cn,PATCH,PREC)
1210	! CN=>CN%SIAMESE
1211	! k=k+1
1212	! ENDDO
1213	! ENDIF
1214	! if(global_verbose) write(6,*) k, " magnets patched in translated in siamese "
1215
1216	END SUBROUTINE TRANSLATE_siamese
1217
1218
1219	SUBROUTINE TRANSLATE_magnet(R,D,ORDER,BASIS,PATCH,PREC) ! TRANSLATES A fibre
1220	IMPLICIT NONE
1221	TYPE (element),TARGET,INTENT(INOUT):: R
1222	REAL(DP),INTENT(IN):: D(3)
1223	REAL(DP), OPTIONAL :: BASIS(3,3)
1224	TYPE(FIBRE), POINTER::P
1225	INTEGER, OPTIONAL, INTENT(IN) :: ORDER
1226	LOGICAL(LP),OPTIONAL :: PATCH
1227	REAL(DP),OPTIONAL :: PREC
1228	LOGICAL(LP) PAT
1229	REAL(DP) PREC0
1230	type(fibre_appearance), pointer :: dk
1231	integer k
1232
1233	PREC0=PUNY
1234	PAT=MY_FALSE
1235
1236	IF(PRESENT(PATCH)) PAT=PATCH
1237	IF(PRESENT(PREC)) PREC0=PREC
1238
1239	p=> r%parent_fibre
1240
1241	call TRANSLATE(p,D,ORDER,BASIS)
1242
1243	if(pat) then
1244	k=0
1245	if(associated(R%doko)) then !!! PATCH TO DOKO'S IF CREATED USING DNA I.E. APPEND_POINT
1246	dk=>r%doko
1247	do while(associated(dk))
1248	p=> dk%parent_fibre
1249	call FIND_PATCH(p,p%next,NEXT=my_false,ENERGY_PATCH=my_true,prec=PREC0)
1250	call FIND_PATCH(p%previous,p,NEXT=my_true,ENERGY_PATCH=my_true,prec=PREC0)
1251	k=k+1
1252	dk=>dk%next
1253	enddo
1254	if(global_verbose) write(6,*) "in translate_magnet patched ",k,"times using doko"
1255	else !!! FOR COMPATIBILITY MODE FIBRE=MAGNET
1256	call FIND_PATCH(p,p%next,NEXT=my_false,ENERGY_PATCH=my_true,prec=PREC0)
1257	call FIND_PATCH(p%previous,p,NEXT=my_true,ENERGY_PATCH=my_true,prec=PREC0)
1258	endif
1259	endif
1260
1261	END SUBROUTINE TRANSLATE_magnet
1262
1263	SUBROUTINE rotate_magnet(R,Ang,OMEGA,ORDER,BASIS,PATCH,PREC) ! TRANSLATES A fibre
1264	IMPLICIT NONE
1265	TYPE (element),TARGET,INTENT(INOUT):: R
1266	REAL(DP),INTENT(IN):: ang(3)
1267	REAL(DP), OPTIONAL :: BASIS(3,3)
1268	TYPE(FIBRE), POINTER::P
1269	INTEGER, OPTIONAL, INTENT(IN) :: ORDER
1270	LOGICAL(LP),OPTIONAL :: PATCH
1271	REAL(DP),OPTIONAL :: PREC
1272	LOGICAL(LP) PAT
1273	REAL(DP) PREC0,omega(3)
1274	type(fibre_appearance), pointer :: dk
1275	integer k
1276
1277	PREC0=PUNY
1278	PAT=MY_FALSE
1279
1280	IF(PRESENT(PATCH)) PAT=PATCH
1281	IF(PRESENT(PREC)) PREC0=PREC
1282
1283	p=> r%parent_fibre
1284
1285	call rotate(p,OMEGA,Ang,ORDER,BASIS)
1286
1287	if(pat) then
1288	k=0
1289	if(associated(R%doko)) then
1290	dk=>r%doko
1291	do while(associated(dk)) !!! PATCH TO DOKO'S IF CREATED USING DNA I.E. APPEND_POINT
1292	p=> dk%parent_fibre
1293	call FIND_PATCH(p,p%next,NEXT=my_false,ENERGY_PATCH=my_true,prec=PREC0)
1294	call FIND_PATCH(p%previous,p,NEXT=my_true,ENERGY_PATCH=my_true,prec=PREC0)
1295	k=k+1
1296	dk=>dk%next
1297	enddo
1298	if(global_verbose) write(6,*) "in rotate_magnet patched ",k,"times using doko"
1299	else !!! FOR COMPATIBILITY MODE FIBRE=MAGNET
1300	call FIND_PATCH(p,p%next,NEXT=my_false,ENERGY_PATCH=my_true,prec=PREC0)
1301	call FIND_PATCH(p%previous,p,NEXT=my_true,ENERGY_PATCH=my_true,prec=PREC0)
1302	endif
1303	endif
1304
1305	END SUBROUTINE rotate_magnet
1306
1307	! SUBROUTINE patch_magnet(R,PATCH,PREC) ! TRANSLATES A fibre
1308	! IMPLICIT NONE
1309	! TYPE (element),TARGET,INTENT(INOUT):: R
1310	! TYPE(FIBRE), POINTER::P
1311	! LOGICAL(LP),OPTIONAL :: PATCH
1312	! REAL(DP),OPTIONAL :: PREC
1313	! LOGICAL(LP) PAT
1314	! REAL(DP) PREC0
1315	! type(fibre_appearance), pointer :: dk
1316	! integer k
1317	!
1318	! PREC0=PUNY
1319	! PAT=MY_FALSE
1320	!
1321	! IF(PRESENT(PATCH)) PAT=PATCH
1322	! IF(PRESENT(PREC)) PREC0=PREC
1323	!
1324	! p=> r%parent_fibre
1325	!
1326	!
1327	! if(pat) then
1328	! k=0
1329	! if(associated(R%doko)) then
1330	! dk=>r%doko
1331	! do while(associated(dk))
1332	! p=> dk%parent_fibre
1333	! call FIND_PATCH(p,p%next,NEXT=my_false,ENERGY_PATCH=my_true,prec=PREC0)
1334	! call FIND_PATCH(p%previous,p,NEXT=my_true,ENERGY_PATCH=my_true,prec=PREC0)
1335	! k=k+1
1336	! dk=>dk%next
1337	!
1338	! enddo
1339	! if(global_verbose) write(6,*) " patched ",k,"times using doko"
1340	! else
1341	! call FIND_PATCH(p,p%next,NEXT=my_false,ENERGY_PATCH=my_true,prec=PREC0)
1342	! call FIND_PATCH(p%previous,p,NEXT=my_true,ENERGY_PATCH=my_true,prec=PREC0)
1343	! endif
1344	! endif
1345	!
1346	! END SUBROUTINE patch_magnet
1347
1348	SUBROUTINE rotate_siamese(S2,Ang,OMEGA,ORDER,BASIS,PATCH,PREC) !
1349	IMPLICIT NONE
1350	TYPE (fibre),TARGET,INTENT(INOUT):: s2
1351	REAL(DP),INTENT(IN):: ang(3)
1352	TYPE (element),pointer :: c,cn
1353	REAL(DP), OPTIONAL :: BASIS(3,3),omega(3)
1354	INTEGER, OPTIONAL, INTENT(IN) :: ORDER
1355	LOGICAL(LP),OPTIONAL :: PATCH
1356	REAL(DP),OPTIONAL :: PREC
1357	LOGICAL(LP) FOUND
1358	REAL(DP) b(3),exi(3,3), BASISt(3,3),omegat(3)
1359	integer k
1360
1361	FOUND=.FALSE.
1362	CALL FIND_AFFINE_SIAMESE(S2,CN,FOUND)
1363	IF(FOUND) CALL FIND_FRAME_SIAMESE(CN,B,EXI,ADD=my_false)
1364
1365	! write(6,*)found, b
1366
1367	IF(PRESENT(BASIS)) THEN
1368	BASIST=BASIS
1369	ELSE
1370	if(found) then
1371	BASIST=exi
1372	else
1373	BASIST=global_frame
1374	endif
1375	ENDIF
1376
1377	IF(PRESENT(OMEGA)) THEN
1378	OMEGAT=OMEGA
1379	ELSE
1380	if(found) then
1381	OMEGAT=b
1382	else
1383	OMEGAT=global_origin
1384	endif
1385	ENDIF
1386
1387
1388
1389	c=>s2%mag
1390	CALL rotate_magnet(c,Ang,OMEGAt,ORDER,BASISt,PATCH,PREC)
1391	! CALL rotate_magnet(c,Ang,OMEGAt,ORDER,BASISt,PATCH=.false.)
1392	k=1
1393
1394	IF(ASSOCIATED(S2%MAG%SIAMESE)) THEN
1395	C=>S2%MAG
1396	CN=>S2%MAG%SIAMESE
1397	DO WHILE(.NOT.ASSOCIATED(C,CN))
1398	! CALL rotate_magnet(cn,Ang,OMEGAt,ORDER,BASISt,PATCH=.false.)
1399	CALL rotate_magnet(cn,Ang,OMEGAt,ORDER,BASISt,PATCH,PREC)
1400	CN=>CN%SIAMESE
1401	k=k+1
1402	ENDDO
1403	ENDIF
1404
1405	! if(global_verbose) write(6,*) k, " magnets rotated in siamese"
1406	! c=>s2%mag
1407	! call patch_magnet(c,PATCH,PREC)
1408	! k=1
1409	!
1410	! IF(ASSOCIATED(S2%MAG%SIAMESE)) THEN
1411	! C=>S2%MAG
1412	! CN=>S2%MAG%SIAMESE
1413	! DO WHILE(.NOT.ASSOCIATED(C,CN))
1414	! call patch_magnet(cn,PATCH,PREC)
1415	! CN=>CN%SIAMESE
1416	! k=k+1
1417	! ENDDO
1418	! ENDIF
1419	! if(global_verbose) write(6,*) k, " magnets patched in rotated in siamese "
1420
1421	END SUBROUTINE rotate_siamese
1422
1423	SUBROUTINE rotate_girder(S2,Ang,OMEGA,ORDER,BASIS,PATCH,PREC) !
1424	IMPLICIT NONE
1425	TYPE (fibre),TARGET,INTENT(INOUT):: s2
1426	REAL(DP),INTENT(IN):: ang(3)
1427	TYPE (element),pointer :: c,cn,caf
1428	REAL(DP), OPTIONAL :: BASIS(3,3),omega(3)
1429	INTEGER, OPTIONAL, INTENT(IN) :: ORDER
1430	LOGICAL(LP),OPTIONAL :: PATCH
1431	REAL(DP),OPTIONAL :: PREC
1432	LOGICAL(LP) FOUND
1433	REAL(DP) b(3),exi(3,3), BASISt(3,3),omegat(3)
1434	TYPE(MAGNET_FRAME), POINTER :: F
1435	integer k
1436
1437	FOUND=.FALSE.
1438	CALL FIND_AFFINE_girder(S2,CAF,FOUND)
1439	IF(FOUND) CALL FIND_FRAME_girder(CAF,B,EXI,ADD=my_false)
1440
1441
1442	IF(PRESENT(BASIS)) THEN
1443	BASIST=BASIS
1444	ELSE
1445	if(found) then
1446	BASIST=exi
1447	else
1448	BASIST=global_frame
1449	endif
1450	ENDIF
1451
1452	IF(PRESENT(OMEGA)) THEN
1453	OMEGAT=OMEGA
1454	ELSE
1455	if(found) then
1456	OMEGAT=b
1457	else
1458	OMEGAT=global_origin
1459	endif
1460	ENDIF
1461
1462
1463
1464	c=>s2%mag
1465	! CALL rotate_magnet(c,Ang,OMEGAt,ORDER,BASISt,PATCH=.false.)
1466	CALL rotate_magnet(c,Ang,OMEGAt,ORDER,BASISt,PATCH,PREC)
1467	k=1
1468
1469	IF(ASSOCIATED(S2%MAG%girderS)) THEN
1470	C=>S2%MAG
1471	CN=>S2%MAG%girderS
1472	DO WHILE(.NOT.ASSOCIATED(C,CN))
1473	! CALL rotate_magnet(cn,Ang,OMEGAt,ORDER,BASISt,PATCH=.false.)
1474	CALL rotate_magnet(cn,Ang,OMEGAt,ORDER,BASISt,PATCH,PREC)
1475	CN=>CN%girderS
1476	k=k+1
1477	ENDDO
1478	ENDIF
1479	if(global_verbose) write(6,*) k, " magnets rotated in girder "
1480
1481
1482	! c=>s2%mag
1483	! call patch_magnet(c,PATCH,PREC)
1484	! k=1
1485
1486	! IF(ASSOCIATED(S2%MAG%girder)) THEN
1487	! C=>S2%MAG
1488	! CN=>S2%MAG%girder
1489	! DO WHILE(.NOT.ASSOCIATED(C,CN))
1490	! call patch_magnet(cn,PATCH,PREC)
1491	! CN=>CN%girder
1492	! k=k+1
1493	! ENDDO
1494	! ENDIF
1495	!if(global_verbose) write(6,*) k, " magnets patched in rotated girder "
1496
1497	!!! SAME GYMNASTICS AS IN TRANSLATE GIRDER
1498	IF(FOUND) THEN
1499	call alloc(f)
1500	f%a=CAF%GIRDER_FRAME%a
1501	f%ent=CAF%GIRDER_FRAME%ent
1502	f%b=CAF%GIRDER_FRAME%B
1503	f%exi=CAF%GIRDER_FRAME%exi
1504	CALL ROTATE_FRAME(F,OMEGAT,ang,ORDER,BASIS=BASIST)
1505	CAF%GIRDER_FRAME%ENT=F%ENT
1506	CAF%GIRDER_FRAME%A=F%A
1507	CAF%GIRDER_FRAME%EXI=F%EXI
1508	CAF%GIRDER_FRAME%B=F%B
1509	call kill(f)
1510	ENDIF
1511
1512
1513
1514
1515	END SUBROUTINE rotate_girder
1516
1517
1518
1519	! NEW ROUTINES TO CHANGE LAYOUT
1520
1521	SUBROUTINE TRANSLATE_layout(R,D,I1,I2,ORDER,BASIS) ! TRANSLATES A LAYOUT
1522	IMPLICIT NONE
1523	TYPE (LAYOUT),INTENT(INOUT):: R
1524	REAL(DP),INTENT(IN):: D(3)
1525	REAL(DP), OPTIONAL :: BASIS(3,3)
1526	TYPE(FIBRE), POINTER::P
1527	INTEGER I,I11,I22
1528	INTEGER, OPTIONAL, INTENT(IN) :: ORDER,I1,I2
1529	! THIS ROUTINE TRANSLATE THE ENTIRE LINE BY A(3) IN STANDARD ORDER USING THE
1530	! GLOBAL FRAME TO DEFINE D
1531
1532	P=>R%START
1533
1534	I11=1
1535	I22=R%N
1536	IF(PRESENT(I1)) I11=I1
1537	IF(PRESENT(I2)) I22=I2
1538	DO I=1,I11-1
1539	P=>P%NEXT
1540	ENDDO
1541
1542
1543	DO I=1,I22-I11+1
1544	CALL TRANSLATE_Fibre(P,D,ORDER,BASIS,dogirder=my_true) ! DOGIRDER IS SET TO TRUE
1545	P=>P%NEXT
1546	ENDDO
1547
1548
1549	END SUBROUTINE TRANSLATE_layout
1550
1551	SUBROUTINE TRANSLATE_Fibre(R,D,ORDER,BASIS,dogirder) ! TRANSLATES A fibre
1552	! THIS ROUTINE TRANSLATE THE ENTIRE LINE BY A(3) IN STANDARD ORDER USING THE
1553	! GLOBAL FRAME TO DEFINE D
1554	IMPLICIT NONE
1555	TYPE (FIBRE),TARGET,INTENT(INOUT):: R
1556	REAL(DP),INTENT(IN):: D(3)
1557	REAL(DP), OPTIONAL :: BASIS(3,3)
1558	TYPE(FIBRE), POINTER::P,pp
1559	INTEGER IORDER
1560	INTEGER, OPTIONAL, INTENT(IN) :: ORDER
1561	TYPE(INTEGRATION_NODE), POINTER :: T
1562	TYPE(element), POINTER::caf
1563	logical(lp), OPTIONAL, INTENT(IN) :: dogirder
1564	REAL(DP) DD(3)
1565	type(fibre_appearance), pointer :: dk
1566
1567	logical(lp) dog
1568	dog=.false.
1569	if(present(dogirder)) dog=dogirder
1570
1571	P=>R
1572	Pp=>R
1573
1574	IORDER=1
1575	DD=D
1576	IF(PRESENT(ORDER)) IORDER=ORDER
1577	IF(PRESENT(BASIS)) THEN
1578	CALL CHANGE_BASIS(D,BASIS,DD,GLOBAL_FRAME)
1579	ENDIF
1580
1581
1582
1583	! IF(.NOT.ASSOCIATED(P%PARENT_CHART)) THEN ! ONLY TRANSLATES ORIGINAL OTHERWISE
1584	! THEY WILL TRANSLATE MORE THAN ONCE
1585
1586	IF(ASSOCIATED(P%CHART)) THEN
1587	IF(ASSOCIATED(P%CHART%F)) THEN
1588	CALL TRANSLATE_FRAME(P%CHART%F,D,ORDER,BASIS)
1589
1590	IF(ASSOCIATED(P%MAG%P%F)) THEN
1591	CALL TRANSLATE_FRAME(P%MAG%P%F,D,ORDER,BASIS)
1592	P%MAGP%P%F=P%MAG%P%F
1593	ENDIF
1594	ENDIF
1595	ENDIF
1596
1597	! ENDIF
1598
1599	if(associated(R%mag%doko).and.associated(p,r%mag%parent_fibre)) then
1600	dk=>R%mag%doko
1601	do while(associated(dk)) !!! PATCH TO DOKO'S IF CREATED USING DNA I.E. APPEND_POINT
1602	pP=> dk%parent_fibre
1603	IF(ASSOCIATED(PP%T1)) THEN
1604	IF(ASSOCIATED(PP%T1%A)) THEN
1605	T=>PP%T1
1606	DO WHILE(.NOT.ASSOCIATED(PP%T2,T))
1607	CALL GEO_TRA(T%A,GLOBAL_FRAME,DD,IORDER) ! A= A +I D*ENT
1608	CALL GEO_TRA(T%B,GLOBAL_FRAME,DD,IORDER) ! A= A +I D*ENT
1609	T=>T%NEXT
1610	ENDDO
1611	CALL GEO_TRA(T%A,GLOBAL_FRAME,DD,IORDER) ! A= A +I D*ENT
1612	CALL GEO_TRA(T%B,GLOBAL_FRAME,DD,IORDER) ! A= A +I D*ENT
1613	ENDIF
1614	ENDIF
1615
1616	dk=>dk%next
1617	enddo
1618	endif
1619	IF(ASSOCIATED(R%T1)) THEN
1620	IF(ASSOCIATED(R%T1%A)) THEN
1621	T=>P%T1
1622	DO WHILE(.NOT.ASSOCIATED(R%T2,T))
1623	CALL GEO_TRA(T%A,GLOBAL_FRAME,DD,IORDER) ! A= A +I D*ENT
1624	CALL GEO_TRA(T%B,GLOBAL_FRAME,DD,IORDER) ! A= A +I D*ENT
1625	T=>T%NEXT
1626	ENDDO
1627	CALL GEO_TRA(T%A,GLOBAL_FRAME,DD,IORDER) ! A= A +I D*ENT
1628	CALL GEO_TRA(T%B,GLOBAL_FRAME,DD,IORDER) ! A= A +I D*ENT
1629	ENDIF
1630	ENDIF
1631
1632	if(dog) then ! IF DOGIRDER IS SET TO TRUE
1633	if(associated(r%mag%GIRDER_FRAME)) then
1634	caf=>r%mag
1635	CALL GEO_TRA(CAF%GIRDER_FRAME%a,GLOBAL_FRAME,DD,IORDER) ! A= A +I D*ENT
1636	CALL GEO_TRA(CAF%GIRDER_FRAME%b,GLOBAL_FRAME,DD,IORDER) ! A= A +I D*ENT
1637	endif
1638	endif
1639	END SUBROUTINE TRANSLATE_Fibre
1640
1641
1642
1643	SUBROUTINE ROTATE_LAYOUT(R,OMEGA,Ang,I1,I2,ORDER,BASIS) ! ROTATES A LAYOUT AROUND OMEGA BY A(3) IN STANDARD PTC ORDER
1644	! INVERSE => ORDER=-1 USING GLOBAL FRAME
1645	IMPLICIT NONE
1646	TYPE (LAYOUT),INTENT(INOUT):: R
1647	REAL(DP),INTENT(IN):: OMEGA(3),Ang(3)
1648	TYPE(FIBRE), POINTER::P
1649	REAL(DP) OMEGAT(3)
1650	INTEGER I,IORDER,I11,I22
1651	INTEGER, OPTIONAL :: ORDER,I1,I2
1652	REAL(DP), OPTIONAL, INTENT(IN):: BASIS(3,3)
1653	real(dp) basist(3,3)
1654	! THIS ROUTINE ROTATES THE ENTIRE LINE BY A(3) IN STANDARD ORDER USING THE
1655	! GLOBAL FRAME TO DEFINE THE ANGLES A(3) AND THE POINT OMEGA AROUND WHICH THE
1656	! ROTATION HAPPENS
1657	! OMEGA DEFINED IN THAT BASIS
1658	! ANGLE AS WELL
1659	OMEGAT=OMEGA
1660	P=>R%START
1661	IORDER=1
1662	I11=1
1663	I22=R%N
1664	IF(PRESENT(ORDER)) IORDER=ORDER
1665	IF(PRESENT(I1)) I11=I1
1666	IF(PRESENT(I2)) I22=I2
1667
1668	BASIST=GLOBAL_FRAME ! NECESSARY SINCE BASIS CAN CHANGE DURING THE CALCULATION ASSUMING A POINTER IS PASSED
1669	IF(PRESENT(BASIS)) BASIST=BASIS
1670
1671
1672	DO I=1,I11-1
1673	P=>P%NEXT
1674	ENDDO
1675
1676
1677	DO I=1,I22-I11+1
1678	CALL ROTATE_FIBRE(P,OMEGA,Ang,ORDER,BASIST,dogirder=my_true) ! IF DOGIRDER IS SET TO TRUE, DOES GIRDER
1679	P=>P%NEXT
1680	ENDDO
1681
1682	END SUBROUTINE ROTATE_LAYOUT
1683
1684	SUBROUTINE ROTATE_FIBRE(R,OMEGA,Ang,ORDER,BASIS,dogirder) ! ROTATES A FIBRE AROUND OMEGA BY A(3) IN STANDARD PTC ORDER
1685	! INVERSE => ORDER=-1 USING GLOBAL FRAME IF BASIS NOT SPECIFIED
1686	IMPLICIT NONE
1687	TYPE (FIBRE),TARGET,INTENT(INOUT):: R
1688	REAL(DP),INTENT(IN):: OMEGA(3),Ang(3)
1689	TYPE(FIBRE), POINTER::P,pp
1690	REAL(DP) OMEGAT(3)
1691	INTEGER IORDER
1692	INTEGER, OPTIONAL :: ORDER
1693	REAL(DP), OPTIONAL, INTENT(IN):: BASIS(3,3)
1694	real(dp) basist(3,3),D(3)
1695	TYPE(INTEGRATION_NODE), POINTER :: T
1696	TYPE(element), POINTER::caf
1697	logical(lp), OPTIONAL, INTENT(IN) :: dogirder
1698	logical(lp) dog
1699	type(fibre_appearance), pointer :: dk
1700
1701	dog=.false.
1702	if(present(dogirder)) dog=dogirder
1703
1704
1705	OMEGAT=OMEGA
1706	P=>R
1707	Pp=>R
1708	IORDER=1
1709	IF(PRESENT(ORDER)) IORDER=ORDER
1710	BASIST=GLOBAL_FRAME ! NECESSARY SINCE BASIS CAN CHANGE DURING THE CALCULATION ASSUMING A POINTER IS PASSED
1711	IF(PRESENT(BASIS)) BASIST=BASIS
1712
1713
1714
1715
1716	! IF(.NOT.ASSOCIATED(P%PARENT_CHART)) THEN ! ONLY ROTATES ORIGINAL OTHERWISE
1717	IF(ASSOCIATED(P%CHART)) THEN
1718	IF(ASSOCIATED(P%CHART%F)) THEN
1719	! THEY WILL ROTATE MORE THAN ONCE
1720	CALL ROTATE_FRAME(P%CHART%F, OMEGAT,Ang,IORDER,BASIST)
1721
1722
1723	IF(ASSOCIATED(P%MAG%P%F)) THEN
1724
1725	CALL ROTATE_FRAME(P%MAG%P%F, OMEGAT,Ang,IORDER,BASIST)
1726	P%MAGP%P%F=P%MAG%P%F
1727	ENDIF
1728	ENDIF
1729	ENDIF
1730	! ENDIF
1731
1732	if(associated(R%mag%doko).and.associated(p,r%mag%parent_fibre)) then
1733	dk=>R%mag%doko
1734	do while(associated(dk)) !!! PATCH TO DOKO'S IF CREATED USING DNA I.E. APPEND_POINT
1735	pP=> dk%parent_fibre
1736	IF(ASSOCIATED(pp%T1)) THEN
1737	IF(ASSOCIATED(pp%T1%A)) THEN
1738	T=>pp%T1
1739	DO WHILE(.NOT.ASSOCIATED(pp%T2,T))
1740	D=T%A-OMEGAT
1741	CALL GEO_ROT(T%ENT,D,ANG,IORDER,BASIST)
1742	T%A=OMEGAT+D
1743	D=T%B-OMEGAT ! ERROR BEFORE 2008.5.20
1744	CALL GEO_ROT(T%EXI,D,ANG,IORDER,BASIST)
1745	D=T%B-OMEGAT
1746	T=>T%NEXT
1747	ENDDO
1748	D=T%A-OMEGAT
1749	CALL GEO_ROT(T%ENT,D,ANG,IORDER,BASIST)
1750	T%A=OMEGAT+D
1751	D=T%B-OMEGAT ! ERROR BEFORE 2008.5.20
1752	CALL GEO_ROT(T%EXI,D,ANG,IORDER,BASIST)
1753	D=T%B-OMEGAT
1754	ENDIF
1755	ENDIF
1756
1757	dk=>dk%next
1758	enddo
1759	endif
1760	IF(ASSOCIATED(R%T1)) THEN
1761	IF(ASSOCIATED(R%T1%A)) THEN
1762	T=>R%T1
1763	DO WHILE(.NOT.ASSOCIATED(R%T2,T))
1764	D=T%A-OMEGAT
1765	CALL GEO_ROT(T%ENT,D,ANG,IORDER,BASIST)
1766	T%A=OMEGAT+D
1767	D=T%B-OMEGAT ! ERROR BEFORE 2008.5.20
1768	CALL GEO_ROT(T%EXI,D,ANG,IORDER,BASIST)
1769	D=T%B-OMEGAT
1770	T=>T%NEXT
1771	ENDDO
1772	D=T%A-OMEGAT
1773	CALL GEO_ROT(T%ENT,D,ANG,IORDER,BASIST)
1774	T%A=OMEGAT+D
1775	D=T%B-OMEGAT ! ERROR BEFORE 2008.5.20
1776	CALL GEO_ROT(T%EXI,D,ANG,IORDER,BASIST)
1777	D=T%B-OMEGAT
1778	ENDIF
1779	ENDIF
1780
1781	if(dog) then ! IF DOGIRDER IS SET TO TRUE, TRANSLATE GIRDER FRAME
1782	if(associated(r%mag%GIRDER_FRAME)) then
1783	caf=>r%mag
1784	D=CAF%GIRDER_FRAME%A-OMEGAT
1785	CALL GEO_ROT(CAF%GIRDER_FRAME%ENT,D,ANG,IORDER,BASIST)
1786	CAF%GIRDER_FRAME%A=OMEGAT+D
1787	D=CAF%GIRDER_FRAME%B-OMEGAT
1788	CALL GEO_ROT(CAF%GIRDER_FRAME%EXI,D,ANG,IORDER,BASIST)
1789	CAF%GIRDER_FRAME%B=OMEGAT+D
1790	endif
1791	endif
1792
1793
1794	END SUBROUTINE ROTATE_FIBRE
1795
1796
1797
1798
1799
1800
1801	SUBROUTINE FIBRE_BL(S2,S1) ! PUTS A NEW MULTIPOLE BLOCK INTO FIBRE. EXTENDS ELEMENT(P) ROUTINES TO FIBRES
1802	IMPLICIT NONE
1803	TYPE (MUL_BLOCK),INTENT(IN):: S1
1804	TYPE(FIBRE),INTENT(INOUT):: S2
1805
1806	S2%MAG=S1
1807	S2%MAGP=S1
1808
1809	END SUBROUTINE FIBRE_BL
1810
1811	SUBROUTINE BL_FIBRE(S2,S1) ! SUCKS THE MULTIPOLE OUT LOOKING AT ELEMENT
1812	IMPLICIT NONE
1813	TYPE (FIBRE),INTENT(IN):: S1
1814	TYPE(MUL_BLOCK),INTENT(INOUT):: S2
1815
1816	S2=S1%MAG
1817
1818
1819	END SUBROUTINE BL_FIBRE
1820
1821
1822	!RECURSIVE
1823	SUBROUTINE SURVEY_EXIST_PLANAR_IJ(PLAN,I1,I2,ENT,A) ! STANDARD SURVEY FROM FIBRE #I1 TO #I2
1824	IMPLICIT NONE
1825	TYPE(LAYOUT),target, INTENT(INOUT):: PLAN
1826	TYPE (FIBRE), POINTER :: C
1827	TYPE (PATCH), POINTER :: P
1828	REAL(DP),OPTIONAL, INTENT(INOUT) :: A(3),ENT(3,3)
1829	INTEGER , INTENT(IN)::I1,I2
1830	INTEGER I,i22
1831	REAL(DP) AT(3),ENTT(3,3),NORM
1832	LOGICAL(LP) SKIP
1833
1834	SKIP=.FALSE.
1835
1836	NULLIFY(C);
1837
1838	if(i2>=i1) then
1839	i22=i2
1840	else
1841	i22=PLAN%n+i2
1842	endif
1843
1844
1845	CALL MOVE_TO(PLAN,C,MOD_N(I1,PLAN%N))
1846
1847
1848	IF((PRESENT(ENT).AND.(.NOT.PRESENT(A))).OR.(PRESENT(A).AND.(.NOT.PRESENT(ENT)))) THEN
1849	W_P=0
1850	W_P%NC=2
1851	W_P%FC='(2(1X,A72,/),(1X,A72))'
1852	W_P%C(1)=" BEWARE : ENT AND A "
1853	W_P%C(2)=" MUST BOTH BE PRESENT OR ABSENT"
1854	! call !write_e(100)
1855	ELSEIF(PRESENT(ENT)) THEN
1856	ENTT=ENT
1857	AT=A
1858	ELSE
1859	IF(ASSOCIATED(C%CHART%F)) THEN
1860	IF(C%DIR==1) THEN
1861	ENTT=C%CHART%F%ENT
1862	AT=C%CHART%F%A
1863	ELSE
1864	ENTT=C%CHART%F%EXI
1865	AT=C%CHART%F%B
1866	ENDIF
1867	ELSE
1868	write(6,*) " No charts "
1869	STOP 888
1870	ENDIF
1871	IF(ASSOCIATED(C%PATCH)) THEN
1872	P=>C%PATCH
1873	IF(P%PATCH/=0) THEN
1874	NORM=0.0_dp
1875	DO I=1,3
1876	NORM=NORM+ABS(P%A_ANG(I))
1877	NORM=NORM+ABS(P%A_D(I))
1878	ENDDO
1879	NORM=NORM+ABS(P%A_X1-1)+ABS(P%A_X2-1)
1880	IF(NORM/=0.0_dp) THEN
1881	WRITE(6,*) " NORM IN SURVEY ", NORM
1882	WRITE(6,*) " THE SURVEY SKIPS THE FIRST PATCH"
1883	WRITE(6,*) " IT IS NOT A SELF-CHECK ANYMORE"
1884	SKIP=.TRUE.
1885	ENDIF
1886	ENDIF
1887	ENDIF
1888
1889	ENDIF
1890
1891
1892
1893	I=I1
1894
1895	DO WHILE(I<I22.AND.ASSOCIATED(C))
1896
1897	CALL survey_FIBRE(C,ENTT,AT,SKIP)
1898	SKIP=.FALSE.
1899	C=>C%NEXT
1900	I=I+1
1901	ENDDO
1902
1903
1904	! IF(PRESENT(ENT)) THEN
1905	! ENT=ENTT
1906	! A=AT
1907	! ENDIF
1908
1909
1910
1911	END SUBROUTINE SURVEY_EXIST_PLANAR_IJ
1912
1913
1914	!recursive
1915	SUBROUTINE SURVEY_FIBRE(C,ENT,A,nogirder,SKIP,E_IN) !,MAGNETFRAME
1916	!changed
1917	! SURVEYS A SINGLE ELEMENT FILLS IN CHART AND MAGNET_CHART; LOCATES ORIGIN AT THE ENTRANCE OR EXIT
1918	IMPLICIT NONE
1919	TYPE(FIBRE), TARGET , INTENT(INOUT):: C
1920	! TYPE(MAGNET_FRAME), OPTIONAL :: MAGNETFRAME
1921	TYPE(INNER_FRAME), OPTIONAL :: E_IN
1922	logical(lp), OPTIONAL :: nogirder
1923	LOGICAL(LP), OPTIONAL :: SKIP
1924	REAL(DP), INTENT(INOUT) :: ENT(3,3),A(3)
1925	REAL(DP) D(3),ANG(3),DT(3)
1926	LOGICAL(LP) SEL,SKIPT,dog
1927	TYPE (PATCH), POINTER :: P
1928	REAL(DP)dg1(3),ag1(3),ENT0(3,3)
1929	REAL(DP)dg2(3),ag2(3)
1930	dog=.true.
1931	if(present(nogirder)) dog=.not.nogirder ! IF DOGIRDER IS SET TO TRUE, MOVES GIRDER FRAME DURING SURVEY
1932	!!! RECORDS RELATIVE POSITION OF GIRDER
1933	IF(ASSOCIATED(C%MAG%GIRDER_FRAME).and.dog) THEN
1934	call FIND_PATCH(C%chart%F%a,C%chart%F%ENT, &
1935	C%MAG%GIRDER_FRAME%a, C%MAG%GIRDER_FRAME%ent,dg1,ag1)
1936	call FIND_PATCH(C%chart%F%a,C%chart%F%ENT, &
1937	C%MAG%GIRDER_FRAME%b, C%MAG%GIRDER_FRAME%exi,dg2,ag2)
1938	ENDIF
1939
1940	IF(PRESENT(E_IN) ) CALL XFRAME(E_IN,ENT,A,-6)
1941	IF(PRESENT(E_IN) ) CALL XFRAME(E_IN,ENT,A,-5)
1942	SKIPT=.FALSE.
1943
1944	IF(PRESENT(SKIP)) SKIPT=SKIP
1945	SEL=.FALSE.
1946	IF(ASSOCIATED(C%CHART)) THEN
1947	SEL=.FALSE.
1948	IF(ASSOCIATED(C%CHART%F)) SEL=.TRUE.
1949	ENDIF
1950
1951	! IF(.NOT.SEL) THEN !
1952	! ENDIF
1953	IF(.NOT.SKIPT) THEN
1954	IF(ASSOCIATED(C%PATCH)) THEN
1955	P=>C%PATCH
1956	IF(P%PATCH==1.or.P%PATCH==2.or.P%PATCH==3) THEN
1957	ANG=0.0_dp
1958	ANG=P%A_ANG ;
1959
1960	DT=P%A_D
1961	! seems wrong !
1962	IF(P%A_X1*P%A_X2<0) ANG(1)=ANG(1)+PI
1963	IF(P%A_X2<0) then
1964	ANG(2)=-ANG(2)
1965	ANG(3)=-ANG(3)
1966	DT(2)=-DT(2)
1967	DT(3)=-DT(3)
1968	endif
1969
1970	D=0.0_dp
1971	ent0=ent
1972	CALL GEO_ROT(ENT0,D,ANG,1,ENT) ! for frank's flags
1973	ent=ent0
1974
1975	CALL GEO_TRA(A,ENT,DT,1)
1976
1977	ENDIF
1978	ENDIF
1979
1980	IF(PRESENT(E_IN) ) CALL XFRAME(E_IN,ENT,A,-4)
1981	IF(PRESENT(E_IN) ) CALL XFRAME(E_IN,ENT,A,-3)
1982	ENDIF
1983
1984	IF(C%DIR==1) THEN
1985	C%CHART%F%ENT=ENT
1986	C%CHART%F%A=A
1987	ELSE
1988	C%CHART%F%EXI=ENT
1989	C%CHART%F%B=A
1990	ENDIF
1991
1992
1993	CALL SURVEY_NO_PATCH(C,E_IN=E_IN)
1994
1995
1996	IF(C%DIR==1) THEN
1997	ENT=C%CHART%F%EXI
1998	A=C%CHART%F%B
1999	ELSE
2000	ENT=C%CHART%F%ENT
2001	A=C%CHART%F%A
2002	ENDIF
2003
2004	IF(PRESENT(E_IN) ) CALL XFRAME(E_IN,ENT,A,E_IN%NST-3)
2005	IF(PRESENT(E_IN) ) CALL XFRAME(E_IN,ENT,A,E_IN%NST-2)
2006
2007
2008	IF(ASSOCIATED(C%PATCH)) THEN
2009	IF(P%PATCH==1.or.P%PATCH==2.or.P%PATCH==3) THEN
2010	ANG=0.0_dp
2011	ANG=P%B_ANG ;
2012
2013	DT=P%B_D
2014	IF(P%B_X1*P%B_X2<0) ANG(1)=ANG(1)+PI
2015	IF(P%B_X2<0) then
2016	ANG(2)=-ANG(2)
2017	ANG(3)=-ANG(3)
2018	DT(2)=-DT(2)
2019	DT(3)=-DT(3)
2020	endif
2021
2022	D=0.0_dp
2023	ent0=ent
2024	CALL GEO_ROT(ENT0,D,ANG,1,ENT) ! for frank's flags
2025	ent=ent0
2026
2027	CALL GEO_TRA(A,ENT,DT,1)
2028
2029	ENDIF
2030	ENDIF
2031	IF(PRESENT(E_IN) ) CALL XFRAME(E_IN,ENT,A,E_IN%NST-1)
2032	IF(PRESENT(E_IN) ) CALL XFRAME(E_IN,ENT,A,E_IN%NST)
2033	IF(PRESENT(E_IN) ) CALL XFRAME(E_IN,ENT,A,-7)
2034
2035	!!! PLACES INTO THE COMPUTED RELATIVE POSITION OF GIRDER
2036	IF(ASSOCIATED(C%MAG%GIRDER_FRAME).and.dog) THEN ! IF DOGIRDER IS SET TO TRUE, MOVES GIRDER FRAME DURING SURVEY
2037	call INVERSE_FIND_PATCH(C%chart%F%a,C%chart%F%ENT, &
2038	dg1,ag1,C%MAG%GIRDER_FRAME%a, C%MAG%GIRDER_FRAME%ent)
2039	call INVERSE_FIND_PATCH(C%chart%F%a,C%chart%F%ENT, &
2040	dg2,ag2,C%MAG%GIRDER_FRAME%b, C%MAG%GIRDER_FRAME%exi)
2041	ENDIF
2042
2043	END SUBROUTINE SURVEY_FIBRE
2044
2045
2046
2047
2048
2049
2050
2051	!RECURSIVE
2052	SUBROUTINE SURVEY_EXIST_PLANAR_L_NEW(PLAN,ENT,A) ! CALLS ABOVE ROUTINE FROM FIBRE #1 TO #PLAN%N : STANDARD SURVEY
2053	IMPLICIT NONE
2054	TYPE(LAYOUT),target, INTENT(INOUT):: PLAN
2055	REAL(DP),OPTIONAL, INTENT(INOUT) :: A(3),ENT(3,3)
2056
2057	CALL survey(PLAN,1,ENT,A)
2058
2059	END SUBROUTINE SURVEY_EXIST_PLANAR_L_NEW
2060
2061	!RECURSIVE
2062	SUBROUTINE SURVEY_EXIST_PLANAR_I(PLAN,I1,ENT,A) ! STANDARD SURVEY FROM FIBRE #I1 TO #I2
2063	IMPLICIT NONE
2064	TYPE(LAYOUT),target, INTENT(INOUT):: PLAN
2065	REAL(DP),OPTIONAL, INTENT(INOUT) :: A(3),ENT(3,3)
2066	INTEGER , INTENT(IN)::I1
2067	INTEGER I2
2068	I2=PLAN%N+I1
2069
2070	CALL survey(PLAN,I1,I2,ENT,A)
2071
2072	END SUBROUTINE SURVEY_EXIST_PLANAR_I
2073
2074
2075	!RECURSIVE
2076	SUBROUTINE SURVEY_NO_PATCH(C,MAGNETFRAME,E_IN)
2077	!changed
2078	! SURVEYS A SINGLE ELEMENT FILLS IN CHART AND MAGNET_CHART; LOCATES ORIGIN AT THE ENTRANCE OR EXIT
2079	IMPLICIT NONE
2080	TYPE(FIBRE), TARGET , INTENT(INOUT):: C
2081	TYPE(MAGNET_FRAME), TARGET, OPTIONAL :: MAGNETFRAME
2082	TYPE(INNER_FRAME), OPTIONAL :: E_IN
2083	LOGICAL(LP) SEL
2084
2085	IF(.NOT.ASSOCIATED(C%CHART)) THEN
2086	RETURN
2087	ENDIF
2088
2089
2090	SEL=.FALSE.
2091	IF(ASSOCIATED(C%CHART)) THEN
2092	SEL=.FALSE.
2093	IF(ASSOCIATED(C%CHART%F)) SEL=.TRUE.
2094	ENDIF
2095
2096
2097	IF(SEL) THEN
2098	CALL SURVEY_mag(C%CHART,C%MAG,C%DIR,MAGNETFRAME,E_IN)
2099	ENDIF
2100
2101	IF(ASSOCIATED(C%MAGP%P%F)) THEN
2102	C%MAGP%P%F=C%MAG%P%F
2103	ENDIF
2104
2105
2106	RETURN
2107
2108	END SUBROUTINE SURVEY_NO_PATCH
2109
2110
2111
2112
2113	SUBROUTINE COPY_LAYOUT(R2,R1) ! COPY STANDARD LAYOUT ONLY
2114	IMPLICIT NONE
2115	TYPE(LAYOUT),target, INTENT(INOUT):: R1
2116	TYPE(LAYOUT),target, INTENT(INOUT):: R2
2117	TYPE (FIBRE), POINTER :: C
2118	LOGICAL(LP) :: DONEITT=.TRUE.
2119	INTEGER I ! TGV
2120	NULLIFY(C)
2121	! CALL LINE_L(R1,DONEIT) ! TGV
2122
2123	IF(ASSOCIATED(R2%N)) CALL KILL(R2)
2124	CALL SET_UP(R2)
2125
2126	R2%CLOSED=.FALSE.
2127	R2%NTHIN=R1%NTHIN
2128	R2%THIN=R1%THIN
2129	R2%HARMONIC_NUMBER=R1%HARMONIC_NUMBER
2130	! if(associated(r1%parent_universe)) R2%parent_universe=> r1%parent_universe
2131	C=> R1%START
2132	! DO WHILE(ASSOCIATED(C)) ! TGV
2133	DO I=1,R1%N
2134	CALL APPEND(R2,C)
2135	C=>C%NEXT
2136	ENDDO
2137	R2%LASTPOS=R2%N
2138	R2%LAST=>R2%END
2139
2140	R2%CLOSED=R1%CLOSED
2141	CALL RING_L(R2,DONEITT)
2142	! CALL RING_L(R1,DONEIT) ! TGV
2143
2144	END SUBROUTINE COPY_LAYOUT
2145
2146	SUBROUTINE COPY_LAYOUT_IJ(R1,I,J,R2) ! COPY PIECES OF A STANDARD LAYOUT FROM FIBRE #I TO #J
2147	IMPLICIT NONE
2148	TYPE(LAYOUT),target, INTENT(INOUT):: R1
2149	TYPE(LAYOUT),target, INTENT(INOUT):: R2
2150	INTEGER, INTENT(IN):: I,J
2151	TYPE (FIBRE), POINTER :: C
2152	LOGICAL(LP) :: DONEITT=.TRUE.
2153	INTEGER K
2154	NULLIFY(C)
2155
2156	! CALL LINE_L(R1,DONEIT) !TGV
2157
2158
2159	IF(ASSOCIATED(R2%N)) CALL KILL(R2)
2160	CALL SET_UP(R2)
2161
2162	R2%CLOSED=.FALSE.
2163	R2%NTHIN=R1%NTHIN
2164	R2%THIN=R1%THIN
2165	! if(associated(r1%parent_universe)) R2%parent_universe=> r1%parent_universe
2166
2167	CALL MOVE_TO(R1,C,I)
2168	K=I
2169	! DO WHILE(ASSOCIATED(C).AND.K<=J) !TGV
2170	DO K=I,J
2171	CALL APPEND(R2,C)
2172	! CALL APPEND(R2,C%MAG)
2173	! CALL EQUAL(R2%END%CHART,C%CHART)
2174	C=>C%NEXT
2175	! K=K+1 !TGV
2176	ENDDO
2177	R2%LASTPOS=R2%N
2178	R2%LAST=>R2%END
2179
2180	R2%CLOSED=R1%CLOSED
2181	CALL RING_L(R2,DONEITT)
2182	! CALL RING_L(R1,DONEIT) !TGV
2183
2184	END SUBROUTINE COPY_LAYOUT_IJ
2185
2186
2187
2188
2189	SUBROUTINE COPY_LAYOUT_I(R1,R2) ! COPIES IN THE COPY ORDER RATHER THAN THE LAYOUT ORDER
2190	IMPLICIT NONE
2191	TYPE(LAYOUT),target, INTENT(INOUT):: R1
2192	TYPE(LAYOUT),target, INTENT(INOUT):: R2
2193
2194	CALL EQUAL(R2,R1)
2195
2196	END SUBROUTINE COPY_LAYOUT_I
2197
2198	SUBROUTINE KILL_PARA_L(R) ! RESETS ALL THE PARAMETERS IN A LAYOUT : REMOVE POLYMORPHIC KNOBS
2199	IMPLICIT NONE
2200	TYPE(LAYOUT),target,INTENT(INOUT):: R
2201	TYPE (FIBRE), POINTER :: C
2202	INTEGER I
2203	c_%np_pol=0
2204	NULLIFY(C)
2205
2206	! CALL LINE_L(R,DONEIT) ! TGV
2207
2208	C=>R%START
2209	DO I=1,R%N
2210	! DO WHILE(ASSOCIATED(C)) ! TGV
2211	if(mfpolbloc/=0) call ELp_POL_print(C%MAGP)
2212	CALL RESET31(C%MAGP)
2213	C=>C%NEXT
2214	ENDDO
2215	! CALL RING_L(R,DONEIT) ! TGV
2216	END SUBROUTINE KILL_PARA_L
2217
2218	SUBROUTINE FIBRE_POL(S2,S1) ! SET POLYMORPH IN A FIBRE
2219	IMPLICIT NONE
2220	TYPE (POL_BLOCK),INTENT(IN):: S1
2221	TYPE(FIBRE),INTENT(INOUT):: S2
2222	S2%MAGP=S1
2223	END SUBROUTINE FIBRE_POL
2224
2225	SUBROUTINE EL_POL_force(S2,S1) ! SET POLYMORPH IN A FIBRE UNCONDITIONALLY
2226	IMPLICIT NONE
2227	TYPE (POL_BLOCK),INTENT(IN):: S1
2228	TYPE(FIBRE),INTENT(INOUT):: S2
2229	call ELp_POL_force(S2%MAGP,S1)
2230	END SUBROUTINE EL_POL_force
2231
2232	SUBROUTINE SCAN_FOR_POLYMORPHS(R,B) ! SET POLYMORPH IN A FULL LAYOUT ONLY IF THE MAGNET IS A PRIMITIVE PARENT
2233	IMPLICIT NONE
2234	TYPE(LAYOUT),target, INTENT(INOUT):: R
2235	TYPE(POL_BLOCK), INTENT(IN):: B
2236
2237	TYPE (FIBRE), POINTER :: C
2238	INTEGER I
2239
2240	NULLIFY(C)
2241	! CALL LINE_L(R,DONEIT) ! TGV
2242	C=>R%START
2243
2244	DO I=1,R%N
2245	! DO WHILE(ASSOCIATED(C)) ! TGV
2246	! IF(.NOT.ASSOCIATED(C%PARENT_MAG)) THEN
2247	C%MAGP=B
2248	! ENDIF
2249	C=>C%NEXT
2250	ENDDO
2251	! CALL RING_L(R,DONEIT)
2252
2253
2254	END SUBROUTINE SCAN_FOR_POLYMORPHS
2255
2256	SUBROUTINE EL_TO_ELP_L(R) ! COPY ALL PRIMITIVES ELEMENT INTO ELEMENTP
2257	IMPLICIT NONE
2258	TYPE(LAYOUT),target, INTENT(INOUT):: R
2259	TYPE (FIBRE), POINTER :: C
2260	INTEGER I
2261
2262	NULLIFY(C)
2263	! CALL LINE_L(R,DONEIT) ! TGV
2264
2265	C=>R%START
2266	DO I=1,R%N
2267	! DO WHILE(ASSOCIATED(C)) ! TGV
2268	! IF(.NOT.ASSOCIATED(C%PARENT_MAG)) CALL COPY(C%MAG,C%MAGP)
2269	CALL COPY(C%MAG,C%MAGP)
2270	C=>C%NEXT
2271	ENDDO
2272
2273	! CALL RING_L(R,DONEIT) ! TGV
2274
2275	END SUBROUTINE EL_TO_ELP_L
2276
2277	SUBROUTINE ELP_TO_EL_L(R) ! COPY ALL PRIMITIVES ELEMENTP INTO ELEMENT
2278	IMPLICIT NONE
2279	TYPE(LAYOUT),target, INTENT(INOUT):: R
2280	TYPE (FIBRE), POINTER :: C
2281	INTEGER I
2282	NULLIFY(C)
2283
2284	! CALL LINE_L(R,DONEIT) ! ! TGV
2285	C=>R%START
2286	! DO WHILE(ASSOCIATED(C)) ! TGV
2287	DO I=1,R%N
2288	! IF(.NOT.ASSOCIATED(C%PARENT_MAG)) CALL COPY(C%MAGP,C%MAG)
2289	CALL COPY(C%MAGP,C%MAG)
2290
2291	C=>C%NEXT
2292	ENDDO
2293
2294	! CALL RING_L(R,DONEIT) ! TGV
2295	END SUBROUTINE ELP_TO_EL_L
2296
2297
2298	SUBROUTINE fill_survey_ONE_FIBRE(R)
2299	! THIS SUBROUTINE ALLOCATES NODE FRAMES IF NEEDED
2300	! IT SURVEYS THE NODES USING THE OLD REAL WORMS
2301	! SHOULD BE CALLED AFTER MISALIGNMENTS OR MOVING PART OF LATTICE
2302
2303	IMPLICIT NONE
2304	type(FIBRE),target:: r
2305	type(fibre), pointer ::c
2306	type(INTEGRATION_NODE), pointer ::t
2307	type(worm) vers
2308	integer ic,j
2309	real(dp) x(6),ent(3,3),a(3)
2310	! INTEGER, TARGET :: CHARGE
2311	LOGICAL(LP) APER
2312
2313	aper=APERTURE_FLAG
2314	APERTURE_FLAG=.FALSE.
2315
2316
2317
2318
2319	C=>R
2320
2321	CALL ALLOC(vers,r)
2322
2323	CALL XFRAME(vers%E,C%chart%f%ent,C%chart%f%A,-7) ! initializes the survey part of worm
2324	vers%E%L(-1)=0.d0 !Starts beam line at z=0 fake distance along ld for cheap work
2325
2326	! do k=1,r%n
2327	x=0.0_dp
2328	CALL TRACK_FIBRE_RR(C,x,default,vers)
2329
2330	t=>c%t1
2331	j=-6
2332	call gMID(vers,x,j)
2333	call G_FRAME(vers%e,ENT,A,j)
2334	t%ent=ent
2335	t%a=a
2336
2337	t=>t%next
2338	if(t%cas/=case1) then
2339	write(6,*)" error in fill_survey_data_in_NODE_LAYOUT",j,t%cas
2340	stop 665
2341	endif
2342	j=vers%POS(2)
2343	call gMID(vers,x,j)
2344	call G_FRAME(vers%e,ENT,A,j)
2345	t%ent=ent
2346	t%a=a
2347	t%previous%exi=ent
2348	t%previous%b=a
2349	t=>t%next
2350	ic=0
2351	DO J=vers%POS(2)+1,vers%POS(3)-1 ! pos(2)+1 to pos(3)-1 inside the magnet
2352
2353	ic=ic+1
2354
2355	call gMID(vers,x,j)
2356	call G_FRAME(vers%e,ENT,A,j)
2357
2358	if(j/=vers%POS(2)+1) then
2359	t%previous%exi=ent
2360	t%previous%b=a
2361	if(t%previous%cas/=case0) then
2362	write(6,*)" error in fill_survey_data_in_NODE_LAYOUT",j,t%previous%cas
2363	stop 666
2364	endif
2365	else
2366	t%previous%exi=ent
2367	t%previous%b=a
2368	if(t%previous%cas/=case1) then
2369	write(6,*)" error in fill_survey_data_in_NODE_LAYOUT",j,t%previous%cas
2370	stop 664
2371	endif
2372	endif
2373
2374	if(j/=vers%POS(3)-1) then
2375	t%ent=ent
2376	t%a=a
2377	if(t%cas/=case0) then
2378	write(6,*)" error in fill_survey_data_in_NODE_LAYOUT",j,t%cas
2379	stop 666
2380	endif
2381	else
2382	t%ent=ent
2383	t%a=a
2384	if(t%cas/=case2) then
2385	write(6,*)" error in fill_survey_data_in_NODE_LAYOUT",j,t%cas
2386	write(6,*)t%POS,T%PARENT_FIBRE%MAG%NAME
2387	write(6,*)T%PARENT_FIBRE%T1%POS,T%PARENT_FIBRE%T2%POS
2388	stop 668
2389	endif
2390	endif
2391
2392
2393
2394	t=>t%next
2395	enddo
2396	j=vers%POS(3)
2397	call gMID(vers,x,j)
2398	call G_FRAME(vers%e,ENT,A,j)
2399	t%previous%exi=ent
2400	t%previous%b=a
2401	t%ent=ent
2402	t%a=a
2403	if(t%previous%cas/=case2) then
2404	write(6,*)" error in fill_survey_data_in_NODE_LAYOUT",j,t%cas
2405	stop 669
2406	endif
2407	! t=>t%next
2408
2409	j=vers%nst
2410	call gMID(vers,x,j)
2411	call G_FRAME(vers%e,ENT,A,j)
2412
2413	t%exi=ent
2414	t%b=a
2415
2416	if(t%cas/=casep2) then
2417	write(6,*)" error in fill_survey_data_in_NODE_LAYOUT",j,t%cas
2418	stop 670
2419	endif
2420
2421
2422	if(ic/=c%mag%p%nst+1) then
2423	write(6,*)" error in fill_survey_data_in_NODE_LAYOUT"
2424	write(6,*) ic,c%mag%name,c%mag%p%nst
2425	stop 888
2426	endif
2427	c=>c%next
2428	! enddo
2429
2430	CALL kill(vers)
2431
2432	APERTURE_FLAG=aper
2433
2434	end subroutine fill_survey_ONE_FIBRE
2435
2436	SUBROUTINE TRACK_FIBRE_RR(C,X,K,X_IN)
2437	implicit none
2438	TYPE(FIBRE),TARGET,INTENT(INOUT):: C
2439	real(dp), INTENT(INOUT):: X(6)
2440	TYPE(WORM), OPTIONAL,INTENT(INOUT):: X_IN
2441	! INTEGER,optional, target, INTENT(IN) :: CHARGE
2442	TYPE(INTERNAL_STATE), INTENT(IN) :: K
2443	INTEGER(2) PATCHT,PATCHG,PATCHE
2444	REAL(DP) ENT(3,3), A(3)
2445	! integer,target :: charge1
2446
2447
2448
2449
2450	IF(PRESENT(X_IN)) then
2451	X_IN%F=>c ; X_IN%E%F=>C; X_IN%NST=>X_IN%E%NST;
2452	endif
2453
2454	! DIRECTIONAL VARIABLE
2455	C%MAG%P%DIR=>C%DIR
2456	! if(present(charge)) then
2457	! C%MAG%P%CHARGE=>CHARGE
2458	! else
2459	! charge1=1
2460	C%MAG%P%CHARGE=>C%charge
2461	! endif
2462	!
2463	! IF(.NOT.CHECK_STABLE) CHECK_STABLE=.TRUE.
2464	!FRONTAL PATCH
2465	IF(ASSOCIATED(C%PATCH)) THEN
2466	PATCHT=C%PATCH%TIME ;PATCHE=C%PATCH%ENERGY ;PATCHG=C%PATCH%PATCH;
2467	ELSE
2468	PATCHT=0 ; PATCHE=0 ;PATCHG=0;
2469	ENDIF
2470	IF(PRESENT(X_IN)) then
2471	CALL XMID(X_IN,X,-6)
2472	X_IN%POS(1)=X_IN%nst
2473	endif
2474
2475	IF(PRESENT(X_IN)) CALL XMID(X_IN,X,-5)
2476
2477	! The chart frame of reference is located here implicitely
2478	IF(PRESENT(X_IN)) CALL XMID(X_IN,X,-4)
2479	IF(PRESENT(X_IN)) CALL XMID(X_IN,X,-3)
2480
2481	IF(PRESENT(X_IN)) CALL XMID(X_IN,X,-2)
2482	! The magnet frame of reference is located here implicitely before misalignments
2483
2484	! CALL TRACK(C,X,EXACTMIS=K%EXACTMIS)
2485	IF(PRESENT(X_IN)) then
2486	CALL XMID(X_IN,X,-1)
2487	X_IN%POS(2)=X_IN%nst
2488	endif
2489
2490	CALL TRACK(C%MAG,X,K,X_IN)
2491
2492	IF(PRESENT(X_IN)) then
2493	CALL XMID(X_IN,X,X_IN%nst+1)
2494	X_IN%POS(3)=X_IN%nst
2495	endif
2496
2497	IF(PRESENT(X_IN)) CALL XMID(X_IN,X,X_IN%nst+1)
2498	! The magnet frame of reference is located here implicitely before misalignments
2499	IF(PRESENT(X_IN)) CALL XMID(X_IN,X,X_IN%nst+1)
2500
2501	IF(PRESENT(X_IN)) CALL XMID(X_IN,X,X_IN%nst+1)
2502
2503	IF(PRESENT(X_IN)) CALL XMID(X_IN,X,X_IN%nst+1)
2504
2505	! The CHART frame of reference is located here implicitely
2506
2507	IF(PRESENT(X_IN)) then
2508	CALL XMID(X_IN,X,X_IN%nst+1)
2509	X_IN%POS(4)=X_IN%nst
2510	endif
2511
2512	IF(PRESENT(X_IN)) THEN
2513	IF(X_IN%E%DO_SURVEY) THEN
2514	CALL G_FRAME(X_IN%E,ENT,A,-7)
2515	CALL SURVEY(C,ENT,A,E_IN=X_IN%E)
2516	ELSE
2517	CALL SURVEY_INNER_MAG(X_IN%E)
2518	ENDIF
2519	ENDIF
2520
2521
2522
2523	nullify(C%MAG%P%DIR)
2524	nullify(C%MAG%P%CHARGE)
2525	END SUBROUTINE TRACK_FIBRE_RR
2526
2527
2528	END MODULE S_FAMILY

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: PSPA/madxPSPA/libs/ptc/src/Sl_family.f90 @ 430

Download in other formats: