source: PSPA/madxPSPA/libs/ptc/src/Sm_tracking.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: 27.5 KB
Line 
1!The Polymorphic Tracking Code
2!Copyright (C) Etienne Forest and CERN
3
4
5MODULE S_TRACKING
6  USE S_FAMILY
7
8  IMPLICIT NONE
9  public
10  logical(lp),TARGET :: ALWAYS_EXACT_PATCHING=.TRUE.
11  !  type(fibre), pointer :: lost_fibre
12  !  type(integration_node), pointer :: lost_node
13
14  ! linked
15  PRIVATE TRACK_LAYOUT_FLAG_R,TRACK_LAYOUT_FLAG_P
16  !  PRIVATE FIND_ORBIT_LAYOUT,FIND_ORBIT_M_LAYOUT,FIND_ENV_LAYOUT, FIND_ORBIT_LAYOUT_noda
17  PRIVATE TRACK_LAYOUT_FLAG_R1,TRACK_LAYOUT_FLAG_P1
18  PRIVATE MIS_FIBR,MIS_FIBP,PATCH_FIBR,PATCH_FIBP
19  PRIVATE TRACK_FIBRE_R,TRACK_FIBRE_P
20  PRIVATE TRACK_LAYOUT_FLAG_R1f,TRACK_LAYOUT_FLAG_P1f
21  PRIVATE TRACK_LAYOUT_FLAG_Rf,TRACK_LAYOUT_FLAG_Pf
22  private TRACK_fibre_based_R,TRACK_fibre_based_P
23  ! old Sj_elements
24  ! END old Sj_elements
25
26  ! TYPE UPDATING
27  !    logical(lp) UPDATE
28  ! END TYPE UPDATING
29
30
31
32  !  TYPE (UPDATING), PARAMETER ::  COMPUTE= UPDATING(.TRUE.)
33  LOGICAL :: COMPUTE = .FALSE.
34
35  INTERFACE TRACK
36     ! linked
37     MODULE PROCEDURE TRACK_LAYOUT_FLAG_R
38     MODULE PROCEDURE TRACK_LAYOUT_FLAG_P
39     MODULE PROCEDURE TRACK_LAYOUT_FLAG_R1
40     MODULE PROCEDURE TRACK_LAYOUT_FLAG_P1
41     MODULE PROCEDURE TRACK_FIBRE_R
42     MODULE PROCEDURE TRACK_FIBRE_P
43     MODULE PROCEDURE TRACK_fibre_based_R
44     MODULE PROCEDURE TRACK_fibre_based_P
45     ! old Sj_elements
46     ! END old Sj_elements
47  END INTERFACE
48
49
50  INTERFACE TRACK_FIBRE_SINGLE
51     MODULE PROCEDURE TRACK_FIBRE_R
52     MODULE PROCEDURE TRACK_FIBRE_P
53  END INTERFACE
54
55  INTERFACE TRACK_FLAG
56     MODULE PROCEDURE TRACK_LAYOUT_FLAG_R1f
57     MODULE PROCEDURE TRACK_LAYOUT_FLAG_P1f
58     MODULE PROCEDURE TRACK_LAYOUT_FLAG_Rf
59     MODULE PROCEDURE TRACK_LAYOUT_FLAG_Pf
60  END INTERFACE
61
62
63  INTERFACE PATCH_FIB
64     MODULE PROCEDURE PATCH_FIBR
65     MODULE PROCEDURE PATCH_FIBP
66  END INTERFACE
67
68  INTERFACE MIS_FIB
69     MODULE PROCEDURE MIS_FIBR
70     MODULE PROCEDURE MIS_FIBP
71  END INTERFACE
72
73
74contains
75  ! old Sj_elements
76
77
78  ! END old Sj_elements
79
80  !  recursive
81  integer function TRACK_LAYOUT_FLAG_R1f(R,X,II1,k,X_IN)
82    implicit none
83    TYPE(layout),target,INTENT(INOUT):: R
84    real(dp), INTENT(INOUT):: X(6)
85    TYPE(WORM), OPTIONAL,INTENT(INOUT):: X_IN
86    TYPE(INTERNAL_STATE) K
87    INTEGER, INTENT(IN):: II1
88
89    call track(R,X,II1,k,X_IN)
90    call PRODUCE_APERTURE_FLAG(TRACK_LAYOUT_FLAG_R1f)
91    !    call RESET_APERTURE_FLAG(my_false)
92  end  function TRACK_LAYOUT_FLAG_R1f
93
94  !  recursive
95  integer function TRACK_LAYOUT_FLAG_P1f(R,X,II1,k)
96    implicit none
97    TYPE(layout),target,INTENT(INOUT):: R
98    TYPE(REAL_8), INTENT(INOUT):: X(6)
99    !    TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: X_IN
100    TYPE(INTERNAL_STATE) K
101    INTEGER, INTENT(IN):: II1
102
103    call track(R,X,II1,k)
104    call PRODUCE_APERTURE_FLAG(TRACK_LAYOUT_FLAG_P1f)
105    !    call RESET_APERTURE_FLAG(my_false)
106
107  end  function TRACK_LAYOUT_FLAG_P1f
108
109  !  recursive
110  SUBROUTINE TRACK_LAYOUT_FLAG_R1(R,X,II1,k,X_IN) ! Tracks real(dp) from II1 to the end or back to II1 if closed
111    implicit none
112    TYPE(layout),target,INTENT(INOUT):: R
113    real(dp), INTENT(INOUT):: X(6)
114    TYPE(WORM), OPTIONAL,INTENT(INOUT):: X_IN
115    TYPE(INTERNAL_STATE) K
116    INTEGER, INTENT(IN):: II1
117    INTEGER II2
118
119    !    CALL RESET_APERTURE_FLAG
120
121    IF(R%CLOSED) THEN
122       II2=II1+R%N
123    ELSE
124       II2=R%N+1
125    ENDIF
126
127    CALL TRACK(R,X,II1,II2,k,X_IN)
128    !    if(c_%watch_user) ALLOW_TRACKING=.FALSE.
129  END SUBROUTINE TRACK_LAYOUT_FLAG_R1
130
131  !  recursive
132  SUBROUTINE TRACK_LAYOUT_FLAG_P1(R,X,II1,k) ! Tracks polymorphs from II1 to the end or back to II1 if closed
133    implicit none
134    TYPE(layout),target,INTENT(INOUT):: R
135    TYPE(REAL_8), INTENT(INOUT):: X(6)
136    !    TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: X_IN
137    TYPE(INTERNAL_STATE) K
138    INTEGER, INTENT(IN):: II1
139    INTEGER II2
140
141    !    CALL RESET_APERTURE_FLAG
142
143    IF(R%CLOSED) THEN
144       II2=II1+R%N
145    ELSE
146       II2=R%N+1
147    ENDIF
148
149    CALL TRACK(R,X,II1,II2,k)
150    !    if(c_%watch_user) ALLOW_TRACKING=.FALSE.
151
152  END SUBROUTINE TRACK_LAYOUT_FLAG_P1
153
154  !  recursive
155  integer function TRACK_LAYOUT_FLAG_Rf(R,X,I1,I2,k,X_IN) ! Tracks double from i1 to i2 in state k
156    IMPLICIT NONE
157    TYPE(layout),target,INTENT(INOUT):: R
158    real(dp), INTENT(INOUT):: X(6)
159    TYPE(INTERNAL_STATE) K
160    TYPE(WORM), OPTIONAL,INTENT(INOUT):: X_IN
161    INTEGER, INTENT(IN):: I1,I2
162
163    call track(R,X,I1,I2,k,X_IN)
164    call PRODUCE_APERTURE_FLAG(TRACK_LAYOUT_FLAG_Rf)
165
166  end  function TRACK_LAYOUT_FLAG_Rf
167
168  !  recursive
169  integer function TRACK_LAYOUT_FLAG_Pf(R,X,I1,I2,k) ! Tracks double from i1 to i2 in state k
170    IMPLICIT NONE
171    TYPE(LAYOUT),target,INTENT(INOUT):: R ;
172    TYPE(REAL_8), INTENT(INOUT):: X(6);
173    INTEGER, INTENT(IN):: I1,I2; TYPE(INTERNAL_STATE) K;
174    !    TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: X_IN
175
176    call track(R,X,I1,I2,k)
177    call PRODUCE_APERTURE_FLAG(TRACK_LAYOUT_FLAG_Pf)
178
179  end  function TRACK_LAYOUT_FLAG_Pf
180
181
182
183
184  SUBROUTINE TRACK_fibre_based_R(X,k,fibre1,fibre2) ! Tracks double from i1 to i2 in state k
185    IMPLICIT NONE
186    real(dp), INTENT(INOUT):: X(6)
187    TYPE(INTERNAL_STATE) K
188    TYPE (fibre), POINTER :: fibre1
189    TYPE (fibre), optional, POINTER :: fibre2
190    TYPE (fibre), POINTER :: C,c1,c2,last
191
192    c1=>fibre1
193    if(present(fibre2)) then
194       c2=>fibre2
195       nullify(last)
196    else
197       if(fibre1%parent_layout%closed) then
198          last=>fibre1%previous
199          c2=>last
200       else
201          last=>fibre1%parent_layout%end
202          c2=>fibre1%parent_layout%end
203       endif
204    endif
205
206
207    c=>c1
208
209
210
211    DO  WHILE(.not.ASSOCIATED(C,c2))
212
213       CALL TRACK(C,X,K)
214       if(.not.check_stable) exit
215
216       C=>C%NEXT
217    ENDDO
218
219    if(associated(last).and.check_stable) then
220       CALL TRACK(last,X,K)
221    endif
222
223    C_%STABLE_DA=.true.
224
225
226
227  END SUBROUTINE TRACK_fibre_based_R
228
229
230  SUBROUTINE TRACK_fibre_based_p(X,k,fibre1,fibre2) ! Tracks double from i1 to i2 in state k
231    IMPLICIT NONE
232    type(real_8), INTENT(INOUT):: X(6)
233    TYPE(INTERNAL_STATE) K
234    TYPE (fibre), POINTER :: fibre1
235    TYPE (fibre), optional, POINTER :: fibre2
236    TYPE (fibre), POINTER :: C,c1,c2,last
237
238    c1=>fibre1
239    if(present(fibre2)) then
240       c2=>fibre2
241       nullify(last)
242    else
243       if(fibre1%parent_layout%closed) then
244          last=>fibre1%previous
245          c2=>last
246       else
247          last=>fibre1%parent_layout%end
248          c2=>fibre1%parent_layout%end
249       endif
250    endif
251
252
253    c=>c1
254
255
256
257    DO  WHILE(.not.ASSOCIATED(C,c2))
258
259       CALL TRACK(C,X,K)
260       if(.not.check_stable) exit
261
262       C=>C%NEXT
263    ENDDO
264
265    if(associated(last).and.check_stable) then
266       CALL TRACK(last,X,K)
267    endif
268
269    C_%STABLE_DA=.true.
270
271
272  END SUBROUTINE TRACK_fibre_based_p
273
274
275
276
277
278  SUBROUTINE TRACK_LAYOUT_FLAG_R(R,X,I1,I2,k,X_IN) ! Tracks double from i1 to i2 in state k
279    IMPLICIT NONE
280    TYPE(layout),target,INTENT(INOUT):: R
281    real(dp), INTENT(INOUT):: X(6)
282    TYPE(INTERNAL_STATE) K
283    TYPE(WORM), OPTIONAL,INTENT(INOUT):: X_IN
284    INTEGER, INTENT(IN):: I1,I2
285    INTEGER J,i22
286    TYPE (fibre), POINTER :: C
287
288
289    ! CALL RESET_APERTURE_FLAG
290
291
292
293    call move_to(r,c,I1)
294
295    if(i2>=i1) then
296       i22=i2
297    else
298       i22=r%n+i2
299    endif
300
301    !    if(i2>i1) then
302    J=I1
303
304    DO  WHILE(J<I22.AND.ASSOCIATED(C))
305       CALL TRACK(C,X,K,X_IN=X_IN)  !,C%CHARGE
306       !       CALL TRACK(C,X,K,R%CHARGE,X_IN)
307
308       if(.not.check_stable) exit
309
310       C=>C%NEXT
311       J=J+1
312    ENDDO
313
314    C_%STABLE_DA=.true.
315
316    !    else
317    !       J=I1
318    !
319    !       DO  WHILE(J>I2.AND.ASSOCIATED(C))
320    !          j_global=j
321    !
322    !          c%dir=-c%dir
323    !          CALL TRACK(C,X,K,R%CHARGE,X_IN)
324    !          c%dir=-c%dir
325    !
326    !          C=>C%previous
327    !          J=J-1
328    !       ENDDO
329    !
330    !    endif
331
332
333    !    if(c_%watch_user) ALLOW_TRACKING=.FALSE.
334
335  END SUBROUTINE TRACK_LAYOUT_FLAG_R
336
337
338
339  !  recursive
340  SUBROUTINE TRACK_LAYOUT_FLAG_P(R,X,I1,I2,K) ! TRACKS POLYMORPHS FROM I1 TO I2 IN STATE K
341    IMPLICIT NONE
342    TYPE(LAYOUT),target,INTENT(INOUT):: R ;TYPE(REAL_8), INTENT(INOUT):: X(6);
343    INTEGER, INTENT(IN):: I1,I2; TYPE(INTERNAL_STATE) K;
344    !    TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: X_IN
345    INTEGER J,I22
346
347    TYPE (FIBRE), POINTER :: C
348
349
350    !  CALL RESET_APERTURE_FLAG
351
352    call move_to(r,c,I1)
353
354    if(i2>=i1) then
355       i22=i2
356    else
357       i22=r%n+i2
358    endif
359
360    !    if(i2>i1) then
361    J=I1
362
363    DO  WHILE(J<I22.AND.ASSOCIATED(C))
364       CALL TRACK(C,X,K)  !,C%CHARGE
365       !       CALL TRACK(C,X,K,R%CHARGE)
366       if(.not.check_stable) exit
367
368       C=>C%NEXT
369       J=J+1
370    ENDDO
371
372    C_%STABLE_DA=.true.
373
374    !    else
375    !       J=I1
376
377    !       DO  WHILE(J>I2.AND.ASSOCIATED(C))
378    !          j_global=j
379
380    !          c%dir=-c%dir
381    !          CALL TRACK(C,X,K,R%CHARGE,X_IN)
382    !          c%dir=-c%dir
383
384    !          C=>C%previous
385    !          J=J-1
386    !       ENDDO
387
388    !    endif
389
390    !    if(c_%watch_user) ALLOW_TRACKING=.FALSE.
391
392    ! PATCHES
393  END SUBROUTINE TRACK_LAYOUT_FLAG_P
394
395  !  recursive
396  !  SUBROUTINE TRACK_FIBRE_R(C,X,K,CHARGE,X_IN)
397  SUBROUTINE TRACK_FIBRE_R(C,X,K,X_IN)
398    implicit none
399    logical(lp) :: doneitt=.true.
400    logical(lp) :: doneitf=.false.
401    TYPE(FIBRE),TARGET,INTENT(INOUT):: C
402    real(dp), INTENT(INOUT):: X(6)
403    TYPE(WORM), OPTIONAL,INTENT(INOUT):: X_IN
404    !    INTEGER,optional, target, INTENT(IN) :: CHARGE
405    TYPE(INTERNAL_STATE), INTENT(IN) :: K
406    logical(lp) ou,patch
407    INTEGER(2) PATCHT,PATCHG,PATCHE
408    TYPE (fibre), POINTER :: CN
409    real(dp), POINTER :: P0,B0
410    REAL(DP) ENT(3,3), A(3)
411
412    ! real(dp), POINTER :: BETA0,GAMMA0I,GAMBET,P0C,MASS0
413    !INTEGER, POINTER :: CHARGE
414
415
416    IF(.NOT.CHECK_STABLE) then
417       CALL RESET_APERTURE_FLAG
418    endif
419    !    C%MAG%P%p0c=>c%p0c
420    C%MAG%P%beta0=>c%beta0
421    C%MAG%P%GAMMA0I=>c%GAMMA0I
422    C%MAG%P%GAMBET=>c%GAMBET
423    C%MAG%P%CHARGE=>c%CHARGE
424    ! DIRECTIONAL VARIABLE
425    C%MAG%P%DIR=>C%DIR
426    ! if(present(charge)) then
427    !    C%MAG%P%CHARGE=>CHARGE
428    ! endif
429    !  C%MAG=K
430
431    !    if(c_%x_prime) then
432    !       P0=>C%MAG%P%P0C
433    !       B0=>C%MAG%P%BETA0
434    !       IF(C%MAG%P%exact)THEN
435    !          IF(k%TIME)THEN
436    !             xp=x(2)/root(one+two*X(5)/B0+X(5)**2-x(2)**2-x(4)**2)
437    !             x(4)=x(4)/root(one+two*X(5)/B0+X(5)**2-x(2)**2-x(4)**2)
438    !             x(2)=xp
439    !          else
440    !             xp=x(2)/root((one+x(5))**2-x(2)**2-x(4)**2)
441    !             x(4)=x(4)/root((one+x(5))**2-x(2)**2-x(4)**2)
442    !             x(2)=xp
443    !          endif
444    !       else
445    !          IF(k%TIME)THEN
446    !             x(2)=x(2)/root(one+two*X(5)/B0+X(5)**2)
447    !             x(4)=x(4)/root(one+two*X(5)/B0+X(5)**2)
448    !          else
449    !             x(2)=x(2)/(one+x(5))
450    !             x(4)=x(4)/(one+x(5))
451    !          endif
452    !       endif
453    !    endif
454
455
456    IF(PRESENT(X_IN)) then
457       X_IN%F=>c ; X_IN%E%F=>C; X_IN%NST=>X_IN%E%NST;
458    endif
459
460    !
461    !    IF(.NOT.CHECK_STABLE) CHECK_STABLE=.TRUE.
462    !FRONTAL PATCH
463    !    IF(ASSOCIATED(C%PATCH)) THEN
464    PATCHT=C%PATCH%TIME ;PATCHE=C%PATCH%ENERGY ;PATCHG=C%PATCH%PATCH;
465    !    ELSE
466    !       PATCHT=0 ; PATCHE=0 ;PATCHG=0;
467    !    ENDIF
468    IF(PRESENT(X_IN)) then
469       CALL XMID(X_IN,X,-6)
470       X_IN%POS(1)=X_IN%nst
471    endif
472
473    IF(PATCHE/=0.AND.PATCHE/=2) THEN
474       NULLIFY(P0);NULLIFY(B0);
475       CN=>C%PREVIOUS
476       IF(ASSOCIATED(CN)) THEN ! ASSOCIATED
477          !          IF(.NOT.CN%PATCH%ENERGY) THEN     ! No need to patch IF PATCHED BEFORE
478          IF(CN%PATCH%ENERGY==0) THEN     ! No need to patch IF PATCHED BEFORE
479             P0=>CN%MAG%P%P0C
480             B0=>CN%BETA0
481
482             X(2)=X(2)*P0/C%MAG%P%P0C
483             X(4)=X(4)*P0/C%MAG%P%P0C
484             IF(k%TIME.or.recirculator_cheat)THEN
485                X(5)=root(1.0_dp+2.0_dp*X(5)/B0+X(5)**2)  !X(5) = 1+DP/P0C_OLD
486                X(5)=X(5)*P0/C%MAG%P%P0C-1.0_dp !X(5) = DP/P0C_NEW
487                X(5)=(2.0_dp*X(5)+X(5)**2)/(root(1.0_dp/C%MAG%P%BETA0**2+2.0_dp*X(5)+X(5)**2)+1.0_dp/C%MAG%P%BETA0)
488             ELSE
489                X(5)=(1.0_dp+X(5))*P0/C%MAG%P%P0C-1.0_dp
490             ENDIF
491          ENDIF ! No need to patch
492       ENDIF ! ASSOCIATED
493
494    ENDIF
495    IF(PRESENT(X_IN)) CALL XMID(X_IN,X,-5)
496
497    ! The chart frame of reference is located here implicitely
498    IF(PATCHG==1.or.PATCHG==3) THEN
499       patch=ALWAYS_EXACT_PATCHING.or.C%MAG%P%EXACT
500       CALL PATCH_FIB(C,X,k,PATCH,MY_TRUE)
501    ENDIF
502    IF(PRESENT(X_IN)) CALL XMID(X_IN,X,-4)
503    IF(PATCHT/=0.AND.PATCHT/=2.AND.(K%TOTALPATH==0)) THEN
504      if(K%time) then
505       X(6)=X(6)-C%PATCH%a_T/c%beta0
506      else
507       X(6)=X(6)-C%PATCH%a_T
508      endif
509    ENDIF
510    IF(PRESENT(X_IN)) CALL XMID(X_IN,X,-3)
511
512    CALL DTILTD(C%DIR,C%MAG%P%TILTD,1,X)
513    IF(PRESENT(X_IN)) CALL XMID(X_IN,X,-2)
514    ! The magnet frame of reference is located here implicitely before misalignments
515
516    !      CALL TRACK(C,X,EXACTMIS=K%EXACTMIS)
517    IF(C%MAG%MIS) THEN
518       ou = ALWAYS_EXACTMIS    !K%EXACTMIS.or.
519       CALL MIS_FIB(C,X,k,OU,DONEITT)
520    ENDIF
521    IF(PRESENT(X_IN)) then
522       CALL XMID(X_IN,X,-1)
523       X_IN%POS(2)=X_IN%nst
524    endif
525
526    CALL TRACK(C%MAG,X,K,X_IN)
527    !    if(abs(x(1))+abs(x(3))>absolute_aperture.or.(.not.CHECK_MADX_APERTURE)) then ! new 2010
528    !       if(CHECK_MADX_APERTURE) c_%message="exceed absolute_aperture in TRACK_FIBRE_R"
529    !       CHECK_STABLE=.false.
530    !    else   ! new 2010
531
532    IF(PRESENT(X_IN)) then
533       CALL XMID(X_IN,X,X_IN%nst+1)
534       X_IN%POS(3)=X_IN%nst
535    endif
536
537    IF(C%MAG%MIS) THEN
538       CALL MIS_FIB(C,X,k,OU,DONEITF)
539    ENDIF
540    IF(PRESENT(X_IN)) CALL XMID(X_IN,X,X_IN%nst+1)
541    ! The magnet frame of reference is located here implicitely before misalignments
542    CALL DTILTD(C%DIR,C%MAG%P%TILTD,2,X)
543    IF(PRESENT(X_IN)) CALL XMID(X_IN,X,X_IN%nst+1)
544
545    IF(PATCHT/=0.AND.PATCHT/=1.AND.(K%TOTALPATH==0)) THEN
546      if(K%time) then
547       X(6)=X(6)-C%PATCH%b_T/c%beta0
548      else
549       X(6)=X(6)-C%PATCH%b_T
550      endif
551    ENDIF
552    IF(PRESENT(X_IN)) CALL XMID(X_IN,X,X_IN%nst+1)
553
554    IF(PATCHG==2.or.PATCHG==3) THEN
555       patch=ALWAYS_EXACT_PATCHING.or.C%MAG%P%EXACT
556       CALL PATCH_FIB(C,X,k,PATCH,MY_FALSE)
557    ENDIF
558    IF(PRESENT(X_IN)) CALL XMID(X_IN,X,X_IN%nst+1)
559
560    ! The CHART frame of reference is located here implicitely
561
562    IF(PATCHE/=0.AND.PATCHE/=1) THEN
563       NULLIFY(P0);NULLIFY(B0);
564       CN=>C%NEXT
565       IF(.NOT.ASSOCIATED(CN)) CN=>C
566       P0=>CN%MAG%P%P0C
567       B0=>CN%BETA0
568       X(2)=X(2)*C%MAG%P%P0C/P0
569       X(4)=X(4)*C%MAG%P%P0C/P0
570       IF(k%TIME.or.recirculator_cheat)THEN
571          X(5)=root(1.0_dp+2.0_dp*X(5)/C%MAG%P%BETA0+X(5)**2)  !X(5) = 1+DP/P0C_OLD
572          X(5)=X(5)*C%MAG%P%P0C/P0-1.0_dp !X(5) = DP/P0C_NEW
573          X(5)=(2.0_dp*X(5)+X(5)**2)/(root(1.0_dp/B0**2+2.0_dp*X(5)+X(5)**2)+1.0_dp/B0)
574       ELSE
575          X(5)=(1.0_dp+X(5))*C%MAG%P%P0C/P0-1.0_dp
576       ENDIF
577    ENDIF
578
579    IF(PRESENT(X_IN)) then
580       CALL XMID(X_IN,X,X_IN%nst+1)
581       X_IN%POS(4)=X_IN%nst
582    endif
583
584    IF(PRESENT(X_IN))  THEN
585       IF(X_IN%E%DO_SURVEY) THEN
586          CALL G_FRAME(X_IN%E,ENT,A,-7)
587          CALL  SURVEY(C,ENT,A,E_IN=X_IN%E)
588       ELSE
589          CALL SURVEY_INNER_MAG(X_IN%E)
590       ENDIF
591    ENDIF
592
593    !    endif ! new 2010
594
595    if(abs(x(1))+abs(x(3))>absolute_aperture) then   !.or.(.not.CHECK_MADX_APERTURE)) then
596       messageLOST="exceed absolute_aperture in TRACK_FIBRE_R"
597       xlost=x
598       CHECK_STABLE=.false.
599    endif
600    if(.not.check_stable ) lost_fibre=>c
601
602  END SUBROUTINE TRACK_FIBRE_R
603
604  !  recursive
605  !  SUBROUTINE TRACK_FIBRE_P(C,X,K,CHARGE)
606  SUBROUTINE TRACK_FIBRE_P(C,X,K)
607    IMPLICIT NONE
608    logical(lp) :: doneitt=.true.
609    logical(lp) :: doneitf=.false.
610    TYPE(FIBRE),TARGET,INTENT(INOUT):: C
611    TYPE(REAL_8), INTENT(INOUT):: X(6)
612    !    TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: X_IN
613    !   INTEGER, optional,TARGET, INTENT(IN) :: CHARGE
614    TYPE(INTERNAL_STATE), INTENT(IN) :: K
615    logical(lp) OU,PATCH
616    INTEGER(2) PATCHT,PATCHG,PATCHE
617    TYPE (FIBRE), POINTER :: CN
618    REAL(DP), POINTER :: P0,B0
619
620    IF(.NOT.CHECK_STABLE) then
621       CALL RESET_APERTURE_FLAG
622    endif
623    !    C%MAGp%P%p0c=>c%p0c
624    C%MAGp%P%beta0=>c%beta0
625    C%MAGp%P%GAMMA0I=>c%GAMMA0I
626    C%MAGp%P%GAMBET=>c%GAMBET
627    C%MAGp%P%CHARGE=>c%CHARGE
628    C%MAGP%P%DIR=>C%DIR
629    !    if(present(charge)) then
630    !       C%MAGP%P%CHARGE=>CHARGE
631    !    endif
632
633    ! NEW STUFF WITH KIND=3: KNOB OF FPP IS SET TO TRUE IF NECESSARY
634    IF(K%PARA_IN ) KNOB=.TRUE.
635    PATCHT=C%PATCH%TIME ;PATCHE=C%PATCH%ENERGY ;PATCHG=C%PATCH%PATCH;
636    IF(PATCHE/=0.AND.PATCHE/=2) THEN
637       NULLIFY(P0);NULLIFY(B0);
638       CN=>C%PREVIOUS
639       IF(ASSOCIATED(CN)) THEN ! ASSOCIATED
640          !          IF(.NOT.CN%PATCH%ENERGY) THEN     ! NO NEED TO PATCH IF PATCHED BEFORE
641          IF(CN%PATCH%ENERGY==0) THEN     ! NO NEED TO PATCH IF PATCHED BEFORE
642             P0=>CN%MAGP%P%P0C
643             B0=>CN%BETA0
644
645             X(2)=X(2)*P0/C%MAGP%P%P0C
646             X(4)=X(4)*P0/C%MAGP%P%P0C
647             IF(k%TIME.or.recirculator_cheat)THEN
648                X(5)=SQRT(1.0_dp+2.0_dp*X(5)/B0+X(5)**2)  !X(5) = 1+DP/P0C_OLD
649                X(5)=X(5)*P0/C%MAGP%P%P0C-1.0_dp !X(5) = DP/P0C_NEW
650                X(5)=(2.0_dp*X(5)+X(5)**2)/(SQRT(1.0_dp/C%MAGP%P%BETA0**2+2.0_dp*X(5)+X(5)**2)+1.0_dp/C%MAGP%P%BETA0)
651             ELSE
652                X(5)=(1.0_dp+X(5))*P0/C%MAGP%P%P0C-1.0_dp
653             ENDIF
654          ENDIF ! NO NEED TO PATCH
655       ENDIF ! ASSOCIATED
656
657    ENDIF
658    !    IF(PRESENT(X_IN)) CALL XMID(X_IN,X,-5)
659
660
661    ! POSITION PATCH
662    IF(PATCHG==1.or.PATCHG==3) THEN
663       patch=ALWAYS_EXACT_PATCHING.or.C%MAGP%P%EXACT
664       CALL PATCH_FIB(C,X,k,PATCH,MY_TRUE)
665    ENDIF
666    !    IF(PRESENT(X_IN)) CALL XMID(X_IN,X,-4)
667    ! TIME PATCH
668    IF(PATCHT/=0.AND.PATCHT/=2.AND.(K%TOTALPATH==0)) THEN
669      if(K%time) then
670       X(6)=X(6)-C%PATCH%a_T/c%beta0
671      else
672       X(6)=X(6)-C%PATCH%a_T
673      endif
674    ENDIF
675    !    IF(PRESENT(X_IN)) CALL XMID(X_IN,X,-3)
676
677    CALL DTILTD(C%DIR,C%MAGP%P%TILTD,1,X)
678    !    IF(PRESENT(X_IN)) CALL XMID(X_IN,X,-2)
679    ! MISALIGNMENTS AT THE ENTRANCE
680    IF(C%MAGP%MIS) THEN
681       OU =ALWAYS_EXACTMIS   ! K%EXACTMIS.OR.
682       CALL MIS_FIB(C,X,k,OU,DONEITT)
683    ENDIF
684
685    CALL TRACK(C%MAGP,X,K)
686    !    if(abs(x(1))+abs(x(3))>absolute_aperture.or.(.not.CHECK_MADX_APERTURE)) then ! new 2010
687    !       if(CHECK_MADX_APERTURE) c_%message="exceed absolute_aperture in TRACK_FIBRE_P"
688    !       CHECK_STABLE=.false.
689    !    else ! new 2010
690
691
692
693    ! MISALIGNMENTS AT THE EXIT
694    IF(C%MAGP%MIS) THEN
695       CALL MIS_FIB(C,X,k,OU,DONEITF)
696    ENDIF
697    !    IF(PRESENT(X_IN)) CALL XMID(X_IN,X,X_IN%nst+1)
698
699    CALL DTILTD(C%DIR,C%MAGP%P%TILTD,2,X)
700    !    IF(PRESENT(X_IN)) CALL XMID(X_IN,X,X_IN%nst+1)
701
702    !EXIT PATCH
703    ! TIME PATCH
704    IF(PATCHT/=0.AND.PATCHT/=1.AND.(K%TOTALPATH==0)) THEN
705      if(K%time) then
706       X(6)=X(6)-C%PATCH%b_T/c%beta0
707      else
708       X(6)=X(6)-C%PATCH%b_T
709      endif
710    ENDIF
711    !    IF(PRESENT(X_IN)) CALL XMID(X_IN,X,X_IN%nst+1)
712
713    ! POSITION PATCH
714    IF(PATCHG==2.or.PATCHG==3) THEN
715       patch=ALWAYS_EXACT_PATCHING.or.C%MAGP%P%EXACT
716       CALL PATCH_FIB(C,X,k,PATCH,MY_FALSE)
717    ENDIF
718    !    IF(PRESENT(X_IN)) CALL XMID(X_IN,X,X_IN%nst+1)
719
720    ! ENERGY PATCH
721    IF(PATCHE/=0.AND.PATCHE/=1) THEN
722       NULLIFY(P0);NULLIFY(B0);
723       CN=>C%NEXT
724       IF(.NOT.ASSOCIATED(CN)) CN=>C
725       P0=>CN%MAGP%P%P0C
726       B0=>CN%BETA0
727       X(2)=X(2)*C%MAGP%P%P0C/P0
728       X(4)=X(4)*C%MAGP%P%P0C/P0
729       IF(k%TIME.or.recirculator_cheat)THEN
730          X(5)=SQRT(1.0_dp+2.0_dp*X(5)/C%MAGP%P%BETA0+X(5)**2)  !X(5) = 1+DP/P0C_OLD
731          X(5)=X(5)*C%MAGP%P%P0C/P0-1.0_dp !X(5) = DP/P0C_NEW
732          X(5)=(2.0_dp*X(5)+X(5)**2)/(SQRT(1.0_dp/B0**2+2.0_dp*X(5)+X(5)**2)+1.0_dp/B0)
733       ELSE
734          X(5)=(1.0_dp+X(5))*C%MAGP%P%P0C/P0-1.0_dp
735       ENDIF
736    ENDIF
737    !   endif ! new 2010
738
739
740    ! KNOB IS RETURNED TO THE PTC DEFAULT
741    ! NEW STUFF WITH KIND=3
742    KNOB=ALWAYS_knobs
743    ! END NEW STUFF WITH KIND=3
744
745    ! new 2010
746    if(abs(x(1))+abs(x(3))>absolute_aperture) then   !.or.(.not.CHECK_MADX_APERTURE)) then
747       messageLOST="exceed absolute_aperture in TRACK_FIBRE_P"
748       xlost=x
749       CHECK_STABLE=.false.
750    endif
751    if(.not.check_stable ) lost_fibre=>c
752
753  END SUBROUTINE TRACK_FIBRE_P
754
755
756
757  SUBROUTINE PATCH_FIBR(C,X,k,PATCH,ENTERING)
758    implicit none
759    ! MISALIGNS REAL FIBRES IN PTC ORDER FOR FORWARD AND BACKWARD FIBRES
760    TYPE(FIBRE),INTENT(INOUT):: C
761    real(dp), INTENT(INOUT):: X(6)
762    logical(lp),INTENT(IN):: PATCH,ENTERING
763    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
764
765    IF(ENTERING) THEN
766       X(3)=C%PATCH%A_X1*X(3);X(4)=C%PATCH%A_X1*X(4);
767       CALL ROT_YZ(C%PATCH%A_ANG(1),X,C%MAG%P%BETA0,PATCH,k%TIME)
768       CALL ROT_XZ(C%PATCH%A_ANG(2),X,C%MAG%P%BETA0,PATCH,k%TIME)
769       CALL ROT_XY(C%PATCH%A_ANG(3),X)  !,PATCH)
770       CALL TRANS(C%PATCH%A_D,X,C%MAG%P%BETA0,PATCH,k%TIME)
771       X(3)=C%PATCH%A_X2*X(3);X(4)=C%PATCH%A_X2*X(4);
772    ELSE
773       X(3)=C%PATCH%B_X1*X(3);X(4)=C%PATCH%B_X1*X(4);
774       CALL ROT_YZ(C%PATCH%B_ANG(1),X,C%MAG%P%BETA0,PATCH,k%TIME)
775       CALL ROT_XZ(C%PATCH%B_ANG(2),X,C%MAG%P%BETA0,PATCH,k%TIME)
776       CALL ROT_XY(C%PATCH%B_ANG(3),X)  !,PATCH)
777       CALL TRANS(C%PATCH%B_D,X,C%MAG%P%BETA0,PATCH,k%TIME)
778       X(3)=C%PATCH%B_X2*X(3);X(4)=C%PATCH%B_X2*X(4);
779    ENDIF
780
781
782  END SUBROUTINE PATCH_FIBR
783
784
785  SUBROUTINE PATCH_FIBP(C,X,k,PATCH,ENTERING)
786    implicit none
787    ! MISALIGNS REAL FIBRES IN PTC ORDER FOR FORWARD AND BACKWARD FIBRES
788    TYPE(FIBRE),INTENT(INOUT):: C
789    TYPE(REAL_8), INTENT(INOUT):: X(6)
790    logical(lp),INTENT(IN):: PATCH,ENTERING
791    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
792
793    IF(ENTERING) THEN
794       X(3)=C%PATCH%A_X1*X(3);X(4)=C%PATCH%A_X1*X(4);
795       CALL ROT_YZ(C%PATCH%A_ANG(1),X,C%MAGP%P%BETA0,PATCH,k%TIME)
796       CALL ROT_XZ(C%PATCH%A_ANG(2),X,C%MAGP%P%BETA0,PATCH,k%TIME)
797       CALL ROT_XY(C%PATCH%A_ANG(3),X)  !,PATCH)
798       CALL TRANS(C%PATCH%A_D,X,C%MAGP%P%BETA0,PATCH,k%TIME)
799       X(3)=C%PATCH%A_X2*X(3);X(4)=C%PATCH%A_X2*X(4);
800    ELSE
801       X(3)=C%PATCH%B_X1*X(3);X(4)=C%PATCH%B_X1*X(4);
802       CALL ROT_YZ(C%PATCH%B_ANG(1),X,C%MAGP%P%BETA0,PATCH,k%TIME)
803       CALL ROT_XZ(C%PATCH%B_ANG(2),X,C%MAGP%P%BETA0,PATCH,k%TIME)
804       CALL ROT_XY(C%PATCH%B_ANG(3),X)  !,PATCH)
805       CALL TRANS(C%PATCH%B_D,X,C%MAGP%P%BETA0,PATCH,k%TIME)
806       X(3)=C%PATCH%B_X2*X(3);X(4)=C%PATCH%B_X2*X(4);
807    ENDIF
808
809
810  END SUBROUTINE PATCH_FIBP
811
812  !   Misalignment routines
813  SUBROUTINE MIS_FIBR(C,X,k,OU,ENTERING)
814    implicit none
815    ! MISALIGNS REAL FIBRES IN PTC ORDER FOR FORWARD AND BACKWARD FIBRES
816    TYPE(FIBRE),INTENT(INOUT):: C
817    real(dp), INTENT(INOUT):: X(6)
818    logical(lp),INTENT(IN):: OU,ENTERING
819    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
820
821    IF(ASSOCIATED(C%CHART)) THEN
822       IF(C%DIR==1) THEN   ! FORWARD PROPAGATION
823          IF(ENTERING) THEN
824             CALL ROT_YZ(C%CHART%ANG_IN(1),X,C%MAG%P%BETA0,OU,k%TIME)   ! ROTATIONS
825             CALL ROT_XZ(C%CHART%ANG_IN(2),X,C%MAG%P%BETA0,OU,k%TIME)
826             CALL ROT_XY(C%CHART%ANG_IN(3),X)  !,OU)
827             CALL TRANS(C%CHART%D_IN,X,C%MAG%P%BETA0,OU,k%TIME)         ! TRANSLATION
828          ELSE
829             CALL ROT_YZ(C%CHART%ANG_OUT(1),X,C%MAG%P%BETA0,OU,k%TIME)  ! ROTATIONS
830             CALL ROT_XZ(C%CHART%ANG_OUT(2),X,C%MAG%P%BETA0,OU,k%TIME)
831             CALL ROT_XY(C%CHART%ANG_OUT(3),X)  !,OU)
832             CALL TRANS(C%CHART%D_OUT,X,C%MAG%P%BETA0,OU,k%TIME)        ! TRANSLATION
833          ENDIF
834       ELSE
835          IF(ENTERING) THEN  ! BACKWARD PROPAGATION
836             C%CHART%D_OUT(1)=-C%CHART%D_OUT(1)
837             C%CHART%D_OUT(2)=-C%CHART%D_OUT(2)
838             C%CHART%ANG_OUT(3)=-C%CHART%ANG_OUT(3)
839             CALL TRANS(C%CHART%D_OUT,X,C%MAG%P%BETA0,OU,k%TIME)        ! TRANSLATION
840             CALL ROT_XY(C%CHART%ANG_OUT(3),X)  !,OU)
841             CALL ROT_XZ(C%CHART%ANG_OUT(2),X,C%MAG%P%BETA0,OU,k%TIME)
842             CALL ROT_YZ(C%CHART%ANG_OUT(1),X,C%MAG%P%BETA0,OU,k%TIME)  ! ROTATIONS
843             C%CHART%D_OUT(1)=-C%CHART%D_OUT(1)
844             C%CHART%D_OUT(2)=-C%CHART%D_OUT(2)
845             C%CHART%ANG_OUT(3)=-C%CHART%ANG_OUT(3)
846          ELSE
847             C%CHART%D_IN(1)=-C%CHART%D_IN(1)
848             C%CHART%D_IN(2)=-C%CHART%D_IN(2)
849             C%CHART%ANG_IN(3)=-C%CHART%ANG_IN(3)
850             CALL TRANS(C%CHART%D_IN,X,C%MAG%P%BETA0,OU,k%TIME)         ! TRANSLATION
851             CALL ROT_XY(C%CHART%ANG_IN(3),X)  !,OU)
852             CALL ROT_XZ(C%CHART%ANG_IN(2),X,C%MAG%P%BETA0,OU,k%TIME)
853             CALL ROT_YZ(C%CHART%ANG_IN(1),X,C%MAG%P%BETA0,OU,k%TIME)   ! ROTATIONS
854             C%CHART%D_IN(1)=-C%CHART%D_IN(1)
855             C%CHART%D_IN(2)=-C%CHART%D_IN(2)
856             C%CHART%ANG_IN(3)=-C%CHART%ANG_IN(3)
857          ENDIF
858       ENDIF
859    ENDIF
860  END SUBROUTINE MIS_FIBR
861
862  SUBROUTINE MIS_FIBP(C,X,k,OU,ENTERING)  ! Misaligns polymorphic fibres in PTC order for forward and backward fibres
863    implicit none
864    TYPE(FIBRE),INTENT(INOUT):: C
865    type(REAL_8), INTENT(INOUT):: X(6)
866    logical(lp),INTENT(IN):: OU,ENTERING
867    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
868
869    IF(ASSOCIATED(C%CHART)) THEN
870       IF(C%DIR==1) THEN
871          IF(ENTERING) THEN
872             CALL ROT_YZ(C%CHART%ang_in(1),X,C%MAGP%P%BETA0,OU,k%TIME)                ! rotations
873             CALL ROT_XZ(C%CHART%ang_in(2),X,C%MAGP%P%BETA0,OU,k%TIME)
874             CALL ROT_XY(C%CHART%ang_in(3),X)  !,OU)
875             CALL TRANS(C%CHART%d_in,X,C%MAGP%P%BETA0,OU,k%TIME)                       !translation
876          ELSE
877             CALL ROT_YZ(C%CHART%ang_out(1),X,C%MAGP%P%BETA0,OU,k%TIME)                ! rotations
878             CALL ROT_XZ(C%CHART%ang_out(2),X,C%MAGP%P%BETA0,OU,k%TIME)
879             CALL ROT_XY(C%CHART%ang_out(3),X)  !,OU)
880             CALL TRANS(C%CHART%d_out,X,C%MAGP%P%BETA0,OU,k%TIME)                       !translation
881          ENDIF
882       ELSE
883          IF(ENTERING) THEN
884             C%CHART%d_out(1)=-C%CHART%d_out(1)
885             C%CHART%d_out(2)=-C%CHART%d_out(2)
886             C%CHART%ang_out(3)=-C%CHART%ang_out(3)
887             CALL TRANS(C%CHART%d_out,X,C%MAGP%P%BETA0,OU,k%TIME)                       !translation
888             CALL ROT_XY(C%CHART%ang_out(3),X)  !,OU)
889             CALL ROT_XZ(C%CHART%ang_out(2),X,C%MAGP%P%BETA0,OU,k%TIME)
890             CALL ROT_YZ(C%CHART%ang_out(1),X,C%MAGP%P%BETA0,OU,k%TIME)                ! rotations
891             C%CHART%d_out(1)=-C%CHART%d_out(1)
892             C%CHART%d_out(2)=-C%CHART%d_out(2)
893             C%CHART%ang_out(3)=-C%CHART%ang_out(3)
894          ELSE
895             C%CHART%d_in(1)=-C%CHART%d_in(1)
896             C%CHART%d_in(2)=-C%CHART%d_in(2)
897             C%CHART%ang_in(3)=-C%CHART%ang_in(3)
898             CALL TRANS(C%CHART%d_in,X,C%MAGP%P%BETA0,OU,k%TIME)                       !translation
899             CALL ROT_XY(C%CHART%ang_in(3),X)  !,OU)
900             CALL ROT_XZ(C%CHART%ang_in(2),X,C%MAGP%P%BETA0,OU,k%TIME)
901             CALL ROT_YZ(C%CHART%ang_in(1),X,C%MAGP%P%BETA0,OU,k%TIME)                ! rotations
902             C%CHART%d_in(1)=-C%CHART%d_in(1)
903             C%CHART%d_in(2)=-C%CHART%d_in(2)
904             C%CHART%ang_in(3)=-C%CHART%ang_in(3)
905          ENDIF
906       ENDIF
907    ENDIF
908  END SUBROUTINE MIS_FIBP
909
910
911
912END MODULE S_TRACKING
Note: See TracBrowser for help on using the repository browser.