subroutine Track_and_test_aperture
use madx_ptc_module
use pointer_lattice
implicit none
type(layout), pointer :: ALS
REAL(dp) X0(6),X(6),R
TYPE(INTERNAL_STATE) STATE
als=>M_U%start
state=default
call put_back_an_aperture
write(6,*) "aperture => True or false "
read(5,*) aperture_flag
write(6,*) " Check_madx_aperture (magnet aperture) => True or false "
read(5,*) check_madx_aperture
write(6,*) " Give value of the absolute_aperture "
read(5,*) absolute_aperture
WRITE(6,*) " GIVE A 'BIG' INITIAL VALUE (ONE NUMBER) FOR X(1:6)= R (example 0.1) "
READ(5,*) R
X0(1:6)=R
x=x0
call track(x,state,fibre1=als%start)
if(.not.check_stable) then
write(6,*) "Using one call to Track"
write(6,"(a255)") messagelost
write(6,*) lost_fibre%pos,lost_fibre%mag%name
write(6,*) "Unstable ray"
WRITE(6,'(6(1x,E15.8))') Xlost
else
write(6,*) "stable ray"
WRITE(6,'(6(1x,E15.8))') X
endif
call remove_temporarily_an_aperture
end subroutine Track_and_test_aperture
!================================================================= subroutine put_an_aperture(x,y) use madx_ptc_module use pointer_lattice implicit none type(layout), pointer :: ALS integer pos type(fibre), pointer :: p real(dp) x,y als=>M_U%start als%last=>als%start als%lastpos=als%last%pos call move_to(als,p,"BEND",pos) write(6,*) pos,p%mag%name,p%mag%vorname call move_to(als,p,"BEND",pos) write(6,*) pos,p%mag%name,p%mag%vorname call alloc(p%mag%p%aperture) call alloc(p%magp%p%aperture) p%mag%p%aperture%kind=2 p%mag%p%aperture%x=x p%mag%p%aperture%y=y p%mag%p%aperture%dx=0.d0 p%mag%p%aperture%dy=0.d0 write(6,*) " Aperture size ",x,y end subroutine put_an_aperture
subroutine remove_temporarily_an_aperture use madx_ptc_module use pointer_lattice implicit none type(layout), pointer :: ALS integer pos type(fibre), pointer :: p als=>M_U%start als%last=>als%start als%lastpos=als%last%pos call move_to(als,p,"BEND",pos) call move_to(als,p,"BEND",pos)
p%mag%p%aperture%kind=-p%mag%p%aperture%kind
p%magp%p%aperture%kind=-p%magp%p%aperture%kind
end subroutine remove_temporarily_an_aperture
subroutine put_back_an_aperture
use madx_ptc_module
use pointer_lattice
implicit none
type(layout), pointer :: ALS
integer pos
type(fibre), pointer :: p
als=>M_U%start
als%last=>als%start
als%lastpos=als%last%pos
call move_to(als,p,"BEND",pos)
call move_to(als,p,"BEND",pos)
p%mag%p%aperture%kind=iabs(p%mag%p%aperture%kind)
p%magp%p%aperture%kind=iabs(p%magp%p%aperture%kind)
end subroutine put_back_an_aperture
subroutine put_an_s_aperture(x,y,r)
use madx_ptc_module
use pointer_lattice
implicit none
type(layout), pointer :: ALS
integer pos,i
type(fibre), pointer :: p
type(MADX_APERTURE), pointer :: a
real(dp) x,y,r
integer s
als=>M_U%start
als%last=>als%start
als%lastpos=als%last%pos
call move_to(als,p,"QFA1",pos)
write(6,*) pos,p%mag%name,p%mag%vorname
s=nint(r*p%mag%p%nst)
write(6,*) " Aperture put at position ",s
call alloc(p%mag%p%a,p%mag%p%nst+1)
call alloc(p%magp%p%a,p%mag%p%nst+1)
do i=1,p%mag%p%nst+1
a=> p%mag%p%a(i)%aperture
if(i==s+1) then
a%x=x
a%y=y
else
a%x=absolute_aperture
a%y=absolute_aperture
endif
a%kind=2
a%dx=0.d0
a%dy=0.d0
p%magp%p%a(i)%aperture=a
enddo
write(6,*) " Aperture size ",x,y
end subroutine put_an_s_aperture
!=================================================================
subroutine Track_and_test_s_aperture
use madx_ptc_module
use pointer_lattice
implicit none
type(layout), pointer :: ALS
REAL(dp) X0(6),X(6),R
real(sp) per
TYPE(INTERNAL_STATE) STATE
als=>M_U%start
state=default
!
write(6,*) "aperture => True or false "
read(5,*) aperture_flag
write(6,*) " Check_madx_aperture (magnet aperture) => True or false "
read(5,*) check_madx_aperture
write(6,*) " s_aperture_check ( Extended magnet aperture) => True or false "
read(5,*) s_aperture_check
write(6,*) " Give value of the absolute_aperture "
read(5,*) absolute_aperture
WRITE(6,*) " GIVE A 'BIG' INITIAL VALUE (ONE NUMBER) FOR X(1:6)= R (example 0.1) "
READ(5,*) R
X0(1:6)=R
x=x0
call track_probe_x(x,state,fibre1=als%start)
if(.not.check_stable) then
write(6,*) "Using one call to Track"
write(6,"(a255)") messagelost
write(6,*) lost_fibre%pos,lost_fibre%mag%name
write(6,*) " Position lost, beginning of element, end of element "
write(6,*) lost_node%s(1),lost_node%parent_fibre%t1%s(1),lost_node%parent_fibre%t2%next%s(1)
per= 100*(lost_node%s(1)-lost_node%parent_fibre%t1%s(1))/lost_node%parent_fibre%mag%l
write(6,*) " Lost at ", per," % down the magnet"
write(6,*) "Unstable ray"
WRITE(6,'(6(1x,E15.8))') Xlost
else
write(6,*) "stable ray"
WRITE(6,'(6(1x,E15.8))') X
endif
call remove_temporarily_an_aperture
end subroutine Track_and_test_s_aperture