source: PSPA/madxPSPA/libs/ptc/src/Sn_mad_like.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: 88.2 KB
Line 
1!The Polymorphic Tracking Code
2!Copyright (C) Etienne Forest and CERN
3
4
5module Mad_like
6  USE ptc_multiparticle,drifter=>drift
7  !USE file_handler
8  IMPLICIT NONE
9  public
10
11  private QUADTILT, SOLTILT, EL_Q,EL_0,arbitrary_tilt
12  private drft,r_r !,rot,mark
13  PRIVATE SEXTTILT,OCTUTILT
14  private HKICKTILT,VKICKTILT,GKICKTILT
15  private GBTILT,SBTILT,pottilt,Set_mad_v
16  PRIVATE RFCAVITYL,SMITILT,CHECKSMI,TWCAVITYL
17  PRIVATE rectaETILT,recttilt
18  PRIVATE B1,A1,A2,B2,A3,B3,A4,B4,A5,A6,A7,A8,A9,A10,B5,B6,B7,B8,B9,B10,BLTILT
19  private fac
20  !  private Taylor_maptilt
21  PRIVATE MONIT,HMONIT,VMONIT,INSTRUMEN
22  PRIVATE RCOLIT,ECOLIT
23  ! linked
24  private ADD_EE,EQUAL_L_L,add_Eb,add_BE,add_BB,MUL_B,mul_e,SUB_BB,makeitc,makeits
25  private unary_subb
26  PRIVATE GET_GAM,HELICALTILT
27  logical(lp),PRIVATE ::  MADX= .FALSE.,MADX_MAGNET_ONLY=.FALSE.
28
29  logical(lp),private::LIKEMAD =.false.,mad_list_killed =.true.,setmad = .false.,verbose=.FALSE.,&
30       madkick=.false.,circular=.false.,makeit=.false.
31  logical(lp)::DRIFT_KICK =.true.
32  logical(lp),TARGET ::FIBRE_flip=.true.
33  !  logical(lp) :: FIBRE_SURVEY=.true.
34  INTEGER,TARGET ::FIBRE_DIR=1
35  real(dp),TARGET ::INITIAL_CHARGE=1
36  real(dp),PRIVATE::ENERGY,P0C,BRHO,KINETIC,gamma0I,gamBET,beta0,MC2
37
38  !real(dp),PRIVATE::TOTAL_EPS
39  character(80) file_fitted
40  !  type(layout),save::mad_list
41  type(layout),target, private::mad_list
42  LOGICAL(LP) :: CURVED_ELEMENT=.FALSE.  !  TO SET UP BEND_FRINGE CORRECTLY FOR EXACT
43  !  type(tree_element), PRIVATE :: mad_tree,mad_tree_rad
44  !  type(tree_element),PRIVATE :: mad_tree_REV,mad_tree_rad_REV
45  LOGICAL(LP) MAD_TREE_DELTAMAP
46  logical(lp):: symplectic_print=.false.
47  logical(lp):: symplectify=.false.
48  integer :: symplectic_order = 0
49  REAL(DP) :: symplectic_eps = -1.0_dp
50  REAL(DP)  MAD_TREE_LD , MAD_TREE_ANGLE
51  type(tree_element), private, allocatable :: t_e(:),t_ax(:),t_ay(:)
52  logical(lp) :: set_ap=my_false
53  TYPE EL_LIST
54     real(dp) L,LD,LC,K(NMAX),KS(NMAX)
55     real(dp) ang(3),t(3)
56     real(dp) angi(3),ti(3)
57     integer patchg,CAVITY_TOTALPATH
58     real(dp) T1,T2,B0
59     real(dp) volt,freq0,harmon,lag,DELTA_E,BSOL
60     real(dp) tilt
61     real(dp) FINT,hgap,h1,h2,X_COL,Y_COL
62     real(dp) thin_h_foc,thin_v_foc,thin_h_angle,thin_v_angle,hf,vf,ls  ! highly illegal additions by frs
63     CHARACTER(120) file
64     CHARACTER(120) file_rev
65     CHARACTER(nlp) NAME
66     CHARACTER(vp) VORNAME
67     INTEGER KIND,nmul,nst,method
68     LOGICAL(LP) APERTURE_ON
69     INTEGER APERTURE_KIND
70     REAL(DP) APERTURE_R(2),APERTURE_X,APERTURE_Y
71     LOGICAL(LP) KILL_ENT_FRINGE,KILL_EXI_FRINGE,BEND_FRINGE,PERMFRINGE
72     REAL(DP) DPHAS,PSI,dvds
73     INTEGER N_BESSEL
74     !     logical(lp) in,out
75  END TYPE EL_LIST
76
77  INTERFACE OPERATOR (+)
78     !  linked
79     MODULE PROCEDURE add_EE
80     MODULE PROCEDURE add_Eb
81     MODULE PROCEDURE add_BE
82     MODULE PROCEDURE add_BB
83  END INTERFACE
84
85
86
87  INTERFACE OPERATOR (-)
88     !  linked
89     MODULE PROCEDURE SUB_BB
90     MODULE PROCEDURE UNARY_SUBB
91  END INTERFACE
92
93  INTERFACE OPERATOR (*)
94     !    linked
95     MODULE PROCEDURE MUL_B
96     MODULE PROCEDURE MUL_E
97  END INTERFACE
98
99  INTERFACE assignment (=)
100     MODULE PROCEDURE EL_Q
101     MODULE PROCEDURE EL_0
102     !  linked
103     MODULE PROCEDURE EQUAL_L_L
104  end  INTERFACE
105
106  INTERFACE OPERATOR (.ring.)
107     MODULE PROCEDURE makeitc
108  END INTERFACE
109
110  INTERFACE OPERATOR (.line.)
111     MODULE PROCEDURE makeits
112  END INTERFACE
113
114
115
116  INTERFACE operator (.is.)
117     MODULE PROCEDURE r_r
118  end  INTERFACE
119
120  INTERFACE operator (.d.)
121     MODULE PROCEDURE B1
122  end  INTERFACE
123  INTERFACE operator (.sd.)
124     MODULE PROCEDURE a1
125  end  INTERFACE
126  INTERFACE operator (.Q.)
127     MODULE PROCEDURE B2
128  end  INTERFACE
129  INTERFACE operator (.sQ.)
130     MODULE PROCEDURE a2
131  end  INTERFACE
132  INTERFACE operator (.S.)
133     MODULE PROCEDURE B3
134  end  INTERFACE
135  INTERFACE operator (.sS.)
136     MODULE PROCEDURE a3
137  end  INTERFACE
138  INTERFACE operator (.O.)
139     MODULE PROCEDURE B4
140  end  INTERFACE
141  INTERFACE operator (.sO.)
142     MODULE PROCEDURE a4
143  end  INTERFACE
144  INTERFACE operator (.dE.)
145     MODULE PROCEDURE B5
146  end  INTERFACE
147  INTERFACE operator (.sDe.)
148     MODULE PROCEDURE a5
149  end  INTERFACE
150  INTERFACE operator (.Do.)
151     MODULE PROCEDURE B6
152  end  INTERFACE
153  INTERFACE operator (.sDo.)
154
155     MODULE PROCEDURE a6
156  end  INTERFACE
157
158  INTERFACE operator (.II.)
159     MODULE PROCEDURE B1
160  end  INTERFACE
161  INTERFACE operator (.sII.)
162     MODULE PROCEDURE a1
163  end  INTERFACE
164  INTERFACE operator (.IV.)
165     MODULE PROCEDURE B2
166  end  INTERFACE
167  INTERFACE operator (.sIV.)
168     MODULE PROCEDURE a2
169  end  INTERFACE
170  INTERFACE operator (.VI.)
171     MODULE PROCEDURE B3
172  end  INTERFACE
173  INTERFACE operator (.sVI.)
174     MODULE PROCEDURE a3
175  end  INTERFACE
176  INTERFACE operator (.VIII.)
177     MODULE PROCEDURE B4
178  end  INTERFACE
179  INTERFACE operator (.sVIII.)
180     MODULE PROCEDURE a4
181  end  INTERFACE
182  INTERFACE operator (.X.)
183     MODULE PROCEDURE B5
184  end  INTERFACE
185  INTERFACE operator (.SX.)
186     MODULE PROCEDURE a5
187  end  INTERFACE
188  INTERFACE operator (.XII.)
189     MODULE PROCEDURE B6
190  end  INTERFACE
191  INTERFACE operator (.SXII.)
192     MODULE PROCEDURE a6
193  end  INTERFACE
194  INTERFACE operator (.XIV.)
195     MODULE PROCEDURE B7
196  end  INTERFACE
197  INTERFACE operator (.SXIV.)
198     MODULE PROCEDURE a7
199  end  INTERFACE
200  INTERFACE operator (.XVI.)
201     MODULE PROCEDURE B8
202  end  INTERFACE
203  INTERFACE operator (.SXVI.)
204     MODULE PROCEDURE a8
205  end  INTERFACE
206  INTERFACE operator (.XVIII.)
207     MODULE PROCEDURE B9
208  end  INTERFACE
209  INTERFACE operator (.SXVIII.)
210     MODULE PROCEDURE a9
211  end  INTERFACE
212  INTERFACE operator (.XX.)
213     MODULE PROCEDURE B10
214  end  INTERFACE
215  INTERFACE operator (.SXX.)
216     MODULE PROCEDURE a10
217  end  INTERFACE
218
219
220  INTERFACE EL_Q_FOR_MADX
221     MODULE PROCEDURE EL_Q
222  end  INTERFACE
223
224  INTERFACE OCTUPOLE
225     MODULE PROCEDURE OCTUTILT
226  end  INTERFACE
227
228  INTERFACE SEXTUPOLE
229     MODULE PROCEDURE SEXTTILT
230  end  INTERFACE
231
232  INTERFACE quadrupole
233     MODULE PROCEDURE QUADTILT
234  end  INTERFACE
235
236  INTERFACE HELICAL
237     MODULE PROCEDURE HELICALTILT
238  end  INTERFACE
239
240  INTERFACE SOLENOID
241     MODULE PROCEDURE SOLTILT
242  end  INTERFACE
243
244  INTERFACE SMI
245     MODULE PROCEDURE SMITILT
246  end  INTERFACE
247
248  INTERFACE SINGLE_LENS
249     MODULE PROCEDURE SMITILT
250  end  INTERFACE
251
252  INTERFACE multipole_block
253     MODULE PROCEDURE BLTILT
254  end  INTERFACE
255
256
257  INTERFACE HKICKER
258     MODULE PROCEDURE HKICKTILT
259  end  INTERFACE
260
261  INTERFACE VKICKER
262     MODULE PROCEDURE VKICKTILT
263  end  INTERFACE
264
265  INTERFACE KICKER
266     MODULE PROCEDURE GKICKTILT
267  end  INTERFACE
268
269  INTERFACE rbend
270     !     MODULE PROCEDURE recttilt
271     MODULE PROCEDURE rectaETILT
272  end  INTERFACE
273
274  INTERFACE sbend
275     MODULE PROCEDURE sBtilt
276  end  INTERFACE
277
278  INTERFACE Gbend
279     MODULE PROCEDURE GBtilt
280  end  INTERFACE
281
282  INTERFACE drift
283     MODULE PROCEDURE drft
284  end  INTERFACE
285
286  INTERFACE marker
287     MODULE PROCEDURE mark
288  end  INTERFACE
289
290  INTERFACE RCOLLIMATOR
291     MODULE PROCEDURE RCOLIT
292  end  INTERFACE
293  INTERFACE ECOLLIMATOR
294     MODULE PROCEDURE ECOLIT
295  end  INTERFACE
296
297  INTERFACE MONITOR
298     MODULE PROCEDURE MONIT
299  end  INTERFACE
300  INTERFACE HMONITOR
301     MODULE PROCEDURE HMONIT
302  end  INTERFACE
303  INTERFACE VMONITOR
304     MODULE PROCEDURE VMONIT
305  end  INTERFACE
306  INTERFACE INSTRUMENT
307     MODULE PROCEDURE INSTRUMEN
308  end  INTERFACE
309
310  INTERFACE RFCAVITY
311     MODULE PROCEDURE RFCAVITYL
312  end  INTERFACE
313
314  INTERFACE TWCAVITY
315     MODULE PROCEDURE TWCAVITYL
316  end  INTERFACE
317
318  INTERFACE ELSEPARATOR
319     MODULE PROCEDURE ELSESTILT
320  end  INTERFACE
321
322
323
324
325
326  INTERFACE WIGGLER
327     MODULE PROCEDURE WIGGLERL
328  end  INTERFACE
329
330
331
332  INTERFACE arbitrary
333     MODULE PROCEDURE arbitrary_tilt
334  end  INTERFACE
335
336  !  Taylor map
337  !  INTERFACE Taylor_map
338  !     MODULE PROCEDURE  Taylor_maptilt
339  !  end  INTERFACE
340
341
342
343CONTAINS
344
345  SUBROUTINE SET_MADX_(CONV,CONV1)
346    IMPLICIT NONE
347    logical(lp) CONV,CONV1
348    MADX=CONV
349    MADX_MAGNET_ONLY=CONV1
350  END SUBROUTINE SET_MADX_
351
352
353
354  FUNCTION r_r( S1, S2 )
355    implicit none
356    TYPE(TILTING) r_r
357    TYPE(TILTING), INTENT (IN) :: S1
358    real(dp), INTENT (IN) :: S2
359
360
361    r_r=S1
362    R_R%TILT(0)=S2
363    R_R%NATURAL=.FALSE.
364
365  END FUNCTION r_r
366
367  real(dp) function fac(n)    ! David Sagan
368    implicit none
369    integer n
370    fac=1.0_dp
371    if(mad) then
372       fac=madfac(iabs(n))
373    endif
374
375  end  function fac
376
377  SUBROUTINE  CHECKSMI(S2,S1)
378    implicit none
379    type (EL_LIST),INTENT(IN):: S2
380    INTEGER,INTENT(IN):: S1
381    IF(S2%KIND==KIND8) THEN
382       IF(S2%NMUL/=S1) THEN
383          w_p=0
384          w_p%nc=1
385          w_p%fc='((1X,a72))'
386          write(w_p%c(1),'(a24,1x,i4,a21,1x,i4)')  MYTYPE(KIND8),S2%NMUL,' DOES NOT ALLOW POLE ', 2*S1
387          ! call !write_e(KIND8)
388       ENDIF
389    ELSEIF(S2%KIND==KIND9) THEN
390       IF(S2%NMUL/=-S1) THEN
391          w_p=0
392          w_p%nc=1
393          w_p%fc='((1X,a72))'
394          write(w_p%c(1),'(a24,1x,i4,a21,1x,i4)') MYTYPE(KIND9),S2%NMUL,' DOES NOT ALLOW POLE ',2*S1
395          ! call !write_e(KIND9)
396       ENDIF
397    ENDIF
398
399  END SUBROUTINE CHECKSMI
400
401
402  FUNCTION  A10(S2,S1)
403    implicit none
404    type (EL_LIST) A10
405    type (EL_LIST),INTENT(IN):: S2
406    real(dp),INTENT(IN):: S1
407    CALL CHECKSMI(S2,-10)
408    A10 =S2
409    A10 %K(10)=A10%K(10)
410    A10 %KS(10)=A10%KS(10)+S1 !/fac(10)
411  END FUNCTION A10
412
413  FUNCTION  B10(S2,S1)
414    implicit none
415    type (EL_LIST) B10
416    type (EL_LIST),INTENT(IN):: S2
417    real(dp),INTENT(IN):: S1
418    CALL CHECKSMI(S2,10)
419    B10 =S2
420    B10 %K(10)=B10 %K(10)+S1 !/fac(10)
421    B10 %KS(10)=B10 %KS(10)
422  END FUNCTION B10
423
424  FUNCTION  A9(S2,S1)
425    implicit none
426    type (EL_LIST) A9
427    type (EL_LIST),INTENT(IN):: S2
428    real(dp),INTENT(IN):: S1
429    CALL CHECKSMI(S2,-9)
430    A9 =S2
431    A9 %K(9)=A9%K(9)
432    A9 %KS(9)=A9%KS(9)+S1  !/fac(9)
433  END FUNCTION A9
434
435  FUNCTION  B9(S2,S1)
436    implicit none
437    type (EL_LIST) B9
438    type (EL_LIST),INTENT(IN):: S2
439    real(dp),INTENT(IN):: S1
440    CALL CHECKSMI(S2,9)
441    B9 =S2
442    B9 %K(9)=B9 %K(9)+S1 !/fac(9)
443    B9 %KS(9)=B9 %KS(9)
444  END FUNCTION B9
445
446  FUNCTION  A8(S2,S1)
447    implicit none
448    type (EL_LIST) A8
449    type (EL_LIST),INTENT(IN):: S2
450    real(dp),INTENT(IN):: S1
451    CALL CHECKSMI(S2,-8)
452    A8 =S2
453    A8 %K(8)=A8%K(8)
454    A8 %KS(8)=A8%KS(8)+S1 !/fac(8)
455  END FUNCTION A8
456
457  FUNCTION  B8(S2,S1)
458    implicit none
459    type (EL_LIST) B8
460    type (EL_LIST),INTENT(IN):: S2
461    real(dp),INTENT(IN):: S1
462    CALL CHECKSMI(S2,8)
463    B8 =S2
464    B8 %K(8)=B8 %K(8)+S1 !/fac(8)
465    B8 %KS(8)=B8 %KS(8)
466  END FUNCTION B8
467
468  FUNCTION  A7(S2,S1)
469    implicit none
470    type (EL_LIST) A7
471    type (EL_LIST),INTENT(IN):: S2
472    real(dp),INTENT(IN):: S1
473    CALL CHECKSMI(S2,-7)
474    A7 =S2
475    A7 %K(7)=A7%K(7)
476    A7 %KS(7)=A7%KS(7)+S1  !/fac(7)
477  END FUNCTION A7
478
479  FUNCTION  B7(S2,S1)
480    implicit none
481    type (EL_LIST) B7
482    type (EL_LIST),INTENT(IN):: S2
483    real(dp),INTENT(IN):: S1
484    CALL CHECKSMI(S2,7)
485    B7 =S2
486    B7 %K(7)=B7 %K(7)+S1   !/fac(7)
487    B7 %KS(7)=B7 %KS(7)
488  END FUNCTION B7
489
490  FUNCTION  A6(S2,S1)
491    implicit none
492    type (EL_LIST) A6
493    type (EL_LIST),INTENT(IN):: S2
494    real(dp),INTENT(IN):: S1
495    CALL CHECKSMI(S2,-6)
496    A6 =S2
497    A6 %K(6)=A6%K(6)
498    A6 %KS(6)=A6%KS(6)+S1  !/fac(6)
499  END FUNCTION A6
500
501  FUNCTION  B6(S2,S1)
502    implicit none
503    type (EL_LIST) B6
504    type (EL_LIST),INTENT(IN):: S2
505    real(dp),INTENT(IN):: S1
506    CALL CHECKSMI(S2,6)
507    B6 =S2
508    B6 %K(6)=B6 %K(6)+S1 !/fac(6)
509    B6 %KS(6)=B6 %KS(6)
510  END FUNCTION B6
511
512  FUNCTION  A5(S2,S1)
513    implicit none
514    type (EL_LIST) A5
515    type (EL_LIST),INTENT(IN):: S2
516    real(dp),INTENT(IN):: S1
517    CALL CHECKSMI(S2,-5)
518    A5 =S2
519    A5 %K(5)=A5%K(5)
520    A5 %KS(5)=A5%KS(5)+S1 !/fac(5)
521  END FUNCTION A5
522
523  FUNCTION  B5(S2,S1)
524    implicit none
525    type (EL_LIST) B5
526    type (EL_LIST),INTENT(IN):: S2
527    real(dp),INTENT(IN):: S1
528    CALL CHECKSMI(S2,5)
529    B5 =S2
530    B5 %K(5)=B5 %K(5)+S1 !/fac(5)
531    B5 %KS(5)=B5 %KS(5)
532  END FUNCTION B5
533
534  FUNCTION  A4(S2,S1)
535    implicit none
536    type (EL_LIST) A4
537    type (EL_LIST),INTENT(IN):: S2
538    real(dp),INTENT(IN):: S1
539    CALL CHECKSMI(S2,-4)
540    A4 =S2
541    A4 %K(4)=A4%K(4)
542    A4 %KS(4)=A4%KS(4)+S1 !/fac(4)
543  END FUNCTION A4
544
545  FUNCTION  B4(S2,S1)
546    implicit none
547    type (EL_LIST) B4
548    type (EL_LIST),INTENT(IN):: S2
549    real(dp),INTENT(IN):: S1
550    CALL CHECKSMI(S2,4)
551    B4 =S2
552    B4 %K(4)=B4 %K(4)+S1 !/fac(4)
553    B4 %KS(4)=B4 %KS(4)
554  END FUNCTION B4
555
556  FUNCTION  A3(S2,S1)
557    implicit none
558    type (EL_LIST) A3
559    type (EL_LIST),INTENT(IN):: S2
560    real(dp),INTENT(IN):: S1
561    CALL CHECKSMI(S2,-3)
562    A3 =S2
563    A3 %K(3)=A3%K(3)
564    A3 %KS(3)=A3%KS(3)+S1 !/fac(3)
565  END FUNCTION A3
566
567  FUNCTION  B3(S2,S1)
568    implicit none
569    type (EL_LIST) B3
570    type (EL_LIST),INTENT(IN):: S2
571    real(dp),INTENT(IN):: S1
572    CALL CHECKSMI(S2,3)
573    B3 =S2
574    B3 %K(3)=B3 %K(3)+S1 !/fac(3)
575    B3 %KS(3)=B3 %KS(3)
576  END FUNCTION B3
577
578  FUNCTION  A2(S2,S1)
579    implicit none
580    type (EL_LIST) A2
581    type (EL_LIST),INTENT(IN):: S2
582    real(dp),INTENT(IN):: S1
583    CALL CHECKSMI(S2,-2)
584    A2 =S2
585    A2 %K(2)=A2%K(2)
586    A2 %KS(2)=A2%KS(2)+S1
587  END FUNCTION A2
588
589  FUNCTION  B2(S2,S1)
590    implicit none
591    type (EL_LIST) B2
592    type (EL_LIST),INTENT(IN):: S2
593    real(dp),INTENT(IN):: S1
594    CALL CHECKSMI(S2,2)
595    B2 =S2
596    B2 %K(2)=B2 %K(2)+S1
597    B2 %KS(2)=B2 %KS(2)
598  END FUNCTION B2
599
600  FUNCTION  A1(S2,S1)
601    implicit none
602    type (EL_LIST) A1
603    type (EL_LIST),INTENT(IN):: S2
604    real(dp),INTENT(IN):: S1
605    real(dp) smad
606    CALL CHECKSMI(S2,-1)
607    smad=s1
608    if(madkick) then
609       if(s2%L/=0) smad=smad/s2%L
610    endif
611    A1 =S2
612    A1 %K(1)=A1%K(1)
613    A1 %KS(1)=A1%KS(1)+Smad
614  END FUNCTION A1
615
616  FUNCTION  B1(S2,S1)
617    implicit none
618    type (EL_LIST) B1
619    type (EL_LIST),INTENT(IN):: S2
620    real(dp),INTENT(IN):: S1
621    real(dp) smad
622    CALL CHECKSMI(S2,1)
623
624    smad=s1
625    if(madkick) then
626       smad=-smad
627       if(s2%L/=0) smad=smad/s2%L
628    endif
629
630    B1 =S2
631    B1 %K(1)=B1 %K(1)+smad
632    B1 %KS(1)=B1 %KS(1)
633  END FUNCTION B1
634
635
636
637  SUBROUTINE  EL_0(S2,S1)
638    implicit none
639    type (EL_LIST),INTENT(OUT):: S2
640    INTEGER,INTENT(IN):: S1
641    INTEGER I
642
643    if(.not.setmad) then
644       w_p=0
645       w_p%nc=1
646       w_p%fc='((1X,a72))'
647       w_p%c(1) =  " Run the Set_mad routine first "
648       ! call !write_e(-1)
649    endif
650
651    IF(S1==0) THEN
652       S2%L=0.0_dp
653       S2%LD=0.0_dp
654       S2%LC=0.0_dp
655       DO I=1,NMAX
656          S2%K(I)=0.0_dp;S2%KS(I)=0.0_dp
657       ENDDO
658       do i=1,3              ! needed???
659          S2%ang(i)=0.0_dp
660          S2%t(i)=0.0_dp
661          S2%angi(i)=0.0_dp
662          S2%ti(i)=0.0_dp
663       enddo
664       s2%CAVITY_TOTALPATH=1
665       S2%patchg=0
666       S2%T1=0.0_dp
667       S2%T2=0.0_dp
668       S2%B0=0.0_dp
669       S2%volt=0.0_dp
670       S2%freq0=0.0_dp
671       S2%harmon=1.0_dp
672       S2%lag=0.0_dp
673       S2%DELTA_E=0.0_dp
674       S2%BSOL=0.0_dp
675       S2%TILT=0.0_dp
676       s2%FINT=0.5_dp
677       s2%hgap=0.0_dp
678       s2%h1=0.0_dp
679       s2%h2=0.0_dp
680       s2%X_COL=0.0_dp    !!!! missing !!!
681       s2%Y_COL=0.0_dp   !!!! missing !!!
682       s2%thin_h_foc=0.0_dp
683       s2%thin_v_foc=0.0_dp
684       s2%thin_h_angle=0.0_dp
685       s2%thin_v_angle=0.0_dp
686       s2%hf=0.0_dp
687       s2%vf=0.0_dp
688       s2%ls=1.0_dp
689       s2%file=' '
690       s2%file_rev=' '
691       s2%NAME=' '
692       s2%VORNAME=' '
693       S2%KIND=0
694       S2%nmul=0
695       S2%nst=nstd
696       S2%method=metd
697       s2%APERTURE_ON=my_false
698       s2%APERTURE_KIND=0
699       S2%APERTURE_R(1)=absolute_aperture  !!! just in case !!!
700       S2%APERTURE_R(2)=absolute_aperture  !!! just in case !!!
701       S2%APERTURE_X=absolute_aperture
702       S2%APERTURE_Y=absolute_aperture
703       s2%KILL_ENT_FRINGE=my_false
704       s2%KILL_EXI_FRINGE=my_false
705       s2%BEND_FRINGE=my_false
706       s2%PERMFRINGE=my_false
707       s2%DPHAS=0.0_dp
708       s2%PSI=0.0_dp
709       s2%dvds=0.0_dp
710       s2%N_BESSEL=0
711
712    ENDIF
713  END SUBROUTINE EL_0
714
715  !  SUBROUTINE  EL_0(S2,S1)
716  !    implicit none
717  !    type (EL_LIST),INTENT(OUT):: S2
718  !    INTEGER,INTENT(IN):: S1
719  !    INTEGER I
720  !
721  !    if(.not.setmad) then
722  !       w_p=0
723  !       w_p%nc=1
724  !       w_p%fc='((1X,a72))'
725  !       w_p%c(1) =  " Run the Set_mad routine first "
726  !       ! call !write_e(-1)
727  !    endif
728  !
729  !    IF(S1==0) THEN
730  !       S2%ang=zero
731  !       S2%t=zero
732  !       S2%angi=zero
733  !       S2%ti=zero
734  !       S2%patchg=0
735  !       S2%L=zero
736  !       S2%LD=zero
737  !       S2%LC=zero
738  !       S2%TILT=zero
739  !       DO I=1,NMAX
740  !          S2%K(I)=zero;S2%KS(I)=zero
741  !       ENDDO
742  !       S2%T1=zero
743  !       S2%T2=zero
744  !       S2%B0=zero
745  !       S2%BSOL=zero
746  !       S2%volt=zero
747  !       S2%freq0=zero
748  !       S2%harmon=one
749  !       S2%DELTA_E=zero
750  !       S2%lag=zero
751  !       S2%KIND=0
752  !       S2%nmul=0
753  !       S2%method=metd
754  !       S2%nst=nstd
755  !       s2%NAME=' '
756  !       s2%VORNAME=' '
757  !       s2%file=' '
758  !       s2%file_rev=' '
759  !       s2%FINT=half
760  !       s2%hgap=zero
761  !       s2%h1=zero
762  !       s2%h2=zero
763  !       s2%hf=zero
764  !       s2%vf=zero
765  !       s2%ls=one
766  !       s2%thin_h_foc=zero
767  !       s2%thin_v_foc=zero
768  !       s2%thin_h_angle=zero
769  !       s2%thin_v_angle=zero
770  !       s2%APERTURE_ON=.FALSE.
771  !       s2%KILL_ENT_FRINGE=.FALSE.
772  !       s2%KILL_EXI_FRINGE=.FALSE.
773  !       s2%BEND_FRINGE=.FALSE.
774  !       s2%PERMFRINGE=.FALSE.
775  !       s2%DPHAS=ZERO
776  !       s2%dvds=ZERO
777  !       s2%PSI=ZERO
778  !       s2%N_BESSEL=0
779  !
780  !       s2%APERTURE_KIND=0
781  !       S2%APERTURE_R=absolute_aperture
782  !       S2%APERTURE_X=absolute_aperture
783  !       S2%APERTURE_Y=absolute_aperture
784  !    ENDIF
785  !  END SUBROUTINE EL_0
786
787  !  DEFINING ELEMEMTS
788
789  FUNCTION  SMITILT(NAME,K1,N,T,LIST)
790    implicit none
791    type (EL_LIST) SMITILT
792    type (EL_LIST),optional, INTENT(IN):: LIST
793    CHARACTER(*), INTENT(IN):: NAME
794    type (TILTING),optional, INTENT(IN):: T
795    real(dp),optional, INTENT(IN):: K1
796    INTEGER,optional,INTENT(IN):: N
797    INTEGER NN,I
798    LOGICAL(LP) SEARCH
799    REAL(DP) K11
800    NN=0
801    K11=0.0_dp
802    IF(PRESENT(N)) NN=N
803    IF(PRESENT(K1)) K11=K1
804
805    IF(PRESENT(LIST)) THEN   !
806       SMITILT=LIST    !  SPECIAL SINCE SMI CAN ONLY BE A SINGLE POLE
807       SMITILT%L=0.0_dp
808       SMITILT%LD=0.0_dp
809       SMITILT%LC=0.0_dp
810       NN=1
811       SEARCH=.TRUE.
812       DO I=NMAX,1,-1
813          IF(LIST%K(I)/=0.0_dp.AND.SEARCH) THEN
814             SEARCH=.FALSE.
815             K11=LIST%K(I)
816             NN=I
817          ENDIF
818          IF(LIST%KS(I)/=0.0_dp.AND.SEARCH) THEN
819             SEARCH=.FALSE.
820             K11=LIST%KS(I)
821             NN=-I
822          ENDIF
823       ENDDO
824
825       IF(NN>=1.AND.NN<=10) THEN
826          SMITILT%K(NN)=K11  !/fac(nN)
827          SMITILT%KIND=kind8
828          SMITILT%nmul=NN
829       ELSEIF(NN<0.AND.NN>=-10) THEN
830          SMITILT%KS(-NN)=K11 !/fac(nN)
831          SMITILT%KIND=kind9
832          SMITILT%nmul=-NN
833       ELSE
834          w_p=0
835          w_p%nc=1
836          w_p%fc='((1X,a72))'
837          write(w_p%c(1),'(a21,1x,i4)') " FORBIDDEN 'SMITILT' ",NN
838          ! call !write_e(1221)
839       ENDIF
840       if(present(t)) SMITILT%tilt=t%tilt(0)
841
842       IF(LEN(NAME)>nlp) THEN
843          w_p=0
844          w_p%nc=2
845          w_p%fc='((1X,a72,/),(1x,a72))'
846          w_p%c(1)=name
847          WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
848          ! call ! WRITE_I
849          SMITILT%NAME=NAME(1:16)
850       ELSE
851          SMITILT%NAME=NAME
852       ENDIF
853
854    ELSE    !
855       SMITILT=0
856       SMITILT%L=0.0_dp
857       SMITILT%LD=0.0_dp
858       SMITILT%LC=0.0_dp
859       IF(NN>=1.AND.NN<=10) THEN
860          SMITILT%K(NN)=K11 !/fac(Nn)
861          SMITILT%KIND=kind8
862          SMITILT%nmul=NN
863       ELSEIF(NN<0.AND.NN>=-10) THEN
864          SMITILT%KS(-NN)=K11 !/fac(nN)
865          SMITILT%KIND=kind9
866          SMITILT%nmul=-NN
867       ELSE
868          w_p=0
869          w_p%nc=1
870          w_p%fc='((1X,a72))'
871          write(w_p%c(1),'(a21,1x,i4)') " FORBIDDEN 'SMITILT' ",NN
872          ! call !write_e(1221)
873       ENDIF
874       if(present(t)) then
875          IF(T%NATURAL) THEN
876             SMITILT%tilt=t%tilt(iabs(Nn))
877          ELSE
878             SMITILT%tilt=t%tilt(0)
879          ENDIF
880       endif
881
882
883
884       IF(LEN(NAME)>nlp) THEN
885          w_p=0
886          w_p%nc=2
887          w_p%fc='((1X,a72,/),(1x,a72))'
888          w_p%c(1)=name
889          WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
890          ! call ! WRITE_I
891          SMITILT%NAME=NAME(1:16)
892       ELSE
893          SMITILT%NAME=NAME
894       ENDIF
895
896    ENDIF   !1
897  END FUNCTION SMITILT
898
899  FUNCTION  BLTILT(NAME,K,T,LIST)
900    implicit none
901    type (EL_LIST) BLTILT
902    type (EL_LIST),optional, INTENT(IN):: LIST
903    CHARACTER(*), INTENT(IN):: NAME
904    type (TILTING),optional, INTENT(IN):: T
905    TYPE(MUL_BLOCK),OPTIONAL, INTENT(IN):: K
906    INTEGER I
907    LOGICAL(LP) COUNT
908    if(present(list)) then   !1
909       BLTILT=list
910       BLTILT%L=0.0_dp
911       BLTILT%LD=0.0_dp
912       BLTILT%LC=0.0_dp
913
914       BLTILT%KIND=kind3
915       BLTILT%BSOL=LIST%bsol
916       BLTILT%nmul=LIST%NMUL
917       COUNT=.TRUE.
918
919       DO I=NMAX,1,-1
920          BLTILT%K(I)=LIST%K(I) !/fac(i)
921          BLTILT%KS(I)=LIST%KS(I) !/fac(i)
922          IF(COUNT) THEN
923             IF(BLTILT%K(I)/=0.0_dp.OR.BLTILT%KS(I)/=0.0_dp) THEN
924                COUNT=.FALSE.
925                BLTILT%nmul=I
926             ENDIF
927          ENDIF
928       ENDDO
929
930       if(present(t)) BLTILT%tilt=t%tilt(0)
931
932
933
934       IF(LEN(NAME)>nlp) THEN
935          w_p=0
936          w_p%nc=2
937          w_p%fc='((1X,a72,/),(1x,a72))'
938          w_p%c(1)=name
939          WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
940          ! call ! WRITE_I
941          BLTILT%NAME=NAME(1:16)
942       ELSE
943          BLTILT%NAME=NAME
944       ENDIF
945
946    else   !1
947       BLTILT=0
948       BLTILT%L=0.0_dp
949       BLTILT%LD=0.0_dp
950       BLTILT%LC=0.0_dp
951
952       BLTILT%KIND=kind3
953       BLTILT%nmul=K%NMUL
954       DO I=1,K%NMUL
955          BLTILT%K(I)=K%BN(I) !/fac(i)
956          BLTILT%KS(I)=K%AN(I) !/fac(i)
957       ENDDO
958
959       if(present(t)) then
960          IF(T%NATURAL) THEN
961             BLTILT%tilt=t%tilt(K%NATURAL)
962          ELSE
963             BLTILT%tilt=t%tilt(0)
964          ENDIF
965       endif
966
967
968
969       IF(LEN(NAME)>nlp) THEN
970          w_p=0
971          w_p%nc=2
972          w_p%fc='((1X,a72,/),(1x,a72))'
973          w_p%c(1)=name
974          WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
975          ! call ! WRITE_I
976          BLTILT%NAME=NAME(1:16)
977       ELSE
978          BLTILT%NAME=NAME
979       ENDIF
980    endif    !1
981  END FUNCTION BLTILT
982
983
984  FUNCTION  HKICKTILT(NAME,L,kick,T)
985    implicit none
986    type (EL_LIST) HKICKTILT
987    type (TILTING),optional, INTENT(IN):: T
988    CHARACTER(*), INTENT(IN):: NAME
989    real(dp) ,OPTIONAL, INTENT(IN):: L,kick
990    real(dp) L1,K11
991    L1=0.0_dp
992    K11=0.0_dp
993    IF(PRESENT(L)) L1=L
994    IF(PRESENT(kick)) K11=kick
995    madkick=.true.
996    HKICKTILT=0
997    HKICKTILT%L=L1
998    HKICKTILT%LD=L1
999    HKICKTILT%LC=L1
1000    IF(L1==0.0_dp) THEN
1001       HKICKTILT%K(1)=-K11        ! MAD convention K1>0 means px > 0
1002       HKICKTILT%KIND=MADKIND3N
1003       HKICKTILT%nmul=1
1004    ELSE
1005       HKICKTILT%K(1)=-K11/L1
1006       HKICKTILT%KIND=MADKIND2
1007       HKICKTILT%nmul=2
1008    ENDIF
1009
1010    IF(PRESENT(T)) THEN
1011       IF(T%NATURAL) THEN
1012          HKICKTILT%tilt=t%tilt(1)
1013       ELSE
1014          HKICKTILT%tilt=t%tilt(0)
1015       ENDIF
1016    ENDIF
1017
1018    IF(LEN(NAME)>nlp) THEN
1019       w_p=0
1020       w_p%nc=2
1021       w_p%fc='((1X,a72,/),(1x,a72))'
1022       w_p%c(1)=name
1023       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
1024       ! call ! WRITE_I
1025       HKICKTILT%NAME=NAME(1:16)
1026    ELSE
1027       HKICKTILT%NAME=NAME
1028    ENDIF
1029  END FUNCTION HKICKTILT
1030
1031  FUNCTION  VKICKTILT(NAME,L,kick,T)
1032    implicit none
1033    type (EL_LIST) VKICKTILT
1034    type (TILTING),OPTIONAL, INTENT(IN):: T
1035    CHARACTER(*), INTENT(IN):: NAME
1036    real(dp) ,OPTIONAL, INTENT(IN):: L,kick
1037    real(dp) L1,K11
1038    L1=0.0_dp
1039    K11=0.0_dp
1040    IF(PRESENT(L)) L1=L
1041    IF(PRESENT(kick)) K11=kick
1042
1043    madkick=.true.
1044    VKICKTILT=0
1045    VKICKTILT%L=L1
1046    VKICKTILT%LD=L1
1047    VKICKTILT%LC=L1
1048    IF(L1==0.0_dp) THEN
1049       VKICKTILT%KS(1)=K11        ! MAD convention K1>0 means px > 0
1050       VKICKTILT%KIND=MADKIND3S
1051       VKICKTILT%nmul=1
1052    ELSE
1053       VKICKTILT%KS(1)=K11/L1
1054       VKICKTILT%KIND=MADKIND2
1055       VKICKTILT%nmul=2
1056    ENDIF
1057    IF(PRESENT(T)) THEN
1058       IF(T%NATURAL) THEN
1059          VKICKTILT%tilt=t%tilt(1)
1060       ELSE
1061          VKICKTILT%tilt=t%tilt(0)
1062       ENDIF
1063    ENDIF
1064
1065    IF(LEN(NAME)>nlp) THEN
1066       w_p=0
1067       w_p%nc=2
1068       w_p%fc='((1X,a72,/),(1x,a72))'
1069       w_p%c(1)=name
1070       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
1071       ! call ! WRITE_I
1072       VKICKTILT%NAME=NAME(1:16)
1073    ELSE
1074       VKICKTILT%NAME=NAME
1075    ENDIF
1076  END FUNCTION VKICKTILT
1077
1078
1079  FUNCTION  GKICKTILT(NAME,L,hkick,vkick,T,LIST)
1080    implicit none
1081    type (EL_LIST) GKICKTILT
1082    type (EL_LIST), OPTIONAL,INTENT(IN):: LIST
1083    type (TILTING), OPTIONAL,INTENT(IN):: T
1084    CHARACTER(*), INTENT(IN):: NAME
1085    real(dp) ,OPTIONAL, INTENT(IN):: L ,hkick ,vkick
1086    real(dp) L1,K11,K21
1087    L1=0.0_dp
1088    K11=0.0_dp
1089    K21=0.0_dp
1090    IF(PRESENT(L)) L1=L
1091    IF(PRESENT(hkick)) K11=hkick
1092    IF(PRESENT(vkick)) K21=vkick
1093    madkick=.true.
1094
1095    if(present(list)) then
1096       GKICKTILT=list
1097       l1=list%L
1098       K11=LIST%K(1)
1099       K21=LIST%KS(1)
1100
1101
1102    else
1103       GKICKTILT=0
1104    endif
1105    GKICKTILT%L=L1
1106    GKICKTILT%LD=L1
1107    GKICKTILT%LC=L1
1108    IF(L1==0.0_dp) THEN
1109       GKICKTILT%K(1)=-K11        ! MAD convention K1>0 means px > 0
1110       GKICKTILT%KS(1)=K21        ! MAD convention K1>0 means px > 0
1111       GKICKTILT%KIND=KIND3
1112       GKICKTILT%nmul=1
1113    ELSE
1114       GKICKTILT%K(1)=-K11/L1        ! MAD convention K1>0 means px > 0
1115       GKICKTILT%KS(1)=K21/L1        ! MAD convention K1>0 means px > 0
1116       GKICKTILT%KIND=MADKIND2
1117       GKICKTILT%nmul=2
1118    ENDIF
1119    IF(PRESENT(T)) THEN      !2002.11.09   BUG
1120       IF(T%NATURAL) THEN
1121          GKICKTILT%tilt=t%tilt(1)
1122       ELSE
1123          GKICKTILT%tilt=t%tilt(0)
1124       ENDIF
1125    ENDIF
1126
1127    IF(LEN(NAME)>nlp) THEN
1128       w_p=0
1129       w_p%nc=2
1130       w_p%fc='((1X,a72,/),(1x,a72))'
1131       w_p%c(1)=name
1132       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
1133       ! call ! WRITE_I
1134       GKICKTILT%NAME=NAME(1:16)
1135    ELSE
1136       GKICKTILT%NAME=NAME
1137    ENDIF
1138  END FUNCTION GKICKTILT
1139
1140
1141
1142  FUNCTION  QUADTILT(NAME,L,K1,T,list)
1143    implicit none
1144    type (EL_LIST) QUADTILT
1145    type (EL_LIST),optional, INTENT(IN)::list
1146    type (TILTING),optional, INTENT(IN):: T
1147    CHARACTER(*), INTENT(IN):: NAME
1148    real(dp) ,optional, INTENT(IN):: L,K1
1149    real(dp) L1,K11
1150    L1=0.0_dp
1151    K11=0.0_dp
1152    IF(PRESENT(L)) L1=L
1153    IF(PRESENT(K1)) K11=K1
1154    if(present(list)) then
1155       quadtilt=list
1156       l1=list%L
1157       K11=LIST%K(2)
1158    else
1159       QUADTILT=0
1160    endif
1161    QUADTILT%L=L1
1162    QUADTILT%LD=L1
1163    QUADTILT%LC=L1
1164    QUADTILT%K(2)=K11
1165    IF(L1==0.0_dp) THEN
1166       QUADTILT%K(2)=K11
1167       QUADTILT%KIND=MADKIND3N
1168    ELSE
1169       QUADTILT%K(2)=K11
1170       QUADTILT%KIND=MADKIND2
1171    ENDIF
1172    QUADTILT%nmul=2
1173    IF(PRESENT(t)) then
1174       IF(T%NATURAL) THEN
1175          QUADTILT%tilt=t%tilt(2)
1176       ELSE
1177          QUADTILT%tilt=t%tilt(0)
1178       ENDIF
1179    endif
1180    IF(LEN(NAME)>nlp) THEN
1181       w_p=0
1182       w_p%nc=2
1183       w_p%fc='((1X,a72,/),(1x,a72))'
1184       w_p%c(1)=name
1185       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
1186       ! call ! WRITE_I
1187       QUADTILT%NAME=NAME(1:16)
1188    ELSE
1189       QUADTILT%NAME=NAME
1190    ENDIF
1191  END FUNCTION QUADTILT
1192
1193  FUNCTION  multipoleTILT(NAME,T,list)
1194    implicit none
1195    type (EL_LIST) multipoleTILT
1196    type (EL_LIST), INTENT(IN)::list
1197    type (TILTING),optional, INTENT(IN):: T
1198    CHARACTER(*), INTENT(IN):: NAME
1199
1200    real(dp) L1,K11
1201    L1=0.0_dp
1202    K11=0.0_dp
1203    multipoleTILT=list
1204    l1=list%L
1205
1206    multipoleTILT%L=L1
1207    multipoleTILT%LD=L1
1208    multipoleTILT%LC=L1
1209    IF(L1==0.0_dp) THEN
1210       multipoleTILT%KIND=MADKIND3N
1211    ELSE
1212       multipoleTILT%KIND=MADKIND2
1213    ENDIF
1214    IF(PRESENT(t)) then
1215       IF(T%NATURAL) THEN
1216          multipoleTILT%tilt=t%tilt(2)
1217       ELSE
1218          multipoleTILT%tilt=t%tilt(0)
1219       ENDIF
1220    endif
1221    IF(LEN(NAME)>nlp) THEN
1222       w_p=0
1223       w_p%nc=2
1224       w_p%fc='((1X,a72,/),(1x,a72))'
1225       w_p%c(1)=name
1226       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
1227       ! call ! WRITE_I
1228       multipoleTILT%NAME=NAME(1:16)
1229    ELSE
1230       multipoleTILT%NAME=NAME
1231    ENDIF
1232  END FUNCTION multipoleTILT
1233
1234  FUNCTION  HELICALTILT(NAME,L,K1,ks1,omega,PHASE,list)
1235    implicit none
1236    type (EL_LIST) HELICALTILT
1237    type (EL_LIST),optional, INTENT(IN)::list
1238    CHARACTER(*), INTENT(IN):: NAME
1239    real(dp) ,optional, INTENT(IN):: L,K1,ks1,PHASE,omega
1240    real(dp) L1,K11,Ks11,LAG1,FREQ01
1241    L1=0.0_dp
1242    K11=0.0_dp
1243    IF(PRESENT(L)) L1=L
1244    IF(PRESENT(K1)) K11=K1
1245    IF(PRESENT(Ks1)) Ks11=Ks1
1246    IF(PRESENT(PHASE)) LAG1=PHASE
1247    IF(PRESENT(omega)) FREQ01=omega
1248    if(present(list)) then
1249       HELICALTILT=list
1250       l1=list%L
1251       K11=LIST%K(1)
1252       Ks11=LIST%Ks(1)
1253       LAG1=LIST%LAG
1254       FREQ01=LIST%FREQ0
1255    else
1256       HELICALTILT=0
1257    endif
1258    HELICALTILT%L=L1
1259    HELICALTILT%LD=L1
1260    HELICALTILT%LC=L1
1261    HELICALTILT%K(1)=K11
1262    HELICALTILT%Ks(1)=Ks11
1263    HELICALTILT%LAG=LAG1
1264    HELICALTILT%FREQ0=FREQ01
1265    !   RFCAVITYL%P0C=P0C
1266    IF(L1==0.0_dp) THEN
1267       stop 999
1268    ELSE
1269       HELICALTILT%K(1)=K11
1270       HELICALTILT%Ks(1)=Ks11
1271       HELICALTILT%KIND=KIND22
1272    ENDIF
1273    HELICALTILT%nmul=1
1274
1275    IF(LEN(NAME)>nlp) THEN
1276       w_p=0
1277       w_p%nc=2
1278       w_p%fc='((1X,a72,/),(1x,a72))'
1279       w_p%c(1)=name
1280       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
1281       ! call ! WRITE_I
1282       HELICALTILT%NAME=NAME(1:16)
1283    ELSE
1284       HELICALTILT%NAME=NAME
1285    ENDIF
1286
1287
1288  END FUNCTION HELICALTILT
1289
1290
1291  FUNCTION  SOLTILT(NAME,L,KS,K1,T,LIST)
1292    implicit none
1293    type (EL_LIST) SOLTILT
1294    type (EL_LIST),optional, INTENT(IN):: LIST
1295    type (TILTING),optional, INTENT(IN):: T
1296    CHARACTER(*), INTENT(IN):: NAME
1297    real(dp) ,optional, INTENT(IN):: L,KS,K1
1298    real(dp) L1,K11,kq
1299
1300    L1=0.0_dp
1301    K11=0.0_dp
1302    KQ=0.0_dp
1303    IF(PRESENT(L)) L1=L
1304    IF(PRESENT(KS)) K11=KS
1305    IF(PRESENT(k1)) kq=K1
1306
1307    if(present(list)) then
1308       SOLTILT=list
1309       l1=list%L
1310       K11=LIST%BSOL
1311       KQ=LIST%K(2)
1312    else
1313       SOLTILT=0
1314    endif
1315    SOLTILT%L=L1
1316    SOLTILT%LD=L1
1317    SOLTILT%LC=L1
1318    SOLTILT%BSOL=K11
1319    SOLTILT%nmul=2
1320    IF(L1==0.0_dp) THEN
1321       SOLTILT%KIND=KIND3    ! used to be kind0
1322    ELSE
1323       SOLTILT%K(2)=KQ !/FAC(2)    ! MAD FACTOR
1324       !       if(madkind2==kind2) then
1325       SOLTILT%KIND=KIND5
1326       !       else
1327       !          SOLTILT%KIND=KIND17
1328       !       endif
1329    ENDIF
1330    IF(PRESENT(t)) then
1331       IF(T%NATURAL) THEN
1332          SOLTILT%tilt=0.0_dp   ! NO NATURAL TILT
1333       ELSE
1334          SOLTILT%tilt=t%tilt(0)
1335       ENDIF
1336    endif
1337    IF(LEN(NAME)>nlp) THEN
1338       w_p=0
1339       w_p%nc=2
1340       w_p%fc='((1X,a72,/),(1x,a72))'
1341       w_p%c(1)=name
1342       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
1343       ! call ! WRITE_I
1344       SOLTILT%NAME=NAME(1:16)
1345    ELSE
1346       SOLTILT%NAME=NAME
1347    ENDIF
1348  END FUNCTION SOLTILT
1349
1350
1351  FUNCTION  SEXTTILT(NAME,L,K2,T,LIST)
1352    implicit none
1353    type (EL_LIST) SEXTTILT
1354    type (EL_LIST),optional, INTENT(IN)::list
1355    type (TILTING),optional, INTENT(IN):: T
1356    CHARACTER(*), INTENT(IN):: NAME
1357    real(dp),optional , INTENT(IN):: L,K2
1358    real(dp) L1,K11
1359
1360    L1=0.0_dp
1361    K11=0.0_dp
1362    IF(PRESENT(L)) L1=L
1363    IF(PRESENT(K2)) K11=K2
1364    if(present(list)) then
1365       SEXTTILT=list
1366       l1=list%L
1367       K11=LIST%K(3)
1368    else
1369       SEXTTILT=0
1370    endif
1371    SEXTTILT%L=L1
1372    SEXTTILT%LD=L1
1373    SEXTTILT%LC=L1
1374    IF(L1==0.0_dp) THEN
1375       SEXTTILT%K(3)=K11  !/FAC(3)    ! MAD FACTOR
1376       SEXTTILT%KIND=MADKIND3N
1377    ELSE
1378       SEXTTILT%K(3)=K11 !/FAC(3)         ! MAD FACTOR
1379       SEXTTILT%KIND=MADKIND2
1380    ENDIF
1381    SEXTTILT%nmul=3
1382    if(present(t)) then
1383       IF(T%NATURAL) THEN
1384          SEXTTILT%tilt=t%tilt(3)
1385       ELSE
1386          SEXTTILT%tilt=t%tilt(0)
1387       ENDIF
1388    endif
1389
1390    IF(LEN(NAME)>nlp) THEN
1391       w_p=0
1392       w_p%nc=2
1393       w_p%fc='((1X,a72,/),(1x,a72))'
1394       w_p%c(1)=name
1395       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
1396       ! call ! WRITE_I
1397       SEXTTILT%NAME=NAME(1:16)
1398    ELSE
1399       SEXTTILT%NAME=NAME
1400    ENDIF
1401  END FUNCTION SEXTTILT
1402
1403
1404  FUNCTION  OCTUTILT(NAME,L,K3,T,LIST)
1405    implicit none
1406    type (EL_LIST) OCTUTILT
1407    type (EL_LIST),optional, INTENT(IN)::list
1408    type (TILTING),optional, INTENT(IN):: T
1409    CHARACTER(*), INTENT(IN):: NAME
1410    real(dp) ,optional, INTENT(IN):: L,K3
1411    real(dp) L1,K11
1412    L1=0.0_dp
1413    K11=0.0_dp
1414    IF(PRESENT(L)) L1=L
1415    IF(PRESENT(K3)) K11=K3
1416    if(present(list)) then
1417       OCTUTILT=list
1418       l1=list%L
1419       K11=LIST%K(4)
1420    else
1421       OCTUTILT=0
1422    endif
1423    OCTUTILT%L=L1
1424    OCTUTILT%LD=L1
1425    OCTUTILT%LC=L1
1426    IF(L1==0.0_dp) THEN
1427       OCTUTILT%K(4)=K11 !/FAC(4)         ! MAD FACTOR
1428       OCTUTILT%KIND=MADKIND3N
1429    ELSE
1430       OCTUTILT%K(4)=K11 !/FAC(4)         ! MAD FACTOR
1431       OCTUTILT%KIND=MADKIND2
1432    ENDIF
1433    OCTUTILT%nmul=4
1434    if(present(t)) then
1435       IF(T%NATURAL) THEN
1436          OCTUTILT%tilt=t%tilt(4)
1437       ELSE
1438          OCTUTILT%tilt=t%tilt(0)
1439       ENDIF
1440    endif
1441    !  call rot(OCTUTILT%tilt,OCTUTILT%K,OCTUTILT%KS,OCTUTILT%C,OCTUTILT%S)
1442    IF(LEN(NAME)>nlp) THEN
1443       w_p=0
1444       w_p%nc=2
1445       w_p%fc='((1X,a72,/),(1x,a72))'
1446       w_p%c(1)=name
1447       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
1448       ! call ! WRITE_I
1449       OCTUTILT%NAME=NAME(1:16)
1450    ELSE
1451       OCTUTILT%NAME=NAME
1452    ENDIF
1453  END FUNCTION OCTUTILT
1454
1455
1456  FUNCTION  SBTILT(NAME,L,ANGLE,E1,E2,T,LIST)
1457    implicit none
1458    type (EL_LIST) SBTILT
1459    type (EL_LIST),optional, INTENT(IN)::list
1460    type (TILTING),optional, INTENT(IN):: T
1461    CHARACTER(*), INTENT(IN):: NAME
1462    real(dp) ,optional, INTENT(IN):: L,angle,E1,E2
1463    real(dp) L1,ANG1,E11,E22
1464    CURVED_ELEMENT=.TRUE.
1465    L1=0.0_dp
1466    ANG1=0.0_dp
1467    E11=0.0_dp
1468    E22=0.0_dp
1469    IF(PRESENT(L)) L1=L
1470    IF(PRESENT(angle)) ANG1=angle
1471
1472    IF(PRESENT(E1)) E11=E1
1473    IF(PRESENT(E2)) E22=E2
1474
1475
1476
1477
1478    if(present(list)) then
1479       SBTILT=list
1480       l1=list%L
1481       E11=LIST%T1
1482       E22=LIST%T2
1483       ANG1=LIST%B0
1484    else
1485       SBTILT=0
1486    endif
1487
1488    if(present(t))then
1489       IF(EXACT_MODEL) THEN                 ! .and.madkind2==kind2
1490          SBTILT=POTTILT(NAME,L1,ANG1,E11,E22,T,LIST)
1491       ELSE
1492          SBTILT=GBEND(NAME,L1,ANG1,E11,E22,T,LIST)
1493       ENDIF
1494    else
1495       IF(EXACT_MODEL) THEN                 ! .and.madkind2==kind2
1496          SBTILT=POTTILT(NAME,L1,ANG1,E11,E22)
1497       ELSE
1498          SBTILT=GBEND(NAME,L1,ANG1,E11,E22)
1499       ENDIF
1500    endif
1501
1502  END FUNCTION SBTILT
1503
1504
1505  FUNCTION  POTTILT(NAME,L,ANG,E1,E2,T,LIST)
1506    implicit none
1507    type (EL_LIST) POTTILT
1508    type (EL_LIST),optional, INTENT(IN)::list
1509    real(dp) ,optional, INTENT(IN):: E1,E2
1510    type (TILTING),optional, INTENT(IN):: T
1511    CHARACTER(*), INTENT(IN):: NAME
1512    real(dp),optional , INTENT(IN):: L,ANG
1513    real(dp) E11,E22,L1,ANG1
1514
1515    E11=0.0_dp
1516    E22=0.0_dp
1517    L1=0.0_dp
1518    ANG1=0.0_dp
1519    IF(PRESENT(E1)) E11=E1 ;
1520    IF(PRESENT(E2)) E22=E2 ;
1521    IF(PRESENT(ANG)) ANG1=ANG ;
1522    IF(PRESENT(L)) L1=L ;
1523    if(present(list)) then
1524       POTTILT=list
1525       l1=list%L
1526       ANG1=LIST%B0
1527       E11=LIST%T1
1528       E22=LIST%T2
1529    else
1530       POTTILT=0
1531    endif
1532
1533
1534
1535    POTTILT%B0=ANG1/L1
1536    POTTILT%L=L1
1537    POTTILT%LD=L1
1538    POTTILT%T1=E11;
1539    POTTILT%T2=E22;
1540
1541    IF(ANG/=0.0_dp) THEN
1542       POTTILT%LC=2.0_dp*SIN(ANG/2.0_dp)/POTTILT%B0
1543    ELSE
1544       POTTILT%LC=POTTILT%L
1545    ENDIF
1546    IF(LEN(NAME)>nlp) THEN
1547       w_p=0
1548       w_p%nc=2
1549       w_p%fc='((1X,a72,/),(1x,a72))'
1550       w_p%c(1)=name
1551       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
1552       ! call ! WRITE_I
1553       POTTILT%NAME=NAME(1:16)
1554    ELSE
1555       POTTILT%NAME=NAME
1556    ENDIF
1557
1558    if(present(t)) then
1559       IF(T%NATURAL) THEN
1560          POTTILT%tilt=t%tilt(1)
1561       ELSE
1562          POTTILT%tilt=t%tilt(0)
1563       ENDIF
1564    endif
1565
1566    POTTILT%KIND=KIND10
1567    POTTILT%K(1)=POTTILT%B0+POTTILT%K(1)
1568    POTTILT%nmul=SECTOR_NMUL
1569
1570  END FUNCTION POTTILT
1571
1572
1573  FUNCTION  GBTILT(NAME,L,ANGLE,e1,e2,T,LIST)
1574    implicit none
1575    type (EL_LIST) GBTILT
1576    type (EL_LIST),optional, INTENT(IN)::list
1577    type (TILTING), optional,INTENT(IN):: T
1578    CHARACTER(*), INTENT(IN):: NAME
1579    real(dp) ,optional, INTENT(IN):: L,angle,e1,e2
1580    real(dp) L1,ANG1,t11,t21
1581    if(exact_model) then
1582       w_p=0
1583       w_p%nc=5
1584       w_p%fc='(4(1X,a72,/),(1X,a72))'
1585       w_p%c(1)= " *************************************************** "
1586       w_p%c(2)= " * In PTC, under the exact option                  * "
1587       w_p%c(3)= " * 1.0_dp must distinguish between RBEND and SBEND    * "
1588       w_p%c(4)= " * This is call is thus completely forbidden       * "
1589       w_p%c(5)= " *************************************************** "
1590       ! call !write_e(101)
1591    endif
1592    L1=0.0_dp
1593    ANG1=0.0_dp
1594    t11=0.0_dp
1595    t21=0.0_dp
1596    IF(PRESENT(L)) L1=L
1597    IF(PRESENT(angle)) ANG1=angle
1598    IF(PRESENT(e1)) t11=e1
1599    IF(PRESENT(e2)) t21=e2
1600
1601    if(present(list)) then
1602       GBTILT=list
1603       l1=list%L
1604       ANG1=LIST%B0
1605       T11=LIST%T1
1606       T21=LIST%T2
1607    else
1608       GBTILT=0
1609    endif
1610    GBTILT%B0=ANG1/L1
1611    GBTILT%L=L1
1612    GBTILT%LD=L1
1613    IF(ANG1/=0.0_dp) THEN
1614       GBTILT%LC=2.0_dp*SIN(ANG1/2.0_dp)/GBTILT%B0
1615    ELSE
1616       GBTILT%LC=GBTILT%L
1617    ENDIF
1618    GBTILT%T1=T11 ; GBTILT%T2=T21;
1619    IF(LEN(NAME)>nlp) THEN
1620       w_p=0
1621       w_p%nc=2
1622       w_p%fc='((1X,a72,/),(1x,a72))'
1623       w_p%c(1)=name
1624       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
1625       ! call ! WRITE_I
1626       GBTILT%NAME=NAME(1:16)
1627    ELSE
1628       GBTILT%NAME=NAME
1629    ENDIF
1630    GBTILT%K(1)=GBTILT%B0+GBTILT%K(1)   ! NEW IMPLEMENTATION FOR DIR=-1
1631    GBTILT%nmul=2
1632
1633    GBTILT%KIND=MADKIND2
1634    if(present(t)) then
1635       IF(T%NATURAL) THEN
1636          GBTILT%tilt=t%tilt(1)
1637       ELSE
1638          GBTILT%tilt=t%tilt(0)
1639       ENDIF
1640    endif
1641
1642  END FUNCTION GBTILT
1643
1644
1645  FUNCTION  RECTTILT(NAME,L,ANGLE,E1,E2,T)
1646    implicit none
1647    type (EL_LIST) RECTTILT
1648    type (TILTING),OPTIONAL, INTENT(IN):: T
1649    CHARACTER(*), INTENT(IN):: NAME
1650    real(dp) ,optional, INTENT(IN):: L,angle,E1,E2
1651    real(dp) L1,LM,ANG1,E11,E22
1652
1653    L1=0.0_dp
1654    ANG1=0.0_dp
1655    IF(PRESENT(L)) LM=L
1656    IF(PRESENT(angle)) ANG1=angle
1657    E11=0.0_dp
1658    E22=0.0_dp
1659
1660    IF(PRESENT(E1)) E11=E1
1661    IF(PRESENT(E2)) E22=E2
1662
1663    IF(MADLENGTH.or.ang1==0.0_dp) THEN
1664       L1=LM
1665    ELSE
1666       L1=2.0_dp*LM*SIN(ANG1/2.0_dp)/ANG1
1667    ENDIF
1668
1669    RECTTILT=0
1670    RECTTILT%B0=2.0_dp*SIN(ANG1/2.0_dp)/L1
1671    !    IF(ANG1==zero) THEN
1672    !       RECTTILT%L=L1
1673    !       RECTTILT%LD=L1
1674    !       RECTTILT%LC=L1
1675    !    ELSE
1676    IF(EXACT_MODEL) THEN
1677       if(verbose) then
1678          w_p=0
1679          w_p%nc=2
1680          w_p%fc='((1X,a72,/,1x,a72))'
1681          w_p%c(1)= NAME
1682          w_p%c(2)= " READ AS TRUE RECTANGULAR BEND "
1683          ! call ! WRITE_I
1684       endif
1685       if(ang1==0.0_dp) then
1686          RECTTILT%LD=L1
1687       else
1688          RECTTILT%LD=ANG1/RECTTILT%B0
1689       endif
1690       RECTTILT%L=L1
1691       RECTTILT%LC=L1
1692       RECTTILT%K(1)=RECTTILT%B0+RECTTILT%K(1)
1693       if(LIKEMAD) then
1694          RECTTILT%T1=ANG1/2.0_dp+E11    !one
1695          RECTTILT%T2=ANG1/2.0_dp+E22    !zero
1696       else
1697          RECTTILT%T1=ANG1/2.0_dp+E11    !one
1698          RECTTILT%T2=ANG1/2.0_dp+E22    !zero
1699
1700          !             RECTTILT%T1=one   !wrong???
1701          !             RECTTILT%T2=zero
1702       endif
1703       RECTTILT%nmul=2
1704    ELSE
1705       RECTTILT%LC=L1
1706       IF(ANG1==0.0_dp) THEN
1707          RECTTILT%L=L1
1708          RECTTILT%LD=L1
1709       ELSE
1710          RECTTILT%L=ANG1/RECTTILT%B0
1711          RECTTILT%LD=ANG1/RECTTILT%B0
1712       ENDIF
1713       RECTTILT%T1=ANG1/2.0_dp+E11 ; RECTTILT%T2=ANG1/2.0_dp+E22;
1714       RECTTILT%K(1)=RECTTILT%B0+RECTTILT%K(1) ! NEW IMPLEMENTATION FOR DIR=-1
1715       RECTTILT%nmul=2   ! 0 before
1716    ENDIF
1717    !    ENDIF
1718    IF(LEN(NAME)>nlp) THEN
1719       w_p=0
1720       w_p%nc=2
1721       w_p%fc='((1X,a72,/),(1x,a72))'
1722       w_p%c(1)=name
1723       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
1724       ! call ! WRITE_I
1725       RECTTILT%NAME=NAME(1:16)
1726    ELSE
1727       RECTTILT%NAME=NAME
1728    ENDIF
1729
1730    RECTTILT%KIND=MADKIND2
1731    IF(present(t)) THEN
1732       IF(T%NATURAL) THEN
1733          RECTTILT%tilt=t%tilt(1)
1734       ELSE
1735          RECTTILT%tilt=t%tilt(0)
1736       ENDIF
1737    endif
1738  END FUNCTION RECTTILT
1739
1740
1741  FUNCTION  rectaETILT(NAME,L,ANGLE,E1,E2,T,LIST)
1742    implicit none
1743    type (EL_LIST) rectaETILT
1744    CHARACTER(*), INTENT(IN):: NAME
1745    real(dp) ,optional, INTENT(IN):: L,ANGLE,E1,E2
1746    type (TILTING), optional,INTENT(IN):: T
1747    real(dp) ANGE,SPE
1748    real(dp) LM1,ANG1,ANGI1,e11,e22
1749    integer tempkind
1750    type (EL_LIST),optional, INTENT(IN)::list
1751
1752
1753
1754
1755    CURVED_ELEMENT=.TRUE.
1756
1757    E11=0.0_dp
1758    E22=0.0_dp
1759    tempkind=madkind2
1760    IF(PRESENT(ANGLE)) THEN
1761       if(ANGLE==0.0_dp) then
1762          madkind2=kind2
1763          w_p=0
1764          w_p%nc=2
1765          w_p%fc='((1X,a72,/),(1x,a72))'
1766          w_p%c(1)=name
1767          WRITE(w_p%c(2),'(a12,a16,a23)') ' ANGLE=0 IN ', NAME,' CHANGED TO DRIFT-KICK '
1768          ! call ! WRITE_I
1769
1770       endif
1771    ELSE
1772       madkind2=kind2
1773       w_p=0
1774       w_p%nc=2
1775       w_p%fc='((1X,a72,/),(1x,a72))'
1776       w_p%c(1)=name
1777       WRITE(w_p%c(2),'(a12,a16,a23)') ' ANGLE=0 IN ', NAME,' CHANGED TO DRIFT-KICK '
1778       ! call ! WRITE_I
1779    ENDIF
1780
1781    IF((PRESENT(E1).AND.PRESENT(E2)).OR.(.NOT.PRESENT(E1).AND.(.NOT.PRESENT(E2))) ) THEN !1
1782       if(present(e1).and.present(e2)) THEN
1783          IF(EXACT_MODEL) LIKEMAD=.true.
1784          E11=E1
1785          E22=E2
1786       endif
1787
1788       IF(present(t)) then
1789          rectaETILT=RECTTILT(NAME,L,ANGLE,E11,E22,T)
1790       else
1791          rectaETILT=RECTTILT(NAME,L,ANGLE,E11,E22)
1792       endif
1793       return
1794
1795    ELSE  !  1
1796
1797       LM1=0.0_dp
1798       ANG1=0.0_dp
1799       IF(PRESENT(L)) LM1=L
1800       IF(PRESENT(angle)) ANG1=angle
1801
1802       IF(PRESENT(E1)) ANGI1=e1
1803       IF(PRESENT(E2)) ANGI1=ANG1-e2
1804
1805       rectaETILT=0
1806       ANGE=ANG1-ANGI1
1807       SPE=ANG1/2.0_dp-ANGI1
1808
1809       IF(MADLENGTH) THEN
1810          rectaETILT%L=LM1
1811          rectaETILT%LC=rectaETILT%L/COS(SPE)
1812          rectaETILT%B0=2.0_dp*SIN(ANG1/2.0_dp)/rectaETILT%LC
1813          if(ang1/=0.0_dp) then
1814             rectaETILT%LD=ANG1/rectaETILT%B0
1815          else
1816             rectaETILT%LD=rectaETILT%LC
1817          endif
1818       ELSE
1819          rectaETILT%LD=LM1
1820          rectaETILT%B0=ANG1/rectaETILT%LD
1821          if(ang1/=0.0_dp) then
1822             rectaETILT%LC=2.0_dp*SIN(ANG1/2.0_dp)/rectaETILT%B0
1823          else
1824             rectaETILT%LC=rectaETILT%LD
1825          endif
1826          rectaETILT%L=rectaETILT%LC*COS(SPE)
1827       ENDIF
1828
1829
1830       IF(EXACT_MODEL) THEN
1831          if(verbose) then
1832             w_p=0
1833             w_p%nc=2
1834             w_p%fc='((1X,a72,/,1x,a72))'
1835             w_p%c(1)= NAME
1836             w_p%c(2)= " READ AS TRUE RECTANGULAR BEND "
1837             ! call ! WRITE_I
1838          endif
1839          rectaETILT%K(1)=rectaETILT%B0+rectaETILT%K(1) ! NEW IMPLEMENTATION FOR DIR=-1
1840          rectaETILT%nmul=2
1841          !         rectaETILT%T1=ANGI1/(ANG1/two)
1842          rectaETILT%T1=ANGI1
1843          rectaETILT%T2=ange
1844
1845          !         rectaETILT%T2=rectaETILT%LC*SIN(SPE)
1846       ELSE
1847          rectaETILT%K(1)=rectaETILT%B0+rectaETILT%K(1)
1848          rectaETILT%L=rectaETILT%LD
1849          rectaETILT%T1=ANGI1 ; rectaETILT%T2=ANGE;
1850          rectaETILT%nmul=2   ! 0 before
1851       ENDIF
1852
1853       IF(LEN(NAME)>nlp) THEN
1854          w_p=0
1855          w_p%nc=2
1856          w_p%fc='((1X,a72,/),(1x,a72))'
1857          w_p%c(1)=name
1858          WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
1859          ! call ! WRITE_I
1860          rectaETILT%NAME=NAME(1:16)
1861       ELSE
1862          rectaETILT%NAME=NAME
1863       ENDIF
1864
1865       rectaETILT%KIND=MADKIND2
1866       if(present(t)) then
1867          IF(T%NATURAL) THEN
1868             rectaETILT%tilt=t%tilt(1)
1869          ELSE
1870             rectaETILT%tilt=t%tilt(0)
1871          ENDIF
1872       endif
1873
1874    ENDIF !1
1875    madkind2=TEMPKIND
1876
1877    if(present(list)) then
1878       rectaETILT%k=rectaETILT%k+list%k
1879       rectaETILT%ks=rectaETILT%ks+list%ks
1880       rectaETILT%tilt=list%tilt
1881       rectaETILT%FINT=list%FINT
1882       rectaETILT%hgap=list%hgap
1883       rectaETILT%h1=list%h1
1884       rectaETILT%h2=list%h2
1885       rectaETILT%nmul=list%nmul
1886       rectaETILT%nst=list%nst
1887       rectaETILT%APERTURE_ON=list%APERTURE_ON
1888       rectaETILT%APERTURE_KIND=list%APERTURE_KIND
1889       rectaETILT%APERTURE_R=list%APERTURE_R
1890       rectaETILT%APERTURE_X=list%APERTURE_X
1891       rectaETILT%APERTURE_Y=list%APERTURE_Y
1892       rectaETILT%KILL_ENT_FRINGE=list%KILL_ENT_FRINGE
1893       rectaETILT%KILL_EXI_FRINGE=list%KILL_EXI_FRINGE
1894       rectaETILT%BEND_FRINGE=list%BEND_FRINGE
1895       rectaETILT%PERMFRINGE=list%PERMFRINGE
1896    endif
1897
1898
1899  END FUNCTION rectaETILT
1900
1901
1902
1903  FUNCTION  drft(NAME,L,LIST)
1904    implicit none
1905    type (EL_LIST) drft
1906    CHARACTER(*), INTENT(IN):: NAME
1907    TYPE(EL_LIST) ,optional, INTENT(IN):: LIST
1908    real(dp) ,optional, INTENT(IN):: L
1909    real(dp)  L1
1910    L1=0.0_dp
1911    IF(PRESENT(L)) L1=L
1912
1913    if(present(list)) then
1914       drft=list
1915       l1=list%L
1916    else
1917       drft=0
1918    endif
1919    DRFT%NST=1
1920    DRFT%METHOD=2
1921
1922    drft%L=L1
1923    drft%LD=L1
1924    drft%LC=L1
1925    IF(LEN(NAME)>nlp) THEN
1926       w_p=0
1927       w_p%nc=2
1928       w_p%fc='((1X,a72,/),(1x,a72))'
1929       w_p%c(1)=name
1930       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
1931       ! call ! WRITE_I
1932       drft%NAME=NAME(1:16)
1933    ELSE
1934       drft%NAME=NAME
1935    ENDIF
1936    drft%KIND=KIND1
1937
1938  END FUNCTION drft
1939
1940  FUNCTION  RCOLIT(NAME,L,T,LIST)
1941    implicit none
1942    integer ipause, mypause
1943    type (EL_LIST) RCOLIT
1944    type (EL_LIST),OPTIONAL,INTENT(IN):: LIST
1945    type (TILTING),OPTIONAL,INTENT(IN):: T
1946    CHARACTER(*), INTENT(IN):: NAME
1947    real(dp) ,optional, INTENT(IN):: L
1948    real(dp)  L1
1949    L1=0.0_dp
1950    set_ap=my_true
1951    IF(PRESENT(L)) L1=L
1952
1953    if(present(list)) then
1954       RCOLIT=list
1955       l1=list%L
1956       WRITE(6,*) " WHAT ABOUT WRITING THE CODE USING X AND Y"
1957       ipause=mypause(0)
1958    else
1959       RCOLIT=0
1960    endif
1961
1962    RCOLIT%L=L1
1963    RCOLIT%LD=L1
1964    RCOLIT%LC=L1
1965    IF(LEN(NAME)>nlp) THEN
1966       w_p=0
1967       w_p%nc=2
1968       w_p%fc='((1X,a72,/),(1x,a72))'
1969       w_p%c(1)=name
1970       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
1971       ! call ! WRITE_I
1972       RCOLIT%NAME=NAME(1:16)
1973    ELSE
1974       RCOLIT%NAME=NAME
1975    ENDIF
1976    RCOLIT%KIND=KIND18
1977    if(present(t)) then
1978       RCOLIT%tilt=t%tilt(0)
1979    endif
1980    RCOLIT%NST=1
1981    RCOLIT%METHOD=2
1982
1983  END FUNCTION RCOLIT
1984
1985  FUNCTION  ECOLIT(NAME,L,T,LIST)
1986    implicit none
1987    integer ipause, mypause
1988    type (EL_LIST) ECOLIT
1989    type (EL_LIST),OPTIONAL,INTENT(IN):: LIST
1990    type (TILTING),OPTIONAL,INTENT(IN):: T
1991    CHARACTER(*), INTENT(IN):: NAME
1992    real(dp) ,optional, INTENT(IN):: L
1993    real(dp)  L1
1994    L1=0.0_dp
1995    set_ap=my_true
1996    IF(PRESENT(L)) L1=L
1997
1998    if(present(list)) then
1999       ECOLIT=list
2000       l1=list%L
2001       WRITE(6,*) " WHAT ABOUT WRITING THE CODE USING X AND Y"
2002       ipause=mypause(0)
2003
2004    else
2005       ECOLIT=0
2006    endif
2007
2008    ECOLIT%L=L1
2009    ECOLIT%LD=L1
2010    ECOLIT%LC=L1
2011    IF(LEN(NAME)>nlp) THEN
2012       w_p=0
2013       w_p%nc=2
2014       w_p%fc='((1X,a72,/),(1x,a72))'
2015       w_p%c(1)=name
2016       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
2017       ! call ! WRITE_I
2018       ECOLIT%NAME=NAME(1:16)
2019    ELSE
2020       ECOLIT%NAME=NAME
2021    ENDIF
2022    ECOLIT%KIND=KIND19
2023    if(present(t)) then
2024       ECOLIT%tilt=t%tilt(0)
2025    endif
2026
2027    ECOLIT%NST=1
2028    ECOLIT%METHOD=2
2029
2030  END FUNCTION ECOLIT
2031
2032  FUNCTION  MONIT(NAME,L,T,LIST)
2033    implicit none
2034    type (EL_LIST) MONIT
2035    type (EL_LIST),OPTIONAL,INTENT(IN):: LIST
2036    type (TILTING),OPTIONAL,INTENT(IN):: T
2037    CHARACTER(*), INTENT(IN):: NAME
2038    real(dp) ,optional, INTENT(IN):: L
2039    real(dp)  L1
2040    L1=0.0_dp
2041    IF(PRESENT(L)) L1=L
2042
2043    if(present(list)) then
2044       MONIT=list
2045       l1=list%L
2046    else
2047       MONIT=0
2048    endif
2049
2050    MONIT%NST=1
2051    MONIT%METHOD=2
2052
2053    MONIT%L=L1
2054    MONIT%LD=L1
2055    MONIT%LC=L1
2056    IF(LEN(NAME)>nlp) THEN
2057       w_p=0
2058       w_p%nc=2
2059       w_p%fc='((1X,a72,/),(1x,a72))'
2060       w_p%c(1)=name
2061       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
2062       ! call ! WRITE_I
2063       MONIT%NAME=NAME(1:16)
2064    ELSE
2065       MONIT%NAME=NAME
2066    ENDIF
2067    MONIT%KIND=KIND11
2068    if(present(t)) then
2069       MONIT%tilt=t%tilt(0)
2070    endif
2071
2072  END FUNCTION MONIT
2073
2074  FUNCTION  hMONIT(NAME,L)
2075    implicit none
2076    type (EL_LIST) hMONIT
2077    CHARACTER(*), INTENT(IN):: NAME
2078    real(dp) ,optional, INTENT(IN):: L
2079    real(dp)  L1
2080    L1=0.0_dp
2081    IF(PRESENT(L)) L1=L
2082
2083
2084    hMONIT=0
2085    hMONIT%L=L1
2086    hMONIT%LD=L1
2087    hMONIT%LC=L1
2088    IF(LEN(NAME)>nlp) THEN
2089       w_p=0
2090       w_p%nc=2
2091       w_p%fc='((1X,a72,/),(1x,a72))'
2092       w_p%c(1)=name
2093       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
2094       ! call ! WRITE_I
2095       hMONIT%NAME=NAME(1:16)
2096    ELSE
2097       hMONIT%NAME=NAME
2098    ENDIF
2099    hMONIT%KIND=KIND12
2100    hMONIT%NST=1
2101    hMONIT%METHOD=2
2102
2103  END FUNCTION hMONIT
2104
2105  FUNCTION  VMONIT(NAME,L)
2106    implicit none
2107    type (EL_LIST) VMONIT
2108    CHARACTER(*), INTENT(IN):: NAME
2109    real(dp) ,optional, INTENT(IN):: L
2110    real(dp)  L1
2111    L1=0.0_dp
2112    IF(PRESENT(L)) L1=L
2113
2114
2115    VMONIT=0
2116    VMONIT%L=L1
2117    VMONIT%LD=L1
2118    VMONIT%LC=L1
2119    IF(LEN(NAME)>nlp) THEN
2120       w_p=0
2121       w_p%nc=2
2122       w_p%fc='((1X,a72,/),(1x,a72))'
2123       w_p%c(1)=name
2124       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
2125       ! call ! WRITE_I
2126       VMONIT%NAME=NAME(1:16)
2127    ELSE
2128       VMONIT%NAME=NAME
2129    ENDIF
2130    VMONIT%KIND=KIND13
2131    VMONIT%NST=1
2132    VMONIT%METHOD=2
2133
2134  END FUNCTION VMONIT
2135
2136  FUNCTION  INSTRUMEN(NAME,L)
2137    implicit none
2138    type (EL_LIST) INSTRUMEN
2139    CHARACTER(*), INTENT(IN):: NAME
2140    real(dp) ,optional, INTENT(IN):: L
2141    real(dp)  L1
2142    L1=0.0_dp
2143    IF(PRESENT(L)) L1=L
2144
2145
2146    INSTRUMEN=0
2147    INSTRUMEN%L=L1
2148    INSTRUMEN%LD=L1
2149    INSTRUMEN%LC=L1
2150    IF(LEN(NAME)>nlp) THEN
2151       w_p=0
2152       w_p%nc=2
2153       w_p%fc='((1X,a72,/),(1x,a72))'
2154       w_p%c(1)=name
2155       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
2156       ! call ! WRITE_I
2157       INSTRUMEN%NAME=NAME(1:16)
2158    ELSE
2159       INSTRUMEN%NAME=NAME
2160    ENDIF
2161    INSTRUMEN%KIND=KIND14
2162    INSTRUMEN%NST=1
2163    INSTRUMEN%METHOD=2
2164
2165  END FUNCTION INSTRUMEN
2166
2167  FUNCTION  mark(NAME,LIST)
2168    implicit none
2169    type (EL_LIST) mark
2170    CHARACTER(*), INTENT(IN):: NAME
2171    type (EL_LIST),OPTIONAL,INTENT(IN):: LIST
2172
2173
2174    if(present(list)) then
2175       mark=list
2176    else
2177       mark=0
2178    endif
2179
2180    IF(LEN(NAME)>nlp) THEN
2181       w_p=0
2182       w_p%nc=2
2183       w_p%fc='((1X,a72,/),(1x,a72))'
2184       w_p%c(1)=name
2185       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
2186       ! call ! WRITE_I
2187       mark%NAME=NAME(1:16)
2188    ELSE
2189       mark%NAME=NAME
2190    ENDIF
2191
2192    mark%KIND=KIND0
2193
2194  END FUNCTION mark
2195
2196  FUNCTION  CHANGEREF(NAME,ANG,T,PATCHG)
2197    implicit none
2198    type (EL_LIST) CHANGEREF
2199    CHARACTER(*), INTENT(IN):: NAME
2200    REAL(DP) ANG(3),T(3)
2201    INTEGER PATCHG
2202
2203    CHANGEREF=0
2204    IF(LEN(NAME)>nlp) THEN
2205       w_p=0
2206       w_p%nc=2
2207       w_p%fc='((1X,a72,/),(1x,a72))'
2208       w_p%c(1)=name
2209       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
2210       ! call ! WRITE_I
2211       CHANGEREF%NAME=NAME(1:16)
2212    ELSE
2213       CHANGEREF%NAME=NAME
2214    ENDIF
2215
2216    CHANGEREF%KIND=KIND0
2217    CHANGEREF%ANG=ANG
2218    CHANGEREF%T=T
2219    CHANGEREF%PATCHG=PATCHG
2220
2221  END FUNCTION CHANGEREF
2222
2223  !  subroutine  guirder(f,cell)
2224  !    implicit none
2225  !    type (fibre) f
2226  !    type (layout),target :: cell!
2227
2228  !    f%MAG%G23=>CELL
2229  !    f%MAGP%G23=>CELL
2230  !    f%MAG%KIND=KIND23
2231  !    f%MAGP%KIND=KIND23
2232  !    f%MAG%p%nst=1
2233  !    f%MAGP%p%nst=1
2234  !    f%chart%f%ent=1
2235  !    f%chart=0
2236  !   CALL SURVEY_no_patch(f)
2237
2238
2239  !  END  subroutine guirder
2240
2241  FUNCTION  RFCAVITYL(NAME,L,VOLT,LAG,HARMON,REV_FREQ,DELTAE,LIST)
2242    implicit none
2243    type (EL_LIST) RFCAVITYL
2244    TYPE(EL_LIST),optional, INTENT(IN):: LIST
2245    CHARACTER(*), INTENT(IN):: NAME
2246    real(dp) ,optional, INTENT(IN):: L,VOLT,LAG,REV_FREQ,DELTAE
2247    INTEGER,optional, INTENT(IN):: HARMON
2248    real(dp)  L1,VOLT1,LAG1,FREQ01
2249    INTEGER  HARMON1
2250    L1=0.0_dp
2251    VOLT1=0.0_dp
2252    LAG1=0.0_dp
2253    FREQ01=0.0_dp
2254    HARMON1=1
2255    IF(PRESENT(L)) L1=L
2256    IF(PRESENT(VOLT)) THEN
2257       VOLT1=VOLT
2258       IF(PRESENT(DELTAE)) THEN
2259          w_p=0
2260          w_p%nc=1
2261          w_p%fc='((1X,a72))'
2262          w_p%c(1)= "Use either volt or deltae"
2263          ! call !write_e(100)
2264       ENDIF
2265    elseIF(PRESENT(DELTAE)) THEN
2266       volt1=DELTAE*p0c
2267    endif
2268    IF(PRESENT(LAG)) LAG1=LAG
2269    IF(PRESENT(HARMON)) HARMON1=HARMON
2270    IF(PRESENT(REV_FREQ)) FREQ01=REV_FREQ
2271
2272    if(present(list)) then
2273       RFCAVITYL=list
2274       l1=list%L
2275       VOLT1=LIST%VOLT
2276       LAG1=LIST%LAG
2277       FREQ01=LIST%FREQ0
2278       HARMON1=LIST%HARMON
2279       if(LIST%delta_e/=0.0_dp) then
2280          if(volt1==0.0_dp) then
2281             volt1=LIST%DELTA_E*p0c    ! DELTA_E used for two purposes, but OK
2282          else
2283             w_p=0
2284             w_p%nc=1
2285             w_p%fc='((1X,a72))'
2286             w_p%c(1)= "Use either volt or deltae"
2287             ! call !write_e(101)
2288          endif
2289       endif
2290    else
2291       RFCAVITYL=0
2292    endif
2293
2294    RFCAVITYL%L=L1
2295    RFCAVITYL%LD=L1
2296    RFCAVITYL%LC=L1
2297    RFCAVITYL%KIND=KIND4
2298    RFCAVITYL%nmul=1
2299    IF(LEN(NAME)>nlp) THEN
2300       w_p=0
2301       w_p%nc=2
2302       w_p%fc='((1X,a72,/),(1x,a72))'
2303       w_p%c(1)=name
2304       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
2305       ! call ! WRITE_I
2306       RFCAVITYL%NAME=NAME(1:16)
2307    ELSE
2308       RFCAVITYL%NAME=NAME
2309    ENDIF
2310    RFCAVITYL%VOLT=VOLT1
2311    RFCAVITYL%LAG=LAG1
2312    RFCAVITYL%HARMON=HARMON1
2313    RFCAVITYL%FREQ0=FREQ01
2314    !   RFCAVITYL%P0C=P0C
2315    RFCAVITYL%DELTA_E=0.0_dp
2316
2317  END FUNCTION RFCAVITYL
2318
2319  FUNCTION  TWCAVITYL(NAME,L,VOLT,LAG,HARMON,REV_FREQ,DELTAE,LIST)
2320    implicit none
2321    type (EL_LIST) TWCAVITYL
2322    TYPE(EL_LIST),optional, INTENT(IN):: LIST
2323    CHARACTER(*), INTENT(IN):: NAME
2324    real(dp) ,optional, INTENT(IN):: L,VOLT,LAG,REV_FREQ,DELTAE
2325    INTEGER,optional, INTENT(IN):: HARMON
2326    real(dp)  L1,VOLT1,LAG1,FREQ01
2327    INTEGER  HARMON1
2328    L1=0.0_dp
2329    VOLT1=0.0_dp
2330    LAG1=0.0_dp
2331    FREQ01=0.0_dp
2332    HARMON1=1
2333    IF(PRESENT(L)) L1=L
2334    IF(PRESENT(VOLT)) THEN
2335       VOLT1=VOLT
2336       IF(PRESENT(DELTAE)) THEN
2337          w_p=0
2338          w_p%nc=1
2339          w_p%fc='((1X,a72))'
2340          w_p%c(1)= "Use either volt or deltae"
2341          ! call !write_e(100)
2342       ENDIF
2343    elseIF(PRESENT(DELTAE)) THEN
2344       volt1=DELTAE*p0c
2345    endif
2346    IF(PRESENT(LAG)) LAG1=LAG
2347    IF(PRESENT(HARMON)) HARMON1=HARMON
2348    IF(PRESENT(REV_FREQ)) FREQ01=REV_FREQ
2349
2350    if(present(list)) then
2351       TWCAVITYL=list
2352       l1=list%L
2353       VOLT1=LIST%VOLT
2354       LAG1=LIST%LAG
2355       FREQ01=LIST%FREQ0
2356       HARMON1=LIST%HARMON
2357       if(LIST%delta_e/=0.0_dp) then
2358          if(volt1==0.0_dp) then
2359             volt1=LIST%DELTA_E*p0c    ! DELTA_E used for two purposes, but OK
2360          else
2361             w_p=0
2362             w_p%nc=1
2363             w_p%fc='((1X,a72))'
2364             w_p%c(1)= "Use either volt or deltae"
2365             ! call !write_e(101)
2366          endif
2367       endif
2368    else
2369       TWCAVITYL=0
2370    endif
2371    IF(L1==0.0_dp) THEN
2372       WRITE(6,*) " TWCAVITY MUST HAVE A LENGTH "
2373       STOP 555
2374    ENDIF
2375
2376    TWCAVITYL%L=L1
2377    TWCAVITYL%LD=L1
2378    TWCAVITYL%LC=L1
2379    TWCAVITYL%KIND=KIND21
2380    IF(LEN(NAME)>nlp) THEN
2381       w_p=0
2382       w_p%nc=2
2383       w_p%fc='((1X,a72,/),(1x,a72))'
2384       w_p%c(1)=name
2385       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
2386       ! call ! WRITE_I
2387       TWCAVITYL%NAME=NAME(1:16)
2388    ELSE
2389       TWCAVITYL%NAME=NAME
2390    ENDIF
2391    TWCAVITYL%VOLT=VOLT1
2392    TWCAVITYL%LAG=LAG1
2393    TWCAVITYL%HARMON=HARMON1
2394    TWCAVITYL%FREQ0=FREQ01
2395    !   RFCAVITYL%P0C=P0C
2396    TWCAVITYL%DELTA_E=0.0_dp
2397
2398  END FUNCTION TWCAVITYL
2399
2400
2401
2402  FUNCTION  ELSESTILT(NAME,L,E,T,LIST)
2403    implicit none
2404    type (TILTING),optional, INTENT(IN):: T
2405    type (EL_LIST),optional, INTENT(IN):: LIST
2406    type (EL_LIST) ELSESTILT
2407    CHARACTER(*), INTENT(IN):: NAME
2408    real(dp) ,optional, INTENT(IN):: L,E
2409    real(dp) L1,K11
2410
2411    L1=0.0_dp
2412    K11=0.0_dp
2413    IF(PRESENT(L)) L1=L
2414    IF(PRESENT(E)) K11=E
2415
2416    if(present(list)) then
2417       ELSESTILT=list
2418       l1=list%L
2419       K11=LIST%VOLT
2420    else
2421       ELSESTILT=0
2422    endif
2423    ELSESTILT%L=L1
2424    ELSESTILT%LD=L1
2425    ELSESTILT%LC=L1
2426    ELSESTILT%VOLT=K11
2427    ELSESTILT%KIND=KIND15
2428    ELSESTILT%NST=1
2429    ELSESTILT%METHOD=2
2430
2431    IF(PRESENT(t)) then
2432       IF(T%NATURAL) THEN
2433          ELSESTILT%tilt=t%tilt(1)
2434       ELSE
2435          ELSESTILT%tilt=t%tilt(0)
2436       ENDIF
2437    ENDIF
2438
2439    IF(LEN(NAME)>nlp) THEN
2440       w_p=0
2441       w_p%nc=2
2442       w_p%fc='((1X,a72,/),(1x,a72))'
2443       w_p%c(1)=name
2444       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
2445       ! call ! WRITE_I
2446       ELSESTILT%NAME=NAME(1:16)
2447    ELSE
2448       ELSESTILT%NAME=NAME
2449    ENDIF
2450
2451  END FUNCTION ELSESTILT
2452
2453
2454
2455
2456
2457  FUNCTION  WIGGLERL(NAME,L,T,list)
2458    implicit none
2459    type (EL_LIST) WIGGLERL
2460    type (TILTING),optional, INTENT(IN):: T
2461    type (EL_LIST),optional, INTENT(IN):: LIST
2462    CHARACTER(*), INTENT(IN):: NAME
2463    real(dp) ,optional, INTENT(IN):: L
2464
2465    if(present(list)) then
2466       WIGGLERL=list
2467       WIGGLERL%L=list%L
2468    elseif(present(L)) then
2469       WIGGLERL=0
2470       WIGGLERL%L=L
2471    else
2472       write(6,*) " Error neither L nor list is present in WIGGLERL"
2473       stop 900
2474    endif
2475       WIGGLERL%LD=WIGGLERL%L
2476       WIGGLERL%LC=WIGGLERL%L
2477    WIGGLERL%KIND=KINDWIGGLER
2478    IF(LEN(NAME)>nlp) THEN
2479       w_p=0
2480       w_p%nc=2
2481       w_p%fc='((1X,a72,/),(1x,a72))'
2482       w_p%c(1)=name
2483       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
2484       ! call ! WRITE_I
2485       WIGGLERL%NAME=NAME(1:16)
2486    ELSE
2487       WIGGLERL%NAME=NAME
2488    ENDIF
2489    IF(PRESENT(t)) then
2490       IF(T%NATURAL) THEN
2491          WIGGLERL%tilt=t%tilt(1)
2492       ELSE
2493          WIGGLERL%tilt=t%tilt(0)
2494       ENDIF
2495    ENDIF
2496  END FUNCTION WIGGLERL
2497
2498       subroutine nullify_for_madx(s22)
2499       implicit none
2500       type (fibre),target,INTENT(inOUT)::s22   
2501
2502       nullify(s22%mag); nullify(s22%magp);
2503       allocate(s22%mag);allocate(s22%magp);
2504       nullify(s22%CHART);nullify(s22%PATCH);
2505       allocate(s22%CHART);allocate(s22%PATCH);
2506       nullify(s22%dir);allocate(s22%dir);
2507
2508       NULLIFY(S22%I)
2509       if(use_info) then
2510          allocate(s22%i);
2511          call alloc(s22%i)
2512       endif
2513
2514       nullify(S22%BETA0);allocate(s22%BETA0);
2515       nullify(S22%GAMMA0I);allocate(s22%GAMMA0I);
2516       nullify(S22%GAMBET);allocate(s22%GAMBET);
2517       !       nullify(S22%P0C);allocate(s22%P0C);
2518       nullify(S22%MASS);allocate(s22%MASS);
2519       nullify(S22%ag);allocate(s22%ag);
2520       nullify(S22%CHARGE);allocate(s22%CHARGE);
2521       !     111 CONTINUE  ! SAGAN CHECK MEMORY
2522  end subroutine nullify_for_madx
2523
2524  SUBROUTINE  EL_Q(s22,S1)
2525    !changed
2526    implicit none
2527    type (fibre),target,INTENT(inOUT)::s22
2528    type (EL_LIST),INTENT(IN)::S1
2529    INTEGER I,flip
2530    logical(lp) DONE,THICKKICKTEMP
2531    type(element),pointer :: s2
2532    type(elementp), pointer :: s2p
2533    type(fibre), pointer::el
2534    !    integer ntot,ntot_rad,ntot_REV,ntot_rad_REV
2535
2536    nullify(el);
2537    THICKKICKTEMP=.FALSE.
2538    nullify(s2); nullify(s2p);
2539    IF(MADX_MAGNET_ONLY) THEN
2540       S22%MAG=-1;     !  FIBRE AND  MUST ALREADY EXIST
2541       S22%MAGP=-1;    !  POINTER MUST STAY ALLOCATED OTHERWISE ALL HELL BREAKS LOOSE
2542    ELSE    ! done in a madx generated layout
2543       !!!!!    GOTO 111    ! SAGAN CHECK MEMORY
2544       call nullify_for_madx(s22)
2545   !    nullify(s22%mag); nullify(s22%magp);
2546   !    allocate(s22%mag);allocate(s22%magp);
2547   !    nullify(s22%CHART);nullify(s22%PATCH);
2548   !    allocate(s22%CHART);allocate(s22%PATCH);
2549   !    nullify(s22%dir);allocate(s22%dir);
2550
2551    !   NULLIFY(S22%I)
2552    !   if(use_info) then
2553    !      allocate(s22%i);
2554    !      call alloc(s22%i)
2555    !   endif
2556
2557    !   nullify(S22%BETA0);allocate(s22%BETA0);
2558    !   nullify(S22%GAMMA0I);allocate(s22%GAMMA0I);
2559    !   nullify(S22%GAMBET);allocate(s22%GAMBET);
2560       !       nullify(S22%P0C);allocate(s22%P0C);
2561    !   nullify(S22%MASS);allocate(s22%MASS);
2562    !   nullify(S22%ag);allocate(s22%ag);
2563    !   nullify(S22%CHARGE);allocate(s22%CHARGE);
2564       !!!!!     111 CONTINUE  ! SAGAN CHECK MEMORY
2565    ENDIF
2566
2567    IF(.NOT.MADX) then  ! not done in a layout generated by madx
2568       nullify(s22%next);
2569       nullify(s22%previous);
2570    endif
2571    ! CALL ALLOCATE_FIBRE(S22)
2572    ! CALL ALLOCATE_DATA_FIBRE(S22)  !ONLY ALLOWED ON POINTERS
2573    IF(.NOT.MADX_MAGNET_ONLY) THEN   ! true in madx layout
2574       s22%dir=FIBRE_DIR    ! ALL THAT SHIT ALREADY EXISTS
2575       !     s22%P0C=P0C
2576       !     s22%BETA0=BETA0
2577       !    GOTO 112    ! SAGAN CHECK MEMORY
2578       s22%CHART=0
2579       s22%PATCH=0
2580       !     112 CONTINUE  ! SAGAN CHECK MEMORY
2581    ENDIF
2582    ! New stuff
2583    !Powering the CHART frame in MAG only
2584    !
2585    !
2586    flip=1
2587    if(FIBRE_flip) flip=FIBRE_dir
2588    s2=>s22%mag;
2589    s2p=>s22%magp;
2590
2591    DONE=.FALSE.
2592
2593    DO I=NMAX,1,-1
2594       IF(S1%K(I)/=0.0_dp.or.S1%KS(I)/=0.0_dp) THEN
2595          if(I>=S1%NMUL) THEN
2596             S2 = I
2597             DONE=.TRUE.
2598          ENDIF
2599          GOTO 100
2600       ENDIF
2601    ENDDO
2602100 CONTINUE
2603
2604    IF(.NOT.DONE) S2 = S1%NMUL
2605
2606    S2%P%B0=S1%B0
2607    !    if(S2%P%B0/=zero) S2%P%bend_fringe=.true.
2608    IF(CURVED_ELEMENT) THEN
2609       S2%P%bend_fringe=.true.
2610       CURVED_ELEMENT=.FALSE.
2611    ENDIF
2612    S2%KIND=S1%KIND; S2%P%METHOD=S1%METHOD ;        S2%P%NST=S1%NST ;
2613    S2%NAME=S1%NAME        ;S2%VORNAME=S1%VORNAME ;
2614    S2%L =S1%L ;S2%P%LD=S1%LD;S2%P%LC=S1%LC;
2615
2616!    S2%PERMFRINGE=S1%PERMFRINGE
2617    S2%p%PERMFRINGE=S1%PERMFRINGE
2618    S2%P%KILL_EXI_FRINGE=S1%KILL_EXI_FRINGE
2619    S2%P%KILL_ENT_FRINGE=S1%KILL_ENT_FRINGE
2620    !    S2%P%BEND_FRINGE=S1%BEND_FRINGE    ! SET ON THE BASIS OF B0
2621
2622    DO I=1,S2%P%NMUL
2623       S2%BN(I)=flip*S1%K(I)/FAC(I) ; S2%AN(I)=flip*S1%KS(I)/FAC(I);
2624    ENDDO
2625    S2%p%exact=EXACT_MODEL
2626    !    IF(S2%p%EXACT) THEN
2627    S2%P%EDGE(1)=(S1%T1)
2628    S2%P%EDGE(2)=(S1%T2)
2629    !     ENDIF
2630    ! S2%B0=S1%B0
2631    s2%P%tiltd=S1%tilt
2632    if(s1%kind==kind4) then
2633       ALLOCATE(S2%VOLT,S2%FREQ,S2%PHAS,S2%DELTA_E,S2%THIN,S2%lag)
2634
2635       S2%lag=S1%lag
2636       S2%volt=flip*S1%volt
2637       S2%freq=S1%freq0*S1%harmon
2638       S2%phas=-S1%lag
2639       !       S2%lag=zero
2640       !       S2%volt=flip*S1%volt
2641       !       S2%freq=S1%freq0*S1%harmon
2642       !       S2%phas=-S1%lag
2643       !      S2%p0c=S1%p0c
2644       !frs
2645       S2%DELTA_E=S1%DELTA_E
2646       S2%THIN=.FALSE.
2647       IF(S2%L==0.0_dp) then
2648          S2%THIN=.TRUE.
2649
2650       else
2651          S2%volt=S2%volt/S2%L
2652       endif
2653    endif
2654
2655    if(s1%kind==kind21) then
2656       ALLOCATE(S2%VOLT,S2%FREQ,S2%PHAS,S2%LAG,S2%DELTA_E,S2%THIN)
2657       S2%lag=0.0_dp
2658       S2%volt=flip*S1%volt
2659       S2%freq=S1%freq0*S1%harmon
2660       S2%phas=-S1%lag
2661       !      S2%p0c=S1%p0c
2662       !frs
2663       S2%DELTA_E=S1%DELTA_E
2664       S2%THIN=.FALSE.
2665       !skowron 14.03.06
2666       S2%lag=s1%lag
2667       IF(S2%L==0.0_dp) then
2668          S2%THIN=.TRUE.
2669          write(6,*) " Can that be true ? Travelling wave cavity with length zero?"
2670          stop 666
2671       else
2672          S2%volt=S2%volt/S2%L
2673       endif
2674
2675    endif
2676
2677    if(s1%kind==kind22) then
2678       ALLOCATE(S2%FREQ,S2%PHAS)
2679       S2%freq=S1%freq0
2680       S2%phas=s1%lag
2681    endif
2682
2683    if(s1%kind==kind15) then
2684       ALLOCATE(S2%VOLT)
2685       S2%volt=S1%volt
2686       ALLOCATE(S2%phas)
2687       S2%phas=S1%lag
2688    endif
2689
2690    if(s1%kind==kind3.or.s1%kind==kind5) then   !.or.s1%kind==kind17) then
2691       ALLOCATE(S2%B_SOL);
2692       S2%B_SOL=S1%BSOL
2693    endif
2694
2695
2696    CALL CONTEXT( S2%NAME )
2697    !    S2%P%BETA0=BETA0
2698    !    S2%P%gamma0I=gamma0I
2699    !    S2%P%gambet=gambet
2700    S2%P%p0c=p0c
2701
2702
2703    if(S2%KIND==KIND2.AND.EXACT_MODEL) then
2704       S2%KIND=KIND16
2705    endif
2706
2707    if((S2%KIND==KIND6.or.S2%KIND==KIND7.or.S2%KIND==KIND17).AND.EXACT_MODEL.AND.S2%P%B0/=0.0_dp) then
2708       if(S2%KIND==KIND17) then
2709          write(6,*) " kind17 not permitted here in madlike "
2710          stop 17
2711       endif
2712       S2%KIND=KIND16
2713       THICKKICKTEMP=.TRUE.
2714    endif
2715
2716    !    ntot=0; ntot_rad=0; ntot_REV=0 ; ntot_rad_REV=0;
2717    !    if(S2%KIND==KIND22) then
2718    !       IF(ASSOCIATED(mad_tree%CC)) ntot=mad_tree%n
2719    !       IF(ASSOCIATED(mad_tree_rad%CC)) ntot_rad=mad_tree_rad%n
2720    !       IF(ASSOCIATED(mad_tree_REV%CC)) ntot_REV=mad_tree_REV%n
2721    !       IF(ASSOCIATED(mad_tree_RAD_REV%CC)) ntot_rad_REV=mad_tree_RAD_REV%n
2722    !    endif
2723
2724    !    CALL SETFAMILY(S2,ntot,ntot_rad,ntot_REV,ntot_rad_REV,6)
2725    if(s2%kind/=kindpa) then
2726       CALL SETFAMILY(S2)  !,NTOT=ntot,ntot_rad=ntot_rad,NTOT_REV=ntot_REV,ntot_rad_REV=ntot_rad_REV,ND2=6)
2727    else
2728       CALL SETFAMILY(S2,t=T_E)  !,T_ax=T_ax,T_ay=T_ay)
2729       S2%P%METHOD=4
2730       deallocate(T_E,t_ax,t_ay)
2731    endif
2732
2733    IF(S2%KIND==KIND4) THEN
2734       S2%C4%N_BESSEL=S1%N_BESSEL
2735    ENDIF
2736    IF(S2%KIND==KIND21) THEN
2737       s2%CAV21%DPHAS=s1%DPHAS
2738       s2%CAV21%dvds=s1%dvds
2739       s2%CAV21%PSI=s1%PSI
2740    ENDIF
2741
2742    if(LIKEMAD) then
2743       if(S2%KIND/=KIND16) then
2744          w_p=0
2745          w_p%nc=1
2746          w_p%fc='((1X,a72))'
2747          w_p%c(1)= " Likemad is true and element is not STREX "
2748          ! call !write_e(kind16)
2749       endif
2750       s2%k16%likemad=LIKEMAD
2751       S2%KIND=KIND20
2752       LIKEMAD=.false.
2753    endif
2754
2755
2756    if(S2%KIND==KIND10) then
2757       S2%TP10%DRIFTKICK=DRIFT_KICK
2758       IF(madkind2==kind6.or.madkind2==kind7)   S2%TP10%DRIFTKICK=.FALSE.   ! 2002.11.04
2759       IF(S2%p%b0==0.0_dp)   then
2760          S2%TP10%DRIFTKICK=.true.
2761          w_p=0
2762          w_p%nc=2
2763          w_p%fc='((1X,a72,/),(1x,a72))'
2764          w_p%c(1)=S2%name
2765          WRITE(w_p%c(2),'(a12,a16,a23)') ' ANGLE=0 IN ', S2%name,' CHANGED TO DRIFT-KICK '
2766          ! call ! WRITE_I
2767       endif
2768    endif
2769
2770    if(S2%KIND==KIND16.OR.S2%KIND==KIND20) then
2771       IF(S2%P%B0/=0.AND.(.NOT.DRIFT_KICK)) THEN
2772          S2%K16%DRIFTKICK=.FALSE.
2773       ELSE
2774          S2%K16%DRIFTKICK=.TRUE.
2775       ENDIF
2776       IF(THICKKICKTEMP)   S2%K16%DRIFTKICK=.FALSE.
2777    ENDIF
2778
2779    IF(S2%KIND==KIND18) THEN
2780 !      S2%RCOL18%A%KIND=2
2781 !      S2%RCOL18%A%X=ABSOLUTE_APERTURE
2782 !      S2%RCOL18%A%Y=ABSOLUTE_APERTURE
2783    ENDIF
2784    IF(S2%KIND==KIND19) THEN
2785 !      S2%ECOL19%A%KIND=1
2786 !      S2%ECOL19%A%R(1)=ABSOLUTE_APERTURE
2787 !      S2%ECOL19%A%R(2)=ABSOLUTE_APERTURE
2788    ENDIF
2789
2790    IF(MADX) then
2791       s2%fint=s1%FINT
2792       s2%hgap=s1%hgap
2793       s2%h1=s1%h1
2794       s2%h2=s1%h2
2795       IF(S2%KIND==KIND3) THEN
2796          s2%K3%hf=s1%hf
2797          s2%K3%vf=s1%vf
2798          s2%K3%ls=s1%ls
2799          s2%K3%thin_h_foc=s1%thin_h_foc
2800          s2%K3%thin_v_foc=s1%thin_v_foc
2801          s2%K3%thin_h_angle=s1%thin_h_angle
2802          s2%K3%thin_v_angle=s1%thin_v_angle
2803       ENDIF
2804       if(s1%APERTURE_KIND/=0) then
2805          call alloc(s2%p%aperture)
2806          s2%p%aperture%kind = -s1%APERTURE_KIND
2807          if(s1%aperture_on) s2%p%aperture%kind =-s2%p%aperture%kind
2808          s2%p%aperture%r    = s1%APERTURE_R
2809          s2%p%aperture%x    = s1%APERTURE_X
2810          s2%p%aperture%y    = s1%APERTURE_y
2811       endif
2812    endif
2813    !   goto 113 ! sagan
2814    s2p=0
2815    ! 113 continue
2816    if(set_ap) then
2817     allocate(s2%p%aperture)
2818     call alloc(s2%p%aperture)
2819       if(S2%KIND==KIND18) then
2820          S2%p%aperture%KIND=2
2821         S2%p%aperture%X=ABSOLUTE_APERTURE
2822         S2%p%aperture%Y=ABSOLUTE_APERTURE   
2823       endif
2824      if(S2%KIND==KIND19) then
2825          S2%p%aperture%KIND=1
2826         S2%p%aperture%r(1)=ABSOLUTE_APERTURE
2827         S2%p%aperture%r(2)=ABSOLUTE_APERTURE   
2828       endif
2829     set_ap=MY_FALSE
2830    endif
2831    call copy(s2,s2p)
2832
2833    ! end of machida stuff here
2834    ! Default survey stuff here
2835    !         s22%CHART%A_XY=s2%P%tilTd      ! THAT SHIT SHOULD NOT BE CHANGED NORMALLY
2836    !         s22%CHART%L=s2%P%LC
2837    !         s22%CHART%ALPHA=s2%P%LD*s2%P%B0
2838    IF(.NOT.MADX_MAGNET_ONLY) THEN      !  true in madx layout
2839       if(associated(s22%chart%f)) then
2840          s22%chart%f%ent=1
2841          !           s22%chart=1
2842          s22%chart=2
2843          CALL SURVEY_no_patch(S22)
2844       endif
2845    else
2846       CALL SURVEY_no_patch(S22)
2847    ENDIF
2848
2849
2850    if(s1%patchg/=0) then
2851       if(s1%patchg==4) then   ! zgoubi order using two patches
2852          s22%PATCH%B_ANG=s1%ang    !
2853          s22%PATCH%A_D=s1%t
2854          s22%PATCH%patch=3
2855       elseif(s1%patchg==2) then
2856          s22%PATCH%B_ANG=s1%ang    !
2857          s22%PATCH%B_D=s1%t
2858          s22%PATCH%patch=2
2859       elseif(s1%patchg==1) then
2860          s22%PATCH%A_ANG=s1%angi    !
2861          s22%PATCH%A_D=s1%ti
2862          s22%PATCH%patch=1
2863       elseif(s1%patchg==3) then
2864          s22%PATCH%A_ANG=s1%angi    !
2865          s22%PATCH%A_D=s1%ti
2866          s22%PATCH%B_ANG=s1%ang    !
2867          s22%PATCH%B_D=s1%t
2868          s22%PATCH%patch=3
2869       endif
2870    endif
2871
2872
2873
2874    madkick=.false.
2875
2876    if(s22%mag%kind==kind3) then
2877       s22%mag%p%nst=1
2878       s22%magp%p%nst=1
2879    endif
2880    if(s22%mag%L==0.0_dp) then
2881       s22%mag%p%nst=1
2882       s22%magp%p%nst=1
2883    endif
2884    !    S22%p0c=p0c
2885    S22%BETA0=BETA0
2886    S22%gamma0I=gamma0I
2887    S22%gambet=gambet
2888    S22%MASS=mc2
2889    S22%ag=a_particle
2890    S22%CHARGE=INITIAL_CHARGE
2891
2892    IF(.NOT.MADX) THEN
2893       el=>s22
2894       !    call APPEND_mad_like(mad_list,s22)
2895       call APPEND_mad_like(mad_list,el)
2896    ENDIF
2897
2898  END SUBROUTINE EL_Q
2899
2900  SUBROUTINE  clean_up
2901    implicit none
2902    logical(lp) crotte
2903
2904    write(6,*) " Clean_up disable: no worry "
2905    return
2906    crotte=superkill
2907    superkill=my_true
2908    call kill(mad_list)
2909    superkill=crotte
2910
2911    mad_list_killed=.true.
2912  end SUBROUTINE  clean_up
2913
2914  subroutine set_pointers
2915    implicit none
2916    call set_da_pointers
2917    c_%NP_pol => NP_pol
2918    c_%ALWAYS_EXACTMIS=> ALWAYS_EXACTMIS
2919
2920
2921    c_%CAVITY_TOTALPATH => CAVITY_TOTALPATH
2922    c_%wherelost => wherelost
2923
2924
2925    c_%valishev => valishev
2926    c_%MADTHICK => MADKIND2
2927    c_%MADTHIN_NORMAL => MADKIND3N
2928    c_%MADTHIN_SKEW => MADKIND3S
2929    c_%NSTD => NSTD
2930    c_%METD => METD
2931    c_%MADLENGTH => MADLENGTH
2932    c_%MAD => MAD
2933    c_%EXACT_MODEL => EXACT_MODEL
2934    c_%ALWAYS_EXACTMIS => ALWAYS_EXACTMIS
2935    c_%sixtrack_compatible => sixtrack_compatible
2936    c_%HIGHEST_FRINGE => HIGHEST_FRINGE
2937    c_%do_beam_beam => do_beam_beam
2938    c_%FIBRE_DIR => FIBRE_DIR
2939    c_%INITIAL_CHARGE => INITIAL_CHARGE
2940    c_%FIBRE_flip => FIBRE_flip
2941    c_%eps_pos => eps_pos
2942    c_%SECTOR_NMUL => SECTOR_NMUL
2943    c_%SECTOR_NMUL_MAX => SECTOR_NMUL_MAX
2944    c_%electron => electron
2945    c_%massfactor => muon
2946    c_%compute_stoch_kick => compute_stoch_kick
2947    c_%FEED_P0C => FEED_P0C
2948    c_%ALWAYS_EXACT_PATCHING => ALWAYS_EXACT_PATCHING
2949    c_%OLD_IMPLEMENTATION_OF_SIXTRACK => OLD_IMPLEMENTATION_OF_SIXTRACK
2950    c_%wedge_coeff => wedge_coeff
2951    c_%MAD8_WEDGE => MAD8_WEDGE
2952    c_%phase0 => phase0
2953    c_%ALWAYS_knobs => ALWAYS_knobs
2954    c_%recirculator_cheat => recirculator_cheat
2955
2956  end subroutine set_pointers
2957
2958  SUBROUTINE  Set_mad(Energy,kinetic,p0c,BRHO,BETa,noisy,method,step)
2959    implicit none
2960    real(dp) ,optional, INTENT(IN)::Energy,kinetic,BRHO,BETa,p0c
2961    integer, optional, INTENT(IN)::method,step
2962    logical(lp), optional, INTENT(IN)::noisy
2963
2964    real(dp) Energy1,kinetic1,BRHO1,BETa1,p0c1
2965    logical(lp) verb
2966    integer met,ns
2967    logical(lp) all
2968
2969    IF(MAD8_WEDGE) THEN
2970       WEDGE_COEFF(1)=1.0_dp+1.0_dp/4.0_dp
2971       WEDGE_COEFF(2)=2.0_dp-0.5_dp
2972    ELSE
2973       WEDGE_COEFF(1)=1.0_dp
2974       WEDGE_COEFF(2)=1.0_dp
2975    ENDIF
2976
2977    call set_pointers
2978
2979    !    CALL NULL_TREE(mad_tree)
2980    !    CALL NULL_TREE(mad_tree_rad)
2981    !    CALL NULL_TREE(mad_tree_REV)
2982    !    CALL NULL_TREE(mad_tree_rad_REV)
2983
2984
2985    ns=nstd
2986    met=METD
2987    verb=verbose
2988    Energy1=0.0_dp
2989    kinetic1=0.0_dp
2990    p0c1=0.0_dp
2991    BRHO1=0.0_dp
2992    BETa1=0.0_dp
2993    all=.true.
2994    if(present(Energy)) then
2995       Energy1=-Energy
2996    else
2997       all=.false.
2998    endif
2999    if(present(kinetic)) then
3000       kinetic1=-kinetic
3001    else
3002       all=.false.
3003    endif
3004    if(present(p0c)) then
3005       p0c1=-p0c
3006    else
3007       all=.false.
3008    endif
3009    if(present(BRHO)) then
3010       BRHO1=-BRHO
3011    else
3012       all=.false.
3013    endif
3014    if(present(BETa)) then
3015       BETa1=-BETa
3016    else
3017       all=.false.
3018    endif
3019    if(present(noisy)) then
3020       verb=noisy
3021    else
3022       all=.false.
3023    endif
3024    if(present(method)) then
3025       met=method
3026    else
3027       all=.false.
3028    endif
3029    if(present(step)) then
3030       ns=step
3031    else
3032       all=.false.
3033    endif
3034    if(all) then
3035       Energy1=-Energy1
3036       p0c1=-p0c1
3037       BRHO1=-BRHO1
3038       kinetic1=-kinetic1
3039       BETa1=-BETa1
3040    endif
3041    call Set_mad_v(Energy1,kinetic1,p0c1,BRHO1,BETa1,verb,met,ns)
3042
3043  end SUBROUTINE  Set_mad
3044
3045  SUBROUTINE  Set_madx(Energy,kinetic,p0c,BRHO,BETa,noisy,method,step)
3046    implicit none
3047    real(dp) ,optional, INTENT(IN)::Energy,kinetic,BRHO,BETa,p0c
3048    integer, optional, INTENT(IN)::method,step
3049    logical(lp), optional, INTENT(IN)::noisy
3050
3051    real(dp) Energy1,kinetic1,BRHO1,BETa1,p0c1
3052    logical(lp) verb
3053    integer met,ns
3054    logical(lp) all
3055
3056    IF(MAD8_WEDGE) THEN
3057       WEDGE_COEFF(1)=1.0_dp+1.0_dp/4.0_dp
3058       WEDGE_COEFF(2)=2.0_dp-0.5_dp
3059    ELSE
3060       WEDGE_COEFF(1)=1.0_dp
3061       WEDGE_COEFF(2)=1.0_dp
3062    ENDIF
3063
3064    call set_pointers
3065
3066
3067    ns=nstd
3068    met=METD
3069    verb=verbose
3070    Energy1=0.0_dp
3071    kinetic1=0.0_dp
3072    p0c1=0.0_dp
3073    BRHO1=0.0_dp
3074    BETa1=0.0_dp
3075    all=.true.
3076    if(present(Energy)) then
3077       Energy1=-Energy
3078    else
3079       all=.false.
3080    endif
3081    if(present(kinetic)) then
3082       kinetic1=-kinetic
3083    else
3084       all=.false.
3085    endif
3086    if(present(p0c)) then
3087       p0c1=-p0c
3088    else
3089       all=.false.
3090    endif
3091    if(present(BRHO)) then
3092       BRHO1=-BRHO
3093    else
3094       all=.false.
3095    endif
3096    if(present(BETa)) then
3097       BETa1=-BETa
3098    else
3099       all=.false.
3100    endif
3101    if(present(noisy)) then
3102       verb=noisy
3103    else
3104       all=.false.
3105    endif
3106    if(present(method)) then
3107       met=method
3108    else
3109       all=.false.
3110    endif
3111    if(present(step)) then
3112       ns=step
3113    else
3114       all=.false.
3115    endif
3116    if(all) then
3117       Energy1=-Energy1
3118       p0c1=-p0c1
3119       BRHO1=-BRHO1
3120       kinetic1=-kinetic1
3121       BETa1=-BETa1
3122    endif
3123    madx=.true.
3124    call Set_mad_v(Energy1,kinetic1,p0c1,BRHO1,BETa1,verb,met,ns)
3125    madx=.false.
3126  end SUBROUTINE  Set_madx
3127
3128
3129
3130
3131
3132  SUBROUTINE GET_ENERGY(ENE,KIN,BRHOin,BET,P0CC)
3133    implicit none
3134    real(dp) ,INTENT(INOUT)::ENE,kin,BRHOin,BET,P0CC
3135    ENE=ENERGY
3136    KIN=KINETIC
3137    BRHOIN=BRHO
3138    BET=BETA0
3139    P0CC=P0C
3140
3141  end SUBROUTINE  GET_ENERGY
3142
3143  SUBROUTINE  GET_GAM(GAMI,GAMB)
3144    implicit none
3145    real(dp) ,INTENT(INOUT)::GAMI,GAMB
3146    GAMI=gamma0I
3147    GAMB=gambet
3148
3149  end SUBROUTINE  GET_GAM
3150
3151  SUBROUTINE  GET_ONE(MASS,ENERGY,KINETIC,BRHO,BETA0,P0C,gamma0I,gambet)
3152    implicit none
3153    real(dp) ,optional,INTENT(OUT)::ENERGY,KINETIC,BRHO,BETA0,P0C,gamma0I,gambet,MASS
3154    real(dp)  ENE,kin,BRHOin,BET,P0CC,GAMI,GAMB
3155
3156    call GET_ENERGY(ENE,KIN,BRHOin,BET,P0CC)
3157    CALL GET_GAM(GAMI,GAMB)
3158
3159    if(present(ENERGY))  ENERGY=ENE
3160    if(present(KINETIC)) KINETIC=kin
3161    if(present(BRHO)) BRHO=BRHOin
3162    if(present(BETA0)) BETA0=BET
3163    if(present(P0C)) P0C=P0CC
3164    if(present(gamma0I)) gamma0I=GAMI
3165    if(present(gambet)) gambet=GAMB
3166    if(present(MASS)) MASS=mc2
3167
3168  end SUBROUTINE  GET_ONE
3169
3170  SUBROUTINE  Set_mad_v(ENE,KIN,p0c1,BRHOin,BET,verb,met,ns)
3171    implicit none
3172    real(dp) ,INTENT(IN)::ENE,BRHOin,BET,p0c1
3173    real(dp) XMC2,cl,CU,ERG,beta0i,GAMMA,GAMMA2,CON ,KIN
3174    logical(lp) PROTON,verb
3175    integer met,ns
3176
3177
3178    METD=met
3179    nstd=ns
3180    if(mad_list_killed.and.(.not.madx)) then
3181       call set_up(mad_list)
3182       mad_list_killed=.false.
3183    endif
3184    setmad = .true.
3185    verbose=verb
3186    !total_EPS=c_1d_10
3187
3188    ENERGY=ENE
3189    KINETIC=KIN
3190    beta0=BET
3191    brho=BRHOin
3192    p0c=p0c1
3193
3194    PROTON=.NOT.ELECTRON
3195    cl=(clight/1e8_dp)
3196    CU=55.0_dp/24.0_dp/SQRT(3.0_dp)
3197    w_p=0
3198    w_p%nc=8
3199    w_p%fc='(7((1X,A72,/)),1X,A72)'
3200    if(electron) then
3201       XMC2=muon*pmae
3202       w_p%c(1)=" This is an electron "
3203    elseif(proton) then
3204       XMC2=pmap
3205       w_p%c(2)=" This is a proton! "
3206    endif
3207    if(energy<0) then
3208       energy=-energy
3209       erg=ENERGY
3210       p0c=SQRT(erg**2-xmc2**2)
3211    endif
3212    if(KINETIC<0) then
3213       KINETIC=-KINETIC
3214       erg=KINETIC+xmc2
3215       p0c=SQRT(erg**2-xmc2**2)
3216    endif
3217    if(brho<0) then
3218       brho=-brho
3219       p0c=BRHO*(cl/10.0_dp)    !SQRT(BRHO**2*(cl/ten)**2)
3220    endif
3221    if(beta0<0) then
3222       beta0=-beta0
3223       p0c=(1.0_dp-beta0**2)
3224       if(p0c<=0.0_dp) then
3225          w_p=0
3226          w_p%nc=2
3227          w_p%fc='(((1X,A72,/)),1X,A72)'
3228          write(w_p%c(1),'(a9,1x,g21.14)') " Beta0 = ",beta0
3229          w_p%c(2) ="Beta0 is too close to 1 "
3230          ! call !write_e(-567)
3231       endif
3232       p0c=xmc2*beta0/SQRT(p0c)
3233    endif
3234    if(p0c<0) p0c=-p0c
3235    erg=SQRT(p0c**2+XMC2**2)
3236    ENERGY=ERG
3237    KINETIC=ERG-xmc2
3238    beta0=SQRT(KINETIC**2+2.0_dp*KINETIC*XMC2)/erg
3239    beta0i=1.0_dp/beta0
3240    GAMMA=erg/XMC2
3241    write(W_P%C(2),'(A16,g21.14)') ' Kinetic Energy ',kinetic
3242    write(W_P%C(3),'(A7,g21.14)') ' gamma ',gamma
3243    write(W_P%C(4),'(A7,g21.14)')' beta0 ',BETa0
3244    CON=3.0_dp*CU*CGAM*HBC/2.0_dp*TWOPII/XMC2**3
3245    CRAD=CGAM*TWOPII   !*ERG**3
3246    CFLUC=CON  !*ERG**5
3247    GAMMA2=erg**2/XMC2**2
3248    BRHO=SQRT(ERG**2-XMC2**2)*10.0_dp/cl
3249    write(W_P%C(5),'(A7,g21.14)') ' p0c = ',p0c
3250    write(W_P%C(6),'(A9,g21.14)')' GAMMA = ',SQRT(GAMMA2)
3251    write(W_P%C(7),'(A8,g21.14)')' BRHO = ',brho
3252    write(W_P%C(8),'(A15,G21.14,1X,g21.14)')"CRAD AND CFLUC ", crad ,CFLUC
3253    ! call ! WRITE_I
3254    !END OF SET RADIATION STUFF  AND TIME OF FLIGHT SUFF
3255
3256    gamma0I=XMC2*BETA0/P0C
3257    GAMBET=(XMC2/P0C)**2
3258    MC2=XMC2
3259  END SUBROUTINE Set_mad_v
3260
3261
3262
3263  FUNCTION  arbitrary_tilt(NAME,file,T,no)
3264    implicit none
3265    type (EL_LIST) arbitrary_tilt
3266    CHARACTER(*), INTENT(IN):: NAME,file
3267    type (TILTING),optional, INTENT(IN):: T
3268    real(dp) L,ANGLE,HC
3269    integer mf,nst,I,ORDER
3270    integer, optional :: no
3271    LOGICAL(LP) REPEAT
3272    TYPE(TAYLOR) B(3),ax(2),ay(2)
3273
3274    file_fitted=file
3275    arbitrary_tilt=0
3276
3277    call kanalnummer(mf)
3278    open(unit=mf,file=file_fitted)
3279    read(mf,*) nst,L,hc, ORDER,REPEAT
3280    if(present(no)) order=no
3281    CALL INIT(ORDER,2)
3282    CALL ALLOC(B)
3283    CALL ALLOC(ax)
3284    CALL ALLOC(ay)
3285
3286    IF(REPEAT.AND.NST==0) NST=NSTD
3287
3288    ALLOCATE(T_E(NST),T_ax(NST),T_ay(NST))
3289
3290    DO I=1,NST
3291       IF(I==1.or.(.not.repeat)) THEN
3292          CALL READ(B(1),mf);CALL READ(B(2),mf);CALL READ(B(3),mf);
3293          !          CALL READ(Ax(1),mf);CALL READ(Ay(1),mf);CALL READ(Ax(2),mf);CALL READ(Ay(2),mf);
3294          B(1)=B(1)/BRHO
3295          B(2)=B(2)/BRHO
3296          B(3)=B(3)/BRHO
3297          Ax(1)=Ax(1)/BRHO
3298          Ax(2)=Ax(2)/BRHO
3299          Ay(1)=Ay(1)/BRHO
3300          Ay(2)=Ay(2)/BRHO
3301       ENDIF
3302       CALL SET_TREE_g(T_E(i),B)
3303       !       CALL SET_TREE_g(T_ax(i),ax)
3304       !       CALL SET_TREE_g(T_ay(i),ay)
3305    enddo
3306    call KILL(B)
3307    CALL KILL(ax)
3308    CALL KILL(ay)
3309
3310    close(MF)
3311
3312
3313    ANGLE=L*HC
3314
3315
3316    !    IF(ANG/=zero.AND.R/=zero) THEN
3317    if(hc/=0.0_dp) then
3318       arbitrary_tilt%LC=2.0_dp*SIN(ANGLE/2.0_dp)/hc
3319    else
3320       arbitrary_tilt%LC=L
3321    endif
3322    arbitrary_tilt%B0=hc                     !COS(ANG/two)/R
3323    arbitrary_tilt%LD=L
3324    arbitrary_tilt%L=arbitrary_tilt%LD
3325
3326    IF(LEN(NAME)>nlp) THEN
3327       w_p=0
3328       w_p%nc=2
3329       w_p%fc='((1X,a72,/),(1x,a72))'
3330       w_p%c(1)=name
3331       WRITE(w_p%c(2),'(a17,1x,a16)') ' IS TRUNCATED TO ', NAME(1:16)
3332       ! call ! WRITE_I
3333       arbitrary_tilt%NAME=NAME(1:16)
3334    ELSE
3335       arbitrary_tilt%NAME=NAME
3336    ENDIF
3337
3338    IF(NST<3.OR.MOD(NST,2)/=1) THEN
3339       WRITE(6,*) "NUMBER OF SLICES IN 'arbitrary'  MUST BE ODD AND >= 3 ",NST
3340       STOP 101
3341    ENDIF
3342    arbitrary_tilt%nst=(NST-1)/2
3343    arbitrary_tilt%KIND=KINDPA
3344    IF(PRESENT(t)) then
3345       IF(T%NATURAL) THEN
3346          arbitrary_tilt%tilt=t%tilt(1)
3347       ELSE
3348          arbitrary_tilt%tilt=t%tilt(0)
3349       ENDIF
3350    ENDIF
3351  END FUNCTION arbitrary_tilt
3352  ! linked
3353
3354
3355  SUBROUTINE  EQUAL_L(R,S1)
3356    implicit none
3357    type (layout),INTENT(inOUT)::R
3358    type (layout),INTENT(IN)::S1
3359    INTEGER I
3360    !    real(dp) gamma0I,gamBET
3361    TYPE (fibre), POINTER :: C   !,fitted
3362    !   logical(lp) firstfitted
3363    Nullify(C);    !Nullify(fitted);
3364    !   firstfitted=.true.
3365    CALL SET_UP(R)
3366    !    R%ENERGY=ENERGY
3367    !    R%KINETIC=KINETIC
3368    !    R%beta0=beta0
3369    !    R%brho=BRHO
3370    !    R%p0c=p0c
3371    !    gamma0I=SQRT(one-R%beta0**2)
3372    !    gambet =(gamma0I/R%beta0)**2
3373
3374    !    R%CIRCUMFERENCE=zero
3375    c=>s1%start
3376    DO I=1,S1%N
3377
3378       CALL APPEND( R, C )
3379       c=>c%next
3380    ENDDO
3381
3382
3383    if(use_info) then
3384       c=>R%start
3385       c%i%s=0.0_dp
3386       do i=1,R%n
3387          if(i<R%n.and.use_info) c%next%i%s=c%i%s+c%mag%p%ld
3388
3389          c=>c%next
3390       enddo
3391    endif
3392
3393  END SUBROUTINE EQUAL_L
3394
3395
3396
3397  ! linked
3398  SUBROUTINE Set_Up_MAD( L )
3399    implicit none
3400    TYPE (layout) L
3401    NULLIFY(L%closed);  NULLIFY(L%lastpos);
3402    NULLIFY(L%NTHIN);NULLIFY(L%THIN);
3403    !    NULLIFY(L%ENERGY);NULLIFY(L%KINETIC);
3404    !    NULLIFY(L%P0C);NULLIFY(L%BRHO);NULLIFY(L%BETA0);
3405    NULLIFY(L%n);
3406    !    NULLIFY(L%circumference);
3407    allocate(l%n); l%n=0;
3408    allocate(l%closed); l%closed=.false.;
3409    allocate(l%lastpos); l%lastpos=0;
3410
3411    NULLIFY( L % last )       ! layout is empty at first
3412    NULLIFY( L % end )       ! layout is empty at first
3413    NULLIFY( L % start )       ! layout is empty at first
3414    NULLIFY( L % start_ground )       ! layout is empty at first
3415    NULLIFY( L % PARENT_UNIVERSE )       ! layout is empty at first
3416  END SUBROUTINE Set_Up_MAD
3417
3418
3419  SUBROUTINE  EQUAL_L_L(R,S1)
3420    implicit none
3421    logical(lp) :: doneitt=.true.
3422    type (layout),INTENT(inOUT)::R
3423    type (layout),INTENT(IN)::S1
3424    INTEGER I
3425    TYPE (fibre), POINTER :: C
3426
3427    if(makeit) then
3428       call equal_l(r,s1)
3429       r%closed=circular
3430       circular=.false.
3431       makeit=.false.
3432       CALL RING_L(R,doneitt)
3433       return
3434    endif
3435
3436    Nullify(C);
3437
3438    CALL SET_UP(R)
3439
3440    c=>s1%start
3441    DO I=1,S1%N
3442       call APPEND_mad_like(R,C)
3443       C=>C%NEXT
3444    ENDDO
3445
3446  END SUBROUTINE EQUAL_L_L
3447
3448  FUNCTION add_EE( S1, S2 )
3449    implicit none
3450    TYPE (layout) add_EE
3451    TYPE (fibre), INTENT (IN) :: S1, S2
3452
3453    call Set_Up_mad(add_ee)
3454    call APPEND_mad_like(add_ee,s1)
3455    call APPEND_mad_like(add_ee,s2)
3456
3457  END FUNCTION add_EE
3458
3459  FUNCTION add_EB( S1, S2 )
3460    implicit none
3461    TYPE (layout) add_EB
3462    TYPE (fibre), INTENT (IN) :: S1
3463    TYPE (layout), INTENT (IN) :: S2
3464    INTEGER I
3465    type(fibre), pointer ::c
3466    nullify(c)
3467    call Set_Up_MAD(add_EB)
3468    call APPEND_mad_like(add_EB,s1)
3469
3470    c=>s2%start
3471    do i=1,s2%n
3472       call APPEND_mad_like(add_EB,c)
3473       c=>c%next
3474    enddo
3475
3476  END FUNCTION add_EB
3477
3478  FUNCTION add_BE( S2 , S1 )
3479    implicit none
3480    TYPE (layout) add_BE
3481    TYPE (fibre), INTENT (IN) :: S1
3482    TYPE (layout), INTENT (IN) :: S2
3483    INTEGER I
3484    type(fibre), pointer ::c
3485    nullify(c)
3486    call Set_Up_MAD(add_BE)
3487
3488    c=>s2%start
3489    do i=1,s2%n
3490       call APPEND_mad_like(add_BE,c)
3491       c=>c%next
3492    enddo
3493    call APPEND_mad_like(add_BE,s1)
3494
3495  END FUNCTION add_BE
3496
3497  FUNCTION add_BB( S1 , S2 )
3498    implicit none
3499    TYPE (layout) add_BB
3500    TYPE (layout), INTENT (IN) :: S1
3501    TYPE (layout), INTENT (IN) :: S2
3502    INTEGER I
3503    type(fibre), pointer ::c
3504    nullify(c)
3505    call Set_Up_MAD(add_BB)
3506
3507    c=>s1%start
3508    do i=1,s1%n
3509       call APPEND_mad_like(add_BB,c)
3510       c=>c%next
3511    enddo
3512    c=>s2%start
3513    do i=1,s2%n
3514       call APPEND_mad_like(add_BB,c)
3515       c=>c%next
3516    enddo
3517
3518  END FUNCTION add_BB
3519
3520  FUNCTION SUB_BB( S1 , S2 )
3521    implicit none
3522    TYPE (layout) SUB_BB
3523    TYPE (layout), INTENT (IN) :: S1
3524    TYPE (layout), INTENT (IN) :: S2
3525    INTEGER I
3526    type(fibre), pointer ::c
3527    nullify(c)
3528    call Set_Up_MAD(SUB_BB)
3529
3530    c=>s1%start
3531    do i=1,s1%n
3532       call APPEND_mad_like(SUB_BB,c)
3533       c=>c%next
3534    enddo
3535    c=>s2%end
3536    do i=1,s2%n
3537       call APPEND_mad_like(SUB_BB,c)
3538       c=>c%previous
3539    enddo
3540
3541  END FUNCTION SUB_BB
3542
3543
3544
3545
3546  FUNCTION MUL_B( S1, S2 )
3547    implicit none
3548    TYPE (layout) MUL_B
3549    integer, INTENT (IN) :: S1
3550    TYPE (layout), INTENT (IN) :: S2
3551    INTEGER I,j
3552    type(fibre), pointer ::c
3553    nullify(c)
3554    call Set_Up_MAD(MUL_B)
3555    if(s1>=0) then
3556       do j=1,s1
3557          c=>s2%start
3558          do i=1,s2%n
3559             call APPEND_mad_like(MUL_B,c)
3560             c=>c%next
3561          enddo
3562       enddo
3563    else
3564       do j=1,-s1
3565          c=>s2%end
3566          do i=1,s2%n
3567             call APPEND_mad_like(MUL_B,c)
3568             c=>c%previous
3569          enddo
3570       enddo
3571    endif
3572
3573  END FUNCTION MUL_B
3574
3575  FUNCTION MUL_E( S1, S2 )
3576    implicit none
3577    TYPE (layout) MUL_E
3578    integer, INTENT (IN) :: S1
3579    TYPE (fibre), INTENT (IN) :: S2
3580    INTEGER I
3581    call Set_Up_MAD(MUL_E)
3582    !  write(6,*) 1,associated(mul_e%mass)
3583    !  if(associated(mul_e%mass)) write(6,*) mul_e%mass
3584
3585    do I=1,IABS(s1)
3586       call APPEND_mad_like(MUL_E,S2)
3587    enddo
3588    !   write(6,*)2, associated(mul_e%mass)
3589    !   if(associated(mul_e%mass)) write(6,*) mul_e%mass
3590
3591  END FUNCTION MUL_E
3592
3593
3594  FUNCTION UNARY_SUBB( S1 )
3595    implicit none
3596    TYPE (layout) UNARY_SUBB
3597    TYPE (layout), INTENT (IN) :: S1
3598    type(fibre), pointer ::c
3599    integer i
3600    nullify(c)
3601    call Set_Up_MAD(UNARY_SUBB)
3602
3603    c=>s1%end
3604    do i=1,s1%n
3605       call APPEND_mad_like(UNARY_SUBB,c)
3606       c=>c%previous
3607    enddo
3608
3609  END FUNCTION UNARY_SUBB
3610
3611  FUNCTION makeitc( S1 )
3612    implicit none
3613    TYPE (layout) makeitc
3614    TYPE (layout), INTENT (IN) :: S1
3615    type(fibre), pointer ::c
3616    integer i
3617    nullify(c)
3618    call Set_Up_MAD(makeitc)
3619
3620    makeit=.true.
3621    circular=.true.
3622    c=>s1%start
3623    do i=1,s1%n
3624       call APPEND_mad_like(makeitc,c)
3625       c=>c%next
3626    enddo
3627
3628  END FUNCTION makeitc
3629
3630  FUNCTION makeits( S1 )
3631    implicit none
3632    TYPE (layout) makeits
3633    TYPE (layout), INTENT (IN) :: S1
3634    type(fibre), pointer ::c
3635    integer i
3636    nullify(c)
3637    call Set_Up_MAD(makeits)
3638
3639    makeit=.true.
3640    circular=.false.
3641    c=>s1%start
3642    do i=1,s1%n
3643       call APPEND_mad_like(makeits,c)
3644       c=>c%next
3645    enddo
3646
3647  END FUNCTION makeits
3648
3649
3650
3651
3652end module Mad_like
Note: See TracBrowser for help on using the repository browser.