Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

Sk_link_list.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: 69.4 KB

Line
1	!The Polymorphic Tracking Code
2	!Copyright (C) Etienne Forest and CERN
3
4	MODULE S_FIBRE_BUNDLE
5	USE S_DEF_ELEMENT
6	! USE S_ELEMENTS
7	! Implementation of abstract data type as a linked layout
8	IMPLICIT NONE
9	public
10	private unify_mad_universe
11
12	PRIVATE kill_layout,kill_info,alloc_info,copy_info
13	private dealloc_fibre,append_fibre !, alloc_fibre public now also as alloc
14	! private null_it0
15	private move_to_p,move_to_name_old,move_to_nameS,move_to_name_FIRSTNAME
16	PRIVATE append_EMPTY_FIBRE
17	PRIVATE FIND_PATCH_0
18	PRIVATE FIND_PATCH_p_new
19	PRIVATE INDEX_0
20	private FIND_POS_in_universe,FIND_POS_in_layout,super_dealloc_fibre
21	TYPE(LAYOUT), PRIVATE, POINTER:: LC
22	logical :: superkill=.false.
23	logical(lp),TARGET :: use_info=.false.
24	integer, target :: nsize_info = 70
25	private zero_fibre
26	INTEGER :: INDEX_0=0
27	INTEGER :: INDEX_node=0
28	logical(lp),PRIVATE,PARAMETER::T=.TRUE.,F=.FALSE.
29	real(dp),target :: eps_pos=1e-10_dp
30	integer(2),parameter::it0=0,it1=1,it2=2,it3=3,it4=4,it5=5,it6=6,it7=7,it8=8,it9=9
31
32	INTERFACE kill
33	MODULE PROCEDURE kill_layout
34	MODULE PROCEDURE dealloc_fibre
35	MODULE PROCEDURE kill_info
36	MODULE PROCEDURE kill_NODE_LAYOUT
37	MODULE PROCEDURE de_Set_Up_ORBIT_LATTICE
38	MODULE PROCEDURE kill_BEAM_BEAM_NODE
39	END INTERFACE
40
41	INTERFACE super_kill
42	MODULE PROCEDURE super_dealloc_fibre
43	end INTERFACE
44
45	INTERFACE alloc
46	! MODULE PROCEDURE set_up
47	MODULE PROCEDURE alloc_fibre
48	MODULE PROCEDURE alloc_info
49	MODULE PROCEDURE ALLOC_BEAM_BEAM_NODE
50	END INTERFACE
51
52	INTERFACE copy
53	MODULE PROCEDURE copy_info
54	END INTERFACE
55
56	INTERFACE append
57	MODULE PROCEDURE append_fibre
58	END INTERFACE
59
60	INTERFACE append_EMPTY
61	MODULE PROCEDURE append_EMPTY_FIBRE
62	END INTERFACE
63
64	INTERFACE move_to
65	MODULE PROCEDURE move_to_p
66	MODULE PROCEDURE move_to_name_old
67	MODULE PROCEDURE move_to_nameS
68	MODULE PROCEDURE move_to_name_FIRSTNAME
69	END INTERFACE
70
71	INTERFACE FIND_PATCH
72	MODULE PROCEDURE FIND_PATCH_0
73	END INTERFACE
74
75
76	INTERFACE FIND_pos
77	MODULE PROCEDURE FIND_POS_in_layout
78	MODULE PROCEDURE FIND_POS_in_universe
79	END INTERFACE
80
81
82
83
84	interface assignment (=)
85	! MODULE PROCEDURE null_it0
86	MODULE PROCEDURE zero_fibre
87	end interface
88
89	CONTAINS
90
91	SUBROUTINE alloc_info( c ) ! Does the full allocation of fibre and initialization of internal variables
92	implicit none
93	type(info),target, intent(inout):: c
94
95	allocate(c%s) ;c%s=0.0_dp;
96	allocate(c%beta(nsize_info));c%beta=0.0_dp;
97	allocate(c%fix(6));c%fix=0.0_dp;
98	allocate(c%fix0(6));c%fix0=0.0_dp;
99	allocate(c%pos(2));c%pos=0.0_dp;
100
101
102	end SUBROUTINE alloc_info
103
104	SUBROUTINE copy_info( c,d ) ! Does the full allocation of fibre and initialization of internal variables
105	implicit none
106	type(info),target, intent(in)::c
107	type(info),target, intent(inout)::d
108
109	! d%name=c%name
110	d%s=c%s
111	d%beta=c%beta
112	d%fix=c%fix
113	d%fix0=c%fix0
114	d%pos=c%pos
115
116	end SUBROUTINE copy_info
117
118	SUBROUTINE kill_info( c ) ! Does the full allocation of fibre and initialization of internal variables
119	implicit none
120	type(info),target, intent(inout):: c
121
122	! deallocate(c%name)
123	deallocate(c%s)
124	deallocate(c%fix)
125	deallocate(c%fix0)
126	deallocate(c%beta)
127	deallocate(c%pos)
128
129	end SUBROUTINE kill_info
130
131	SUBROUTINE APPEND_mad_like( L, el ) ! Used in MAD-Like input
132	implicit none
133	TYPE (fibre),target :: el
134	TYPE (fibre), POINTER :: Current
135	TYPE (layout), TARGET, intent(inout):: L
136	L%N=L%N+1
137	CALL ALLOCATE_FIBRE(Current);
138	current%mag=>el%mag
139	current%magp=>el%magp
140	current%CHART=>el%CHART
141	current%PATCH=>el%PATCH
142	if(use_info) current%i=>el%i
143	current%dir=>el%dir
144	! OCTOBER 2007
145	! current%P0C=>el%P0C
146	current%BETA0=>el%BETA0
147	current%GAMMA0I=>el%GAMMA0I
148	current%GAMBET=>el%GAMBET
149	current%MASS=>el%MASS
150	current%AG=>el%AG
151	current%CHARGE=>el%CHARGE
152
153	current%PARENT_LAYOUT=>L
154	if(L%N==1) current%next=> L%start
155	Current % previous => L % end ! point it to next fibre
156	if(L%N>1) THEN
157	L % end % next => current !
158	ENDIF
159
160	L % end => Current
161	if(L%N==1) L%start=> Current
162
163	L%LASTPOS=L%N ;
164	L%LAST=>CURRENT;
165
166	END SUBROUTINE APPEND_mad_like
167
168
169	SUBROUTINE kill_layout( L ) ! Destroys a layout
170	implicit none
171	TYPE (fibre), POINTER :: Current
172	TYPE (layout), TARGET, intent(inout):: L
173	logical(lp) doneit
174	write(6,*) "Killing Layout",L%name
175	CALL LINE_L(L,doneit)
176	nullify(current)
177	IF(ASSOCIATED(L%T)) THEN
178	CALL kill_NODE_LAYOUT(L%T) ! KILLING THIN LAYOUT
179	nullify(L%T)
180	WRITE(6,*) " NODE LAYOUT HAS BEEN KILLED "
181	ENDIF
182	IF(ASSOCIATED(L%DNA)) THEN
183	DEALLOCATE(L%DNA)
184	WRITE(6,*) " DNA CONTENT HAS BEEN DEALLOCATED "
185	ENDIF
186	! IF(ASSOCIATED(L%con)) THEN
187	! DEALLOCATE(L%con)
188	! WRITE(6,*) " CONNECTOR CONTENT HAS BEEN KILLED "
189	! ENDIF
190	! IF(ASSOCIATED(L%con1)) THEN
191	! DEALLOCATE(L%con1)
192	! WRITE(6,*) " CONNECTOR CONTENT HAS BEEN DEALLOCATED "
193	! ENDIF
194	! IF(ASSOCIATED(L%con2)) THEN
195	! DEALLOCATE(L%con2)
196	! WRITE(6,*) " CONNECTOR CONTENT HAS BEEN DEALLOCATED "
197	! ENDIF
198	! IF(ASSOCIATED(L%girder)) THEN
199	! DEALLOCATE(L%girder)
200	! WRITE(6,*) " GIRDER CONTENT HAS BEEN DEALLOCATED "
201	! ENDIF
202
203	LC=> L ! USED TO AVOID DNA MEMBERS
204	Current => L % end ! end at the end
205	DO WHILE (ASSOCIATED(L % end))
206	L % end => Current % previous ! update the end before disposing
207	call dealloc_fibre(Current)
208	Current => L % end ! alias of last fibre again
209	L%N=L%N-1
210	END DO
211	call de_set_up(L)
212	WRITE(6,*) 'Layout killed '
213	END SUBROUTINE kill_layout
214
215
216	SUBROUTINE APPEND_fibre( L, el ) ! Standard append that clones everything
217	implicit none
218	TYPE (fibre),target, intent(in) :: el
219	TYPE (fibre), POINTER :: Current
220	TYPE (layout), TARGET,intent(inout):: L
221	logical(lp) doneit
222	CALL LINE_L(L,doneit)
223	L%N=L%N+1
224	nullify(current)
225	call alloc_fibre(current)
226	! call copy(el%magp,current%mag) ! 2010 etienne does not understand!
227	! call copy(current%mag,current%magp) ! 2010 etienne does not understand!
228	! call copy(el%mag,current%mag) ! 2010 etienne does not understand!
229	call copy(el%mag,current%mag) ! 2010 etienne replaces!
230	call copy(current%mag,current%magp) ! 2010 etienne replaces!
231	! write(6,*) " used "
232	!if(associated(current%CHART))
233	call copy(el%CHART,current%CHART)
234	!if(associated(current%patch))
235	call copy(el%PATCH,current%PATCH)
236	if(use_info.and.associated(current%patch)) call copy(el%i,current%i)
237	current%dir=el%dir
238	! current%P0C =el%P0C
239	current%BETA0 =el%BETA0
240	current%GAMMA0I=el%GAMMA0I
241	current%GAMBET =el%GAMBET
242	current%MASS =el%MASS
243	current%AG =el%AG
244	current%CHARGE =el%CHARGE
245
246	current%PARENT_LAYOUT=>L
247	current%mag%PARENT_FIBRE=>current
248	current%magP%PARENT_FIBRE=>current
249	! current%magp%PARENT_FIBRE=>current
250	if(L%N==1) current%next=> L%start
251	Current % previous => L % end ! point it to next fibre
252	if(L%N>1) THEN
253	L % end % next => current !
254	ENDIF
255
256	L % end => Current
257	if(L%N==1) L%start=> Current
258	current%pos=l%n
259
260	L%LASTPOS=L%N ; L%LAST=>CURRENT;
261	CALL RING_L(L,doneit)
262	END SUBROUTINE APPEND_fibre
263
264	SUBROUTINE APPEND_clone( L, muonfactor,charge ) ! Standard append that clones everything
265	implicit none
266	TYPE (fibre), POINTER :: Current
267	TYPE (layout), TARGET,intent(inout):: L
268	logical(lp) doneit
269	real(dp),optional :: charge
270	real(dp),optional :: muonfactor
271	real(dp) mu
272	real(dp) ch
273	CALL LINE_L(L,doneit)
274	L%N=L%N+1
275	nullify(current)
276	call alloc_fibre(current)
277	! if(use_info.and.associated(current%patch)) call copy(el%i,current%i)
278	current%dir=1
279	mu=1.0_dp
280	ch=1
281	if(present(muonfactor)) mu=muonfactor
282	if(present(charge)) ch=charge
283	! OCT 2007
284	! current%P0C=ONE
285	current%BETA0=1.0_dp
286	current%GAMMA0I=1.0_dp
287	current%GAMBET=0.0_dp
288	current%MASS=mu*pmae
289	current%AG=A_particle
290	current%CHARGE=ch
291
292	current%pos=l%n
293
294	current%PARENT_LAYOUT=>L
295	current%mag%PARENT_FIBRE=>current
296	current%magP%PARENT_FIBRE=>current
297	! current%magp%PARENT_FIBRE=>current
298	if(L%N==1) current%next=> L%start
299	Current % previous => L % end ! point it to next fibre
300	if(L%N>1) THEN
301	L % end % next => current !
302	ENDIF
303
304	L % end => Current
305	if(L%N==1) L%start=> Current
306
307	L%LASTPOS=L%N ; L%LAST=>CURRENT;
308	CALL RING_L(L,doneit)
309	END SUBROUTINE APPEND_clone
310
311
312
313
314
315
316
317
318	SUBROUTINE move_to_p( L,current,POS ) ! Moves current to the i^th position
319	implicit none
320	TYPE (fibre), POINTER :: Current
321	TYPE (layout), TARGET, intent(inout):: L
322	integer i,k,POS
323
324	! CALL LINE_L(L,doneit) !TGV
325	I=mod_n(POS,L%N)
326	IF(L%LASTPOS==0) THEN
327	w_p=0
328	w_p%nc=2
329	w_p%fc='((1X,a72,/),(1X,a72))'
330	w_p%c(1)= " L%LASTPOS=0 : ABNORMAL UNLESS LINE EMPTY"
331	write(w_p%c(2),'(a7,i4)')" L%N = ",L%N
332	! call !write_e(-124)
333	ENDIF
334
335	nullify(current);
336	Current => L%LAST
337
338	k=L%LASTPOS
339	IF(I>=L%LASTPOS) THEN
340	DO K=L%LASTPOS,I-1
341	! DO WHILE (ASSOCIATED(Current).and.k<i) !TGV
342	! k=k+1 !TGV
343	Current => Current % next
344	END DO
345	ELSE
346	DO K=L%LASTPOS,I+1,-1
347	! DO WHILE (ASSOCIATED(Current).and.k>i) !TGV
348	! k=k-1 !TGV
349	Current => Current % PREVIOUS
350	END DO
351	ENDIF
352	L%LASTPOS=I; L%LAST => Current;
353	! CALL RING_L(L,doneit) ! TGV
354	END SUBROUTINE move_to_p
355
356
357	SUBROUTINE move_to_name_old( L,current,name,pos,reset) ! moves to next one in list called name
358	implicit none
359	logical(lp),optional :: reset
360	TYPE (fibre), POINTER :: Current
361	TYPE (layout), TARGET, intent(inout):: L
362	integer, intent(inout):: pos
363	character(*), intent(in):: name
364	CHARACTER(nlp) S1NAME
365	integer i
366
367	logical(lp) foundit
368	TYPE (fibre), POINTER :: p
369
370	if(present(reset)) then
371	if(reset) then
372	l%lastpos=1
373	l%last=>L%start
374	endif
375	endif
376
377	foundit=.false.
378	S1NAME=name
379	CALL CONTEXT(S1name)
380
381	nullify(p)
382	p=>l%last%next
383
384	if(.not.associated(p)) goto 100
385	do i=1,l%n
386	if(p%mag%name==s1name) then
387	foundit=.true.
388	goto 100
389	endif
390	p=>p%next
391	if(.not.associated(p)) goto 100
392	enddo
393	100 continue
394	if(foundit) then
395	current=>p
396	pos=mod_n(l%lastpos+i,l%n)
397	l%lastpos=pos
398	l%last=>current
399	else
400	pos=0
401	WRITE(6,*) " Fibre not found in move_to_name_old ",S1name
402	endif
403	END SUBROUTINE move_to_name_old
404
405	SUBROUTINE move_to_partial( L,current,name,pos) ! moves to next one in list called name
406	implicit none
407	TYPE (fibre), POINTER :: Current
408	TYPE (layout), TARGET, intent(inout):: L
409	integer, intent(inout):: pos
410	character(*), intent(in):: name
411	CHARACTER(nlp) S1NAME
412	integer i
413
414	logical(lp) foundit
415	TYPE (fibre), POINTER :: p
416
417	foundit=.false.
418	S1NAME=name
419	CALL CONTEXT(S1name)
420
421	nullify(p)
422	p=>l%last%next
423
424	if(.not.associated(p)) goto 100
425	do i=1,l%n
426	if(index(p%mag%name,s1name(1:len_trim(s1name)))/=0) then
427	foundit=.true.
428	goto 100
429	endif
430	p=>p%next
431	if(.not.associated(p)) goto 100
432	enddo
433	100 continue
434	if(foundit) then
435	current=>p
436	pos=mod_n(l%lastpos+i,l%n)
437	l%lastpos=pos
438	l%last=>current
439	else
440	pos=0
441	endif
442	END SUBROUTINE move_to_partial
443
444	SUBROUTINE move_to_name_FIRSTNAME( L,current,name,VORNAME,pos) ! moves to next one in list called name
445	implicit none
446	TYPE (fibre), POINTER :: Current
447	TYPE (layout), TARGET, intent(inout):: L
448	integer, intent(inout):: pos
449	character(*), intent(in):: name,VORNAME
450	CHARACTER(nlp) S1NAME,S2NAME
451	integer i
452
453	logical(lp) foundit
454	TYPE (fibre), POINTER :: p
455
456	foundit=.false.
457	S1NAME=name
458	S2NAME=VORNAME
459	CALL CONTEXT(S1name)
460	CALL CONTEXT(S2name)
461
462	nullify(p)
463	p=>l%last%next
464
465	if(.not.associated(p)) goto 100
466	do i=1,l%n
467	if(p%mag%name==s1name.AND.p%mag%VORname==S2NAME) then
468	foundit=.true.
469	goto 100
470	endif
471	p=>p%next
472	if(.not.associated(p)) goto 100
473	enddo
474	100 continue
475	if(foundit) then
476	current=>p
477	pos=mod_n(l%lastpos+i,l%n)
478	l%lastpos=pos
479	l%last=>current
480	else
481	pos=0
482	WRITE(6,*) " Did not find in move_to_name_FIRSTNAME"
483	WRITE(6,*) s1name,s2name
484	endif
485	END SUBROUTINE move_to_name_FIRSTNAME
486
487	SUBROUTINE move_to_nameS( L,current,name,posR,POS) ! moves to next one in list called name
488	implicit none
489	TYPE (fibre), POINTER :: Current
490	TYPE (layout), TARGET, intent(inout):: L
491	integer, intent(inout):: pos,POSR
492	character(*), intent(in):: name
493	CHARACTER(nlp) S1NAME
494	integer i,IC
495
496	logical(lp) foundit
497	TYPE (fibre), POINTER :: p
498
499	foundit=.false.
500	S1NAME=name
501	CALL CONTEXT(S1name)
502
503	nullify(p)
504	p=>l%START
505	IC=0
506	if(.not.associated(p)) goto 100
507	do i=1,l%n
508	if(p%mag%name==s1name) then
509	IC=IC+1
510	IF(IC==POSR) THEN
511	foundit=.true.
512	goto 100
513	ENDIF
514	endif
515	p=>p%next
516	if(.not.associated(p)) goto 100
517	enddo
518	100 continue
519	if(foundit) then
520	current=>p
521	pos=mod_n(i,l%n)
522	l%lastpos=pos
523	l%last=>current
524	else
525	pos=0
526	endif
527	END SUBROUTINE move_to_nameS
528
529	SUBROUTINE move_to_i( L,current,POS) ! move_to_i ! move to ith fibre
530	implicit none
531	TYPE (fibre), POINTER :: Current
532	TYPE (layout), TARGET, intent(inout):: L
533	integer, intent(inout):: pos
534	integer i
535
536	logical(lp) foundit
537	TYPE (fibre), POINTER :: p
538
539	foundit=.false.
540
541	nullify(p)
542	p=>l%START
543	if(.not.associated(p)) goto 100
544
545	do i=1,l%n
546	if(p%pos==pos) then
547	foundit=my_true
548	exit
549	endif
550	if(l%lastpos>=pos) then
551	p=>p%previous
552	else
553	p=>p%next
554	endif
555	if(.not.associated(p)) goto 100
556	enddo
557	100 continue
558	if(foundit) then
559	current=>p
560	l%lastpos=pos
561	l%last=>current
562	else
563	pos=0
564	endif
565	END SUBROUTINE move_to_i
566
567
568
569
570	SUBROUTINE Set_Up( L ) ! Sets up a layout: gives a unique negative index
571	implicit none
572	TYPE (layout),TARGET, INTENT(INOUT):: L
573	type(mad_universe), pointer :: madu
574	! new 2012.9.7
575	nullify(madu)
576	if(associated(L%parent_universe) ) madu=>L%parent_universe
577	!
578
579	CALL NULLIFY_LAYOUT(L)
580
581	if(associated(madu) ) L%parent_universe=>madu
582	nullify(madu)
583
584	ALLOCATE(L%closed); ALLOCATE(L%lastpos);ALLOCATE(L%NAME);ALLOCATE(L%HARMONIC_NUMBER);
585	ALLOCATE(L%NTHIN);ALLOCATE(L%THIN);ALLOCATE(L%INDEX);
586	ALLOCATE(L%n);
587	L%closed=.false.;
588	L%NTHIN=0;L%THIN=0.0_dp;
589	L%N=0;
590	L%lastpos=0;L%NAME='No name assigned';
591	INDEX_0=INDEX_0+1
592	L%INDEX=INDEX_0
593	L%HARMONIC_NUMBER=0
594	END SUBROUTINE Set_Up
595
596
597
598
599	SUBROUTINE de_Set_Up( L ) ! deallocates layout content
600	implicit none
601	TYPE (layout),TARGET, INTENT(INOUT):: L
602	deallocate(L%closed);deallocate(L%lastpos);deallocate(L%NAME);deallocate(L%HARMONIC_NUMBER);
603	deallocate(L%INDEX);
604	deallocate(L%NTHIN);deallocate(L%THIN);
605	deallocate(L%n); !deallocate(L%parent_universe) left out
606	IF(ASSOCIATED(L%T)) deallocate(L%T);
607	END SUBROUTINE de_Set_Up
608
609
610	SUBROUTINE nullIFY_LAYOUT( L ) ! Nullifies layout content,i
611	implicit none
612	! integer , intent(in) :: i
613	TYPE (layout),TARGET, intent(inout) :: L
614	! if(i==0) then
615	nullify(L%T) ! THIN LAYOUT
616	nullify(L%DNA) ! THIN LAYOUT
617	! nullify(L%CON) ! THIN LAYOUT
618	! nullify(L%CON1) ! THIN LAYOUT
619	! nullify(L%CON2) ! THIN LAYOUT
620	! nullify(L%girder) ! THIN LAYOUT
621	nullify(L%parent_universe)
622	nullify(L%INDEX)
623	nullify(L%HARMONIC_NUMBER)
624	nullify(L%NAME)
625	nullify(L%CLOSED,L%N )
626	nullify(L%NTHIN )
627	nullify(L%THIN )
628	nullify(L%LASTPOS ) ! POSITION OF LAST VISITED
629	nullify(L%LAST )! LAST VISITED
630	!
631	nullify(L%END )
632	nullify(L%START )
633	nullify(L%START_GROUND )! STORE THE GROUNDED VALUE OF START DURING CIRCULAR SCANNING
634	nullify(L%END_GROUND )! STORE THE GROUNDED VALUE OF END DURING CIRCULAR SCANNING
635	! nullify(L%NEXT )! STORE THE GROUNDED VALUE OF END DURING CIRCULAR SCANNING
636	! nullify(L%PREVIOUS )! STORE THE GROUNDED VALUE OF END DURING CIRCULAR SCANNING
637	! nullify(L%parent_universe ) ! left out
638	! else
639	! w_p=0
640	! w_p%nc=1
641	! w_p%fc='(1((1X,a72)))'
642	! w_p%c(1)= " Only =0 permitted (nullify) "
643	! ! call !write_e(100)
644	! endif
645	END SUBROUTINE nullIFY_LAYOUT
646
647
648
649	SUBROUTINE LINE_L(L,doneit) ! makes into line temporarily
650	implicit none
651	TYPE (layout), TARGET, intent(inout):: L
652	logical(lp) doneit
653	doneit=.false.
654	if(L%closed) then
655	if(associated(L%end%next)) then
656	L%end%next=>L%start_ground
657	doneit=.true.
658	endif
659	if(associated(L%start%previous)) then
660	L%start%previous=>L%end_ground
661	endif
662	endif
663	END SUBROUTINE LINE_L
664
665	SUBROUTINE RING_L(L,doit) ! Brings back to ring if needed
666	implicit none
667	TYPE (layout), TARGET, intent(inout):: L
668	logical(lp) doit
669	if(L%closed.and.doit) then
670	if(.NOT.(associated(L%end%next))) then
671	L%start_ground=>L%end%next ! saving grounded pointer
672	L%end%next=>L%start
673	endif
674	if(.NOT.(associated(L%start%previous))) then
675	L%end_ground=>L%start%previous ! saving grounded pointer
676	L%start%previous=>L%end
677	endif
678	endif
679	END SUBROUTINE RING_L
680
681
682	SUBROUTINE APPEND_POINT( L, el ) ! Appoints without cloning
683	implicit none
684	TYPE (fibre),POINTER :: el
685	TYPE (fibre), POINTER :: Current
686	TYPE (layout), TARGET, intent(inout):: L
687	! type(fibre), pointer :: p
688	logical(lp) doneit
689	TYPE(fibre_appearance), POINTER :: D
690	! nullify(p);
691	CALL LINE_L(L,doneit)
692	L%N=L%N+1
693	CALL ALLOCATE_FIBRE(Current);
694	ALLOCATE(Current%PATCH);
695
696
697	CURRENT%PARENT_LAYOUT=>L !
698	current%mag=>el%mag
699	current%magp=>el%magp
700	current%CHART=>el%CHART
701	current%PATCH=0 ! new patches always belong to fibre ! this was the error Weishi
702	IF(EL%PATCH%PATCH/=0) THEN
703	IF(.NOT.ASSOCIATED(CURRENT%PATCH)) CURRENT%PATCH=0
704	CALL COPY(EL%PATCH,current%PATCH)
705	ENDIF
706	! if(use_info) current%i=>el%i
707	if(use_info) then
708	allocate(current%i)
709	call alloc(current%i)
710	endif
711
712	ALLOCATE(current%DIR) !;
713	! ALLOCATE(current%P0C);
714	ALLOCATE(current%BETA0);
715	ALLOCATE(current%GAMMA0I);
716	ALLOCATE(current%GAMBET);
717	ALLOCATE(current%MASS);
718	ALLOCATE(current%AG);
719	ALLOCATE(current%CHARGE);
720	current%dir=el%dir
721	! current%P0C=el%P0C
722	current%BETA0=el%BETA0
723	current%GAMMA0I=el%GAMMA0I
724	current%GAMBET=el%GAMBET
725	current%MASS=el%MASS
726	current%AG=el%AG
727	current%CHARGE=el%CHARGE
728
729
730	ALLOCATE(Current%pos);
731	current%pos=l%n
732	! current%P0C=el%P0C
733	! current%BETA0=el%BETA0
734	if(L%N==1) current%next=> L%start
735	Current % previous => L % end ! point it to next fibre
736	if(L%N>1) THEN
737	L % end % next => current !
738	ENDIF
739
740	L % end => Current
741	if(L%N==1) L%start=> Current
742	if(.not.associated(current%pos)) allocate(current%pos)
743	current%pos=l%n
744
745	L%LASTPOS=L%N ;
746	L%LAST=>CURRENT;
747	CALL RING_L(L,doneit)
748
749	IF(.NOT.ASSOCIATED(CURRENT%MAG%DOKO)) THEN
750	ALLOCATE(CURRENT%MAG%DOKO)
751	NULLIFY(CURRENT%MAG%DOKO%NEXT)
752	CURRENT%MAG%DOKO%PARENT_FIBRE=>CURRENT
753	ELSE
754	D=>CURRENT%MAG%DOKO
755	DO WHILE(ASSOCIATED(D%NEXT))
756	D=>D%NEXT
757	ENDDO
758	ALLOCATE(D%NEXT)
759	D=>D%NEXT
760	D%PARENT_FIBRE=>CURRENT
761	NULLIFY(D%NEXT)
762	ENDIF
763
764	END SUBROUTINE APPEND_POINT
765
766
767
768
769	SUBROUTINE append_EMPTY_FIBRE( L ) ! Creates an empty fibre to be filled later
770	implicit none
771	TYPE (fibre), POINTER :: Current
772	TYPE (layout), TARGET, intent(inout):: L
773	L%N=L%N+1
774	CALL ALLOCATE_FIBRE(Current)
775	if(L%N==1) current%next=> L%start
776	Current % previous => L % end ! point it to next fibre
777	if(L%N>1) THEN
778	L%end%next => current !
779	ENDIF
780
781	L % end => Current
782	if(L%N==1) L%start=> Current
783	if(.not.associated(current%pos)) allocate(current%pos)
784	current%pos=l%n
785
786	L%LASTPOS=L%N ;
787	L%LAST=>CURRENT;
788	current%parent_layout=>L
789	END SUBROUTINE append_EMPTY_FIBRE
790
791	SUBROUTINE append_NOT_SO_EMPTY_FIBRE( L ) ! Creates an empty fibre to be filled later
792	implicit none
793	TYPE (fibre), POINTER :: Current
794	TYPE (layout), TARGET, intent(inout):: L
795	L%N=L%N+1
796	CALL ALLOC(Current)
797	if(L%N==1) current%next=> L%start
798	Current % previous => L % end ! point it to next fibre
799	if(L%N>1) THEN
800	L%end%next => current !
801	ENDIF
802
803	L % end => Current
804	if(L%N==1) L%start=> Current
805	if(.not.associated(current%pos)) allocate(current%pos)
806	current%pos=l%n
807
808	L%LASTPOS=L%N ;
809	L%LAST=>CURRENT;
810	current%parent_layout=>L
811	END SUBROUTINE append_NOT_SO_EMPTY_FIBRE
812
813	SUBROUTINE NULL_FIBRE(CURRENT) ! nullifies fibre content
814	implicit none
815	TYPE (fibre), TARGET, intent(inout):: Current
816	nullify(Current%dir); !nullify(Current%P0C);nullify(Current%BETA0);
817	nullify(Current%magp);nullify(Current%mag);nullify(Current%CHART);nullify(Current%PATCH);
818	nullify(current%next);nullify(current%previous);
819	nullify(current%PARENT_LAYOUT);
820	nullify(current%T1,current%T2,current%TM);
821	nullify(current%i,current%pos,current%loc);
822
823
824	! nullify(Current%P0C);
825	nullify(Current%BETA0);
826	nullify(Current%GAMMA0I);
827	nullify(Current%GAMBET);
828	nullify(Current%MASS);
829	nullify(Current%AG);
830	nullify(Current%CHARGE);
831
832	nullify(current%P,current%N);
833
834	! nullify(current%PARENT_CHART);nullify(current%PARENT_MAG);
835	END SUBROUTINE NULL_FIBRE
836
837	SUBROUTINE ALLOCATE_FIBRE(CURRENT) ! allocates and nullifies current's content
838	implicit none
839	TYPE (fibre), POINTER :: Current
840	NULLIFY(CURRENT)
841	ALLOCATE(Current)
842	CALL NULL_FIBRE(CURRENT)
843	END SUBROUTINE ALLOCATE_FIBRE
844
845	SUBROUTINE ALLOCATE_DATA_FIBRE(CURRENT) ! Allocates pointers in fibre
846	implicit none
847	TYPE (fibre), TARGET, intent(inout):: Current
848	ALLOCATE(Current%dir); ! ALLOCATE(Current%P0C);ALLOCATE(Current%BETA0);
849	ALLOCATE(Current%magp);ALLOCATE(Current%mag);
850
851	ALLOCATE(Current%CHART);
852	ALLOCATE(Current%PATCH);
853	ALLOCATE(Current%pos);
854
855	! ALLOCATE(Current%P0C);
856	ALLOCATE(Current%BETA0);
857	ALLOCATE(Current%GAMMA0I);
858	ALLOCATE(Current%GAMBET);
859	ALLOCATE(Current%MASS);
860	ALLOCATE(Current%AG);
861	ALLOCATE(Current%CHARGE);
862	if(use_info) then
863	allocate(Current%i)
864	call alloc(Current%i)
865	endif
866
867	END SUBROUTINE ALLOCATE_DATA_FIBRE
868
869	SUBROUTINE alloc_fibre( c ) ! Does the full allocation of fibre and initialization of internal variables
870	implicit none
871	type(fibre),pointer:: c
872	CALL ALLOCATE_FIBRE(C)
873	CALL ALLOCATE_DATA_FIBRE(C)
874	c%DIR=1
875	! C%P0C = ONE
876	C%BETA0 = 1.0_dp
877	C%GAMMA0I = 1.0_dp
878	C%GAMBET = 1.0_dp
879	C%MASS = 1.0_dp
880	C%MASS = A_particle
881	C%CHARGE = 1
882
883
884	! c%P0C=zero
885	! c%BETA0=zero
886	c%mag=0
887	c%magp=0
888	!if(associated(c%CHART))
889	c%CHART=0
890	!if(associated(c%PATCH))
891	c%PATCH=0
892	end SUBROUTINE alloc_fibre
893
894	SUBROUTINE zero_fibre( c,i ) ! Does the full allocation of fibre and initialization of internal variables
895	implicit none
896	type(fibre),target,intent(inout):: c
897	integer, intent(in) :: i
898	if(i==0) then
899	c%DIR=1
900	! C%P0C = ONE
901	C%BETA0 = 1.0_dp
902	C%GAMMA0I = 1.0_dp
903	C%GAMBET = 1.0_dp
904	C%MASS = 1.0_dp
905	C%ag = a_particle
906	C%CHARGE = 1
907	! c%P0C=zero
908	! c%BETA0=zero
909	c%mag=0
910	c%magp=0
911	if(associated(c%CHART)) c%CHART=0
912	if(associated(c%PATCH)) c%PATCH=0
913	elseif(i==-1) then
914	IF(ASSOCIATED(LC,c%mag%PARENT_FIBRE%PARENT_LAYOUT).or.superkill) THEN ! ORDINARY
915	IF(ASSOCIATED(c%magP)) then ! 2010_1
916	c%magp=-1;
917	deallocate(c%magP);
918	ENDIF
919	IF(ASSOCIATED(c%mag)) then ! 2010_1 changed order with above
920	c%mag=-1;
921	deallocate(c%mag);
922	ENDIF
923	IF(ASSOCIATED(c%CHART)) then !.AND.(.NOT.ASSOCIATED(c%PARENT_CHART))) THEN
924	C%CHART=-1
925	deallocate(c%CHART);
926	ENDIF
927	IF(ASSOCIATED(c%PATCH)) then !.AND.(.NOT.ASSOCIATED(c%PARENT_PATCH))) THEN
928	C%PATCH=-1
929	deallocate(c%PATCH);
930	ENDIF
931	ELSE ! POINTED LAYOUT
932	IF(.NOT.ASSOCIATED(c%mag%PARENT_FIBRE%CHART,c%CHART)) then
933	C%CHART=-1
934	deallocate(c%CHART);
935	ENDIF
936	IF(.NOT.ASSOCIATED(c%mag%PARENT_FIBRE%PATCH,c%PATCH)) then
937	C%PATCH=-1
938	deallocate(c%PATCH);
939	ENDIF
940	ENDIF
941
942	IF(ASSOCIATED(c%DIR)) THEN
943	deallocate(c%DIR);
944	ENDIF
945	! IF(ASSOCIATED(c%P0C)) THEN
946	! deallocate(c%P0C);
947	! ENDIF
948	IF(ASSOCIATED(c%BETA0)) THEN
949	deallocate(c%BETA0);
950	ENDIF
951	IF(ASSOCIATED(c%GAMMA0I)) THEN
952	deallocate(c%GAMMA0I);
953	ENDIF
954	IF(ASSOCIATED(c%GAMBET)) THEN
955	deallocate(c%GAMBET);
956	ENDIF
957	IF(ASSOCIATED(c%MASS)) THEN
958	deallocate(c%MASS);
959	ENDIF
960	IF(ASSOCIATED(c%ag)) THEN
961	deallocate(c%ag);
962	ENDIF
963	IF(ASSOCIATED(c%CHARGE)) THEN
964	deallocate(c%CHARGE);
965	ENDIF
966
967	! IF(ASSOCIATED(C%N)) nullify(C%N)
968	! IF(ASSOCIATED(C%P)) nullify(C%P)
969	nullify(C%N)
970	nullify(C%P)
971
972	!!! maybe missing per Sagan 2012.3.18
973	! IF(ASSOCIATED(C%T1)) THEN
974	! if(associated(C%T1,C%TM)) nullify(C%TM)
975	! deallocate(C%T1);
976	! deallocate(C%T2);
977	! ENDIF
978	nullify(C%T1,C%T2,C%Tm)
979	!!! maybe missing per Sagan 2012.3.18
980
981	IF(ASSOCIATED(c%pos)) THEN
982	deallocate(c%pos);
983	ENDIF
984	IF(ASSOCIATED(c%loc)) THEN
985	deallocate(c%loc);
986	ENDIF
987
988	IF(ASSOCIATED(C%TM)) deallocate(C%TM);
989
990	IF(ASSOCIATED(c%i).and.use_info) THEN
991	call kill(c%i);
992	deallocate(c%i);
993	ENDIF
994
995	else
996	w_p=0
997	w_p%nc=1
998	w_p%fc='(1((1X,a72)))'
999	w_p%c(1)= "Error in zero_fibre "
1000	! call !write_e(100)
1001	endif
1002	end SUBROUTINE zero_fibre
1003
1004	SUBROUTINE SUPER_zero_fibre( c,i ) ! Does the full allocation of fibre and initialization of internal variables
1005	implicit none
1006	type(fibre),target,intent(inout):: c
1007	integer, intent(in) :: i
1008	if(i==0) then
1009	c%DIR=1
1010	! C%P0C = ONE
1011	C%BETA0 = 1.0_dp
1012	C%GAMMA0I = 1.0_dp
1013	C%GAMBET = 1.0_dp
1014	C%MASS = 1.0_dp
1015	C%ag = a_particle
1016	C%CHARGE = 1
1017	! c%P0C=zero
1018	! c%BETA0=zero
1019	c%mag=0
1020	c%magp=0
1021	if(associated(c%CHART)) c%CHART=0
1022	if(associated(c%PATCH)) c%PATCH=0
1023	elseif(i==-1) then
1024	! IF(ASSOCIATED(c%mag)) then !.AND.(.NOT.ASSOCIATED(c%PARENT_MAG))) THEN
1025	c%mag=-1;
1026	deallocate(c%mag);
1027	! ENDIF
1028	! IF(ASSOCIATED(c%magP)) then !.AND.(.NOT.ASSOCIATED(c%PARENT_MAG))) THEN
1029	c%magp=-1;
1030	deallocate(c%magP);
1031	! ENDIF
1032	! IF(ASSOCIATED(c%CHART)) then !.AND.(.NOT.ASSOCIATED(c%PARENT_CHART))) THEN
1033	C%CHART=-1
1034	deallocate(c%CHART);
1035	! ENDIF
1036	! IF(ASSOCIATED(c%PATCH)) then !.AND.(.NOT.ASSOCIATED(c%PARENT_PATCH))) THEN
1037	C%PATCH=-1
1038	deallocate(c%PATCH);
1039	! ENDIF
1040
1041
1042	! IF(ASSOCIATED(c%DIR)) THEN
1043	deallocate(c%DIR);
1044	! ENDIF
1045	! IF(ASSOCIATED(c%BETA0)) THEN
1046	deallocate(c%BETA0);
1047	! ENDIF
1048	! IF(ASSOCIATED(c%GAMMA0I)) THEN
1049	deallocate(c%GAMMA0I);
1050	! ENDIF
1051	! IF(ASSOCIATED(c%GAMBET)) THEN
1052	deallocate(c%GAMBET);
1053	! ENDIF
1054	! IF(ASSOCIATED(c%MASS)) THEN
1055	deallocate(c%MASS);
1056	deallocate(c%ag);
1057	! ENDIF
1058	! IF(ASSOCIATED(c%CHARGE)) THEN
1059	deallocate(c%CHARGE);
1060	! ENDIF
1061	! IF(ASSOCIATED(C%N)) nullify(C%N)
1062	! IF(ASSOCIATED(C%P)) nullify(C%P)
1063	nullify(C%N)
1064	nullify(C%P)
1065
1066	IF(ASSOCIATED(C%T1)) THEN
1067	deallocate(C%T1);
1068	deallocate(C%T2);
1069	deallocate(C%TM);
1070	ENDIF
1071	IF(ASSOCIATED(c%i)) THEN
1072	call kill(c%i);
1073	deallocate(c%i);
1074	ENDIF
1075	! IF(ASSOCIATED(c%pos)) THEN
1076	deallocate(c%pos);
1077	! ENDIF
1078	IF(ASSOCIATED(c%loc)) deallocate(c%loc);
1079
1080	else
1081	w_p=0
1082	w_p%nc=1
1083	w_p%fc='(1((1X,a72)))'
1084	w_p%c(1)= "Error in zero_fibre "
1085	! call !write_e(100)
1086	endif
1087	end SUBROUTINE SUPER_zero_fibre
1088
1089
1090
1091
1092	SUBROUTINE dealloc_fibre( c ) ! destroys internal data if it is not pointing (i.e. not a parent)
1093	implicit none
1094	type(fibre),pointer :: c
1095	IF(ASSOCIATED(C)) THEN
1096	CALL zero_fibre(c,-1)
1097	deallocate(c);
1098	ENDIF
1099	end SUBROUTINE dealloc_fibre
1100
1101	SUBROUTINE super_dealloc_fibre( c ) ! destroys internal data if it is not pointing (i.e. not a parent)
1102	implicit none
1103	type(fibre),pointer :: c
1104	IF(ASSOCIATED(C)) THEN
1105	CALL super_zero_fibre(c,-1)
1106	deallocate(c);
1107	ENDIF
1108	end SUBROUTINE super_dealloc_fibre
1109
1110	! MORE FUNNY APPENDING
1111	SUBROUTINE APPEND_FLAT( L, el, NAME ) ! points unless called "name" in which case it clones
1112	implicit none
1113	TYPE (layout), TARGET, intent(inout):: L
1114	TYPE (fibre), POINTER :: el
1115	CHARACTER(*) NAME
1116	CHARACTER(nlp) NAME1
1117
1118	NAME1=NAME
1119	CALL CONTEXT(NAME1)
1120
1121	IF(EL%MAG%NAME==NAME1) THEN !FULL CLONING
1122	CALL APPEND(L,EL)
1123	ELSE ! FULL POINTING
1124	CALL APPEND_POINT(L,EL)
1125	ENDIF
1126	END SUBROUTINE APPEND_FLAT
1127
1128
1129	! EUCLIDEAN ROUTINES
1130	SUBROUTINE CHECK_NEED_PATCH(EL1,EL2_NEXT,PREC,PATCH_NEEDED) ! check need of PATCHES
1131	IMPLICIT NONE
1132	TYPE (FIBRE), TARGET,INTENT(IN) :: EL1
1133	TYPE (FIBRE),TARGET,OPTIONAL, INTENT(INOUT) :: EL2_NEXT
1134	TYPE (FIBRE),POINTER :: EL2
1135	REAL(DP) D(3),ANG(3)
1136	REAL(DP) ENT(3,3),EXI(3,3),ENT0(3,3),EXI0(3,3)
1137	REAL(DP), POINTER,DIMENSION(:)::A,B
1138	INTEGER DIR
1139	REAL(DP) PREC
1140	INTEGER A_YZ,A_XZ
1141	LOGICAL(LP) DISCRETE,ene
1142	INTEGER I,PATCH_NEEDED
1143	REAL(DP) NORM,pix(3)
1144
1145	PATCH_NEEDED=0
1146	pix=0.0_dp
1147	pix(1)=pi
1148	DIR=1
1149	DISCRETE=.FALSE.
1150	ANG=0.0_dp
1151	D=0.0_dp
1152
1153	IF(PRESENT(EL2_NEXT)) THEN
1154	EL2=>EL2_NEXT
1155	ELSE
1156	EL2=>EL1%NEXT
1157	ENDIF
1158
1159
1160
1161	IF(EL1%DIR*EL2%DIR==1) THEN ! 1
1162	IF(EL1%DIR==1) THEN
1163	EXI=EL1%CHART%F%EXI
1164	B=>EL1%CHART%F%B
1165	ENT=EL2%CHART%F%ENT
1166	A=>EL2%CHART%F%A
1167	A_XZ=1;A_YZ=1;
1168	ELSE
1169	EXI=EL1%CHART%F%ENT
1170	exi0=exi
1171	call geo_rot(exi,pix,1,basis=exi0)
1172	B=>EL1%CHART%F%A
1173	ENT=EL2%CHART%F%EXI
1174	ent0=ent
1175	call geo_rot(ent,pix,1,basis=ent0)
1176	A=>EL2%CHART%F%B
1177	! A_XZ=1;A_YZ=1;
1178	A_XZ=-1;A_YZ=-1;
1179	ENDIF
1180	ELSE ! 1
1181	IF(EL1%DIR==1) THEN
1182	EXI=EL1%CHART%F%EXI
1183	B=>EL1%CHART%F%B
1184	ENT=EL2%CHART%F%EXI
1185	ent0=ent
1186	call geo_rot(ent,pix,1,basis=ent0)
1187	A=>EL2%CHART%F%B
1188	A_XZ=1;A_YZ=-1;
1189	ELSE
1190	EXI=EL1%CHART%F%ENT
1191	exi0=exi
1192	call geo_rot(exi,pix,1,basis=exi0)
1193	B=>EL1%CHART%F%A
1194	ENT=EL2%CHART%F%ENT
1195	A=>EL2%CHART%F%A
1196	A_XZ=-1;A_YZ=1;
1197	ENDIF
1198	ENDIF ! 1
1199
1200	CALL FIND_PATCH(B,EXI,A,ENT,D,ANG)
1201
1202	NORM=0.0_dp
1203	DO I=1,3
1204	NORM=NORM+ABS(D(I))
1205	ENDDO
1206	IF(NORM>=PREC) THEN
1207	D=0.0_dp
1208	PATCH_NEEDED=PATCH_NEEDED+1
1209	ENDIF
1210	NORM=0.0_dp
1211	DO I=1,3
1212	NORM=NORM+ABS(ANG(I))
1213	ENDDO
1214	ene=(NORM<=PREC.and.(A_XZ==1.and.A_YZ==1)).or.(NORM<=PREC.and.(A_XZ==-1.and.A_YZ==-1))
1215	IF(.not.ene) THEN
1216	ANG=0.0_dp
1217	PATCH_NEEDED=PATCH_NEEDED+10
1218	ENDIF
1219
1220
1221	if(ABS((EL2%MAG%P%P0C-EL1%MAG%P%P0C)/EL1%MAG%P%P0C)>PREC) PATCH_NEEDED=PATCH_NEEDED+100
1222
1223
1224	DISCRETE=.false.
1225	IF(ANG(1)/TWOPI<-0.25_dp) THEN
1226	DISCRETE=.TRUE.
1227	ENDIF
1228	IF(ANG(1)/TWOPI>0.25_dp) THEN
1229	DISCRETE=.TRUE.
1230	ENDIF
1231	IF(ANG(2)/TWOPI<-0.25_dp) THEN
1232	DISCRETE=.TRUE.
1233	ENDIF
1234	IF(ANG(1)/TWOPI>0.25_dp) THEN
1235	DISCRETE=.TRUE.
1236	ENDIF
1237
1238	! IF(DISCRETE) THEN
1239	! WRITE(6,*) " NO GEOMETRIC PATCHING POSSIBLE : MORE THAN 90 DEGREES BETWEEN FACES "
1240	! STOP 1123
1241	! ENDIF
1242
1243	if(discrete) then
1244	PATCH_NEEDED=PATCH_NEEDED-1000
1245	endif
1246
1247	norm=abs(el1%mag%p%p0c-el2%mag%p%p0c)
1248	ene=(norm>prec)
1249
1250	if(ene) then
1251	PATCH_NEEDED=PATCH_NEEDED+100
1252	endif
1253
1254	END SUBROUTINE CHECK_NEED_PATCH
1255
1256	SUBROUTINE remove_patch(r,geometry,energy) ! check need of PATCHES
1257	IMPLICIT NONE
1258	TYPE (layout), target :: r
1259	TYPE (FIBRE), pointer :: p
1260	integer i
1261	logical(lp), optional :: geometry,energy
1262	logical(lp) g,e
1263
1264	g=my_true
1265	e=my_true
1266
1267	if(present(energy)) e=energy
1268	if(present(geometry)) g=geometry
1269
1270	p=>r%start
1271
1272	do i=1,r%n
1273	if(g) p%patch%patch=0
1274	if(e) p%patch%energy=0
1275	p=>p%next
1276	enddo
1277
1278
1279	end SUBROUTINE remove_patch
1280
1281	SUBROUTINE FIND_PATCH_P_new(EL1,EL2_NEXT,D,ANG,DIR,ENERGY_PATCH,PREC) ! COMPUTES PATCHES
1282	IMPLICIT NONE
1283	TYPE (FIBRE), INTENT(INOUT) :: EL1
1284	TYPE (FIBRE),TARGET,OPTIONAL, INTENT(INOUT) :: EL2_NEXT
1285	TYPE (FIBRE),POINTER :: EL2
1286	REAL(DP), INTENT(INOUT) :: D(3),ANG(3)
1287	REAL(DP) ENT(3,3),EXI(3,3),ENT0(3,3),EXI0(3,3)
1288	REAL(DP), POINTER,DIMENSION(:)::A,B
1289	INTEGER, INTENT(IN) :: DIR
1290	LOGICAL(LP), OPTIONAL, INTENT(IN) :: ENERGY_PATCH
1291	REAL(DP), OPTIONAL, INTENT(IN) :: PREC
1292	INTEGER A_YZ,A_XZ
1293	LOGICAL(LP) ENE,DOIT,DISCRETE
1294	INTEGER LOC,I,PATCH_NEEDED
1295	REAL(DP) NORM,pix(3)
1296	PATCH_NEEDED=1
1297	pix=0.0_dp
1298	pix(1)=pi
1299
1300	DISCRETE=.FALSE.
1301	IF(PRESENT(EL2_NEXT)) THEN
1302	LOC=-1
1303	EL2=>EL2_NEXT
1304	ELSE
1305	LOC=1
1306	EL2=>EL1%NEXT
1307	ENDIF
1308	ENE=.FALSE.
1309	IF(PRESENT(ENERGY_PATCH)) ENE=ENERGY_PATCH
1310	DOIT=ASSOCIATED(EL1%CHART%F).AND.ASSOCIATED(EL2%CHART%F)
1311	IF(DIR==1) THEN
1312	DOIT=DOIT.AND.(ASSOCIATED(EL2%PATCH))
1313	ELSE
1314	DOIT=DOIT.AND.(ASSOCIATED(EL1%PATCH))
1315	ENDIF
1316	IF(DOIT) THEN
1317	IF(EL1%DIR*EL2%DIR==1) THEN ! 1
1318	IF(EL1%DIR==1) THEN
1319	EXI=EL1%CHART%F%EXI
1320	B=>EL1%CHART%F%B
1321	ENT=EL2%CHART%F%ENT
1322	A=>EL2%CHART%F%A
1323	A_XZ=1;A_YZ=1;
1324	ELSE
1325	EXI=EL1%CHART%F%ENT
1326	exi0=exi
1327	call geo_rot(exi,pix,1,basis=exi0)
1328	B=>EL1%CHART%F%A
1329	ENT=EL2%CHART%F%EXI
1330	ent0=ent
1331	call geo_rot(ent,pix,1,basis=ent0)
1332	A=>EL2%CHART%F%B
1333	! A_XZ=1;A_YZ=1;
1334	A_XZ=-1;A_YZ=-1;
1335	ENDIF
1336	ELSE ! 1
1337	IF(EL1%DIR==1) THEN
1338	EXI=EL1%CHART%F%EXI
1339	B=>EL1%CHART%F%B
1340	ENT=EL2%CHART%F%EXI
1341	ent0=ent
1342	call geo_rot(ent,pix,1,basis=ent0)
1343	A=>EL2%CHART%F%B
1344	A_XZ=1;A_YZ=-1;
1345	ELSE
1346	EXI=EL1%CHART%F%ENT
1347	exi0=exi
1348	call geo_rot(exi,pix,1,basis=exi0)
1349	B=>EL1%CHART%F%A
1350	ENT=EL2%CHART%F%ENT
1351	A=>EL2%CHART%F%A
1352	A_XZ=-1;A_YZ=1;
1353	ENDIF
1354	ENDIF ! 1
1355
1356	CALL FIND_PATCH(B,EXI,A,ENT,D,ANG)
1357
1358	IF(PRESENT(PREC)) THEN
1359	NORM=0.0_dp
1360	DO I=1,3
1361	NORM=NORM+ABS(D(I))
1362	ENDDO
1363	IF(NORM<=PREC) THEN
1364	D=0.0_dp
1365	PATCH_NEEDED=PATCH_NEEDED+1
1366	ENDIF
1367	NORM=0.0_dp
1368	DO I=1,3
1369	NORM=NORM+ABS(ANG(I))
1370	ENDDO
1371	IF(NORM<=PREC.and.(A_XZ==1.and.A_YZ==1)) THEN
1372	ANG=0.0_dp
1373	PATCH_NEEDED=PATCH_NEEDED+1
1374	ELSEIF(NORM<=PREC.and.(A_XZ==-1.and.A_YZ==-1)) THEN ! added 2008.6.18
1375	ANG=0.0_dp
1376	PATCH_NEEDED=PATCH_NEEDED+1
1377	ENDIF
1378	IF(PATCH_NEEDED==3) THEN
1379	PATCH_NEEDED=0
1380	ELSE
1381	PATCH_NEEDED=1
1382	ENDIF
1383	ENDIF
1384	if(PRESENT(PREC)) then
1385	norm=abs(el1%mag%p%p0c-el2%mag%p%p0c)
1386	ene=ene.and.(norm>prec)
1387	endif
1388
1389	IF(DIR==1) THEN
1390
1391	EL2%PATCH%A_X2=A_YZ
1392	EL2%PATCH%A_X1=A_XZ
1393	EL2%PATCH%A_D=D
1394	EL2%PATCH%A_ANG=ANG
1395	SELECT CASE(EL2%PATCH%PATCH)
1396	CASE(it0,it1)
1397	EL2%PATCH%PATCH=1*PATCH_NEEDED
1398	CASE(it2,it3)
1399	EL2%PATCH%PATCH=PATCH_NEEDED + 2 ! etienne 2008.05.29
1400	END SELECT
1401	IF(ENE) THEN
1402
1403	SELECT CASE(EL2%PATCH%ENERGY)
1404	CASE(it0,it1)
1405	EL2%PATCH%ENERGY=1
1406	CASE(it2,it3)
1407	EL2%PATCH%ENERGY=3
1408	END SELECT
1409	ENDIF
1410
1411	ELSEIF(DIR==-1) THEN
1412
1413	EL1%PATCH%B_X2=A_YZ ! BUG WAS EL2
1414	EL1%PATCH%B_X1=A_XZ !
1415	EL1%PATCH%B_D=D
1416	EL1%PATCH%B_ANG=ANG
1417	SELECT CASE(EL1%PATCH%PATCH)
1418	CASE(it0,it2)
1419	EL1%PATCH%PATCH=2*PATCH_NEEDED
1420	CASE(it1,it3)
1421	EL1%PATCH%PATCH=2*PATCH_NEEDED + 1 ! etienne 2008.05.29
1422	END SELECT
1423	IF(ENE) THEN
1424	SELECT CASE(EL2%PATCH%ENERGY)
1425	CASE(it0,it2)
1426	EL1%PATCH%ENERGY=2
1427	CASE(it1,it3)
1428	EL1%PATCH%ENERGY=3
1429	END SELECT
1430	ENDIF
1431	ENDIF
1432	ELSE ! NO FRAME
1433
1434	W_P=0
1435	W_P%NC=3
1436	W_P%FC='(2(1X,A72,/),(1X,A72))'
1437	W_P%C(1)= " NO GEOMETRIC PATCHING POSSIBLE : EITHER NO FRAMES IN PTC OR NO PATCHES "
1438	WRITE(W_P%C(2),'(A16,1X,L1,1X,L1)') " CHARTS 1 AND 2 ", ASSOCIATED(EL1%CHART%F), ASSOCIATED(EL2%CHART%F)
1439	WRITE(W_P%C(3),'(A16,1X,L1,1X,L1)') "PATCHES 1 AND 2 ", ASSOCIATED(EL1%PATCH), ASSOCIATED(EL2%PATCH)
1440	! call ! WRITE_I
1441
1442	IF(DIR==1) THEN
1443
1444	IF(ASSOCIATED(EL2%PATCH)) THEN
1445	IF(ENE) THEN
1446	SELECT CASE(EL2%PATCH%ENERGY)
1447	CASE(it0,it1)
1448	EL2%PATCH%ENERGY=1
1449	CASE(it2,it3)
1450	EL2%PATCH%ENERGY=3
1451	END SELECT
1452	ENDIF
1453	ELSE
1454	W_P=0
1455	W_P%NC=1
1456	W_P%FC='((1X,A72))'
1457	W_P%C(1)= " NOT EVEN ENERGY PATCH POSSIBLE ON ELEMENT 2 "
1458	! call ! WRITE_I
1459	ENDIF
1460
1461	ELSEIF(DIR==-1) THEN
1462
1463	IF(ASSOCIATED(EL2%PATCH)) THEN
1464	IF(ENE) THEN
1465	SELECT CASE(EL2%PATCH%ENERGY)
1466	CASE(it0,it2)
1467	EL1%PATCH%ENERGY=2
1468	CASE(it1,it3)
1469	EL1%PATCH%ENERGY=3
1470	END SELECT
1471	ENDIF
1472	ELSE
1473	W_P=0
1474	W_P%NC=1
1475	W_P%FC='((1X,A72))'
1476	W_P%C(1)= " NOT EVEN ENERGY PATCH POSSIBLE ON ELEMENT 1 "
1477	! call ! WRITE_I
1478	ENDIF
1479	ENDIF
1480
1481	ENDIF
1482
1483	DISCRETE=.false.
1484	IF(ANG(1)/TWOPI<-0.25_dp) THEN
1485	DISCRETE=.TRUE.
1486	ENDIF
1487	IF(ANG(1)/TWOPI>0.25_dp) THEN
1488	DISCRETE=.TRUE.
1489	ENDIF
1490	IF(ANG(2)/TWOPI<-0.25_dp) THEN
1491	DISCRETE=.TRUE.
1492	ENDIF
1493	IF(ANG(1)/TWOPI>0.25_dp) THEN
1494	DISCRETE=.TRUE.
1495	ENDIF
1496
1497	IF(DISCRETE) THEN
1498	W_P=0
1499	W_P%NC=1
1500	W_P%FC='(2(1X,A72,/),(1X,A72))'
1501	W_P%C(1)= " NO GEOMETRIC PATCHING POSSIBLE : MORE THAN 90 DEGREES BETWEEN FACES "
1502	! call ! WRITE_I
1503	ENDIF
1504
1505
1506	END SUBROUTINE FIND_PATCH_P_new
1507
1508	SUBROUTINE FIND_PATCH_0(EL1,EL2_NEXT,NEXT,ENERGY_PATCH,PREC) ! COMPUTES PATCHES
1509	IMPLICIT NONE
1510	TYPE (FIBRE),pointer :: EL1
1511	TYPE (FIBRE),TARGET,OPTIONAL, INTENT(INOUT) :: EL2_NEXT
1512	TYPE (FIBRE),POINTER :: EL2
1513	REAL(DP) D(3),ANG(3)
1514	REAL(DP), OPTIONAL :: PREC
1515	LOGICAL(LP), OPTIONAL, INTENT(IN) :: NEXT,ENERGY_PATCH
1516	INTEGER DIR
1517	LOGICAL(LP) ENE,NEX
1518
1519	IF(PRESENT(EL2_NEXT)) THEN
1520	EL2=>EL2_NEXT
1521	ELSE
1522	EL2=>EL1%NEXT
1523	ENDIF
1524	NEX=.FALSE.
1525	ENE=.FALSE.
1526	IF(PRESENT(NEXT)) NEX=NEXT
1527
1528	if(associated(el1,el1%parent_layout%start)) then
1529	if(.not.nex) then
1530	nex=my_true
1531	endif
1532	endif
1533	if(associated(el1%next,el1%parent_layout%start)) then
1534	if(nex) then
1535	nex=my_false
1536	endif
1537	endif
1538
1539	el1%PATCH%B_X1=1
1540	el1%PATCH%B_X2=1
1541	el1%PATCH%B_D=0.0_dp
1542	el1%PATCH%B_ANG=0.0_dp
1543	el1%PATCH%B_T=0.0_dp
1544
1545	EL2%PATCH%A_X1=1
1546	EL2%PATCH%A_X2=1
1547	EL2%PATCH%A_D=0.0_dp
1548	EL2%PATCH%A_ANG=0.0_dp
1549	EL2%PATCH%A_T=0.0_dp
1550
1551	if(el1%PATCH%patch==3) then
1552	el1%PATCH%patch=1
1553	elseIF(el1%PATCH%patch==2) then
1554	el1%PATCH%patch=0
1555	endif
1556
1557	if(el1%PATCH%energy==3) then
1558	el1%PATCH%ENERGY=1
1559	elseIF(el1%PATCH%energy==2) then
1560	el1%PATCH%ENERGY=0
1561	endif
1562
1563	if(el1%PATCH%time==3) then
1564	el1%PATCH%time=1
1565	elseIF(el1%PATCH%time==2) then
1566	el1%PATCH%time=0
1567	endif
1568
1569
1570	if(EL2%PATCH%patch==3) then
1571	EL2%PATCH%patch=2
1572	elseIF(EL2%PATCH%patch==1) then
1573	EL2%PATCH%patch=0
1574	endif
1575
1576	if(EL2%PATCH%energy==3) then
1577	EL2%PATCH%ENERGY=2
1578	elseIF(EL2%PATCH%energy==1) then
1579	EL2%PATCH%ENERGY=0
1580	endif
1581
1582	if(EL2%PATCH%time==3) then
1583	EL2%PATCH%time=2
1584	elseIF(EL2%PATCH%time==1) then
1585	EL2%PATCH%time=0
1586	endif
1587
1588	IF(PRESENT(ENERGY_PATCH)) then
1589	ENE=ENERGY_PATCH
1590	else
1591	if(ABS((EL2%MAG%P%P0C-EL1%MAG%P%P0C)/EL1%MAG%P%P0C)>eps_fitted) ENE=.TRUE.
1592	endif
1593	DIR=-1 ; IF(NEX) DIR=1;
1594	D=0.0_dp;ANG=0.0_dp;
1595
1596	CALL FIND_PATCH_P_new(EL1,EL2,D,ANG,DIR,ENERGY_PATCH=ENE,prec=PREC)
1597
1598
1599	END SUBROUTINE FIND_PATCH_0
1600
1601
1602	! UNIVERSE STUFF
1603
1604	SUBROUTINE Set_Up_UNIVERSE( L ) ! Sets up a layout: gives a unique negative index
1605	implicit none
1606	TYPE (MAD_UNIVERSE), TARGET, intent(inout):: L
1607	CALL NULLIFY_UNIVERSE(L)
1608	ALLOCATE(L%n);
1609	ALLOCATE(L%SHARED);
1610	ALLOCATE(L%LASTPOS);
1611	ALLOCATE(L%NF);
1612	L%N=0;
1613	L%SHARED=0;
1614	L%LASTPOS=0;
1615	L%NF=0;
1616	END SUBROUTINE Set_Up_UNIVERSE
1617
1618	SUBROUTINE kill_last_layout( L ) ! Destroys a layout
1619	implicit none
1620	TYPE (LAYOUT), POINTER :: Current,Current1
1621	TYPE (MAD_UNIVERSE), TARGET, intent(inout):: L
1622	nullify(current)
1623	nullify(current1)
1624	Current => L % end ! end at the end
1625	! DO WHILE (ASSOCIATED(L % end))
1626	Current1 => L % end ! end at the end
1627	L % end => Current % previous ! update the end before disposing
1628	call kill_layout(Current)
1629	Current => L % end ! alias of last fibre again
1630	L%N=L%N-1
1631	deallocate(Current1)
1632	! END DO
1633	! call de_Set_Up_UNIVERSE(L)
1634	END SUBROUTINE kill_last_layout
1635
1636	SUBROUTINE kill_UNIVERSE( L ) ! Destroys a layout
1637	implicit none
1638	TYPE (LAYOUT), POINTER :: Current,Current1
1639	TYPE (MAD_UNIVERSE), TARGET, intent(inout):: L
1640	nullify(current)
1641	nullify(current1)
1642	Current => L % end ! end at the end
1643	DO WHILE (ASSOCIATED(L % end))
1644	Current1 => L % end ! end at the end
1645	L % end => Current % previous ! update the end before disposing
1646	! WRITE(6,*) ' killing last layout '
1647	call kill_layout(Current)
1648	! WRITE(6,*) ' killed last layout '
1649	Current => L % end ! alias of last fibre again
1650	L%N=L%N-1
1651	deallocate(Current1)
1652	END DO
1653	call de_Set_Up_UNIVERSE(L)
1654	END SUBROUTINE kill_UNIVERSE
1655
1656	SUBROUTINE kill_layout_in_universe( L ) ! Destroys a layout
1657	implicit none
1658	TYPE (LAYOUT), POINTER :: L,C1,c2
1659	TYPE (MAD_UNIVERSE), pointer :: u
1660
1661	if(.not.associated(l)) then
1662	write(6,*) " There is nothing to kill "
1663	return
1664	endif
1665
1666
1667	u=>l%parent_universe
1668
1669	if(u%nf/=0) then
1670	write(6,*) " You cannot kill a layout in a tied Universe "
1671	return
1672	endif
1673
1674	if(associated(u%start,u%end)) then
1675	call kill_layout(u%start)
1676	call de_Set_Up_UNIVERSE(u)
1677	call Set_Up_UNIVERSE(u)
1678	! write(6,*) " 1 "
1679	return
1680	elseif(u%n==2) then
1681	if(associated(l,u%start)) then
1682	call kill_layout(L)
1683	u%start=>u%end
1684	! write(6,*) " start 2"
1685	else
1686	call kill_layout(L)
1687	u%end=>u%start
1688	endif
1689	u%n=1
1690	! write(6,*) " end 2"
1691	return
1692	endif
1693
1694	if(associated(l,u%start)) then
1695	C1=>l%next
1696	call kill_layout(L)
1697	u%start=>c1
1698	! write(6,*) " start >2"
1699	elseif (associated(l,u%end)) then
1700	C1=>l%previous
1701	call kill_layout(L)
1702	u%end=>c1
1703	! write(6,*) " end >2"
1704	else
1705	C1=>l%previous
1706	C2=>l%next
1707	call kill_layout(L)
1708	c1%next=>c2
1709	c2%previous=>c1
1710	! write(6,*) " middle >2"
1711
1712	endif
1713
1714	u%n=u%n-1
1715	END SUBROUTINE kill_layout_in_universe
1716
1717	SUBROUTINE FIND_POS_in_universe(C,i ) ! Finds the location "i" of the fibre C in layout L
1718	implicit none
1719	INTEGER, INTENT(INOUT) :: I
1720	TYPE (layout), POINTER :: C
1721	TYPE (layout), POINTER :: P
1722	NULLIFY(P);
1723	P=>C
1724	I=0
1725	DO WHILE(ASSOCIATED(P))
1726	I=I+1
1727	P=>P%PREVIOUS
1728	ENDDO
1729	END SUBROUTINE FIND_POS_in_universe
1730
1731	SUBROUTINE MOVE_TO_LAYOUT_I( L,current,i ) ! Moves current to the i^th position
1732	implicit none
1733	TYPE (LAYOUT), POINTER :: Current
1734	TYPE (MAD_UNIVERSE), TARGET, intent(inout):: L
1735	integer i,k
1736
1737	nullify(current);
1738	Current => L%START
1739	IF(I<=L%N) THEN
1740	DO K=1,I-1
1741	CURRENT=>CURRENT%NEXT
1742	ENDDO
1743	ELSE
1744	WRITE(6,*) "FATAL ERROR IN MOVE_TO_LAYOUT_I ",I,L%N
1745	STOP 900
1746	ENDIF
1747	END SUBROUTINE MOVE_TO_LAYOUT_I
1748
1749
1750	SUBROUTINE MOVE_TO_LAYOUT_name( L,current,name ) ! Moves current to the i^th position
1751	implicit none
1752	TYPE (LAYOUT), POINTER :: Current
1753	TYPE (MAD_UNIVERSE), TARGET, intent(inout):: L
1754	integer i,k
1755	character(120) name,name1
1756
1757	name1=name
1758	call context(name1)
1759
1760
1761	nullify(current);
1762	do i=1,l%n
1763	Current => L%START
1764	call context(current%name)
1765	IF(current%NAME==NAME1) RETURN
1766	IF(I<=L%N) THEN
1767	DO K=1,I-1
1768	CURRENT=>CURRENT%NEXT
1769	call context(current%name)
1770	IF(current%NAME==NAME1) RETURN
1771	ENDDO
1772	ELSE
1773	WRITE(6,*) "FATAL ERROR IN MOVE_TO_LAYOUT_I ",I,L%N
1774	STOP 900
1775	ENDIF
1776	enddo
1777	END SUBROUTINE MOVE_TO_LAYOUT_name
1778
1779	SUBROUTINE de_Set_Up_UNIVERSE( L ) ! deallocates layout content
1780	implicit none
1781	TYPE (MAD_UNIVERSE), TARGET, intent(inout):: L
1782	deallocate(L%n);
1783	deallocate(L%SHARED);
1784	deallocate(L%NF);
1785	deallocate(L%LASTPOS);
1786	END SUBROUTINE de_Set_Up_UNIVERSE
1787
1788	SUBROUTINE nullIFY_UNIVERSE( L ) ! Nullifies layout content,i
1789	implicit none
1790	TYPE (MAD_UNIVERSE), TARGET, intent(inout):: L
1791	nullify(L%N)
1792	nullify(L%SHARED)
1793
1794	nullify(L%END )! STORE THE GROUNDED VALUE OF END DURING CIRCULAR SCANNING
1795	nullify(L%START )! STORE THE GROUNDED VALUE OF END DURING CIRCULAR SCANNING
1796	nullify(L%NF ) ! POSITION OF LAST VISITED
1797	nullify(L%LASTPOS ) ! POSITION OF LAST VISITED
1798	nullify(L%LAST )! LAST VISITED
1799
1800	END SUBROUTINE nullIFY_UNIVERSE
1801
1802
1803	SUBROUTINE APPEND_EMPTY_LAYOUT( L ) ! Appoints without cloning
1804	implicit none
1805	TYPE (MAD_UNIVERSE), TARGET, intent(inout):: L
1806	TYPE (LAYOUT),POINTER :: current
1807	nullify(current);
1808	L%N=L%N+1
1809
1810	allocate(current)
1811	CALL SET_UP(current)
1812	current%parent_universe=>L
1813
1814	if(L%N==1) then
1815	L%start=>current
1816	L%end=>current
1817	nullify(current%previous)
1818	nullify(current%next)
1819	return
1820	endif
1821	Current % previous => L % end ! point it to next fibre
1822	L % end % next => current !
1823
1824	L % end => Current
1825
1826	END SUBROUTINE APPEND_EMPTY_LAYOUT
1827
1828
1829	SUBROUTINE locate_in_universe(F,i,j)
1830	IMPLICIT NONE
1831	integer i,j
1832	TYPE(FIBRE),pointer :: F
1833
1834
1835	call FIND_POS(f%mag%PARENT_FIBRE%parent_layout, f%mag%PARENT_FIBRE,j )
1836
1837	call FIND_POS( f%mag%PARENT_FIBRE%parent_layout,i )
1838
1839
1840	END SUBROUTINE locate_in_universe
1841
1842	SUBROUTINE FIND_POS_in_layout(L, C,i ) ! Finds the location "i" of the fibre C in layout L
1843	implicit none
1844	INTEGER, INTENT(INOUT) :: I
1845	TYPE(LAYOUT) L
1846	TYPE (fibre), POINTER :: C
1847	TYPE (fibre), POINTER :: P
1848	NULLIFY(P);
1849
1850	! CALL LINE_L(L,doneit) ! TGV
1851	I=0
1852	IF(ASSOCIATED(C,L%START)) THEN
1853	I=1
1854	RETURN
1855	ENDIF
1856	P=>L%start%NEXT
1857	I=2
1858	DO WHILE(.NOT.ASSOCIATED(P,C))
1859	I=I+1
1860	P=>P%NEXT
1861	if(i>1000000) then
1862	write(6,*) " not found in FIND_POS_in_layout "
1863	i=0
1864	exit
1865	endif
1866	ENDDO
1867
1868	! CALL RING_L(L,doneit)
1869	END SUBROUTINE FIND_POS_in_layout
1870
1871	SUBROUTINE unify_mad_universe(M_U,N)
1872	implicit none
1873	type(MAD_UNIVERSE),TARGET :: M_U
1874	type(layout),pointer :: L
1875	integer i,k,N0
1876	type(fibre),pointer :: c,c0
1877	INTEGER, OPTIONAL :: N
1878	! used in TIE_MAD_UNIVERSE
1879	N0=M_U%N
1880	IF(PRESENT(N)) N0=N
1881
1882	IF(N0>M_U%N) THEN
1883	WRITE(6,*) " ERROR IN unify_mad_universe"
1884	ENDIF
1885
1886	k=0
1887	l=>m_u%start
1888	do i=1,N0-1
1889	k=k+l%n
1890	l%end%N=>l%next%start
1891	l%next%start%P=>l%end
1892	l=>l%next
1893	enddo
1894	l%end%N=>m_u%start%start
1895	m_u%start%start%P=>l%end
1896	k=k+l%n
1897
1898	write(6,*) "universe has ",k," fibres"
1899	k=0
1900	l=>m_u%start
1901
1902	k=0
1903	c0=>l%start
1904	c=>l%start
1905	do while(.true.)
1906	k=k+1
1907	c=>c%N
1908	if(associated(c0,c)) exit
1909	enddo
1910	write(6,*) "universe has ",k," fibres"
1911
1912	end SUBROUTINE unify_mad_universe
1913
1914	SUBROUTINE TIE_MAD_UNIVERSE(M_U,N)
1915	implicit none
1916	type(layout),pointer :: L
1917	integer i,j,N0,K
1918	INTEGER, OPTIONAL :: N
1919	type(fibre),pointer :: c
1920	type(MAD_UNIVERSE),TARGET :: M_U
1921	N0=M_U%N
1922	! ties universe from layout 1 to layout N; otherwise ties it all
1923	! with new pointers fibre%N and fibre%P. (Next and previous; circular list)
1924	! See move_to_name
1925	! m_u%nf the numbers of fibres tied together
1926	! fibre%loc location in the tied universed
1927
1928	IF(PRESENT(N)) N0=N
1929
1930	IF(N0>M_U%N) THEN
1931	WRITE(6,*) " ERROR IN TIE_MAD_UNIVERSE"
1932	ENDIF
1933	K=1
1934	l=>m_u%start
1935	do i=1,N0
1936	C=>L%START
1937	do j=1,L%N
1938	C%N=>C%NEXT
1939	C%P=>C%PREVIOUS
1940	if(.not.associated(c%loc)) allocate(c%loc)
1941	c%loc=k
1942	K=K+1
1943	C=>C%NEXT
1944	enddo
1945	L=>L%NEXT
1946	enddo
1947	k=k-1
1948	WRITE(6,*) K," FIBRES COMPUTED IN TIE_MAD_UNIVERSE"
1949	CALL unify_mad_universe(M_U,N)
1950	m_u%nf=k
1951	m_u%last=>m_u%start%start
1952	m_u%lastpos=1
1953	end SUBROUTINE TIE_MAD_UNIVERSE
1954
1955	subroutine gUniverse_max_n(u,n)
1956	!use build_lattice
1957	implicit none
1958	integer n,i
1959	type(mad_universe), target :: u
1960	type(layout), pointer :: L
1961	n=0
1962
1963	l=>u%start
1964	do i=1,u%n
1965	n=n+l%n
1966	l=>l%next
1967	enddo
1968
1969	end subroutine gUniverse_max_n
1970
1971
1972	subroutine gUniverse_max_node_n(u,n)
1973	!use build_lattice
1974	implicit none
1975	integer n,i
1976	type(mad_universe), target :: u
1977	type(layout), pointer :: L
1978	n=0
1979
1980	l=>u%start
1981	do i=1,u%n
1982	if(associated(l%t) ) n=n+l%t%n
1983	l=>l%next
1984	enddo
1985
1986	end subroutine gUniverse_max_node_n
1987
1988
1989	SUBROUTINE move_to_name( m_u,current,name,pos,next)
1990	! moves to next one in list called name in tied universe
1991	implicit none
1992	TYPE (fibre), POINTER :: Current
1993	TYPE (mad_universe), target :: m_u
1994	integer, intent(inout):: pos
1995	character(*), intent(in):: name
1996	CHARACTER(nlp) S1NAME
1997	integer i
1998	logical(lp), optional :: next
1999	logical(lp) ne
2000
2001	logical(lp) foundit,b
2002	TYPE (fibre), POINTER :: p
2003	TYPE (fibre), POINTER :: pb
2004	TYPE (fibre), POINTER :: pa
2005
2006	! locates magnet with name "name"
2007	! it searches back and forth
2008
2009	ne=.true.
2010	if(present(next)) ne=next
2011	foundit=.false.
2012	b=.false.
2013	S1NAME=name
2014	CALL CONTEXT(S1name)
2015
2016	nullify(p)
2017	p=>m_u%last
2018	pb=>p%p
2019	pa=>p%n
2020	if(.not.associated(p)) goto 100
2021	do i=1,m_u%nf/2+1
2022	if(i==1.and..not.ne) then
2023	if(p%mag%name==s1name) then
2024	foundit=.true.
2025	b=.true.
2026	pb=>p
2027	goto 100
2028	endif
2029	endif
2030	if(pb%mag%name==s1name) then
2031	foundit=.true.
2032	b=.true.
2033	goto 100
2034	endif
2035	if(pa%mag%name==s1name) then
2036	foundit=.true.
2037	goto 100
2038	endif
2039	pa=>pa%n
2040	pb=>pb%p
2041	enddo
2042	100 continue
2043	if(foundit) then
2044	if(b) then
2045	current=>pb
2046	pos=mod_n(m_u%lastpos-i,m_u%nf)
2047	else
2048	current=>pa
2049	pos=mod_n(m_u%lastpos+i,m_u%nf)
2050	endif
2051	m_u%lastpos=pos
2052	m_u%last=>current
2053	else
2054	pos=0
2055	write(6,*) " did not find ",S1name, "in tied universe "
2056	endif
2057	END SUBROUTINE move_to_name
2058
2059	! THIN LENS STRUCTURE STUFF
2060
2061
2062	SUBROUTINE NULL_THIN(T) ! nullifies THIN content
2063	implicit none
2064	TYPE (INTEGRATION_NODE), TARGET, intent(inout):: T
2065	NULLIFY(T%PARENT_NODE_LAYOUT)
2066	NULLIFY(T%PARENT_FIBRE)
2067	! NULLIFY(T%BB)
2068	NULLIFY(T%S)
2069	NULLIFY(T%lost)
2070	NULLIFY(T%delta_rad_out)
2071	NULLIFY(T%delta_rad_in)
2072	NULLIFY(T%ref)
2073	! NULLIFY(T%ORBIT)
2074	NULLIFY(T%a,T%ENT)
2075	NULLIFY(T%B,T%EXI)
2076	! NULLIFY(T%BT)
2077	NULLIFY(T%NEXT)
2078	NULLIFY(T%PREVIOUS)
2079	NULLIFY(T%BB)
2080	NULLIFY(T%T)
2081	! NULLIFY(T%WORK)
2082	! NULLIFY(T%USE_TPSA_MAP)
2083	! NULLIFY(T%TPSA_MAP)
2084	! NULLIFY(T%INTEGRATION_NODE_AFTER_MAP)
2085	END SUBROUTINE NULL_THIN
2086
2087	SUBROUTINE ALLOCATE_THIN(CURRENT) ! allocates and nullifies current's content
2088	implicit none
2089	TYPE (INTEGRATION_NODE), POINTER :: Current
2090	NULLIFY(CURRENT)
2091	ALLOCATE(Current)
2092	CALL NULL_THIN(CURRENT)
2093
2094	ALLOCATE(CURRENT%S(5))
2095	ALLOCATE(CURRENT%ds_ac)
2096	ALLOCATE(CURRENT%lost)
2097	ALLOCATE(CURRENT%delta_rad_in)
2098	ALLOCATE(CURRENT%delta_rad_out)
2099	ALLOCATE(CURRENT%ref(4))
2100	CURRENT%lost=0
2101	CURRENT%ref=0.0_dp
2102	CURRENT%delta_rad_in=0.0_dp
2103	CURRENT%delta_rad_out=0.0_dp
2104	CURRENT%ds_ac=0.0_dp
2105	! ALLOCATE(CURRENT%ORBIT(6))
2106	ALLOCATE(CURRENT%pos_in_fibre)
2107	ALLOCATE(CURRENT%pos)
2108	ALLOCATE(CURRENT%CAS)
2109	ALLOCATE(CURRENT%TEAPOT_LIKE)
2110	! ALLOCATE(CURRENT%USE_TPSA_MAP)
2111
2112	! ALLOCATE(CURRENT%A(3),CURRENT%ENT(3,3))
2113	! ALLOCATE(CURRENT%B(3),CURRENT%EXI(3,3))
2114	! CURRENT%A=ZERO
2115	! CURRENT%ENT=GLOBAL_FRAME
2116	! CURRENT%B=ZERO
2117	! CURRENT%EXI=GLOBAL_FRAME
2118
2119	CURRENT%pos_in_fibre=-100
2120	CURRENT%pos=-100
2121	CURRENT%CAS=-100
2122	CURRENT%TEAPOT_LIKE=-100
2123	! CURRENT%USE_TPSA_MAP=MY_FALSE
2124	END SUBROUTINE ALLOCATE_THIN
2125
2126	! SUBROUTINE ALLOCATE_NODE_MAP(CURRENT) ! allocates and nullifies current's content
2127	! implicit none
2128	! TYPE (INTEGRATION_NODE), POINTER :: Current
2129	! ALLOCATE(CURRENT%ORBIT(6))
2130	! ALLOCATE(CURRENT%TPSA_MAP)
2131	! CURRENT%USE_TPSA_MAP=MY_FALSE
2132	! CURRENT%ORBIT=ZERO
2133	! END SUBROUTINE ALLOCATE_NODE_MAP
2134
2135	SUBROUTINE nullIFY_NODE_LAYOUT( L ) ! Nullifies layout content,i
2136	implicit none
2137	! integer , intent(in) :: i
2138	TYPE (NODE_layout), TARGET, intent(inout):: L
2139	! if(i==0) then
2140	nullify(L%INDEX)
2141	nullify(L%NAME)
2142	nullify(L%CLOSED,L%N )
2143	nullify(L%LASTPOS ) ! POSITION OF LAST VISITED
2144	nullify(L%LAST )! LAST VISITED
2145	!
2146	nullify(L%END )
2147	nullify(L%START )
2148	nullify(L%START_GROUND )! STORE THE GROUNDED VALUE OF START DURING CIRCULAR SCANNING
2149	nullify(L%END_GROUND )! STORE THE GROUNDED VALUE OF END DURING CIRCULAR SCANNING
2150	nullify(L%parent_LAYOUT )!
2151	nullify(L%ORBIT_LATTICE )!
2152
2153
2154
2155	END SUBROUTINE nullIFY_NODE_LAYOUT
2156
2157	SUBROUTINE Set_Up_NODE_LAYOUT( L ) ! Sets up a layout: gives a unique index
2158	implicit none
2159	TYPE (NODE_LAYOUT), TARGET, intent(inout):: L
2160	CALL NULLIFY_NODE_LAYOUT(L)
2161	ALLOCATE(L%closed); ALLOCATE(L%lastpos);ALLOCATE(L%NAME);
2162	ALLOCATE(L%INDEX);
2163	ALLOCATE(L%n);
2164	L%closed=.false.;
2165	L%N=0;
2166	L%lastpos=0;L%NAME='NEMO';
2167	NULLIFY(L%LAST)
2168	INDEX_node=INDEX_node+1
2169	L%INDEX=INDEX_node
2170	END SUBROUTINE Set_Up_NODE_LAYOUT
2171
2172	SUBROUTINE APPEND_EMPTY_THIN( L ) ! Creates an empty fibre to be filled later
2173	implicit none
2174	TYPE (INTEGRATION_NODE), POINTER :: Current
2175	TYPE (NODE_LAYOUT), TARGET, intent(inout):: L
2176	! LOGICAL(LP) doneit
2177
2178	L%N=L%N+1
2179	CALL ALLOCATE_THIN(Current)
2180	if(L%N==1) current%next=> L%start
2181	Current % previous => L % end ! point it to next fibre
2182	if(L%N>1) THEN
2183	L%end%next => current !
2184	ENDIF
2185
2186	L % end => Current
2187	if(L%N==1) L%start=> Current
2188
2189	L%LASTPOS=L%N ;
2190	L%LAST=>CURRENT;
2191
2192	END SUBROUTINE APPEND_EMPTY_THIN
2193
2194
2195	SUBROUTINE allocate_node_frame( L ) ! Creates an empty fibre to be filled later
2196	implicit none
2197	TYPE (INTEGRATION_NODE), POINTER :: Current
2198	TYPE (LAYOUT), TARGET, intent(inout):: L
2199	integer i
2200
2201
2202	Current=>L%T%START
2203	do i=1,L%T%N
2204	IF(.NOT.ASSOCIATED(CURRENT%A)) THEN
2205	ALLOCATE(CURRENT%A(3),CURRENT%ENT(3,3))
2206	ALLOCATE(CURRENT%B(3),CURRENT%EXI(3,3))
2207	CURRENT%A=0.0_dp
2208	CURRENT%ENT=GLOBAL_FRAME
2209	CURRENT%B=0.0_dp
2210	CURRENT%EXI=GLOBAL_FRAME
2211	ENDIF
2212	Current=>CURRENT%NEXT
2213	ENDDO
2214	end SUBROUTINE allocate_node_frame
2215
2216	SUBROUTINE LINE_L_THIN(L,doneit) ! makes into line temporarily
2217	implicit none
2218	TYPE (NODE_LAYOUT), TARGET, intent(inout):: L
2219	logical(lp) doneit
2220	doneit=.false.
2221	if(L%closed) then
2222	if(associated(L%end%next)) then
2223	L%end%next=>L%start_ground
2224	doneit=.true.
2225	endif
2226	if(associated(L%start%previous)) then
2227	L%start%previous=>L%end_ground
2228	endif
2229	endif
2230	END SUBROUTINE LINE_L_THIN
2231
2232	SUBROUTINE RING_L_THIN(L,doit) ! Brings back to ring if needed
2233	implicit none
2234	TYPE (NODE_LAYOUT), TARGET, intent(inout):: L
2235	logical(lp) doit
2236	if(L%closed.and.doit) then
2237	if(.NOT.(associated(L%end%next))) then
2238	L%start_ground=>L%end%next ! saving grounded pointer
2239	L%end%next=>L%start
2240	endif
2241	if(.NOT.(associated(L%start%previous))) then
2242	L%end_ground=>L%start%previous ! saving grounded pointer
2243	L%start%previous=>L%end
2244	endif
2245	endif
2246	END SUBROUTINE RING_L_THIN
2247
2248	SUBROUTINE DEALLOC_INTEGRATION_NODE(T)
2249	IMPLICIT NONE
2250	!!! maybe missing per Sagan 2012.3.18
2251	! TYPE(INTEGRATION_NODE), TARGET, INTENT(INOUT) :: T
2252	TYPE(INTEGRATION_NODE), pointer :: T
2253	!!! maybe missing per Sagan 2012.3.18
2254
2255	! IF(ASSOCIATED(T%bb)) then
2256	! CALL KILL(t%bb)
2257	! DEALLOCATE(T%bb)
2258	! endif
2259	IF(ASSOCIATED(T%a)) DEALLOCATE(T%a)
2260	IF(ASSOCIATED(T%ent)) DEALLOCATE(T%ent)
2261	IF(ASSOCIATED(T%b)) DEALLOCATE(T%b)
2262	IF(ASSOCIATED(T%exi)) DEALLOCATE(T%exi)
2263	IF(ASSOCIATED(T%S)) DEALLOCATE(T%S)
2264	IF(ASSOCIATED(T%DS_ac)) DEALLOCATE(T%DS_ac)
2265	IF(ASSOCIATED(T%lost)) DEALLOCATE(T%lost)
2266	! IF(ASSOCIATED(T%ORBIT)) DEALLOCATE(T%ORBIT)
2267	IF(ASSOCIATED(T%pos_in_fibre)) DEALLOCATE(T%pos_in_fibre)
2268	IF(ASSOCIATED(T%POS)) DEALLOCATE(T%POS)
2269	IF(ASSOCIATED(T%CAS)) DEALLOCATE(T%CAS)
2270	IF(ASSOCIATED(T%BB)) THEN
2271	CALL KILL(T%BB)
2272	DEALLOCATE(T%BB)
2273	ENDIF
2274	IF(ASSOCIATED(T%T)) THEN
2275	CALL KILL(T%T)
2276	DEALLOCATE(T%T)
2277	ENDIF
2278	! IF(ASSOCIATED(T%TPSA_MAP)) THEN
2279	! CALL KILL(T%TPSA_MAP)
2280	! DEALLOCATE(T%TPSA_MAP)
2281	! ENDIF
2282	! IF(ASSOCIATED(T%USE_TPSA_MAP)) DEALLOCATE(T%USE_TPSA_MAP)
2283	! IF(ASSOCIATED(T%TPSA_MAP)) THEN
2284	! CALL KILL(T%TPSA_MAP)
2285	! DEALLOCATE(T%TPSA_MAP)
2286	! ENDIF
2287	!!! maybe missing per Sagan 2012.3.18
2288	DEALLOCATE(T)
2289	!!! maybe missing per Sagan 2012.3.18
2290
2291	END SUBROUTINE DEALLOC_INTEGRATION_NODE
2292
2293	SUBROUTINE kill_NODE_LAYOUT( L ) ! Destroys a layout
2294	implicit none
2295	TYPE (INTEGRATION_NODE), POINTER :: Current
2296	TYPE (NODE_LAYOUT), POINTER :: L
2297	logical(lp) doneit
2298	IF(.NOT.ASSOCIATED(L)) RETURN
2299	CALL LINE_L_THIN(L,doneit)
2300
2301	IF(ASSOCIATED(L%ORBIT_LATTICE)) THEN
2302	CALL de_Set_Up_ORBIT_LATTICE(L%ORBIT_LATTICE) ! KILLING ORBIT LATTICE
2303	!(NO LINKED LIST DE_SET_UP_... = KILL_... )
2304	WRITE(6,*) " ORBIT LATTICE HAS BEEN KILLED "
2305	ENDIF
2306
2307
2308	nullify(current)
2309	Current => L % end ! end at the end
2310	DO WHILE (ASSOCIATED(L % end))
2311	L % end => Current % previous ! update the end before disposing
2312	call DEALLOC_INTEGRATION_NODE(Current)
2313	Current => L % end ! alias of last fibre again
2314	L%N=L%N-1
2315	END DO
2316	call de_Set_Up_NODE_LAYOUT(L)
2317	DEALLOCATE(L);
2318	NULLIFY(L);
2319	END SUBROUTINE kill_NODE_LAYOUT
2320
2321	SUBROUTINE de_Set_Up_ORBIT_LATTICE( L ) ! deallocates layout content
2322	implicit none
2323	TYPE (ORBIT_LATTICE),POINTER :: L
2324	INTEGER I
2325
2326	DO I=1,L%ORBIT_N_NODE+1
2327	! CALL KILL_ORBIT_NODE(L%ORBIT_NODES,I)
2328	CALL KILL_ORBIT_NODE1(L%ORBIT_NODES(I))
2329	ENDDO
2330	deallocate(L%ORBIT_NODES)
2331	deallocate(L%ORBIT_N_NODE)
2332	deallocate(L%ORBIT_USE_ORBIT_UNITS)
2333	deallocate(L%ORBIT_WARNING)
2334	deallocate(L%ORBIT_P0C)
2335	deallocate(L%ORBIT_BETA0)
2336	deallocate(L%ORBIT_LMAX)
2337	deallocate(L%orbit_kinetic)
2338	deallocate(L%orbit_brho)
2339	deallocate(L%ORBIT_MAX_PATCH_TZ)
2340	deallocate(L%ORBIT_mass_in_amu)
2341	deallocate(L%ORBIT_gammat)
2342	deallocate(L%ORBIT_harmonic)
2343	deallocate(L%ORBIT_L)
2344	deallocate(L%ORBIT_CHARGE)
2345	deallocate(L%STATE)
2346	deallocate(L%orbit_energy)
2347	deallocate(L%ORBIT_OMEGA_after,L%orbit_gamma)
2348	! deallocate(L%orbit_dppfac)
2349	deallocate(L%orbit_deltae)
2350	deallocate(L%accel)
2351	if(associated(L%dt)) deallocate(L%dt)
2352	nullify(L%tp)
2353
2354	! deallocate(L%dxs6,L%xs6,L%freqb,L%freqa,L%voltb,L%volta,L%phasa,L%phasb)
2355	deallocate(L)
2356
2357	END SUBROUTINE de_Set_Up_ORBIT_LATTICE
2358
2359
2360
2361
2362	SUBROUTINE KILL_ORBIT_NODE1(ORBIT_LAYOUT_node)
2363	IMPLICIT NONE
2364	TYPE(ORBIT_NODE), TARGET, intent(inout):: ORBIT_LAYOUT_node
2365	DEALLOCATE(ORBIT_LAYOUT_node%LATTICE)
2366	DEALLOCATE(ORBIT_LAYOUT_node%DPOS)
2367	DEALLOCATE(ORBIT_LAYOUT_node%ENTERING_TASK)
2368	DEALLOCATE(ORBIT_LAYOUT_node%PTC_TASK)
2369	DEALLOCATE(ORBIT_LAYOUT_node%CAVITY)
2370	END SUBROUTINE KILL_ORBIT_NODE1
2371
2372	SUBROUTINE ALLOC_ORBIT_NODE1(ORBIT_LAYOUT_node,NL)
2373	IMPLICIT NONE
2374	TYPE(ORBIT_NODE), TARGET, intent(inout):: ORBIT_LAYOUT_node
2375	INTEGER NL
2376
2377	ALLOCATE(ORBIT_LAYOUT_node%LATTICE(1:NL))
2378	ALLOCATE(ORBIT_LAYOUT_node%DPOS)
2379	ALLOCATE(ORBIT_LAYOUT_node%ENTERING_TASK)
2380	ALLOCATE(ORBIT_LAYOUT_node%PTC_TASK)
2381	ALLOCATE(ORBIT_LAYOUT_node%CAVITY)
2382
2383	ORBIT_LAYOUT_node%LATTICE(1:NL)=0.0_dp
2384	ORBIT_LAYOUT_node%DPOS=0
2385	ORBIT_LAYOUT_node%ENTERING_TASK=0
2386	ORBIT_LAYOUT_node%PTC_TASK=0
2387	ORBIT_LAYOUT_node%CAVITY=MY_FALSE
2388
2389	END SUBROUTINE ALLOC_ORBIT_NODE1
2390
2391	SUBROUTINE Set_Up_ORBIT_LATTICE(O,N,U)
2392	IMPLICIT NONE
2393	TYPE(ORBIT_LATTICE), TARGET, intent(inout):: O
2394	INTEGER N
2395	LOGICAL(lp) :: U
2396
2397	if(N>0) THEN
2398	ALLOCATE(O%ORBIT_NODES(N))
2399	ELSE
2400	ALLOCATE(O%ORBIT_N_NODE);O%ORBIT_N_NODE=N
2401	ALLOCATE(O%ORBIT_USE_ORBIT_UNITS);O%ORBIT_USE_ORBIT_UNITS=U
2402	ALLOCATE(O%ORBIT_WARNING);O%ORBIT_WARNING=0
2403	ALLOCATE(O%ORBIT_OMEGA);O%ORBIT_OMEGA=1.0_dp
2404	ALLOCATE(O%ORBIT_P0C);O%ORBIT_P0C=1.0_dp
2405	ALLOCATE(O%ORBIT_BETA0);O%ORBIT_BETA0=1.0_dp
2406	ALLOCATE(O%ORBIT_LMAX);O%ORBIT_LMAX=0.0_dp
2407	ALLOCATE(O%orbit_kinetic);O%orbit_kinetic=0.0_dp
2408	ALLOCATE(O%ORBIT_MAX_PATCH_TZ);O%ORBIT_MAX_PATCH_TZ=0.0_dp
2409	ALLOCATE(O%ORBIT_mass_in_amu);O%ORBIT_mass_in_amu=0.0_dp
2410	ALLOCATE(O%ORBIT_gammat);O%ORBIT_gammat=0.0_dp
2411	ALLOCATE(O%ORBIT_L);O%ORBIT_L=0.0_dp
2412	ALLOCATE(O%ORBIT_harmonic);O%ORBIT_harmonic=1.0_dp
2413	ALLOCATE(O%ORBIT_CHARGE);O%ORBIT_CHARGE=1
2414	ALLOCATE(O%STATE);O%STATE=DEFAULT
2415	ALLOCATE(O%orbit_brho);O%orbit_brho=1.0_dp
2416	ALLOCATE(O%orbit_energy);O%orbit_energy=0.0_dp;
2417	ALLOCATE(O%orbit_gamma);O%orbit_gamma=0.0_dp;
2418	! ALLOCATE(O%orbit_dppfac);O%orbit_dppfac=zero;
2419	ALLOCATE(O%orbit_deltae);O%orbit_deltae=0.0_dp;
2420	ALLOCATE(O%ORBIT_OMEGA_after);O%ORBIT_OMEGA_after=1.0_dp
2421	! ALLOCATE(O%dxs6,O%xs6,O%freqb,O%freqa,O%voltb,O%volta,O%phasa,O%phasb)
2422	ALLOCATE(O%accel);
2423	nullify(O%dt);
2424	nullify(O%tp);
2425	nullify(O%parent_layout);
2426	! O%freqb=zero
2427	! O%freqa=zero
2428	! O%voltb=zero
2429	! O%volta=zero
2430	! O%phasa=zero
2431	! O%phasb=zero
2432	! O%xs6=zero
2433	! O%dxs6=zero
2434	O%accel=my_false
2435	ENDIF
2436
2437	! REAL(DP), pointer :: orbit_dppfac ! GET_dppfac
2438	! REAL(DP), pointer :: orbit_deltae ! GET_deltae
2439	! REAL(DP), pointer :: ORBIT_OMEGA_after
2440	! REAL(DP), pointer :: freqb,freqa,voltb,volta,phasa,phasb,xs6,dxs6
2441
2442
2443	END SUBROUTINE Set_Up_ORBIT_LATTICE
2444
2445
2446	SUBROUTINE de_Set_Up_NODE_LAYOUT( L ) ! deallocates layout content
2447	implicit none
2448	TYPE (NODE_LAYOUT), TARGET, intent(inout):: L
2449	deallocate(L%closed);deallocate(L%lastpos);deallocate(L%NAME);
2450	deallocate(L%INDEX);
2451	deallocate(L%n); !deallocate(L%parent_universe) left out
2452	IF(ASSOCIATED(L%ORBIT_LATTICE)) deallocate(L%ORBIT_LATTICE);
2453	END SUBROUTINE de_Set_Up_NODE_LAYOUT
2454
2455	SUBROUTINE move_to_INTEGRATION_NODE( L,current,POS ) ! Moves current to the i^th position
2456	implicit none
2457	TYPE (INTEGRATION_NODE), POINTER :: Current
2458	TYPE (NODE_LAYOUT), TARGET, intent(inout):: L
2459	integer i,k,POS,nt
2460	nt=l%n
2461	I=mod_n(POS,L%N)
2462
2463	! CALL LINE_L_THIN(L,doneit) ! TGV
2464
2465	IF(L%LASTPOS==0) THEN
2466	w_p=0
2467	w_p%nc=2
2468	w_p%fc='((1X,a72,/),(1X,a72))'
2469	w_p%c(1)= " L%LASTPOS=0 : ABNORMAL UNLESS LINE EMPTY"
2470	write(w_p%c(2),'(a7,i4)')" L%N = ",L%N
2471	! call !write_e(-124)
2472	ENDIF
2473
2474	nullify(current);
2475	Current => L%LAST
2476
2477	k=L%LASTPOS
2478
2479	IF(I>=L%LASTPOS) THEN
2480
2481	! DO WHILE (ASSOCIATED(Current).and.k<i) !TGV
2482	DO WHILE (k<nt.and.k<i)
2483	k=k+1
2484	Current => Current % next
2485	END DO
2486	ELSE
2487	! DO WHILE (ASSOCIATED(Current).and.k>i) !TGV
2488	DO WHILE (k>1.and.k>i)
2489	k=k-1
2490	Current => Current % PREVIOUS
2491	END DO
2492	ENDIF
2493	L%LASTPOS=I; L%LAST => Current;
2494	! CALL RING_L_THIN(L,doneit)
2495	END SUBROUTINE move_to_INTEGRATION_NODE !TGV
2496
2497	! Beam beam stuff
2498
2499	SUBROUTINE ALLOC_BEAM_BEAM_NODE(B)
2500	IMPLICIT NONE
2501	TYPE(BEAM_BEAM_NODE),POINTER :: B
2502
2503	allocate(B)
2504	! ALLOCATE(B%DS)
2505	ALLOCATE(B%S)
2506	ALLOCATE(B%FK)
2507	ALLOCATE(B%SX)
2508	ALLOCATE(B%SY)
2509	ALLOCATE(B%XM)
2510	ALLOCATE(B%YM)
2511	! ALLOCATE(B%DPOS)
2512	ALLOCATE(B%bbk(2))
2513	! ALLOCATE(B%mid(3,3))
2514	! ALLOCATE(B%o(3))
2515	ALLOCATE(B%A(3))
2516	ALLOCATE(B%D(3))
2517	! ALLOCATE(B%beta0)
2518	ALLOCATE(B%A_X1)
2519	ALLOCATE(B%A_X2)
2520	ALLOCATE(B%PATCH)
2521	B%PATCH=.FALSE.
2522	B%A_X1=1
2523	B%A_X2=1
2524	! B%beta0=one
2525	! B%mid=global_frame
2526	! B%o=zero
2527	B%A=0.0_dp
2528	B%D=0.0_dp
2529	B%bbk=0.0_dp
2530	B%SX=1.0_dp
2531	B%Sy=1.0_dp
2532	B%XM=0.0_dp
2533	B%YM=0.0_dp
2534	! B%DS=ZERO
2535	B%S=0.0_dp
2536	! B%DPOS=0
2537	B%FK=0.0_dp
2538	END SUBROUTINE ALLOC_BEAM_BEAM_NODE
2539
2540	SUBROUTINE KILL_BEAM_BEAM_NODE(B)
2541	IMPLICIT NONE
2542	TYPE(BEAM_BEAM_NODE),POINTER :: B
2543
2544	! DEALLOCATE(B%DS)
2545	DEALLOCATE(B%FK)
2546	DEALLOCATE(B%SX)
2547	DEALLOCATE(B%SY)
2548	DEALLOCATE(B%XM)
2549	DEALLOCATE(B%YM)
2550	DEALLOCATE(B%s)
2551	! DEALLOCATE(B%DPOS)
2552	DEALLOCATE(B%bbk)
2553	! DEALLOCATE(B%mid)
2554	! DEALLOCATE(B%O)
2555	DEALLOCATE(B%A)
2556	DEALLOCATE(B%D)
2557	! DEALLOCATE(B%beta0)
2558	DEALLOCATE(B%A_X1)
2559	DEALLOCATE(B%A_X2)
2560	DEALLOCATE(B%PATCH)
2561
2562	! DEALLOCATE(B)
2563
2564	END SUBROUTINE KILL_BEAM_BEAM_NODE
2565
2566	END MODULE S_FIBRE_BUNDLE

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

Context Navigation

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

Download in other formats: