Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

St_pointers.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: 95.9 KB

Line
1	module pointer_lattice
2	use madx_ptc_module !etienne, my_state_mad=>my_state, my_ring_mad=>my_ring
3	! use madx_keywords
4	USE gauss_dis
5	implicit none
6	public
7	! stuff for main program
8	type(layout),pointer :: my_ering
9	type(internal_state),pointer :: my_estate
10	! type(internal_state),pointer :: my_old_state
11	integer ,pointer :: my_start, MY_ORDER, MY_NP,MY_END,my_start_t
12	real(dp), pointer :: my_fix(:),MY_DELTA
13	real(dp), pointer ::my_target(:)
14	type(pol_block), pointer :: my_pol_block(:)
15	integer, pointer :: n_pol_block
16	real(sp) my_scale_planar
17	! end of stuff for main program
18	integer :: lat(0:6,0:6,3)=1,mres(3),mresp
19	character(25) lat_name(81)
20	real(dp) r_ap(2),x_ap,y_ap ! default aperture
21	integer :: kind_ap=2,file_ap=0 ! Single aperture position and kind of aperture + file unit
22	character(nlp) name_ap,namet(2)
23	character(255) :: filename_ap = "Tracking.txt"
24	integer last_npara
25	integer :: i_layout=1, i_layout_t=1
26	integer my_lost_position
27	private thin
28	real(dp) thin
29	! BEAM STUFF
30	REAL(DP) SIG(6),ait(6,6)
31	type(beam), allocatable:: my_beams(:)
32	type(beam), pointer:: my_beam
33	INTEGER :: N_BEAM=0,USE_BEAM=1
34
35	TYPE(REAL_8),private :: Y(6)
36	TYPE(DAMAP),PRIVATE :: ID
37	! integer nd2,npara
38	! PRIVATE POWER_CAVITY,RADIA
39	! stuff from my fortran
40	type(internal_state), target:: etat
41	integer,target:: START ,FIN,ORDER,np,start_t
42	real(dp),target:: xfix(6) ,DELT0
43
44	INTERFACE SCRIPT
45	MODULE PROCEDURE read_ptc_command
46	END INTERFACE
47
48
49
50	contains
51	subroutine set_lattice_pointers
52	implicit none
53
54	print77=.true.
55	read77 =.true.
56
57	my_ering => m_u%start
58	if(associated(my_estate)) then
59	! my_estate=>my_old_state
60	etat=my_estate
61	my_estate => etat
62	else
63	etat=DEFAULT !+nocavity0-time0
64	my_estate => etat
65	endif
66	my_start => START
67	my_END => FIN
68	my_fix=>xfix
69	my_DELTA=> DELT0
70	MY_ORDER=> ORDER
71	MY_NP=> NP
72	MY_ORDER=1
73	my_start_t=>start_t
74	start_t=1
75	DELT0=0.D0
76	START=1
77	FIN=1
78	ORDER=1
79	NP=0
80	xfix=0.d0
81	my_scale_planar=100.d0
82	my_fix(1)=.000d0
83
84	write(6,*) " absolute_aperture ", absolute_aperture
85	write(6,*) " hyperbolic_aperture ", hyperbolic_aperture
86
87	! CALL create_p_ring
88
89
90	end subroutine set_lattice_pointers
91
92
93	subroutine read_ptc_command(ptc_fichier)
94	use madx_ptc_module !etienne , piotr_state=>my_state,piotr_my_ring=>my_ring
95	implicit none
96	CHARACTER*(120) com,COMT,filename,name_root,title,name_root_res,filetune,FILESMEAR
97	character*(4) suffix,SUFFIX_res
98	character(*) ptc_fichier
99	integer i,ii,mf,i_layout_temp,IB,NO,i_layout_temp_t
100	! FITTING FAMILIES
101	INTEGER NPOL,J,NMUL,K,ICN,N,np
102	type(pol_block), ALLOCATABLE :: pol_(:)
103	type(pol_block) :: pb
104	CHARACTER*(NLP) NAME,VORNAME
105	real(dp) targ_tune(2),targ_chrom(2),EPSF
106	real(dp) targ_RES(4)
107	! END FITTING FAMILIES
108	real(dp),pointer :: beta(:,:,:)
109	REAL(DP) DBETA,tune(3),tunenew(2),CHROM(2),DEL,dtune(3)
110	integer ntune(2)
111	! fitting and scanning tunes
112	real(dp) tune_ini(2),tune_fin(2),dtu(2),fint,hgap
113	integer nstep(2),i1,i2,I3,n_bessel
114	LOGICAL(LP) STRAIGHT,skip,fixp
115	! end
116	! TRACK 4D NORMALIZED
117	INTEGER POS,NTURN,resmax
118	real(dp) EMIT(6),APER(2),emit0(2),sca
119	integer nscan,mfr,ITMAX,MRES(4)
120	real(dp), allocatable :: resu(:,:)
121	! END
122	! RANDOM MULTIPOLE
123	INTEGER addi
124	REAL(DP) CUT,cn,cns
125	LOGICAL(LP) integrated
126	! END
127	! LOCAL BEAM STUFF
128	INTEGER NUMBER_OF_PARTICLE
129	TYPE(DAMAP) MY_A
130	INTEGER MY_A_NO
131	! APERTURE
132	REAL(DP) APER_R(2),APER_X,APER_Y
133	INTEGER KINDAPER
134	TYPE(integration_node), POINTER :: TL
135	type(internal_state),target :: my_default
136	! DYN APERTURE
137	REAL(DP) r_in,del_in,DLAM,ang_in,ang_out,dx,targ_tune_alex(2),sexr0
138	INTEGER ITE,n_in,POSR
139	logical(lp) found_it
140	type(fibre),pointer ::p
141	! TRACKING RAYS
142	INTEGER IBN,N_name
143	REAL(DP) X(6),DT(3),x_ref(6),sc,NLAM,A1,B1,HPHA,B_TESLA,CUR1,CUR2
144	REAL(DP)VOLT,PHASE
145	INTEGER HARMONIC_NUMBER
146	! changing magnet
147	logical(lp) bend_like
148	logical exists
149	! remove_patches
150	save my_default
151	integer :: limit_int(2) =(/4,18/)
152	LOGICAL :: b_b,patchbb
153	REAL(DP) xbend
154	! automatic track
155	! type(internal_state),pointer :: my_old_state
156	TYPE(WORK) W
157	INTEGER KINDA ! 1,2,3,4
158	REAL(DP) RA(2)
159	REAL(DP) XA,YA,DXA,DYA, DC_ac,A_ac,theta_ac,D_ac
160	real(dp), allocatable :: an(:),bn(:) !,n_co(:)
161	integer icnmin,icnmax,n_ac,inode !,n_coeff
162	logical :: log_estate=.true.
163	integer :: mftune=6,nc
164	real(dp), allocatable :: tc(:)
165	type(integration_node), pointer :: t
166
167	if(log_estate) then
168	nullify(my_estate)
169	! nullify(my_old_state)
170	log_estate=.false.
171	endif
172
173	if(associated(my_estate)) then
174	! my_old_state=>my_estate
175	my_default=my_estate
176	else
177	my_default=default
178	endif
179	my_estate=>my_default
180	skip=.false.
181	call kanalnummer(mf)
182	write(6,*) "$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$"
183	write(6,*) "$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$"
184	write(6,*) "$$$$$$$$$$ Write New read_ptc_command $$$$$$$$$$"
185	write(6,*) "$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$"
186	write(6,*) "$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$"
187
188	open(unit=mf,file=ptc_fichier)
189
190	do i=1,10000
191	read(mf,'(a120)') comT
192	COM=COMT
193	call context(com)
194
195
196
197	if(com(1:1)==' ') THEN
198	WRITE(6,*) ' '
199	cycle
200	ENDIF
201	! if(com(1:1)=='!'.and.com(2:2)/='!') THEN
202	if(com(1:1)=='!') THEN
203	cycle
204	ENDIF
205	if(com(1:5)=='PAUSE') THEN
206	com=com(1:5)
207	ENDIF
208	if(.not.skip) then
209	if(com(1:2)=="/*") then
210	skip=.true.
211	cycle
212	endif
213	endif
214	if(skip) then !1
215	if(com(1:2)=="*/") then
216	skip=.false.
217	endif
218	cycle
219	endif ! 1
220	write(6,*) "$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$"
221	write(6,*) " "
222	write(6,*) ' ',i,comT(1:LEN_TRIM(COMT))
223	write(6,*) " "
224	write(6,*) "$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$"
225	select case(com)
226	case('SELECTLAYOUT','SELECTLATTICE')
227	read(mf,*) i_layout_temp
228	if(i_layout_temp>m_u%n) then
229	write(6,*) " Universe Size ", m_u%n
230
231	write(6,*) " Selected Layout does not exist "
232
233	else
234
235	i_layout=i_layout_temp
236	call move_to_layout_i(m_u,my_ering,i_layout)
237	write(6,*) "Selected Layout",i_layout," called ---> ",my_ering%name
238	endif
239	case('SELECTTRACKABLELAYOUT','SELECTTRACKABLELATTICE')
240	read(mf,*) i_layout_temp
241	if(i_layout_temp>m_u%n) then
242	write(6,*) " Universe Size ", m_u%n
243
244	write(6,*) " Selected Layout does not exist "
245
246	else
247
248	i_layout=i_layout_temp
249	call move_to_layout_i(m_u,my_ering,i_layout)
250	write(6,*) "Selected Layout",i_layout," called ---> ",my_ering%name
251	endif
252	case('SELECTLASTLAYOUT','SELECTLASTLATTICE')
253	i_layout_temp=m_u%n
254	if(i_layout_temp>m_u%n) then
255	write(6,*) " Universe Size ", m_u%n
256
257	write(6,*) " Selected Layout does not exist "
258
259	else
260
261	i_layout=i_layout_temp
262	call move_to_layout_i(m_u,my_ering,i_layout)
263	write(6,*) "Selected Layout",i_layout," called ---> ",my_ering%name
264	endif
265	case('NAMELAYOUT')
266	read(mf,*) NAME
267	case('KILLLASTLAYOUT')
268	read(mf,*) NAME
269	call kill_last_layout(m_u)
270	my_ering%NAME=NAME
271	! case('RESTOREDEFAULT','RESTORE')
272	! my_OLD_state=default
273	! my_default=default
274	! my_estate=>my_default
275	! Orbit stuff
276
277	case('UPDATETWISS','UPDATETWISSFORORBIT')
278	call update_twiss_for_orbit
279	case('USEORBITUNITS')
280	MY_ERING%t%ORBIT_LATTICE%ORBIT_USE_ORBIT_UNITS=.true.
281	case('DONOTUSEORBITUNITS')
282	MY_ERING%t%ORBIT_LATTICE%ORBIT_USE_ORBIT_UNITS=.false.
283	case('SETORBITRESTORE')
284	read(mf,*) restore_mag,restore_magp
285	case('SETORBITPHASOR')
286	read(mf,*) xsm%ac%x(1:2)
287	xsm0%ac%x(1:2)=xsm%ac%x(1:2)
288	ptc_node_old=-1
289	first_particle=my_false
290	case('SETORBITMARKER') !!! TO CREATE A NODE
291	READ(MF,*) i1
292	allocate(orbitname(i1))
293	do i1=1,size(orbitname)
294	READ(MF,*) name
295	call context(name)
296	orbitname(i1)=name
297	enddo
298	case('SETORBITPHASORFREQUENCY')
299	read(mf,*) xsm%ac%om
300	xsm0%ac%om=xsm%ac%om
301	ptc_node_old=-1
302	first_particle=my_false
303	case('SETORBITPHASORTIME','ORBITTIME')
304	read(mf,*) xsm%ac%t
305	xsm0%ac%t=xsm%ac%t
306	x_orbit_sync=0.0_dp
307	x_orbit_sync(6)=xsm%ac%t
308	ptc_node_old=-1
309	first_particle=my_false
310	case('MAKEORBITMARKER')
311	extra_node=1
312	if(associated(my_ering%t)) then
313	if(associated(my_ering%t%ORBIT_LATTICE)) then
314	write(6,*) "The orbit nodes have been already created "
315	write(6,*) '"MAKE ORBIT MARKER" will not work!'
316	write(6,*) 'If running orbit put this command in the special '
317	write(6,*) ' PTC script called pre_orbit_set.txt '
318	write(6,*) ' Execution now interrupted '
319	stop
320	endif
321	endif
322	case('TIMEINUNITS','TIMEINSECONDS')
323
324	read(mf,*) xsm%ac%t
325	! write(6,*) " Using ",unit_time," seconds"
326	xsm%ac%t=xsm%ac%tclight !unit_time
327	xsm0%ac%t=xsm%ac%t
328	x_orbit_sync=0.0_dp
329	x_orbit_sync(6)=xsm%ac%t
330	ptc_node_old=-1
331	first_particle=my_false
332	case('INITIALTIMEINMYUNITS','TIMEINMYUNITS','READFROMFILEINITIALTIME')
333	INQUIRE (FILE = INITIAL_setting, EXIST = exists)
334	if(exists) then
335	write(6,*) "file ", INITIAL_setting(1:len_trim(FINAL_setting)), &
336	" exists, interrupt execution if you do not want to overwrite!"
337	call kanalnummer(i1,INITIAL_setting)
338	! read(i1,*) xsm%ac%t,unit_time,n_used_patch,include_patch
339	read(i1,*) xsm%ac%t,n_used_patch,include_patch
340	read(i1,*) nc
341	if(nc/=0) then
342	allocate(tc(nc))
343	do i2=1,nc
344	read(i1,*) tc(i2)
345	enddo
346	call set_all_tc_for_restarting(my_ering,tc,nc)
347	deallocate(tc)
348	endif
349	close(i1)
350	if(include_patch) then
351	call kanalnummer(i1,"time_patch.dat")
352	read(i1,*) n_patch
353	if(associated(my_ering%T%ORBIT_LATTICE%dt)) deallocate(my_ering%T%ORBIT_LATTICE%dt)
354	allocate(my_ering%T%ORBIT_LATTICE%dt(n_patch))
355	do i2=1,n_patch
356	read(i1,*) i3,my_ering%T%ORBIT_LATTICE%dt(i2)
357	enddo
358	close(i1)
359	!looking for element just before the cavity
360	do i2=1,size(my_ering%T%ORBIT_LATTICE%ORBIT_NODES)
361	T=>my_ering%T%ORBIT_LATTICE%ORBIT_NODES(i2)%NODE
362
363	DO I1=1,my_ering%T%ORBIT_LATTICE%ORBIT_NODES(i2)%dpos
364
365
366	if(t%parent_fibre%mag%kind==kind4) then
367	my_ering%T%ORBIT_LATTICE%tp=>t%previous
368	inode=i2
369	goto 2222
370	endif
371
372	T=>T%NEXT
373	ENDDO
374	enddo
375	2222 write(6,*) "ptc mode # ",inode,"element ", my_ering%T%ORBIT_LATTICE%tp%parent_fibre%mag%name
376
377
378
379
380	endif
381	else
382	read(mf,*) xsm%ac%t,n_used_patch,include_patch
383	! read(mf,*) xsm%ac%t,unit_time,n_used_patch,include_patch
384	endif
385	! write(6,*) " Using ",unit_time," seconds"
386	xsm%ac%t=xsm%ac%t*clight
387	xsm0%ac%t=xsm%ac%t
388	x_orbit_sync=0.0_dp
389	x_orbit_sync(6)=xsm%ac%t
390	ptc_node_old=-1
391	first_particle=my_false
392	write(6,*) "x_orbit_sync(6) = " , x_orbit_sync(6)
393
394	case('FINALTIMEINMYUNITS')
395	! INQUIRE (FILE = FINAL_setting, EXIST = exists)
396	! if(exists) then
397	call kanalnummer(i1,FINAL_setting)
398	write(i1,*) x_orbit_sync(6)/clight,n_used_patch,include_patch
399	write(6,*) "x_orbit_sync(6) = " , x_orbit_sync(6)
400	write(6,*) "t_fin = " , x_orbit_sync(6)/clight
401
402	call find_all_tc_for_restarting(my_ering,tc,nc)
403	write(i1,*) nc
404	do i2=1,nc
405	write(i1,*) tc(i2)
406	enddo
407	deallocate(tc)
408	close(i1)
409	! endif
410
411
412	case('SETORBITACCELERATION')
413	accelerate=my_true
414	case('SETORBITNOACCELERATION')
415	accelerate=my_false
416	case('SETORBITRAMPING','RAMPING')
417	RAMP=my_true
418	case('SETORBITNORAMPING','NORAMPING')
419	RAMP=my_false
420	! case('SETORBITTIMEUNIT')
421	! read(mf,*) unit_time
422	case('SETORBITSTATE')
423	my_ORBIT_LATTICE%state=my_estate
424	case('PUTORBITSTATE','USEORBITSTATE')
425	my_estate=my_ORBIT_LATTICE%state
426	case('NULLIFYACCELERATION')
427	nullify(acc)
428	nullify(ACCFIRST)
429	nullify(paccfirst)
430	nullify(paccthen)
431	case('INITIALIZECAVITY','CAVITYTABLE')
432	p=>my_ering%start
433	READ(MF,*)n
434	do i1=1,n
435	read(mf,*) name,filename
436	call move_to( my_ering,p,name,pos)
437	write(6,*) "Found cavity ",name," at position ",pos
438	call lecture_fichier(p%mag,filename)
439	enddo
440	paccthen%mag%c4%acc%next=>paccfirst
441	paccfirst%mag%c4%acc%previous=>paccthen
442	case('ENERGIZEORBITLATTICEATTIME')
443	read(mf,*) xa
444	call energize_ORBIT_lattice(xa)
445	case('ENERGIZEORBITLATTICE')
446	call energize_ORBIT_lattice
447	case('SETALLRAMP')
448	call set_all_ramp(my_ering)
449
450	case('PRINTHERD','OPENHERD')
451	IF(MF_HERD/=0) THEN
452	WRITE(6,*) " CANNOT OPEN HERD FILE TWICE "
453	STOP 55
454	ENDIF
455	call kanalnummer(MF_HERD)
456	open(unit=MF_HERD,file=print_herd)
457	case('CLOSEHERD')
458	CLOSE(MF_HERD)
459	MF_HERD=0
460	case('PRINTPTCNODES','PRINTORBITNODES')
461	call kanalnummer(ii)
462	open(unit=ii,file=def_orbit_node)
463
464	tL=>my_ORBIT_LATTICE%ORBIT_NODES(1)%NODE
465	write(ii,*) " Number of PTC Nodes from 0 to ",my_ORBIT_LATTICE%ORBIT_N_NODE-1
466
467	do j=1,my_ORBIT_LATTICE%ORBIT_N_NODE
468	write(ii,) "***************************************************"
469	write(ii,*) " Node Number ",j-1
470	write(ii,*) " Number of PTC Integration Nodes",my_ORBIT_LATTICE%ORBIT_NODES(j)%dpos
471	DO I1=1,my_ORBIT_LATTICE%ORBIT_NODES(j)%dpos
472	write(ii,*) tL%S(1),tL%parent_fibre%mag%name,' ',tL%parent_fibre%pos,tL%cas
473	TL=>TL%NEXT
474	ENDDO
475	enddo
476	close(ii)
477
478	case('SETORBITFORACCELERATION')
479	! CALL ptc_synchronous_set(-1)
480	case('READORBITINTERMEDIATEDATA')
481	! CALL ptc_synchronous_set(-2)
482	case('PRINTORBITINTERMEDIATEDATA')
483	! CALL ptc_synchronous_after(-2)
484	case('FILEFORORBITINITIALSETTINGS') ! ACCELERATION FILE
485	READ(MF,*) initial_setting
486	write(6,*) initial_setting
487
488	! INQUIRE (FILE = initial_setting, EXIST = exists)
489	! if(exists) then
490	! write(6,*) "file ", initial_setting(1:len_trim(def_orbit_node)), &
491	! " exists, interrupt execution if you do not want to overwrite!"
492	! endif
493	case('FILEFORORBITFINALSETTINGS') ! ACCELERATION FILE
494	READ(MF,*) final_setting
495	write(6,*) final_setting
496	! INQUIRE (FILE = final_setting, EXIST = exists)
497	! if(exists) then
498	! write(6,*) "file ", final_setting(1:len_trim(def_orbit_node)), &
499	! " exists, interrupt execution if you do not want to overwrite!"
500	! endif
501	case('PTCNODEFILE','PTCNODE') ! ACCELERATION FILE
502	READ(MF,*) def_orbit_node
503	write(6,*) def_orbit_node
504	! INQUIRE (FILE = def_orbit_node, EXIST = exists)
505	! if(exists) then
506	! write(6,*) "file ", def_orbit_node(1:len_trim(def_orbit_node)), &
507	! " exists, interrupt execution if you do not want to overwrite!"
508	! write(6,*) " you have 2 seconds to do so "
509	! CALL DATE_AND_TIME(values=temps)
510	! i1=temps(7)
511	if(i1>=58) i1=i1-58
512	! do while(.true.)
513	! CALL DATE_AND_TIME(values=temps)
514	! if(temps(7)>i1+2) exit
515	! enddo
516	! endif
517	! end Orbit stuff
518	case('RECORDLOSTPARTICLEINORBIT') !
519	wherelost=1
520	case('RECORDLOSTPARTICLE') ! 1= orbit , 2 thin lens PTC
521	read(mf,*) wherelost
522	case('NOLOSTPARTICLE') !
523	wherelost=0
524	case('CLEANLOSTPARTICLE') !
525	if(associated(my_ering%T)) then
526	TL=>my_ering%T%START
527	DO j=1,my_ering%T%N
528	tl%lost=0
529	TL=>TL%NEXT
530	ENDDO
531	endif
532	case('PRINTLOSTPARTICLE') !
533	read(mf,*) filename
534	CALL kanalnummer(mfr)
535	OPEN(UNIT=MFR,FILE=FILENAME,status='REPLACE')
536	write(mfr,'(a42)') " s , lost , cas , pos , name "
537	if(associated(my_ering%T)) then
538	TL=>my_ering%T%START
539	DO j=1,my_ering%T%N
540	if(TL%lost>0) then
541	write(mfr,900) tl%s(1),TL%lost,tl%cas,TL%pos_in_fibre,tl%parent_fibre%mag%name
542	900 FORMAT(F13.6,1x,(i8,1x),2(i4,1x),a16)
543	endif
544	TL=>TL%NEXT
545	ENDDO
546	endif
547	close(mfr)
548	case('DEFAULT')
549	my_estate=DEFAULT0
550	case('+NOCAVITY')
551	my_estate=my_estate+NOCAVITY0
552	case('-NOCAVITY')
553	my_estate=my_estate-NOCAVITY0
554	case('+CAVITY')
555	my_estate=my_estate-NOCAVITY0
556	case('-CAVITY')
557	my_estate=my_estate+NOCAVITY0
558	case('+FRINGE')
559	my_estate=my_estate+FRINGE0
560	case('-FRINGE')
561	my_estate=my_estate-FRINGE0
562	case('+TIME')
563	my_estate=my_estate+TIME0
564	case('-TIME')
565	my_estate=my_estate-TIME0
566	case('+TOTALPATH')
567	my_estate=my_estate+TOTALPATH0
568	case('-TOTALPATH')
569	my_estate=my_estate-TOTALPATH0
570	case('+ONLY_4D')
571	my_estate=my_estate+ONLY_4D0
572	case('-ONLY_4D')
573	my_estate=my_estate-ONLY_4D0
574	case('+DELTA')
575	my_estate=my_estate+DELTA0
576	case('-DELTA')
577	my_estate=my_estate-DELTA0
578	case('+RADIATION')
579	my_estate=my_estate+RADIATION0
580	case('-RADIATION')
581	my_estate=my_estate-RADIATION0
582	case('+MODULATION')
583	my_estate=my_estate+MODULATION0
584	case('-MODULATION',"+NOMODULATION")
585	my_estate=my_estate-MODULATION0
586	case('+SPIN')
587	my_estate=my_estate+SPIN0
588	case('-SPIN')
589	my_estate=my_estate-SPIN0
590	! case('+EXACTMIS')
591	! my_estate=my_estate+EXACTMIS0
592	! case('-EXACTMIS')
593	! my_estate=my_estate-EXACTMIS0
594
595	! case('DEFAULTTPSA')
596	! read(mf,*) default_tpsa
597	! if(default_tpsa) then
598	! write(6,*) " Default TPSA is Chinese "
599	! else
600	! write(6,*) " Default TPSA is Germanic "
601	! endif
602	case('ALMOSTEXACT')
603	almost_exact=.true.
604	write(6,*) " Almost Exact = ",almost_exact
605	case('TRUELYEXACT','EXACT')
606	almost_exact=.false.
607	write(6,*) " Almost Exact = ",almost_exact
608	case('BERZ','GERMANIC','MARTIN')
609	CALL change_package(2)
610	case('YANG','CHINESE','LINGYUN')
611	CALL change_package(1)
612	case('ALLOCATEBETA')
613	ALLOCATE(BETA(2,3,my_ering%N))
614
615	case('DEALLOCATEBETA')
616	DEALLOCATE(BETA)
617	case('FILLBETA')
618	READ(MF,*) IB,pos
619	CALL FILL_BETA(my_ering,my_estate,pos,BETA,IB,DBETA,tune,tunenew)
620	case('FITBENDS')
621	CALL fit_all_bends(my_ering,my_estate)
622	case('LIMITFORCUTTING')
623	READ(MF,*) limit_int
624	WRITE(6,*) "limit_int =",limit_int
625	case('LMAX')
626	READ(MF,*) LMAX
627	WRITE(6,*) "LMAX FOR SPACE CHARGE =",LMAX
628	case('FUZZYLMAX')
629	READ(MF,*) FUZZY_SPLIT
630	WRITE(6,) "FUZZY LMAX FOR SPACE CHARGE =",abs(LMAX),abs(LMAXFUZZY_SPLIT)
631	case('CUTTINGALGORITHM')
632	READ(MF,*) resplit_cutting
633	IF(resplit_cutting==0) WRITE(6,*) " RESPLITTING NORMALLY"
634	IF(resplit_cutting==1) WRITE(6,*) " CUTTING DRIFT USING LMAX"
635	IF(resplit_cutting==2) WRITE(6,*) " CUTTING EVERYTHING USING LMAX"
636	! case('KIND7WITHMETHOD1')
637	! CALL PUT_method1_in_kind7(my_ering,1000)
638	case('THINLENS=1')
639	call THIN_LENS_restart(my_ering)
640	case('MANUALTHINLENS')
641	THIN=-1
642	CALL THIN_LENS_resplit(my_ering,THIN,lim=limit_int)
643	case('THINLENS')
644	READ(MF,*) THIN
645	xbend=-1.0_dp
646	if(thin<0) then
647	READ(MF,*) sexr0,xbend
648	if(xbend<0) then
649	xbend=-xbend
650	radiation_bend_split=MY_true
651	endif
652	thin=-thin
653	endif
654	WRITE(6,*) "THIN LENS FACTOR =",THIN
655	CALL THIN_LENS_resplit(my_ering,THIN,lim=limit_int,lmax0=lmax,sexr=sexr0,xbend=xbend)
656	radiation_bend_split=MY_false
657	case('EVENTHINLENS')
658	READ(MF,*) THIN
659	xbend=-1.0_dp
660	if(thin<0) then
661	READ(MF,*) sexr0,xbend
662	if(xbend<0) then
663	xbend=-xbend
664	radiation_bend_split=MY_true
665	endif
666	thin=-thin
667	endif
668	WRITE(6,*) "THIN LENS FACTOR =",THIN
669	CALL THIN_LENS_resplit(my_ering,THIN,EVEN=my_TRUE,lim=limit_int,lmax0=lmax,sexr=sexr0,xbend=xbend)
670	case('ODDTHINLENS')
671	READ(MF,*) THIN
672	xbend=-1.0_dp
673	if(thin<0) then
674	READ(MF,*) sexr0,xbend
675	if(xbend<0) then
676	xbend=-xbend
677	radiation_bend_split=MY_true
678	endif
679	thin=-thin
680	endif
681	WRITE(6,*) "THIN LENS FACTOR =",THIN
682	CALL THIN_LENS_resplit(my_ering,THIN,EVEN=my_FALSE,lim=limit_int,lmax0=lmax,sexr=sexr0,xbend=xbend)
683	! thin layout stuff
684
685	case('ADDSURVEYINFO')
686
687	call ADD_SURVEY_INFO(my_ering)
688
689	case('RECUTKIND7NODRIFT','USEODDMETHODS')
690	call RECUT_KIND7(my_ering,lmax,my_false)
691	case('RECUTKIND7ANDDRIFT','USEODDMETHODSONDRIFT')
692	call RECUT_KIND7(my_ering,lmax,my_true)
693	case('MAKE_THIN_LAYOUT','MAKELAYOUT','MAKE_NODE_LAYOUT')
694
695	if(.not.associated(my_ering%t)) CALL MAKE_node_LAYOUT(my_ering)
696	case('SURVEY_THIN_LAYOUT','SURVEYLAYOUT','SURVEY_NODE_LAYOUT')
697
698	IF(associated(my_ering%t)) THEN
699	CALL fill_survey_data_in_NODE_LAYOUT(my_ering)
700	ELSE
701	WRITE(6,*) " NO NODE LAYOUT PRESENT "
702	ENDIF
703
704
705	! BEAMS STUFF
706	case('ALLOCATEBEAMS')
707	READ(MF,*) N_BEAM
708	ALLOCATE(MY_BEAMS(N_BEAM))
709	CALL NULLIFY_BEAMS(MY_BEAMS)
710	case('DEALLOCATEBEAMS')
711	CALL KILL_BEAMS(MY_BEAMS)
712	DEALLOCATE(MY_BEAMS)
713	case('CREATEBEAM')
714	READ(MF,*) USE_BEAM,NUMBER_OF_PARTICLE, FILENAME
715	READ(MF,*) CUT,SIG(1:6)
716	CALL CONTEXT(FILENAME)
717	IF(FILENAME(1:2)=='NO'.OR.FILENAME(1:2)=='no') THEN
718	CALL create_PANCAKE(MY_BEAMS(USE_BEAM),NUMBER_OF_PARTICLE,CUT,SIG,my_ering%start%t1)
719	ELSE
720	CALL kanalnummer(mfr)
721	OPEN(UNIT=MFR,FILE=FILENAME)
722	READ(MF,*) MY_A_NO
723	CALL compute_A_4d(my_ering,my_estate,filename,pos,del,MY_A_NO,MY_A)
724	CALL create_PANCAKE(MY_BEAMS(USE_BEAM),NUMBER_OF_PARTICLE,CUT,SIG,my_ering%start%t1,MY_A)
725	CALL KILL(MY_A)
726	close(mfr)
727	ENDIF
728	case('COPYBEAM')
729	READ(MF,*) I1,I2
730	CALL COPY_BEAM(MY_BEAMS(I1),MY_BEAMS(I2))
731	case('PRINTBEAM')
732	READ(MF,*) i1,filename
733	CALL kanalnummer(mfr)
734	OPEN(UNIT=MFR,FILE=FILENAME)
735	call PRINT_beam_raw(MY_BEAMS(I1),MFr)
736	CLOSE(MFR)
737	case('BEAMSTATISTICS')
738	READ(MF,*) USE_BEAM
739
740	CALL Stat_beam_raw(MY_BEAMS(USE_BEAM),4,6)
741
742	case('CHECKKREIN')
743	WRITE(6,*) "OLD CHECK_KREIN ",check_krein
744	READ(MF,*) check_krein
745	WRITE(6,*) "NEW CHECK_KREIN ",CHECK_KREIN
746
747	case('KREINSIZE')
748	WRITE(6,*) "OLD KREIN SIZE PARAMETER ",size_krein
749	READ(MF,*) size_krein
750	WRITE(6,*) "NEW KREIN SIZE PARAMETER",size_krein
751
752	case('ABSOLUTEAPERTURE')
753	WRITE(6,*) "OLD C_%ABSOLUTE_APERTURE ",C_%ABSOLUTE_APERTURE
754	READ(MF,*) C_%ABSOLUTE_APERTURE
755	WRITE(6,*) "NEW C_%ABSOLUTE_APERTURE ",C_%ABSOLUTE_APERTURE
756	! end of layout stuff
757	! random stuff
758	case('GLOBALAPERTUREFLAG')
759	WRITE(6,*) "OLD C_%APERTURE_FLAG ",C_%APERTURE_FLAG
760	READ(MF,*) APERTURE_FLAG
761	WRITE(6,*) "NEW C_%APERTURE_FLAG ",C_%APERTURE_FLAG
762	case('TURNOFFONEAPERTURE','TOGGLEAPERTURE')
763	READ(MF,*) POS
764	CALL TURN_OFF_ONE_aperture(my_ering,pos)
765	case('SETONEAPERTURE')
766	read(MF,*) pos
767	read(MF,*) kindaper, APER_R,APER_X,APER_Y,dxa,dya
768	CALL assign_one_aperture(my_ering,pos,kindaper,APER_R,APER_X,APER_Y,dxa,dya)
769	! end of layout stuff
770	! random stuff
771
772	case('GAUSSIANSEED')
773	READ(MF,*) I1
774	CALL gaussian_seed(i1)
775
776	case('RANDOMMULTIPOLE')
777	read(mf,*) i1, cut,STRAIGHT !!! seed, cut on sigma, print
778	read(mf,*) name,fixp !!! name, full=> logical true full name compared
779	read(mf,*) sc !!! percentage
780
781	if(sc<=0) then
782	read(mf,*) addi,integrated
783	read(mf,) n,cns,cn !!! n (negative means skew) bn=cns+cnx
784	endif
785	call lattice_random_error_new(my_ering,name,fixp,i1,cut,n,addi,integrated,cn,cns,sc,STRAIGHT)
786	case('MISALIGNEVERYTHING')
787
788	read(mf,*) SIG(1:6),cut
789	CALL MESS_UP_ALIGNMENT(my_ering,SIG,cut)
790	! end of random stuff
791	case('MISALIGN','MISALIGNONE')
792	read(mf,*) i1, cut,STRAIGHT
793	read(mf,*) name,fixp
794	read(mf,*) SIG(1:6)
795	call MESS_UP_ALIGNMENT_name(my_ering,name,i1,fixp,sig,cut,STRAIGHT)
796	case('ALWAYS_EXACTMIS',"ALWAYSEXACTMISALIGNMENTS")
797	! end of random stuff
798	read(mf,*) ALWAYS_EXACTMIS
799	if(ALWAYS_EXACTMIS) write(6,*) " ALWAYS EXACT MISALIGNMENTS "
800	if(.NOT.ALWAYS_EXACTMIS) write(6,*) " EXACT MISALIGNMENTS SET USING STATE "
801	case('KILLBEAMBEAM')
802	if(associated(my_ering%T)) then
803	TL=>my_ering%T%START
804	DO j=1,my_ering%T%N
805	if(associated(tl%BB)) then
806	write(6,*) tl%pos,tl%parent_fibre%mag%name,' killed'
807	call kill(tl%BB)
808	endif
809	TL=>TL%NEXT
810	ENDDO
811	endif
812	case('BEAMBEAM')
813	READ(MF,*) SC,pos,patchbb
814	read(mf,*) X_ref(1), X_ref(2), X_ref(3), X_ref(4)
815	if(patchbb) then
816	read(mf,*) x
817	endif
818	IF(.NOT.ASSOCIATED(my_ering%T)) THEN
819	CALL MAKE_NODE_LAYOUT(my_ering)
820	ENDIF
821	! s(1) total ld
822	! s(2) local integration distance
823	! SC=MOD(SC,MY_RING%T%END%S(1))
824	b_b=.false.
825	TL=>my_ering%T%START
826	DO j=1,my_ering%T%N
827	if(pos<1) then
828	IF(TL%S(1)<=SC.AND.TL%NEXT%S(1)>SC) then
829	b_b=.true.
830	exit
831	endif
832	else
833	if(j==pos) then
834	b_b=.true.
835	exit
836	endif
837	endif
838	TL=>TL%NEXT
839	ENDDO
840	if(b_b.and.tl%cas==case0) then
841	write(6,*) " Beam-Beam position at ",tl%parent_fibre%mag%name
842	if(.not.associated(tl%BB)) call alloc(tl%BB)
843	tl%bb%fk=X_ref(1)* X_ref(4)**2
844	tl%bb%sx=X_ref(2)* X_ref(4)
845	tl%bb%sy=X_ref(3)* X_ref(4)
846	! if(pos<1) tl%bb%ds=SC-TL%S(1)
847	write(6,*) tl%pos,tl%parent_fibre%mag%name,' created'
848	! write(6,*) " ds = ",tl%bb%ds
849	if(patchbb) then
850	tl%bb%patch=patchbb
851	tl%bb%a=x(1:3)
852	tl%bb%d=x(4:6)
853	endif
854	else
855	write(6,*) " Beam-Beam position not found "
856	endif
857
858	case('DOBEAMBEAM')
859	do_beam_beam=my_true
860	case('NOBEAMBEAM')
861	do_beam_beam=my_false
862	case('SETFAMILIES','SETGFAMILIES')
863	np=0
864	READ(MF,*) NPOL
865	ALLOCATE(pol_(NPOL))
866	DO J=1,NPOL
867	READ(MF,*) NMUL,NAME
868	CALL CONTEXT(NAME)
869	N_NAME=0
870	IF(NAME(1:2)=='NO') THEN
871	READ(MF,*) NAME
872	call context(name)
873	N_NAME=len_trim(name)
874	ENDIF
875	POL_(J)=0
876	POL_(J)%NAME=NAME
877	POL_(J)%N_NAME=N_NAME
878	DO K=1,NMUL
879	IF(COM=='SETGFAMILIES') THEN
880	READ(MF,*) N,ICN,POL_(J)%G,POL_(J)%NB,POL_(J)%NP ! integer g,np,nb ! group index number of blocks
881	ELSE
882	READ(MF,*) N,ICN
883	ENDIF
884	if(icn>np) np=icn
885	IF(N>0) THEN
886	POL_(J)%IBN(N)=ICN
887	ELSE
888	POL_(J)%IAN(-N)=ICN
889	ENDIF
890	ENDDO
891	ENDDO
892	Write(6,*) " Number of parameters = ",np
893	Write(6,*) " Number of polymorphic blocks = ",NPOL
894
895	case('SETGFAMILIESN')
896	np=0
897	READ(MF,*) NPOL
898	ALLOCATE(pol_(NPOL))
899	kindaper=0
900	n_in=0
901	2010 continue
902	READ(MF,*) kinda
903	kindaper=kindaper+kinda
904	n_in=n_in+1
905	icnmin=100000
906	icnmax=0
907	DO J=kindaper-kinda+1,kindaper
908	READ(MF,*) NMUL,NAME
909	CALL CONTEXT(NAME)
910	N_NAME=0
911	IF(NAME(1:2)=='NO') THEN
912	READ(MF,*) NAME
913	call context(name)
914	N_NAME=len_trim(name)
915	ENDIF
916	POL_(J)=0
917	POL_(J)%NAME=NAME
918	POL_(J)%N_NAME=N_NAME
919	DO K=1,NMUL
920	IF(COM=='SETGFAMILIES') THEN
921	READ(MF,*) N,ICN,POL_(J)%G,POL_(J)%NB,POL_(J)%NP ! integer g,np,nb ! group index number of blocks
922	ELSE
923	READ(MF,*) N,ICN
924	POL_(J)%NB=n_in
925	ENDIF
926	if(icn>np) np=icn
927	if(icn<icnmin) icnmin=icn
928	if(icn>icnmax) icnmax=icn
929	IF(N>0) THEN
930	POL_(J)%IBN(N)=ICN
931	ELSE
932	POL_(J)%IAN(-N)=ICN
933	ENDIF
934	ENDDO
935	ENDDO
936	DO J=kindaper-kinda+1,kindaper
937	POL_(J)%g=icnmin
938	POL_(J)%NP=icnmax-icnmin+1
939	enddo
940	if(kindaper<npol) goto 2010
941	Write(6,*) " Number of parameters = ",np
942	Write(6,*) " Number of polymorphic blocks = ",NPOL
943
944	case('READFAMILIESANBN')
945	read(mf,*) filename
946	call kanalnummer(mfr,filename)
947	READ(MFR,*) II
948	DO J=1,II
949	read(mfr,'(a120)') title
950	READ(title,*) NAME,VORNAME
951	call move_to( my_ering,p,name,VORNAME,pos)
952
953	call context(title)
954	do while(.true.)
955	read(mfr,'(a120)') title
956	name_root=title
957	call context(name_root)
958	if(name_root(1:3)=='END') exit
959	read(title,*) n,r_in
960	call add(p,n,0,r_in)
961	enddo
962
963	ENDDO
964
965	close(mfr)
966
967	case('FRANKCOMMAND','MADCOMMAND','COMMAND')
968	read(mf,*) filename
969	call read_mad_command77(filename)
970
971	case('PRINTFAMILIESANBN')
972	read(mf,*) filename
973	call kanalnummer(mfr,filename)
974	write(MFR,*) NPOL
975	DO J=1,NPOL
976	my_ering=pol_(J)
977	ENDDO
978
979	p=>my_ering%start
980
981	do j=1,my_ering%n
982	if(p%magp%knob) then
983	write(mfr,*) p%magp%name, p%magp%vorname
984	do ii=1,p%magp%p%nmul
985	if(p%magp%bn(ii)%kind==3) then
986	write(mfr,*)ii, p%magp%bn(ii)%r
987	endif
988	if(p%magp%an(ii)%kind==3) then
989	write(mfr,*)-ii, p%magp%an(ii)%r
990	endif
991	enddo
992	write(mfr,*) "end of data"
993	endif
994	p=>p%next
995	enddo
996	call kill_para(my_ering)
997	close(mfr)
998	case('RAMP','RAMPMAGNET')
999	READ(MF,*) NAME, filename, hgap
1000
1001	CALL CONTEXT(NAME)
1002	N_NAME=0
1003	IF(NAME(1:2)=='NO') THEN
1004	READ(MF,*) NAME
1005	call context(name)
1006	N_NAME=len_trim(name)
1007	ENDIF
1008	DC_ac=1.0_dp
1009	A_ac=0.0_dp
1010	theta_ac=0.0_dp
1011	D_ac=0.0_dp
1012	n_ac=0
1013	! n_coeff=0
1014	p=>my_ering%start
1015	do ii=1,my_ering%N
1016	found_it=MY_FALSE
1017	IF(N_NAME==0) THEN
1018	found_it=P%MAG%NAME==NAME
1019	ELSE
1020	found_it=P%MAG%NAME(1:N_NAME)==NAME(1:N_NAME)
1021	ENDIF
1022
1023	IF(FOUND_IT) THEN
1024
1025	write(6,*) " slow ramping magnet found ",P%MAG%name
1026
1027	call reading_file(P%MAG,filename)
1028	p%mag%ramp%r=hgap
1029	p%magp%ramp%r=hgap
1030
1031	i2=size(p%mag%ramp%table(0)%bn)
1032
1033	if(.not.associated(P%MAG%DC_ac)) then
1034	allocate(P%MAG%DC_ac)
1035	allocate(P%MAG%A_ac)
1036	allocate(P%MAG%theta_ac)
1037	allocate(P%MAG%D_ac)
1038
1039	allocate(P%MAGP%DC_ac)
1040	allocate(P%MAGP%A_ac)
1041	allocate(P%MAGP%theta_ac)
1042	CALL alloc(P%MAGP%DC_ac)
1043	CALL alloc(P%MAGP%A_ac)
1044	CALL alloc(P%MAGP%theta_ac)
1045	allocate(P%MAGp%D_ac)
1046	CALL alloc(P%MAGP%D_ac)
1047
1048
1049
1050	P%MAG%D_ac=D_ac
1051	P%MAG%DC_ac=DC_ac
1052	P%MAG%A_ac=A_ac
1053	P%MAG%theta_ac=theta_ac*twopi
1054	P%MAGP%D_ac=D_ac
1055	P%MAGP%DC_ac=DC_ac
1056	P%MAGP%A_ac=A_ac
1057	P%MAGP%theta_ac=theta_ac*twopi
1058	P%MAG%slow_ac=.true.
1059	P%MAGP%slow_ac=.true.
1060
1061	if(i2>p%mag%p%nmul) then
1062	CALL ADD(P,i2,0,0.0_dp)
1063	endif
1064	allocate(P%MAG%d_an(p%mag%p%nmul))
1065	allocate(P%MAG%d_bn(p%mag%p%nmul))
1066	allocate(P%MAGp%d_an(p%mag%p%nmul))
1067	allocate(P%MAGp%d_bn(p%mag%p%nmul))
1068	allocate(P%MAG%d0_an(p%mag%p%nmul))
1069	allocate(P%MAG%d0_bn(p%mag%p%nmul))
1070	allocate(P%MAGp%d0_an(p%mag%p%nmul))
1071	allocate(P%MAGp%d0_bn(p%mag%p%nmul))
1072
1073
1074	P%MAG%d_an=0.0_dp
1075	P%MAG%d_bn=0.0_dp
1076
1077	call alloc(P%MAGp%d_an,p%mag%p%nmul)
1078	call alloc(P%MAGp%d_bn,p%mag%p%nmul)
1079	call alloc(P%MAGp%d0_an,p%mag%p%nmul)
1080	call alloc(P%MAGp%d0_bn,p%mag%p%nmul)
1081	do i1=1,p%mag%p%nmul
1082	P%MAG%d0_bn(i1)=P%MAG%bn(i1)
1083	P%MAG%d0_an(i1)=P%MAG%an(i1)
1084	P%MAGp%d0_bn(i1)=P%MAG%bn(i1)
1085	P%MAGp%d0_an(i1)=P%MAG%an(i1)
1086	enddo
1087
1088
1089	else
1090	write(6,*) " already associated --> change code "
1091	stop 166
1092	ENDIF
1093	ENDIF
1094
1095
1096	p=>p%next
1097	enddo
1098
1099
1100	case('MODULATE','ACMAGNET')
1101	READ(MF,*) NAME
1102
1103	CALL CONTEXT(NAME)
1104	N_NAME=0
1105	IF(NAME(1:2)=='NO') THEN
1106	READ(MF,*) NAME
1107	call context(name)
1108	N_NAME=len_trim(name)
1109	ENDIF
1110	READ(MF,*) DC_ac,A_ac,theta_ac
1111	READ(MF,*) D_ac,n_ac !,n_coeff
1112	i2=0
1113	if(n_ac>0) then !n_ac>0
1114	allocate(an(n_ac))
1115	allocate(bn(n_ac))
1116	an=0.0_dp
1117	bn=0.0_dp
1118	do while(.true.)
1119	read(mf,*) i1,dtu(1:2)
1120	if(i1<=0) exit
1121	if(i1>i2) i2=i1
1122	an(i1)=dtu(2)
1123	bn(i1)=dtu(1)
1124	enddo
1125	endif !n_ac>0
1126	! if(n_coeff>0) then !n_ac>0
1127	! allocate(n_co(n_coeff))
1128	! n_co=zero
1129	! read(mf,*) n_co
1130	! endif !n_ac>0
1131	p=>my_ering%start
1132	do ii=1,my_ering%N
1133	found_it=MY_FALSE
1134	IF(N_NAME==0) THEN
1135	found_it=P%MAG%NAME==NAME
1136	ELSE
1137	found_it=P%MAG%NAME(1:N_NAME)==NAME(1:N_NAME)
1138	ENDIF
1139
1140	IF(FOUND_IT) THEN
1141	write(6,*) " slow ac magnet found ",P%MAG%name
1142	if(.not.associated(P%MAG%DC_ac)) then
1143	allocate(P%MAG%DC_ac)
1144	allocate(P%MAG%A_ac)
1145	allocate(P%MAG%theta_ac)
1146	allocate(P%MAG%D_ac)
1147
1148	allocate(P%MAGP%DC_ac)
1149	allocate(P%MAGP%A_ac)
1150	allocate(P%MAGP%theta_ac)
1151	CALL alloc(P%MAGP%DC_ac)
1152	CALL alloc(P%MAGP%A_ac)
1153	CALL alloc(P%MAGP%theta_ac)
1154	allocate(P%MAGp%D_ac)
1155	CALL alloc(P%MAGP%D_ac)
1156
1157
1158
1159	P%MAG%D_ac=D_ac
1160	P%MAG%DC_ac=DC_ac
1161	P%MAG%A_ac=A_ac
1162	P%MAG%theta_ac=theta_ac*twopi
1163	P%MAGP%D_ac=D_ac
1164	P%MAGP%DC_ac=DC_ac
1165	P%MAGP%A_ac=A_ac
1166	P%MAGP%theta_ac=theta_ac*twopi
1167	P%MAG%slow_ac=.true.
1168	P%MAGP%slow_ac=.true.
1169
1170	if(i2>p%mag%p%nmul) then
1171	CALL ADD(P,i2,0,0.0_dp)
1172	endif
1173	allocate(P%MAG%d_an(p%mag%p%nmul))
1174	allocate(P%MAG%d_bn(p%mag%p%nmul))
1175	allocate(P%MAGp%d_an(p%mag%p%nmul))
1176	allocate(P%MAGp%d_bn(p%mag%p%nmul))
1177	allocate(P%MAG%d0_an(p%mag%p%nmul))
1178	allocate(P%MAG%d0_bn(p%mag%p%nmul))
1179	allocate(P%MAGp%d0_an(p%mag%p%nmul))
1180	allocate(P%MAGp%d0_bn(p%mag%p%nmul))
1181
1182
1183	P%MAG%d_an=0.0_dp
1184	P%MAG%d_bn=0.0_dp
1185
1186	call alloc(P%MAGp%d_an,p%mag%p%nmul)
1187	call alloc(P%MAGp%d_bn,p%mag%p%nmul)
1188	call alloc(P%MAGp%d0_an,p%mag%p%nmul)
1189	call alloc(P%MAGp%d0_bn,p%mag%p%nmul)
1190	do i1=1,p%mag%p%nmul
1191	P%MAG%d0_bn(i1)=P%MAG%bn(i1)
1192	P%MAG%d0_an(i1)=P%MAG%an(i1)
1193	P%MAGp%d0_bn(i1)=P%MAG%bn(i1)
1194	P%MAGp%d0_an(i1)=P%MAG%an(i1)
1195	enddo
1196
1197	do i1=1,n_ac
1198	P%MAG%d_an(i1) =an(i1)
1199	P%MAGp%d_an(i1)=an(i1)
1200	P%MAG%d_bn(i1) =bn(i1)
1201	P%MAGp%d_bn(i1)=bn(i1)
1202	enddo
1203	!
1204	! IF(K%MODULATION) THEN
1205	! DV=(XS%AC%X(1)COS(EL%theta_ac)-XS%AC%X(2)SIN(EL%theta_ac))
1206	! V=EL%DC_ac+EL%A_ac*DV
1207	! DV=el%D_ac*DV
1208	! else
1209	! V=EL%DC_ac
1210	! DV=zero
1211	! endif
1212	! P%MAG%DC_ac=DC_ac
1213	! P%MAG%A_ac=A_ac
1214	! P%MAG%theta_ac=theta_ac*twopi
1215	! P%MAGP%DC_ac=DC_ac
1216	! P%MAGP%A_ac=A_ac
1217	! P%MAGP%theta_ac=theta_ac*twopi
1218	! P%MAG%slow_ac=.true.
1219	! P%MAGP%slow_ac=.true.
1220	else
1221	write(6,*) " already associated --> change code "
1222	stop 166
1223	ENDIF
1224	ENDIF
1225
1226
1227	p=>p%next
1228	enddo
1229
1230
1231	if(n_ac>0) then
1232	deallocate(an,bn)
1233	endif
1234
1235	! if(n_coeff>0) then
1236	! deallocate(n_co)
1237	! endif
1238
1239	case('SETAPERTURE')
1240	READ(MF,*) KINDA,NAME
1241
1242	CALL CONTEXT(NAME)
1243	N_NAME=0
1244	IF(NAME(1:2)=='NO') THEN
1245	READ(MF,*) NAME
1246	call context(name)
1247	N_NAME=len_trim(name)
1248	ENDIF
1249	READ(MF,*) XA,YA,DXA,DYA
1250	READ(MF,*) RA(1),RA(2)
1251
1252	p=>my_ering%start
1253	do ii=1,my_ering%N
1254	found_it=MY_FALSE
1255	IF(N_NAME==0) THEN
1256	found_it=P%MAG%NAME==NAME
1257	ELSE
1258	found_it=P%MAG%NAME(1:N_NAME)==NAME(1:N_NAME)
1259	ENDIF
1260
1261	IF(FOUND_IT) THEN
1262	IF(.NOT.ASSOCIATED(P%MAG%P%APERTURE)) THEN
1263	CALL alloc(P%MAG%P%APERTURE)
1264	ENDIF
1265	IF(.NOT.ASSOCIATED(P%MAGP%P%APERTURE)) THEN
1266	CALL alloc(P%MAGP%P%APERTURE)
1267	ENDIF
1268
1269	P%MAG%P%APERTURE%KIND= KINDA ! 1,2,3,4
1270	P%MAG%P%APERTURE%R= RA
1271	P%MAG%P%APERTURE%X= XA
1272	P%MAG%P%APERTURE%Y= YA
1273	P%MAG%P%APERTURE%DX= DXA
1274	P%MAG%P%APERTURE%DY= DYA
1275	P%MAGP%P%APERTURE%KIND= KINDA ! 1,2,3,4
1276	P%MAGP%P%APERTURE%R= RA
1277	P%MAGP%P%APERTURE%X= XA
1278	P%MAGP%P%APERTURE%Y= YA
1279	P%MAGP%P%APERTURE%DX= DXA
1280	P%MAGP%P%APERTURE%DY= DYA
1281
1282	ENDIF
1283
1284	p=>p%next
1285	enddo
1286
1287
1288
1289
1290	case('PUTFAMILY','LAYOUT<=KNOB')
1291	do j=1,NPOL
1292	my_ering=pol_(j)
1293	enddo
1294	case('DEALLOCATEFAMILIES')
1295	call kill_para(my_ering)
1296	deallocate(POL_)
1297	case('PTCTWISSTENGEDWARDS','TWISSTENGEDWARDS') !
1298	read(mf,*) filename, NAME, integrated
1299	read(mf,*) del
1300
1301	call compute_twiss(my_ering,my_estate,filename,1,del,1,integrated,name,my_true,my_false)
1302	case('PTCTWISS','TWISS','PTCTWISSRIPKEN','TWISSRIPKEN') !
1303	read(mf,*) filename, NAME, integrated
1304	read(mf,*) del
1305
1306	call compute_twiss(my_ering,my_estate,filename,1,del,1,integrated,name,my_false,my_false)
1307
1308	case('PTCTWISSSASHA','TWISSSASHA','PTCTWISSRIPKENSASHA','TWISSRIPKENSASHA') !
1309	read(mf,*) filename, NAME, integrated
1310	read(mf,*) del
1311
1312	call compute_twiss(my_ering,my_estate,filename,1,del,1,integrated,name,my_false,my_true)
1313
1314	case('FITTUNESCAN','SEARCHAPERTUREX=Y')
1315	read(mf,*) epsf
1316	read(mf,*) ntune
1317	read(mf,*) tune(1:2)
1318	read(mf,*) dtune(1:2),targ_RES(3:4)
1319	if(com=='SEARCHAPERTUREX=Y') then
1320	READ(MF,*) r_in,del_in,dx,DLAM,fixp
1321	READ(MF,*) POS,NTURN,ITE,FILENAME,name
1322	call context(name)
1323	if(name(1:11)/='NONAMEGIVEN') then
1324	posr=pos
1325	call move_to( my_ering,p,name,posR,POS)
1326	if(pos==0) then
1327	write(6,*) name, " not found "
1328	stop
1329	endif
1330	endif
1331	call kanalnummer(mfr,filename)
1332	endif
1333
1334
1335
1336
1337	do i2=0,ntune(2)
1338	do i1=0,ntune(1)
1339
1340	if(ntune(1)/=0) then
1341	targ_tune(1)=tune(1)+((dtune(1)-tune(1))*i1)/(ntune(1))
1342	else
1343	targ_tune(1)=tune(1)
1344	endif
1345	if(ntune(2)/=0) then
1346	targ_tune(2)=tune(2)+((dtune(2)-tune(2))*i2)/(ntune(2))
1347	else
1348	targ_tune(2)=tune(2)
1349	endif
1350	if(abs(targ_RES(3))>999) then
1351	call lattice_fit_TUNE_gmap(my_ering,my_estate,epsf,pol_,NPOL,targ_tune,NP)
1352	else
1353	targ_RES(1:2)=targ_tune(1:2)
1354	call lattice_fit_tune_CHROM_gmap(my_ering,my_estate,EPSF,pol_,NPOL,targ_RES,NP)
1355	endif
1356	if(com=='SEARCHAPERTUREX=Y') then
1357	! write(mfr,*) targ_tune(1:2)
1358	CALL dyn_aperalex(my_ering,r_in,del_in,dx,dlam,pos,nturn,ite,my_estate,MFR,targ_tune,fixp)
1359	endif
1360	enddo
1361	enddo
1362	if(com=='SEARCHAPERTUREX=Y') close(mfr)
1363
1364	case('ALEXFITTUNESCAN','ALEXSEARCHAPERTUREX=Y')
1365	read(mf,*) epsf
1366	read(mf,*) ntune
1367	read(mf,*) tune(1:2)
1368	read(mf,*) dtune(1:2),targ_RES(3:4)
1369	if(com=='ALEXSEARCHAPERTUREX=Y') then
1370	READ(MF,*) r_in,del_in,dx,DLAM,fixp
1371	READ(MF,*) POS,NTURN,ITE,FILENAME,name
1372	call context(name)
1373	if(name(1:11)/='NONAMEGIVEN') then
1374	posr=pos
1375	call move_to( my_ering,p,name,posR,POS)
1376	if(pos==0) then
1377	write(6,*) name, " not found "
1378	stop
1379	endif
1380	endif
1381	call kanalnummer(mfr,filename)
1382	endif
1383
1384	sc=1.d0
1385
1386
1387	do i2=0,ntune(2)
1388	do i1=0,ntune(1)
1389
1390	if(ntune(1)/=0) then
1391	targ_tune(1)=tune(1)+((dtune(1)-tune(1))*i1)/(ntune(1))
1392	else
1393	targ_tune(1)=tune(1)
1394	endif
1395	if(ntune(2)/=0) then
1396	targ_tune(2)=tune(2)+((dtune(2)-tune(2))*i2)/(ntune(2))
1397	else
1398	targ_tune(2)=tune(2)
1399	endif
1400	targ_tune_alex(1)=22.0_dp+targ_tune(1)
1401	targ_tune_alex(2)=20.0_dp+targ_tune(2)
1402
1403	if(abs(targ_RES(3))>999) then
1404
1405	CALL special_alex_main_ring_auto(my_ering,3,targ_tune_alex,sc,epsf)
1406	call lattice_fit_TUNE_gmap(my_ering,my_estate,epsf,pol_,NPOL,targ_tune,NP)
1407	else
1408	CALL special_alex_main_ring_auto(my_ering,3,targ_tune_alex,sc,epsf)
1409	targ_RES(1:2)=targ_tune(1:2)
1410	call lattice_fit_tune_CHROM_gmap(my_ering,my_estate,EPSF,pol_,NPOL,targ_RES,NP)
1411	endif
1412	if(com=='ALEXSEARCHAPERTUREX=Y') then
1413	! write(mfr,*) targ_tune(1:2)
1414	CALL dyn_aperalex(my_ering,r_in,del_in,dx,dlam,pos,nturn,ite,my_estate,MFR,targ_tune,fixp)
1415	endif
1416	enddo
1417	enddo
1418	if(com=='ALEXSEARCHAPERTUREX=Y') close(mfr)
1419
1420	case('FITTUNE')
1421	read(mf,*) epsf
1422	read(mf,*) targ_tune
1423	if(targ_tune(1)<=0.0_dp) targ_tune=tune(1:2)
1424	call lattice_fit_TUNE_gmap(my_ering,my_estate,epsf,pol_,NPOL,targ_tune,NP)
1425	case('FITTUNEAUTO')
1426	read(mf,*) epsf
1427	read(mf,*) targ_tune
1428	read(mf,*) namet(1), namet(2)
1429	if(targ_tune(1)<=0.0_dp) targ_tune=tune(1:2)
1430	call lattice_fit_TUNE_gmap_auto(my_ering,my_estate,EPSF,targ_tune,namet)
1431	case('FITTUNECOUPLING')
1432	read(mf,*) epsf
1433	read(mf,*) targ_tune
1434	call lattice_linear_res_gmap(my_ering,my_estate,epsf,pol_,NPOL,targ_tune,NP)
1435	case('SCANTUNE')
1436	STRAIGHT=.FALSE.
1437	read(mf,*) epsf
1438	read(mf,*) nstep
1439	read(mf,*) tune_ini,tune_fin
1440	read(mf,*) name_root,SUFFIX
1441	dtu=0.0_dp
1442	IF(NSTEP(2)/=0) THEN
1443	if(nstep(1)/=1) dtu(1)=(tune_fin(1)-tune_ini(1))/(nstep(1)-1)
1444	if(nstep(2)/=1) dtu(2)=(tune_fin(2)-tune_ini(2))/(nstep(2)-1)
1445	ELSE
1446	dtu(1)=(tune_fin(1)-tune_ini(1))/(nstep(1)-1)
1447	dtu(2)=(tune_fin(2)-tune_ini(2))/(nstep(1)-1)
1448	STRAIGHT=.TRUE.
1449	NSTEP(2)=1
1450	ENDIF
1451
1452	I3=0
1453	do i1=0,nstep(1)-1
1454	do i2=0,nstep(2)-1
1455	IF(STRAIGHT) THEN
1456	targ_tune(1)=tune_ini(1)+dtu(1)*i1
1457	targ_tune(2)=tune_ini(2)+dtu(2)*I1
1458	ELSE
1459	targ_tune(1)=tune_ini(1)+dtu(1)*i1
1460	targ_tune(2)=tune_ini(2)+dtu(2)*i2
1461	ENDIF
1462	call lattice_fit_TUNE_gmap(my_ering,my_estate,epsf,pol_,NPOL,targ_tune,NP)
1463	write(title,*) 'tunes =',targ_tune
1464	I3=I3+1
1465	call create_name(name_root,i3,suffix,filename)
1466	write(6,*)" printing in "
1467	write(6,*)filename
1468	call print_bn_an(my_ering,2,title,filename)
1469	write(6,*)" PRINTED "
1470	enddo
1471	enddo
1472	case('FITSEX')
1473	read(mf,*) epsf
1474	read(mf,*) targ_chrom
1475	read(mf,*)i1
1476	call lattice_fit_CHROM_gmap1(my_ering,my_estate,EPSF,pol_,NPOL,targ_chrom,np,i1,mf)
1477	case('FITSEXLINEAR')
1478	read(mf,*) epsf
1479	read(mf,*) targ_chrom
1480	read(mf,*)i1
1481	call lattice_fit_CHROM_gmap2(my_ering,my_estate,EPSF,pol_,NPOL,targ_chrom,np,i1,mf)
1482	case('FITCHROMATICITY')
1483	read(mf,*) epsf
1484	read(mf,*) targ_chrom
1485	call lattice_fit_CHROM_gmap(my_ering,my_estate,EPSF,pol_,NPOL,targ_chrom,NP)
1486	case('FITTUNECHROMATICITY')
1487	read(mf,*) epsf
1488	read(mf,*) targ_RES
1489	call lattice_fit_tune_CHROM_gmap(my_ering,my_estate,EPSF,pol_,NPOL,targ_RES,NP)
1490	case('GETCHROMATICITY')
1491	call lattice_GET_CHROM(my_ering,my_estate,CHROM)
1492	case('OPENTUNEFILE')
1493	read(mf,*) filename
1494	call kanalnummer(mftune,filename)
1495	! write(mftune,*) " Time unit = ",unit_time ," seconds "
1496	case('CLOSETUNEFILE')
1497	close(mftune)
1498	mftune=6
1499	case('GETTUNE')
1500	call lattice_GET_tune(my_ering,my_estate,mftune)
1501	case('STRENGTH','STRENGTHFILE') !
1502	IF(mfpolbloc/=0) CLOSE(mfpolbloc)
1503
1504	READ(MF,*) file_block_name
1505
1506	if(file_block_name(1:7)/="noprint") then
1507	call kanalnummer(mfpolbloc)
1508	open(unit=mfpolbloc,file=file_block_name)
1509	endif
1510
1511	WRITE(6,*) " KNOBS PRINTED IN ",file_block_name(1:LEN_TRIM(file_block_name))
1512	case('NOSTRENGTH','NOSTRENGTHFILE') !
1513	file_block_name='noprint'
1514	IF(mfpolbloc/=0) CLOSE(mfpolbloc)
1515	case('FINALSETTING') ! ACCELERATION FILE
1516	READ(MF,*) FINAL_setting
1517	2000 INQUIRE (FILE = FINAL_setting, EXIST = exists)
1518	if(exists) then
1519	write(6,*) "file ", FINAL_setting(1:len_trim(FINAL_setting)), &
1520	" exists, interrupt execution if you do not want to overwrite!"
1521	! write(6,*) " you have 2 seconds to do so "
1522	! CALL DATE_AND_TIME(values=temps)
1523	! i1=temps(7)
1524	! if(i1>=58) i1=i1-58
1525	! do while(.true.)
1526	! CALL DATE_AND_TIME(values=temps)
1527	! if(temps(7)>i1+2) exit
1528	! enddo
1529	endif
1530	case('INITIALSETTING') ! ACCELERATION FILE
1531	READ(MF,*) initial_setting
1532	2001 INQUIRE (FILE = initial_setting, EXIST = exists)
1533	if(.not.exists) then
1534	write(6,*) "file ", initial_setting(1:len_trim(initial_setting)), &
1535	" does not exist, please input now on screen "
1536	read(5,*) initial_setting
1537	GOTO 2001
1538	endif
1539	case('PAUSE')
1540	WRITE(6,*) " Type enter to continue execution "
1541	READ(5,*)
1542	case('PRINTONCE')
1543	print77=.true.
1544	read77=.true.
1545	CASE('4DMAP')
1546	READ(MF,*) NO
1547	READ(MF,*) POS, DEL
1548	READ(MF,*) filename
1549	CALL compute_map_4d(my_ering,my_estate,filename,pos,del,no)
1550	case('PRINTAINRESONANCE')
1551	READ(MF,*) MRES(1:4)
1552	READ(MF,*) NO,EMIT0
1553	READ(MF,*) FILENAME
1554	CALL lattice_PRINT_RES_FROM_A(my_ering,my_estate,NO,EMIT0,MRES,FILENAME)
1555	case('PRINTSTATE')
1556	CALL PRINT(my_estate,6)
1557	case('PRINTTWICE')
1558	print77=.false.
1559	read77=.false.
1560	case('PRINTBNAN','PRINTANBN','PRINTBN','PRINTAN')
1561	read(mf,*) title
1562	read(mf,*) nmul,filename
1563	call print_bn_an(my_ering,nmul,title,filename)
1564	case('READBNAN','READANBN','READBN','READAN')
1565	read(mf,*) filename
1566	call READ_bn_an(my_ering,filename)
1567	case('RETURN','EXIT','QUIT','END','STOP')
1568	goto 100
1569	case('PTCEND','ENDPTC','APOCALYSPE')
1570	CALL PTC_END()
1571	goto 100
1572	case('TRACK4DNORMALIZED')
1573	emit=0.0_dp
1574	read(mf,*) IB
1575	read(mf,*) POS,NTURN,ITMAX,resmax
1576	read(mf,*) EMIT(1:2),APER(1:2),emit(3),emit(6)
1577	read(mf,*) filename,filetune,FILESMEAR
1578	! emit(3)=1.d38
1579	CALL track_aperture(my_ering,my_estate,beta,dbeta,tune,ib,ITMAX,emit,aper,pos,nturn,FILENAME,filetune,FILESMEAR,resmax)
1580	case('SCANTRACK4DNORMALIZED')
1581	emit=0.0_dp
1582
1583	read(mf,*) POS,NTURN,ITMAX,resmax
1584	read(mf,*) EMIT0(1:2),APER,emit(3),emit(6)
1585	read(mf,*) nscan,name_root,SUFFIX
1586	read(mf,*) name_root_res,SUFFIX_res
1587	ib=1
1588	allocate(resu(nscan,4))
1589	do i1=1,nscan
1590	write(6,*) " CASE NUMBER ",i1
1591	call create_name(name_root,i1,suffix,filename)
1592	call READ_bn_an(my_ering,filename)
1593	call create_name(name_root_res,i1,SUFFIX_res,filename)
1594	COMT=name_root_res(1:len_trim(name_root_res))//"_resonance"
1595	call create_name(COMT,i1,SUFFIX_res,filetune)
1596	COMT=name_root_res(1:len_trim(name_root_res))//"_SMEAR"
1597	call create_name(COMT,i1,SUFFIX_res,FILESMEAR)
1598	if(i1/=1) ib=2
1599	emit(1:2)=EMIT0
1600	CALL track_aperture(my_ering,my_estate,beta,dbeta,tune,ib,ITMAX,emit,aper,pos,nturn,FILENAME,filetune,FILESMEAR,resmax)
1601	resu(i1,1:2)=emit(4:5)
1602	resu(i1,3:4)=emit(1:2)
1603	enddo
1604	filetune=name_root_res(1:len_trim(name_root_res))//'.'//SUFFIX_res
1605	call kanalnummer(mfr)
1606
1607	OPEN(UNIT=mfr,FILE=filetune)
1608	write(mfr,*) " Precision = ",emit(3),emit(6)
1609	do i1=1,nscan
1610	write(mfr,205) i1,resu(i1,1:4)
1611	enddo
1612	deallocate(resu)
1613	close(mfr)
1614	205 FORMAT(1x,i4,4(1X,D18.11))
1615	case('SEARCHAPERTURE')
1616
1617	READ(MF,*) r_in,n_in,ang_in,ang_out,del_in,DLAM
1618	READ(MF,*) POS,NTURN,ITE,FILENAME,name
1619	call context(name)
1620	if(name(1:11)/='NONAMEGIVEN') then
1621	posr=pos
1622	call move_to( my_ering,p,name,posR,POS)
1623	if(pos==0) then
1624	write(6,*) name, " not found "
1625	stop
1626	endif
1627	endif
1628
1629
1630	call kanalnummer(mfr)
1631	open(unit=mfr,file=filename)
1632	CALL dyn_aper(my_ering,r_in,n_in,ang_in,ang_out,del_in,dlam,pos,nturn,ite,my_estate,MFR)
1633	close(mfr)
1634
1635	case('KNOB')
1636
1637	READ(MF,*) POS, IBN
1638
1639	if (pos > my_ering%n) stop
1640
1641	p=>my_ering%start
1642	do ii=1,pos
1643	p=>p%next
1644	enddo
1645
1646
1647	write(6,*) "El name ", p%mag%name
1648
1649
1650	CALL INIT(default,3,1,BERZ)
1651
1652	print*, "Npara is ", c_%NPARA
1653
1654	pb = 0
1655	pb%name = p%mag%name
1656	write(6,*) "IBN ", IBN
1657	pb%ibn(ibn) = 1
1658
1659	my_ering = pb
1660
1661	CALL ALLOC(ID)
1662	CALL ALLOC(Y)
1663	x(:)=0
1664	ID=1
1665	Y=X+ID
1666
1667	p=>my_ering%start
1668	do ii=1,my_ering%n
1669	write(6,*) "##########################################"
1670	write(6,'(i4, 1x,a, f10.6)') ii,p%mag%name
1671	write(6,'(a, f9.6, a)') "Ref Momentum ",p%mag%p%p0c," GeV/c"
1672
1673	call track(my_ering,y,ii,ii+1,default)
1674	call daprint(y(1),6)
1675	p=>p%next
1676
1677	enddo
1678
1679	case('ALEXREMOVAL')
1680	call special_alex_main_ring_removal(my_ering)
1681	case('SASHASPECIALRCS')
1682	READ(MF,*) epsf,sca ! aper scale >0 <=1
1683	! call lattice_fit_bump_rcs(my_ering,epsf)
1684	call lattice_fit_bump_min_rcs(my_ering%next,my_ering,EPSF,pol_,NPOL,sca)
1685	case('PRINTFRAMES')
1686
1687	READ(MF,*) FILENAME
1688	CALL print_frames(my_ering,filename)
1689
1690
1691	case('PRINTNEWFLATFILE')
1692
1693	READ(MF,*) FILENAME
1694
1695	call print_new_flat(my_ering,filename)
1696
1697	case('READNEWFLATFILE')
1698
1699	READ(MF,*) FILENAME
1700	call read_lattice_append(M_U,filename)
1701	WRITE(6,*) M_U%END%N, M_U%END%END%POS
1702
1703	case('READFLATFILE')
1704
1705	READ(MF,*) FILENAME
1706	CALL READ_AND_APPEND_VIRGIN_general(M_U,filename)
1707
1708	WRITE(6,*) M_U%END%N, M_U%END%END%POS
1709
1710	case('PRINTFLATFILE')
1711
1712	READ(MF,*) FILENAME
1713	CALL print_COMPLEX_SINGLE_STRUCTURE(my_ering,filename,lmax0=lmax)
1714
1715	WRITE(6,*) M_U%END%N, M_U%END%END%POS
1716	case('SKIPMARKER','SKIPMARKERS')
1717	print_marker=my_false
1718	case('INCLUDEMARKER','INCLUDEMARKERS')
1719	print_marker=my_true
1720
1721	case('TOGGLEMARKER','TOGGLEMARKERS')
1722	print_marker=.not.print_marker
1723	if(print_marker) then
1724	Write(6,*) 'printing makers on flat file '
1725	else
1726	Write(6,*) ' NOT printing makers on flat file '
1727	endif
1728	case('PERMFRINGEON')
1729
1730	CALL PUTFRINGE(my_ering,MY_TRUE)
1731
1732	case('PERMFRINGEOFF')
1733
1734	CALL PUTFRINGE(my_ering,MY_FALSE)
1735
1736	case('BENDFRINGEON')
1737
1738	CALL PUTbend_FRINGE(my_ering,MY_TRUE)
1739
1740	case('BENDFRINGEOFF')
1741
1742	CALL PUTbend_FRINGE(my_ering,MY_FALSE)
1743
1744	case('SOLENOID2','SOLENOIDFRINGE')
1745
1746	write(6,*) " At the ends of all solenoids kick of the form "
1747	write(6,) " X(2)=X(2)+X(1)B/PZ where pz=1+delta"
1748	write(6,) " X(4)=X(4)+X(3)B/PZ "
1749	write(6,) " X(6)=X(6)-0.5_dpB(X(1)2+X(3)2)TIME_FAC/PZ**2 "
1750
1751	read(mf,*) fint,hgap
1752
1753	p=>my_ering%start
1754	nscan=0
1755
1756	do ii=1,my_ering%n
1757	if(associated(p%mag%s5)) then
1758	p%mag%s5%fint=fint
1759	p%mag%s5%hgap=hgap
1760	p%magp%s5%fint=fint
1761	p%magp%s5%hgap=hgap
1762	nscan=nscan+1
1763	endif
1764	p=>p%next
1765	enddo
1766	Write(6,*) " Found ",nscan," Solenoids"
1767
1768	case('CAVITYBESSEL','CAVITYINNERFIELD')
1769
1770	read(mf,*) n_bessel
1771	nscan=0
1772	p=>my_ering%start
1773
1774	do ii=1,my_ering%n
1775	if(associated(p%mag%c4)) then
1776	p%mag%c4%n_bessel=n_bessel
1777	p%magp%c4%n_bessel=n_bessel
1778	nscan=nscan+1
1779	endif
1780	p=>p%next
1781	enddo
1782
1783	Write(6,*) " Found ",nscan," Cavities"
1784
1785	case('REVERSEBEAMLINE')
1786
1787	CALL REVERSE_BEAM_LINE(my_ering)
1788
1789	! WRITE(6,*) M_U%END%N, M_U%END%END%POS
1790
1791	case('PSREXAMPLEOFPATCHING')
1792
1793	call APPEND_EMPTY_LAYOUT(m_u)
1794	CALL remove_drifts(my_ering,m_u%END)
1795	m_u%end%name="psr_no_drift"
1796	call APPEND_EMPTY_LAYOUT(m_u)
1797	m_u%end%name="psr_quads_for_bends"
1798	CALL remove_drifts_bends(my_ering,m_u%END)
1799
1800	WRITE(6,*) my_ering%N , m_u%END%N
1801
1802	case('NORMALFORM')
1803	READ(MF,*)POS,name
1804	READ(MF,*) FILENAME
1805
1806	case('TRANSLATELAYOUT')
1807	READ(MF,*)DT
1808	CALL TRANSLATE(my_ering,DT)
1809	case('TRANSLATEPARTOFLAYOUT')
1810	READ(MF,*)DT
1811	READ(MF,*) I1,I2
1812	CALL TRANSLATE(my_ering,DT,I1,I2)
1813	CALL MOVE_TO(my_ering,P,i1)
1814	CALL FIND_PATCH(P%PREVIOUS,P,NEXT=my_TRUE,ENERGY_PATCH=my_FALSE)
1815	CALL MOVE_TO(my_ering,P,i2)
1816	CALL FIND_PATCH(P,P%NEXT,NEXT=my_FALSE,ENERGY_PATCH=my_FALSE)
1817	case('ROTATEPARTOFLAYOUT')
1818
1819	READ(MF,*)DT
1820	READ(MF,*) I1,I2
1821	CALL MOVE_TO(my_ering,P,i1)
1822	call ROTATE_LAYOUT(my_ering,P%mag%p%f%ent,DT,I1,I2)
1823	CALL MOVE_TO(my_ering,P,i1)
1824	CALL FIND_PATCH(P%PREVIOUS,P,NEXT=MY_TRUE,ENERGY_PATCH=MY_FALSE)
1825	CALL MOVE_TO(my_ering,P,i2)
1826	CALL FIND_PATCH(P,P%NEXT,NEXT=MY_FALSE,ENERGY_PATCH=MY_FALSE)
1827
1828	case('TRANSLATEFIBREANDPATCH')
1829	READ(MF,*)POS
1830	READ(MF,*)DT
1831	CALL MOVE_TO(my_ering,P,POS)
1832	CALL TRANSLATE_Fibre(P,DT,ORDER=1,BASIS=P%MAG%P%F%MID)
1833	CALL FIND_PATCH(P%PREVIOUS,P,NEXT=MY_TRUE,ENERGY_PATCH=MY_FALSE)
1834	CALL FIND_PATCH(P,P%NEXT,NEXT=MY_FALSE,ENERGY_PATCH=MY_FALSE)
1835	case('DEBUG')
1836	read(mf,*) debug_flag,debug_acos
1837	case('VALISHEVON')
1838	valishev=my_true
1839	Write(6,*)"Valishev's multipoles are on"
1840	case('VALISHEVOFF')
1841	valishev=my_true
1842	Write(6,*)"Valishev's multipoles are off"
1843	case('POWERVALISHEV')
1844	valishev=my_true
1845	READ(MF,*)POS
1846	READ(MF,*)A1,B1
1847	CALL MOVE_TO(my_ering,P,POS)
1848	p%mag%VA=A1
1849	p%mag%VS=B1
1850	p%magp%VA=A1
1851	p%magp%VS=B1
1852	case('POWERVALISHEVQUADRUPOLE')
1853	valishev=my_true
1854	READ(MF,*)POS
1855	READ(MF,*)A1,B1
1856	CALL MOVE_TO(my_ering,P,POS)
1857	a1=p%mag%bn(2)
1858	cns=0.0_dp
1859	CALL ADD(P,2,0,cns)
1860	a1=0.5_dpa1b1**2
1861	p%mag%VA=A1
1862	p%mag%VS=B1
1863	p%magp%VA=A1
1864	p%magp%VS=B1
1865	case('VALISHEVALLQUADRUPOLE')
1866	valishev=my_true
1867	READ(MF,*)B1
1868	i2=0
1869	p=>my_ering%start
1870	do i1=1,my_ering%n
1871	if(.not.associated(p%mag%volt).and.associated(p%mag%bn)) then
1872	if(p%mag%p%nmul>=2) then
1873	a1=p%mag%bn(2)
1874	cns=0.0_dp
1875	CALL ADD(P,2,0,cns)
1876	a1=0.5_dpa1b1**2
1877	p%mag%VA=A1
1878	p%mag%VS=B1
1879	p%magp%VA=A1
1880	p%magp%VS=B1
1881	i2=i2+1
1882	endif
1883	endif
1884	p=>p%next
1885	enddo
1886	write(6,*) i2, "Quadrupoles globally replaced by Valishev quadrupoles"
1887	case('UNDOVALISHEVQUADRUPOLE')
1888	valishev=my_false
1889	p=>my_ering%start
1890	i2=0
1891	do i1=1,my_ering%n
1892	if(.not.associated(p%mag%volt).and.associated(p%mag%bn)) then
1893	if(p%mag%p%nmul>=2) then
1894	a1= p%magp%VA
1895	B1=p%magp%VS
1896	a1=a12.0_dp/b1*2
1897	p%mag%VA=0.0_dp
1898	p%mag%VS=0.0_dp
1899	p%magp%VA=0.0_dp
1900	p%magp%VS=0.0_dp
1901	cns=a1
1902	i2=i2+1
1903	CALL ADD(P,2,1,cns)
1904	endif
1905	endif
1906	p=>p%next
1907	enddo
1908	write(6,*) i2,"Valishev quadrupoles globally replaced by normal quadrupoles"
1909	case('POWERVALISHEVNAME')
1910	valishev=my_true
1911	READ(MF,*)name !,POS
1912	READ(MF,*)A1,B1
1913	! call move_to(my_ering,p,name,POS)
1914	i2=0
1915	p=>my_ering%start
1916	do i1=1,my_ering%n
1917	if(.not.associated(p%mag%volt).and.associated(p%mag%bn).and.name==p%mag%name) then
1918	if(p%mag%p%nmul>=2) then
1919	i2=i2+1
1920	p%mag%VA=A1
1921	p%mag%VS=B1
1922	p%magp%VA=A1
1923	p%magp%VS=B1
1924	endif
1925	endif
1926	p=>p%next
1927	enddo
1928	write(6,*) " found ",i2, " Valishev quadrupoles "
1929	case('POWERVALISHEVNAMEQUADRUPOLE')
1930	valishev=my_true
1931	READ(MF,*)name !,POS
1932	READ(MF,*)A1,B1
1933	! call move_to(my_ering,p,name,POS)
1934	p=>my_ering%start
1935	do i1=1,my_ering%n
1936	if(.not.associated(p%mag%volt).and.associated(p%mag%bn).and.name==p%mag%name) then
1937	if(p%mag%p%nmul>=2) then
1938	i2=i2+1
1939	a1=p%mag%bn(2)
1940	cns=0.0_dp
1941	CALL ADD(P,2,0,cns)
1942	a1=0.5_dpa1b1**2
1943	p%mag%VA=A1
1944	p%mag%VS=B1
1945	p%magp%VA=A1
1946	p%magp%VS=B1
1947	endif
1948	endif
1949	p=>p%next
1950	enddo
1951	write(6,*) " found ",i2, " Valishev quadrupoles "
1952	case('POWERMULTIPOLE')
1953	READ(MF,*)POS
1954	READ(MF,*)n,cns, bend_like
1955	CALL MOVE_TO(my_ering,P,POS)
1956	CALL ADD(P,N,0,CNS)
1957	p%mag%p%bend_fringe=bend_like
1958	p%magp%p%bend_fringe=bend_like
1959	case('POWERMULTIPOLENAME')
1960	READ(MF,*)name !,POS
1961	READ(MF,*)n,cns, bend_like
1962	call move_to(my_ering,p,name,POS)
1963	if(pos/=0) then
1964	CALL ADD(P,N,0,CNS)
1965	p%mag%p%bend_fringe=bend_like
1966	p%magp%p%bend_fringe=bend_like
1967	else
1968	write(6,*) name," Not found "
1969	stop 555
1970	endif
1971	case('POWERHELICALDIPOLE','POWERHELICAL')
1972
1973	!SRM DEBUG ... typo
1974	!B_TESLA --> B_TESLA
1975
1976	READ(MF,*)name, VORNAME !,POS
1977	READ(MF,*) A1,B1 ! A1,B1
1978	READ(MF,*) NLAM ! NUMBER OF WAVES
1979	READ(MF,*) HPHA ! PHASE
1980	READ(MF,*) CUR2,CUR1,B_TESLA ! ACTUAL CURRENT, REF CURRENT, b FIELD
1981	READ(MF,*) I1,I2 ! NST,METHOD
1982	call move_to(my_ering,p,name,VORNAME,POS)
1983	if(pos/=0) then
1984	W=P
1985	B_TESLA=CUR2/CUR1*B_TESLA/w%brho
1986
1987	p%mag%bn(1)=B_TESLA+B1
1988	p%magp%bn(1)=B_TESLA+B1
1989	p%mag%an(1)=-B_TESLA+A1
1990	p%magp%an(1)=-B_TESLA+A1
1991
1992	!SRM DEBUG ... phase
1993	p%mag%phas=twopi*HPHA
1994	p%magp%phas=p%mag%phas
1995
1996	!SRM DEBUG ... multiply NLAM
1997	! p%mag%freq=twopi/p%mag%l/NLAM
1998	p%mag%freq=twopi/p%mag%l*NLAM
1999	p%magp%freq=p%mag%freq
2000
2001	p%mag%p%nst=I1
2002	p%mag%p%method=I2
2003	p%magp%p%nst=I1
2004	p%magp%p%method=I2
2005	else
2006	write(6,*) name," Not found "
2007	stop 555
2008	endif
2009	case('COMPUTEMAP')
2010	READ(MF,*)POS,DEL,NO
2011	READ(MF,*) FILENAME
2012
2013	CALL compute_map_general(my_ering,my_estate,filename,pos,del,no)
2014
2015	case('ZEROSEXTUPOLES')
2016	call zero_sex(my_ering)
2017	case('POWERCAVITY')
2018	c_%CAVITY_TOTALPATH=0 ! fake pill box
2019	! c_%phase0=0.0_dp ! because madx is crap anyway
2020	READ(MF,*)HARMONIC_NUMBER,VOLT,PHASE,c_%phase0,c_%CAVITY_TOTALPATH,epsf
2021	c_%phase0=c_%phase0*pi
2022	CALL power_cavity(my_ering,HARMONIC_NUMBER,VOLT,PHASE,epsf)
2023
2024
2025	case('CAVITYTOTALPATH')
2026	read(mf,*) pos
2027
2028	if(pos/=0.and.pos/=1) then
2029	Write(6,*) "Cavity totalpath must 0 or 1"
2030	stop 665
2031	endif
2032
2033	call totalpath_cavity(my_ering,pos)
2034
2035	case('EQUILIBRIUMSIZES')
2036	READ(MF,*) POS,FILENAME,fileTUNE, NAME
2037	call context(name)
2038	if(name(1:11)/='NONAMEGIVEN') then
2039	posr=pos
2040	call move_to( my_ering,p,name,posR,POS)
2041	if(pos==0) then
2042	write(6,*) name, " not found "
2043	stop
2044	endif
2045	endif
2046	CALL radia(my_ering,POS,FILENAME,fileTUNE,my_estate)
2047	case('NEWEQUILIBRIUMSIZES')
2048	READ(MF,*) POS,FILENAME, i1,NAME
2049	call context(name)
2050	if(name(1:11)/='NONAMEGIVEN') then
2051	posr=pos
2052	call move_to( my_ering,p,name,posR,POS)
2053	if(pos==0) then
2054	write(6,*) name, " not found "
2055	stop
2056	endif
2057	endif
2058	call radia_new(my_ering,POS,i1,FILENAME,my_estate)
2059	case('SPECIALALEX')
2060	READ(MF,*) I1
2061	READ(MF,*) targ_tune(1:2),sc
2062
2063	CALL special_alex_main_ring(my_ering,i1,targ_tune,sc)
2064
2065	case('SPECIALALEXAUTO')
2066	READ(MF,*) I1,epsf
2067	READ(MF,*) targ_tune(1:2),sc
2068
2069	CALL special_alex_main_ring_auto(my_ering,i1,targ_tune,sc,epsf)
2070
2071
2072	case default
2073
2074	write(6,*) " Command Ignored "
2075
2076	end select
2077
2078
2079	enddo
2080	100 continue
2081	! if(associated(my_old_state)) my_estate=>my_old_state
2082
2083	write(6,*) " Exiting Command File ", ptc_fichier(1:len_trim(ptc_fichier))
2084
2085	close(mf)
2086
2087	END subroutine read_ptc_command
2088
2089	subroutine totalpath_cavity(r,j)
2090	implicit none
2091	TYPE(LAYOUT), POINTER :: r
2092	type(fibre), pointer :: p
2093	integer i,j
2094
2095
2096	p=>r%start
2097	do i=1,r%n
2098
2099	if(p%mag%kind==kind4) then
2100	write(6,*) " cavity found ",p%mag%name,p%mag%vorname
2101	p%mag%c4%CAVITY_TOTALPATH=mod(j,2)
2102	p%magp%c4%CAVITY_TOTALPATH=mod(j,2)
2103	endif
2104
2105	p=>P%NEXT
2106
2107	enddo
2108	c_%CAVITY_TOTALPATH=j
2109	end subroutine totalpath_cavity
2110
2111	subroutine power_cavity(r,HARM,VOLT,PHAS,prec)
2112	implicit none
2113	TYPE(LAYOUT), POINTER :: r
2114	type(fibre), pointer :: p
2115	integer i,ip,HARM,j
2116	type(internal_state) state
2117	real(dp) closed(6),s,VOLT,PHAS,accuracy,circum,freq
2118	real(dp),optional :: prec
2119
2120	call get_length(r,circum)
2121
2122	write(6,*) " fiducial length ",circum
2123
2124	state=my_estate+nocavity0-totalpath0
2125
2126	accuracy=1.0e-10_dp
2127	if(present(prec)) accuracy=prec
2128	closed=0.0_dp
2129	CALL FIND_ORBIT(R,CLOSED,1,STATE,1e-5_dp)
2130
2131	closed(6)=0.d0
2132	call track(r,closed,1,state+totalpath0+time0)
2133	write(6,*) " CT = ",closed(6)
2134
2135	freq=HARM*CLIGHT/closed(6)
2136
2137	ip=0
2138	p=>r%start
2139	do i=1,r%n
2140	closed(6)=0.0_dp
2141	call track(r,closed,i,i+1,state)
2142	s=closed(6)
2143	circum=circum+s
2144	IF(ABS(s)>accuracy) THEN
2145	ip=ip+1
2146	p%patch%b_t=-s
2147	p%patch%time=2
2148	ELSE
2149	p%patch%time=0
2150	ENDIF
2151	p=>P%next
2152	enddo
2153
2154	if(ip/=0) then
2155	WRITE(6,*)"?????????????????????????????????????????????????????????????"
2156	WRITE(6,*)"?????????????????????????????????????????????????????????????"
2157	WRITE(6,*)IP,"TIME PATCHES WERE NEEDED BECAUSE BENDS HAVE BEEN ADJUSTED "
2158	WRITE(6,*)"THEY WERE PUT AT THE END OF SEVERAL FIBRES "
2159	WRITE(6,*)"TIME PATCH MAYBE NEEDED IN IDEAL LATTICES IF BENDS ARE ADJUSTED "
2160	WRITE(6,*) " ACTUAL LENGTH ",CIRCUM
2161	WRITE(6,*)"?????????????????????????????????????????????????????????????"
2162	WRITE(6,*)"?????????????????????????????????????????????????????????????"
2163	endif
2164
2165
2166	p=>r%start
2167	do i=1,r%n
2168
2169	if(p%mag%kind==kind4) then
2170	write(6,*) " Before "
2171
2172	! write(6,*) p%mag%name
2173	! write(6,*) " volt = ",p%mag%volt
2174	! write(6,*) " freq = ",p%mag%freq
2175	! write(6,*) " phas = ",p%mag%phas
2176	! write(6,*) " ref p0c = ",p%mag%p%p0c
2177	! write(6,*) "electron = ", c_%electron
2178	if(p%mag%l/=0.0_dp) then
2179	p%mag%volt=VOLT/p%mag%l
2180	p%magp%volt=p%mag%volt
2181	else
2182	p%mag%volt=VOLT !/p%mag%l
2183	p%magp%volt=p%mag%volt
2184	endif
2185	p%mag%freq=freq !CLIGHT*HARM/circum ! harmonic=120.0_dp
2186	p%magp%freq=p%mag%freq
2187	p%mag%phas=PHAS
2188	p%magp%phas=p%mag%phas
2189	write(6,*) " After "
2190
2191	write(6,*) p%mag%name
2192	write(6,*) " volt = ",p%mag%volt
2193	write(6,*) " freq = ",p%mag%freq
2194	write(6,*) " phas = ",p%mag%phas
2195	write(6,*) " ref p0c = ",p%mag%p%p0c
2196	p%mag%c4%phase0=0.0_dp
2197	p%magp%c4%phase0=0.0_dp
2198	p%mag%c4%f(1)=1.0_dp
2199	p%magp%c4%f(1)=1.0_dp
2200	p%mag%c4%ph(1)=0.0_dp
2201	p%magp%c4%ph(1)=0.0_dp
2202	p%mag%c4%CAVITY_TOTALPATH=0
2203	p%magp%c4%CAVITY_TOTALPATH=0
2204	do j=2,p%mag%c4%nf
2205	p%mag%c4%f(j)=0.0_dp
2206	p%magp%c4%f(j)=0.0_dp
2207	p%mag%c4%ph(j)=0.0_dp
2208	p%magp%c4%ph(j)=0.0_dp
2209	enddo
2210	! write(6,*) "electron = ", c_%electron
2211	! write(6,*) " phase0 = ", c_%phase0
2212	if(c_%CAVITY_TOTALPATH==0) write(6,*) " fake cavity "
2213	endif
2214	p=>P%NEXT
2215
2216	enddo
2217
2218	end subroutine power_cavity
2219
2220	subroutine zero_sex(r)
2221	implicit none
2222	TYPE(LAYOUT), POINTER :: r
2223	type(fibre), pointer :: p
2224	integer i
2225
2226	p=>r%start
2227	do i=1,r%n
2228	if(associated(p%mag%bn)) then
2229	if(p%mag%p%nmul>=3) then
2230	call add(p,3,0,0.0_dp)
2231	endif
2232	endif
2233	p=>p%next
2234	enddo
2235
2236	end subroutine zero_sex
2237
2238	subroutine charge_dir(r)
2239	implicit none
2240	TYPE(LAYOUT), POINTER :: r
2241	type(fibre), pointer :: p
2242	integer i
2243	p=>r%start
2244	do i=1,r%n
2245	p%dir=-p%dir
2246	p=>p%next
2247	enddo
2248
2249	end subroutine charge_dir
2250
2251
2252	SUBROUTINE remove_drifts(R,NR)
2253	IMPLICIT NONE
2254	TYPE(LAYOUT),TARGET :: R,NR
2255	integer I
2256	type(fibre), pointer :: P
2257	logical(lp) doneit
2258
2259	p=>r%start
2260
2261	do i=1,r%n
2262	IF(P%MAG%KIND/=KIND0.AND.P%MAG%KIND/=KIND1) THEN
2263
2264	! call APPEND_EMPTY(NR)
2265	CALL APPEND( NR, P )
2266
2267	ENDIF
2268	P=>P%NEXT
2269	ENDDO
2270
2271	NR%closed=.true.
2272	doneit=.true.
2273	call ring_l(NR,doneit)
2274
2275
2276	write(6,*) " do you want patching ?"
2277	read(5,*) i
2278	if(i==0) return
2279
2280	p=>nr%start
2281
2282	do i=1,nr%n-1
2283	CALL FIND_PATCH(P,P%next,NEXT=MY_TRUE,ENERGY_PATCH=MY_FALSE)
2284
2285	P=>P%NEXT
2286	ENDDO
2287	CALL FIND_PATCH(P,P%next,NEXT=my_false,ENERGY_PATCH=MY_FALSE)
2288
2289	! avoiding putting a patch on the very first fibre since survey does not allow it....
2290
2291
2292	end SUBROUTINE remove_drifts
2293
2294	SUBROUTINE remove_drifts_bends(R,NR) ! special example to be removed later
2295	IMPLICIT NONE
2296	TYPE(LAYOUT),TARGET :: R,NR
2297	integer I,IG
2298	type(fibre), pointer :: P,bend
2299	logical(lp) doneit
2300	real(dp) ent(3,3),a(3),ang(3),d(3)
2301
2302	p=>r%start
2303	bend=>r%next%start%next ! second layout in universe
2304	write(6,*) " using bend called ",bend%mag%name
2305	write(6,*) " 'USING SURVEY' TYPE 1 / 'USING GEOMETRY' TYPE 0 "
2306	READ(5,*) IG
2307	do i=1,r%n
2308	IF(P%MAG%KIND/=KIND0.AND.P%MAG%KIND/=KIND1.and.P%MAG%p%b0==0.0_dp) THEN
2309
2310	CALL APPEND( NR, P )
2311	elseif(P%MAG%p%b0/=0.0_dp) then
2312	bend%mag%p%bend_fringe=.true.
2313	bend%magp%p%bend_fringe=.true.
2314	bend%mag%L=P%MAG%p%lc
2315	bend%magp%L=P%MAG%p%lc ! give it correct arc length
2316	bend%mag%p%Lc=P%MAG%p%lc
2317	bend%magp%p%Lc=P%MAG%p%lc ! give it correct arc length
2318	bend%mag%p%Ld=P%MAG%p%lc
2319	bend%magp%p%Ld=P%MAG%p%lc ! give it correct arc length
2320	call add(bend,1,0,p%mag%bn(1)) ! Give a huge B field to quadrupole, i.e. looks like a kicker now
2321	CALL APPEND( NR, bend )
2322	ent=p%chart%f%mid ! storing the bend location
2323	a=p%chart%f%a !
2324	! since we use a quadrupole, the entrance frame of this quad is the mid frame of the bend
2325	! The fibre bend must be rotated and translated into position
2326	! easiest way is to survey it with initial condition correspounding to the actual position and orientation
2327	!
2328	IF(IG==1) THEN
2329	call SURVEY(nr%end,ENT,A)
2330	ELSE
2331	d=a-nr%end%chart%f%a
2332	CALL TRANSLATE_Fibre(nr%end,D) ! translation in global frame
2333	CALL COMPUTE_ENTRANCE_ANGLE(nr%end%chart%f%ENT,ENT,ANG)
2334	CALL ROTATE_Fibre(nr%end,A,ang) ! translation in global frame
2335	ENDIF
2336
2337
2338	ENDIF
2339	P=>P%NEXT
2340	ENDDO
2341
2342	NR%closed=.true.
2343	doneit=.true.
2344	call ring_l(NR,doneit)
2345
2346
2347
2348	p=>nr%start
2349
2350	do i=1,nr%n-1
2351	CALL FIND_PATCH(P,P%next,NEXT=MY_TRUE,ENERGY_PATCH=MY_FALSE)
2352
2353	P=>P%NEXT
2354
2355	ENDDO
2356	CALL FIND_PATCH(P,P%next,NEXT=my_false,ENERGY_PATCH=MY_FALSE)
2357
2358	! avoiding putting a patch on the very first fibre since survey is not a self-check in that case
2359
2360
2361	end SUBROUTINE remove_drifts_bends
2362
2363
2364
2365
2366	SUBROUTINE print_frames(R,filename)
2367	IMPLICIT NONE
2368	TYPE(LAYOUT),TARGET :: R
2369	integer I,mf
2370	type(fibre), pointer :: P
2371	character(*) filename
2372	call kanalnummer(mf)
2373
2374
2375	open(unit=mf,file=filename)
2376	write(mf,*) "Contains location of each fibre and the magnet within the fibre "
2377	write(mf,*) "N.B. Drifts and Markers are fibres in PTC "
2378	p=>r%start
2379	do i=1,r%n
2380
2381
2382	! INTEGER(2), POINTER:: PATCH ! IF TRUE, SPACIAL PATCHES NEEDED
2383	! INTEGER, POINTER :: A_X1,A_X2 ! FOR ROTATION OF PI AT ENTRANCE = -1, DEFAULT = 1 ,
2384	! INTEGER, POINTER :: B_X1,B_X2 ! FOR ROTATION OF PI AT EXIT = -1 , DEFAULT = 1
2385	! REAL(DP),DIMENSION(:), POINTER:: A_D,B_D !ENTRACE AND EXIT TRANSLATIONS A_D(3)
2386	! REAL(DP),DIMENSION(:), POINTER:: A_ANG,B_ANG !ENTRACE AND EXIT ROTATIONS A_ANG(3)
2387	! INTEGER(2), POINTER:: ENERGY ! IF TRUE, ENERGY PATCHES NEEDED
2388	! INTEGER(2), POINTER:: TIME ! IF TRUE, TIME PATCHES NEEDED
2389	! REAL(DP), POINTER:: A_T,B_T ! TIME SHIFT NEEDED SOMETIMES WHEN RELATIVE TIME IS USED
2390	write(mf,*) " $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$"
2391	write(mf,*) " "
2392	write(mf,*) "\|\| position = ", i,' \|\| PTC kind = ', P%mag%kind," \|\| name = ",P%mag%name, " \|\|"
2393	write(mf,*) " "
2394	if(p%patch%patch==1.or.p%patch%patch==3) then
2395	write(mf,*) " >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>"
2396	write(mf,*) " Entrance geometrical Patch "
2397	write(mf,*) " Translations A_D(3) "
2398	write(mf,*) P%patch%a_d
2399	write(mf,*) " Rotations A_ANG(3) \|\| PI rotations -> ",p%patch%a_x1,p%patch%a_x2
2400	write(mf,*) P%patch%A_ANG
2401	write(mf,*) " <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<"
2402	write(mf,*) " "
2403	endif
2404	write(mf,*) " Fibre positioning or Ideal position in conventional parlance"
2405	write(mf,*) " "
2406	write(mf,*) " Entrance origin A(3) "
2407	write(mf,*) P%chart%f%a
2408	write(mf,*) " Entrance frame (i,j,k) basis in the ent(3,3) array "
2409	write(mf,*) P%chart%f%ent(1,:)
2410	write(mf,*) P%chart%f%ent(2,:)
2411	write(mf,*) P%chart%f%ent(3,:)
2412	write(mf,*) " Middle origin O(3) "
2413	write(mf,*) P%chart%f%o
2414	write(mf,*) " Middle frame (i,j,k) basis in the ent(3,3) array "
2415	write(mf,*) P%chart%f%mid(1,:)
2416	write(mf,*) P%chart%f%mid(2,:)
2417	write(mf,*) P%chart%f%mid(3,:)
2418	write(mf,*) " Exit origin B(3) "
2419	write(mf,*) P%chart%f%B
2420	write(mf,*) " Exit frame (i,j,k) basis in the ent(3,3) array "
2421	write(mf,*) P%chart%f%exi(1,:)
2422	write(mf,*) P%chart%f%exi(2,:)
2423	write(mf,*) P%chart%f%exi(3,:)
2424	write(mf,*) " "
2425	write(mf,*) " Actual magnet positioning "
2426	write(mf,*) " "
2427	write(mf,*) " Entrance origin A(3) "
2428	write(mf,*) P%mag%p%f%a
2429	write(mf,*) " Entrance frame (i,j,k) basis in the ent(3,3) array "
2430	write(mf,*) P%mag%p%f%ent(1,:)
2431	write(mf,*) P%mag%p%f%ent(2,:)
2432	write(mf,*) P%mag%p%f%ent(3,:)
2433	write(mf,*) " Middle origin O(3) "
2434	write(mf,*) P%mag%p%f%o
2435	write(mf,*) " Middle frame (i,j,k) basis in the ent(3,3) array "
2436	write(mf,*) P%mag%p%f%mid(1,:)
2437	write(mf,*) P%mag%p%f%mid(2,:)
2438	write(mf,*) P%mag%p%f%mid(3,:)
2439	write(mf,*) " Exit origin B(3) "
2440	write(mf,*) P%mag%p%f%B
2441	write(mf,*) " Exit frame (i,j,k) basis in the ent(3,3) array "
2442	write(mf,*) P%mag%p%f%exi(1,:)
2443	write(mf,*) P%mag%p%f%exi(2,:)
2444	write(mf,*) P%mag%p%f%exi(3,:)
2445	if(p%patch%patch==2.or.p%patch%patch==3) then
2446	write(mf,*) " >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>"
2447	write(mf,*) " Exit geometrical Patch "
2448	write(mf,*) " Translations B_D(3) "
2449	write(mf,*) P%patch%b_d
2450	write(mf,*) " Rotations B_ANG(3) \|\| PI rotations -> ",p%patch%b_x1,p%patch%b_x2
2451	write(mf,*) P%patch%B_ANG
2452	write(mf,*) " <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<"
2453	write(mf,*) " "
2454	endif
2455	write(mf,*) " $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$"
2456
2457	P=>P%NEXT
2458	ENDDO
2459
2460	close(mf)
2461	end SUBROUTINE print_frames
2462
2463	subroutine printframes(filenameIA)
2464	use madx_ptc_module
2465	implicit none
2466	character*48 charconv
2467	! include 'twissa.fi'
2468	integer filenameIA(*)
2469	character(48) filename
2470
2471	filename = charconv(filenameIA)
2472	call print_frames(my_ering,filename)
2473
2474	end subroutine printframes
2475
2476
2477	SUBROUTINE radia(R,loc,FILE1,FILE2,estate,ast,asti,kick,mat,mat0,fixrad)
2478	implicit none
2479	TYPE(LAYOUT) R
2480
2481	REAL(DP) X(6),m,as(6,6),energy,deltap
2482	TYPE(ENV_8) YS(6) !
2483	type(beamenvelope) env
2484	CHARACTER(*) FILE1,FILE2
2485	type(normalform) normal
2486	integer nd2,npara,i,j,js(6),n1,n2
2487	TYPE(REAL_8) Y(6)
2488	TYPE(DAMAP) ID
2489	TYPE(INTERNAL_STATE) state
2490	TYPE(INTERNAL_STATE), target :: estate
2491	integer no,loc,mf1,mf2
2492	real(dp) av(6,6),e(3),mat0i(6,6)
2493	real(dp),optional :: ast(6,6),asti(6,6),kick(6),mat(6,6),mat0(6,6),fixrad(6)
2494	type(fibre), pointer :: p
2495	no=0
2496	call kanalnummer(mf1)
2497	open(mf1,file=FILE1)
2498	call kanalnummer(mf2)
2499	open(mf2,file=FILE2)
2500
2501
2502	if(present(mat0)) then
2503	state=(estate-nocavity0)+radiation0
2504	x=0.d0
2505	CALL FIND_ORBIT_x(R,X,STATE,1.0e-5_dp,fibre1=loc)
2506	CALL INIT(state,1,0)
2507	CALL ALLOC(Y)
2508	CALL ALLOC(NORMAL)
2509	call alloc(id) ! ALLOCATE VARIABLES
2510	id=1
2511	y=id+x
2512	CALL TRACK_PROBE_x(r,y,state, fibre1=loc)
2513	id=y
2514	mat0=id
2515	normal=id
2516	mat0i=id**(-1) ! mat0i has inverse
2517	write(6,*) "symplectic tunes "
2518	write(6,*) normal%tune
2519
2520	CALL kill(Y)
2521	CALL kill(NORMAL)
2522	call kill(id) ! ALLOCATE VARIABLES
2523
2524	endif
2525	state=(estate-nocavity0)+radiation0
2526	x=0.d0
2527
2528	CALL FIND_ORBIT_x(R,X,STATE,1.0e-5_dp,fibre1=loc)
2529	WRITE(6,*) " CLOSED ORBIT AT LOCATION ",loc
2530	write(6,*) x
2531	if(present(fixrad)) fixrad=x
2532	if(track_flag(r,x,loc,state)==0) then
2533	write(6,*) " stable closed orbit tracked "
2534	else
2535	write(6,*) " unstable closed orbit tracked "
2536	stop 333
2537	endif
2538
2539	goto 100
2540	open(unit=30,file='junk.txt')
2541	call move_to(r,p,loc)
2542	do i=loc,loc+r%n
2543	call track(r,x,i,i+1,state)
2544	p=>p%next
2545	write(30,205) i,p%mag%name(1:8),x
2546	enddo
2547	close(30)
2548	205 FORMAT(1x,i4,1x,a8,1x,6(1X,D18.11))
2549	100 continue
2550
2551	call GET_loss(r,energy,deltap)
2552	write(6,*) x
2553	write(6,*) "energy loss: GEV and DeltaP/p0c ",energy,deltap
2554
2555	write(mf1,*) " stable closed orbit tracked "
2556	write(mf1,"(6(1X,D18.11))") x
2557	write(mf1,*) "energy loss: GEV and DeltaP/p0c ",energy,deltap
2558
2559	CALL INIT(state,2,0,BERZ,ND2,NPARA)
2560	CALL ALLOC(Y)
2561	CALL ALLOC(NORMAL)
2562	call alloc(ys)
2563	call alloc(env) ! ALLOCATE VARIABLES
2564	!Y=NPARA
2565	CALL ALLOC(ID)
2566	ID=1
2567	Y=X+ID
2568	ys=y
2569
2570	CALL TRACK(R,YS,loc,state)
2571	call kanalnummer(npara,'junkys.txt')
2572	write(6,*) loc
2573	call print(ys,npara)
2574	close(npara)
2575	if(.not.check_stable) write(6,*) " unstable tracking envelope "
2576	env%stochastic=.true.
2577	env=ys
2578	if(.not.check_stable) write(6,*) " unstable in normalizing envelope "
2579
2580	y=ys
2581	normal=y
2582	if(.not.check_stable) write(6,*) " unstable in normalizing map "
2583	as=normal%a_t
2584	goto 111
2585	id=y
2586	open(unit=66,file='crap.txt')
2587	call print(id,66)
2588	do i=1,6
2589	do j=1,6
2590	m=ys(i)%e(j)
2591	write(66,*) i,j,m
2592	enddo
2593	enddo
2594	close(66)
2595	111 continue
2596	! TYPE beamenvelope
2597	! ! radiation normalization
2598	! type (damap) transpose ! Transpose of map which acts on polynomials
2599	! type (taylor) bij ! Represents the stochastic kick at the end of the turn Env_f=M Env_f M^t + B
2600	! TYPE (pbresonance) bijnr ! Equilibrium beam sizes in resonance basis
2601	! type (taylor) sij0 ! equilibrium beam sizes
2602	! real(dp) emittance(3),tune(3),damping(3)
2603	! logical AUTO,STOCHASTIC
2604	! real(dp) KICK(3)
2605	! type (damap) STOCH
2606	! END TYPE beamenvelope
2607
2608	write(6,*) " Chao emittance "
2609	write(6,*) env%emittance
2610	write(6,*) " tunes "
2611	write(6,*) env%tune
2612	write(6,*) " damping decrements "
2613	write(6,*) env%damping
2614	write(mf1,*) " Chao emittance "
2615	write(mf1,*) env%emittance
2616	write(mf1,*) " tunes "
2617	write(mf1,*) env%tune
2618	write(mf1,*) " damping decrements "
2619	write(mf1,*) env%damping
2620	js=0
2621	do i=1,6
2622	do j=1,6
2623	js(j)=1
2624	m=env%STOCH%v(i).sub.js
2625	write(mf1,*) m,i,j
2626	js(j)=0
2627	enddo
2628	enddo
2629	js=0
2630	do i=1,6
2631	do j=1,6
2632	js(j)=1
2633	m=ys(i)%v.sub.js
2634	! write(mf1,*) m,i,j
2635	js(j)=0
2636	enddo
2637	enddo
2638	if(present(kick)) then
2639	kick(1)=env%kick(1)
2640	kick(2)=env%kick(1)
2641	kick(3)=env%kick(2)
2642	kick(4)=env%kick(2)
2643	kick(5)=env%kick(3)
2644	kick(6)=env%kick(3)
2645	endif
2646	write(mf1,*) env%kick
2647	write(mf1,*) "B matrix"
2648	call print(env%STOCH,mf1)
2649	write(mf1,*) "m matrix"
2650
2651	if(present(mat)) then
2652	id=ys%v
2653	mat=id
2654	mat=matmul(mat,mat0i)
2655	endif
2656	call print(ys%v,mf1)
2657	write(mf1,*) "equilibrium <X_i X_j>"
2658	call print(env%sij0,mf1)
2659	write(mf1,*) " Resonance Fluctuation "
2660	call print(env%bijnr,mf1)
2661	! for etienne
2662	write(mf2,*) env%kick
2663	call print(env%STOCH,mf2)
2664	if(present(ast)) ast=env%STOCH
2665	env%STOCH=env%STOCH**(-1)
2666	if(present(asti))asti=env%STOCH
2667	call print(env%STOCH,mf2)
2668	call print(ys%v,mf2)
2669	write(mf2,*) " Damping "
2670	write(mf2,*) env%damping
2671	write(mf2,*) " Stochastic Theta "
2672	call print(env%bij,mf2)
2673
2674	js=0
2675	av=0.d0
2676	e=env%emittance
2677	write(mf1,*) " emmitances "
2678	write(mf1,*) e
2679	av(1,1)=(as(1,1)2+as(1,2)2)e(1)+(as(1,3)2+as(1,4)2)e(2)+ &
2680	(as(1,5)2+as(1,6)2)*e(3)
2681	av(3,3)=(as(3,1)2+as(3,2)2)e(1)+(as(3,3)2+as(3,4)2)e(2)+ &
2682	(as(3,5)2+as(3,6)2)*e(3)
2683	av(5,5)=(as(5,1)2+as(5,2)2)e(1)+(as(5,3)2+as(5,4)2)e(2)+ &
2684	(as(5,5)2+as(5,6)2)*e(3)
2685	av(3,5)=(as(3,1)as(5,1)+as(3,2)as(5,2))e(1)+(as(3,3)as(5,3)+as(3,4)as(5,4))e(2)+ &
2686	(as(3,5)as(5,5)+as(3,6)as(5,6))*e(3)
2687	n1=1
2688	n2=3
2689	av(n1,n2)=(as(n1,1)as(n2,1)+as(n1,2)as(n2,2))e(1)+(as(n1,3)as(n2,3)+as(n1,4)as(n2,4))e(2)+ &
2690	(as(n1,5)as(n2,5)+as(n1,6)as(n2,6))*e(3)
2691	n1=3
2692	n2=6
2693	av(n1,n2)=(as(n1,1)as(n2,1)+as(n1,2)as(n2,2))e(1)+(as(n1,3)as(n2,3)+as(n1,4)as(n2,4))e(2)+ &
2694	(as(n1,5)as(n2,5)+as(n1,6)as(n2,6))*e(3)
2695
2696	m=env%sij0.sub.'2'
2697
2698	write(mf1,) " <X*2> exact and alex "
2699	write(mf1,*) m
2700	write(mf1,*) av(1,1)
2701	m=env%sij0.sub.'002'
2702	write(mf1,) " <y*2> exact and alex "
2703	write(mf1,*) m
2704	write(mf1,*) av(3,3)
2705	m=env%sij0.sub.'00002'
2706	write(mf1,) " <L*2> exact and alex "
2707	write(mf1,*) m
2708	write(mf1,*) av(5,5)
2709	m=env%sij0.sub.'001010'
2710	write(mf1,*) " <y delta> exact and alex "
2711	write(mf1,*) m/2.d0
2712	write(mf1,*) av(3,5)
2713	n1=1
2714	n2=3
2715	m=env%sij0.sub.'101000'
2716	write(mf1,*) " <x y> exact and alex "
2717	write(mf1,*) m/2.d0
2718	write(mf1,*) av(n1,n2)
2719	n1=3
2720	n2=6
2721	m=env%sij0.sub.'001001'
2722	write(mf1,*) " <y L> exact and alex "
2723	write(mf1,*) m/2.d0
2724	write(mf1,*) av(n1,n2)
2725
2726
2727
2728	CALL KILL(Y)
2729	CALL KILL(Ys)
2730	CALL KILL(NORMAL)
2731	CALL KILL(env)
2732
2733	! compute map with radiation minus the cavity!
2734	! cavity must be at the end and only one cavity
2735
2736	if(no>0) then
2737	CALL INIT(STATE,no,0,BERZ,ND2,NPARA)
2738	CALL ALLOC(Y) ! ALLOCATE VARIABLES
2739	write(17,*) x(1),x(2),x(3)
2740	write(17,*) x(4),x(5),x(6)
2741	Y=NPARA
2742	Y=X
2743
2744	CALL TRACK(R,Y,1,r%n,STATE)
2745
2746	call print(y,17)
2747	call kill(y)
2748	endif
2749	close(mf1)
2750	close(mf2)
2751
2752
2753	if(present(mat)) then
2754	call kanalnummer(mf1)
2755	open(mf1,file='barber_stochastic.txt')
2756	if(present(mat)) then
2757	do i=1,6
2758	do j=1,6
2759	write(mf1,*) i,j,mat(i,j)," mat"
2760	enddo
2761	enddo
2762	endif
2763	if(present(ast)) then
2764	do i=1,6
2765	do j=1,6
2766	write(mf1,*) i,j,ast(i,j)," ast"
2767	enddo
2768	enddo
2769	endif
2770	if(present(asti)) then
2771	do i=1,6
2772	do j=1,6
2773	write(mf1,*) i,j,asti(i,j)," asti"
2774	enddo
2775	enddo
2776	endif
2777	if(present(kick)) then
2778	do i=1,6
2779	write(mf1,*) i,kick(i)," kick"
2780	enddo
2781	endif
2782
2783	close(mf1)
2784	endif
2785
2786	end subroutine radia
2787
2788	SUBROUTINE radia_new(R,loc,i1,FILE1,estate)
2789	implicit none
2790	TYPE(LAYOUT) R
2791
2792	REAL(DP) X(6),m,energy,deltap
2793	CHARACTER(*) FILE1
2794	type(normal_spin) normal
2795	integer i,j ,i1
2796	TYPE(damapspin) ID
2797	TYPE(INTERNAL_STATE) state
2798	TYPE(INTERNAL_STATE), target :: estate
2799	integer loc,mf1
2800	type(fibre), pointer :: p
2801	type(probe) xs0
2802	type(probe_8) xs
2803
2804	call kanalnummer(mf1)
2805	open(mf1,file=FILE1)
2806
2807
2808
2809
2810	state=(estate-nocavity0)+radiation0
2811	x=0.d0
2812
2813	CALL FIND_ORBIT_x(R,X,STATE,1.0e-5_dp,fibre1=loc)
2814	WRITE(6,*) " CLOSED ORBIT AT LOCATION ",loc
2815	write(6,*) x
2816
2817
2818
2819
2820	call GET_loss(r,energy,deltap)
2821
2822	write(6,*) "energy loss: GEV and DeltaP/p0c ",energy,deltap
2823
2824	write(mf1,*) " stable closed orbit tracked "
2825	write(mf1,"(6(1X,D18.11))") x
2826	write(mf1,*) "energy loss: GEV and DeltaP/p0c ",energy,deltap
2827
2828	CALL INIT(state,1,0)
2829	CALL ALLOC(NORMAL)
2830	CALL ALLOC(ID)
2831	call alloc(xs)
2832
2833	if(i1==1) normal%stochastic=my_true
2834	xs0=x
2835	ID=1
2836	xs=XS0+ID
2837
2838	state=state+envelope0
2839
2840	CALL TRACK_PROBE(r,xs,state, fibre1=loc)
2841	write(mf1,*) " Full Map "
2842	id=xs
2843	call print(id,mf1)
2844	write(mf1,*) " End of Full Map "
2845
2846	normal=id
2847	write(mf1,*)" $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ "
2848	write(mf1,*)" Tunes "
2849	write(mf1,*) normal%tune
2850	write(mf1,*)" Damping "
2851	write(mf1,*) normal%damping
2852	write(mf1,*)" Emittances "
2853	write(mf1,*) normal%emittance
2854	write(mf1,*)" $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ "
2855	write(mf1,*)" "
2856
2857	write(mf1,*)" Equilibrium Beam Sizes "
2858	do i=1,6
2859	do j=1,6
2860	write(mf1,*) i,j,normal%s_ij0(i,j)
2861	enddo
2862	enddo
2863	write(mf1,*)" Equilibrium Phasor Sizes "
2864	do i=1,6
2865	do j=1,6
2866	write(mf1,*) i,j,normal%s_ijr(i,j)
2867	enddo
2868	enddo
2869
2870	if(normal%stochastic) then
2871	write(mf1,*) "Stochastic kicks"
2872	write(mf1,*) normal%kick
2873
2874	write(mf1,*)" Stochastic Transformation "
2875	do i=1,6
2876	do j=1,6
2877	write(mf1,*) i,j,normal%STOCH(i,j)
2878	enddo
2879	enddo
2880
2881	write(mf1,*)" Inverse Stochastic Transformation "
2882	do i=1,6
2883	do j=1,6
2884	write(mf1,*) i,j,normal%STOCH_inv(i,j)
2885	enddo
2886	enddo
2887
2888	endif
2889
2890	close(mf1)
2891
2892	CALL KILL(NORMAL)
2893	CALL KILL(ID)
2894	CALL KILL(xs)
2895
2896	end subroutine radia_new
2897
2898	subroutine Universe_max_n(n)
2899	!use build_lattice
2900	implicit none
2901	integer n,i
2902	type(layout), pointer :: L
2903	n=0
2904
2905	l=>m_u%start
2906	do i=1,m_u%n
2907	n=n+l%n
2908	l=>l%next
2909	enddo
2910
2911	end subroutine Universe_max_n
2912
2913	subroutine Universe_max_node_n(n)
2914	!use build_lattice
2915	implicit none
2916	integer n,i
2917	type(layout), pointer :: L
2918	n=0
2919
2920	l=>m_u%start
2921	do i=1,m_u%n
2922	if(associated(l%t) ) n=n+l%t%n
2923	l=>l%next
2924	enddo
2925
2926	end subroutine Universe_max_node_n
2927
2928
2929	end module pointer_lattice
2930
2931
2932
2933
2934	subroutine read_ptc_command77(ptc_fichier)
2935	use pointer_lattice
2936	implicit none
2937	character(*) ptc_fichier
2938	integer m
2939
2940	if(ptc_fichier(1:len_trim(ptc_fichier))=='CPP') then
2941	call change_default_tpsa(1)
2942	return
2943	endif
2944	if(ptc_fichier(1:len_trim(ptc_fichier))=='FORTRAN') then
2945	call change_default_tpsa(2)
2946	return
2947	endif
2948
2949	call kanalnummer(m)
2950
2951	open(unit=m,file=ptc_fichier,status='OLD',err=2001)
2952	close(m)
2953	call read_ptc_command(ptc_fichier)
2954	return
2955	2001 continue
2956
2957	write(6,*) " Warning: command file does not exit "
2958
2959	end subroutine read_ptc_command77
2960
2961
2962
2963	!Piotr says:
2964	!I have implemented for you MAD-X command ptc_script.
2965	!It has one parameter named "file". Hence, you call sth like
2966	!ptc_script, file="directptctweaks.ptc"
2967	!It executes subroutine execscript in file madx_ptc_script.f90.
2968
2969	subroutine gino_ptc_command77(gino_command)
2970	use pointer_lattice
2971	implicit none
2972	character(*) gino_command
2973
2974	! Etienne puts garbage here
2975	! print*,"Fuck it works! ",gino_command
2976
2977	call context(gino_command)
2978	call call_gino(gino_command)
2979
2980	end subroutine gino_ptc_command77
2981
2982
2983	subroutine read_mad_command77(ptc_fichier)
2984	use pointer_lattice
2985	! use pointer_lattice_frank
2986	implicit none
2987	character(*) ptc_fichier
2988	integer m
2989
2990	call kanalnummer(m)
2991
2992	open(unit=m,file=ptc_fichier,status='OLD',err=2001)
2993	close(m)
2994	! call read_mad_command(ptc_fichier) ! inside pointer_lattice_frank
2995	return
2996	2001 continue
2997
2998	write(6,*) " Warning: mad command file does not exit "
2999
3000	end subroutine read_mad_command77
3001

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

Context Navigation

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

Download in other formats: