Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

ptc_export_xml.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: 14.1 KB

Line
1	module ptc_export_xml_module
2	use madx_ptc_module ! to access the layout 'MY_RING'
3	implicit none
4
5	private
6	public :: ptc_export_xml ! external interface
7
8
9	contains
10
11	subroutine ptc_export_xml(filenameIA)
12	implicit none
13	integer filenameIA(*)
14	character(48) filename
15	!integer I,MF,DI,nt
16	integer i,mf
17	type(LAYOUT), TARGET :: L
18	type(FIBRE), pointer :: P
19	!character*255 line
20	!REAL(DP) D(3),ANG(3),PREC,DS
21	!LOGICAL(LP) ENERGY_PATCH
22	integer xml_level
23
24	xml_level = 0
25
26	filename = charconv(filenameIA)
27
28	write(6,*) 'Fortran: export XML document "', trim(filename),'"representing PTC machine'
29
30
31
32	L = MY_RING ! my ring is global variable from madx_ptc_module
33
34	! P=>L%START
35	! i=1
36	! nt=0
37	! do while(i<=l%n)
38
39	! call count_PATCH_sixtrack(di,p)
40	! i=i+1+DI
41	! nt=nt+1
42	! ENDDO
43
44	!nt=0
45
46	! PREC=1.D-10
47	call kanalnummer(mf)
48	open(unit=mf,file=filename)
49
50	write (MF,'(a)') '<?xml version="1.0" encoding="UTF-8"?>' ! format to avoid first blank character
51	write (MF,*) '<!-- File generated by Fortran code linked against the PTC library -->'
52	write (MF,*) '<ptc-machine xsi:noNamespaceSchemaLocation="PtcMachine.xsd"' ! ...
53	write (MF,*) 'xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance">' !... continued
54
55	P=>L%START
56	i=1
57	do while(i<=l%n) ! for each fibre
58
59	CALL print_FIBRE_SIXTRACK(P,mf,xml_level+1)
60	p=>p%next
61	i=i+1 !+DI
62	ENDDO
63
64	call print_XML_beam(L,mf,xml_level+1)
65
66	write (MF,*) '</ptc-machine>'
67	close(MF)
68	END subroutine ptc_export_xml
69
70	subroutine print_FIBRE_SIXTRACK(fibre_ptr,file_handle,xml_level)
71	implicit none
72	integer file_handle
73	integer xml_level
74	type(FIBRE), pointer :: fibre_ptr
75	character propagation*32
76	select case(fibre_ptr%dir)
77	case(1)
78	propagation = 'forward'
79	case(-1)
80	propagation = 'backward'
81	case default
82	propagation = 'undefined'
83	end select
84
85	write(file_handle,*) '<fibre propagation-direction="',trim(propagation),'">'
86	call print_XML_patches(file_handle,fibre_ptr,xml_level+1)
87	call print_XML_misalignments(file_handle,fibre_ptr,xml_level+1)
88	call print_XML_element(fibre_ptr%mag,file_handle,xml_level+1)
89	write(file_handle,*) '</fibre>'
90	END subroutine print_FIBRE_SIXTRACK
91
92	subroutine print_XML_patches(mf,f,xml_level)
93	implicit none
94	type(FIBRE), pointer :: f
95	integer mf,i
96	integer xml_level
97	character padding*10
98	real(dp) xi,yi,zi,xo,yo,zo
99	real(dp) rxi,ryi,rzi,rxo,ryo,rzo
100	padding = ''
101	do i=1,10
102	padding = padding//' '
103	end do
104	! input patch
105	xi = f%patch%a_d(1)
106	yi = f%patch%a_d(2)
107	zi = f%patch%a_d(3)
108	rxi = f%patch%a_ang(1)
109	ryi = f%patch%a_ang(2)
110	rzi = f%patch%a_ang(3)
111	! output patch
112	xo = f%patch%b_d(1)
113	yo = f%patch%b_d(2)
114	zo = f%patch%b_d(3)
115	rxo = f%patch%b_ang(1)
116	ryo = f%patch%b_ang(2)
117	rzo = f%patch%b_ang(3)
118	write(mf,*) padding(1:xml_level), '<patches>'
119	write(mf,*) padding(1:xml_level+1), '<input>'
120	write(mf,*) padding(1:xml_level+2), '<translations x="',xi,'"',' y="',yi,'"',' z="',zi,'"/>'
121	write(mf,*) padding(1:xml_level+2), '<rotations rx="',rxi,'"',' ry="',ryi,'"',' rz="',rzi,'"/>'
122	write(mf,*) padding(1:xml_level+1), '</input>'
123	write(mf,*) padding(1:xml_level+1), '<output>'
124	write(mf,*) padding(1:xml_level+2), '<translations x="',xo,'"',' y="',yo,'"',' z="',zo,'"/>'
125	write(mf,*) padding(1:xml_level+2), '<rotations rx="',rxo,'"',' ry="',ryo,'"',' rz="',rzo,'"/>'
126	write(mf,*) padding(1:xml_level+1), '</output>'
127	write(mf,*) padding(1:xml_level), '</patches>'
128	end subroutine print_XML_patches
129
130	subroutine print_XML_misalignments(mf,f,xml_level)
131	implicit none
132	integer mf
133	integer xml_level,i
134	type(FIBRE), pointer ::f
135	character padding*10
136	real(dp) xi,yi,zi,xo,yo,zo
137	real(dp) rxi,ryi,rzi,rxo,ryo,rzo
138
139	padding = ''
140	do i=1,10
141	padding = padding//' '
142	end do
143	! input misalignment
144	xi = f%chart%d_in(1)
145	yi = f%chart%d_in(2)
146	zi = f%chart%d_in(3)
147	rxi = f%chart%ang_in(1)
148	ryi = f%chart%ang_in(2)
149	rzi = f%chart%ang_in(3)
150	! output misalignment
151	xo = f%chart%d_out(1)
152	yo = f%chart%d_out(2)
153	zo = f%chart%d_out(3)
154	rxo = f%chart%ang_out(1)
155	ryo = f%chart%ang_out(2)
156	rzo = f%chart%ang_out(3)
157	write(mf,*) padding(1:xml_level), '<misalignments>'
158	write(mf,*) padding(1:xml_level+1), '<input>'
159	write(mf,*) padding(1:xml_level+2), '<translations x="',xi,'"',' y="',yi,'"',' z="',zi,'"/>'
160	write(mf,*) padding(1:xml_level+2), '<rotations rx="',rxi,'"',' ry="',ryi,'"',' rz="',rzi,'"/>'
161	write(mf,*) padding(1:xml_level+1), '</input>'
162	write(mf,*) padding(1:xml_level+1), '<output>'
163	write(mf,*) padding(1:xml_level+2), '<translations x="',xo,'"',' y="',yo,'"',' z="',zo,'"/>'
164	write(mf,*) padding(1:xml_level+2), '<rotations rx="',rxo,'"',' ry="',ryo,'"',' rz="',rzo,'"/>'
165	write(mf,*) padding(1:xml_level+1), '</output>'
166	write(mf,*) padding(1:xml_level), '</misalignments>'
167	end subroutine print_XML_misalignments
168
169
170	subroutine print_XML_element(m,mf,xml_level)
171	implicit none
172	integer mf
173	integer xml_level,i
174	! type(FIBRE), pointer :: P
175	type(element), pointer :: m
176	real(dp) length ! for a drift or a magnet
177	real(dp) voltage, phase, frequency ! for an RF cavity
178	real(dp) ks ! try this for a solenoid
179	real(dp) a1,b1 ! for a crab cavity
180	character el_name*48 ! the name of the element
181	character padding*10
182	el_name = ''
183	padding = ''
184	do i=1,10
185	padding = padding//' '
186	end do
187	do i=1,len(trim(M%VORNAME))
188	el_name(i:i)=lowercase(M%VORNAME(i:i))
189	end do
190	! hardcode design-tilt as 0.0 for the time-being
191	write (MF,*) padding(1:xml_level), '<element name="',trim(el_name),'" design-tilt="0.0"><!-- instance of ',TRIM(M%NAME),'-->'
192	write(MF,*) padding(1:xml_level+1), '<kind>'
193	! trim to remove trailing blanks
194	select case (M%KIND)
195	case (30) ! this is a marker
196	write(MF,*) padding(1:xml_level+2), '<marker/>'
197	case (31) ! this is a drift
198	length = M%L
199	write(MF,*) padding(1:xml_level+2), '<drift length="',length,'"/>'
200	case (32) ! this is a drift-kick-drift??
201	!write(MF,*) padding(1:xml_level+2), '<UNIDENTIFIED/><!-- drift-kick-drift -->'
202	! should ensure this is a quadrupole (do we end-up here for sextupole as well?
203	length = M%L
204	write(MF,*) padding(1:xml_level+2), '<magnet length="',length,'">'
205	! Does it account for any kind of magnet - at least this is what we
206	! agreed on in the Schema
207	if (ASSOCIATED(M%an)) then
208	do i=1,m%p%NMUL
209	! write(mf,*) m%bn(i),m%an(i), " BN AN ",I
210	write(mf,*) padding(1:xml_level+3), '<an index="',i,'" value="',m%an(i),'"/>'
211	write(mf,*) padding(1:xml_level+3), '<bn index="',i,'" value="',m%bn(i),'"/>'
212	enddo
213	endif
214	write(MF,*) padding(1:xml_level+2), '</magnet>'
215	case (33) ! this is a multiple block
216	! As far as I know let's identify it as a MAD multipole composed of a series
217	! of zero length thin lenses
218	! for the time being omit, MAD's LRAD fictitious length (synchrotron radiation)
219	! and TILT
220	write(MF,*) padding(1:xml_level+2), '<thin-lens-series>'
221	if (ASSOCIATED(M%an)) then
222	do i=1,m%p%NMUL
223	write(MF,*) padding(1:xml_level+3), '<an index="',i,'" value="',m%bn(i),'"/><!-- skew component-->'
224	write(MF,*) padding(1:xml_level+3), '<bn index="',i,'" value="',m%an(i),'"/><!-- normal component-->'
225	enddo
226	endif
227	write(MF,*) padding(1:xml_level+2), '</thin-lens-series>'
228	case (34) ! this is a cavity
229	length = M%L
230	voltage = M%VOLT ! for an ordinary RF cavity (i.e. not a crab)
231	frequency = M%FREQ
232	phase = M%PHAS + M%C4%PHASE0 + M%C4%PH(1)
233	write(MF,*) padding(1:xml_level), '<RF-cavity length="',length, &
234	'" voltage="',voltage,'" frequency="',frequency,'" phase="',phase,'">'
235	! following should be conditionnal to the cavity being
236	! a crab cavity
237	a1 = M%AN(1)
238	b1 = M%BN(1)
239	write(MF,*) padding(1:xml_level+3), '<a1 value="',a1,'"/>'
240	write(MF,*) padding(1:xml_level+3), '<b1 value="',b1,'"/>'
241	write(MF,*) padding(1:xml_level+2), '</RF-cavity>'
242	case (35) ! found-out that this is a solenoid
243	length = M%L
244	ks = 0 ! as I don't know yet where to pick it up
245	write(MF,*) padding(1:xml_level), '<solenoid length="',length,'" ks="',ks,'"/>'
246	case (41) ! found-out that this is monitor
247	length = M%L
248	write(MF,*) padding(1:xml_level), '<monitor length="',length,'"/>'
249	! monitor actual has a type, but let's forget it for the time-being
250	case (42) ! found-out this is an H-monitor
251	length = M%L
252	write(MF,*) padding(1:xml_level), '<H-monitor length="',length,'"/>'
253	case (43) ! found-out this is a V-monitor
254	length = M%L
255	write(MF,*) padding(1:xml_level), '<V-monitor length="',length,'"/>'
256	case (44) ! found-out this is an instrument
257	write(MF,*) padding(1:xml_level), '<instrument/>'
258	case (48) ! found-out this is a R-collimator
259	length = M%L
260	write(MF,*) padding(1:xml_level), '<R-collimator length="',length,'"/>'
261	! and what about an E-collimator ???
262	case (51) ! to be confirmed that this is indeed a cavity...
263	!voltage = M%VOLT;
264	length = M%L
265	write(MF,*) padding(1:xml_level), '<TW-cavity length="',length,'"/>'
266	case default
267	write(MF,*) padding(1:xml_level), '<device code="',M%KIND,'"--/><!--unknown-->'
268	end select
269	write (MF,*) padding(1:xml_level+1), '</kind>'
270	write (MF,*) padding(1:xml_level), '</element>'
271	end subroutine print_XML_element
272
273
274	subroutine print_XML_beam(L,file_handle, xml_level)
275	integer file_handle,xml_level
276	integer i
277	real(dp) charge,mass,beta0,p0c
278	type(LAYOUT), TARGET :: L
279	character padding*10;
280	padding = ''
281	do i=1,10
282	padding = padding//' '
283	end do
284	charge = L%START%charge
285	mass = L%START%mass
286	beta0 = L%START%beta0
287	p0c = L%START%MAG%P%p0c
288	write(file_handle,*) padding(1:xml_level), '<beam charge="',charge,'" mass="',mass,'" beta0="',beta0,'" p0c="',p0c,'"/>'
289	end subroutine print_XML_beam
290
291	subroutine print_element_SIXTRACK(P,m,mf)
292	implicit none
293	integer mf,I
294	type(FIBRE), pointer :: P
295	type(element), pointer :: m
296	character*255 line
297
298	WRITE(MF,*) "$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ ELEMENT $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$"
299	if(m%vorname(1:1)==' ') then
300	WRITE(MF,*) M%KIND,M%NAME, ' NOVORNAME'
301	ELSE
302	WRITE(MF,*) M%KIND,M%NAME,' ',M%VORNAME
303	ENDIF
304	WRITE(MF,*) M%L
305	IF(ASSOCIATED(M%FREQ)) THEN
306	WRITE(MF,*) " CAVITY INFORMATION "
307	!HALFEL%P%DIREL%P%CHARGEEL%voltc_1d_3SIN(twopiEL%freq*x(6)/CLIGHT+EL%PHAS+EL%phase0)/EL%P%P0C
308
309	WRITE(LINE,) c_1d_3M%VOLT, twopi*M%FREQ/CLIGHT,M%PHAS+M%C4%phase0
310	WRITE(MF,'(A255)') LINE
311	ELSEIF(ASSOCIATED(M%VOLT)) THEN
312	WRITE(MF,*) " ELECTRIC SEPTUM INFORMATION "
313	WRITE(MF,*) M%VOLT,M%PHAS, "VOLT, PHAS(rotation angle) "
314	ELSE
315	WRITE(MF,*) " NO ELECTRIC ELEMENT INFORMATION "
316	ENDIF
317	IF(ASSOCIATED(M%B_SOL)) THEN
318	WRITE(MF,*) M%B_SOL, " B_SOL"
319	ELSE
320	WRITE(MF,*) zero
321	ENDIF
322	CALL print_magnet_chart_SIXTRACK(P,m%P,mf)
323	IF(ASSOCIATED(M%an)) THEN
324	do i=1,m%p%NMUL
325	write(mf,*) m%bn(i),m%an(i), " BN AN ",I
326	enddo
327	endif
328	! call print_specific_element(m,mf)
329	WRITE(MF,*) "$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ END $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$"
330	end subroutine print_element_SIXTRACK
331
332	subroutine print_magnet_chart_SIXTRACK(P,m,mf)
333	implicit none
334	type(FIBRE), pointer :: P
335	type(magnet_chart), pointer :: m
336	integer mf
337	character*200 line
338
339	WRITE(MF,*) "MAGNET CHART MAGNET CHART MAGNET CHART MAGNET CHART MAGNET CHART MAGNET CHART "
340	WRITE(MF,*) M%METHOD,M%NST,M%NMUL, " METHOD NST NMUL"
341	WRITE(line,*) M%B0,M%EDGE, m%tiltd, " B0, EDGES, TILT"
342	WRITE(MF,'(A200)') LINE
343	WRITE(LINE,*) P%BETA0,P%GAMMA0I, P%GAMBET, " BETA0 GAMMA0I GAMBET "
344	WRITE(MF,'(A200)') LINE
345
346	write(mf,'(a68)') "END MAGNET CHART END MAGNET CHART END MAGNET CHART END MAGNET CHART "
347
348	if(M%METHOD/=2.and.p%mag%l>zero) then
349	write(6,*) " error method must be 2 ",P%mag%name
350	stop
351	endif
352	if(M%exact) then
353	write(6,*) " No exact magnet permitted ",P%mag%name
354	stop
355	endif
356	end subroutine print_magnet_chart_SIXTRACK
357
358	subroutine print_PATCH_MIS_SIXTRACK(m,mf)
359	implicit none
360	type(FIBRE), pointer :: m
361	integer mf
362	character*200 line
363
364	write(mf,'(a30)') " PATCHING AND MISALIGNMENTS "
365	write(mf,'(a30)') " Reversed discontinuous patches "
366	WRITE(MF,*) M%PATCH%A_X1,M%PATCH%A_X2,M%PATCH%B_X1,M%PATCH%B_X2
367	write(mf,'(a30)') " Time patches "
368	WRITE(MF,*) M%PATCH%A_T, M%PATCH%B_T
369	write(mf,'(a30)') " Frontal geometric patches "
370	WRITE(LINE,*) M%PATCH%A_ANG,M%PATCH%A_D
371	WRITE(MF,'(a200)') LINE
372	write(mf,'(a30)') " Exit geometric patches "
373	WRITE(LINE,*) M%PATCH%B_ANG,M%PATCH%B_D
374	WRITE(MF,'(a200)') LINE
375	write(mf,'(a30)') " Entrance misalignments "
376	WRITE(LINE,*) M%CHART%ANG_IN,M%CHART%D_IN
377	WRITE(MF,'(a200)') LINE
378	write(mf,'(a30)') " Exit misalignments "
379	WRITE(LINE,*) M%CHART%ANG_OUT,M%CHART%D_OUT
380	WRITE(MF,'(a200)') LINE
381
382	write(mf,'(a14)') " END GEOMETRY "
383	end subroutine print_PATCH_MIS_SIXTRACK
384
385	character function lowercase(C)
386	implicit none
387	character C
388	integer asciiDiff
389	asciiDiff = iachar('a') - iachar('A')
390	if (LGE(C,'A') .AND. LLE(C,'Z')) then
391	lowercase = achar(iachar(C) + asciiDiff)
392	else
393	lowercase = C
394	endif
395	end function
396
397	! following copied from util.F
398
399	character * 48 function charconv(tint)
400	!----------------------------------------------------------------------*
401	! purpose: *
402	! converts integer array to string (based on ascii) *
403	! input: *
404	! tint (int array) 1 = length, rest = string *
405	!----------------------------------------------------------------------*
406	implicit none
407	integer tint(*)
408	integer i, j, m, n
409	parameter (m = 128)
410	character *(m) letter
411	data letter / &
412	&' !"#$%&''()*+,-./0123456789:;<=>?@&
413	&ABCDEFGHIJKLMNOPQRSTUVWXYZ[ ]^_`abcdefghijklmnopqrstuvwxyz{\|}~'/
414	charconv = ' '
415	n = tint(1)
416	do i = 1, n
417	j = tint(i+1)
418	if (j .lt. m) charconv(i:i) = letter(j:j)
419	enddo
420	end function
421
422
423	end module ptc_export_xml_module

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

Context Navigation

source: PSPA/madxPSPA/src/ptc_export_xml.f90 @ 430

Download in other formats: