source: PSPA/madxPSPA/libs/ptc/src/Sp_keywords.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: 86.6 KB
Line 
1!The Polymorphic Tracking Code
2!Copyright (C) Etienne Forest and CERN
3
4module madx_keywords
5  use S_fitting
6  implicit none
7  public
8  logical(lp)::mad8=my_false
9  integer :: ifield_name=0
10  logical(lp),private :: do_survey =my_false
11  logical(lp) :: print_marker =my_true
12  type(tree_element), private, allocatable :: t_e(:),t_ax(:),t_ay(:)
13  real(dp), private :: a_(3),ent_(3,3), b_(3),exi_(3,3)
14
15
16  type keywords
17     character*20 magnet
18     character*20 model
19     logical(lp) FIBRE_flip
20     INTEGER FIBRE_DIR
21     integer method
22     integer nstep
23     logical(lp) exact
24     logical(lp) madLENGTH
25     logical(lp) mad8
26     real(dp) tiltd
27     type(el_list) LIST
28  end type keywords
29
30  type MADX_SURVEY
31     REAL(DP) ALPHA,TILT,LD
32     REAL(DP) PHI,THETA,PSI
33     TYPE(CHART) CHART
34  END type MADX_SURVEY
35
36  include "a_namelists.inc"
37
38
39  INTERFACE read_lattice_append
40     MODULE PROCEDURE read_universe_database
41  END  INTERFACE
42
43
44contains
45
46
47  subroutine create_fibre_append(append,mylat,key,EXCEPTION,magnet_only) 
48    implicit none
49
50!    type(mad_universe), target, intent(inout)  :: m_u
51    type(layout), target, intent(inout)  :: mylat
52    logical(lp), optional :: magnet_only
53    type(keywords) key
54    INTEGER EXCEPTION  !,NSTD0,METD0
55    logical(lp) doneit,append
56    type(fibre), pointer :: current
57
58    if(append) then
59     call append_empty(mylat)
60    else
61     if(associated(mylat%end)) then
62      IF(ASSOCIATED(mylat%T)) THEN
63         CALL kill_NODE_LAYOUT(mylat%T)  !  KILLING THIN LAYOUT
64         nullify(mylat%T)
65        if(lielib_print(12)==1) WRITE(6,*) " NODE LAYOUT HAS BEEN KILLED "
66       ENDIF     
67        mylat%end=-1
68       else
69        call append_empty(mylat)
70     endif
71    endif
72     call  create_fibre(mylat%end,key,EXCEPTION,magnet_only)
73     
74    if(.not.append) then
75     mylat%closed=my_true
76
77     doneit=my_true
78     call ring_l(mylat,doneit)
79
80     call survey(mylat)
81     call MAKE_NODE_LAYOUT( mylat)     
82    endif
83  end subroutine create_fibre_append
84
85
86  subroutine create_fibre(el,key,EXCEPTION,magnet_only)
87    implicit none
88    integer ipause, mypause,i
89    type(fibre), target, intent(inout)::el
90    logical(lp), optional :: magnet_only
91    type(keywords) key
92    type(el_list) blank
93    character*255 magnet
94    character*17 MODEL
95    INTEGER EXCEPTION  !,NSTD0,METD0
96    LOGICAL(LP) EXACT0,magnet0
97    logical(lp) FIBRE_flip0,MAD0
98    logical(lp) :: t=my_true,f=my_false
99    INTEGER FIBRE_DIR0,IL
100    real(dp) e1_true,norm
101
102
103    IL=15
104
105    if(present(magnet_only)) then
106       magnet0=magnet_only
107    else
108       magnet0=my_false
109    endif
110
111    blank=0
112    magnet=key%magnet
113    call context(magnet)
114    model=key%model
115    call context(model)
116
117    CALL SET_MADX_(t,magnet0)
118
119
120    select case(MODEL)
121    CASE("DRIFT_KICK       ")
122       MADTHICK=drift_kick_drift
123    CASE("MATRIX_KICK      ")
124       MADTHICK=matrix_kick_matrix
125    CASE("DELTA_MATRIX_KICK")
126       MADTHICK=kick_sixtrack_kick
127    CASE DEFAULT
128 
129       EXCEPTION=1
130       ipause=mypause(444)
131       RETURN
132    END SELECT
133
134    !    NSTD0=NSTD
135    !    METD0=METD
136    EXACT0=EXACT_MODEL
137    FIBRE_FLIP0= FIBRE_FLIP
138    FIBRE_DIR0=FIBRE_DIR
139    MAD0=MAD
140
141    KEY%LIST%nst=KEY%NSTEP
142    KEY%LIST%method=KEY%METHOD
143    EXACT_MODEL=KEY%EXACT
144    FIBRE_FLIP = KEY%FIBRE_FLIP
145    FIBRE_DIR  = KEY%FIBRE_DIR
146    MADLENGTH=KEY%MADLENGTH
147
148    !     real(dp) L,LD,LC,K(NMAX),KS(NMAX)
149    !     real(dp) ang(3),t(3)
150    !     real(dp) angi(3),ti(3)
151    !     integer patchg
152    !     real(dp) T1,T2,B0
153    !     real(dp) volt,freq0,harmon,lag,DELTA_E,BSOL
154    !     real(dp) tilt
155    !     real(dp) FINT,hgap,h1,h2,X_COL,Y_COL
156    !     real(dp) thin_h_foc,thin_v_foc,thin_h_angle,thin_v_angle  ! highly illegal additions by frs
157    !     CHARACTER(120) file
158    !     CHARACTER(120) file_rev
159    !    CHARACTER(nlp) NAME
160    !     CHARACTER(vp) VORNAME
161    !     INTEGER KIND,nmul,nst,method
162    !     LOGICAL(LP) APERTURE_ON
163    !     INTEGER APERTURE_KIND
164    !     REAL(DP) APERTURE_R(2),APERTURE_X,APERTURE_Y
165    !     LOGICAL(LP) KILL_ENT_FRINGE,KILL_EXI_FRINGE,BEND_FRINGE,PERMFRINGE
166    !     REAL(DP) DPHAS,PSI,dvds
167    !     INTEGER N_BESSEL
168
169    if(sixtrack_compatible) then
170       EXACT_MODEL=my_false
171       KEY%LIST%method=2
172       MADTHICK=drift_kick_drift
173    endif
174
175
176    SELECT CASE(magnet(1:IL))
177    CASE("DRIFT          ")
178       BLANK=DRIFT(KEY%LIST%NAME,LIST=KEY%LIST)
179    CASE("SOLENOID       ")
180       if(sixtrack_compatible) stop 1
181       if(KEY%LIST%L/=0.0_dp) then
182          BLANK=SOLENOID(KEY%LIST%NAME,t=tilt.is.KEY%tiltd,LIST=KEY%LIST)
183          !  BLANK%bend_fringe=key%list%bend_fringe
184       else
185          write(6,*) "switch solenoid to dubious thin multipole "
186          BLANK=MULTIPOLE_BLOCK(KEY%LIST%NAME,t=tilt.is.KEY%tiltd,LIST=KEY%LIST)
187       endif
188
189    CASE("THICKMULTIPOLE ")
190       BLANK=multipoleTILT(KEY%LIST%NAME,t=tilt.is.KEY%tiltd,LIST=KEY%LIST)
191       BLANK%bend_fringe=key%list%bend_fringe
192
193    CASE("QUADRUPOLE     ")
194       BLANK=QUADRUPOLE(KEY%LIST%NAME,t=tilt.is.KEY%tiltd,LIST=KEY%LIST)
195       BLANK%bend_fringe=key%list%bend_fringe
196    CASE("SEXTUPOLE     ")
197       BLANK=SEXTUPOLE(KEY%LIST%NAME,t=tilt.is.KEY%tiltd,LIST=KEY%LIST)
198       BLANK%bend_fringe=key%list%bend_fringe
199    CASE("OCTUPOLE      ")
200       BLANK=OCTUPOLE(KEY%LIST%NAME,t=tilt.is.KEY%tiltd,LIST=KEY%LIST)
201       BLANK%bend_fringe=key%list%bend_fringe
202    CASE("SBEND         ")
203       BLANK=SBEND(KEY%LIST%NAME,t=tilt.is.KEY%tiltd,LIST=KEY%LIST)
204    CASE("TRUERBEND     ")
205       if(sixtrack_compatible) stop 2
206
207       e1_true= KEY%LIST%b0/2.0_dp+ KEY%LIST%t1
208       BLANK=rbend(KEY%LIST%NAME,l=KEY%LIST%l,angle=KEY%LIST%b0,e1=e1_true,list=KEY%LIST)
209
210    CASE("WEDGRBEND     ")
211       if(sixtrack_compatible) stop 3
212
213       BLANK=rbend(KEY%LIST%NAME,l=KEY%LIST%l,angle=KEY%LIST%b0,e1=KEY%LIST%t1,e2=KEY%LIST%t2,list=KEY%LIST)
214
215    CASE("RBEND         ")
216       if(sixtrack_compatible) stop 4
217       KEY%LIST%T1=KEY%LIST%T1+KEY%LIST%B0/2.0_dp
218       KEY%LIST%T2=KEY%LIST%T2+KEY%LIST%B0/2.0_dp
219       BLANK=SBEND(KEY%LIST%NAME,t=tilt.is.KEY%tiltd,LIST=KEY%LIST)
220    CASE("KICKER         ","VKICKER        ","HKICKER        ")
221       BLANK=KICKER(KEY%LIST%NAME,t=tilt.is.KEY%tiltd,LIST=KEY%LIST)
222       BLANK%bend_fringe=key%list%bend_fringe
223    CASE("MONITOR        ")
224       if(sixtrack_compatible) then
225          BLANK=DRIFT(KEY%LIST%NAME,LIST=KEY%LIST)
226       else
227          BLANK=MONITOR(KEY%LIST%NAME,t=tilt.is.KEY%tiltd,LIST=KEY%LIST)
228       endif
229    CASE("HMONITOR        ")
230       if(sixtrack_compatible) then
231          BLANK=DRIFT(KEY%LIST%NAME,LIST=KEY%LIST)
232       else
233          BLANK=MONITOR(KEY%LIST%NAME,t=tilt.is.KEY%tiltd,LIST=KEY%LIST) ;BLANK%KIND=KIND12;
234       endif
235    CASE("VMONITOR       ")
236       if(sixtrack_compatible) then
237          BLANK=DRIFT(KEY%LIST%NAME,LIST=KEY%LIST)
238       else
239          BLANK=MONITOR(KEY%LIST%NAME,t=tilt.is.KEY%tiltd,LIST=KEY%LIST) ;BLANK%KIND=KIND13;
240       endif
241    CASE("INSTRUMENT     ")
242       if(sixtrack_compatible) then
243          BLANK=DRIFT(KEY%LIST%NAME,LIST=KEY%LIST)
244       else
245          BLANK=MONITOR(KEY%LIST%NAME,t=tilt.is.KEY%tiltd,LIST=KEY%LIST) ;BLANK%KIND=KIND14;
246       endif
247    CASE("MARKER         ")
248       BLANK=MARKER(KEY%LIST%NAME,list=KEY%LIST)
249    CASE("CHANGEREF      ")
250       if(sixtrack_compatible) stop 5
251       BLANK=CHANGEREF(KEY%LIST%NAME,KEY%LIST%ANG,KEY%LIST%T,KEY%LIST%PATCHG)
252    CASE("RFCAVITY       ")
253       if(sixtrack_compatible) then
254          If(KEY%LIST%L/=0.0_dp) stop 60
255          If(KEY%LIST%N_BESSEL/=0.0_dp) stop 61
256          norm=0.0_dp
257          do i=1,nmax
258             norm=norm+abs(KEY%LIST%k(i))+abs(KEY%LIST%ks(i))
259          enddo
260          norm=norm-abs(KEY%LIST%k(2))
261          if(norm/=0.0_dp) then
262             write(6,*) norm
263             stop 62
264          endif
265       endif
266       BLANK=RFCAVITY(KEY%LIST%NAME,LIST=KEY%LIST)
267    CASE("TWCAVITY       ")
268       if(sixtrack_compatible) stop 7
269       BLANK=TWCAVITY(KEY%LIST%NAME,LIST=KEY%LIST)
270    CASE("ELSEPARATOR    ")
271       if(sixtrack_compatible) stop 8
272       BLANK=ELSEPARATOR(KEY%LIST%NAME,t=tilt.is.KEY%tiltd,LIST=KEY%LIST)
273    CASE("MULTIPOLE_BLOCK","MULTIPOLE      ")
274       BLANK=MULTIPOLE_BLOCK(KEY%LIST%NAME,t=tilt.is.KEY%tiltd,LIST=KEY%LIST)
275    CASE("SMI            ","SINGLE_LENS    ")
276       if(sixtrack_compatible) stop 9
277       BLANK=SINGLE_LENS(KEY%LIST%NAME,t=tilt.is.KEY%tiltd,LIST=KEY%LIST)
278    CASE("RCOLLIMATOR    ")
279       if(sixtrack_compatible) stop 10
280       BLANK=RCOLLIMATOR(KEY%LIST%NAME,t=tilt.is.KEY%tiltd,LIST=KEY%LIST)
281    CASE("ECOLLIMATOR    ")
282       if(sixtrack_compatible) then
283          BLANK=DRIFT(KEY%LIST%NAME,LIST=KEY%LIST)
284       else
285          BLANK=ECOLLIMATOR(KEY%LIST%NAME,t=tilt.is.KEY%tiltd,LIST=KEY%LIST)
286       endif
287    CASE("WIGGLER        ")
288       if(sixtrack_compatible) stop 12
289       BLANK=WIGGLER(KEY%LIST%NAME,t=tilt.is.KEY%tiltd,LIST=KEY%LIST)
290    CASE("HELICALDIPOLE  ")
291       if(sixtrack_compatible) stop 13
292       BLANK=HELICAL(KEY%LIST%NAME,LIST=KEY%LIST)
293       !    CASE("TAYLORMAP      ")
294       !       IF(KEY%LIST%file/=' '.and.KEY%LIST%file_rev/=' ') THEN
295       !          BLANK=TAYLOR_MAP(KEY%LIST%NAME,FILE=KEY%LIST%file,FILE_REV=KEY%LIST%file_REV,t=tilt.is.KEY%tiltd)
296       !       ELSEIF(KEY%LIST%file/=' '.and.KEY%LIST%file_rev==' ') THEN
297       !          BLANK=TAYLOR_MAP(KEY%LIST%NAME,FILE=KEY%LIST%file,t=tilt.is.KEY%tiltd)
298       !       ELSEIF(KEY%LIST%file==' '.and.KEY%LIST%file_rev/=' ') THEN
299       !          BLANK=TAYLOR_MAP(KEY%LIST%NAME,FILE_REV=KEY%LIST%file_REV,t=tilt.is.KEY%tiltd)
300       !       ELSE
301       !          BLANK=TAYLOR_MAP(KEY%LIST%NAME,t=tilt.is.KEY%tiltd)
302       !       ENDIF
303       ! BLANK%bend_fringe=key%list%bend_fringe
304    CASE DEFAULT
305       WRITE(6,*) " "
306       WRITE(6,*) " THE MAGNET"
307       WRITE(6,*) " "
308       WRITE(6,*) "  --->   ",MAGNET(1:IL)
309       WRITE(6,*) " "
310       WRITE(6,*)  " IS NOT PERMITTED "
311       STOP 666
312    END SELECT
313
314    BLANK%VORNAME = KEY%LIST%VORNAME
315    CALL EL_Q_FOR_MADX(EL,BLANK)
316    !  added 2007.07.09
317    el%mag%parent_fibre =>el
318    el%magp%parent_fibre=>el
319    !  end of added 2007.07.09
320
321
322    CALL SET_MADX_(f,f)
323
324    !    NSTD=NSTD0
325    !    METD=METD0
326    EXACT_MODEL=EXACT0
327    FIBRE_FLIP= FIBRE_FLIP0
328    FIBRE_DIR=FIBRE_DIR0
329    MAD=MAD0
330
331    !    IF(ASSOCIATED(EL%PREVIOUS)) THEN
332    !     if(.not.associated(EL%POS))allocate(EL%POS)
333    !     EL%POS=EL%PREVIOUS%POS+1
334    !    ELSE
335    !     if(.not.associated(EL%POS))allocate(EL%POS)
336    !     EL%POS=1
337    !    ENDIF
338    if(key%list%BEND_FRINGE) then
339       el%mag%p%bend_fringe=my_true
340       el%magp%p%bend_fringe=my_true
341    endif
342
343    if(el%mag%kind==kind4) then
344       el%mag%c4%CAVITY_TOTALPATH=key%list%CAVITY_TOTALPATH
345       el%magp%c4%CAVITY_TOTALPATH=key%list%CAVITY_TOTALPATH
346    endif
347
348  end subroutine create_fibre
349
350  subroutine zero_key(key)
351    implicit none
352
353    type(keywords) , intent(out):: key
354    key%magnet="CROTTE"
355    select case(MADTHICK)
356    CASE(drift_kick_drift)
357       key%model="DRIFT_KICK       "
358    CASE(matrix_kick_matrix)
359       key%model="MATRIX_KICK      "
360    CASE(kick_sixtrack_kick)
361       key%model="DELTA_MATRIX_KICK"
362    END SELECT
363
364
365    key%FIBRE_flip=FIBRE_flip
366    key%FIBRE_DIR=FIBRE_DIR
367    key%method=METD
368    key%nstep=NSTD
369    key%exact=EXACT_MODEL
370    key%madLENGTH=madLENGTH
371    key%LIST%NMUL = 1
372    key%mad8 = mad8
373    key%tiltd=0.0_dp
374    key%LIST=0
375
376  end subroutine zero_key
377
378  !  PRINTING FIBRES FOR FLAT FILES
379  subroutine print_COMPLEX_SINGLE_STRUCTURE(L,FILENAME,LMAX0,NL)
380    implicit none
381    character(*) filename
382    integer I,MF,N,n_l
383    type(LAYOUT), TARGET :: L
384    type(LAYOUT), pointer :: CL
385    REAL(DP),OPTIONAL :: LMAX0
386    integer,OPTIONAL :: NL
387
388    n_l=0
389    if(present(nl)) n_l=nl
390    call kanalnummer(mf)
391    open(unit=mf,file=filename)
392    IF(ASSOCIATED(L%DNA)) THEN
393       N=SIZE(L%DNA)
394       Write(mf,*) N,N_L, " Number of pointers in the DNA array pointed at layouts"
395
396       DO I=1,N
397          L%DNA(I)%L%INDEX=I
398          CALL print_LAYOUT(L%DNA(I)%L,FILENAME,LMAX0,MF)
399       ENDDO
400       !       ENDIF
401
402       !       write(mf,*) " Beam Line DNA structure "
403       !       do i=1,N
404       !        ncon1=0
405       !        ncon2=0
406       !        if(associated(L%DNA(i)%L%con1)) then
407       !         ncon1=size(L%DNA(i)%L%con1)
408       !         ncon2=size(L%DNA(i)%L%con2)
409       !          write(mf,*) ncon1,ncon2
410
411
412       !          do j=1,max(ncon1,ncon2)
413       !           if(j>ncon1) then
414       !             write(mf,*) 0, L%DNA(i)%L%con2(j)%pos
415       !            elseif(j>ncon2) then
416       !             write(mf,*)  L%DNA(i)%L%con1(j)%pos,0
417       !            else
418       !             write(mf,*)  L%DNA(i)%L%con1(j)%pos, L%DNA(i)%L%con2(j)%pos
419       !           endif
420       !          enddo
421       !        else
422       !          write(mf,*) ncon1,ncon2
423       !        endif
424       !      enddo
425
426       !       write(mf,*) " End of Beam Line DNA structure "
427
428    ENDIF
429
430    CL=>L
431
432
433    if(n_l>0) then
434       do i=1,n_l
435          ! write(mf,*) " Beam Line DNA structure "
436          ! write(mf,*) " End of Beam Line DNA structure "
437          CALL print_LAYOUT(CL,FILENAME,LMAX0,MF)
438          CL=>CL%NEXT
439       enddo
440    else
441       CALL print_LAYOUT(L,FILENAME,LMAX0,MF)
442    endif
443
444    CLOSE(MF)
445  END SUBROUTINE print_COMPLEX_SINGLE_STRUCTURE
446
447  subroutine print_LAYOUT(L,FILENAME,LMAX0,MFF)
448    implicit none
449    character(*) filename
450    integer I,MF,nmark
451    INTEGER, OPTIONAL :: MFF
452    type(LAYOUT), TARGET :: L
453    type(FIBRE), pointer :: P
454    REAL(DP),OPTIONAL :: LMAX0
455    character*255 line
456    logical(lp) print_temp
457nmark=0
458  if(.not.print_marker) then ! counting markers if not printing them
459    P=>L%START
460    DO I=1,L%N
461       if(.not.(print_marker.or.p%mag%kind/=kind0.or.i==1)) then 
462        nmark=nmark+1
463       endif
464       P=>P%NEXT
465    ENDDO
466    if(L%START%mag%kind==kind0) then
467        write(6,*) "Removing ",nmark, "markers (first 1.0_dp left in) "
468    else
469        write(6,*) "Removing ",nmark, "markers "
470    endif
471  endif  ! counting markers
472 
473    IF(PRESENT(MFF)) THEN
474       MF=MFF
475    ELSE
476       call kanalnummer(mf)
477       open(unit=mf,file=filename)
478    ENDIF
479
480    IF(PRESENT(LMAX0)) THEN
481       WRITE(MF,*) L%N-nmark, LMAX0, " NUMBER OF FIBRES AND L_MAX  "
482    ELSE
483       WRITE(MF,*) L%N-nmark, 0, " NUMBER OF FIBRES AND L_MAX  "
484    ENDIF
485    if(l%name(1:1)/=' ') then
486       write(MF,'(a17,a16)') " GLOBAL DATA FOR ",l%name
487    else
488       write(MF,*) " $$$$$$$$$ GLOBAL DATA  $$$$$$$$$"
489    endif
490
491    write(line,*) l%start%mass,L%START%mag%p%p0c,l%start%ag, " MASS, P0C, AG(spin)"
492    write(MF,'(a255)') line
493    write(line,*) phase0,compute_stoch_kick,l%start%charge, " PHASE0, compute_stoch_kick, CHARGE"
494    write(MF,'(a255)') line
495!     write(MF,*) phase0,compute_stoch_kick,l%start%charge, " PHASE0, compute_stoch_kick, CHARGE"
496    write(MF,*) CAVITY_TOTALPATH,ALWAYS_EXACTMIS,ALWAYS_EXACT_PATCHING, &
497         "CAVITY_TOTALPATH,ALWAYS_EXACTMIS,ALWAYS_EXACT_PATCHING"
498    write(line,*) SECTOR_NMUL_MAX,SECTOR_NMUL,&
499         OLD_IMPLEMENTATION_OF_SIXTRACK,HIGHEST_FRINGE,&
500         " SECTOR_NMUL_MAX,SECTOR_NMUL,OLD_IMPLEMENTATION_OF_SIXTRACK,HIGHEST_FRINGE"
501    write(mf,'(a255)')line
502    write(line,*) wedge_coeff,valishev, " wedge_coeff", " Valishev Multipole "
503    write(mf,'(a255)')line
504    write(MF,*) MAD8_WEDGE, " MAD8_WEDGE"
505    write(MF,*) " $$$$$$$ END GLOBAL DATA $$$$$$$$$$"
506
507
508    P=>L%START
509    DO I=1,L%N
510       if(i==1) then
511          print_temp=print_frame
512          print_frame=my_true
513       endif
514       
515       if(print_marker.or.p%mag%kind/=kind0.or.i==1) then 
516        CALL print_FIBRE(P,mf)
517       endif
518        if(i==1) then
519          print_frame=print_temp
520       endif
521       P=>P%NEXT
522    ENDDO
523
524    IF(.NOT.PRESENT(MFF)) CLOSE(MF)
525
526  END subroutine print_LAYOUT
527
528
529  subroutine READ_INTO_VIRGIN_LAYOUT(L,FILENAME,RING,LMAX0,mf1)
530    implicit none
531    character(*) filename
532    integer mf,I,N,RES,se1,se2
533    integer, optional :: mf1
534    type(LAYOUT), TARGET :: L
535    LOGICAL(LP), OPTIONAL :: RING
536    REAL(DP), OPTIONAL :: LMAX0
537    LOGICAL(LP) RING_IT,doneit
538    character*255 line
539    character*255 lineg
540    real(dp) p0c,MASSF,ag0
541    type(internal_state) original
542    logical ttt,uuu
543
544    RING_IT=MY_TRUE
545
546    IF(PRESENT(RING)) RING_IT=RING
547
548    if(present(mf1)) then
549       mf=mf1
550    else
551       call kanalnummer(mf)
552       open(unit=mf,file=filename,status='OLD',err=2001)
553    endif
554
555    IF(PRESENT(LMAX0)) then
556       READ(MF,*) N,LMAX0
557    ELSE
558       READ(MF,*) N
559    ENDIF
560    read(MF,'(a255)') line
561    call context(line)
562
563    if(index(line,"FOR")/=0) then
564       l%name=line(index(line,"FOR")+3:index(line,"FOR")+2+nlp)
565    endif
566    read(MF,'(A255)') lineg
567    res=INDEX (lineG, "AG(spin)")
568    IF(RES==0) THEN
569       read(lineg,*) MASSF,p0c
570       IF(ABS(MASSF-pmap)/PMAP<0.01E0_DP) THEN
571          A_PARTICLE=A_PROTON
572       ELSEIF(ABS(MASSF-pmae)/pmae<0.01E0_DP) THEN
573          A_PARTICLE=A_ELECTRON
574       ELSEIF(ABS(MASSF-pmaMUON)/pmaMUON<0.01E0_DP) THEN
575          A_PARTICLE=A_MUON
576       ENDIF
577    ELSE
578       read(lineg,*) MASSF,p0c,A_PARTICLE
579    ENDIF
580    ag0=A_PARTICLE
581    read(MF,*) phase0,compute_stoch_kick,initial_charge
582    read(MF,*) CAVITY_TOTALPATH,ALWAYS_EXACTMIS,ALWAYS_EXACT_PATCHING
583    read(MF,*) se1,se2,OLD_IMPLEMENTATION_OF_SIXTRACK,HIGHEST_FRINGE
584    call input_sector(se2,se1)
585
586    read(MF,'(A255)') lineg
587    res=INDEX (lineG, "Valishev")
588    IF(RES==0) THEN
589       read(lineg,*) wedge_coeff
590    ELSE
591       read(lineg,*) wedge_coeff,valishev
592    ENDIF
593
594    read(MF,*) MAD8_WEDGE
595    read(MF,'(a255)') line
596    original=default
597    if(allocated(s_b)) then
598       firsttime_coef=my_true
599       deallocate(s_b)
600    endif
601    !    L%MASS=MASSF
602    MASSF=MASSF/pmae
603    CALL MAKE_STATES(MASSF)
604    A_PARTICLE=ag0
605    default=original
606    call Set_madx(p0c=p0c)
607    DO I=1,N
608       CALL APPEND_CLONE(L,muonfactor=massf,charge=initial_charge)
609       CALL READ_FIBRE(L%END,mf)
610       CALL COPY(L%END%MAG,L%END%MAGP)
611    ENDDO
612
613    if(.not.present(mf1)) CLOSE(MF)
614
615    L%closed=RING_IT
616
617    doneit=my_true
618    call ring_l(L,doneit)
619    ! if(do_survey) call survey(L)
620
621    return
622
6232001 continue
624
625    Write(6,*) " File ",filename(1:len_trim(filename)) ," does not exist "
626
627  END subroutine READ_INTO_VIRGIN_LAYOUT
628
629  subroutine READ_AND_APPEND_VIRGIN_general(U,filename,RING,LMAX0)
630    implicit none
631    character(*) filename
632    integer  mf
633    type(MAD_UNIVERSE), TARGET :: U
634    LOGICAL(LP), OPTIONAL :: RING
635    REAL(DP), OPTIONAL :: LMAX0
636    character*120 line
637    integer res
638
639    res=0
640    call kanalnummer(mf)
641    open(unit=mf,file=filename,status='OLD',err=2001)
642    read(mf,'(a120)') line
643    res=INDEX (line, "DNA")
644    if(res/=0) res=1
645    close(mf)
646
647    if(res==1) then
648 
649       call read_COMPLEX_SINGLE_STRUCTURE(U,filename,RING,LMAX0)
650    else
651
652       call APPEND_EMPTY_LAYOUT(U)
653 
654       CALL READ_INTO_VIRGIN_LAYOUT(U%END,FILENAME,RING,LMAX0)
655       ! if(do_survey) call survey(u%end)
656    endif
657    do_survey=my_false
658    return
6592001 continue
660
661    Write(6,*) " File ",filename(1:len_trim(filename)) ," does not exist "
662
663  END subroutine READ_AND_APPEND_VIRGIN_general
664
665  subroutine READ_AND_APPEND_VIRGIN_LAYOUT(U,filename,RING,LMAX0,mf)
666    implicit none
667    character(*) filename
668    integer,optional:: mf
669    type(MAD_UNIVERSE), TARGET :: U
670    LOGICAL(LP), OPTIONAL :: RING
671    REAL(DP), OPTIONAL :: LMAX0
672
673
674    call APPEND_EMPTY_LAYOUT(U)
675
676    CALL READ_INTO_VIRGIN_LAYOUT(U%END,FILENAME,RING,LMAX0=LMAX0,mf1=MF)
677
678  END subroutine READ_AND_APPEND_VIRGIN_LAYOUT
679
680  subroutine print_FIBRE(m,mf)
681    implicit none
682    integer mf,siam_pos,siam_index,GIRD_POS,GIRD_index
683    type(FIBRE), pointer :: m
684    siam_pos=0
685    siam_index=0
686    GIRD_POS=0
687    GIRD_index=0
688    if(associated(m%mag%siamese)) then
689       siam_index=m%mag%siamese%parent_fibre%parent_layout%index
690       siam_pos=m%mag%siamese%parent_fibre%pos
691    endif
692    if(associated(m%mag%GIRDERS)) then
693       GIRD_index=m%mag%GIRDERS%parent_fibre%parent_layout%index
694       GIRD_POS=m%mag%GIRDERS%parent_fibre%pos
695    endif
696    WRITE(MF,*) " @@@@@@@@@@@@@@@@@@@@ FIBRE @@@@@@@@@@@@@@@@@@@@"
697    if(siam_index==0.AND.GIRD_index==0) then
698       WRITE(MF,'(A11,4(I4,1x))') " DIRECTION ", M%DIR, &
699            m%mag%parent_fibre%parent_layout%index,m%mag%parent_fibre%pos, &
700            m%mag%parent_fibre%parent_layout%n
701    else
702
703       WRITE(MF,'(A11,4(I4,1x),A16,4(I4,1x))') " DIRECTION ", M%DIR, &
704            m%mag%parent_fibre%parent_layout%index,m%mag%parent_fibre%pos, &
705            m%mag%parent_fibre%parent_layout%n," Siamese/Girder "         &
706            ,siam_pos,siam_index,GIRD_POS,GIRD_index
707    endif
708    CALL print_chart(m%CHART,mf)
709    CALL print_PATCH(m%PATCH,mf)
710    CALL print_element(M,M%MAG,mf)
711    WRITE(MF,*) " @@@@@@@@@@@@@@@@@@@@  END  @@@@@@@@@@@@@@@@@@@@"
712
713  END subroutine print_FIBRE
714
715  subroutine READ_FIBRE(m,mf)
716    implicit none
717    integer mf
718    type(FIBRE), pointer :: m
719    character*255 line
720    READ(MF,*) LINE
721    READ(MF,'(A11,I4)') LINE(1:11),M%DIR
722    CALL READ_chart(m%CHART,mf)
723    CALL READ_PATCH(m%PATCH,mf)
724    CALL READ_element(m,M%MAG,mf)
725    READ(MF,*) LINE
726
727  END subroutine READ_FIBRE
728
729  subroutine READ_FIBRE_2_lines(mf,DIR,index,pos,n,siam_index,siam_pos,gird_index,gird_pos)
730    implicit none
731    integer mf
732    character*255 line
733
734    integer DIR,index,pos,n,siam_index,siam_pos,gird_index,gird_pos
735    READ(MF,*) LINE
736    siam_index=0
737    siam_pos=0
738    gird_index=0
739    gird_pos=0
740    READ(MF,'(A11,4(I4,1x),A16,4(I4,1x))') LINE(1:11),DIR,index,pos,n, &
741         LINE(12:27),siam_pos,siam_index,gird_index,gird_pos
742    !    CALL READ_chart(m%CHART,mf)
743    !    CALL READ_PATCH(m%PATCH,mf)
744    !    CALL READ_element(M%MAG,mf)
745    !    READ(MF,*) LINE
746
747  END subroutine READ_FIBRE_2_lines
748
749  subroutine print_PATCH(m,mf)
750    implicit none
751    integer mf,i1,i2,i3
752    type(PATCH), pointer :: m
753    character*255 line
754
755    i1=M%PATCH
756    i2=M%energy
757    i3=M%time
758
759    IF(IABS(i1)+iabs(i2)+iabs(i3)/=0) then
760       WRITE(MF,*) " >>>>>>>>>>>>>>>>>> PATCH <<<<<<<<<<<<<<<<<<"
761       WRITE(MF,*) M%PATCH,M%ENERGY,M%TIME," patch,energy,time"
762       WRITE(MF,*) M%A_X1,M%A_X2,M%B_X1,M%B_X2," discrete 180 rotations"
763       WRITE(LINE,*) M%A_D,M%A_ANG,"  a_d, a_ang "
764       WRITE(MF,'(A255)') LINE
765       WRITE(LINE,*) M%B_D,M%B_ANG,"  b_d, b_ang "
766       WRITE(MF,'(A255)') LINE
767       WRITE(MF,*) M%A_T,M%B_T,"  time patches a_t and b_t "
768       WRITE(MF,*) " >>>>>>>>>>>>>>>>>>  END  <<<<<<<<<<<<<<<<<<"
769    else
770       WRITE(MF,*) " NO PATCH "
771    endif
772  END subroutine print_PATCH
773
774  subroutine READ_PATCH(m,mf)
775    implicit none
776    integer mf
777    type(PATCH), pointer :: m
778    character*255 line
779
780    READ(MF,*)LINE
781    if(index(line,"NO")==0) then
782       READ(MF,*) M%PATCH,M%ENERGY,M%TIME
783       READ(MF,*) M%A_X1,M%A_X2,M%B_X1,M%B_X2
784       READ(MF,*) M%A_D,M%A_ANG
785       READ(MF,*) M%B_D,M%B_ANG
786       READ(MF,*) M%A_T,M%B_T
787       READ(MF,*) LINE
788    endif
789
790  END subroutine READ_PATCH
791
792  subroutine print_chart(m,mf)
793    implicit none
794    integer mf,I
795    type(CHART), pointer :: m
796    character*255 line
797    real(dp) norm
798
799    norm=0.0_dp
800    do i=1,3
801       norm=abs(M%D_IN(i))+norm
802       norm=abs(M%ANG_IN(i))+norm
803       norm=abs(M%ANG_OUT(i))+norm
804       norm=abs(M%D_OUT(i))+norm
805    enddo
806    if(norm>0.0_dp.OR.print_frame) then
807       write(mf,*) " THIS IS A CHART THIS IS A CHART THIS IS A CHART THIS IS A CHART "
808       CALL print_magnet_frame(m%F,mf)
809       WRITE(LINE,*) M%D_IN,M%ANG_IN
810       WRITE(MF,'(A255)') LINE
811       WRITE(LINE,*) M%D_OUT,M%ANG_OUT
812       WRITE(MF,'(A255)') LINE
813       write(mf,*) " END OF A CHART  END OF A CHART  END OF A CHART  END OF A CHART  "
814    else
815       write(mf,*) " NO CHART "
816    endif
817  end subroutine print_chart
818
819  subroutine READ_chart(m,mf)
820    implicit none
821    integer mf
822    type(CHART), pointer :: m
823    character*60 line
824    READ(mf,*) LINE
825    if(index(line,"NO")==0) then
826       CALL READ_magnet_frame(m%F,mf)
827       READ(MF,*) M%D_IN,M%ANG_IN
828       READ(MF,*) M%D_OUT,M%ANG_OUT
829       READ(mf,*) LINE
830    else
831       do_survey=my_true
832    endif
833  end subroutine READ_chart
834
835
836  subroutine READ_chart_fake(mf)
837    implicit none
838    integer mf
839    character*60 line
840    type(magnet_frame), pointer :: f
841    real(dp) d1(3),d2(3)
842
843    call alloc(f)
844
845    READ(mf,*) LINE
846    if(index(line,"NO")==0) then
847       CALL READ_magnet_frame(F,mf)
848       READ(MF,*) d1,d2
849       READ(MF,*) d1,d2
850       READ(mf,*) LINE
851    else
852       do_survey=my_true
853    endif
854    call kill(f)
855  end subroutine READ_chart_fake
856
857
858  subroutine print_element(P,m,mf)
859    implicit none
860    integer mf,I
861    type(FIBRE), pointer :: P
862    type(element), pointer :: m
863    character*255 line
864    integer f0
865    f0=1
866
867    WRITE(MF,*) "$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ ELEMENT $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$"
868    if(m%vorname(1:1)==' ') then
869       WRITE(MF,*) M%KIND,M%NAME, ' NOVORNAME'
870    ELSE
871       WRITE(MF,*) M%KIND,M%NAME,' ',M%VORNAME
872    ENDIF
873    WRITE(MF,*) M%L,M%p%PERMFRINGE,M%MIS , " L,PERMFRINGE,MIS "
874    WRITE(LINE,*) M%FINT,M%HGAP,M%H1,M%H2, " FINT,HGAP,H1,H2 "
875    WRITE(MF,'(A255)') LINE
876    WRITE(LINE,*) 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0, " no more mis"
877    WRITE(MF,'(A255)') LINE
878    IF(ASSOCIATED(M%DELTA_E).and.ASSOCIATED(M%FREQ)) THEN
879       WRITE(MF,*) " CAVITY INFORMATION "
880       WRITE(LINE,*) M%VOLT, M%FREQ,M%PHAS,M%DELTA_E,M%LAG,M%THIN, " VOLT,FREQ, PHAS, DELTA_E, LAG, THIN"
881       WRITE(MF,'(A255)') LINE
882    ELSEIF(.not.ASSOCIATED(M%DELTA_E).and.ASSOCIATED(M%FREQ)) THEN
883       WRITE(MF,*) " HELICAL DIPOLE INFORMATION "
884       WRITE(LINE,*) M%FREQ,M%PHAS, " K_Z, PHAS"
885       WRITE(MF,'(A255)') LINE
886    ELSEIF(ASSOCIATED(M%VOLT)) THEN
887       WRITE(MF,*) " ELECTRIC SEPTUM INFORMATION "
888       WRITE(MF,*) M%VOLT,M%PHAS, "VOLT, PHAS(rotation angle) "
889    ELSE
890       WRITE(MF,*) " NO ELECTRIC ELEMENT INFORMATION "
891    ENDIF
892    IF(ASSOCIATED(M%B_SOL)) THEN
893       WRITE(MF,*)  " SOLENOID_PRESENT ",M%B_SOL, " B_SOL"
894    ELSE
895       WRITE(MF,*) " NO_SOLENOID_PRESENT ",0.0_dp
896    ENDIF
897    CALL print_magnet_chart(P,m%P,mf)
898    if(p%MAG%KIND==KIND7) then
899       f0=p%MAG%t7%f
900    endif
901    if(p%MAG%KIND==KIND2.and.p%MAG%p%method==2) then
902       f0=p%MAG%k2%f
903    endif
904    if(associated(p%MAG%K16)) then
905       if(p%MAG%K16%DRIFTKICK.and.p%MAG%p%method==2)  f0=p%MAG%K16%f
906    endif
907    if(associated(p%MAG%TP10)) then
908       if(p%MAG%TP10%DRIFTKICK.and.p%MAG%p%method==2) f0=p%MAG%TP10%f
909    endif
910    !    if(f0>0) then
911    !     Write(mf,*) f0," Internal Recutting "
912    !    endif
913    IF(ASSOCIATED(M%an)) THEN
914       do i=1,m%p%NMUL
915          write(line,*) m%bn(i),m%an(i),f0, "  BN AN %f ",I
916          write(mf,'(a255)') line
917       enddo
918    endif
919    call print_specific_element(m,mf)
920    WRITE(MF,*) "$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$   END   $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$"
921  end subroutine print_element
922
923  subroutine print_pancake(el,mf)
924    implicit none
925    type(pancake), pointer :: el
926    integer mf
927    character*120 filename
928
929    ifield_name=ifield_name+1
930    filename(1:8)="fieldmap"
931    write(filename(9:120),*) ifield_name
932    call context(filename)
933    filename=filename(1:len_trim(filename))//'.TXT'
934    call context(filename)
935    write(mf,*) filename
936    call print_pancake_field(el,filename)
937  end subroutine print_pancake
938
939
940  subroutine print_pancake_field(el,filename)
941    implicit none
942    type(pancake), pointer :: el
943    integer mf,nst,i,j
944    character(*) filename
945    real(dp) brho,cl
946    type(real_8) b(3)
947
948
949    call kanalnummer(mf)
950    open(unit=mf,file=filename)
951
952    nst=2*el%p%nst+1
953
954    cl=(clight/1e8_dp)
955    BRHO=el%p%p0c*10.0_dp/cl
956
957    call init(EL%B(1)%no,2)
958    CALL ALLOC(B)
959
960    write(mf,*) nst,el%p%ld,el%p%b0,EL%B(1)%no,my_false
961    do i=1,nst
962       B(1)=morph(1.0_dp.mono.1)
963       B(2)=morph(1.0_dp.mono.2)
964       B(3)=0.0_dp;
965       CALL trackg(EL%B(i),B)
966       do j=1,3
967          b(j)=b(j)*brho
968          call print(b(j),mf)
969       enddo
970
971    enddo
972    CALL kill(B)
973
974    close(mf)
975
976  end subroutine print_pancake_field
977
978
979
980
981  subroutine print_wig(el,mf)
982    implicit none
983    type(SAGAN), pointer :: el
984    integer mf
985    write(mf,*) el%internal
986    call print_undu_R(el%w,mf)
987  end subroutine print_wig
988
989  subroutine read_wig(el,mf)
990    implicit none
991    type(SAGAN), pointer :: el
992    integer mf
993    if(.not.associated(el%internal)) allocate(el%internal(3))
994    read(mf,*) el%internal
995    call read_undu_R(el%w,mf)
996  end subroutine read_wig
997
998  subroutine print_undu_R(el,mf)
999    implicit none
1000    type(undu_R), pointer :: el
1001    integer mf,n,i
1002    character*255 line
1003
1004    write(mf,*) " Undulator internal type undu_R"
1005    n=size(EL%FORM)
1006
1007    write(mf,*) n,EL%offset
1008    do i=1,n
1009       write(line,*) el%a(i),el%f(i),EL%FORM(i),EL%K(1:3,i)
1010       write(mf,'(a255)') line
1011    enddo
1012
1013    write(mf,*) " End of Undulator internal type undu_R"
1014
1015  end subroutine print_undu_R
1016
1017  subroutine read_undu_R(el,mf)
1018    implicit none
1019    type(undu_R), pointer :: el
1020    integer mf,n,i
1021    character*255 line
1022    real(dp) offset
1023
1024    read(mf,'(a255)') line
1025    read(mf,*) n,offset
1026    call INIT_SAGAN_POINTERS(EL,N)
1027    el%offset=offset
1028    do i=1,n
1029       read(mf,*) el%a(i),el%f(i),EL%FORM(i),EL%K(1:3,i)
1030    enddo
1031
1032    read(mf,'(a255)') line
1033
1034  end subroutine read_undu_R
1035
1036
1037  subroutine print_specific_element(el,mf)
1038    implicit none
1039    type(element), pointer :: el
1040    integer mf,i
1041    character*255 line
1042
1043    select case(el%kind)
1044    CASE(KIND0,KIND1,kind2,kind5,kind6,kind7,kind8,kind9,KIND11:KIND15,kind17,KIND22)
1045    case(kind3)
1046       WRITE(LINE,*) el%k3%thin_h_foc,el%k3%thin_v_foc,el%k3%thin_h_angle,el%k3%thin_v_angle," patch_edge_ls ",&
1047            el%k3%patch,el%k3%hf,el%k3%vf,el%k3%ls
1048       WRITE(MF,'(A255)') LINE
1049    case(kind4)
1050       WRITE(line,*) el%c4%N_BESSEL, " HARMON ",el%c4%NF," constant&ripple ",el%c4%a,el%c4%r,el%c4%always_on
1051       WRITE(MF,'(A255)') LINE
1052       WRITE(MF,*) el%c4%t,el%c4%phase0,el%c4%CAVITY_TOTALPATH
1053       do i=1,el%c4%NF
1054          write(mf,*) el%c4%f(i),el%c4%ph(i)
1055       enddo
1056    case(kind10)
1057       WRITE(MF,*) el%tp10%DRIFTKICK,  " driftkick "
1058    case(kind16,kind20)
1059       WRITE(MF,*) el%k16%DRIFTKICK,el%k16%LIKEMAD, " driftkick,likemad"
1060    case(kind18)
1061!       WRITE(MF,*) " RCOLLIMATOR HAS AN INTRINSIC APERTURE "
1062!       CALL print_aperture(EL%RCOL18%A,mf)
1063    case(kind19)
1064 !      WRITE(MF,*) " ECOLLIMATOR HAS AN INTRINSIC APERTURE "
1065 !      CALL print_aperture(EL%ECOL19%A,mf)
1066    case(kind21)
1067       WRITE(MF,*) el%cav21%PSI,el%cav21%DPHAS,el%cav21%DVDS
1068    case(KINDWIGGLER)
1069       call print_wig(el%wi,mf)
1070    case(KINDpa)
1071       call print_pancake(el%pa,mf)
1072    case default
1073       write(6,*) " not supported in print_specific_element",el%kind
1074       stop 101
1075    end select
1076
1077  end subroutine print_specific_element
1078
1079  subroutine read_specific_element(el,mf)
1080    implicit none
1081    type(element), pointer :: el
1082    integer mf,NB,NH,i,i1
1083    CHARACTER*6 HARMON
1084    CHARACTER*15 rip
1085    character*255 line
1086    real(dp) x1,x2,x3,x4
1087    logical(lp) always_on
1088    select case(el%kind)
1089    CASE(KIND0,KIND1,kind2,kind5,kind6,kind7,kind8,kind9,KIND11:KIND15,kind17,kind22)
1090       CALL SETFAMILY(EL)   ! POINTERS MUST BE ESTABLISHED BETWEEN GENERIC ELEMENT M AND SPECIFIC ELEMENTS
1091    case(kind3)
1092       IF(.NOT.ASSOCIATED(el%B_SOL)) then
1093          ALLOCATE(el%B_SOL)
1094          el%B_SOL=0.0_dp
1095       endif
1096       CALL SETFAMILY(EL)   ! POINTERS MUST BE ESTABLISHED BETWEEN GENERIC ELEMENT M AND SPECIFIC ELEMENTS
1097       READ(MF,"(a255)") LINE
1098       if(index(line,"patch_edge_ls")/=0) then
1099          read(line,*) el%k3%thin_h_foc,el%k3%thin_v_foc,el%k3%thin_h_angle,el%k3%thin_v_angle &
1100               ,rip,el%k3%patch,el%k3%hf,el%k3%vf,el%k3%ls
1101       elseif(index(line,"patch_edge")/=0) then
1102          read(line,*) el%k3%thin_h_foc,el%k3%thin_v_foc,el%k3%thin_h_angle,el%k3%thin_v_angle &
1103               ,rip,el%k3%patch,el%k3%hf,el%k3%vf
1104       elseif(index(line,"patch")/=0) then
1105          read(line,*) el%k3%thin_h_foc,el%k3%thin_v_foc,el%k3%thin_h_angle,el%k3%thin_v_angle &
1106               ,harmon,el%k3%patch
1107       else
1108          read(line,*) el%k3%thin_h_foc,el%k3%thin_v_foc,el%k3%thin_h_angle,el%k3%thin_v_angle
1109       endif
1110    case(kind4)
1111       NB=0
1112       NH=0
1113       x3=0.0_dp
1114       x4=1.0_dp
1115       READ(MF,'(a255)') LINE
1116
1117       IF(INDEX(LINE, 'HARMON')/=0) THEN
1118          if(INDEX(LINE, 'ripple')/=0) then
1119             read(LINE,*) NB,HARMON,NH,rip,x3,x4,always_on
1120          else
1121             read(LINE,*) NB,HARMON,NH
1122          endif
1123          if(nh>N_CAV4_F) then
1124             N_CAV4_F=NH
1125          endif
1126          read(MF,*) x1,x2,i1
1127       ELSE
1128          read(LINE,*) NB
1129          x1=0.0_dp
1130          x2=c_%phase0
1131          i1=CAVITY_TOTALPATH
1132       ENDIF
1133       CALL SETFAMILY(EL)   ! POINTERS MUST BE ESTABLISHED BETWEEN GENERIC ELEMENT M AND SPECIFIC ELEMENTS
1134       el%c4%N_BESSEL=NB
1135       N_CAV4_F=1
1136       do i=1,nh
1137          read(mf,*) el%c4%f(i),el%c4%ph(i)
1138       enddo
1139       el%c4%t=x1
1140       el%c4%phase0=x2
1141       el%c4%a=x3
1142       el%c4%r=x4
1143       el%c4%CAVITY_TOTALPATH=i1
1144       el%c4%always_on=always_on
1145    case(kind10)
1146       CALL SETFAMILY(EL)   ! POINTERS MUST BE ESTABLISHED BETWEEN GENERIC ELEMENT M AND SPECIFIC ELEMENTS
1147       read(MF,*) el%tp10%DRIFTKICK
1148    case(kind16,kind20)
1149       CALL SETFAMILY(EL)   ! POINTERS MUST BE ESTABLISHED BETWEEN GENERIC ELEMENT M AND SPECIFIC ELEMENTS
1150       read(MF,*) el%k16%DRIFTKICK,el%k16%LIKEMAD
1151    case(kind18)
1152       CALL SETFAMILY(EL)   ! POINTERS MUST BE ESTABLISHED BETWEEN GENERIC ELEMENT M AND SPECIFIC ELEMENTS
1153  !     READ(MF,*) LINE
1154  !     CALL READ_aperture(EL%RCOL18%A,mf)
1155    case(kind19)
1156       CALL SETFAMILY(EL)   ! POINTERS MUST BE ESTABLISHED BETWEEN GENERIC ELEMENT M AND SPECIFIC ELEMENTS
1157    !   READ(MF,*) LINE
1158    !   CALL READ_aperture(EL%ECOL19%A,mf)
1159    case(kind21)
1160       CALL SETFAMILY(EL)   ! POINTERS MUST BE ESTABLISHED BETWEEN GENERIC ELEMENT M AND SPECIFIC ELEMENTS
1161       read(MF,*) el%cav21%PSI,el%cav21%DPHAS,el%cav21%DVDS
1162    case(KINDWIGGLER)
1163       CALL SETFAMILY(EL)   ! POINTERS MUST BE ESTABLISHED BETWEEN GENERIC ELEMENT M AND SPECIFIC ELEMENTS
1164       call read_wig(el%wi,mf)
1165    case(KINDpa)
1166       call read_pancake(el,mf)  ! SET FAMILY DONE INSIDE
1167    case default
1168       write(6,*) " not supported in read_specific_element"
1169       stop 102
1170    end select
1171
1172  end subroutine read_specific_element
1173
1174  subroutine read_pancake(el,mf)
1175    implicit none
1176    type(ELEMENT), pointer :: el
1177    integer mf
1178    character*120 filename
1179    read(mf,*) filename
1180    call context(filename)
1181
1182    call read_pancake_field(el,filename)
1183  end subroutine read_pancake
1184
1185
1186  subroutine read_pancake_field(el,filename)
1187    implicit none
1188    type(ELEMENT), pointer :: el
1189    integer mf,nst,ORDER,I
1190    real(dp)  L,hc,cl,BRHO
1191    logical(lp) REPEAT
1192    character(*) filename
1193    TYPE(TAYLOR) B(3)
1194    type(tree_element), allocatable :: t_e(:)
1195
1196    cl=(clight/1e8_dp)
1197    BRHO=el%p%p0c*10.0_dp/cl
1198
1199
1200    call kanalnummer(mf)
1201    open(unit=mf,file=filename)
1202    read(mf,*) nst,L,hc, ORDER,REPEAT
1203    CALL INIT(ORDER,2)
1204    CALL ALLOC(B)
1205    ALLOCATE(T_E(NST))
1206    DO I=1,NST
1207       CALL READ(B(1),mf);CALL READ(B(2),mf);CALL READ(B(3),mf);
1208       B(1)=B(1)/BRHO
1209       B(2)=B(2)/BRHO
1210       B(3)=B(3)/BRHO
1211       CALL SET_TREE_g(T_E(i),B)
1212    ENDDO
1213    close(mf)
1214    CALL KILL(B)
1215    CALL SETFAMILY(EL,t=T_E)  !,T_ax=T_ax,T_ay=T_ay)
1216    deallocate(T_E)
1217
1218  end subroutine read_pancake_field
1219
1220  subroutine READ_element(p,m,mf)
1221    implicit none
1222    integer mf,I
1223    type(fibre), pointer :: p
1224    type(element), pointer :: m
1225    character*120 line
1226    character*255 linet
1227    CHARACTER*21 SOL
1228    REAL(DP) B_SOL,r(3),d(3)
1229    integer f0
1230    f0=0
1231    READ(MF,*) LINE
1232    READ(MF,*) M%KIND,M%NAME,M%VORNAME
1233    CALL CONTEXT(M%NAME);
1234    CALL CONTEXT(M%VORNAME);
1235    IF(M%VORNAME(1:9)=='NOVORNAME') M%VORNAME=' '
1236
1237    READ(MF,*) M%L,M%p%PERMFRINGE,M%MIS  !,M%EXACTMIS
1238    READ(MF,*) M%FINT,M%HGAP,M%H1,M%H2
1239    READ(MF,*) R,D
1240    READ(MF,*) LINE
1241    CALL CONTEXT(LINE)
1242    IF(LINE(1:1)=='C') THEN
1243       IF(.NOT.ASSOCIATED(M%VOLT)) ALLOCATE(M%VOLT)
1244       IF(.NOT.ASSOCIATED(M%FREQ)) ALLOCATE(M%FREQ)
1245       IF(.NOT.ASSOCIATED(M%PHAS)) ALLOCATE(M%PHAS)
1246       IF(.NOT.ASSOCIATED(M%DELTA_E))ALLOCATE(M%DELTA_E)
1247       IF(.NOT.ASSOCIATED(M%LAG))   ALLOCATE(M%LAG)
1248       IF(.NOT.ASSOCIATED(M%THIN))  ALLOCATE(M%THIN)
1249       READ(MF,*) M%VOLT, M%FREQ,M%PHAS,M%DELTA_E,M%LAG,M%THIN
1250    ELSEIF(LINE(1:1)=='H') THEN
1251       IF(.NOT.ASSOCIATED(M%FREQ)) ALLOCATE(M%FREQ)
1252       IF(.NOT.ASSOCIATED(M%PHAS)) ALLOCATE(M%PHAS)
1253       READ(MF,*) M%FREQ,M%PHAS
1254    ELSEIF(LINE(1:1)=='E') THEN
1255       IF(.NOT.ASSOCIATED(M%VOLT)) ALLOCATE(M%VOLT)
1256       IF(.NOT.ASSOCIATED(M%PHAS)) ALLOCATE(M%PHAS)
1257       READ(MF,*) M%VOLT, M%PHAS
1258    ENDIF
1259    READ(mf,*) SOL,B_SOL
1260    CALL CONTEXT(SOL)
1261    IF(SOL(1:2)=='SO') THEN
1262       IF(.NOT.ASSOCIATED(M%B_SOL))ALLOCATE(M%B_SOL)
1263       M%B_SOL=B_SOL
1264    ENDIF
1265    CALL  READ_magnet_chart(p,m%P,mf)
1266
1267    !     Write(mf,*) f0," Internal Recutting "
1268    IF(M%P%NMUL/=0) THEN
1269       IF(.NOT.ASSOCIATED(M%AN)) THEN
1270          ALLOCATE(M%AN(M%P%NMUL))
1271          ALLOCATE(M%BN(M%P%NMUL))
1272       ELSE
1273          DEALLOCATE(M%AN)
1274          DEALLOCATE(M%BN)
1275          ALLOCATE(M%AN(M%P%NMUL))
1276          ALLOCATE(M%BN(M%P%NMUL))
1277       ENDIF
1278       !     write(6,*) M%KIND,M%NAME,M%VORNAME
1279
1280       !     write(6,*) M%P%NMUL
1281       !          READ(MF,'(a120)') LINE
1282       !     write(6,'(a120)') line
1283       !     pause 1
1284       do i=1,m%p%NMUL
1285          READ(MF,'(A255)') LINEt
1286          if(index(LINEt,"%f")==0 ) then
1287             READ(linet,*) m%bn(i),m%an(i)
1288          else
1289             READ(linet,*) m%bn(i),m%an(i),f0
1290          endif
1291          !          READ(mf,*) m%bn(i),m%an(i),f0
1292       enddo
1293    endif
1294    call read_specific_element(m,mf)
1295
1296    READ(MF,*) LINE
1297
1298    if(f0>0) then
1299       if(p%MAG%KIND==KIND7) then
1300          p%MAG%t7%f=f0
1301       endif
1302       if(p%MAG%KIND==KIND2.and.p%MAG%p%method==2) then
1303          p%MAG%k2%f=f0
1304       endif
1305       if(associated(p%MAG%K16)) then
1306          if(p%MAG%K16%DRIFTKICK.and.p%MAG%p%method==2)  p%MAG%K16%f=f0
1307       endif
1308       if(associated(p%MAG%TP10)) then
1309          if(p%MAG%TP10%DRIFTKICK.and.p%MAG%p%method==2) p%MAG%TP10%f=f0
1310       endif
1311    endif
1312
1313  end subroutine READ_element
1314
1315
1316  subroutine READ_fake_element(p,mf)
1317    implicit none
1318    integer mf,I
1319    type(fibre),pointer ::  p
1320    type(fibre),pointer ::  f
1321    type(element),pointer ::  m
1322    character*120 line
1323    CHARACTER*21 SOL
1324    REAL(DP) B_SOL,r(3),d(3)
1325    nullify(m)
1326    call alloc(f)
1327    m=>f%mag
1328    !    m=0
1329    READ(MF,*) LINE
1330    READ(MF,*) M%KIND,M%NAME,M%VORNAME
1331    CALL CONTEXT(M%NAME);
1332    CALL CONTEXT(M%VORNAME);
1333    IF(M%VORNAME(1:9)=='NOVORNAME') M%VORNAME=' '
1334
1335    READ(MF,*) M%L,M%p%PERMFRINGE,M%MIS   !,M%EXACTMIS
1336    READ(MF,*) M%FINT,M%HGAP,M%H1,M%H2
1337    READ(MF,*) R,D
1338    READ(MF,*) LINE
1339    CALL CONTEXT(LINE)
1340    IF(LINE(1:1)=='C') THEN
1341       IF(.NOT.ASSOCIATED(M%VOLT)) ALLOCATE(M%VOLT)
1342       IF(.NOT.ASSOCIATED(M%FREQ)) ALLOCATE(M%FREQ)
1343       IF(.NOT.ASSOCIATED(M%PHAS)) ALLOCATE(M%PHAS)
1344       IF(.NOT.ASSOCIATED(M%DELTA_E))ALLOCATE(M%DELTA_E)
1345       IF(.NOT.ASSOCIATED(M%LAG))   ALLOCATE(M%LAG)
1346       IF(.NOT.ASSOCIATED(M%THIN))  ALLOCATE(M%THIN)
1347       READ(MF,*) M%VOLT, M%FREQ,M%PHAS,M%DELTA_E,M%LAG,M%THIN
1348    ELSEIF(LINE(1:1)=='E') THEN
1349       IF(.NOT.ASSOCIATED(M%VOLT)) ALLOCATE(M%VOLT)
1350       IF(.NOT.ASSOCIATED(M%PHAS)) ALLOCATE(M%PHAS)
1351       READ(MF,*) M%VOLT, M%PHAS
1352    ENDIF
1353    READ(mf,*) SOL,B_SOL
1354    CALL CONTEXT(SOL)
1355    IF(SOL(1:2)=='SO') THEN
1356       IF(.NOT.ASSOCIATED(M%B_SOL))ALLOCATE(M%B_SOL)
1357       M%B_SOL=B_SOL
1358    ENDIF
1359    CALL  READ_magnet_chart(p,m%P,mf)
1360    IF(M%P%NMUL/=0) THEN
1361       IF(.NOT.ASSOCIATED(M%AN)) THEN
1362          ALLOCATE(M%AN(M%P%NMUL))
1363          ALLOCATE(M%BN(M%P%NMUL))
1364       ELSE
1365          DEALLOCATE(M%AN)
1366          DEALLOCATE(M%BN)
1367          ALLOCATE(M%AN(M%P%NMUL))
1368          ALLOCATE(M%BN(M%P%NMUL))
1369       ENDIF
1370       !     write(6,*) M%KIND,M%NAME,M%VORNAME
1371
1372       !     write(6,*) M%P%NMUL
1373       !          READ(MF,'(a120)') LINE
1374       !     write(6,'(a120)') line
1375       !     pause 1
1376       do i=1,m%p%NMUL
1377          READ(mf,*) m%bn(i),m%an(i)
1378       enddo
1379    endif
1380    call read_specific_element(m,mf)
1381
1382    READ(MF,*) LINE
1383
1384    !          m=-1;
1385    call SUPER_zero_fibre(f,-1)
1386    !          deallocate(m);
1387
1388  end subroutine READ_fake_element
1389
1390  subroutine print_magnet_chart(P,m,mf)
1391    implicit none
1392    type(FIBRE), pointer :: P
1393    type(magnet_chart), pointer :: m
1394    integer mf
1395    character*200 line
1396
1397    WRITE(MF,*) "MAGNET CHART MAGNET CHART MAGNET CHART MAGNET CHART MAGNET CHART MAGNET CHART "
1398    WRITE(MF,*) M%EXACT,M%METHOD,M%NST,M%NMUL, " EXACT METHOD NST NMUL"
1399    WRITE(line,*) M%LD, M%LC, M%B0,' TILT= ',M%TILTD, " LD LC B0 "
1400    WRITE(MF,'(A200)') LINE
1401    WRITE(LINE,*) P%BETA0,P%GAMMA0I, P%GAMBET, M%P0C, " BETA0 GAMMA0I GAMBET P0C"
1402    WRITE(MF,'(A200)') LINE
1403    WRITE(MF,*) M%EDGE, " EDGES"
1404    WRITE(MF,*) M%KILL_ENT_FRINGE,M%KILL_EXI_FRINGE,M%bend_fringe, " Kill_ent_fringe, kill_exi_fringe, bend_fringe "
1405
1406    CALL print_magnet_frame(m%F,mf)
1407    CALL print_aperture(m%APERTURE,mf)
1408    write(mf,'(a68)') "END MAGNET CHART END MAGNET CHART END MAGNET CHART END MAGNET CHART "
1409  end subroutine print_magnet_chart
1410
1411  subroutine READ_magnet_chart(p,m,mf)
1412    implicit none
1413    type(fibre), pointer :: p
1414    type(magnet_chart), pointer :: m
1415    integer mf
1416    character*200 line
1417    character*5 til
1418    real(dp) BETA0,GAMMA0I, GAMBET
1419
1420
1421    READ(MF,*) LINE
1422    READ(MF,*) M%EXACT,M%METHOD,M%NST,M%NMUL
1423    READ(MF,'(A200)') LINE
1424
1425    if(index(line,"TILT=")/=0) then
1426       READ(LINE,*) M%LD, M%LC, M%B0,til,M%tiltd
1427    else
1428       READ(LINE,*) M%LD, M%LC, M%B0
1429       M%tiltd=0.0_dp
1430    endif
1431
1432
1433    READ(MF,*)BETA0,GAMMA0I, GAMBET, M%P0C
1434    READ(MF,*) M%EDGE
1435    READ(MF,*) M%KILL_ENT_FRINGE,M%KILL_EXI_FRINGE,M%bend_fringe
1436
1437    CALL READ_magnet_frame(m%F,mf)
1438    CALL READ_aperture(m%APERTURE,mf)
1439    READ(MF,*) LINE
1440    p%BETA0=beta0
1441    p%GAMBET=GAMBET
1442    p%GAMMA0I=GAMMA0I
1443    !    p%P0C=M%P0C
1444    !    M%BETA0 =>p%BETA0
1445    !    M%GAMMA0I => p%GAMMA0I
1446    !    M%GAMBET => p%GAMBET
1447
1448  end subroutine READ_magnet_chart
1449
1450  subroutine print_magnet_frame(m,mf)
1451    implicit none
1452    type(magnet_frame), pointer :: m
1453    integer mf,i
1454    if(print_frame) then
1455       write(mf,'(a72)') "MAGNET FRAME MAGNET FRAME MAGNET FRAME MAGNET FRAME MAGNET FRAME MAGNET FRAME "
1456       WRITE(MF,*) m%a
1457       do i=1,3
1458          WRITE(MF,*) m%ent(i,1:3)
1459       enddo
1460       WRITE(MF,*) m%o
1461       do i=1,3
1462          WRITE(MF,*) m%mid(i,1:3)
1463       enddo
1464       WRITE(MF,*) m%b
1465       do i=1,3
1466          WRITE(MF,*) m%exi(i,1:3)
1467       enddo
1468       write(mf,'(a68)') "END MAGNET FRAME END MAGNET FRAME END MAGNET FRAME END MAGNET FRAME "
1469    else
1470       write(mf,'(a72)') " NO MAGNET FRAME NO MAGNET FRAME NO MAGNET FRAME NO MAGNET FRAME NO MAGNET    "
1471    endif
1472  end subroutine print_magnet_frame
1473
1474  subroutine read_magnet_frame(m,mf)
1475    implicit none
1476    type(magnet_frame), pointer :: m
1477    integer mf,i
1478    character*120 line
1479
1480    read(mf,'(a120)') line
1481
1482    if(index(line,"NO")==0) then
1483
1484       read(MF,*) m%a
1485       do i=1,3
1486          read(MF,*) m%ent(i,1:3)
1487       enddo
1488       read(MF,*) m%o
1489       do i=1,3
1490          read(MF,*) m%mid(i,1:3)
1491       enddo
1492       read(MF,*) m%b
1493       do i=1,3
1494          read(MF,*) m%exi(i,1:3)
1495       enddo
1496       read(mf,'(a120)') line
1497    else
1498       do_survey=my_true
1499    endif
1500  end subroutine read_magnet_frame
1501
1502  subroutine print_aperture(m,mf)
1503    implicit none
1504    type(MADX_APERTURE), pointer :: m
1505    integer mf
1506    character*200 line
1507
1508    IF(.NOT.ASSOCIATED(M)) THEN
1509       write(mf,'(a20)') " NO MAGNET APERTURE "
1510    ELSE
1511       write(mf,'(a21)') " HAS MAGNET APERTURE "
1512       WRITE(MF,*) m%KIND   ! 1,2,3,4
1513       WRITE(MF,*) m%R
1514       WRITE(line,*)  m%X,m%Y,' SHIFT ',m%dX,m%dY
1515       WRITE(MF,'(A200)') LINE
1516       write(mf,'(a23)')  " END OF MAGNET APERTURE"
1517    ENDIF
1518
1519  end subroutine print_aperture
1520
1521
1522  subroutine READ_aperture(m,mf)
1523    implicit none
1524    type(MADX_APERTURE), pointer :: m
1525    integer mf
1526    character*200 line
1527    character*5 ch
1528
1529    !    READ(mf,'(a120)') LINE(1:120)
1530    READ(mf,'(a120)') LINE
1531
1532    CALL CONTEXT(LINE)
1533
1534    IF(LINE(1:2)/='NO') THEN
1535       IF(.NOT.ASSOCIATED(M)) THEN
1536          CALL alloc(M)
1537       ENDIF
1538
1539       READ(MF,*) m%KIND   ! 1,2,3,4
1540       READ(MF,*) m%R
1541       read(mf,'(a200)') line
1542       if(index(line,"SHIFT")==0) then
1543          READ(line,*) m%X,m%Y
1544       else
1545          READ(line,*) m%X,m%Y,ch,m%dX,m%dY
1546       endif
1547       READ(mf,'(a120)') LINE(1:120)
1548    ENDIF
1549
1550  end subroutine READ_aperture
1551
1552!!!!!
1553
1554  SUBROUTINE change_fibre(p)
1555    IMPLICIT NONE
1556    INTEGER MF
1557    TYPE(FIBRE), POINTER :: P
1558
1559    CALL KANALNUMMER(MF)
1560
1561    OPEN(UNIT=MF,FILE='JUNK_CHANGE_FIBRE.TXT')
1562
1563    CALL print_FIBRE(P,mf)
1564    P=-1
1565    REWIND MF
1566    CALL alloc_fibre( P )
1567    CALL READ_FIBRE(P,mf)
1568
1569
1570    CLOSE(MF)
1571  END SUBROUTINE change_fibre
1572
1573!!!!!!!!!!  pointed at layout !!!!!!!!!!!!!!
1574  subroutine read_COMPLEX_SINGLE_STRUCTURE(U,filename,RING,LMAX0)
1575    implicit none
1576    character(*) filename
1577    integer mf,n,i,n_l,J
1578    type(MAD_UNIVERSE), TARGET :: U
1579    type(layout), pointer :: L
1580    LOGICAL(LP), OPTIONAL :: RING
1581    REAL(DP), OPTIONAL :: LMAX0
1582
1583    call kanalnummer(mf)
1584    open(unit=mf,file=filename,status='OLD',err=2001)
1585
1586
1587    read(mf,*) n,n_l
1588    write(6,*) n,n_l
1589    do i=1,n
1590       call READ_AND_APPEND_VIRGIN_LAYOUT(U,filename,RING,LMAX0,mf)
1591       if(i==1) L=>U%end
1592       write(6,*) " read layout ", i
1593       write(6,*) U%end%name
1594    enddo
1595    do i=1,n_l
1596       call APPEND_EMPTY_LAYOUT(U)
1597       allocate(U%END%DNA(N))
1598       U%END%DNA(1)%L=>L
1599       U%END%DNA(1)%counter=0
1600       DO J=2,N
1601          U%END%DNA(J)%L=>U%END%DNA(J-1)%L%NEXT
1602          U%END%DNA(j)%counter=0
1603       ENDDO
1604
1605       !   read(mf,'(a120)') line
1606       WRITE(6,*) "LAYOUT ",I
1607       !   WRITE(6,*) LINE
1608       !       do k=1,N
1609       !        read(mf,*) ncon1,ncon2
1610       !        if(ncon1/=0) then
1611       !          allocate(U%END%DNA(k)%L%con1(ncon1))
1612       !          allocate(U%END%DNA(k)%L%con2(ncon2))
1613       !          U%END%DNA(k)%L%con1(1:ncon1)%POS=0
1614       !          U%END%DNA(k)%L%con2(1:ncon2)%POS=0
1615       !        else
1616       !          nullify(U%END%DNA(k)%L%con1)
1617       !          nullify(U%END%DNA(k)%L%con2)
1618       !       endif
1619
1620       !          do j=1,max(ncon1,ncon2)
1621       !            READ(MF,*) POS1,POS2
1622       !           IF(POS1/=0) U%END%DNA(k)%L%con1(J)%POS=POS1
1623       !           IF(POS2/=0) U%END%DNA(k)%L%con2(J)%POS=POS2
1624       !         enddo
1625
1626       !       enddo
1627       !   read(mf,'(a120)') line
1628
1629       !   WRITE(6,*) I
1630       !   WRITE(6,*) LINE
1631
1632
1633       CALL READ_pointed_INTO_VIRGIN_LAYOUT(U%END,FILENAME,RING,LMAX0,mf1=MF)
1634
1635       !     do k=1,N
1636       !      DO J=1,SIZE(U%END%DNA(k)%L%con1)
1637       !        CALL MOVE_TO(U%END,P,U%END%DNA(k)%L%CON1(J)%POS)
1638       !        U%END%DNA(k)%L%CON1(J)%P=>P
1639       !     ENDDO
1640       !     DO J=1,SIZE(U%END%DNA(k)%L%con2)
1641       !       CALL MOVE_TO(U%END,P,U%END%DNA(k)%L%CON2(J)%POS)
1642       !       U%END%DNA(k)%L%CON2(J)%P=>P
1643       !     ENDDO
1644       !    ENDDO
1645
1646    enddo
1647
1648    close(mf)
1649
1650
1651
1652    return
16532001 continue
1654
1655    Write(6,*) " File ",filename(1:len_trim(filename)) ," does not exist "
1656
1657  END subroutine read_COMPLEX_SINGLE_STRUCTURE
1658
1659  ! MAKES NOT SENSE BECAUSE DNA ARRAY NOT PROVIDED!
1660  !  subroutine READ_pointed_AND_APPEND_VIRGIN_LAYOUT(U,filename,RING,mf)
1661  !    implicit none
1662  !    character(*) filename
1663  !    integer,optional :: mf
1664  !    type(MAD_UNIVERSE), TARGET :: U
1665  !    LOGICAL(LP), OPTIONAL :: RING
1666
1667
1668  !    call APPEND_EMPTY_LAYOUT(U)
1669
1670  !    CALL READ_pointed_INTO_VIRGIN_LAYOUT(U%END,FILENAME,RING,mf)
1671
1672  !  END subroutine READ_pointed_AND_APPEND_VIRGIN_LAYOUT
1673
1674  subroutine READ_pointed_INTO_VIRGIN_LAYOUT(L,FILENAME,RING,LMAX0,mf1)
1675    implicit none
1676    character(*) filename
1677    integer I,mf,N,DIR,index_,pos,nt,siam_index,siam_pos,gird_index,gird_pos
1678    type(LAYOUT), TARGET :: L
1679    type(FIBRE), pointer :: P,current,siam,gird
1680    LOGICAL(LP), OPTIONAL :: RING
1681    REAL(DP), OPTIONAL :: LMAX0
1682    LOGICAL(LP) RING_IT,doneit
1683    character*120 line
1684    character*255 lineg
1685    real(dp) p0c,MASSF,LMAX0t,ag0
1686    type(internal_state) original
1687    integer,optional :: mf1
1688    integer res
1689    integer se1,se2
1690
1691    RING_IT=MY_TRUE
1692
1693    IF(PRESENT(RING)) RING_IT=RING
1694
1695    if(present(mf1) ) then
1696       mf=mf1
1697    else
1698       call kanalnummer(mf)
1699       open(unit=mf,file=filename,status='OLD',err=2001)
1700    endif
1701
1702    READ(MF,*) N,LMAX0t
1703    write(6,*) N,LMAX0t
1704    IF(PRESENT(LMAX0)) then
1705       if(LMAX0t/=0.0_dp) LMAX0=LMAX0T
1706    ENDIF
1707    read(MF,'(a120)') line
1708    call context(line)
1709    write(6,*) line
1710
1711    if(index(line,"FOR")/=0) then
1712       l%name=line(index(line,"FOR")+3:index(line,"FOR")+2+nlp)
1713    endif
1714
1715    read(MF,'(A255)') lineg
1716    res=INDEX (lineG, "AG(spin)")
1717    IF(RES==0) THEN
1718       read(lineg,*) MASSF,p0c
1719       IF(ABS(MASSF-pmap)/PMAP<0.01E0_DP) THEN
1720          A_PARTICLE=A_PROTON
1721       ELSEIF(ABS(MASSF-pmae)/pmae<0.01E0_DP) THEN
1722          A_PARTICLE=A_ELECTRON
1723       ELSEIF(ABS(MASSF-pmaMUON)/pmaMUON<0.01E0_DP) THEN
1724          A_PARTICLE=A_MUON
1725       ENDIF
1726    ELSE
1727       read(lineg,*) MASSF,p0c,A_PARTICLE
1728    ENDIF
1729    ag0=A_PARTICLE
1730
1731    !    read(MF,*) MASSF,p0c
1732    read(MF,*) phase0,compute_stoch_kick,initial_charge
1733    read(MF,*) CAVITY_TOTALPATH,ALWAYS_EXACTMIS,ALWAYS_EXACT_PATCHING
1734    read(MF,*) se1,se2,OLD_IMPLEMENTATION_OF_SIXTRACK,HIGHEST_FRINGE
1735    read(MF,'(A255)') lineg
1736    res=INDEX (lineG, "Valishev")
1737    IF(RES==0) THEN
1738       read(lineg,*) wedge_coeff
1739    ELSE
1740       read(lineg,*) wedge_coeff,valishev
1741    ENDIF
1742    read(MF,*) MAD8_WEDGE
1743    read(MF,'(a120)') line
1744    original=default
1745    call input_sector(se2,se1)
1746    if(allocated(s_b)) then
1747       firsttime_coef=my_true
1748       deallocate(s_b)
1749    endif
1750    !    L%MASS=MASSF
1751    MASSF=MASSF/pmae
1752    CALL MAKE_STATES(MASSF)
1753    A_PARTICLE=ag0
1754    default=original
1755    call Set_madx(p0c=p0c)
1756    DO I=1,N
1757       call  READ_FIBRE_2_lines(mf,dir,index_,pos,nt,siam_index,siam_pos,gird_index,gird_pos)
1758       call  READ_chart_fake(mf)
1759       call move_to(L%DNA(index_)%L,p,pos)
1760       CALL APPEND_POINT(L,P)
1761       current=>l%end
1762       current%dir=dir
1763
1764       if(siam_index/=0) then
1765          call move_to(L%DNA(siam_index)%L,siam,siam_pos)
1766          p%mag%siamese=>siam%mag
1767          write(6,*) p%mag%name,' is a siamese of ', siam%mag%name
1768       endif
1769       if(gird_index/=0) then
1770          call move_to(L%DNA(gird_index)%L,gird,gird_pos)
1771          p%mag%girderS=>gird%mag
1772          write(6,*) p%mag%name,' is on the girder of ', gird%mag%name
1773       endif
1774       !        if(pos==1) then
1775       !         if(associated(L%DNA(index)%l%con1)) then
1776       !           L%DNA(index)%counter=L%DNA(index)%counter+1
1777       !           kc=L%DNA(index)%counter
1778       !           L%DNA(index)%l%con1(kc)%p=>current
1779       !      write(6,*)  0,index,kc
1780       !          endif
1781       !        elseif(pos==nt) then
1782       !         if(associated(L%DNA(index)%l%con2)) then
1783       !           L%DNA(index)%l%con2(kc)%p=>current
1784       !     !       write(6,*)  1,index,kc
1785       !          endif
1786       !        endif
1787       CALL READ_PATCH(current%PATCH,mf)
1788       call READ_fake_element(current,mf)
1789       READ(MF,*) LINE
1790       !
1791       ! CALL READ_FIBRE(L%END,mf)
1792       !       CALL COPY(L%END%MAG,L%END%MAGP)
1793    ENDDO
1794
1795    if(.not.present(mf1) ) CLOSE(MF)
1796
1797    L%closed=RING_IT
1798
1799    doneit=my_true
1800    call ring_l(L,doneit)
1801    if(do_survey) call survey(L)
1802
1803    return
1804
18052001 continue
1806
1807    Write(6,*) " File ",filename(1:len_trim(filename)) ," does not exist "
1808
1809  END subroutine READ_pointed_INTO_VIRGIN_LAYOUT
1810
1811
1812!!!!!!!!!!!!  switching routines !!!!!!!!!!!!!
1813  SUBROUTINE switch_layout_to_cavity( L,name,sext,a,r,freq,t )  ! switch to kind7
1814    implicit none
1815    TYPE (layout), target :: L
1816    TYPE (fibre), pointer :: p
1817    character(*) name
1818    real(dp),OPTIONAL:: a,r,freq,t
1819    INTEGER I
1820    logical(lp) sext
1821
1822
1823    p=>L%start
1824    do i=1,L%n
1825
1826       call  switch_to_cavity( p,name,sext,a,r,freq,t)
1827
1828       p=>p%next
1829    enddo
1830
1831
1832
1833  end SUBROUTINE switch_layout_to_cavity
1834
1835
1836
1837  SUBROUTINE switch_to_cavity( el,name,sext,a,r,freq,t )  ! switch to kind7
1838    implicit none
1839    TYPE (fibre), target :: el
1840    character(*) name
1841    integer i,nm,EXCEPTION
1842    real(dp),OPTIONAL:: a,r,freq,t
1843    real(dp), allocatable :: an(:),bn(:)
1844    type(keywords) key
1845    logical(lp) sext
1846    ! This routines switches to cavity
1847    nm=len_trim(name)
1848    select case(el%mag%kind)
1849    case(kind10,kind16,kind2,kind7,kind6,KIND20)
1850       if(el%mag%name(1:nm)==name(1:nm)) then
1851          if(sext.and.el%mag%p%nmul>2)then
1852             write(6,*) el%mag%name
1853             call add(el,3,0,0.0_dp)
1854             call add(el,-3,0,0.0_dp)
1855          else
1856             write(6,*) el%mag%name, " not changed "
1857          endif
1858       endif
1859       if(el%mag%p%b0/=0.0_dp.or.el%mag%name(1:nm)==name(1:nm)) return
1860       write(6,*) el%mag%name
1861       if(el%mag%p%nmul/=size(el%mag%an)) then
1862          write(6,*) "error in switch_to_cavity "
1863          stop 666
1864       endif
1865       allocate(an(el%mag%p%nmul),bn(el%mag%p%nmul))
1866       an=el%mag%an*el%mag%p%p0c
1867       bn=el%mag%bn*el%mag%p%p0c
1868       call zero_key(key)
1869       key%magnet="rfcavity"
1870       key%list%volt=0.0_dp
1871       key%list%lag=0.0_dp
1872       key%list%freq0=0.0_dp
1873       IF(PRESENT(FREQ)) THEN
1874          key%list%freq0=FREQ
1875       ENDIF
1876       key%list%n_bessel=0
1877       key%list%harmon=1.0_dp
1878       key%list%l=el%mag%L
1879       key%list%name=el%mag%name
1880       key%list%vorname=el%mag%vorname
1881       EXACT_MODEL=el%mag%p%exact
1882       key%nstep=el%mag%p%nst
1883       key%method=el%mag%p%method
1884
1885
1886       el%mag=-1
1887       el%magp=-1
1888       el%mag=0
1889       el%magp=0
1890       call create_fibre(el,key,EXCEPTION,my_true)
1891       do i=size(an),1,-1
1892          call add(el,-i,0,an(i))
1893          call add(el,i,0,bn(i))
1894       enddo
1895       el%mag%c4%a=1.0_dp
1896       el%magp%c4%a=1.0_dp
1897       IF(PRESENT(a)) THEN
1898          el%mag%c4%a=a
1899          el%magp%c4%a=a
1900       ENDIF
1901       el%mag%c4%r=0.0_dp
1902       el%magp%c4%r=0.0_dp
1903       IF(PRESENT(r)) THEN
1904          el%mag%c4%r=r
1905          el%magp%c4%r=r
1906       ENDIF
1907       el%mag%c4%PHASE0=0.0_dp
1908       el%mag%c4%PHASE0=0.0_dp
1909       el%mag%c4%always_on=my_true
1910       el%magp%c4%always_on=my_true
1911       IF(PRESENT(FREQ)) THEN
1912          el%mag%FREQ=FREQ
1913          el%magP%FREQ=FREQ
1914       ENDIF
1915       IF(PRESENT(T).and.PRESENT(FREQ)) THEN
1916          el%mag%C4%T=T/(el%mag%C4%freq/CLIGHT)
1917          el%magP%C4%T=el%mag%C4%T
1918       ENDIF
1919       deallocate(an,bn)
1920    CASE(KIND4)
1921       IF(el%mag%c4%always_on) THEN
1922          IF(PRESENT(FREQ)) THEN
1923             el%mag%FREQ=FREQ
1924             el%magP%FREQ=FREQ
1925          ENDIF
1926          IF(PRESENT(T)) THEN
1927             el%mag%C4%T=T/(el%mag%C4%freq/CLIGHT)
1928             el%magP%C4%T=el%mag%C4%T
1929          ENDIF
1930          IF(PRESENT(r)) THEN
1931             el%mag%c4%r=r
1932             el%magp%c4%r=r
1933          ENDIF
1934          IF(PRESENT(a)) THEN
1935             el%mag%c4%a=a
1936             el%magp%c4%a=a
1937          ENDIF
1938
1939       ENDIF
1940
1941    case default
1942       return
1943    end select
1944
1945  END SUBROUTINE switch_to_cavity
1946
1947  SUBROUTINE switch_to_kind7( el )  ! switch to kind7
1948    implicit none
1949    TYPE (fibre), target :: el
1950    ! This routines switches to kind7 (not exact) from kind2,10,16
1951    select case(el%mag%kind)
1952    case(kind10,kind16,kind2,KIND20)
1953       el%magp=-1
1954       el%mag%L=el%mag%p%ld
1955       el%mag%p%lc=el%mag%p%ld
1956       el%mag%p%exact=my_false
1957       el%magp=0
1958    end select
1959
1960    select case(el%mag%kind)
1961    case(kind10)
1962       EL%MAG%TP10=-1
1963       deallocate(EL%MAG%TP10)
1964       el%mag%kind=KIND7
1965       CALL SETFAMILY(EL%MAG)
1966       CALL COPY(EL%MAG,EL%MAGP)
1967    case(kind16,KIND20)
1968       EL%MAG%k16=-1
1969       deallocate(EL%MAG%k16)
1970       el%mag%kind=KIND7
1971       CALL SETFAMILY(EL%MAG)
1972       CALL COPY(EL%MAG,EL%MAGP)
1973    case(KIND2)
1974       el%mag%kind=KIND7
1975       CALL SETFAMILY(EL%MAG)
1976       CALL COPY(EL%MAG,EL%MAGP)
1977    end select
1978
1979  END SUBROUTINE switch_to_kind7
1980
1981!!!!!! New flat file for data base universe  M_T !!!!!!!!!!!!!!!!!
1982 
1983subroutine  print_new_flat(ring,filename,last,com)
1984
1985implicit none
1986type(layout), target :: ring
1987type(fibre), pointer :: f
1988logical(lp), optional ::last
1989character(6), optional ::com
1990character(*) filename
1991integer i,mf
1992character(120) line
1993logical(lp) fin
1994character (6) comt
1995comt='REWIND'
1996fin=my_true
1997if(present(last)) fin=last
1998!goto 1
1999if(present(com)) comt=com
2000call kanalnummer(mf)
2001open(unit=mf,file=filename,position=comt)
2002
2003   write(mf,'(a120)') ring%name
2004   write(mf,*) highest_fringe  , " highest fringe "
2005   write(mf,*) lmax, " Maximum Length for Orbit "
2006   write(MF,*) ALWAYS_EXACTMIS,ALWAYS_EXACT_PATCHING  , "ALWAYS_EXACTMIS,ALWAYS_EXACT_PATCHING "
2007   write(mf,*) SECTOR_NMUL_MAX,SECTOR_NMUL , " SECTOR_NMUL_MAX,SECTOR_NMUL "
2008   
2009 write(mf,*) " $$$$$$$$$$$$$$$$$ START OF LAYOUT $$$$$$$$$$$$$$$$$"
2010
2011
2012 
2013f=>ring%start
2014
2015call Print_initial_chart(f,mf)
2016
2017do i=1,ring%n
2018  call el_el0(f%mag,my_true,mf)
2019  call fib_fib0(f,my_true,mf)
2020  CALL MC_MC0(f%MAG%P,my_true,mf)
2021  CALL print_ElementLIST(f%mag,MY_TRUE,mf)
2022  if(f%patch%patch/=0) call patch_patch0(f%patch,my_true,mf)
2023  if(f%mag%mis) call CHART_CHART0(f%chart,my_true,mf)
2024 write(mf,*) " $$$$$$$$$$$$$$$$$ END OF FIBRE $$$$$$$$$$$$$$$$$"
2025 f=>f%next   
2026enddo
2027
2028 write(mf,*) "&ELENAME"
2029if(fin) then
2030 write(mf,*) "ELE0%NAME_VORNAME    = alldone"
2031else
2032 write(mf,*) "ELE0%NAME_VORNAME    = endhere"
2033endif
2034write(mf,*) "/"
2035
2036
2037close(mf)
2038
2039
2040end subroutine print_new_flat
2041
2042subroutine  print_universe(un,filename)
2043!call print_universe(m_u,'junk2.txt')
2044!call print_universe_pointed(m_u,m_t,'junk3.txt')
2045implicit none
2046type(mad_universe),target :: un
2047type(layout),pointer :: r
2048character(*) filename
2049integer i
2050
2051
2052
2053r=>un%start
2054
2055
2056if(associated(r,un%end)) then
2057 call  print_new_flat(r,filename,last=my_true)
2058else
2059          do while(.not.associated(r,un%end))
2060            if(associated(r,un%start)) then
2061              call  print_new_flat(r,filename,last=my_false) 
2062            else
2063              call  print_new_flat(r,filename,last=my_false,com="APPEND") 
2064            endif
2065            r=>r%next
2066          enddo
2067              call  print_new_flat(r,filename,last=my_true,com="APPEND") 
2068 
2069endif
2070call print_universe_siamese(un,filename)
2071call print_universe_girders(un,filename)
2072end subroutine  print_universe
2073
2074subroutine  print_universe_girders(un,filename)
2075implicit none
2076type(mad_universe),target :: un
2077type(fibre),pointer :: p,p0,ps
2078type(element),pointer :: m,m0
2079character(*) filename
2080integer i,k,i1,i2,j1,j2,MF
2081
2082
2083
2084call TIE_MAD_UNIVERSE(un)
2085
2086p=>un%start%start
2087p0=>p
2088p=>p%next
2089
2090
2091k=0
2092do while(.not.associated(p0,p))
2093
2094
2095if(associated(p%mag%girders)) then
2096 
2097 if(associated(p%mag%GIRDER_FRAME)) then
2098 k=k+1
2099
2100endif
2101endif
2102 
2103 p=>p%n
2104enddo
2105
2106call kanalnummer(mf)
2107open(unit=mf,file=filename,position='APPEND')
2108write(MF,*) k, " girders in the universe "
2109
2110
2111
2112
2113p=>un%start%start
2114p0=>p
2115p=>p%next
2116
2117
2118i=0
2119do while(.not.associated(p0,p))
2120i=i+1
2121
2122if(associated(p%mag%girders)) then
2123 
2124 
2125 if(associated(p%mag%GIRDER_FRAME)) then
2126  j1=0
2127  j2=0
2128  ps=>p
2129  call locate_in_universe(ps,i1,i2)
2130     write(MF,*) p%mag%girder_frame%a   
2131     write(MF,*) p%mag%girder_frame%ent(1,1:3)
2132     write(MF,*) p%mag%girder_frame%ent(2,1:3)
2133     write(MF,*) p%mag%girder_frame%ent(3,1:3)
2134     write(MF,*) p%mag%girder_frame%b   
2135     write(MF,*) p%mag%girder_frame%exi(1,1:3)
2136     write(MF,*) p%mag%girder_frame%exi(2,1:3)
2137     write(MF,*) p%mag%girder_frame%exi(3,1:3)
2138
2139
2140
2141     write(MF,*) i1,i2,ps%loc,PS%MAG%NAME
2142  do while(j1/=i1.or.j2/=i2)
2143      ps=>ps%mag%girders%parent_fibre   
2144      call locate_in_universe(ps,j1,j2)
2145      if (j1/=i1.or.j2/=i2) then
2146        write(MF,*) j1,j2 ,ps%loc
2147      else
2148        write(MF,*) 0,0,0
2149      endif
2150  enddo
2151 endif
2152
2153endif
2154 
2155 p=>p%n
2156enddo
2157
2158
2159CLOSE(MF)
2160
2161end subroutine  print_universe_girders
2162
2163subroutine  read_universe_girders(un,mf,ns)
2164implicit none
2165type(mad_universe),target :: un
2166type(fibre),pointer :: p,p0,ps
2167type(element),pointer :: m,m0
2168integer i,k,j,i1,i2,j1,MF,ns
2169
2170
2171call TIE_MAD_UNIVERSE(un)
2172
2173
2174
2175
2176do i=1,ns
2177
2178call read_initial_chart(mf)
2179
2180read(mf,*) i1,i2,j1
2181
2182 p0=>un%start%start
2183 do j=2,j1
2184  p0=>p0%n
2185 enddo
2186 ps=>p0
2187
2188 do k=1,1000000
2189  read(mf,*) i1,i2,j1
2190  if(i1==0) exit
2191  p=>un%start%start
2192  do j=2,j1
2193   p=>p%n
2194  enddo
2195  ps%mag%girders=>p%mag
2196  ps=>p
2197 enddo
2198  ps%mag%girders=>p0%mag
2199
2200  allocate(p0%mag%girder_frame)
2201  call NULL_af(p0%mag%girder_frame)
2202  allocate(p0%mag%girder_frame%a(3))
2203  allocate(p0%mag%girder_frame%b(3))
2204  allocate(p0%mag%girder_frame%ent(3,3))
2205  allocate(p0%mag%girder_frame%exi(3,3))
2206  p0%mag%girder_frame%a=a_
2207  p0%mag%girder_frame%ent(1,1:3)=ent_(1,1:3)
2208  p0%mag%girder_frame%ent(2,1:3)=ent_(2,1:3)
2209  p0%mag%girder_frame%ent(3,1:3)=ent_(3,1:3)
2210  p0%mag%girder_frame%b=b_
2211  p0%mag%girder_frame%exi(1,1:3)=exi_(1,1:3)
2212  p0%mag%girder_frame%exi(2,1:3)=exi_(2,1:3)
2213  p0%mag%girder_frame%exi(3,1:3)=exi_(3,1:3)
2214
2215enddo
2216
2217
2218end subroutine  read_universe_girders
2219
2220subroutine  print_universe_siamese(un,filename)
2221implicit none
2222type(mad_universe),target :: un
2223type(fibre),pointer :: p,p0,ps
2224type(element),pointer :: m,m0
2225character(*) filename
2226integer i,k,i1,i2,j1,j2,MF
2227
2228
2229
2230call TIE_MAD_UNIVERSE(un)
2231
2232p=>un%start%start
2233p0=>p
2234p=>p%next
2235
2236
2237k=0
2238do while(.not.associated(p0,p))
2239
2240
2241if(associated(p%mag%siamese)) then
2242 
2243 if(associated(p%mag%SIAMESE_FRAME)) then
2244 k=k+1
2245
2246endif
2247endif
2248 
2249 p=>p%n
2250enddo
2251
2252call kanalnummer(mf)
2253open(unit=mf,file=filename,position='APPEND')
2254write(MF,*) k, " siamese in the universe "
2255
2256
2257
2258
2259p=>un%start%start
2260p0=>p
2261p=>p%next
2262
2263
2264i=0
2265do while(.not.associated(p0,p))
2266i=i+1
2267
2268if(associated(p%mag%siamese)) then
2269 
2270 
2271 if(associated(p%mag%SIAMESE_FRAME)) then
2272  j1=0
2273  j2=0
2274  ps=>p
2275  call locate_in_universe(ps,i1,i2)
2276     write(MF,*) p%mag%SIAMESE_FRAME%ANGLE
2277     write(MF,*) p%mag%SIAMESE_FRAME%d
2278     write(MF,*) i1,i2,ps%loc,PS%MAG%NAME
2279  do while(j1/=i1.or.j2/=i2)
2280      ps=>ps%mag%siamese%parent_fibre   
2281      call locate_in_universe(ps,j1,j2)
2282      if (j1/=i1.or.j2/=i2) then
2283        write(MF,*) j1,j2 ,ps%loc
2284      else
2285        write(MF,*) 0,0,0
2286      endif
2287  enddo
2288 endif
2289
2290endif
2291 
2292 p=>p%n
2293enddo
2294
2295
2296CLOSE(MF)
2297
2298end subroutine  print_universe_siamese
2299
2300subroutine  read_universe_siamese(un,mf,ns)
2301implicit none
2302type(mad_universe),target :: un
2303type(fibre),pointer :: p,p0,ps
2304type(element),pointer :: m,m0
2305integer i,k,j,i1,i2,j1,MF,ns
2306real(dp) a(3),d(3)
2307
2308
2309call TIE_MAD_UNIVERSE(un)
2310
2311
2312
2313
2314do i=1,ns
2315
2316read(mf,*) a
2317read(mf,*) d
2318
2319read(mf,*) i1,i2,j1
2320
2321 p0=>un%start%start
2322 do j=2,j1
2323  p0=>p0%n
2324 enddo
2325 ps=>p0
2326
2327 do k=1,1000000
2328  read(mf,*) i1,i2,j1
2329  if(i1==0) exit
2330  p=>un%start%start
2331  do j=2,j1
2332   p=>p%n
2333  enddo
2334  ps%mag%siamese=>p%mag
2335  ps=>p
2336 enddo
2337  ps%mag%siamese=>p0%mag
2338
2339  allocate(p0%mag%siamese_frame)
2340  call NULL_af(p0%mag%siamese_frame)
2341  allocate(p0%mag%siamese_frame%angle(3))
2342  allocate(p0%mag%siamese_frame%d(3))
2343  p0%mag%siamese_frame%angle=a
2344  p0%mag%siamese_frame%d=d
2345enddo
2346
2347
2348end subroutine  read_universe_siamese
2349
2350subroutine  read_universe_database(un,filename,arpent)
2351! the universes should be empty
2352!call read_universe_database(m_u,'junk2.txt',arpent=my_false)
2353!call read_universe_pointed(M_u,M_t,'junk3.txt')
2354!call create_dna(M_u,m_t)
2355!arpent= false => the databaseshould not be surveyed.
2356! DNA is automatically created in create_dna
2357implicit none
2358type(mad_universe),target :: un
2359logical(lp), optional :: arpent
2360character(*) filename
2361integer mf,ns
2362ELE0%NAME_VORNAME(1)=' '
2363
2364 call kanalnummer(mf,filename(1:len_trim(filename)))
2365          do while(ELE0%NAME_VORNAME(1)/="alldone")
2366           call append_empty_layout(un) 
2367           call set_up(un%end)
2368           call read_lattice(un%end,filename,mf,arpent)
2369          enddo
2370read(mf,*) ns   ! number of siamese
2371 call read_universe_siamese(un,mf,ns)
2372read(mf,*) ns   ! number of girders
2373call read_universe_girders(un,mf,ns)
2374close(mf)
2375end subroutine  read_universe_database
2376
2377
2378
2379subroutine  read_lattice(r,filename,mfile,arpent)
2380implicit none
2381type(layout),target :: r
2382character(*) filename
2383logical(lp), optional :: arpent
2384integer , optional :: mfile
2385logical(lp) doneit,surv
2386character(120) line
2387type(fibre),pointer :: s22
2388type(element),pointer :: s2
2389type(elementp), pointer :: s2p
2390
2391
2392integer mf,n
2393
2394call make_states(my_false)
2395call set_mad(energy=2.0d0)
2396
2397if(present(mfile)) then
2398 mf=mfile
2399else
2400 call kanalnummer(mf,filename(1:len_trim(filename)))
2401endif
2402surv=my_true
2403
2404!-----------------------------------
2405
2406
2407   read(mf,'(a120)') r%name
2408   read(mf,*) highest_fringe 
2409   read(mf,*) lmax 
2410   read(MF,*) ALWAYS_EXACTMIS,ALWAYS_EXACT_PATCHING 
2411   read(mf,*) SECTOR_NMUL_MAX,SECTOR_NMUL 
2412   
2413 read(mf,'(a120)') line
2414
2415
2416 
2417 read(mf,'(a120)') line
2418call read_initial_chart(mf)
2419 read(mf,'(a120)') line
2420
2421
2422
2423n=0
2424do while(.true.)
2425   read(mf,NML=ELEname,end=999)
2426
2427
2428   if(ELE0%NAME_VORNAME(1)== "endhere".or.ELE0%NAME_VORNAME(1)=="alldone") goto 99
2429 !write(6,NML=ELEname)
2430   read(mf,NML=FIBRENAME,end=999)
2431 !write(6,NML=FIBRENAME)
2432   read(mf,NML=MAGLNAME,end=999)
2433 !write(6,NML=MAGLNAME)
2434 call read_ElementLIST(ELE0%kind,MF)
2435 if(fib0%patch/=0) read(mf,NML=patchname,end=999)
2436
2437 read(mf,'(a120)') line
2438
2439 call append_empty(r)
2440 s22=>r%end
2441  call  nullify_for_madx(s22)
2442
2443
2444 
2445
2446    s2=>s22%mag;
2447    s2p=>s22%magp;
2448
2449
2450
2451 !pause 78
2452! fib0%GAMMA0I_GAMBET_MASS_AG(1)=f%GAMMA0I
2453 !fib0%GAMMA0I_GAMBET_MASS_AG(2)=f%GAMBET
2454 !fib0%GAMMA0I_GAMBET_MASS_AG(3)=f%MASS
2455 !fib0%GAMMA0I_GAMBET_MASS_AG(4)=f%AG
2456 !!fib0%DIR=f%DIR
2457 !fib0%CHARGE=f%CHARGE
2458
2459    call fib_fib0(s22,my_false)
2460
2461     S2 = MAGL0%METHOD_NST_NMUL(3)   
2462     
2463
2464!write(6,*) associated(s2%p)
2465 !pause 78
2466    call MC_MC0(s2%p,my_false)
2467
2468 !pause 79
2469    call el_el0(s2,my_false)
2470
2471
2472    if(s2%kind/=kindpa) then
2473       CALL SETFAMILY(S2)  !,NTOT=ntot,ntot_rad=ntot_rad,NTOT_REV=ntot_REV,ntot_rad_REV=ntot_rad_REV,ND2=6)
2474    else
2475       CALL SETFAMILY(S2,t=T_E)  !,T_ax=T_ax,T_ay=T_ay)
2476       S2%P%METHOD=4
2477       deallocate(T_E,t_ax,t_ay)
2478    endif   
2479
2480 
2481
2482    call print_ElementLIST(s2,my_false)
2483 
2484    s2p=0   
2485 
2486 !pause 665
2487
2488    call copy(s2,s2p)
2489    s22%mag%parent_fibre =>s22
2490    s22%magp%parent_fibre=>s22
2491       s22%CHART=0
2492       s22%PATCH=0
2493     if(fib0%patch/=0) then
2494       s22%PATCH%patch=fib0%patch
2495      call patch_patch0(s22%patch,my_false)
2496    endif
2497   if(ele0%slowac_recut_even_electric_MIS(5)) call CHART_CHART0(s22%chart,my_false)
2498
2499!  write(6,*) associated(s2%p%f%o)
2500!pause 777
2501!   write(6,*) associated(s22%chart%f)
2502!   write(6,*) s22%paTCH%patch
2503!   write(6,*) s22%paTCH%a_d
2504! pause 666
2505
2506n=n+1
2507enddo
2508
2509
2510   100 CONTINUE
2511
2512
251399 write(6,*) ELE0%NAME_VORNAME(1)
2514999 write(6,*) "Read ",n
2515
2516 s22=>r%start
2517! if(s22%dir==1) then
2518  s22%chart%f%a=a_
2519  s22%chart%f%ent=ent_
2520! else
2521  s22%chart%f%b=b_
2522  s22%chart%f%exi=exi_
2523! endif
2524    r%closed=.true.
2525
2526    doneit=.true.
2527    call ring_l(r,doneit)
2528 if(present(arpent)) surv=arpent
2529
2530   if(surv) then
2531
2532
2533     call survey(r)
2534   endif
2535
25361000 continue
2537
2538if(.not.present(mfile)) close(mf)
2539
2540end subroutine read_lattice
2541
2542  subroutine read_ElementLIST(kind,mf)
2543    implicit none
2544
2545    integer mf,i,kind
2546    LOGICAL dir
2547    character*255 line
2548
2549
2550    select case(kind)
2551    CASE(KIND0,KIND1,kind2,kind5,kind6,kind7,kind8,kind9,KIND11:KIND15,kind17,KIND22)
2552  case(kind3)
2553     read(mf,NML=thin30name)
2554    case(kind4)
2555     read(mf,NML=CAVname)
2556    case(kind10)
2557      read(mf,NML=tp100name)
2558
2559    case(kind16,kind20)
2560
2561     read(mf,NML=k160name)
2562
2563    case(kind18)
2564
2565    case(kind19)
2566
2567    case(kind21)
2568     read(mf,NML=tCAVname)
2569    case(KINDWIGGLER)
2570
2571    case(KINDpa)
2572 
2573   case default
2574       write(MF,*) " not supported in print_specific_element",kind
2575 !      stop 101
2576    end select
2577   
2578    CALL  r_ap_aplist(mf)
2579
2580
2581  END SUBROUTINE read_ElementLIST
2582
2583subroutine  fib_fib0(f,dir,mf)
2584implicit none
2585type(fibre), target :: f
2586logical(lp),optional ::  dir
2587integer,optional :: mf
2588
2589if(present(dir)) then
2590if(dir) then   !BETA0,GAMMA0I,GAMBET,MASS ,AG
2591! fib0%t(1)=f%BETA0
2592 fib0%GAMMA0I_GAMBET_MASS_AG(1)=f%GAMMA0I
2593 fib0%GAMMA0I_GAMBET_MASS_AG(2)=f%GAMBET
2594 fib0%GAMMA0I_GAMBET_MASS_AG(3)=f%MASS
2595 fib0%GAMMA0I_GAMBET_MASS_AG(4)=f%AG
2596 fib0%DIR=f%DIR
2597 fib0%CHARGE=f%CHARGE
2598 fib0%patch=f%patch%patch
2599 !fib0%pos=f%pos
2600 !fib0%loc=f%loc
2601    if(present(mf)) then
2602     write(mf,NML=fibrename)
2603    endif   
2604else
2605    if(present(mf)) then
2606     read(mf,NML=fibrename)
2607    endif   
2608    ! f%BETA0=fib0%t(1)
2609 f%GAMMA0I=fib0%GAMMA0I_GAMBET_MASS_AG(1)
2610 f%GAMBET=fib0%GAMMA0I_GAMBET_MASS_AG(2)
2611 f%MASS=fib0%GAMMA0I_GAMBET_MASS_AG(3)
2612 f%AG=fib0%GAMMA0I_GAMBET_MASS_AG(4)
2613 f%BETA0=sqrt(1.0_dp-f%GAMMA0I**2)   
2614 f%DIR=fib0%DIR
2615 f%CHARGE=fib0%CHARGE
2616 !f%patch%patch=fib0%patch     ! f%patch%patch is not yet allocated
2617endif
2618endif
2619end subroutine fib_fib0
2620
2621subroutine  patch_patch0(f,dir,mf)
2622implicit none
2623type(PATCH), target :: f
2624logical(lp),optional ::  dir
2625integer,optional :: mf
2626
2627if(present(dir)) then
2628if(dir) then   !BETA0,GAMMA0I,GAMBET,MASS ,AG
2629! fib0%t(1)=f%BETA0
2630 
2631 patch0%A_X1=f%A_X1
2632 patch0%A_X2=f%A_X2
2633 patch0%B_X1=f%B_X1
2634 patch0%B_X2=f%B_X2
2635 patch0%A_D=f%A_D
2636 patch0%B_D=f%B_D
2637 patch0%A_ANG=f%A_ANG
2638 patch0%B_ANG=f%B_ANG
2639 patch0%A_T=f%A_T
2640 patch0%B_T=f%B_T
2641 patch0%ENERGY=f%ENERGY
2642 patch0%TIME=f%TIME
2643
2644    if(present(mf)) then
2645     write(mf,NML=patchname)
2646    endif   
2647else
2648    if(present(mf)) then
2649     read(mf,NML=patchname)
2650    endif   
2651
2652f%A_X1= patch0%A_X1
2653f%A_X2= patch0%A_X2
2654f%B_X1= patch0%B_X1
2655f%B_X2= patch0%B_X2
2656
2657 f%A_D=patch0%A_D
2658 f%B_D=patch0%B_D
2659 f%A_ANG=patch0%A_ANG
2660 f%B_ANG=patch0%B_ANG
2661 f%A_T=patch0%A_T
2662 f%B_T=patch0%B_T
2663 f%ENERGY=patch0%ENERGY
2664 f%TIME=patch0%TIME
2665
2666endif
2667endif
2668end subroutine patch_patch0
2669
2670
2671subroutine  CHART_CHART0(f,dir,mf)
2672implicit none
2673type(chart), target :: f
2674logical(lp),optional ::  dir
2675integer,optional :: mf
2676
2677if(present(dir)) then
2678if(dir) then   
2679
2680 CHART0%D_IN=f%D_IN
2681 CHART0%D_OUT=f%D_OUT
2682 CHART0%ANG_IN=f%ANG_IN
2683 CHART0%ANG_OUT=f%ANG_OUT
2684 
2685    if(present(mf)) then
2686     write(mf,NML=CHARTname)
2687    endif   
2688else
2689    if(present(mf)) then
2690     read(mf,NML=CHARTname)
2691    endif   
2692
2693 f%D_IN=CHART0%D_IN
2694 f%D_OUT=CHART0%D_OUT
2695 f%ANG_IN=CHART0%ANG_IN
2696 f%ANG_OUT=CHART0%ANG_OUT
2697 
2698
2699endif
2700endif
2701end subroutine CHART_CHART0
2702
2703
2704
2705subroutine  MC_MC0(f,dir,mf)
2706implicit none
2707type(MAGNET_CHART), target :: f
2708logical(lp),optional ::  dir
2709integer,optional :: mf
2710
2711if(present(dir)) then
2712if(dir) then   !BETA0,GAMMA0I,GAMBET,MASS ,AG
2713 MAGL0%LC_LD_B0_P0(1)=f%LC
2714 MAGL0%LC_LD_B0_P0(2)=f%LD
2715 MAGL0%LC_LD_B0_P0(3)=f%B0
2716 MAGL0%LC_LD_B0_P0(4)=f%P0C
2717 
2718 MAGL0%TILTD_EDGE(1)=f%TILTD
2719 MAGL0%TILTD_EDGE(2)=f%EDGE(1)
2720 MAGL0%TILTD_EDGE(3)=f%EDGE(2)
2721
2722 MAGL0%KIN_KEX_BENDFRINGE_permFRINGE_EXACT(1)=f%KILL_ENT_FRINGE
2723 MAGL0%KIN_KEX_BENDFRINGE_permFRINGE_EXACT(2)=f%KILL_EXI_FRINGE
2724 MAGL0%KIN_KEX_BENDFRINGE_permFRINGE_EXACT(3)=f%bend_fringe
2725 MAGL0%KIN_KEX_BENDFRINGE_permFRINGE_EXACT(4)=f%permFRINGE
2726 MAGL0%KIN_KEX_BENDFRINGE_permFRINGE_EXACT(5)=f%EXACT
2727
2728 MAGL0%METHOD_NST_NMUL(1)=f%METHOD
2729 MAGL0%METHOD_NST_NMUL(2)=f%NST
2730 MAGL0%METHOD_NST_NMUL(3)=f%NMUL
2731
2732 if(present(mf)) then
2733     write(mf,NML=MAGLname)
2734    endif   
2735else
2736    if(present(mf)) then
2737     read(mf,NML=MAGLname)
2738    endif   
2739 f%LC=MAGL0%LC_LD_B0_P0(1)
2740 f%LD=MAGL0%LC_LD_B0_P0(2)
2741 f%B0=MAGL0%LC_LD_B0_P0(3)
2742 f%P0C=MAGL0%LC_LD_B0_P0(4)
2743 
2744 f%TILTD=MAGL0%TILTD_EDGE(1)
2745 f%EDGE(1)=MAGL0%TILTD_EDGE(2)
2746 f%EDGE(2)=MAGL0%TILTD_EDGE(3)
2747
2748 f%KILL_ENT_FRINGE=MAGL0%KIN_KEX_BENDFRINGE_permFRINGE_EXACT(1)
2749 f%KILL_EXI_FRINGE=MAGL0%KIN_KEX_BENDFRINGE_permFRINGE_EXACT(2)
2750 f%bend_fringe=MAGL0%KIN_KEX_BENDFRINGE_permFRINGE_EXACT(3)
2751 f%permFRINGE=MAGL0%KIN_KEX_BENDFRINGE_permFRINGE_EXACT(4)
2752 f%EXACT=MAGL0%KIN_KEX_BENDFRINGE_permFRINGE_EXACT(5)
2753
2754 f%METHOD=MAGL0%METHOD_NST_NMUL(1)
2755 f%NST=MAGL0%METHOD_NST_NMUL(2)
2756 f%NMUL=MAGL0%METHOD_NST_NMUL(3)
2757
2758endif
2759endif
2760end subroutine MC_MC0
2761
2762subroutine  el_el0(f,dir,mf)
2763implicit none
2764type(element), target :: f
2765logical(lp),optional ::  dir
2766integer,optional :: mf
2767
2768if(present(dir)) then
2769if(dir) then   !BETA0,GAMMA0I,GAMBET,MASS ,AG
2770 ELE0%KIND=F%KIND
2771 ELE0%name_vorname(1)=f%name
2772 ELE0%name_vorname(2)=f%vorname
2773 ele0%an=0.0_dp
2774 ele0%an=0.0_dp
2775 ele0%an(1:f%p%nmul)=f%an(1:f%p%nmul)
2776 ele0%bn(1:f%p%nmul)=f%bn(1:f%p%nmul)
2777 ele0%VOLT_FREQ_PHAS=0.0_dp
2778 ele0%B_SOL=0.0_dp
2779 
2780   ele0%fint_hgap_h1_h2(1)=f%fint
2781   ele0%fint_hgap_h1_h2(2)=f%hgap
2782   ele0%fint_hgap_h1_h2(3)=f%h1
2783   ele0%fint_hgap_h1_h2(4)=f%h2
2784   
2785   ele0%L=f%L
2786   IF(ASSOCIATED(f%B_SOL)) ele0%B_SOL=f%B_SOL
2787 
2788 if(associated(f%volt)) ele0%VOLT_FREQ_PHAS(1)=f%VOLT
2789 if(associated(f%FREQ)) ele0%VOLT_FREQ_PHAS(2)=f%FREQ
2790 if(associated(f%PHAS)) ele0%VOLT_FREQ_PHAS(3)=f%PHAS
2791 if(associated(f%THIN)) ele0%THIN=f%THIN
2792
2793
2794ele0%slowac_recut_even_electric_MIS(1) = f%slow_ac
2795ele0%slowac_recut_even_electric_MIS(2) = f%recut
2796ele0%slowac_recut_even_electric_MIS(3) = f%even
2797ele0%slowac_recut_even_electric_MIS(4) = f%electric
2798ele0%slowac_recut_even_electric_MIS(5) = f%MIS
2799 
2800    if(present(mf)) then
2801     write(mf,NML=ELEname)
2802    endif   
2803else
2804 
2805    if(present(mf)) then
2806     read(mf,NML=ELEname)
2807    endif   
2808 F%KIND=ELE0%KIND 
2809 f%name=ELE0%name_vorname(1)
2810 f%vorname=ELE0%name_vorname(2)
2811 f%an(1:f%p%nmul)=ele0%an(1:f%p%nmul)
2812 f%bn(1:f%p%nmul)=ele0%bn(1:f%p%nmul)
2813
2814f%fint= ele0%fint_hgap_h1_h2(1)
2815f%hgap= ele0%fint_hgap_h1_h2(2)
2816f%h1  = ele0%fint_hgap_h1_h2(3)
2817f%h2  = ele0%fint_hgap_h1_h2(4)
2818
2819
2820if(f%kind==kind4.or.f%kind==kind21) then ! cavities
2821 if(.not.associated(f%volt)) then
2822  ALLOCATE(f%VOLT,f%FREQ,f%PHAS,f%DELTA_E,f%THIN,f%lag)
2823 endif
2824  f%VOLT=ele0%VOLT_FREQ_PHAS(1)
2825  f%FREQ=ele0%VOLT_FREQ_PHAS(2)
2826  f%PHAS=ele0%VOLT_FREQ_PHAS(3)
2827  f%THIN=ele0%THIN
2828  f%delta_e=0.0_dp
2829endif
2830
2831if(f%kind==KIND15) then   ! electrip separetor
2832 if(.not.associated(f%volt)) then
2833  ALLOCATE(f%VOLT,f%PHAS)
2834 endif
2835  f%VOLT=ele0%VOLT_FREQ_PHAS(1)
2836  f%PHAS=ele0%VOLT_FREQ_PHAS(3)
2837endif
2838
2839    if(f%kind==kind22) then  ! helical dipole
2840       if(.not.associated(f%freq)) ALLOCATE(f%FREQ,f%PHAS)
2841       f%FREQ=ele0%VOLT_FREQ_PHAS(2)
2842       f%PHAS=ele0%VOLT_FREQ_PHAS(3)
2843    endif
2844
2845 f%slow_ac = ele0%slowac_recut_even_electric_MIS(1)
2846 f%recut = ele0%slowac_recut_even_electric_MIS(2)
2847 f%even = ele0%slowac_recut_even_electric_MIS(3)
2848 f%electric = ele0%slowac_recut_even_electric_MIS(4)
2849 f%MIS = ele0%slowac_recut_even_electric_MIS(5)
2850
2851   F%L=ele0%L
2852
2853   
2854    if(f%kind==kind3.or.f%kind==kind5) then   
2855        IF(.not.ASSOCIATED(f%B_SOL)) ALLOCATE(f%B_SOL);
2856       F%B_SOL=ele0%B_SOL
2857    endif
2858
2859   
2860endif
2861endif
2862end subroutine el_el0
2863
2864
2865  subroutine print_ElementLIST(el,dir,mf)
2866    implicit none
2867    type(element), pointer :: el
2868    integer i
2869     logical(lp),optional ::  dir
2870     integer,optional :: mf
2871    character*255 line
2872
2873
2874    select case(el%kind)
2875    CASE(KIND0,KIND1,kind2,kind5,kind6,kind7,kind8,kind9,KIND11:KIND15,kind17,KIND22)
2876  case(kind3)
2877     call thin3_thin30(el,dir,mf)
2878    case(kind4)
2879        call cav4_cav40(EL,dir,mf)
2880    case(kind10)
2881        call tp10_tp100(EL,dir,mf)
2882
2883    case(kind16,kind20)
2884        call k16_k160(EL,dir,mf)
2885
2886    case(kind18)
2887!       WRITE(MF,*) " RCOLLIMATOR HAS AN INTRINSIC APERTURE "
2888  !     CALL  ap_aplist(el,dir,mf)
2889    case(kind19)
2890!       WRITE(MF,*) " ECOLLIMATOR HAS AN INTRINSIC APERTURE "
2891!       CALL print_aperture(EL%ECOL19%A,mf)
2892    case(kind21)
2893        call tcav4_tcav40(EL,dir,mf)
2894!       WRITE(MF,*) el%cav21%PSI,el%cav21%DPHAS,el%cav21%DVDS
2895    case(KINDWIGGLER)
2896 !      call print_wig(el%wi,mf)
2897    case(KINDpa)
2898 !      call print_pancake(el%pa,mf)
2899    case default
2900       write(MF,*) " not supported in print_specific_element",el%kind
2901 !      stop 101
2902    end select
2903 
2904    CALL  ap_aplist(el,dir,mf)
2905
2906 
2907
2908  END SUBROUTINE print_ElementLIST
2909
2910   
2911subroutine  cav4_cav40(f,dir,mf)
2912implicit none
2913type(element), target :: f
2914logical(lp),optional ::  dir
2915integer,optional :: mf
2916
2917if(present(dir)) then
2918if(dir) then   !BETA0,GAMMA0I,GAMBET,MASS ,AG
2919
2920 cav0%f=0.0_dp
2921 cav0%PH=0.0_dp   
2922 cav0%N_BESSEL=F%c4%N_BESSEL
2923 cav0%NF=F%c4%NF
2924 cav0%CAVITY_TOTALPATH=F%c4%CAVITY_TOTALPATH
2925 cav0%phase0=F%c4%phase0
2926 cav0%t=F%c4%t
2927 cav0%always_on=F%c4%always_on
2928 cav0%f(1:F%c4%NF)=F%c4%f
2929 cav0%PH(1:F%c4%NF)=F%c4%PH
2930 cav0%A=F%c4%A
2931 cav0%R=F%c4%R
2932    if(present(mf)) then
2933     write(mf,NML=CAVname)
2934    endif   
2935 
2936 else
2937    if(present(mf)) then
2938     read(mf,NML=CAVname)
2939    endif   
2940 F%c4%N_BESSEL=cav0%N_BESSEL
2941 F%c4%NF =cav0%NF
2942 F%c4%CAVITY_TOTALPATH=cav0%CAVITY_TOTALPATH
2943 F%c4%phase0=cav0%phase0
2944 F%c4%t=cav0%t
2945 F%c4%always_on=cav0%always_on
2946 F%c4%f=cav0%f(1:F%c4%NF)
2947 F%c4%PH=cav0%PH(1:F%c4%NF)
2948 F%c4%A=cav0%A
2949 F%c4%R=cav0%R 
2950endif
2951endif
2952end subroutine cav4_cav40
2953
2954subroutine  tcav4_tcav40(f,dir,mf)
2955implicit none
2956type(element), target :: f
2957logical(lp),optional ::  dir
2958integer,optional :: mf
2959
2960if(present(dir)) then
2961if(dir) then   !BETA0,GAMMA0I,GAMBET,MASS ,AG
2962
2963
2964 tcav0%PSI_DPHAS_DVDS(1)=F%cav21%psi
2965 tcav0%PSI_DPHAS_DVDS(2)=F%cav21%dphas
2966 tcav0%PSI_DPHAS_DVDS(3)=F%cav21%dvds
2967
2968    if(present(mf)) then
2969     write(mf,NML=tCAVname)
2970    endif   
2971 
2972 else
2973    if(present(mf)) then
2974     read(mf,NML=tCAVname)
2975    endif   
2976
2977 F%cav21%psi=tcav0%PSI_DPHAS_DVDS(1)
2978 F%cav21%dphas=tcav0%PSI_DPHAS_DVDS(2)
2979 F%cav21%dvds=tcav0%PSI_DPHAS_DVDS(3)
2980
2981endif
2982
2983endif
2984end subroutine tcav4_tcav40
2985
2986
2987subroutine  thin3_thin30(f,dir,mf)
2988implicit none
2989type(element), target :: f
2990logical(lp),optional ::  dir
2991integer,optional :: mf
2992
2993if(present(dir)) then
2994if(dir) then   !BETA0,GAMMA0I,GAMBET,MASS ,AG
2995
2996   
2997
2998 thin30%thin_h_foc=F%k3%thin_h_foc
2999 thin30%thin_v_foc=F%k3%thin_v_foc
3000 thin30%thin_h_angle=F%k3%thin_h_angle
3001 thin30%thin_v_angle=F%k3%thin_v_angle
3002 thin30%hf=F%k3%hf
3003 thin30%vf=F%k3%vf
3004 thin30%patch=F%k3%patch
3005 thin30%ls=F%k3%ls
3006    if(present(mf)) then
3007     write(mf,NML=thin30name)
3008    endif   
3009 
3010 else
3011    if(present(mf)) then
3012     read(mf,NML=thin30name)
3013    endif   
3014 f%k3%thin_h_foc=thin30%thin_h_foc
3015 f%k3%thin_v_foc=thin30%thin_v_foc
3016 f%k3%thin_h_angle=thin30%thin_h_angle
3017 f%k3%thin_v_angle=thin30%thin_v_angle
3018 f%k3%hf=thin30%hf
3019 f%k3%vf=thin30%vf
3020 f%k3%patch=thin30%patch
3021 f%k3%ls=thin30%ls
3022endif
3023endif
3024end subroutine thin3_thin30
3025
3026subroutine  tp10_tp100(f,dir,mf)
3027implicit none
3028type(element), target :: f
3029logical(lp),optional ::  dir
3030integer,optional :: mf
3031
3032if(present(dir)) then
3033if(dir) then   !BETA0,GAMMA0I,GAMBET,MASS ,AG
3034
3035   
3036
3037 tp100%DRIFTKICK=F%tp10%DRIFTKICK
3038     if(present(mf)) then
3039     write(mf,NML=tp100name)
3040    endif   
3041 
3042 else
3043    if(present(mf)) then
3044     read(mf,NML=tp100name)
3045    endif   
3046
3047
3048
3049 F%tp10%DRIFTKICK=tp100%DRIFTKICK
3050endif
3051endif
3052end subroutine tp10_tp100
3053
3054subroutine  k16_k160(f,dir,mf)
3055implicit none
3056type(element), target :: f
3057logical(lp),optional ::  dir
3058integer,optional :: mf
3059
3060if(present(dir)) then
3061if(dir) then   !BETA0,GAMMA0I,GAMBET,MASS ,AG
3062 
3063 k160%DRIFTKICK=F%k16%DRIFTKICK
3064 k160%LIKEMAD=F%k16%LIKEMAD
3065     if(present(mf)) then
3066     write(mf,NML=k160name)
3067    endif   
3068 
3069 else
3070    if(present(mf)) then
3071     read(mf,NML=k160name)
3072    endif   
3073 F%k16%DRIFTKICK=k160%DRIFTKICK
3074 F%k16%LIKEMAD=k160%LIKEMAD
3075endif
3076endif
3077end subroutine k16_k160
3078
3079subroutine  ap_aplist(f,dir,mf)
3080implicit none
3081type(element), target :: f
3082type(MADX_APERTURE), pointer :: a
3083logical(lp),optional ::  dir
3084integer,optional :: mf
3085logical(LP) :: here
3086CHARACTER(120) LINE
3087
3088here=associated(f%p%APERTURE)
3089
3090if(present(dir)) then
3091if(dir) then   !BETA0,GAMMA0I,GAMBET,MASS ,AG
3092 
3093if(here) then
3094 a=>f%p%aperture
3095
3096    aplist%kind=a%kind
3097    aplist%r=a%r
3098    aplist%x=a%x
3099    aplist%y=a%y
3100    aplist%dx=a%dx
3101    aplist%dy=a%dy
3102     if(present(mf)) then
3103     Write(mf,*) " APERTURE " 
3104     write(mf,NML=aperturename)
3105    endif   
3106else
3107 Write(mf,*) " NO APERTURE "
3108endif
3109 
3110 else   ! dir=false
3111 !  if(present(mf)) then     
3112 !     READ(MF,'(a120)') LINE
3113 !     CALL CONTEXT(LINE)
3114 !  ENDIF
3115    IF(aplist%on) THEN
3116       IF(.NOT.HERE) THEN
3117          CALL alloc(f%p%aperture)
3118           a=>f%p%aperture
3119       ENDIF
3120   
3121   
3122    if(present(mf)) then     
3123     read(mf,NML=aperturename)
3124    endif   
3125      a%kind=aplist%kind
3126      a%r=aplist%r
3127      a%x=aplist%x
3128      a%y=aplist%y
3129      a%dx=aplist%dx
3130      a%dy=aplist%dy     
3131    ENDIF
3132endif
3133endif
3134end subroutine ap_aplist
3135
3136
3137subroutine  r_ap_aplist(mf)
3138implicit none
3139integer  mf
3140CHARACTER(120) LINE
3141   
3142      READ(MF,'(a120)') LINE
3143      CALL CONTEXT(LINE)
3144    IF(LINE(1:2)/='NO') THEN
3145        read(mf,NML=aperturename)
3146       aplist%on=.true.
3147   !    write(6,nml=aperturename)
3148    else
3149     aplist%on=.false.
3150    endif
3151   
3152end subroutine r_ap_aplist
3153
3154!!!!!!!!!!!!!!!!!!!!!    pointed lattices !!!!!!!!!!!!!!!!!!!!!
3155
3156subroutine  print_universe_pointed(ud,un,filename,com)
3157! call print_universe_pointed(m_u,m_t,'junk3.txt')
3158implicit none
3159type(mad_universe),target :: ud,un
3160type(layout),pointer :: r
3161character(6), optional ::com
3162type(fibre),pointer :: p,p0,ps
3163type(element),pointer :: m,m0
3164character(*) filename
3165integer i,j,i0,j0,i1,j1,jb,MF
3166character (6) comt
3167logical(lp) before,just
3168
3169comt='REWIND'
3170if(present(com)) comt=com
3171
3172call kanalnummer(mf)
3173open(unit=mf,file=filename,position=comt)
3174
3175
3176call TIE_MAD_UNIVERSE(ud)
3177
3178
3179r=>un%start
3180
3181write(mf,*) un%n, "trackable Layouts"
3182
3183
3184do i=1,un%n
3185
3186p0=>r%start
3187p=>p0
3188call locate_in_universe(p,i0,j0)
3189jb=j0
3190j1=j0
3191   write(mf,*) i,r%n," New "
3192
3193
3194  call Print_initial_chart(p,mf)
3195  write(mf,*) i0,p%dir*j0,p%patch%patch,p%mag%name
3196  call fib_fib0(p,my_true,mf)
3197  before=my_false
3198  just=my_false
3199 if(p%patch%patch/=0) call patch_patch0(p%patch,my_true,mf)
3200
3201 do j=2,r%n
3202  p=>p%next
3203    jb=j1
3204   call locate_in_universe(p,i1,j1)
3205    write(mf,*) i1,p%dir*j1,p%patch%patch,p%mag%name
3206       
3207       just=my_false
3208       if(before) then
3209        call fib_fib0(p,my_true,mf)
3210        just=my_true
3211        before=my_false
3212       endif
3213    if(p%patch%patch/=0) then
3214       if(.not.just) call fib_fib0(p,my_true,mf) 
3215       call patch_patch0(p%patch,my_true,mf)   
3216       before=my_true   
3217    endif
3218 enddo
3219
3220write(mf,*) " !!!!!!! End of Pointed Layout !!!!!!!"
3221
3222 r=>r%next
3223
3224enddo
3225
3226close(mf)
3227
3228
3229end subroutine  print_universe_pointed
3230
3231
3232subroutine  read_universe_pointed(ud,un,filename)
3233implicit none
3234type(mad_universe),target :: ud,un
3235type(layout),pointer :: r,rd
3236type(fibre),pointer :: p,p0,ps
3237type(element),pointer :: m,m0
3238character(*) filename
3239integer i,j,i0,MF,n,n_u,k(3)
3240integer pos
3241character(120) line
3242logical(lp) doneit
3243character(nlp) name
3244
3245call kanalnummer(mf)
3246open(unit=mf,file=filename)
3247
3248
3249call TIE_MAD_UNIVERSE(ud)
3250
3251
3252
3253
3254read(mf,*)n_u
3255
3256
3257do i=1,n_u
3258
3259   read(mf,*) i0,n
3260
3261  read(mf,'(a120)') line
3262 call read_initial_chart(mf)
3263  read(mf,'(a120)') line
3264
3265call append_empty_layout(un)
3266call set_up(un%end)  !
3267
3268       R => un%end
3269
3270 do j=1,n
3271       read(mf,*) k    ,name
3272if(j==1.or.k(3)>0) then
3273 read(mf,NML=FIBRENAME)
3274else
3275 if(r%end%patch%patch>0) read(mf,NML=FIBRENAME)    ! previous had a patch
3276endif
3277
3278       call MOVE_TO_LAYOUT_I( ud,rd,k(1) )
3279       pos=iabs(k(2))   
3280       call move_to( rd,p,POS)
3281       call append_point(r, p) 
3282       if( p%mag%name/=name) then
3283         write(6,*) " serious error in read_universe_pointed "
3284         write(6,*) i,p%mag%name,name,k
3285!         pause 666
3286         stop 666   
3287       endif
3288!       write(6,*) p%mag%name,name,pos,k(2)
3289!pause 12
3290     
3291        if(k(3)/=0) then
3292        read(mf,NML=patchname)
3293        call patch_patch0(r%end%patch,my_false)
3294        endif
3295        r%end%patch%patch=k(3)
3296
3297       call fib_fib0(r%end,my_false)
3298       if(k(2)>0) then   ! because fib0 could have the wrong dir
3299        r%end%dir=1
3300       else
3301        r%end%dir=-1
3302       endif
3303 enddo
3304
3305
3306    r%closed=my_true
3307    doneit=my_true
3308    call ring_l(r,doneit)
3309
3310  p=>r%start
3311  p%chart%f%a=a_
3312  p%chart%f%ent=ent_
3313! else
3314  p%chart%f%b=b_
3315  p%chart%f%exi=exi_
3316call survey(r)
3317read(mf,'(a10)') line(1:10)
3318
3319enddo
3320
3321
3322
3323close(mf)
3324
3325
3326end subroutine  read_universe_pointed
3327
3328
3329 subroutine Print_initial_chart(f,mf)
3330 implicit none
3331 type(fibre), target :: f
3332 integer mf
3333
3334 write(mf,*) " $$$$$$$$$$$$$$$$$ INITIAL CHART $$$$$$$$$$$$$$$$$"
3335!  IF(F%DIR==1) THEN
3336   write(mf,*) f%chart%f%A
3337   write(mf,*) f%chart%f%ENT(1,1:3)
3338   write(mf,*) f%chart%f%ENT(2,1:3)
3339   write(mf,*) f%chart%f%ENT(3,1:3)
3340!  ELSE
3341   write(mf,*) f%chart%f%B
3342   write(mf,*) f%chart%f%EXI(1,1:3)
3343   write(mf,*) f%chart%f%EXI(2,1:3)
3344   write(mf,*) f%chart%f%EXI(3,1:3)
3345!  ENDIF
3346 write(mf,*) " $$$$$$$$$$$$$$$$$ END OF INITIAL CHART $$$$$$$$$$$$$$$$$"
3347
3348 end subroutine Print_initial_chart
3349
3350 subroutine read_initial_chart(mf)
3351 implicit none
3352 integer mf
3353 
3354   read(mf,*) A_
3355   read(mf,*) ENT_(1,1:3)
3356   read(mf,*) ENT_(2,1:3)
3357   read(mf,*) ENT_(3,1:3)
3358
3359   read(mf,*) B_
3360   read(mf,*) EXI_(1,1:3)
3361   read(mf,*) EXI_(2,1:3)
3362   read(mf,*) EXI_(3,1:3)
3363
3364 end subroutine read_initial_chart
3365
3366
3367subroutine create_dna(ud,ut)
3368implicit none
3369type(mad_universe), target :: ut,ud
3370type(layout), pointer :: r,rd
3371type(fibre), pointer :: ps
3372integer i,j,j1,j2,k,kn
3373logical(lp), allocatable :: here(:)
3374
3375
3376
3377call TIE_MAD_UNIVERSE(ut)
3378
3379allocate(here(ud%n))
3380
3381r=>ut%start
3382do i=1,ut%n
3383
3384here=my_false
3385
3386ps => r%start
3387
3388do j=1,r%n
3389 call locate_in_universe(ps,j1,j2)
3390 here(j1)=my_true
3391ps=>ps%next
3392enddo
3393
3394kn=0
3395do k=1,size(here)
3396 if(here(k)) kn=kn+1
3397enddo
3398
3399if(associated(r%DNA)) then
3400deallocate(r%DNA)
3401write(6,*) "deallocated DNA"
3402endif
3403allocate(r%DNA(kn))
3404
3405rd=>ud%start
3406kn=0
3407do k=1,size(here)
3408 if(here(k)) then
3409    kn=kn+1
3410    r%dna(kn)%L=>rd
3411    r%dna(kn)%counter=k
3412  endif
3413 rd=>rd%next
3414enddo
3415
3416
3417 r=>r%next
3418
3419enddo
3420
3421deallocate(here)
3422
3423end subroutine create_dna
3424
3425end module madx_keywords
3426
Note: See TracBrowser for help on using the repository browser.