!The Polymorphic Tracking Code
!Copyright (C) Etienne Forest and CERN

MODULE S_DEF_KIND
  USE S_def_all_kinds   ! not needed because of things below
  public
  PRIVATE DRIFTP  !,DRIFT   ! ,DRIFTR
  PRIVATE SPARR,SPARP !,SPAR
  PRIVATE CAVITYR,CAVITYP !,CAVITY
  PRIVATE CAVER,CAVEP
  PRIVATE KICKCAVR,KICKCAVP !,KICKCAV
  PRIVATE FRINGECAVR,FRINGECAVP   !,FRINGECAV
  PRIVATE KICKTR,KICKTP
  PRIVATE MULTIPOLE_FRINGER,MULTIPOLE_FRINGEP !,MULTIPOLE_FRINGE
  PRIVATE FRINGE_dipoleR,FRINGE_dipolep
  !  PRIVATE FRINGE_
  PRIVATE EDGER,EDGEP !,EDGE
  PRIVATE KICKR,KICKP !,KICK
  PRIVATE KICKEXR,KICKEXP
  PRIVATE INTER,INTEP,INTE
  PRIVATE INTEEXR,INTEEXP,INTE_strex
  PRIVATE SYMPINTR,SYMPINTP
  PRIVATE SYMPINTEXR,SYMPINTEXP
  PRIVATE KICK_SOLR,KICK_SOLP !,KICK_SOL
  PRIVATE FRINGE2SOLR,FRINGE2SOLP,FRINGE2SOL
  PRIVATE INTESOLR,INTESOLP,INTESOL
  PRIVATE FACER,FACEP !,FACE
  PRIVATE NEWFACER,NEWFACEP
  PRIVATE EDGE_TRUE_PARALLELR,EDGE_TRUE_PARALLELP

  PRIVATE ZEROR_KTK,ZEROP_KTK,ZEROR_STREX,ZEROP_STREX,ZEROR_CAV4,ZEROP_CAV4,ZEROr_enge,ZEROp_enge
  PRIVATE ZEROR_KICKT3,ZEROP_KICKT3
  PRIVATE ALLOCKTK,KILLKTK
  PRIVATE GETMATR,GETMATD !,GETMAT
  PRIVATE PUSHKTKR,PUSHKTKD !,PUSHKTK
  PRIVATE KICKKTKR,KICKKTKP !,KICKKTK
  PRIVATE INTKTKR,INTKTKD,INTKTK
  PRIVATE SYMPINTKTKR,SYMPINTKTKD

  PRIVATE KICKPATH6R,KICKPATH6P
  PRIVATE EXP6R,EXP6D,EXPCOSY6   ! special for integrated exponential path length
  PRIVATE EXPR,EXPD,EXPCOSY

  PRIVATE ZEROR_TKT7,ZEROP_TKT7
  PRIVATE ALLOCTKT7,KILLTKT7
  PRIVATE GETMAT7R,GETMAT7D  !,GETMAT7
  PRIVATE PUSHTKT7R,PUSHTKT7D !,PUSHTKT7
  PRIVATE KICKTKT7R,KICKTKT7P !,KICKTKT7
  PRIVATE KICKPATHR,KICKPAThD !,KICKPATH
  PRIVATE INTTKT7R,INTTKT7D,INTTKT7
  PRIVATE SYMPINTTKT7R,SYMPINTTKT7D
  PRIVATE SYMPINTSOLR,SYMPINTSOLP
  PRIVATE GETMULB_SOLR,GETMULB_SOLP,GETMULB_SOL
  PRIVATE KICKMULR,KICKMULP !,KICKMUL

  PRIVATE EXPR7,EXPD7,EXPCOSY7

  PRIVATE PUSH_NSMI_R,PUSH_NSMI_D
  PRIVATE PUSH_SSMI_R,PUSH_SSMI_D

  PRIVATE GETANBNR,GETANBNP,ZEROR_teapot,ZEROP_teapot,ALLOCTEAPOT,KILLTEAPOT
  PRIVATE SPROTR,SPROTP,SPROT
  PRIVATE SseCR,SseCP,Ssec
  PRIVATE SSECH1R,SSECH1P !,SSECH1
  PRIVATE SKICKR,SKICKP !,SKICK
  PRIVATE SINTER,SINTEP,SINTE
  PRIVATE SSYMPINTR,SSYMPINTP
  PRIVATE wedgeR,wedgeP !,wedge


  PRIVATE MONTR,MONTP,ZEROr_mon,ZEROP_mon
  PRIVATE MONTIR,MONTIP
  PRIVATE ECOLLIMATORR,ECOLLIMATORP
  PRIVATE RCOLLIMATORR,RCOLLIMATORP
  PRIVATE RCOLLIMATORiR,RCOLLIMATORiP  !,RCOLLIMATORi
  PRIVATE ECOLLIMATORiR,ECOLLIMATORiP  !,RCOLLIMATORi
  PRIVATE ZEROr_ECOL,ZEROP_ECOL,ZEROr_RCOL,ZEROP_RCOL,ZEROR_RAMP

  PRIVATE SEPR,SEPP,SYMPSEPR,SYMPSEPP !,SEPTTRACK
  !  PRIVATE IN,IN1,IN2
  INTEGER IN(4,4),IN1(10),IN2(10)
  PRIVATE ZEROR_CAV_TRAV,ZEROP_CAV_TRAV
  private fringe_TEAPOTr,fringe_TEAPOTp,INTER_TEAPOT,INTEP_TEAPOT
  PRIVATE fringe_STREXR,fringe_STREXP

  PRIVATE copypancake_el_elp,copypancake_elp_el,copypancake_el_el
  PRIVATE POINTERS_pancakeR,POINTERS_pancakep
  PRIVATE ZEROr_PANCAKE,ZEROP_PANCAKE
  PRIVATE rk4_pancaker,rk4_pancakeP
  PRIVATE FEVAL_pancaker,FEVAL_pancakeP
  PRIVATE INTPANCAKER,INTPANCAKEP,conv_to_xpr,conv_to_xpp,conv_to_pxr
  private conv_to_pxp
  private ADJUSTR_TIME_CAV4,ADJUSTp_TIME_CAV4,INTER_CAV4,INTEp_CAV4
  private INTER_STREX,INTEP_STREX,INTER_SOL5,INTEP_SOL5,INTER_KTK,INTEP_KTK
  private fringe_STRAIGHTr,fringe_STRAIGHTP
  private INTEr_dkd2,INTEP_dkd2,INTER_DRIFT1,INTEP_DRIFT1
  private INTER_TKTF,INTEP_TKTF
  private ADJUSTR_TIME_CAV_TRAV_OUT,ADJUSTP_TIME_CAV_TRAV_OUT
  private FRINGE_CAV_TRAVR,FRINGE_CAV_TRAVp,INTER_CAV_TRAV,INTEP_CAV_TRAV
  private INTER_PANCAKE,INTEP_PANCAKE,ADJUSTR_PANCAKE,ADJUSTP_PANCAKE
  private elliptical_b_r,elliptical_b_p  ! valishev

  INTEGER, PRIVATE :: TOTALPATH_FLAG
  !  private DRIFT_pancaker,DRIFT_pancakep,KICKPATH_pancaker,KICKPATH_pancakep
  ! using x and x'
  private fxr,fxp,f_m
  PRIVATE feval       !,rk4_m
  !  FOR CAV_TRAV
  PRIVATE A_TRANSR,A_TRANSP
  PRIVATE feval_CAVr,feval_CAVP,feval_CAV
  PRIVATE fevalBMAD_CAVR,fevalBMAD_CAVP
  private  FRINGECAVR_TRAV,FRINGECAVP_TRAV !,FRINGECAV_TRAV
  private rk2_cavr,rk2_cavp !,rk2_cav
  private rk4_cavr,rk4_cavp !,rk4_cav
  private rk6_cavr,rk6_cavp !,rk6_cav
  PRIVATE DRIFT_INTER,DRIFT_INTEP   ! NEW DRIFTS CUTABLE
  INTEGER,PRIVATE :: NMAXI=10000
  logical(lp) :: SPEED=.TRUE.
  integer,TARGET :: HIGHEST_FRINGE=2
  logical(lp) ,TARGET :: OLD_IMPLEMENTATION_OF_SIXTRACK=.TRUE.
  real(dp), target :: phase0=-pi
  real(dp), target :: wedge_coeff(2)
  logical(lp), target :: MAD8_WEDGE=.TRUE.
  logical(lp) :: bug_intentional=.false.
  logical(lp) :: almost_exact=.false.
  !  logical(lp) :: old_solenoid=.true.
  INTEGER :: N_CAV4_F=1
  ! stochastic radiation in straigth
  PRIVATE computeR_f4,computeP_f4,ZEROR_HE22,ZEROP_HE22
  PRIVATE DRIFTR_HE,DRIFTP_HE
  PRIVATE KICKR_HE,KICKP_HE,KICK_HE
  PRIVATE KICKPATHR_HE,KICKPATHP_HE
  PRIVATE INTR_HE,INTP_HE,INTR_HE_TOT,INTP_HE_TOT
  private ZEROr_DKD2,ZEROp_DKD2
  private GETELECTRICR,GETELECTRICP
  !include "def_all_kind.f90"
  ! New home for element and elementp
  integer, parameter :: N_ENGE=5
  logical(lp),TARGET :: valishev=.false.
  logical(lp):: read_tc=.false.
  logical(lp):: solve_electric=.false.
  !  integer :: nvalishev=100
  PRIVATE feval_teapotr,feval_teapotP
  PRIVATE Abmad_TRANSR,Abmad_TRANSP,Abmad_TRANS
  private rk2bmad_cavr,rk2bmad_cavp,rk4bmad_cavr,rk4bmad_cavp,rk6bmad_cavr,rk6bmad_cavp
  private track_slice4r,track_slice4p


  INTERFACE TRACK_SLICE
!     MODULE PROCEDURE INTER_CAV4
!     MODULE PROCEDURE INTEP_CAV4
     MODULE PROCEDURE track_slice4r
     MODULE PROCEDURE track_slice4p
     MODULE PROCEDURE INTER_TEAPOT
     MODULE PROCEDURE INTEP_TEAPOT
     MODULE PROCEDURE INTER_STREX
     MODULE PROCEDURE INTEP_STREX
     MODULE PROCEDURE INTER_SOL5
     MODULE PROCEDURE INTEP_SOL5
     MODULE PROCEDURE INTER_KTK
     MODULE PROCEDURE INTEP_KTK
     MODULE PROCEDURE INTER_dkd2
     MODULE PROCEDURE INTEP_dkd2
     MODULE PROCEDURE INTER_DRIFT1
     MODULE PROCEDURE INTEP_DRIFT1
     MODULE PROCEDURE INTER_TKTF
     MODULE PROCEDURE INTEP_TKTF
     MODULE PROCEDURE INTER_CAV_TRAV
     MODULE PROCEDURE INTEP_CAV_TRAV
     MODULE PROCEDURE INTER_PANCAKE
     MODULE PROCEDURE INTEP_PANCAKE
     MODULE PROCEDURE INTR_HE
     MODULE PROCEDURE INTP_HE
  END INTERFACE


  

  INTERFACE ADJUST_PANCAKE
     MODULE PROCEDURE ADJUSTR_PANCAKE
     MODULE PROCEDURE ADJUSTP_PANCAKE
  END INTERFACE

  INTERFACE TRACK_FRINGE
     MODULE PROCEDURE fringe_STRAIGHTr
     MODULE PROCEDURE fringe_STRAIGHTp
  END INTERFACE

  INTERFACE fringe_TEAPOT
     MODULE PROCEDURE fringe_TEAPOTr
     MODULE PROCEDURE fringe_TEAPOTP
  END INTERFACE

  INTERFACE fringe_STREX
     MODULE PROCEDURE fringe_STREXR
     MODULE PROCEDURE fringe_STREXP
  END INTERFACE



  INTERFACE TRACK
     !     MODULE PROCEDURE DRFTR   ! MID DEFINED AS 1/2 L
     !     MODULE PROCEDURE DRFTP   ! MID
     !     MODULE PROCEDURE DRFTS
     MODULE PROCEDURE DRIFT_INTER   ! MID DEFINED AS 1/2 L
     MODULE PROCEDURE DRIFT_INTEP   ! MID

     MODULE PROCEDURE SYMPINTR ! MID IN INTE  DKD2
     MODULE PROCEDURE SYMPINTP ! MID IN INTE
     MODULE PROCEDURE SYMPINTEXR ! MID IN INTE
     MODULE PROCEDURE SYMPINTEXP ! MID IN INTE
     MODULE PROCEDURE KICKTR    ! MID DEFINED /12 KICK
     MODULE PROCEDURE KICKTP    ! MID DEFINED /12 KICK
     ! CAVITY THICK/THIN ELEMENT
     MODULE PROCEDURE CAVER     ! MID DEFINED /12 KICK   ALSO IN CAVITYR AND  CAVITYP
     MODULE PROCEDURE CAVEP      ! MID DEFINED /12 KICK
     MODULE PROCEDURE CAVER_TRAV     ! MID DEFINED /12 KICK   ALSO IN CAVITYR AND  CAVITYP
     MODULE PROCEDURE CAVEP_TRAV      ! MID DEFINED /12 KICK
     ! SOLENOID
     MODULE PROCEDURE SYMPINTSOLR
     MODULE PROCEDURE SYMPINTSOLP
     ! SLOW THICK ELEMENT    SIXTRACK
     MODULE PROCEDURE SYMPINTKTKR
     MODULE PROCEDURE SYMPINTKTKD
     ! FAST THICK ELEMENT
     MODULE PROCEDURE SYMPINTTKT7R
     MODULE PROCEDURE SYMPINTTKT7D
     ! THE THIN NORMAL SMI
     MODULE PROCEDURE PUSH_NSMI_R
     MODULE PROCEDURE PUSH_NSMI_D
     ! THE THIN SKEW SMI
     MODULE PROCEDURE PUSH_SSMI_R
     MODULE PROCEDURE PUSH_SSMI_D
     ! SECTOR (TEAPOT)
     MODULE PROCEDURE SSYMPINTR
     MODULE PROCEDURE SSYMPINTP
     ! MONITOR AND INSTRUMENT
     MODULE PROCEDURE MONTR
     MODULE PROCEDURE MONTP
     ! COLLIMATORS
     MODULE PROCEDURE RCOLLIMATORR
     MODULE PROCEDURE RCOLLIMATORP

     MODULE PROCEDURE ECOLLIMATORR
     MODULE PROCEDURE ECOLLIMATORP

     ! ELECTROSTATIC SEPTUM
     MODULE PROCEDURE SYMPSEPR
     MODULE PROCEDURE SYMPSEPP



     ! PANCAKE
     MODULE PROCEDURE INTPANCAKER
     MODULE PROCEDURE INTPANCAKEP

     ! HELICAL_DIPOLE
     MODULE PROCEDURE INTR_HE_TOT
     MODULE PROCEDURE INTP_HE_TOT

  END INTERFACE

  INTERFACE DRIFT
     MODULE PROCEDURE DRIFTR
     MODULE PROCEDURE DRIFTP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)

  END INTERFACE


  !@  INTERFACE DRIFT_pancake
  !    MODULE PROCEDURE DRIFT_pancaker
  !    MODULE PROCEDURE DRIFT_pancakep
  ! END INTERFACE

  INTERFACE MONTI
     MODULE PROCEDURE MONTIR
     MODULE PROCEDURE MONTIP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  INTERFACE RCOLLIMATORi
     MODULE PROCEDURE RCOLLIMATORiR
     MODULE PROCEDURE RCOLLIMATORiP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  INTERFACE ECOLLIMATORi
     MODULE PROCEDURE ECOLLIMATORiR
     MODULE PROCEDURE ECOLLIMATORiP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  INTERFACE KICKCAV
     MODULE PROCEDURE KICKCAVR
     MODULE PROCEDURE KICKCAVP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  INTERFACE Abmad_TRANS
     MODULE PROCEDURE Abmad_TRANSR
     MODULE PROCEDURE Abmad_TRANSP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  INTERFACE A_TRANS
     MODULE PROCEDURE A_TRANSR
     MODULE PROCEDURE A_TRANSP
  END INTERFACE

  INTERFACE feval_CAV
     MODULE PROCEDURE feval_CAVr
     MODULE PROCEDURE feval_CAVp
     MODULE PROCEDURE fevalBMAD_CAVR 
     MODULE PROCEDURE fevalBMAD_CAVP
  END INTERFACE

  INTERFACE feval_teapot
     MODULE PROCEDURE feval_teapotr
     MODULE PROCEDURE feval_teapotP
  END INTERFACE

  INTERFACE rk2_cav
     MODULE PROCEDURE rk2_cavr
     MODULE PROCEDURE rk2_cavp
     MODULE PROCEDURE rk2bmad_cavr
     MODULE PROCEDURE rk2bmad_cavp
  END INTERFACE

  INTERFACE rk4_cav
     MODULE PROCEDURE rk4_cavr
     MODULE PROCEDURE rk4_cavp
     MODULE PROCEDURE rk4bmad_cavr
     MODULE PROCEDURE rk4bmad_cavp
  END INTERFACE

  INTERFACE rk6_cav
     MODULE PROCEDURE rk6_cavr
     MODULE PROCEDURE rk6_cavp
     MODULE PROCEDURE rk6bmad_cavr
     MODULE PROCEDURE rk6bmad_cavp
  END INTERFACE

  INTERFACE FRINGECAV
     MODULE PROCEDURE FRINGECAVR
     MODULE PROCEDURE FRINGECAVP       ! CAVITY FRINGE FIELDS
  END INTERFACE

  INTERFACE ADJUST_TIME_CAV4
     MODULE PROCEDURE ADJUSTR_TIME_CAV4
     MODULE PROCEDURE ADJUSTP_TIME_CAV4
  END INTERFACE

  INTERFACE ADJUST_TIME_CAV_TRAV_OUT
     MODULE PROCEDURE ADJUSTR_TIME_CAV_TRAV_OUT
     MODULE PROCEDURE ADJUSTP_TIME_CAV_TRAV_OUT
  END INTERFACE

  INTERFACE FRINGECAV_TRAV
     MODULE PROCEDURE FRINGECAVR_TRAV
     MODULE PROCEDURE FRINGECAVP_TRAV       ! CAVITY FRINGE FIELDS
  END INTERFACE

  INTERFACE FRINGE_CAV_TRAV
     MODULE PROCEDURE FRINGE_CAV_TRAVr
     MODULE PROCEDURE FRINGE_CAV_TRAVp       ! CAVITY FRINGE FIELDS
  END INTERFACE


  INTERFACE CAVITY
     MODULE PROCEDURE CAVITYR
     MODULE PROCEDURE CAVITYP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  INTERFACE MULTIPOLE_FRINGE
     MODULE PROCEDURE MULTIPOLE_FRINGER
     MODULE PROCEDURE MULTIPOLE_FRINGEP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  !  INTERFACE HIGH_FRINGE
  !     MODULE PROCEDURE HIGH_FRINGER
  !     MODULE PROCEDURE HIGH_FRINGEP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  !     MODULE PROCEDURE HIGH_FRINGES
  !  END INTERFACE

  INTERFACE FRINGE_dipole
     MODULE PROCEDURE FRINGE_dipoleR
     MODULE PROCEDURE FRINGE_dipoleP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  !  INTERFACE FRINGE__MULTI
  !     MODULE PROCEDURE FRINGER
  !  END INTERFACE

  INTERFACE FACE
     MODULE PROCEDURE FACER
     MODULE PROCEDURE FACEP       ! H1 AND H2 OF MAD FOR EXACT = FALSE
     MODULE PROCEDURE NEWFACER
     MODULE PROCEDURE NEWFACEP    ! H1 AND H2 OF MAD FOR EXACT = TRUE
  END INTERFACE

  !  INTERFACE FACE_MULTI
  !     MODULE PROCEDURE NEWFACER
  !  END INTERFACE


  INTERFACE EDGE
     MODULE PROCEDURE EDGER
     MODULE PROCEDURE EDGEP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  INTERFACE EDGE_TRUE_PARALLEL
     MODULE PROCEDURE EDGE_TRUE_PARALLELR
     MODULE PROCEDURE EDGE_TRUE_PARALLELP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE




  INTERFACE KICK
     MODULE PROCEDURE KICKR   ! NOT EXACT
     MODULE PROCEDURE KICKP
  END INTERFACE

  INTERFACE KICKEX
     MODULE PROCEDURE KICKEXR !  EXACT
     MODULE PROCEDURE KICKEXP
  END INTERFACE

  INTERFACE elliptical_b
     MODULE PROCEDURE elliptical_b_r !  EXACT
     MODULE PROCEDURE elliptical_b_p
  END INTERFACE



  !  INTERFACE KICK_multi
  !     MODULE PROCEDURE KICKR
  !     MODULE PROCEDURE KICKEXR !  EXACT
  !  END INTERFACE

  INTERFACE INTE
     MODULE PROCEDURE INTER   ! NOT EXACT !MID  dkd2
     MODULE PROCEDURE INTEP   ! MID
  END INTERFACE


  INTERFACE INTE_strex
     MODULE PROCEDURE INTEEXR ! EXACT
     MODULE PROCEDURE INTEEXP
  END INTERFACE

  INTERFACE KICK_SOL
     MODULE PROCEDURE KICK_SOLR
     MODULE PROCEDURE KICK_SOLP
  END INTERFACE

  !  INTERFACE KICK_SOL_old
  !     MODULE PROCEDURE KICK_SOLr_old
  !     MODULE PROCEDURE KICK_SOLp_old
  !  END INTERFACE

  INTERFACE FRINGE2SOL
     MODULE PROCEDURE FRINGE2SOLR
     MODULE PROCEDURE FRINGE2SOLP
  END INTERFACE

  INTERFACE GETMULB_SOL
     MODULE PROCEDURE GETMULB_SOLR
     MODULE PROCEDURE GETMULB_SOLP
  END INTERFACE

  INTERFACE KICKMUL
     MODULE PROCEDURE KICKMULR
     MODULE PROCEDURE KICKMULP
  END INTERFACE


  INTERFACE INTESOL
     MODULE PROCEDURE INTESOLR
     MODULE PROCEDURE INTESOLP
  END INTERFACE

  INTERFACE SEPTTRACK
     ! ELECTROSTATIC SEPTUM
     MODULE PROCEDURE SEPR
     MODULE PROCEDURE SEPP
  END INTERFACE
!!!! *************************************************************** !!!!
!!!! *                    slow thick element                       * !!!!
!!!! *************************************************************** !!!!

  !INTERFACE EQUAL
  !MODULE PROCEDURE copy_TKTF_TKTFP                              !
  !MODULE PROCEDURE copy_KTKP_KTK                              !
  !MODULE PROCEDURE copy_KTK_KTK                        !
  !end  INTERFACE

  INTERFACE copy
     MODULE PROCEDURE copypancake_el_elp
     MODULE PROCEDURE copypancake_elp_el
     MODULE PROCEDURE copypancake_el_el
  END INTERFACE



  INTERFACE POINTERS_pancake
     MODULE PROCEDURE POINTERS_pancakeR
     MODULE PROCEDURE POINTERS_pancakeP
  END INTERFACE

  INTERFACE ASSIGNMENT (=)
     MODULE PROCEDURE ZEROr_DKD2                 ! need upgrade
     MODULE PROCEDURE ZEROp_DKD2                  ! need upgrade
     MODULE PROCEDURE ZEROr_KTK                 ! need upgrade
     MODULE PROCEDURE ZEROP_KTK                  ! need upgrade
     MODULE PROCEDURE ZEROr_TKT7                 ! need upgrade
     MODULE PROCEDURE ZEROP_TKT7                  ! need upgrade
     MODULE PROCEDURE ZEROR_teapot
     MODULE PROCEDURE ZEROP_teapot
     MODULE PROCEDURE ZEROr_mon                 ! need upgrade
     MODULE PROCEDURE ZEROP_mon                  ! need upgrade
     MODULE PROCEDURE ZEROr_RCOL                 ! need upgrade
     MODULE PROCEDURE ZEROP_RCOL                 ! need upgrade
     MODULE PROCEDURE ZEROr_ECOL                ! need upgrade
     MODULE PROCEDURE ZEROP_ECOL                  ! need upgrade
     MODULE PROCEDURE ZEROR_STREX
     MODULE PROCEDURE ZEROP_STREX
     MODULE PROCEDURE ZEROR_CAV4
     MODULE PROCEDURE ZEROP_CAV4
     MODULE PROCEDURE ZEROR_CAV_TRAV
     MODULE PROCEDURE ZEROP_CAV_TRAV
     MODULE PROCEDURE ZEROR_KICKT3
     MODULE PROCEDURE ZEROP_KICKT3
     MODULE PROCEDURE ZEROr_PANCAKE                 ! need upgrade
     MODULE PROCEDURE ZEROP_PANCAKE                  ! need upgrade
     MODULE PROCEDURE ZEROR_HE22
     MODULE PROCEDURE ZEROP_HE22
     MODULE PROCEDURE ZEROr_enge
     MODULE PROCEDURE ZEROp_enge
     MODULE PROCEDURE ZEROR_RAMP
  END INTERFACE


  INTERFACE ALLOC
     MODULE PROCEDURE ALLOCKTK
     MODULE PROCEDURE ALLOCTKT7
     MODULE PROCEDURE ALLOCTEAPOT
  END INTERFACE

  INTERFACE KILL
     MODULE PROCEDURE KILLKTK
     MODULE PROCEDURE KILLTKT7
     MODULE PROCEDURE KILLTEAPOT
  END INTERFACE

  INTERFACE EXPCOSY6
     MODULE PROCEDURE EXP6R
     MODULE PROCEDURE EXP6D
  END INTERFACE

  INTERFACE GETMAT
     MODULE PROCEDURE GETMATR
     MODULE PROCEDURE GETMATD
  END INTERFACE

  INTERFACE INTKTK
     MODULE PROCEDURE INTKTKR
     MODULE PROCEDURE INTKTKD
  END INTERFACE

  INTERFACE PUSHKTK
     MODULE PROCEDURE PUSHKTKR
     MODULE PROCEDURE PUSHKTKD
  END INTERFACE

  INTERFACE KICKKTK
     MODULE PROCEDURE KICKKTKR
     MODULE PROCEDURE KICKKTKP
  END INTERFACE

  INTERFACE EXPCOSY
     MODULE PROCEDURE EXPR
     MODULE PROCEDURE EXPD
  END INTERFACE


!!!! *************************************************************** !!!!
!!!! *                    fast thick element                       * !!!!
!!!! *************************************************************** !!!!


  INTERFACE EXPCOSY7
     MODULE PROCEDURE EXPR7
     MODULE PROCEDURE EXPD7
  END INTERFACE


  INTERFACE GETMAT7
     MODULE PROCEDURE GETMAT7R
     MODULE PROCEDURE GETMAT7D
  END INTERFACE

  INTERFACE PUSHTKT7
     MODULE PROCEDURE PUSHTKT7R
     MODULE PROCEDURE PUSHTKT7D
  END INTERFACE

  INTERFACE KICKTKT7
     MODULE PROCEDURE KICKTKT7R
     MODULE PROCEDURE KICKTKT7P
  END INTERFACE

  INTERFACE KICKPATH
     MODULE PROCEDURE KICKPATHR
     MODULE PROCEDURE KICKPATHD
     MODULE PROCEDURE KICKPATH6R
     MODULE PROCEDURE KICKPATH6P
     MODULE PROCEDURE KICKPATHR_HE
     MODULE PROCEDURE KICKPATHP_HE
     !     MODULE PROCEDURE KICKPATH_pancaker
     !     MODULE PROCEDURE KICKPATH_pancakep
  END INTERFACE

  INTERFACE INTTKT7
     MODULE PROCEDURE INTTKT7R
     MODULE PROCEDURE INTTKT7D
  END INTERFACE

!!!! *************************************************************** !!!!
!!!! *           Beginning of the teapot element                   * !!!!
!!!! *************************************************************** !!!!

  INTERFACE GETANBN
     MODULE PROCEDURE GETANBNR
     MODULE PROCEDURE GETANBNP
  END INTERFACE


  INTERFACE GETELECTRIC
     MODULE PROCEDURE GETELECTRICR
     MODULE PROCEDURE GETELECTRICP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  INTERFACE GETMULB_TEAPOT
     MODULE PROCEDURE GETMULB_TEAPOTR
     MODULE PROCEDURE GETMULB_TEAPOTP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE


  INTERFACE SPROT
     MODULE PROCEDURE SPROTR
     MODULE PROCEDURE SPROTP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  INTERFACE Ssec
     MODULE PROCEDURE SsecR
     MODULE PROCEDURE SsecP       ! EXACT SECTOR SPLIT
  END INTERFACE

  INTERFACE SSECH1
     MODULE PROCEDURE SSECH1R
     MODULE PROCEDURE SSECH1P       ! EXACT SECTOR SPLIT
  END INTERFACE

  INTERFACE SPAR
     MODULE PROCEDURE SPARR
     MODULE PROCEDURE SPARP       ! EXACT PARALLEL FACE SPLIT
  END INTERFACE

  INTERFACE SKICK
     MODULE PROCEDURE SKICKR
     MODULE PROCEDURE SKICKP       ! USE TO CREATE OTHER ELEMENTS (INTEGRATION)
  END INTERFACE

  INTERFACE SINTE
     MODULE PROCEDURE SINTER
     MODULE PROCEDURE SINTEP
  END INTERFACE


  INTERFACE wedge
     MODULE PROCEDURE wedgeR
     MODULE PROCEDURE wedgeP       ! USE IN EXACT SECTOR BEND (INTEGRATION)
  END INTERFACE
  INTERFACE F_M
     MODULE PROCEDURE FXR
     MODULE PROCEDURE FXP
  END INTERFACE

  INTERFACE feval
     MODULE PROCEDURE FEVAL_pancaker
     MODULE PROCEDURE FEVAL_pancakeP
  END INTERFACE

  INTERFACE conv_to_xp
     MODULE PROCEDURE conv_to_xpr
     MODULE PROCEDURE conv_to_xpp
  END INTERFACE
  INTERFACE conv_to_px
     MODULE PROCEDURE conv_to_pxr
     MODULE PROCEDURE conv_to_pxp
  END INTERFACE


  INTERFACE RK4_M
     MODULE PROCEDURE rk4_pancaker
     MODULE PROCEDURE rk4_pancakeP
  END INTERFACE

!!!!!!!  HELICAL


  INTERFACE compute_f4
     MODULE PROCEDURE computeR_f4
     MODULE PROCEDURE computeP_f4
  END INTERFACE

  INTERFACE DRIFT
     MODULE PROCEDURE DRIFTR_HE
     MODULE PROCEDURE DRIFTP_HE
  END INTERFACE

  INTERFACE KICK_HE
     MODULE PROCEDURE KICKR_HE
     MODULE PROCEDURE KICKP_HE
  END INTERFACE

contains

  SUBROUTINE INTER_DRIFT1(EL,X,k)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(DRIFT1),INTENT(IN):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) DH,DD

    SELECT CASE(EL%P%METHOD)
    CASE(2,4,6)
       DH=EL%L/EL%P%NST
       DD=EL%P%LD/EL%P%NST

       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)


    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

  END SUBROUTINE INTER_DRIFT1

  SUBROUTINE INTEP_DRIFT1(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(DRIFT1P),INTENT(IN):: EL
    TYPE(REAL_8) DH
    real(dp) DD
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(DH)
    SELECT CASE(EL%P%METHOD)
    CASE(2,4,6)
       DH=EL%L/EL%P%NST
       DD=EL%P%LD/EL%P%NST




       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)


    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

    CALL KILL(DH)

  END SUBROUTINE INTEP_DRIFT1


  SUBROUTINE DRIFT_INTER(EL,X,K,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(DRIFT1),INTENT(IN):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    DO I=1,EL%P%NST
       IF(.NOT.PRESENT(MID)) CALL TRACK_SLICE(EL,X,k)
       IF(PRESENT(MID)) CALL XMID(MID,X,I)
    ENDDO


  END SUBROUTINE DRIFT_INTER





  SUBROUTINE DRIFT_INTEP(EL,X,K)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: MID
    TYPE(DRIFT1P),INTENT(IN):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    DO I=1,EL%P%NST
       CALL TRACK_SLICE(EL,X,k)
    ENDDO


  END SUBROUTINE DRIFT_INTEP

  ! tracking fringe areas

  SUBROUTINE fringe_STRAIGHTr(EL,EL5,EL6,EL7,X,k,J)
    IMPLICIT NONE
    TYPE(DKD2),OPTIONAL,INTENT(IN):: EL
    TYPE(SOL5),OPTIONAL,INTENT(INOUT):: EL5
    TYPE(KTK),OPTIONAL,INTENT(INOUT):: EL6
    TYPE(TKTF),OPTIONAL,INTENT(INOUT):: EL7
    !      TYPE(BEAM), INTENT(INOUT) ::B
    integer,INTENT(IN):: J
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    ! J=1 front
    IF(PRESENT(EL)) THEN
       !       DO I=1,B%N
       !        IF(B%U(i)) CYCLE
       !         X=BEAM_IN_X(B,I)

       if(J==1) then
          if(EL%P%DIR==1) THEN
             CALL EDGE(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,1,X,k)
             IF(k%FRINGE.or.EL%P%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
          ELSE
             CALL EDGE(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,2,X,k)
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
          ENDIF
       else
          if(EL%P%DIR==1) THEN
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             CALL EDGE(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,2,X,k)
          ELSE
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             CALL EDGE(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,1,X,k)
          ENDIF
       ENDIF
       !         CALL X_IN_BEAM(X,B,I)

    ELSEIF(PRESENT(EL6)) THEN
       !       DO I=1,B%N
       !        IF(B%U(i)) CYCLE
       !         X=BEAM_IN_X(B,I)

       if(J==1) then
          if(EL6%P%DIR==1) THEN
             CALL EDGE(EL6%P,EL6%BN,EL6%H1,EL6%H2,EL6%FINT,EL6%HGAP,1,X,k)
             IF(k%FRINGE.or.el6%p%permfringe) CALL MULTIPOLE_FRINGE(EL6%P,EL6%AN,EL6%BN,1,X,k)
          ELSE
             CALL EDGE(EL6%P,EL6%BN,EL6%H1,EL6%H2,EL6%FINT,EL6%HGAP,2,X,k)
             IF(k%FRINGE.or.el6%p%permfringe) CALL MULTIPOLE_FRINGE(EL6%P,EL6%AN,EL6%BN,2,X,k)
          ENDIF
       else
          if(EL6%P%DIR==1) THEN
             IF(k%FRINGE.or.el6%p%permfringe) CALL MULTIPOLE_FRINGE(EL6%P,EL6%AN,EL6%BN,2,X,k)
             CALL EDGE(EL6%P,EL6%BN,EL6%H1,EL6%H2,EL6%FINT,EL6%HGAP,2,X,k)
          ELSE
             IF(k%FRINGE.or.el6%p%permfringe) CALL MULTIPOLE_FRINGE(EL6%P,EL6%AN,EL6%BN,1,X,k)
             CALL EDGE(EL6%P,EL6%BN,EL6%H1,EL6%H2,EL6%FINT,EL6%HGAP,1,X,k)
          ENDIF
       ENDIF
       !         CALL X_IN_BEAM(X,B,I)

    ELSEIF(PRESENT(EL5)) THEN
       !       DO I=1,B%N
       !        IF(B%U(i)) CYCLE
       !         X=BEAM_IN_X(B,I)

       if(J==1) then
          if(EL5%P%DIR==1) THEN
             CALL EDGE(EL5%P,EL5%BN,EL5%H1,EL5%H2,EL5%FINT,EL5%HGAP,1,X,k)
             IF(k%FRINGE.or.el5%p%permfringe) CALL MULTIPOLE_FRINGE(EL5%P,EL5%AN,EL5%BN,1,X,k)
             CALL FRINGE2SOL(EL5%P,EL5%B_SOL,EL5%FINT,EL5%HGAP,1,X,k)
          ELSE
             CALL EDGE(EL5%P,EL5%BN,EL5%H1,EL5%H2,EL5%FINT,EL5%HGAP,2,X,k)
             IF(k%FRINGE.or.el5%p%permfringe) CALL MULTIPOLE_FRINGE(EL5%P,EL5%AN,EL5%BN,2,X,k)
             CALL FRINGE2SOL(EL5%P,EL5%B_SOL,EL5%FINT,EL5%HGAP,2,X,k)
          ENDIF
       else
          if(EL5%P%DIR==1) THEN
             CALL FRINGE2SOL(EL5%P,EL5%B_SOL,EL5%FINT,EL5%HGAP,2,X,k)
             IF(k%FRINGE.or.el5%p%permfringe) CALL MULTIPOLE_FRINGE(EL5%P,EL5%AN,EL5%BN,2,X,k)
             CALL EDGE(EL5%P,EL5%BN,EL5%H1,EL5%H2,EL5%FINT,EL5%HGAP,2,X,k)
          ELSE
             CALL FRINGE2SOL(EL5%P,EL5%B_SOL,EL5%FINT,EL5%HGAP,1,X,k)
             IF(k%FRINGE.or.el5%p%permfringe) CALL MULTIPOLE_FRINGE(EL5%P,EL5%AN,EL5%BN,1,X,k)
             CALL EDGE(EL5%P,EL5%BN,EL5%H1,EL5%H2,EL5%FINT,EL5%HGAP,1,X,k)
          ENDIF
       ENDIF

    ELSEIF(PRESENT(EL7)) THEN

       if(J==1) then
          if(EL7%P%DIR==1) THEN
             CALL EDGE(EL7%P,EL7%BN,EL7%H1,EL7%H2,EL7%FINT,EL7%HGAP,1,X,k)
             IF(k%FRINGE.or.el7%p%permfringe) CALL MULTIPOLE_FRINGE(EL7%P,EL7%AN,EL7%BN,1,X,k)
          ELSE
             CALL EDGE(EL7%P,EL7%BN,EL7%H1,EL7%H2,EL7%FINT,EL7%HGAP,2,X,k)
             IF(k%FRINGE.or.el7%p%permfringe) CALL MULTIPOLE_FRINGE(EL7%P,EL7%AN,EL7%BN,2,X,k)
          ENDIF
       else
          if(EL7%P%DIR==1) THEN
             IF(k%FRINGE.or.el7%p%permfringe) CALL MULTIPOLE_FRINGE(EL7%P,EL7%AN,EL7%BN,2,X,k)
             CALL EDGE(EL7%P,EL7%BN,EL7%H1,EL7%H2,EL7%FINT,EL7%HGAP,2,X,k)
          ELSE
             IF(k%FRINGE.or.el7%p%permfringe) CALL MULTIPOLE_FRINGE(EL7%P,EL7%AN,EL7%BN,1,X,k)
             CALL EDGE(EL7%P,EL7%BN,EL7%H1,EL7%H2,EL7%FINT,EL7%HGAP,1,X,k)
          ENDIF
       ENDIF


    ENDIF
  END SUBROUTINE fringe_STRAIGHTr


  SUBROUTINE fringe_STRAIGHTP(EL,EL5,EL6,EL7,X,k,J)
    IMPLICIT NONE
    TYPE(DKD2P),OPTIONAL,INTENT(IN):: EL
    TYPE(SOL5P),OPTIONAL,INTENT(INOUT):: EL5
    TYPE(KTKP),OPTIONAL,INTENT(INOUT):: EL6
    TYPE(TKTFP),OPTIONAL,INTENT(INOUT):: EL7
    !      TYPE(BEAM), INTENT(INOUT) ::B
    integer,INTENT(IN):: J
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K



    ! J=1 front
    IF(PRESENT(EL)) THEN
       !       DO I=1,B%N
       !        IF(B%U(i)) CYCLE
       !         X=BEAM_IN_X(B,I)

       if(J==1) then
          if(EL%P%DIR==1) THEN
             CALL EDGE(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,1,X,k)
             IF(k%FRINGE.or.EL%P%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
          ELSE
             CALL EDGE(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,2,X,k)
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
          ENDIF
       else
          if(EL%P%DIR==1) THEN
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             CALL EDGE(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,2,X,k)
          ELSE
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             CALL EDGE(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,1,X,k)
          ENDIF
       ENDIF
       !         CALL X_IN_BEAM(X,B,I)

    ELSEIF(PRESENT(EL6)) THEN
       !       DO I=1,B%N
       !        IF(B%U(i)) CYCLE
       !         X=BEAM_IN_X(B,I)

       if(J==1) then
          if(EL6%P%DIR==1) THEN
             CALL EDGE(EL6%P,EL6%BN,EL6%H1,EL6%H2,EL6%FINT,EL6%HGAP,1,X,k)
             IF(k%FRINGE.or.EL6%p%permfringe) CALL MULTIPOLE_FRINGE(EL6%P,EL6%AN,EL6%BN,1,X,k)
          ELSE
             CALL EDGE(EL6%P,EL6%BN,EL6%H1,EL6%H2,EL6%FINT,EL6%HGAP,2,X,k)
             IF(k%FRINGE.or.EL6%p%permfringe) CALL MULTIPOLE_FRINGE(EL6%P,EL6%AN,EL6%BN,2,X,k)
          ENDIF
       else
          if(EL6%P%DIR==1) THEN
             IF(k%FRINGE.or.EL6%p%permfringe) CALL MULTIPOLE_FRINGE(EL6%P,EL6%AN,EL6%BN,2,X,k)
             CALL EDGE(EL6%P,EL6%BN,EL6%H1,EL6%H2,EL6%FINT,EL6%HGAP,2,X,k)
          ELSE
             IF(k%FRINGE.or.EL6%p%permfringe) CALL MULTIPOLE_FRINGE(EL6%P,EL6%AN,EL6%BN,1,X,k)
             CALL EDGE(EL6%P,EL6%BN,EL6%H1,EL6%H2,EL6%FINT,EL6%HGAP,1,X,k)
          ENDIF
       ENDIF
       !         CALL X_IN_BEAM(X,B,I)

    ELSEIF(PRESENT(EL5)) THEN
       !       DO I=1,B%N
       !        IF(B%U(i)) CYCLE
       !         X=BEAM_IN_X(B,I)

       if(J==1) then
          if(EL5%P%DIR==1) THEN
             CALL EDGE(EL5%P,EL5%BN,EL5%H1,EL5%H2,EL5%FINT,EL5%HGAP,1,X,k)
             IF(k%FRINGE.or.el5%p%permfringe) CALL MULTIPOLE_FRINGE(EL5%P,EL5%AN,EL5%BN,1,X,k)
             CALL FRINGE2SOL(EL5%P,EL5%B_SOL,EL5%FINT,EL5%HGAP,1,X,k)
          ELSE
             CALL EDGE(EL5%P,EL5%BN,EL5%H1,EL5%H2,EL5%FINT,EL5%HGAP,2,X,k)
             IF(k%FRINGE.or.el5%p%permfringe) CALL MULTIPOLE_FRINGE(EL5%P,EL5%AN,EL5%BN,2,X,k)
             CALL FRINGE2SOL(EL5%P,EL5%B_SOL,EL5%FINT,EL5%HGAP,2,X,k)
          ENDIF
       else
          if(EL5%P%DIR==1) THEN
             CALL FRINGE2SOL(EL5%P,EL5%B_SOL,EL5%FINT,EL5%HGAP,2,X,k)
             IF(k%FRINGE.or.el5%p%permfringe) CALL MULTIPOLE_FRINGE(EL5%P,EL5%AN,EL5%BN,2,X,k)
             CALL EDGE(EL5%P,EL5%BN,EL5%H1,EL5%H2,EL5%FINT,EL5%HGAP,2,X,k)
          ELSE
             CALL FRINGE2SOL(EL5%P,EL5%B_SOL,EL5%FINT,EL5%HGAP,1,X,k)
             IF(k%FRINGE.or.el5%p%permfringe) CALL MULTIPOLE_FRINGE(EL5%P,EL5%AN,EL5%BN,1,X,k)
             CALL EDGE(EL5%P,EL5%BN,EL5%H1,EL5%H2,EL5%FINT,EL5%HGAP,1,X,k)
          ENDIF
       ENDIF

    ELSEIF(PRESENT(EL7)) THEN

       if(J==1) then
          if(EL7%P%DIR==1) THEN
             CALL EDGE(EL7%P,EL7%BN,EL7%H1,EL7%H2,EL7%FINT,EL7%HGAP,1,X,k)
             IF(k%FRINGE.or.EL7%p%permfringe) CALL MULTIPOLE_FRINGE(EL7%P,EL7%AN,EL7%BN,1,X,k)
          ELSE
             CALL EDGE(EL7%P,EL7%BN,EL7%H1,EL7%H2,EL7%FINT,EL7%HGAP,2,X,k)
             IF(k%FRINGE.or.EL7%p%permfringe) CALL MULTIPOLE_FRINGE(EL7%P,EL7%AN,EL7%BN,2,X,k)
          ENDIF
       else
          if(EL7%P%DIR==1) THEN
             IF(k%FRINGE.or.EL7%p%permfringe) CALL MULTIPOLE_FRINGE(EL7%P,EL7%AN,EL7%BN,2,X,k)
             CALL EDGE(EL7%P,EL7%BN,EL7%H1,EL7%H2,EL7%FINT,EL7%HGAP,2,X,k)
          ELSE
             IF(k%FRINGE.or.EL7%p%permfringe) CALL MULTIPOLE_FRINGE(EL7%P,EL7%AN,EL7%BN,1,X,k)
             CALL EDGE(EL7%P,EL7%BN,EL7%H1,EL7%H2,EL7%FINT,EL7%HGAP,1,X,k)
          ENDIF
       ENDIF


    ENDIF
  END SUBROUTINE fringe_STRAIGHTP



  SUBROUTINE ADJUSTR_TIME_CAV4(EL,X,k,J)
    IMPLICIT NONE
    REAL(DP), INTENT(INOUT)::  X(6)
    TYPE(CAV4),INTENT(INOUT):: EL
    integer,INTENT(IN):: J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(J==1) THEN
       EL%DELTA_E=X(5)
       IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN

       IF(EL%THIN) THEN
          CALL CAVITY(EL,X,k)
          EL%DELTA_E=(X(5)-EL%DELTA_E)*EL%P%P0C
          RETURN
       ENDIF

    ELSE
       IF(EL%THIN) RETURN

       if(k%TIME) then
          X(6)=X(6)-(el%CAVITY_TOTALPATH-k%TOTALPATH)*EL%P%LD/EL%P%BETA0
       else
          X(6)=X(6)-(el%CAVITY_TOTALPATH-k%TOTALPATH)*EL%P%LD
       endif

       EL%DELTA_E=(X(5)-EL%DELTA_E)*EL%P%P0C
    ENDIF

  END SUBROUTINE ADJUSTR_TIME_CAV4

  SUBROUTINE ADJUSTP_TIME_CAV4(EL,X,k,J)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT)::  X(6)
    TYPE(CAV4P),INTENT(INOUT):: EL
    integer,INTENT(IN):: J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(J==1) THEN
       EL%DELTA_E=X(5)
       IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN

       IF(EL%THIN) THEN
          CALL CAVITY(EL,X,k)
          EL%DELTA_E=(X(5)-EL%DELTA_E)*EL%P%P0C
          RETURN
       ENDIF

    ELSE
       IF(EL%THIN) RETURN

       if(k%TIME) then
          X(6)=X(6)-(el%CAVITY_TOTALPATH-k%TOTALPATH)*EL%P%LD/EL%P%BETA0
       else
          X(6)=X(6)-(el%CAVITY_TOTALPATH-k%TOTALPATH)*EL%P%LD
       endif

       EL%DELTA_E=(X(5)-EL%DELTA_E)*EL%P%P0C
    ENDIF

  END SUBROUTINE ADJUSTP_TIME_CAV4

  SUBROUTINE track_slice4r(EL,X,kt,zi)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) ::  X(6)
    integer zi
    TYPE(CAV4),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE) kt !,OPTIONAL :: K
    
    if(el%n_bessel/=-1) then
     call INTER_CAV4(EL,X,kt)
    else
     call INTER_CAVbmad4(EL,X,kt,zi)
    endif    
  end SUBROUTINE track_slice4r

  SUBROUTINE INTER_CAV4(EL,X,kt)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) ::  X(6)

    TYPE(CAV4),INTENT(INOUT):: EL
    real(dp) D,DH,DD
    real(dp) D1,D2,DK1,DK2
    real(dp) DD1,DD2
    real(dp) DF(4),DK(4),DDF(4)
    INTEGER I,J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    TYPE(INTERNAL_STATE) kt !,OPTIONAL :: K

    IF(EL%THIN) return
    k=kt
    TOTALPATH_FLAG=k%TOTALPATH
    k%TOTALPATH=el%CAVITY_TOTALPATH



    SELECT CASE(EL%P%METHOD)
    CASE(2)
       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       DD=EL%P%LD/2.0_dp/EL%P%NST

       !       DO I=1,B%N

       !        X=BEAM_IN_X(B,I)
       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICKCAV (EL,D,X,k)
       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)


    CASE(4)
       D1=EL%L*FD1/EL%P%NST
       D2=EL%L*FD2/EL%P%NST
       DD1=EL%P%LD*FD1/EL%P%NST
       DD2=EL%P%LD*FD2/EL%P%NST
       DK1=EL%L*FK1/EL%P%NST
       DK2=EL%L*FK2/EL%P%NST

       !       DO I=1,B%N

       !        X=BEAM_IN_X(B,I)
       CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICKCAV (EL,DK1,X,k)
       CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICKCAV (EL,DK2,X,k)

       CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICKCAV (EL,DK1,X,k)
       CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)



    CASE(6)
       DO I =1,4
          DF(I)=EL%L*YOSD(I)/EL%P%NST
          DDF(I)=EL%P%LD*YOSD(I)/EL%P%NST
          DK(I)=EL%L*YOSK(I)/EL%P%NST
       ENDDO

       !       DO I=1,B%N

       !        X=BEAM_IN_X(B,I)
       DO J=4,2,-1
          CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKCAV (EL,DK(J),X,k)
       ENDDO
       CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICKCAV (EL,DK(1),X,k)

       CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       DO J=2,4
          CALL KICKCAV(EL,DK(J),X,k)
          CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       ENDDO




    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

    k%TOTALPATH=TOTALPATH_FLAG


  END SUBROUTINE INTER_CAV4

  SUBROUTINE INTEP_CAV4(EL,X,kt)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) ::  X(6)

    TYPE(CAV4P),INTENT(INOUT):: EL
    real(dp) DD
    real(dp) DD1,DD2
    real(dp) DDF(4)
    TYPE(REAL_8) DH,D,D1,D2,DK1,DK2,DF(4),DK(4)
    INTEGER I,J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    TYPE(INTERNAL_STATE) kt !,OPTIONAL :: K

    IF(EL%THIN) return
    k=kt
    TOTALPATH_FLAG=k%TOTALPATH
    k%TOTALPATH=el%CAVITY_TOTALPATH



    SELECT CASE(EL%P%METHOD)
    CASE(2)
       CALL ALLOC(DH,D)

       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       DD=EL%P%LD/2.0_dp/EL%P%NST

       !       DO I=1,B%N

       !        X=BEAM_IN_X(B,I)
       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICKCAV (EL,D,X,k)
       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)

       CALL KILL(DH,D)

    CASE(4)
       CALL ALLOC(D1,D2,DK1,DK2)
       D1=EL%L*FD1/EL%P%NST
       D2=EL%L*FD2/EL%P%NST
       DD1=EL%P%LD*FD1/EL%P%NST
       DD2=EL%P%LD*FD2/EL%P%NST
       DK1=EL%L*FK1/EL%P%NST
       DK2=EL%L*FK2/EL%P%NST

       !       DO I=1,B%N

       !        X=BEAM_IN_X(B,I)
       CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICKCAV (EL,DK1,X,k)
       CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICKCAV (EL,DK2,X,k)

       CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICKCAV (EL,DK1,X,k)
       CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)

       CALL KILL(D1,D2,DK1,DK2)


    CASE(6)
       CALL ALLOC(DF,4);CALL ALLOC(DK,4);
       DO I =1,4
          DF(I)=EL%L*YOSD(I)/EL%P%NST
          DDF(I)=EL%P%LD*YOSD(I)/EL%P%NST
          DK(I)=EL%L*YOSK(I)/EL%P%NST
       ENDDO

       !       DO I=1,B%N

       !        X=BEAM_IN_X(B,I)
       DO J=4,2,-1
          CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKCAV (EL,DK(J),X,k)
       ENDDO
       CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICKCAV (EL,DK(1),X,k)

       CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       DO J=2,4
          CALL KICKCAV(EL,DK(J),X,k)
          CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       ENDDO


       CALL KILL(DF,4);CALL KILL(DK,4);


    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

    k%TOTALPATH=TOTALPATH_FLAG


  END SUBROUTINE INTEP_CAV4

  
  SUBROUTINE track_slice4p(EL,X,kt,zi)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) ::  X(6)
    integer zi
    TYPE(REAL_8) z
    TYPE(CAV4P),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE) kt !,OPTIONAL :: K
   
    if(el%n_bessel/=-1) then
     call INTEP_CAV4(EL,X,kt)
    else
     call INTEP_CAVbmad4(EL,X,kt,zi)
    endif    
  end SUBROUTINE track_slice4p



  SUBROUTINE CAVER(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(CAV4),INTENT(INOUT):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ADJUST_TIME_CAV4(EL,X,k,1)
!    IF(EL%N_BESSEL>0)
 CALL FRINGECAV(EL,X,k,1)

    !    TOTALPATH_FLAG=k%TOTALPATH
    !    k%TOTALPATH=CAVITY_TOTALPATH

    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    DO I=1,EL%P%NST
       IF(.NOT.PRESENT(MID)) call track_slice(EL,X,k,i)
       IF(PRESENT(MID)) CALL XMID(MID,X,I)
    ENDDO

    !    k%TOTALPATH=TOTALPATH_FLAG

!    IF(EL%N_BESSEL>0)
 CALL FRINGECAV(EL,X,k,2)
    CALL ADJUST_TIME_CAV4(EL,X,k,2)


  END SUBROUTINE CAVER

  SUBROUTINE CAVEP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: MID
    TYPE(CAV4P),INTENT(INOUT):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    CALL ADJUST_TIME_CAV4(EL,X,k,1)
   ! IF(EL%N_BESSEL>0) 
CALL FRINGECAV(EL,X,k,1)
    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    !   TOTALPATH_FLAG=k%TOTALPATH
    !   k%TOTALPATH=CAVITY_TOTALPATH

    DO I=1,EL%P%NST
       call track_slice(EL,X,k,i)
       !          IF(PRESENT(MID)) CALL XMID(MID,X,I)
    ENDDO

    !    k%TOTALPATH=TOTALPATH_FLAG

  !  IF(EL%N_BESSEL>0) 
CALL FRINGECAV(EL,X,k,2)
    CALL ADJUST_TIME_CAV4(EL,X,k,2)


  END SUBROUTINE CAVEP

  SUBROUTINE CAVITYR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(CAV4),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) O,X1,X3,BBYTWT,BBYTW,BBXTW
    integer j,ko
    real(dp) dir
    IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN
    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    !    EL%DELTA_E=x(5)
    IF(.NOT.PRESENT(MID)) then
       dir=EL%P%DIR*EL%P%CHARGE
       O=twopi*EL%freq/CLIGHT

       do ko=1,el%nf

          x(5)=x(5)-el%f(ko)*dir*EL%volt*1e-3_dp*SIN(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO) &
               +EL%phase0)/EL%P%P0C
          ! doing crabola

          X1=X(1)
          X3=X(3)


          IF(EL%P%NMUL>=1) THEN
             BBYTW=EL%BN(EL%P%NMUL)
             BBXTW=EL%AN(EL%P%NMUL)

             DO  J=EL%P%NMUL-1,1,-1
                BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
                BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
                BBYTW=BBYTWT
             ENDDO
          ELSE
             BBYTW=0.0_dp
             BBXTW=0.0_dp
          ENDIF

          ! multipole * cos(omega t+ phi)/p0c

          X(2)=X(2)-el%f(ko)*dir*BBYTW/EL%P%P0C*(el%a+ el%r*cos(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0))
          X(4)=X(4)+el%f(ko)*DIR*BBXTW/EL%P%P0C*(el%a+ el%r*cos(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0))

          IF(EL%P%NMUL>=1) THEN
             BBYTW=-EL%BN(EL%P%NMUL)/EL%P%NMUL
             BBXTW=-EL%AN(EL%P%NMUL)/EL%P%NMUL


             DO  J=EL%P%NMUL,2,-1
                BBYTWT=X1*BBYTW-X3*BBXTW-EL%BN(J-1)/(J-1)
                BBXTW=X3*BBYTW+X1*BBXTW-EL%AN(J-1)/(J-1)
                BBYTW=BBYTWT
             ENDDO
             BBYTWT=X1*BBYTW-X3*BBXTW
             BBXTW=X3*BBYTW+X1*BBXTW
             BBYTW=BBYTWT
          ELSE
             BBYTW=0.0_dp
             BBXTW=0.0_dp
          ENDIF
          X(5)=X(5)+el%f(ko)*ko*O*dir*BBYTW/EL%P%P0C*el%r*sin(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)

       enddo
    endif

    IF(PRESENT(MID)) CALL XMID(MID,X,1)
    !          IF(.NOT.PRESENT(MID)) x(5)=x(5)-HALF*EL%P%DIR*EL%P%CHARGE*EL%volt*c_1d_3*SIN(twopi*EL%freq*x(6)/CLIGHT+EL%PHAS+EL%phase0)/EL%P%P0C
    !    EL%DELTA_E=(X(5)-EL%DELTA_E)*EL%P%P0C
    IF(PRESENT(MID)) CALL XMID(MID,X,1)

  END SUBROUTINE CAVITYR

  SUBROUTINE CAVITYP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: MID
    TYPE(CAV4P),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    type(real_8) O,X1,X3,BBYTWT,BBYTW,BBXTW
    INTEGER J,ko
    real(dp) dir
    IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN
    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    !    EL%DELTA_E=x(5)
    call alloc(BBYTWT,BBXTW,BBYTW,x1,x3,O)
    dir=EL%P%DIR*EL%P%CHARGE
    O=twopi*EL%freq/CLIGHT

    do ko=1,el%nf

       x(5)=x(5)-el%f(ko)*dir*EL%volt*1e-3_dp*SIN(ko*O*(x(6)+EL%t)+EL%PHAS+ &
            EL%PH(KO)+EL%phase0)/EL%P%P0C
       ! doing crabola

       X1=X(1)
       X3=X(3)


       IF(EL%P%NMUL>=1) THEN
          BBYTW=EL%BN(EL%P%NMUL)
          BBXTW=EL%AN(EL%P%NMUL)

          DO  J=EL%P%NMUL-1,1,-1
             BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
             BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
             BBYTW=BBYTWT
          ENDDO
       ELSE
          BBYTW=0.0_dp
          BBXTW=0.0_dp
       ENDIF

       ! multipole * cos(omega t+ phi)/p0c

       ! multipole * cos(omega t+ phi)/p0c

       X(2)=X(2)-el%f(ko)*dir*BBYTW/EL%P%P0C*(el%a+ el%r*cos(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0))
       X(4)=X(4)+el%f(ko)*DIR*BBXTW/EL%P%P0C*(el%a+ el%r*cos(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0))

       IF(EL%P%NMUL>=1) THEN
          BBYTW=-EL%BN(EL%P%NMUL)/EL%P%NMUL
          BBXTW=-EL%AN(EL%P%NMUL)/EL%P%NMUL


          DO  J=EL%P%NMUL,2,-1
             BBYTWT=X1*BBYTW-X3*BBXTW-EL%BN(J-1)/(J-1)
             BBXTW=X3*BBYTW+X1*BBXTW-EL%AN(J-1)/(J-1)
             BBYTW=BBYTWT
          ENDDO
          BBYTWT=X1*BBYTW-X3*BBXTW
          BBXTW=X3*BBYTW+X1*BBXTW
          BBYTW=BBYTWT
       ELSE
          BBYTW=0.0_dp
          BBXTW=0.0_dp
       ENDIF
       X(5)=X(5)+el%f(ko)*ko*O*dir*BBYTW/EL%P%P0C*el%r*sin(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)

    enddo

    call KILL(BBYTWT,BBXTW,BBYTW,x1,x3,O)
  END SUBROUTINE CAVITYP
!!!!! Saga stuff !!!!!
  SUBROUTINE Abmad_TRANSR(EL,Z,X,k,A,AD)    ! EXP(-I:(X^2+Y^2)/2*A_TRANS:)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(INOUT):: Z,A(3),AD(2)
    TYPE(CAV4),INTENT(INOUT):: EL
    real(dp) C1,S1,V,O
     INTEGER KO
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    if(el%N_BESSEL/=-1) return
    IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN
    IF(EL%THIN) RETURN


    O=EL%freq*twopi/CLIGHT
    V=EL%P%CHARGE*EL%volt*1e-3_dp/EL%P%P0C

    A=0.0_dp
    ad=0.0_dp
   do ko=1,el%nf    ! over modes
   
    C1=el%f(ko)*V*sin(ko*O*z)*COS(ko*O*(x(6)+EL%t)+EL%PHAS+EL%phase0+EL%PH(KO))*0.5_dp
    S1=-el%f(ko)*(ko*O)*V*sin(ko*O*z)*SIN(ko*O*(x(6)+EL%t)+EL%PHAS+EL%phase0+EL%PH(KO))/4.0_dp
    AD(1)=-C1+AD(1)
    AD(2)=S1+AD(2)

    A(1)=AD(1)*X(1)+A(1)
    A(2)=AD(1)*X(3)+A(2)
!!!   DA_3/DT FOR KICK IN X(5)    
    A(3)=A(3)-EL%P%DIR*el%f(ko)*V*COS(ko*O*z)*SIN(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)
   enddo

  !     x(5)=x(5)-el%f(ko)*F*VL*cos(kbmad*ko*O*z)*SIN(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)
 



  END SUBROUTINE Abmad_TRANSR

 SUBROUTINE Abmad_TRANSP(EL,Z,X,k,A,AD)    ! EXP(-I:(X^2+Y^2)/2*A_TRANS:)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(INOUT):: Z,A(3),AD(2)
    TYPE(CAV4P),INTENT(INOUT):: EL
    TYPE(REAL_8) C1,S1,V,O
     INTEGER KO
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    if(el%N_BESSEL/=-1) return
    IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN
    IF(EL%THIN) RETURN
    
    CALL ALLOC(C1,S1,V,O)

    O=EL%freq*twopi/CLIGHT
    V=EL%P%CHARGE*EL%volt*1e-3_dp/EL%P%P0C
    
    DO KO=1,3
     A(KO)=0.0_dp
    ENDDO
    DO KO=1,2
     AD(KO)=0.0_dp
    ENDDO

   do ko=1,el%nf    ! over modes
   
    C1=el%f(ko)*V*sin(ko*O*z)*COS(ko*O*(x(6)+EL%t)+EL%PHAS+EL%phase0+EL%PH(KO))*0.5_dp
    S1=-el%f(ko)*(ko*O)*V*sin(ko*O*z)*SIN(ko*O*(x(6)+EL%t)+EL%PHAS+EL%phase0+EL%PH(KO))/4.0_dp
    AD(1)=-C1+AD(1)
    AD(2)=S1+AD(2)

    A(1)=AD(1)*X(1)+A(1)
    A(2)=AD(1)*X(3)+A(2)
!!!   DA_3/DT FOR KICK IN X(5)    
    A(3)=A(3)-EL%P%DIR*el%f(ko)*V*COS(ko*O*z)*SIN(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)
   enddo

  !     x(5)=x(5)-el%f(ko)*F*VL*cos(kbmad*ko*O*z)*SIN(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)
 

    CALL KILL(C1,S1,V,O)


  END SUBROUTINE Abmad_TRANSP

  subroutine fevalBMAD_CAVR(Z0,X,k,f,D)   ! MODELLED BASED ON DRIFT
    IMPLICIT NONE
    real(dp), INTENT(INout) :: X(6)
    real(dp),INTENT(INOUT):: Z0
    real(dp), INTENT(INOUT) :: F(6)
    REAL(DP) A(3),AD(2),PZ
    TYPE(CAV4),  INTENT(INOUT) :: D
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    CALL Abmad_TRANS(D,Z0,X,k,A,AD)

    X(2)=X(2)-A(1)
    X(4)=X(4)-A(2)

    IF(D%P%EXACT) THEN
       if(k%TIME) then
          PZ=ROOT(1.0_dp+2.0_dp*X(5)/D%P%BETA0+x(5)**2-X(2)**2-X(4)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp/D%P%BETA0+X(5))/PZ-(1-k%TOTALPATH)/D%P%BETA0
       else
          PZ=ROOT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp+X(5))/PZ-(1-k%TOTALPATH)
       endif
    ELSE
       if(k%TIME) then
          PZ=ROOT(1.0_dp+2.0_dp*X(5)/D%P%BETA0+x(5)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=((X(2)*X(2)+X(4)*X(4))/2.0_dp/pz**2+1.0_dp)*(1.0_dp/D%P%BETA0+x(5))/pz
          F(6)=F(6)-(1-k%TOTALPATH)/D%P%BETA0
       else
          F(1)=X(2)/(1.0_dp+X(5))
          F(3)=X(4)/(1.0_dp+X(5))
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp/(1.0_dp+X(5)))*(X(2)*X(2)+X(4)*X(4))/2.0_dp/(1.0_dp+X(5))+k%TOTALPATH
       endif
    ENDIF

    X(2)=X(2)+A(1)
    X(4)=X(4)+A(2)

  END subroutine fevalBMAD_CAVR


  subroutine fevalBMAD_CAVP(Z0,X,k,f,D)   ! MODELLED BASED ON DRIFT
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INout) :: X(6)
    TYPE(REAL_8),INTENT(INOUT):: Z0
    TYPE(REAL_8), INTENT(INOUT) :: F(6)
    TYPE(REAL_8)  A(3),AD(2),PZ
    TYPE(CAV4P),  INTENT(INOUT) :: D
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call alloc(A,3)
    call alloc(AD,2)
    call alloc(PZ)

    CALL Abmad_TRANS(D,Z0,X,k,A,AD)

    X(2)=X(2)-A(1)
    X(4)=X(4)-A(2)

    IF(D%P%EXACT) THEN
       if(k%TIME) then
          PZ=sqrt(1.0_dp+2.0_dp*X(5)/D%P%BETA0+x(5)**2-X(2)**2-X(4)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp/D%P%BETA0+X(5))/PZ-(1-k%TOTALPATH)/D%P%BETA0
       else
          PZ=sqrt((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp+X(5))/PZ-(1-k%TOTALPATH)
       endif
    ELSE
       if(k%TIME) then
          PZ=sqrt(1.0_dp+2.0_dp*X(5)/D%P%BETA0+x(5)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=((X(2)*X(2)+X(4)*X(4))/2.0_dp/pz**2+1.0_dp)*(1.0_dp/D%P%BETA0+x(5))/pz
          F(6)=F(6)-(1-k%TOTALPATH)/D%P%BETA0
       else
          F(1)=X(2)/(1.0_dp+X(5))
          F(3)=X(4)/(1.0_dp+X(5))
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp/(1.0_dp+X(5)))*(X(2)*X(2)+X(4)*X(4))/2.0_dp/(1.0_dp+X(5))+k%TOTALPATH
       endif
    ENDIF

    X(2)=X(2)+A(1)
    X(4)=X(4)+A(2)

    call KILL(A,3)
    call KILL(AD,2)
    call KILL(PZ)
  END subroutine fevalBMAD_CAVP

 subroutine rk2bmad_cavr(ti,h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    real(dp), INTENT(INOUT)::  y(ne)
    real(dp)  yt(ne),f(ne),a(ne),b(ne)
    real(dp)  tt
    type (cav4) ,INTENT(INOUT)::  GR
    integer j
    real(dp), intent(inout) :: ti,h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    call feval_cav(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    tt=tI+h/2.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+b(j)
    enddo
    tI=ti+h

    return
  end  subroutine rk2bmad_cavr

 subroutine rk4bmad_cavr(ti,h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    real(dp), INTENT(INOUT)::  y(ne)
    real(dp)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne)
    type (CAV4) ,INTENT(INOUT)::  GR
    integer j
    real(dp), intent(inout) :: h
    real(dp), intent(inout) :: ti
    real(dp) TT
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    call feval_cav(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    tt=tI+h/2.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + b(j)/2.0_dp
    enddo


    !      tt=tI+1
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+c(j)
    enddo

    tt=tI+h
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo


    do  j=1,ne
       y(j) = y(j)+(a(j)+2.0_dp*b(j)+2.0_dp*c(j)+d(j))/6.0_dp
    enddo
    tI=tt

    return
  end  subroutine rk4bmad_cavr

 subroutine rk6bmad_cavr(ti,h,GR,y,k)
    IMPLICIT none
    !  Written by Rob Ryne, Spring 1986, based on a routine of
    !c  J. Milutinovic.
    !c  For a reference, see page 76 of F. Ceschino and J Kuntzmann,
    !c  Numerical Solution of Initial Value Problems, Prentice Hall 1966.
    !c  This integration routine makes local truncation errors at each
    !c  step of order h**7.
    !c  That is, it is locally correct through terms of order h**6.
    !c  Each step requires 8 function evaluations.

    integer ne
    parameter (ne=6)
    real(dp), INTENT(INOUT)::  y(ne)
    real(dp)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne),e(ne),g(ne),o(ne),p(ne)
    real(dp)  tt
    type (CAV4) ,INTENT(INOUT)::  GR
    integer j
    real(dp), intent(inout) :: ti,h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    call feval_cav(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/9.0_dp
    enddo
    tt=tI+h/9.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + (a(j) + 3.0_dp*b(j))/24.0_dp
    enddo
    tt=tI+h/6.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j)+(a(j)-3.0_dp*b(j)+4.0_dp*c(j))/6.0_dp
    enddo

    tt=tI+h/3.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (-5.0_dp*a(j) + 27.0_dp*b(j) - 24.0_dp*c(j) + 6.0_dp*d(j))/8.0_dp
    enddo
    tt=tI+0.5_dp*h
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       e(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (221.0_dp*a(j) - 981.0_dp*b(j) + 867.0_dp*c(j)- 102.0_dp*d(j) + e(j))/9.0_dp
    enddo
    tt = tI+2.0_dp*h/3.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do   j=1,ne
       g(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(-183.0_dp*a(j)+678.0_dp*b(j)-472.0_dp*c(j)-66.0_dp*d(j)+80.0_dp*e(j) + 3.0_dp*g(j))/48.0_dp
    enddo
    tt = tI + 5.0_dp*h/6.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       o(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(716.0_dp*a(j)-2079.0_dp*b(j)+1002.0_dp*c(j)+834.0_dp*d(j)-454.0_dp*e(j)-9.0_dp*g(j)+72.0_dp*o(j))/82.0_dp
    enddo

    tt = tI + h
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       p(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+(41.0_dp*a(j)+216.0_dp*c(j)+27.0_dp*d(j)+272.0_dp*e(j)+27.0_dp*g(j)+216.0_dp*o(j)+41.0_dp*p(j))/840.0_dp
    enddo
    tI=ti+h

    return
  end  subroutine rk6bmad_cavr

  subroutine rk2bmad_cavp(ti,h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    type (real_8), INTENT(INOUT)::  y(ne)
    type (real_8)  yt(ne),f(ne),a(ne),b(ne)
    type (real_8)  tt
    type (cav4p) ,INTENT(INOUT)::  GR
    integer j
    type(real_8), intent(inout) :: ti,h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call alloc(yt,ne)
    call alloc(f,ne)
    call alloc(a,ne)
    call alloc(b,ne)

    call alloc(tt)

    call feval_cav(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    tt=tI+h/2.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+b(j)
    enddo
    tI=ti+h

    call kill(tt)
    call kill(yt,ne)
    call kill(f,ne)
    call kill(a,ne)
    call kill(b,ne)

    return
  end  subroutine rk2bmad_cavp

  subroutine rk4bmad_cavp(ti,h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    type(real_8), INTENT(INOUT)::  y(ne)
    type (CAV4p) ,INTENT(INOUT)::  GR
    type(real_8), intent(inout) :: h
    type(real_8), intent(inout) :: ti
    type(real_8)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne)
    type(real_8) TT
    integer j
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call alloc(tt)
    call alloc(yt)
    call alloc(f)
    call alloc(a)
    call alloc(b)
    call alloc(c)
    call alloc(d)

    call feval_cav(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    tt=tI+h/2.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + b(j)/2.0_dp
    enddo


    !      tt=tI+1
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+c(j)
    enddo

    tt=tI+h
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo


    do  j=1,ne
       y(j) = y(j)+(a(j)+2.0_dp*b(j)+2.0_dp*c(j)+d(j))/6.0_dp
    enddo
    tI=tt

    call kill(tt)
    call kill(yt)
    call kill(f)
    call kill(a)
    call kill(b)
    call kill(c)
    call kill(d)

    return
  end  subroutine rk4bmad_cavp

  ! sixth order Runge
  subroutine rk6bmad_cavp(ti,h,GR,y,k)
    IMPLICIT none


    integer ne
    parameter (ne=6)
    type (real_8), INTENT(INOUT)::  y(ne)
    type (real_8)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne),e(ne),g(ne),o(ne),p(ne)
    type (real_8)  tt
    type (cav4p) ,INTENT(INOUT)::  GR
    integer j
    type(real_8), intent(inout) :: ti,h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call alloc(yt,ne)
    call alloc(f,ne)
    call alloc(a,ne)
    call alloc(b,ne)
    call alloc(c,ne)
    call alloc(d,ne)
    call alloc(e,ne)
    call alloc(g,ne)
    call alloc(o,ne)
    call alloc(p,ne)
    call alloc(tt)

    call feval_cav(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/9.0_dp
    enddo
    tt=tI+h/9.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + (a(j) + 3.0_dp*b(j))/24.0_dp
    enddo
    tt=tI+h/6.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j)+(a(j)-3.0_dp*b(j)+4.0_dp*c(j))/6.0_dp
    enddo

    tt=tI+h/3.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (-5.0_dp*a(j) + 27.0_dp*b(j) - 24.0_dp*c(j) + 6.0_dp*d(j))/8.0_dp
    enddo
    tt=tI+0.5_dp*h
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       e(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (221.0_dp*a(j) - 981.0_dp*b(j) + 867.0_dp*c(j)- 102.0_dp*d(j) + e(j))/9.0_dp
    enddo
    tt = tI+2.0_dp*h/3.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do   j=1,ne
       g(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(-183.0_dp*a(j)+678.0_dp*b(j)-472.0_dp*c(j)-66.0_dp*d(j)+80.0_dp*e(j) + 3.0_dp*g(j))/48.0_dp
    enddo
    tt = tI + 5.0_dp*h/6.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       o(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(716.0_dp*a(j)-2079.0_dp*b(j)+1002.0_dp*c(j)+834.0_dp*d(j)-454.0_dp*e(j)-9.0_dp*g(j)+72.0_dp*o(j))/82.0_dp
    enddo

    tt = tI + h
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       p(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+(41.0_dp*a(j)+216.0_dp*c(j)+27.0_dp*d(j)+272.0_dp*e(j)+27.0_dp*g(j)+216.0_dp*o(j)+41.0_dp*p(j))/840.0_dp
    enddo
    tI=ti+h
    call kill(tt)
    call kill(yt,ne)
    call kill(f,ne)
    call kill(a,ne)
    call kill(b,ne)
    call kill(c,ne)
    call kill(d,ne)
    call kill(e,ne)
    call kill(g,ne)
    call kill(o,ne)
    call kill(p,ne)

    return
  end  subroutine rk6bmad_cavp

  SUBROUTINE INTER_CAVbmad4(EL,X,kt,j)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(CAV4),INTENT(INOUT):: EL

    integer , INTENT(IN) :: j
    real(dp) D1
    REAL(DP) Z0
    INTEGER TOTALPATH
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    TYPE(INTERNAL_STATE) kt !,OPTIONAL :: K

    D1=el%p%dir*EL%L/EL%P%NST
    IF(EL%P%DIR==1) THEN
       Z0=(j-1)*d1
    ELSE
       Z0=EL%L+(j-1)*d1
    ENDIF

    k=kt
    TOTALPATH=k%TOTALPATH
    k%TOTALPATH=1
    SELECT CASE(EL%P%METHOD)
    CASE(2)

       call rk2_cav(z0,d1,el,X,k)

    CASE(4)

       call rk4_cav(z0,d1,el,X,k)

    CASE(6)

       call rk6_cav(z0,d1,el,X,k)
    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

    !    IF(k%FRINGE)

    k%TOTALPATH=TOTALPATH

  END SUBROUTINE INTER_CAVbmad4

  SUBROUTINE INTEP_CAVbmad4(EL,X,kt,j)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(CAV4P),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    TYPE(INTERNAL_STATE) kt !,OPTIONAL :: K

    !    TYPE(REAL_8), INTENT(IN) :: Z
    integer, INTENT(IN) :: j
    TYPE(REAL_8) Z0,D1
    INTEGER TOTALPATH
    real(dp) xx(6)

    CALL ALLOC(Z0,D1)

    D1=el%p%dir*EL%L/EL%P%NST
    IF(EL%P%DIR==1) THEN
       Z0=(j-1)*d1
    ELSE
       Z0=EL%L+(j-1)*d1
    ENDIF
    k=kt
    TOTALPATH=k%TOTALPATH
    k%TOTALPATH=1

    SELECT CASE(EL%P%METHOD)
    CASE(2)

       call rk2_cav(z0,d1,el,X,k)

    CASE(4)

       call rk4_cav(z0,d1,el,X,k)

    CASE(6)

       call rk6_cav(z0,d1,el,X,k)

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

    !    IF(k%FRINGE)

    k%TOTALPATH=TOTALPATH

    CALL KILL(Z0,D1)


  END SUBROUTINE INTEP_CAVbmad4



  SUBROUTINE FRINGECAVR(EL,X,k,J)
    IMPLICIT NONE
    REAL(DP), INTENT(INOUT) ::  X(6)
    TYPE(CAV4),INTENT(INOUT):: EL
    integer,INTENT(IN):: J
    integer JC,ko
    REAL(DP) C1,S1,V,O,z
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    REAL(DP) KBMAD 
    !return
    !  As of June 2007, Etienne believes that the fringe approximately cancels
    ! it is a mystery perhaps due to the use of canonical variables.
    ! as of 2012 David Sagan said that this is needed after all

    JC=-2*J+3
    if(jc==1) then
     z=0.0_dp
    else
     z=EL%L
    endif

    IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN
    IF(.NOT.(k%FRINGE.or.el%p%permfringe.or.el%N_BESSEL==-1)) RETURN  ! 2012 forcing fringes if n_bessel > 0
    IF(EL%THIN) RETURN
    IF(jC==1.AND.EL%P%KILL_ENT_FRINGE) RETURN
    IF(jC==-1.AND.EL%P%KILL_EXI_FRINGE) RETURN
    IF(el%N_BESSEL==-1) THEN
     KBMAD=1
    ELSE
     KBMAD=0 
    ENDIF

       

    O=EL%freq*twopi/CLIGHT
    V=jC*EL%P%CHARGE*EL%volt*1e-3_dp/EL%P%P0C


   do ko=1,el%nf    ! over modes
   
    s1=cos(kbmad*ko*O*z)*sin(ko*O*(x(6)+EL%t)+EL%PHAS+EL%phase0+EL%PH(KO))
    c1=cos(kbmad*ko*O*z)*cos(ko*O*(x(6)+EL%t)+EL%PHAS+EL%phase0+EL%PH(KO))


    X(2)=X(2)+V*S1*X(1)*0.5_dp
    X(4)=X(4)+V*S1*X(3)*0.5_dp
    x(5)=x(5)-0.25e0_dp*(X(1)**2+X(3)**2)*V*C1*O*ko

   enddo
  END SUBROUTINE FRINGECAVR

  SUBROUTINE FRINGECAVP(EL,X,k,J)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) ::  X(6)
    TYPE(CAV4P),INTENT(INOUT):: EL
    integer,INTENT(IN):: J
    integer JC,ko
    TYPE(REAL_8) C1,S1,V,O,z
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    REAL(DP) KBMAD 
    !return
    !  As of June 2007, Etienne believes that the fringe approximately cancels
    ! it is a mystery perhaps due to the use of canonical variables.
    ! as of 2012 David Sagan said that this is needed after all
    CALL ALLOC(C1,S1,V,O,z)
    
 
    JC=-2*J+3
    if(jc==1) then
     z=0.0_dp
    else
     z=EL%L
    endif

    IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN
    IF(.NOT.(k%FRINGE.or.el%p%permfringe.or.el%N_BESSEL==-1)) RETURN  ! 2012 forcing fringes if n_bessel > 0
    IF(EL%THIN) RETURN
    IF(jC==1.AND.EL%P%KILL_ENT_FRINGE) RETURN
    IF(jC==-1.AND.EL%P%KILL_EXI_FRINGE) RETURN
    IF(el%N_BESSEL==-1) THEN
     KBMAD=1
    ELSE
     KBMAD=0 
    ENDIF

    O=EL%freq*twopi/CLIGHT
    V=jC*EL%P%CHARGE*EL%volt*1e-3_dp/EL%P%P0C

   do ko=1,el%nf    ! over modes
   
    s1=cos(kbmad*ko*O*z)*sin(ko*O*(x(6)+EL%t)+EL%PHAS+EL%phase0+EL%PH(KO))
    c1=cos(kbmad*ko*O*z)*cos(ko*O*(x(6)+EL%t)+EL%PHAS+EL%phase0+EL%PH(KO))


    X(2)=X(2)+V*S1*X(1)*0.5_dp
    X(4)=X(4)+V*S1*X(3)*0.5_dp
    x(5)=x(5)-0.25e0_dp*(X(1)**2+X(3)**2)*V*C1*O*ko

   enddo
    CALL KILL(C1,S1,V,O,z)

  END SUBROUTINE FRINGECAVP





 
  SUBROUTINE KICKCAVR(EL,YL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(INOUT):: YL
    TYPE(CAV4),INTENT(INOUT):: EL
    real(dp) DF,R2,F,DR2,O,VL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) BBYTWT,BBXTW,BBYTW,x1,x3
    integer j,ko
    real(dp) dir

    IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN

    DIR=EL%P%DIR*EL%P%CHARGE

    O=twopi*EL%freq/CLIGHT
    VL=dir*YL*EL%volt*1e-3_dp/EL%P%P0C

    do ko=1,el%nf    ! over modes

       DF=0.0_dp
       F=1.0_dp
       R2=1.0_dp

       DO I=1,EL%N_BESSEL
          R2=-R2*(ko*O)**2/4.0_dp/(I+1)**2
          DR2=R2*I
          DF=DF+DR2*2
          R2=R2*(X(1)**2+X(3)**2)
          F=F+R2
       ENDDO

       !    EL%DELTA_E=x(5)

       IF(EL%N_BESSEL>0) THEN
          X(2)=X(2)-X(1)*el%f(ko)*DF*VL*COS(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)/(ko*O)
          X(4)=X(4)-X(3)*el%f(ko)*DF*VL*COS(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)/(ko*O)
       ENDIF


       x(5)=x(5)-el%f(ko)*F*VL*SIN(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)


       ! doing crabola


       X1=X(1)
       X3=X(3)


       IF(EL%P%NMUL>=1) THEN
          BBYTW=EL%BN(EL%P%NMUL)
          BBXTW=EL%AN(EL%P%NMUL)

          DO  J=EL%P%NMUL-1,1,-1
             BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
             BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
             BBYTW=BBYTWT
          ENDDO
       ELSE
          BBYTW=0.0_dp
          BBXTW=0.0_dp
       ENDIF

       ! multipole * cos(omega t+ phi)/p0c

       X(2)=X(2)-el%f(ko)*YL*DIR*BBYTW/EL%P%P0C*(EL%A+EL%R*cos(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0))
       X(4)=X(4)+el%f(ko)*YL*DIR*BBXTW/EL%P%P0C*(EL%A+EL%R*cos(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0))

       IF(EL%P%NMUL>=1) THEN
          BBYTW=-EL%BN(EL%P%NMUL)/EL%P%NMUL
          BBXTW=-EL%AN(EL%P%NMUL)/EL%P%NMUL


          DO  J=EL%P%NMUL,2,-1
             BBYTWT=X1*BBYTW-X3*BBXTW-EL%BN(J-1)/(J-1)
             BBXTW=X3*BBYTW+X1*BBXTW-EL%AN(J-1)/(J-1)
             BBYTW=BBYTWT
          ENDDO
          BBYTWT=X1*BBYTW-X3*BBXTW
          BBXTW=X3*BBYTW+X1*BBXTW
          BBYTW=BBYTWT
       ELSE
          BBYTW=0.0_dp
          BBXTW=0.0_dp
       ENDIF

       X(5)=X(5)+el%f(ko)*(ko*O)*YL*DIR*BBYTW/EL%P%P0C*EL%R*sin(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)
    enddo    ! over modes


  END SUBROUTINE KICKCAVR

SUBROUTINE KICKCAVP(EL,YL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6),YL
    TYPE(CAV4P),INTENT(INOUT):: EL
    TYPE(REAL_8) DF,R2,F,DR2,O,VL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    TYPE(REAL_8) BBYTWT,BBXTW,BBYTW,x1,x3
    integer j,ko
    real(dp) dir

    IF(k%NOCAVITY.and.(.not.EL%always_on)) RETURN
    CALL ALLOC(DF,R2,F,DR2,O,VL)
    call alloc(BBYTWT,BBXTW,BBYTW,x1,x3)

    DIR=EL%P%DIR*EL%P%CHARGE

    O=twopi*EL%freq/CLIGHT
    VL=dir*YL*EL%volt*1e-3_dp/EL%P%P0C

    do ko=1,el%nf    ! over modes

       DF=0.0_dp
       F=1.0_dp
       R2=1.0_dp

       DO I=1,EL%N_BESSEL
          R2=-R2*(ko*O)**2/4.0_dp/(I+1)**2
          DR2=R2*I
          DF=DF+DR2*2
          R2=R2*(X(1)**2+X(3)**2)
          F=F+R2
       ENDDO

       !    EL%DELTA_E=x(5)

       IF(EL%N_BESSEL>0) THEN
          X(2)=X(2)-X(1)*el%f(ko)*DF*VL*COS(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)/(ko*O)
          X(4)=X(4)-X(3)*el%f(ko)*DF*VL*COS(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)/(ko*O)
       ENDIF


       x(5)=x(5)-el%f(ko)*F*VL*SIN(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)


       ! doing crabola


       X1=X(1)
       X3=X(3)


       IF(EL%P%NMUL>=1) THEN
          BBYTW=EL%BN(EL%P%NMUL)
          BBXTW=EL%AN(EL%P%NMUL)

          DO  J=EL%P%NMUL-1,1,-1
             BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
             BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
             BBYTW=BBYTWT
          ENDDO
       ELSE
          BBYTW=0.0_dp
          BBXTW=0.0_dp
       ENDIF

       ! multipole * cos(omega t+ phi)/p0c

       X(2)=X(2)-el%f(ko)*YL*DIR*BBYTW/EL%P%P0C*(EL%A+EL%R*cos(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0))
       X(4)=X(4)+el%f(ko)*YL*DIR*BBXTW/EL%P%P0C*(EL%A+EL%R*cos(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0))

       IF(EL%P%NMUL>=1) THEN
          BBYTW=-EL%BN(EL%P%NMUL)/EL%P%NMUL
          BBXTW=-EL%AN(EL%P%NMUL)/EL%P%NMUL


          DO  J=EL%P%NMUL,2,-1
             BBYTWT=X1*BBYTW-X3*BBXTW-EL%BN(J-1)/(J-1)
             BBXTW=X3*BBYTW+X1*BBXTW-EL%AN(J-1)/(J-1)
             BBYTW=BBYTWT
          ENDDO
          BBYTWT=X1*BBYTW-X3*BBXTW
          BBXTW=X3*BBYTW+X1*BBXTW
          BBYTW=BBYTWT
       ELSE
          BBYTW=0.0_dp
          BBXTW=0.0_dp
       ENDIF

       X(5)=X(5)+el%f(ko)*(ko*O)*YL*DIR*BBYTW/EL%P%P0C*EL%R*sin(ko*O*(x(6)+EL%t)+EL%PHAS+EL%PH(KO)+EL%phase0)

    enddo    ! over modes
    CALL kill(DF,R2,F,DR2,O,VL)
    call kill(BBYTWT,BBXTW,BBYTW,x1,x3)

  END SUBROUTINE KICKCAVP

  ! STUFF NEEDED FOR INTEGRATION
  SUBROUTINE DRIFTR(L,LD,b,T,EXACT,CTIME,X)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN):: L
    real(dp), INTENT(IN):: LD
    INTEGER,INTENT(IN):: T
    real(dp) PZ,b
    logical(lp) EXACT,CTIME


    IF(EXACT) THEN
       if(CTIME) then
          PZ=ROOT(1.0_dp+2.0_dp*X(5)/b+x(5)**2-X(2)**2-X(4)**2)
          X(1)=X(1)+L*X(2)/PZ
          X(3)=X(3)+L*X(4)/PZ
          X(6)=X(6)+L*(1.0_dp/b+X(5))/PZ-(1-T)*LD/b
       else
          PZ=ROOT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          X(1)=X(1)+L*X(2)/PZ
          X(3)=X(3)+L*X(4)/PZ
          X(6)=X(6)+L*(1.0_dp+X(5))/PZ-(1-T)*LD
       endif
    ELSE
       if(CTIME) then
          PZ=ROOT(1.0_dp+2.0_dp*X(5)/b+x(5)**2)
          X(1)=X(1)+L*X(2)/pz
          X(3)=X(3)+L*X(4)/pz
          ! bug found by Schmidt totalpath=false time=true
          !          X(6)=X(6)+((X(2)*X(2)+X(4)*X(4))/two/pz**2+T)*(one/b+x(5))*L/pz
          X(6)=X(6)+((X(2)*X(2)+X(4)*X(4))/2.0_dp/pz**2+1.0_dp)*(1.0_dp/b+x(5))*L/pz
          X(6)=X(6)-(1-T)*L/B
       else
          X(1)=X(1)+L*X(2)/(1.0_dp+X(5))
          X(3)=X(3)+L*X(4)/(1.0_dp+X(5))
          X(6)=X(6)+(L/(1.0_dp+X(5)))*(X(2)*X(2)+X(4)*X(4))/2.0_dp/(1.0_dp+X(5))+T*L
       endif
    ENDIF

  END SUBROUTINE DRIFTR

  SUBROUTINE DRIFTP(L,LD,b,T,EXACT,ctime,X)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN):: L
    real(dp), INTENT(IN):: LD
    INTEGER,INTENT(IN):: T
    TYPE(REAL_8) PZ
    logical(lp) EXACT,ctime
    real(dp) b

    IF(EXACT) THEN
       CALL ALLOC(PZ)
       if(ctime) then
          PZ=SQRT(1.0_dp+2.0_dp*X(5)/b+x(5)**2-X(2)**2-X(4)**2)
          X(1)=X(1)+L*X(2)/PZ
          X(3)=X(3)+L*X(4)/PZ
          X(6)=X(6)+L*(1.0_dp/b+X(5))/PZ-(1-T)*LD/b
       else
          PZ=SQRT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          X(1)=X(1)+L*X(2)/PZ
          X(3)=X(3)+L*X(4)/PZ
          X(6)=X(6)+L*(1.0_dp+X(5))/PZ-(1-T)*LD
       endif
       CALL KILL(PZ)
    ELSE
       if(ctime) then
          CALL ALLOC(PZ)
          PZ=SQRT(1.0_dp+2.0_dp*X(5)/b+x(5)**2)
          X(1)=X(1)+L*X(2)/pz
          X(3)=X(3)+L*X(4)/pz
          ! bug found by Schmidt totalpath=false time=true
          !          X(6)=X(6)+((X(2)*X(2)+X(4)*X(4))/two/pz**2+T)*(one/b+x(5))*L/pz
          X(6)=X(6)+((X(2)*X(2)+X(4)*X(4))/2.0_dp/pz**2+1.0_dp)*(1.0_dp/b+x(5))*L/pz
          X(6)=X(6)-(1-T)*L/B
          CALL KILL(PZ)
       else
          X(1)=X(1)+L*X(2)/(1.0_dp+X(5))
          X(3)=X(3)+L*X(4)/(1.0_dp+X(5))
          X(6)=X(6)+(L/(1.0_dp+X(5)))*(X(2)*X(2)+X(4)*X(4))/2.0_dp/(1.0_dp+X(5))+T*L
       endif
    ENDIF

  END SUBROUTINE DRIFTP

  SUBROUTINE KICKTR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(KICKT3),INTENT(IN):: EL
    real(dp) X1,X3,BBYTW,BBXTW,BBYTWT,pz,alfh
    INTEGER J,I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) myCOS,mySIN,ANG,XT(6)



    X1=X(1)
    X3=X(3)

    IF(EL%P%NMUL>=1) THEN
       BBYTW=EL%BN(EL%P%NMUL)
       BBXTW=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF
    if(el%patch) then
       alfh=-EL%thin_h_angle/2.0_dp
       call ROT_XZ(alfh,X,EL%P%BETA0,EL%P%exact.or.c_%ALWAYS_EXACT_PATCHING,k%TIME)
    endif
    IF(PRESENT(MID)) THEN
       CALL XMID(MID,X,0)

       CALL XMID(MID,X,1)

       CALL XMID(MID,X,1)
    ELSE
       if(k%TIME) then
          PZ=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%BETA0+x(5)**2)
          X(2)=X(2)+(-EL%thin_h_foc+EL%hf)*x1+EL%P%DIR*EL%P%CHARGE*EL%thin_h_angle*(PZ-1.0_dp)  ! highly illegal additions by frs
          X(4)=X(4)+(-EL%thin_v_foc+EL%vf)*x3+EL%P%DIR*EL%P%CHARGE*EL%thin_v_angle*(PZ-1.0_dp)  ! highly illegal additions by frs
          X(6)=X(6)+EL%P%DIR*EL%P%CHARGE*(EL%thin_h_angle*x1+EL%thin_v_angle*x3)*(1.0_dp/EL%P%BETA0+x(5))/pz
       else
          X(2)=X(2)+(-EL%thin_h_foc+EL%hf)*x1+EL%P%DIR*EL%P%CHARGE*EL%thin_h_angle*x(5)  ! highly illegal additions by frs
          X(4)=X(4)+(-EL%thin_v_foc+EL%vf)*x3+EL%P%DIR*EL%P%CHARGE*EL%thin_v_angle*x(5)  ! highly illegal additions by frs
          X(6)=X(6)+EL%P%DIR*EL%P%CHARGE*(EL%thin_h_angle*x1+EL%thin_v_angle*x3)
       endif

       X(2)=X(2)-EL%P%DIR*EL%P%CHARGE*BBYTW     ! BACKWARDS
       X(4)=X(4)+EL%P%DIR*EL%P%CHARGE*BBXTW     ! BACKWARDS
    ENDIF

!!!!!!!!!!!   solenoid

    if(k%TIME) then   ! bug 2006.1.8
       ANG=EL%B_SOL*EL%P%CHARGE/2.0_dp/root(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)*el%ls
       !       ANG=YL*EL%B_SOL*EL%P%dir*EL%P%CHARGE/two/root(one+two*X(5)/EL%P%beta0+x(5)**2) ! bug_intentional
    else
       ANG=EL%B_SOL*EL%P%CHARGE/2.0_dp/(1.0_dp+X(5))*el%ls
       !       ANG=YL*EL%B_SOL*EL%P%dir*EL%P%CHARGE/two/(one+X(5))   ! bug_intentional
    endif
    myCOS=COS(ANG)
    mySIN=SIN(ANG)
    ! NO EXACT EL%EXACT

    XT(1)=myCOS*X(1)+mySIN*X(3)
    XT(2)=myCOS*X(2)+mySIN*X(4)
    XT(3)=myCOS*X(3)-mySIN*X(1)
    XT(4)=myCOS*X(4)-mySIN*X(2)

    if(k%TIME) then
       X(6)=X(6)+ANG*(1.0_dp/EL%P%beta0+x(5))*(X(3)*X(2)-X(1)*X(4))/(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
    else
       X(6)=X(6)+ANG*(X(3)*X(2)-X(1)*X(4))/(1.0_dp+X(5))
    endif
    DO I=1,4
       X(I)=XT(I)
    ENDDO


    myCOS=(EL%B_SOL*EL%P%CHARGE)**2*el%ls

    if(k%TIME) then
       mySIN=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
       X(2)=X(2)-(myCOS)*X(1)/4.0_dp/mySIN
       X(4)=X(4)-(myCOS)*X(3)/4.0_dp/mySIN
       X(6)=X(6)+(1.0_dp/EL%P%beta0+x(5))*(myCOS)*(X(1)**2+X(3)**2)/8.0_dp/mySIN**3
    else
       X(2)=X(2)-(myCOS)*X(1)/4.0_dp/(1.0_dp+X(5))
       X(4)=X(4)-(myCOS)*X(3)/4.0_dp/(1.0_dp+X(5))
       X(6)=X(6)+(myCOS)*(X(1)**2+X(3)**2)/8.0_dp/(1.0_dp+X(5))**2
    endif


    !  end of solenoid





    if(el%patch) then
       alfh=-EL%thin_h_angle/2.0_dp
       call ROT_XZ(alfh,X,EL%P%BETA0,EL%P%exact.or.c_%ALWAYS_EXACT_PATCHING,k%TIME)
    endif



  END SUBROUTINE KICKTR


  SUBROUTINE KICKTP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: MID
    TYPE(KICKT3P),INTENT(IN):: EL
    TYPE(REAL_8) X1,X3,BBYTW,BBXTW,BBYTWT
    TYPE(REAL_8) pz
    INTEGER J,i
    real(dp) alfh
    TYPE(REAL_8) myCOS,mySIN,ANG,XT(6)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(X1)
    CALL ALLOC(X3)
    CALL ALLOC(BBYTW)
    CALL ALLOC(BBXTW)
    CALL ALLOC(BBYTWT)
    CALL ALLOC(myCOS,mySIN,ANG)
    CALL ALLOC(XT)



    X1=X(1)
    X3=X(3)


    IF(EL%P%NMUL>=1) THEN
       BBYTW=EL%BN(EL%P%NMUL)
       BBXTW=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF


    if(el%patch) then
       alfh=-EL%thin_h_angle/2.0_dp
       call ROT_XZ(alfh,X,EL%P%BETA0,EL%P%exact.or.c_%ALWAYS_EXACT_PATCHING,k%TIME)
    endif

    if(k%TIME) then
       call alloc(pz)
       PZ=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%BETA0+x(5)**2)
       X(2)=X(2)+(-EL%thin_h_foc+EL%hf)*x1+EL%P%DIR*EL%P%CHARGE*EL%thin_h_angle*(PZ-1.0_dp)  ! highly illegal additions by frs
       X(4)=X(4)+(-EL%thin_v_foc+EL%vf)*x3+EL%P%DIR*EL%P%CHARGE*EL%thin_v_angle*(PZ-1.0_dp)  ! highly illegal additions by frs
       X(6)=X(6)+EL%P%DIR*EL%P%CHARGE*(EL%thin_h_angle*x1+EL%thin_v_angle*x3)*(1.0_dp/EL%P%BETA0+x(5))/pz
       call kill(pz)
    else
       X(2)=X(2)+(-EL%thin_h_foc+EL%hf)*x1+EL%P%DIR*EL%P%CHARGE*EL%thin_h_angle*x(5)  ! highly illegal additions by frs
       X(4)=X(4)+(-EL%thin_v_foc+EL%vf)*x3+EL%P%DIR*EL%P%CHARGE*EL%thin_v_angle*x(5)  ! highly illegal additions by frs
       X(6)=X(6)+EL%P%DIR*EL%P%CHARGE*(EL%thin_h_angle*x1+EL%thin_v_angle*x3)
    endif

    X(2)=X(2)-EL%P%DIR*EL%P%CHARGE*BBYTW     ! BACKWARDS
    X(4)=X(4)+EL%P%DIR*EL%P%CHARGE*BBXTW     ! BACKWARDS
    !    ENDIF

!!!!!!!!!!!   solenoid

    if(k%TIME) then   ! bug 2006.1.8
       ANG=EL%B_SOL*EL%P%CHARGE/2.0_dp/sqrt(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)*el%ls
       !       ANG=YL*EL%B_SOL*EL%P%dir*EL%P%CHARGE/two/root(one+two*X(5)/EL%P%beta0+x(5)**2) ! bug_intentional
    else
       ANG=EL%B_SOL*EL%P%CHARGE/2.0_dp/(1.0_dp+X(5))*el%ls
       !       ANG=YL*EL%B_SOL*EL%P%dir*EL%P%CHARGE/two/(one+X(5))   ! bug_intentional
    endif
    myCOS=COS(ANG)
    mySIN=SIN(ANG)
    ! NO EXACT EL%EXACT

    XT(1)=myCOS*X(1)+mySIN*X(3)
    XT(2)=myCOS*X(2)+mySIN*X(4)
    XT(3)=myCOS*X(3)-mySIN*X(1)
    XT(4)=myCOS*X(4)-mySIN*X(2)

    if(k%TIME) then
       X(6)=X(6)+ANG*(1.0_dp/EL%P%beta0+x(5))*(X(3)*X(2)-X(1)*X(4))/(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
    else
       X(6)=X(6)+ANG*(X(3)*X(2)-X(1)*X(4))/(1.0_dp+X(5))
    endif
    DO I=1,4
       X(I)=XT(I)
    ENDDO


    !  end of solenoid


    myCOS=(EL%B_SOL*EL%P%CHARGE)**2*el%ls

    if(k%TIME) then
       mySIN=sqrt(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
       X(2)=X(2)-(myCOS)*X(1)/4.0_dp/mySIN
       X(4)=X(4)-(myCOS)*X(3)/4.0_dp/mySIN
       X(6)=X(6)+(1.0_dp/EL%P%beta0+x(5))*(myCOS)*(X(1)**2+X(3)**2)/8.0_dp/mySIN**3
    else
       X(2)=X(2)-(myCOS)*X(1)/4.0_dp/(1.0_dp+X(5))
       X(4)=X(4)-(myCOS)*X(3)/4.0_dp/(1.0_dp+X(5))
       X(6)=X(6)+(myCOS)*(X(1)**2+X(3)**2)/8.0_dp/(1.0_dp+X(5))**2
    endif




    if(el%patch) then
       alfh=-EL%thin_h_angle/2.0_dp
       call ROT_XZ(alfh,X,EL%P%BETA0,EL%P%exact.or.c_%ALWAYS_EXACT_PATCHING,k%TIME)
    endif



    CALL KILL(myCOS,mySIN,ANG)
    CALL KILL(XT)
    CALL KILL(X1)
    CALL KILL(X3)
    CALL KILL(BBYTW)
    CALL KILL(BBXTW)
    CALL KILL(BBYTWT)

  END SUBROUTINE KICKTP

  SUBROUTINE MULTIPOLE_FRINGER(EL,AN,BN,K1,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN),dimension(:)::AN,BN
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    INTEGER, INTENT(IN) :: K1
    real(dp) A,B,C,D,DEL,X2
    INTEGER J
    real(dp) RX,IX,DRX,DIX,U,V,DU,DV,NF
    real(dp) DUX,DUY,DVX,DVY,FX_X,FX_Y,FY_X,FY_Y,FX,FY
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) i

    IF(EL%NMUL<=1) RETURN

    IF(K1==1.AND.EL%KILL_ENT_FRINGE) RETURN
    IF(K1==2.AND.EL%KILL_EXI_FRINGE) RETURN


    IF(K1==1) THEN
       I= EL%CHARGE
    ELSE
       I=-EL%CHARGE
    ENDIF

    FX=0.0_dp
    FY=0.0_dp
    FX_X=0.0_dp
    FX_Y=0.0_dp
    FY_X=0.0_dp
    FY_Y=0.0_dp

    RX=1.0_dp
    IX=0.0_dp

    !   RX=X(1)
    !   IX=X(3)

    DO J=1,MIN(EL%NMUL,HIGHEST_FRINGE)
       DRX=  RX
       DIX=  IX
       RX =  DRX*X(1)-DIX*X(3)
       IX =  DRX*X(3)+DIX*X(1)    ! COMPUTING (X+IY)**J

       IF(J==1.AND.EL%BEND_FRINGE) THEN
          U =     -  AN(J)*IX
          V =     +  AN(J)*RX
          DU =    -  AN(J)*DIX
          DV =    +  AN(J)*DRX
       ELSE
          U =   BN(J)*RX   -  AN(J)*IX
          V =   BN(J)*IX   +  AN(J)*RX
          DU =  BN(J)*DRX  -  AN(J)*DIX
          DV =  BN(J)*DIX  +  AN(J)*DRX
       ENDIF

       U  = (-I/4.0_dp/(J+1))*U
       V  = (-I/4.0_dp/(J+1))*V
       DU = (-I/4.0_dp/(J+1))*DU
       DV = (-I/4.0_dp/(J+1))*DV

       DUX = J*DU
       DVX = J*DV
       DUY =-J*DV
       DVY = J*DU

       NF= REAL(J+2,kind=DP)/ REAL(J,kind=DP)

       FX=FX+( U*X(1) + NF*V*X(3))
       FY=FY+( U*X(3) - NF*V*X(1))

       FX_X=FX_X+ (DUX*X(1)+U+NF*X(3)*DVX)
       FX_Y=FX_Y+ (DUY*X(1)+NF*V+NF*X(3)*DVY)

       FY_X=FY_X+ (DUX*X(3)-NF*V-NF*X(1)*DVX)
       FY_Y=FY_Y+ (DUY*X(3)+U-NF*X(1)*DVY)

    ENDDO

    if(k%TIME) then
       del=1.0_dp/ROOT(1.0_dp+2.0_dp*X(5)/el%beta0+x(5)**2)
    else
       DEL=1.0_dp/(1.0_dp+X(5))
    endif




    A=1.0_dp-FX_X*DEL
    B=-FY_X*DEL
    D=1.0_dp-FY_Y*DEL
    C=-FX_Y*DEL

    X(1)=X(1)-FX*DEL
    X2=(D*X(2)-B*X(4))/(A*D-B*C)
    X(4)=(A*X(4)-C*X(2))/(A*D-B*C)
    X(2)=X2
    X(3)=X(3)-FY*DEL
    if(k%TIME) then
       X(6)=X(6)-(1.0_dp/el%beta0+x(5))*(X(2)*FX+X(4)*FY)*DEL**3
    else
       X(6)=X(6)-(X(2)*FX+X(4)*FY)*DEL**2
    endif
    !    CALL CHECK_STABILITY(X)
    call check_root_drift(el,X,k)
  END SUBROUTINE MULTIPOLE_FRINGER

  SUBROUTINE MULTIPOLE_FRINGEP(EL,AN,BN,K1,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN),dimension(:)::AN,BN
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    INTEGER, INTENT(IN) :: K1
    INTEGER J
    TYPE(REAL_8) A,B,C,D,DEL,X2
    TYPE(REAL_8) RX,IX,DRX,DIX,U,V,DU,DV
    TYPE(REAL_8) DUX,DUY,DVX,DVY,FX_X,FX_Y,FY_X,FY_Y,FX,FY
    REAL(DP) NF
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) i



    IF(EL%NMUL<=1) RETURN

    IF(K1==1.AND.EL%KILL_ENT_FRINGE) RETURN
    IF(K1==2.AND.EL%KILL_EXI_FRINGE) RETURN

    CALL ALLOC(DUX,DUY,DVX,DVY,FX_X,FX_Y,FY_X,FY_Y,FX,FY)
    CALL ALLOC(RX,IX,DRX,DIX,U,V,DU,DV)
    CALL ALLOC(A,B,C,D,DEL,X2)

    IF(K1==1) THEN
       I= EL%CHARGE
    ELSE
       I=-EL%CHARGE
    ENDIF

    FX=0.0_dp
    FY=0.0_dp
    FX_X=0.0_dp
    FX_Y=0.0_dp
    FY_X=0.0_dp
    FY_Y=0.0_dp
    RX=1.0_dp
    IX=0.0_dp

    !   RX=X(1)
    !   IX=X(3)

    DO J=1,MIN(EL%NMUL,HIGHEST_FRINGE)
       DRX=  RX
       DIX=  IX
       RX =  DRX*X(1)-DIX*X(3)
       IX =  DRX*X(3)+DIX*X(1)    ! COMPUTING (X+IY)**J

       IF(J==1.AND.EL%BEND_FRINGE) THEN
          U =     -  AN(J)*IX
          V =     +  AN(J)*RX
          DU =    -  AN(J)*DIX
          DV =    +  AN(J)*DRX
       ELSE
          U =   BN(J)*RX   -  AN(J)*IX
          V =   BN(J)*IX   +  AN(J)*RX
          DU =  BN(J)*DRX  -  AN(J)*DIX
          DV =  BN(J)*DIX  +  AN(J)*DRX
       ENDIF

       U  = (-I/4.0_dp/(J+1))*U
       V  = (-I/4.0_dp/(J+1))*V
       DU = (-I/4.0_dp/(J+1))*DU
       DV = (-I/4.0_dp/(J+1))*DV

       DUX = J*DU
       DVX = J*DV
       DUY =-J*DV
       DVY = J*DU

       NF= REAL(J+2,kind=DP)/ REAL(J,kind=DP)

       FX=FX+( U*X(1) + NF*V*X(3))
       FY=FY+( U*X(3) - NF*V*X(1))

       FX_X=FX_X+ (DUX*X(1)+U+NF*X(3)*DVX)
       FX_Y=FX_Y+ (DUY*X(1)+NF*V+NF*X(3)*DVY)

       FY_X=FY_X+ (DUX*X(3)-NF*V-NF*X(1)*DVX)
       FY_Y=FY_Y+ (DUY*X(3)+U-NF*X(1)*DVY)

    ENDDO

    if(k%TIME) then
       del=1.0_dp/SQRT(1.0_dp+2.0_dp*X(5)/el%beta0+x(5)**2)
    else
       DEL=1.0_dp/(1.0_dp+X(5))
    endif




    A=1.0_dp-FX_X*DEL
    B=-FY_X*DEL
    D=1.0_dp-FY_Y*DEL
    C=-FX_Y*DEL

    X(1)=X(1)-FX*DEL
    X2=(D*X(2)-B*X(4))/(A*D-B*C)
    X(4)=(A*X(4)-C*X(2))/(A*D-B*C)
    X(2)=X2
    X(3)=X(3)-FY*DEL
    if(k%TIME) then
       X(6)=X(6)-(1.0_dp/el%beta0+x(5))*(X(2)*FX+X(4)*FY)*DEL**3
    else
       X(6)=X(6)-(X(2)*FX+X(4)*FY)*DEL**2
    endif

    CALL KILL(DUX,DUY,DVX,DVY,FX_X,FX_Y,FY_X,FY_Y,FX,FY)
    CALL KILL(RX,IX,DRX,DIX,U,V,DU,DV)
    CALL KILL(A,B,C,D,DEL,X2)


  END SUBROUTINE MULTIPOLE_FRINGEP

  SUBROUTINE NEWFACER(EL,BN,H,X,k)
    IMPLICIT NONE
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN)::H
    real(dp),INTENT(IN),dimension(:)::BN
    real(dp) XI,PM,DXI_PX,DXI_DDEL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    IF(EL%DIR==1) THEN   ! NOT IMPORTANT; JUST TO INSURE REVERSAL SYMMETRY
       ! HORIZONTAL WEDGE
       X(2)=X(2)+(EL%DIR*EL%CHARGE*BN(1)*H/2.0_dp)*X(1)**2
    ENDIF

    IF(k%TIME) THEN
       PM=ROOT(1.0_dp+2.0_dp*X(5)/el%beta0+x(5)**2-X(2)**2)
       XI=EL%DIR*EL%CHARGE*ROOT(1.0_dp+2.0_dp*X(5)/el%beta0+x(5)**2)*BN(1)*H/PM**2
       DXI_PX=2.0_dp*X(2)/PM**2 * XI
       DXI_DDEL=-2.0_dp*(1.0_dp+X(5))/PM**2 * XI
    ELSE
       PM=ROOT((1.0_dp+X(5))**2-X(2)**2)
       XI=EL%DIR*EL%CHARGE*(1.0_dp+X(5))*BN(1)*H/PM**2
       DXI_PX=2.0_dp*X(2)/PM**2 * XI
       DXI_DDEL=-2.0_dp*(1.0_dp/EL%BETA0+X(5))/PM**2 * XI
    ENDIF

    X(1)=X(1)/(1.0_dp-DXI_PX*X(3)**2)
    X(2)=X(2)-XI*X(3)**2
    X(4)=X(4)-2.0_dp*XI*X(1)*X(3)
    X(6)=X(6)-DXI_DDEL*X(1)*X(3)**2

    IF(EL%DIR==-1) THEN   ! NOT IMPORTANT; JUST TO INSURE REVERSAL SYMMETRY
       ! HORIZONTAL WEDGE
       X(2)=X(2)+(EL%DIR*EL%CHARGE*BN(1)*H/2.0_dp)*X(1)**2
    ENDIF
    !    CALL check_stability(X)
    call check_root_drift(el,X,k)
  END SUBROUTINE NEWFACER

  SUBROUTINE NEWFACEP(EL,BN,H,X,k)
    IMPLICIT NONE
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN)::H
    TYPE(REAL_8),INTENT(IN),dimension(:)::BN
    TYPE(REAL_8) XI,PM,DXI_PX,DXI_DDEL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    CALL ALLOC(XI,PM,DXI_PX,DXI_DDEL)

    IF(EL%DIR==1) THEN   ! NOT IMPORTANT; JUST TO INSURE REVERSAL SYMMETRY
       ! HORIZONTAL WEDGE
       X(2)=X(2)+(EL%DIR*EL%CHARGE*BN(1)*H/2.0_dp)*X(1)**2
    ENDIF

    IF(k%TIME) THEN
       PM=SQRT(1.0_dp+2.0_dp*X(5)/el%beta0+x(5)**2-X(2)**2)
       XI=EL%DIR*EL%CHARGE* SQRT(1.0_dp+2.0_dp*X(5)/el%beta0+x(5)**2)*BN(1)*H/PM**2
       DXI_PX=2.0_dp*X(2)/PM**2 * XI
       DXI_DDEL=-2.0_dp*(1.0_dp+X(5))/PM**2 * XI
    ELSE
       PM=SQRT((1.0_dp+X(5))**2-X(2)**2)
       XI=EL%DIR*EL%CHARGE*(1.0_dp+X(5))*BN(1)*H/PM**2
       DXI_PX=2.0_dp*X(2)/PM**2 * XI
       DXI_DDEL=-2.0_dp*(1.0_dp/EL%BETA0+X(5))/PM**2 * XI
    ENDIF

    X(1)=X(1)/(1.0_dp-DXI_PX*X(3)**2)
    X(2)=X(2)-XI*X(3)**2
    X(4)=X(4)-2.0_dp*XI*X(1)*X(3)
    X(6)=X(6)-DXI_DDEL*X(1)*X(3)**2

    IF(EL%DIR==-1) THEN   ! NOT IMPORTANT; JUST TO INSURE REVERSAL SYMMETRY
       ! HORIZONTAL WEDGE
       X(2)=X(2)+(EL%DIR*EL%CHARGE*BN(1)*H/2.0_dp)*X(1)**2
    ENDIF

    CALL KILL(XI,PM,DXI_PX,DXI_DDEL)


  END SUBROUTINE NEWFACEP

  SUBROUTINE FACER(DIR,BN,H,E,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN)::H,E
    real(dp),INTENT(IN),dimension(:)::BN
    real(dp),INTENT(IN):: DIR
    real(dp) C
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    C=1.0_dp/COS(E)**3

    X(2)=X(2)+(DIR*BN(1)*H/2.0_dp)*X(1)**2
    X(2)=X(2)-(DIR*BN(1)*H*C/2.0_dp)*X(3)**2
    X(4)=X(4)-(DIR*BN(1)*H*C)*X(1)*X(3)

  END SUBROUTINE FACER

  SUBROUTINE FACEP(DIR,BN,H,E,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN)::H
    TYPE(REAL_8),INTENT(IN),dimension(:)::BN
    real(dp),INTENT(IN):: E
    real(dp),INTENT(IN):: DIR
    real(dp) C
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    C=1.0_dp/COS(E)**3

    X(2)=X(2)+(DIR*BN(1)*H/2.0_dp)*X(1)**2
    X(2)=X(2)-(DIR*BN(1)*H*C/2.0_dp)*X(3)**2
    X(4)=X(4)-(DIR*BN(1)*H*C)*X(1)*X(3)

  END SUBROUTINE FACEP

  SUBROUTINE FRINGE_dipoleR(EL,BN,FINT,HGAP,K1,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN)::FINT,HGAP
    real(dp),INTENT(IN),dimension(:)::BN
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    INTEGER, INTENT(IN) :: K1
    real(dp) PZ,XP,YP,TIME_FAC
    real(dp) D(3,3),FI(3),FI0,B,co1,co2
    integer i
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    !    if((.not.el%exact)) then
    !     write(6,*) " Fringer should be called in exact magnets only "
    !     stop 101
    !    endif

    IF(.not.EL%BEND_FRINGE) RETURN
    IF(K1==1.AND.EL%KILL_ENT_FRINGE) RETURN
    IF(K1==2.AND.EL%KILL_EXI_FRINGE) RETURN


    IF(K1==1) THEN
       B=EL%CHARGE*BN(1)
    ELSE
       B=-EL%CHARGE*BN(1)
    ENDIF


    if(k%TIME) then
       PZ=ROOT(1.0_dp+2.0_dp*X(5)/el%beta0+x(5)**2-X(2)**2-X(4)**2)
       TIME_FAC=1.0_dp/el%beta0+X(5)
    else
       PZ=ROOT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
       TIME_FAC=1.0_dp+X(5)
    endif
    XP=X(2)/PZ ; YP=X(4)/PZ;

    D(1,1)=(1.0_dp+XP**2)/PZ
    D(2,1)=XP*YP/PZ
    D(3,1)=-XP
    D(1,2)=XP*YP/PZ
    D(2,2)=(1.0_dp+YP**2)/PZ
    D(3,2)=-YP
    D(1,3)=-TIME_FAC*XP/PZ**2
    D(2,3)=-TIME_FAC*YP/PZ**2
    D(3,3)= TIME_FAC/PZ

    !    FI0=(B*XP/(one+yp**2)-B2* ( ONE + XP**2*(TWO+YP**2) )/PZ)
    !    FI0= arctan((XP/(one+yp**2)))    !-B*FINT*HGAP*two*( ONE + XP**2*(TWO+YP**2) )   *PZ
    FI0= ATAN((XP/(1.0_dp+yp**2)))-B*FINT*HGAP*2.0_dp*( 1.0_dp + XP**2*(2.0_dp+YP**2) )*PZ
    CO2=B/COS(FI0)**2
    CO1=CO2/(1.0_dp+(XP/(1.0_dp+yp**2))**2 )

    FI(1)=CO1/(1.0_dp+yp**2)-CO2*B*FINT*HGAP*2.0_dp*( 2.0_dp*XP*(2.0_dp+YP**2)*PZ )
    FI(2)=-CO1*2.0_dp*XP*YP/(1.0_dp+yp**2)**2-CO2*B*FINT*HGAP*2.0_dp*( 2.0_dp*XP**2*YP)*PZ
    FI(3)=-CO2*B*FINT*HGAP*2.0_dp*( 1.0_dp + XP**2*(2.0_dp+YP**2) )

    FI0=B*TAN(FI0)


    !       X(4)=X(4)-TAN(EL%EDGE(I)-EL%DIR*EL%CHARGE*two*FINT*HGAP*(ONE+SIN(EL%EDGE(I))**2)*BN(1)/COS(EL%EDGE(I))) &
    !       & *EL%DIR*EL%CHARGE*BN(1)*X(3)   ! SECTOR WEDGE (PROT) + FRINGE

    B=0.0_dp
    DO i=1,3
       B=FI(I)*D(I,2)+B
    ENDDO
    X(3)=2.0_dp*X(3)/(1.0_dp+ sqrt(1.0_dp-2.0_dp*B*X(3)) )
    X(4)=X(4)-FI0*X(3)

    B=0.0_dp
    DO i=1,3
       B=FI(I)*D(I,1)+B
    ENDDO
    X(1)=X(1)+0.5_dp*B*X(3)**2

    B=0.0_dp
    DO i=1,3
       B=FI(I)*D(I,3)+B
    ENDDO
    X(6)=X(6)-0.5_dp*B*X(3)**2
    !    CALL check_stability(X)
    call check_root_drift(el,X,k)
  END SUBROUTINE FRINGE_dipoleR


  SUBROUTINE FRINGE_dipoleP(EL,BN,FINT,HGAP,K1,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN)::FINT,HGAP
    TYPE(REAL_8),INTENT(IN),dimension(:)::BN
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    INTEGER, INTENT(IN) :: K1
    TYPE(REAL_8) PZ,XP,YP,TIME_FAC,FI0,B
    TYPE(REAL_8) D(3,3),FI(3),CO1,CO2
    integer i,J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    ! etienne

    !    if((.not.el%exact)) then
    !     write(6,*) " Fringep should be called in exact magnets only "
    !     stop 102
    !    endif


    IF(.not.EL%BEND_FRINGE) RETURN
    IF(K1==1.AND.EL%KILL_ENT_FRINGE) RETURN
    IF(K1==2.AND.EL%KILL_EXI_FRINGE) RETURN

    CALL ALLOC(PZ,XP,YP,TIME_FAC,FI0,B,CO1,CO2)
    DO I=1,3
       CALL ALLOC(FI(I))
       DO J=1,3
          CALL ALLOC(D(I,J))
       ENDDO
    ENDDO

    IF(K1==1) THEN
       B=EL%CHARGE*BN(1)
    ELSE
       B=-EL%CHARGE*BN(1)
    ENDIF




    if(k%TIME) then
       PZ=sqrt(1.0_dp+2.0_dp*X(5)/el%beta0+x(5)**2-X(2)**2-X(4)**2)
       TIME_FAC=1.0_dp/el%beta0+X(5)
    else
       PZ=sqrt((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
       TIME_FAC=1.0_dp+X(5)
    endif
    XP=X(2)/PZ ; YP=X(4)/PZ;

    D(1,1)=(1.0_dp+XP**2)/PZ
    D(2,1)=XP*YP/PZ
    D(3,1)=-XP
    D(1,2)=XP*YP/PZ
    D(2,2)=(1.0_dp+YP**2)/PZ
    D(3,2)=-YP
    D(1,3)=-TIME_FAC*XP/PZ**2
    D(2,3)=-TIME_FAC*YP/PZ**2
    D(3,3)= TIME_FAC/PZ

    !    FI0=(B*XP/(one+yp**2)-B2* ( ONE + XP**2*(TWO+YP**2) )/PZ)
    !    FI0=(XP/(one+yp**2))
    !    FI0= ATAN(FI0)-B*FINT*HGAP*two*( ONE + XP**2*(TWO+YP**2) )*PZ
    FI0= ATAN((XP/(1.0_dp+yp**2)))-B*FINT*HGAP*2.0_dp*( 1.0_dp + XP**2*(2.0_dp+YP**2) )*PZ
    CO2=B/COS(FI0)**2
    CO1=CO2/(1.0_dp+(XP/(1.0_dp+yp**2))**2 )

    FI(1)=CO1/(1.0_dp+yp**2)-CO2*B*FINT*HGAP*2.0_dp*( 2.0_dp*XP*(2.0_dp+YP**2)*PZ )
    FI(2)=-CO1*2.0_dp*XP*YP/(1.0_dp+yp**2)**2-CO2*B*FINT*HGAP*2.0_dp*( 2.0_dp*XP**2*YP)*PZ
    FI(3)=-CO2*B*FINT*HGAP*2.0_dp*( 1.0_dp + XP**2*(2.0_dp+YP**2) )

    FI0=B*TAN(FI0)


    !       X(4)=X(4)-TAN(EL%EDGE(I)-EL%DIR*EL%CHARGE*two*FINT*HGAP*(ONE+SIN(EL%EDGE(I))**2)*BN(1)/COS(EL%EDGE(I))) &
    !       & *EL%DIR*EL%CHARGE*BN(1)*X(3)   ! SECTOR WEDGE (PROT) + FRINGE

    B=0.0_dp
    DO i=1,3
       B=FI(I)*D(I,2)+B
    ENDDO
    X(3)=2.0_dp*X(3)/(1.0_dp+ sqrt(1.0_dp-2.0_dp*B*X(3)) )
    X(4)=X(4)-FI0*X(3)

    B=0.0_dp
    DO i=1,3
       B=FI(I)*D(I,1)+B
    ENDDO
    X(1)=X(1)+0.5_dp*B*X(3)**2

    B=0.0_dp
    DO i=1,3
       B=FI(I)*D(I,3)+B
    ENDDO
    X(6)=X(6)-0.5_dp*B*X(3)**2


    CALL KILL(PZ,XP,YP,TIME_FAC,FI0,B,CO1,CO2)
    DO I=1,3
       CALL KILL(FI(I))
       DO J=1,3
          CALL KILL(D(I,J))
       ENDDO
    ENDDO

  END SUBROUTINE FRINGE_dipoleP

  SUBROUTINE FRINGE2SOLR(EL,BSOL,FINT,HGAP,K1,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN)::FINT,HGAP
    INTEGER, INTENT(IN) :: K1
    real(dp),INTENT(IN) :: BSOL
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    real(dp) PZ,TIME_FAC
    real(dp) B

    TYPE(INTERNAL_STATE) k

    IF(K1==1.AND.EL%KILL_ENT_FRINGE) RETURN
    IF(K1==2.AND.EL%KILL_EXI_FRINGE) RETURN

    if(k%TIME) then
       PZ=ROOT(1.0_dp+2.0_dp*X(5)/el%beta0+x(5)**2)
       TIME_FAC=(1.0_dp/el%beta0+X(5))/PZ
    else
       PZ=1.0_dp+X(5)
       TIME_FAC=1.0_dp
    endif

    B=BSOL**2*FINT*HGAP

    X(2)=X(2)+X(1)*B/PZ
    X(4)=X(4)+X(3)*B/PZ

    X(6)=X(6)-0.5_dp*B*(X(1)**2+X(3)**2)*TIME_FAC/PZ**2

  END SUBROUTINE FRINGE2SOLR

  SUBROUTINE FRINGE2SOLP(EL,BSOL,FINT,HGAP,K1,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN)::FINT,HGAP
    INTEGER, INTENT(IN) :: K1
    TYPE(REAL_8),INTENT(IN) :: BSOL
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    TYPE(REAL_8) PZ,TIME_FAC
    TYPE(REAL_8) B

    TYPE(INTERNAL_STATE) k

    CALL ALLOC(PZ,TIME_FAC,B)


    IF(K1==1.AND.EL%KILL_ENT_FRINGE) RETURN
    IF(K1==2.AND.EL%KILL_EXI_FRINGE) RETURN

    if(k%TIME) then
       PZ=SQRT(1.0_dp+2.0_dp*X(5)/el%beta0+x(5)**2)
       TIME_FAC=(1.0_dp/el%beta0+X(5))/PZ
    else
       PZ=1.0_dp+X(5)
       TIME_FAC=1.0_dp
    endif

    B=BSOL**2*FINT*HGAP

    X(2)=X(2)+X(1)*B/PZ
    X(4)=X(4)+X(3)*B/PZ

    X(6)=X(6)-0.5_dp*B*(X(1)**2+X(3)**2)*TIME_FAC/PZ**2

    CALL KILL(PZ,TIME_FAC,B)

  END SUBROUTINE FRINGE2SOLP


  SUBROUTINE EDGE_TRUE_PARALLELR(EL,BN,H1,H2,FINT,HGAP,I,X,k)
    IMPLICIT NONE
    logical(lp) :: doneitt=.true.
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN)::FINT,HGAP,H1,H2
    real(dp),INTENT(IN),dimension(:)::BN
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    INTEGER, INTENT(IN) :: I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(EL%EXACT) THEN
       IF(EL%DIR==1) THEN
          IF(I==1) then                !doubling entrance angle if first half  (1/2 magnet for designer)
             call ROT_XZ(EL%EDGE(1),X,EL%BETA0,DONEITT,k%TIME)
             CALL FACE(EL,BN,H1,X,k)
          endif
          CALL FRINGE_dipole(EL,BN,FINT,HGAP,I,X,k)
          IF(I==2) then                !doubling exit angle if second half
             CALL FACE(EL,BN,H2,X,k)
             x(1)=x(1)+EL%LC*SIN((EL%EDGE(2)-EL%EDGE(1))*0.5_dp)
             call ROT_XZ(EL%EDGE(2),X,EL%BETA0,DONEITT,k%TIME)
          endif
       ELSE
          IF(I==2) then                !doubling exit angle if second half
             call ROT_XZ(EL%EDGE(2),X,EL%BETA0,DONEITT,k%TIME)
             x(1)=x(1)+EL%DIR*EL%LC*SIN((EL%EDGE(2)-EL%EDGE(1))*0.5_dp)
             CALL FACE(EL,BN,H2,X,k)
          endif
          CALL FRINGE_dipole(EL,BN,FINT,HGAP,I,X,k)
          IF(I==1) then                !doubling entrance angle if first half  (1/2 magnet for designer)
             CALL FACE(EL,BN,H1,X,k)
             call ROT_XZ(EL%EDGE(1),X,EL%BETA0,DONEITT,k%TIME)
          endif
       ENDIF

    ELSE
       WRITE(6,*) "ERROR 777"
       STOP 777
    ENDIF

  END SUBROUTINE EDGE_TRUE_PARALLELR

  SUBROUTINE EDGE_TRUE_PARALLELP(EL,BN,H1,H2,FINT,HGAP,I,X,k)
    IMPLICIT NONE
    logical(lp) :: doneitt=.true.
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN)::FINT,HGAP,H1,H2
    TYPE(REAL_8),INTENT(IN),dimension(:)::BN
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    INTEGER, INTENT(IN) :: I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(EL%EXACT) THEN
       IF(EL%DIR==1) THEN
          IF(I==1) then                !doubling entrance angle if first half  (1/2 magnet for designer)
             call ROT_XZ(EL%EDGE(1),X,EL%BETA0,DONEITT,k%TIME)
             CALL FACE(EL,BN,H1,X,k)
          endif
          CALL FRINGE_dipole(EL,BN,FINT,HGAP,I,X,k)
          IF(I==2) then                !doubling exit angle if second half
             CALL FACE(EL,BN,H2,X,k)
             x(1)=x(1)+EL%LC*SIN((EL%EDGE(2)-EL%EDGE(1))*0.5_dp)
             call ROT_XZ(EL%EDGE(2),X,EL%BETA0,DONEITT,k%TIME)
          endif
       ELSE
          IF(I==2) then                !doubling exit angle if second half
             call ROT_XZ(EL%EDGE(2),X,EL%BETA0,DONEITT,k%TIME)
             x(1)=x(1)+EL%DIR*EL%LC*SIN((EL%EDGE(2)-EL%EDGE(1))*0.5_dp)
             CALL FACE(EL,BN,H2,X,k)
          endif
          CALL FRINGE_dipole(EL,BN,FINT,HGAP,I,X,k)
          IF(I==1) then                !doubling entrance angle if first half  (1/2 magnet for designer)
             CALL FACE(EL,BN,H1,X,k)
             call ROT_XZ(EL%EDGE(1),X,EL%BETA0,DONEITT,k%TIME)
          endif
       ENDIF
    ELSE
       WRITE(6,*) "ERROR 778"
       STOP 778

    ENDIF


  END SUBROUTINE EDGE_TRUE_PARALLELP

  SUBROUTINE EDGER(EL,BN,H1,H2,FINT,HGAP,I,X,k)
    IMPLICIT NONE
    logical(lp) :: doneitt=.true.
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN)::FINT,HGAP,H1,H2
    real(dp),INTENT(IN),dimension(:)::BN
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    INTEGER, INTENT(IN) :: I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(EL%EXACT) THEN
       IF(EL%DIR==1) THEN
          IF(I==1) then                !doubling entrance angle if first half  (1/2 magnet for designer)
             call ROT_XZ(EL%EDGE(1),X,EL%BETA0,DONEITT,k%TIME)
             CALL FACE(EL,BN,H1,X,k)
          endif
          CALL FRINGE_dipole(EL,BN,FINT,HGAP,I,X,k)
          IF(I==2) then                !doubling exit angle if second half
             CALL FACE(EL,BN,H2,X,k)
             x(1)=x(1)+EL%LC*SIN((EL%EDGE(2)-EL%EDGE(1))*0.5_dp)
             call ROT_XZ(EL%EDGE(2),X,EL%BETA0,DONEITT,k%TIME)
          endif
       ELSE
          IF(I==2) then                !doubling exit angle if second half
             call ROT_XZ(EL%EDGE(2),X,EL%BETA0,DONEITT,k%TIME)
             x(1)=x(1)+EL%DIR*EL%LC*SIN((EL%EDGE(2)-EL%EDGE(1))*0.5_dp)
             CALL FACE(EL,BN,H2,X,k)
          endif
          CALL FRINGE_dipole(EL,BN,FINT,HGAP,I,X,k)
          IF(I==1) then                !doubling entrance angle if first half  (1/2 magnet for designer)
             CALL FACE(EL,BN,H1,X,k)
             call ROT_XZ(EL%EDGE(1),X,EL%BETA0,DONEITT,k%TIME)
          endif
       ENDIF
    ELSE

       IF(EL%DIR==1) THEN
          IF(I==2) CALL FACE(EL%DIR*EL%CHARGE,BN,H2,EL%EDGE(2),X,k)
       ELSE
          IF(I==1) then
           CALL FACE(EL%DIR*EL%CHARGE,BN,H1,EL%EDGE(1),X,k)
           if(almost_exact.and.i==1.AND.el%b0/=0.0_dp) then
            x(1)=x(1)+EL%CHARGE*BN(1)*X(3)**2/cos(EL%EDGE(I))**3/2.0_dp
            x(4)=x(4)-EL%CHARGE*BN(1)*X(2)*X(3)/cos(EL%EDGE(I))**3
           if(k%time) then
           else  !  px_0=-sin(EL%EDGE(I)) at exit -sign cancels
            x(4)=x(4)+EL%CHARGE*BN(1)*X(5)*X(3)*sin(EL%EDGE(I))/cos(EL%EDGE(I))**3
            x(6)=x(6)+EL%CHARGE*BN(1)*X(3)**2*sin(EL%EDGE(I))/cos(EL%EDGE(I))**3           
           endif
            
           endif
          ENDIF
       ENDIF

       if(el%b0/=0.0_dp) then
                
          X(2)=X(2)+TAN(EL%EDGE(I))*EL%DIR*EL%CHARGE*BN(1)*X(1)   ! SECTOR WEDGE

          IF(EL%BEND_FRINGE.and.(.NOT.((I==1.AND.EL%KILL_ENT_FRINGE).OR.(I==2.AND.EL%KILL_EXI_FRINGE)))) THEN

             X(4)=X(4)-TAN(EL%EDGE(I)-EL%DIR*EL%CHARGE*2.0_dp*FINT*HGAP*(1.0_dp+SIN(EL%EDGE(I))**2)*BN(1)/COS(EL%EDGE(I))) &
                  & *EL%DIR*EL%CHARGE*BN(1)*X(3)   ! SECTOR WEDGE (PROT) + FRINGE
          ENDIF

       else
          IF(EL%BEND_FRINGE.and.(.NOT.((I==1.AND.EL%KILL_ENT_FRINGE).OR.(I==2.AND.EL%KILL_EXI_FRINGE)))) THEN
             CALL FRINGE_dipole(EL,BN,FINT,HGAP,I,X,k)
          endif
       endif

       IF(EL%DIR==1) THEN
          IF(I==1) CALL FACE(EL%DIR*EL%CHARGE,BN,H1,EL%EDGE(1),X,k)
       ELSE
          IF(I==2) THEN 
           if(almost_exact.and.i==1.AND.el%b0/=0.0_dp) then
           if(k%time) then
           else  !  px_0=-sin(EL%EDGE(I)) at exit -sign cancels
            x(4)=x(4)+EL%CHARGE*BN(1)*X(5)*X(3)*sin(EL%EDGE(I))/cos(EL%EDGE(I))**3
            x(6)=x(6)+EL%CHARGE*BN(1)*X(3)**2*sin(EL%EDGE(I))/cos(EL%EDGE(I))**3           
           endif
           
            x(1)=x(1)-EL%CHARGE*BN(1)*X(3)**2/cos(EL%EDGE(I))**3/2.0_dp
            x(4)=x(4)+EL%CHARGE*BN(1)*X(2)*X(3)/cos(EL%EDGE(I))**3
           endif
           CALL FACE(EL%DIR*EL%CHARGE,BN,H2,EL%EDGE(2),X,k)
          ENDIF

        ENDIF
    ENDIF

  END SUBROUTINE EDGER

  SUBROUTINE EDGEP(EL,BN,H1,H2,FINT,HGAP,I,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN)::FINT,HGAP,H1,H2
    TYPE(REAL_8),INTENT(IN),dimension(:)::BN
    TYPE(MAGNET_CHART),INTENT(IN):: EL
    INTEGER, INTENT(IN) :: I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(EL%EXACT) THEN
       IF(EL%DIR==1) THEN
          IF(I==1) then                !doubling entrance angle if first half  (1/2 magnet for designer)
             !   call ROT_XZ(EL%EDGE(1),X,EL%BETA0,DONEITT,k%TIME)       !DONE IN TRUE_PARALLEL ROUTINE!!!!!
             CALL FACE(EL,BN,H1,X,k)
          endif
          CALL FRINGE_dipole(EL,BN,FINT,HGAP,I,X,k)
          IF(I==2) then                !doubling exit angle if second half
             CALL FACE(EL,BN,H2,X,k)
             !   x(1)=x(1)+EL%LC*SIN((EL%EDGE(2)-EL%EDGE(1))*half)
             !   call ROT_XZ(EL%EDGE(2),X,EL%BETA0,DONEITT,k%TIME)
          endif
       ELSE
          IF(I==2) then                !doubling exit angle if second half
             !   call ROT_XZ(EL%EDGE(2),X,EL%BETA0,DONEITT,k%TIME)
             !   x(1)=x(1)+EL%DIR*EL%LC*SIN((EL%EDGE(2)-EL%EDGE(1))*half)
             CALL FACE(EL,BN,H2,X,k)
          endif
          CALL FRINGE_dipole(EL,BN,FINT,HGAP,I,X,k)
          IF(I==1) then                !doubling entrance angle if first half  (1/2 magnet for designer)
             CALL FACE(EL,BN,H1,X,k)
             !   call ROT_XZ(EL%EDGE(1),X,EL%BETA0,DONEITT,k%TIME)
          endif
       ENDIF
    ELSE

       IF(EL%DIR==1) THEN
          IF(I==2) CALL FACE(EL%DIR*EL%CHARGE,BN,H2,EL%EDGE(2),X,k)
       ELSE
          IF(I==1) then
           CALL FACE(EL%DIR*EL%CHARGE,BN,H1,EL%EDGE(1),X,k)
           if(almost_exact.and.i==1.AND.el%b0/=0.0_dp) then
            x(1)=x(1)+EL%CHARGE*BN(1)*X(3)**2/cos(EL%EDGE(I))**3/2.0_dp
            x(4)=x(4)-EL%CHARGE*BN(1)*X(2)*X(3)/cos(EL%EDGE(I))**3
    !       if(k%time) then
    !       else  !  px_0=-sin(EL%EDGE(I)) at exit -sign cancels
    !        x(4)=x(4)+EL%CHARGE*BN(1)*X(5)*X(3)*sin(EL%EDGE(I))/cos(EL%EDGE(I))**3
    !        x(6)=x(6)+EL%CHARGE*BN(1)*X(3)**2*sin(EL%EDGE(I))/cos(EL%EDGE(I))**3           
    !       endif
            
           endif
          ENDIF
       ENDIF

       if(el%b0/=0.0_dp) then
          X(2)=X(2)+TAN(EL%EDGE(I))*EL%DIR*EL%CHARGE*BN(1)*X(1)   ! SECTOR WEDGE

          IF(EL%BEND_FRINGE.and.(.NOT.((I==1.AND.EL%KILL_ENT_FRINGE).OR.(I==2.AND.EL%KILL_EXI_FRINGE)))) THEN

             X(4)=X(4)-TAN(EL%EDGE(I)-EL%DIR*EL%CHARGE*2.0_dp*FINT*HGAP*(1.0_dp+SIN(EL%EDGE(I))**2)*BN(1)/COS(EL%EDGE(I))) &
                  & *EL%DIR*EL%CHARGE*BN(1)*X(3)   ! SECTOR WEDGE (PROT) + FRINGE
          ENDIF

       else
          IF(EL%BEND_FRINGE.and.(.NOT.((I==1.AND.EL%KILL_ENT_FRINGE).OR.(I==2.AND.EL%KILL_EXI_FRINGE)))) THEN
             CALL FRINGE_dipole(EL,BN,FINT,HGAP,I,X,k)
          endif
       endif


       IF(EL%DIR==1) THEN
          IF(I==1) CALL FACE(EL%DIR*EL%CHARGE,BN,H1,EL%EDGE(1),X,k)
       ELSE
          IF(I==2) THEN 
           if(almost_exact.and.i==1.AND.el%b0/=0.0_dp) then
           if(k%time) then
           else  !  px_0=-sin(EL%EDGE(I)) at exit -sign cancels
            x(4)=x(4)+EL%CHARGE*BN(1)*X(5)*X(3)*sin(EL%EDGE(I))/cos(EL%EDGE(I))**3
            x(6)=x(6)+EL%CHARGE*BN(1)*X(3)**2*sin(EL%EDGE(I))/cos(EL%EDGE(I))**3           
           endif
           
            x(1)=x(1)-EL%CHARGE*BN(1)*X(3)**2/cos(EL%EDGE(I))**3/2.0_dp
            x(4)=x(4)+EL%CHARGE*BN(1)*X(2)*X(3)/cos(EL%EDGE(I))**3
           endif
           CALL FACE(EL%DIR*EL%CHARGE,BN,H2,EL%EDGE(2),X,k)
          ENDIF
       ENDIF



    ENDIF


  END SUBROUTINE EDGEP

  SUBROUTINE KICKR(EL,YL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(DKD2),INTENT(IN):: EL
    real(dp),INTENT(IN):: YL
    real(dp) X1,X3,X5,BBYTW,BBXTW,BBYTWT
    INTEGER J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir


    DIR=EL%P%DIR*EL%P%CHARGE

    X1=X(1)
    X3=X(3)

    if(k%TIME) then
       X5=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)-1.0_dp
    else
       X5=X(5)
    endif

    IF(EL%P%NMUL>=1) THEN
       BBYTW=EL%BN(EL%P%NMUL)
       BBXTW=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF


    IF(EL%P%EXACT) THEN
       X(2)=X(2)-YL*DIR*BBYTW
       X(4)=X(4)+YL*DIR*BBXTW
    ELSE
       !  for sixtrack comparison
       !          X(2)=X(2)-EL%thin_h_foc*x1*HALF +EL%P%DIR*EL%P%CHARGE*EL%thin_h_angle*(PZ-one)*HALF  ! highly illegal additions by frs
       !          X(4)=X(4)-EL%thin_v_foc*x3*HALF +EL%P%DIR*EL%P%CHARGE*EL%thin_v_angle*(PZ-one)*HALF  ! highly illegal additions by frs
       !          X(6)=X(6)+EL%P%DIR*EL%P%CHARGE*(EL%thin_h_angle*x1+EL%thin_v_angle*x3)*(one/EL%P%BETA0+x(5))/pz*HALF
       X(2)=X(2)-YL*(DIR*BBYTW-EL%P%B0-(X5-X1*DIR*EL%BN(1))*EL%P%B0)
       X(4)=X(4)+YL* DIR*BBXTW

       if(k%TIME) then
          X(6)=X(6)+YL*EL%P%B0*X1*(1.0_dp/EL%P%beta0+x(5))/(1.0_dp+X5)
       else
          X(6)=X(6)+YL*EL%P%B0*X1
       endif
    ENDIF

    !outvalishev    if(valishev.and.ABS(el%VS)>eps)   then  !valishev
    !outvalishev     call elliptical_b(el%VA,el%VS,x,BBXTW,BBYTW) !valishev
    !outvalishev       X(2)=X(2)-YL*DIR*BBYTW !valishev
    !outvalishev       X(4)=X(4)+YL* DIR*BBXTW !valishev
    !outvalishev    endif !valishev

  END SUBROUTINE KICKR

  SUBROUTINE KICKP(EL,YL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(DKD2P),INTENT(IN):: EL
    TYPE(REAL_8),INTENT(IN):: YL
    TYPE(REAL_8) X1,X3,X5,BBYTW,BBXTW,BBYTWT
    INTEGER J,DIR
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    CALL ALLOC(X1)
    CALL ALLOC(X3)
    CALL ALLOC(X5)
    CALL ALLOC(BBYTW)
    CALL ALLOC(BBXTW)
    CALL ALLOC(BBYTWT)

    DIR=EL%P%DIR*EL%P%CHARGE
    X1=X(1)
    X3=X(3)

    if(k%TIME) then
       X5=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)-1.0_dp
    else
       X5=X(5)
    endif

    IF(EL%P%NMUL>=1) THEN
       BBYTW=EL%BN(EL%P%NMUL)
       BBXTW=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF


    IF(EL%P%EXACT) THEN
       X(2)=X(2)-YL*DIR*BBYTW
       X(4)=X(4)+YL*DIR*BBXTW
    ELSE
       X(2)=X(2)-YL*(DIR*BBYTW-EL%P%B0-(X5-X1*DIR*EL%BN(1))*EL%P%B0)
       X(4)=X(4)+YL* DIR*BBXTW

       if(k%TIME) then
          X(6)=X(6)+YL*EL%P%B0*X1*(1.0_dp/EL%P%beta0+x(5))/(1.0_dp+X5)
       else
          X(6)=X(6)+YL*EL%P%B0*X1
       endif
    ENDIF

    !outvalishev    if(valishev.and.ABS(el%VS)>eps)   then  !valishev
    !outvalishev     call elliptical_b(el%VA,el%VS,x,BBXTW,BBYTW) !valishev
    !outvalishev       X(2)=X(2)-YL*DIR*BBYTW !valishev
    !outvalishev       X(4)=X(4)+YL* DIR*BBXTW !valishev
    !outvalishev    endif !valishev


    CALL KILL(X1)
    CALL KILL(X3)
    CALL KILL(X5)
    CALL KILL(BBYTW)
    CALL KILL(BBXTW)
    CALL KILL(BBYTWT)

  END SUBROUTINE KICKP

  SUBROUTINE INTER_dkd2 (EL,X,k,pos)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(DKD2),INTENT(IN):: EL
    INTEGER pos
    real(dp) D,DH,DD
    real(dp) D1,D2,DK1,DK2
    real(dp) DD1,DD2
    real(dp) DF(4),DK(4),DDF(4)
    INTEGER I,J,f1
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    SELECT CASE(EL%P%METHOD)
    CASE(1)
       if(EL%F==1) then
          f1=0
       else
          f1=EL%F+1
       endif
       DH=EL%L/EL%P%NST
       D=EL%L/(EL%P%NST/EL%F/2)
       DD=EL%P%LD/EL%P%NST

       IF(MOD(POS,2*EL%F)==f1) THEN
          CALL KICK (EL,D,X,k)
       ENDIF
       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)

    CASE(2)
       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       DD=EL%P%LD/2.0_dp/EL%P%NST




       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICK (EL,D,X,k)
       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)



    CASE(4)
       D1=EL%L*FD1/EL%P%NST
       D2=EL%L*FD2/EL%P%NST
       DD1=EL%P%LD*FD1/EL%P%NST
       DD2=EL%P%LD*FD2/EL%P%NST
       DK1=EL%L*FK1/EL%P%NST
       DK2=EL%L*FK2/EL%P%NST




       CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICK (EL,DK1,X,k)
       CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICK (EL,DK2,X,k)

       CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICK (EL,DK1,X,k)
       CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)



    CASE(6)
       DO I =1,4
          DF(I)=EL%L*YOSD(I)/EL%P%NST
          DDF(I)=EL%P%LD*YOSD(I)/EL%P%NST
          DK(I)=EL%L*YOSK(I)/EL%P%NST
       ENDDO

       !       DO I=1,B%N

       !        X=BEAM_IN_X(B,I)

       DO J=4,2,-1
          CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICK (EL,DK(J),X,k)
       ENDDO
       CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICK (EL,DK(1),X,k)

       CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       DO J=2,4
          CALL KICK (EL,DK(J),X,k)
          CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       ENDDO




    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

  END SUBROUTINE INTER_dkd2

  SUBROUTINE INTEP_dkd2 (EL,X,k,pos)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(DKD2P),INTENT(IN):: EL

    real(dp) DD
    real(dp) DD1,DD2
    real(dp) DDF(4)
    TYPE(REAL_8) DH,D,D1,D2,DK1,DK2,DF(4),DK(4)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    INTEGER I,J,pos,f1

    SELECT CASE(EL%P%METHOD)

    CASE(1)
       if(EL%F==1) then
          f1=0
       else
          f1=EL%F+1
       endif
       CALL ALLOC(DH,D)
       DH=EL%L/EL%P%NST
       D=EL%L/(EL%P%NST/EL%F/2)
       DD=EL%P%LD/EL%P%NST

       IF(MOD(POS,2*EL%F)==f1) THEN
          CALL KICK (EL,D,X,k)
       ENDIF
       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KILL(DH,D)

    CASE(2)
       CALL ALLOC(DH,D)
       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       DD=EL%P%LD/2.0_dp/EL%P%NST

       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICK (EL,D,X,k)
       CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)

       CALL KILL(DH,D)

    CASE(4)
       CALL ALLOC(D1,D2,DK1,DK2)
       D1=EL%L*FD1/EL%P%NST
       D2=EL%L*FD2/EL%P%NST
       DD1=EL%P%LD*FD1/EL%P%NST
       DD2=EL%P%LD*FD2/EL%P%NST
       DK1=EL%L*FK1/EL%P%NST
       DK2=EL%L*FK2/EL%P%NST



       CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICK (EL,DK1,X,k)
       CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICK (EL,DK2,X,k)

       CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICK (EL,DK1,X,k)
       CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)

       CALL KILL(D1,D2,DK1,DK2)


    CASE(6)
       CALL ALLOC(DF,4);CALL ALLOC(DK,4);
       DO I =1,4
          DF(I)=EL%L*YOSD(I)/EL%P%NST
          DDF(I)=EL%P%LD*YOSD(I)/EL%P%NST
          DK(I)=EL%L*YOSK(I)/EL%P%NST
       ENDDO

       !       DO I=1,B%N

       !        X=BEAM_IN_X(B,I)

       DO J=4,2,-1
          CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICK (EL,DK(J),X,k)
       ENDDO
       CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CALL KICK (EL,DK(1),X,k)

       CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       DO J=2,4
          CALL KICK (EL,DK(J),X,k)
          CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       ENDDO


       CALL KILL(DF,4);CALL KILL(DK,4);


    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

  END SUBROUTINE INTEP_dkd2

  SUBROUTINE INTER(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(DKD2),INTENT(IN):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    DO I=1,EL%P%NST
       IF(.NOT.PRESENT(MID)) CALL TRACK_SLICE(EL,X,k,i)
       IF(PRESENT(MID)) CALL XMID(MID,X,I)
    ENDDO

  END SUBROUTINE INTER





  SUBROUTINE INTEP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: MID
    TYPE(DKD2P),INTENT(IN):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    DO I=1,EL%P%NST
       CALL TRACK_SLICE(EL,X,k,i)
    ENDDO

  END SUBROUTINE INTEP

  SUBROUTINE SYMPINTR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(DKD2),INTENT(IN):: EL
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(.NOT.PRESENT(MID)) CALL TRACK_FRINGE(EL=EL,X=X,k=k,J=1)
    CALL INTE(EL,X,k,MID)
    IF(.NOT.PRESENT(MID)) CALL TRACK_FRINGE(EL=EL,X=X,k=k,J=2)

  END SUBROUTINE SYMPINTR

  SUBROUTINE SYMPINTP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(DKD2P),INTENT(IN):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL TRACK_FRINGE(EL=EL,X=X,k=k,J=1)
    CALL INTE(EL,X,k)
    CALL TRACK_FRINGE(EL=EL,X=X,k=k,J=2)


  END SUBROUTINE SYMPINTP



  SUBROUTINE KICK_SOLR(EL,YL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(SOL5),INTENT(IN):: EL
    real(dp),INTENT(IN):: YL
    real(dp)  bsol,ang,xp,yp,h,c,sh,yh,xt(4),dl
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    integer i



    bsol=EL%B_SOL*EL%P%CHARGE
    xp=x(2)+bsol*x(3)/2.0_dp
    yp=x(4)-bsol*x(1)/2.0_dp

    ! NO EXACT EL%EXACT
    if(EL%p%exact) then
       if(k%TIME) then
          h=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2-xp**2-yp**2)
          dl=1.0_dp
       else
          h=ROOT((1.0_dp+x(5))**2-xp**2-yp**2)
          dl=1.0_dp
       endif
    else
       if(k%TIME) then
          h=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
          dl=1.0_dp+(xp**2+yp**2)/2.0_dp/h**2
       else
          h=1.0_dp+x(5)
          dl=1.0_dp+(xp**2+yp**2)/2.0_dp/h**2
       endif
    endif
    yh=yl/h
    c=cos(yh*bsol/2.0_dp)
    sh=SINX_X(yh*bsol/2.0_dp)

    xt(1)=c*x(1)+yh*sh*x(2)
    xt(2)=c*x(2)-yh*bsol**2*sh*x(1)/4.0_dp
    xt(3)=c*x(3)+yh*sh*x(4)
    xt(4)=c*x(4)-yh*bsol**2*sh*x(3)/4.0_dp

    DO I=1,4
       X(I)=XT(I)
    ENDDO

    ANG=Yh*EL%B_SOL*EL%P%CHARGE/2.0_dp

    c=COS(ANG)
    sh=SIN(ANG)
    ! NO EXACT EL%EXACT

    XT(1)=c*X(1)+sh*X(3)
    XT(2)=c*X(2)+sh*X(4)
    XT(3)=c*X(3)-sh*X(1)
    XT(4)=c*X(4)-sh*X(2)

    DO I=1,4
       X(I)=XT(I)
    ENDDO


    if(k%TIME) then
       x(6)=x(6)+yl*dl*(1.0_dp/EL%P%beta0+X(5))/h-(1-k%totalpath)*yl/EL%P%beta0
    else
       x(6)=x(6)+yl*dl*(1.0_dp+X(5))/h-(1-k%totalpath)*yl
    endif



  END SUBROUTINE KICK_SOLR

  SUBROUTINE KICK_SOLP(EL,YL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(SOL5P),INTENT(IN):: EL
    TYPE(REAL_8),INTENT(IN):: YL
    TYPE(REAL_8)  BSOL,xp,yp,h,yh,xt(4),sh,c,ang,dl
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    integer i

    CALL ALLOC(BSOL,xp,yp,h,yh,sh,c,ang,dl)
    CALL ALLOC(xt,4)

    bsol=EL%B_SOL*EL%P%CHARGE
    xp=x(2)+bsol*x(3)/2.0_dp
    yp=x(4)-bsol*x(1)/2.0_dp

    ! NO EXACT EL%EXACT
    if(EL%p%exact) then
       if(k%TIME) then
          h=sqrt(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2-xp**2-yp**2)
          dl=1.0_dp
       else
          h=sqrt((1.0_dp+x(5))**2-xp**2-yp**2)
          dl=1.0_dp
       endif
    else
       if(k%TIME) then
          h=sqrt(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
          dl=1.0_dp+(xp**2+yp**2)/2.0_dp/h**2
       else
          h=1.0_dp+x(5)
          dl=1.0_dp+(xp**2+yp**2)/2.0_dp/h**2
       endif
    endif
    yh=yl/h
    c=cos(yh*bsol/2.0_dp)
    sh=SINX_X(yh*bsol/2.0_dp)

    xt(1)=c*x(1)+yh*sh*x(2)
    xt(2)=c*x(2)-yh*bsol**2*sh*x(1)/4.0_dp
    xt(3)=c*x(3)+yh*sh*x(4)
    xt(4)=c*x(4)-yh*bsol**2*sh*x(3)/4.0_dp

    DO I=1,4
       X(I)=XT(I)
    ENDDO

    ANG=Yh*EL%B_SOL*EL%P%CHARGE/2.0_dp

    c=COS(ANG)
    sh=SIN(ANG)
    ! NO EXACT EL%EXACT

    XT(1)=c*X(1)+sh*X(3)
    XT(2)=c*X(2)+sh*X(4)
    XT(3)=c*X(3)-sh*X(1)
    XT(4)=c*X(4)-sh*X(2)

    DO I=1,4
       X(I)=XT(I)
    ENDDO


    if(k%TIME) then
       x(6)=x(6)+yl*dl*(1.0_dp/EL%P%beta0+X(5))/h-(1-k%totalpath)*yl/EL%P%beta0
    else
       x(6)=x(6)+yl*dl*(1.0_dp+X(5))/h-(1-k%totalpath)*yl
    endif



    CALL kill(xt,4)
    CALL kill(BSOL,xp,yp,h,yh,sh,c,ang,dl)

  END SUBROUTINE KICK_SOLP

  SUBROUTINE GETMULB_SOLR(EL,B,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6),B(3)
    TYPE(SOL5),INTENT(IN):: EL
    real(dp) X1,X3,BBYTW,BBXTW,BBYTWT
    INTEGER J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    X1=X(1)
    X3=X(3)

    IF(EL%P%NMUL>=1) THEN
       BBYTW=EL%BN(EL%P%NMUL)
       BBXTW=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF
    B(1)=BBXTW;B(2)=BBYTW;B(3)=EL%B_SOL;
    !outvalishev    if(valishev.and.ABS(el%VS)>eps)   then  !valishev
    !outvalishev     call elliptical_b(el%VA,el%VS,x,BBXTW,BBYTW) !valishev
    !outvalishev     B(1)=B(1)+BBXTW; B(2)=B(2)+BBYTW;
    !outvalishev    endif !valishev

  END SUBROUTINE GETMULB_SOLR

  SUBROUTINE GETMULB_SOLP(EL,B,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6),B(3)
    TYPE(SOL5P),INTENT(IN):: EL
    TYPE(REAL_8) X1,X3,BBYTW,BBXTW,BBYTWT
    INTEGER J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(X1,X3,BBYTW,BBXTW,BBYTWT)
    X1=X(1)
    X3=X(3)

    IF(EL%P%NMUL>=1) THEN
       BBYTW=EL%BN(EL%P%NMUL)
       BBXTW=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF
    B(1)=BBXTW;B(2)=BBYTW;B(3)=EL%B_SOL;
    !outvalishev    if(valishev.and.ABS(el%VS)>eps)   then  !valishev
    !outvalishev     call elliptical_b(el%VA,el%VS,x,BBXTW,BBYTW) !valishev
    !outvalishev     B(1)=B(1)+BBXTW; B(2)=B(2)+BBYTW;
    !outvalishev    endif !valishev

    CALL KILL(X1,X3,BBYTW,BBXTW,BBYTWT)

  END SUBROUTINE GETMULB_SOLP

  SUBROUTINE KICKMULR(EL,YL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(SOL5),INTENT(IN):: EL
    real(dp),INTENT(IN):: YL
    real(dp) B(3)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL GETMULB_SOL(EL,B,X,k)

    X(2)=X(2)-YL*EL%P%DIR*EL%P%CHARGE*B(2)
    X(4)=X(4)+YL*EL%P%DIR*EL%P%CHARGE*B(1)

  END SUBROUTINE KICKMULR

  SUBROUTINE KICKMULP(EL,YL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(SOL5P),INTENT(IN):: EL
    TYPE(REAL_8),INTENT(IN):: YL
    TYPE(REAL_8) B(3)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(B,3)

    CALL GETMULB_SOL(EL,B,X,k)

    X(2)=X(2)-YL*EL%P%DIR*EL%P%CHARGE*B(2)
    X(4)=X(4)+YL*EL%P%DIR*EL%P%CHARGE*B(1)

    CALL KILL(B,3)

  END SUBROUTINE KICKMULP




  SUBROUTINE INTER_SOL5(EL,X,k)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) ::  X(6)
    TYPE(SOL5),INTENT(IN):: EL

    real(dp) D,DH,DD
    real(dp) D1,D2,DK1,DK2,D2H
    real(dp) dd1,dd2,DK(4),DF(4),DDF(4)
    INTEGER I,J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K




    SELECT CASE(EL%P%METHOD)
    CASE(2)
       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       DD=(EL%P%LD)/2.0_dp/EL%P%NST


       CALL KICK_SOL(EL,DH,X,k)
       CALL KICKMUL(EL,D,X,k)
       CALL KICK_SOL(EL,DH,X,k)



    CASE(4)

       D=EL%L/EL%P%NST
       D1=D*FD1
       D2=D*FD2
       DK1=D*FK1
       DK2=D*FK2
       D2H=DK2/2.0_dp
       DD1=(EL%P%LD)/EL%P%NST*FD1
       DD2=(EL%P%LD)/EL%P%NST*FD2

       CALL KICK_SOL(EL,D1,X,k)
       CALL KICKMUL(EL,DK1,X,k)
       CALL KICK_SOL(EL,D1,X,k)
       CALL KICK_SOL(EL,D2H,X,k)
       CALL KICKMUL(EL,DK2,X,k)
       CALL KICK_SOL(EL,D2H,X,k)
       CALL KICK_SOL(EL,D1,X,k)
       CALL KICKMUL(EL,DK1,X,k)
       CALL KICK_SOL(EL,D1,X,k)



    CASE(6)
       DO I =1,4
          DK(I)=EL%L*YOSK(I)/EL%P%NST
          DF(I)=DK(I)/2.0_dp
          DDF(I)=EL%P%LD*YOSK(I)/2.0_dp/EL%P%NST
       ENDDO

       !       DO I=1,B%N

       !        X=BEAM_IN_X(B,I)
       DO J=4,1,-1
          CALL KICK_SOL(EL,DF(J),X,k)
          CALL KICKMUL(EL,DK(J),X,k)
          CALL KICK_SOL(EL,DF(J),X,k)
       ENDDO

       DO J=2,4
          CALL KICK_SOL(EL,DF(J),X,k)
          CALL KICKMUL(EL,DK(J),X,k)
          CALL KICK_SOL(EL,DF(J),X,k)
       ENDDO


    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT



  END SUBROUTINE INTER_SOL5

  SUBROUTINE INTEP_SOL5(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) ::  X(6)
    TYPE(SOL5P),INTENT(IN):: EL

    real(dp) DD
    real(dp) DD1,DD2
    real(dp) DDF(4)
    TYPE(REAL_8) DH,D,D1,D2,DK1,DK2,DF(4),DK(4),D2H
    INTEGER I,J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K




    SELECT CASE(EL%P%METHOD)
    CASE(2)
       CALL ALLOC(DH,D)
       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       DD=(EL%P%LD)/2.0_dp/EL%P%NST


       CALL KICK_SOL(EL,DH,X,k)
       CALL KICKMUL(EL,D,X,k)
       CALL KICK_SOL(EL,DH,X,k)
       CALL KILL(DH,D)


    CASE(4)
       CALL ALLOC(D1,D2,DK1,DK2,D2H)

       D=EL%L/EL%P%NST
       D1=D*FD1
       D2=D*FD2
       DK1=D*FK1
       DK2=D*FK2
       D2H=DK2/2.0_dp
       DD1=(EL%P%LD)/EL%P%NST*FD1
       DD2=(EL%P%LD)/EL%P%NST*FD2

       CALL KICK_SOL(EL,D1,X,k)
       CALL KICKMUL(EL,DK1,X,k)
       CALL KICK_SOL(EL,D1,X,k)
       CALL KICK_SOL(EL,D2H,X,k)
       CALL KICKMUL(EL,DK2,X,k)
       CALL KICK_SOL(EL,D2H,X,k)
       CALL KICK_SOL(EL,D1,X,k)
       CALL KICKMUL(EL,DK1,X,k)
       CALL KICK_SOL(EL,D1,X,k)

       CALL KILL(D1,D2,DK1,DK2,D2H)


    CASE(6)
       CALL ALLOC(DF,4);CALL ALLOC(DK,4);
       DO I =1,4
          DK(I)=EL%L*YOSK(I)/EL%P%NST
          DF(I)=DK(I)/2.0_dp
          DDF(I)=EL%P%LD*YOSK(I)/2.0_dp/EL%P%NST
       ENDDO

       !       DO I=1,B%N

       !        X=BEAM_IN_X(B,I)
       DO J=4,1,-1
          CALL KICK_SOL(EL,DF(J),X,k)
          CALL KICKMUL(EL,DK(J),X,k)
          CALL KICK_SOL(EL,DF(J),X,k)
       ENDDO

       DO J=2,4
          CALL KICK_SOL(EL,DF(J),X,k)
          CALL KICKMUL(EL,DK(J),X,k)
          CALL KICK_SOL(EL,DF(J),X,k)
       ENDDO

       CALL KILL(DF,4);CALL KILL(DK,4);

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

  END SUBROUTINE INTEP_SOL5


  SUBROUTINE INTESOLR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: mid
    TYPE(SOL5),INTENT(IN):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    IF(PRESENT(MID)) CALL XMID(MID,X,0)


    DO I=1,EL%P%NST

       IF(.NOT.PRESENT(MID)) CALL TRACK_SLICE(EL,X,k)
       IF(PRESENT(MID)) CALL XMID(MID,X,I)
    ENDDO

  END SUBROUTINE INTESOLR

  SUBROUTINE INTESOLP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(SOL5P),INTENT(IN):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    INTEGER I

    DO I=1,EL%P%NST
       CALL TRACK_SLICE(EL,X,k)
    ENDDO

  END SUBROUTINE INTESOLP

  SUBROUTINE SYMPINTSOLR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(SOL5),INTENT(INOUT):: EL
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: mid
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(.NOT.PRESENT(MID)) CALL TRACK_FRINGE(EL5=EL,X=X,k=k,J=1)
    CALL INTESOL(EL,X,k,MID)
    IF(.NOT.PRESENT(MID)) CALL TRACK_FRINGE(EL5=EL,X=X,k=k,J=2)

  END SUBROUTINE SYMPINTSOLR

  SUBROUTINE SYMPINTSOLP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(SOL5P),INTENT(INOUT):: EL
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: mid
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL TRACK_FRINGE(EL5=EL,X=X,k=k,J=1)
    CALL INTESOL(EL,X,k)
    CALL TRACK_FRINGE(EL5=EL,X=X,k=k,J=2)

  END SUBROUTINE SYMPINTSOLP


!!!! *************************************************************** !!!!
!!!! *           Beginning of the slow thick element               * !!!!
!!!! *************************************************************** !!!!







!!!! *************************************************************** !!!!
!!!! *           Beginning of the slow thick element               * !!!!
!!!! *************************************************************** !!!!

  SUBROUTINE GETMATR(EL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(KTK),INTENT(INOUT):: EL
    real(dp) HX(3,3),HY(3,3),HL(6,6),V(6),W(6)
    real(dp) DH,X5,X6
    INTEGER I,J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE


    IF(EL%P%METHOD==2.AND.OLD_IMPLEMENTATION_OF_SIXTRACK) THEN
       DH=EL%L/EL%P%NST
    ELSE
       IF(EL%P%METHOD/=6) THEN
          DH=EL%L/EL%P%NST/2.0_dp
       ELSE
          DH=EL%L/EL%P%NST/4.0_dp
       ENDIF
    ENDIF

    IF(k%TIME) THEN
       X5=ROOT(1.0_dp+2.0_dp*X(5)/el%P%beta0+x(5)**2)-1
    ELSE
       X5=X(5)
    ENDIF

    HX(1,1)=0.0_dp;HX(1,2)=DH/(1.0_dp+X5);HX(1,3)=0.0_dp;
    HX(2,1)=DIR*DH*(-EL%BN(2)-EL%P%B0*EL%BN(1));HX(2,2)=0.0_dp;HX(2,3)=DH*EL%P%B0;
    HX(3,1)=0.0_dp;HX(3,2)=0.0_dp;HX(3,3)=0.0_dp;
    HY(1,1)=0.0_dp;HY(1,2)=HX(1,2);HY(1,3)=0.0_dp;
    HY(2,1)=DH*DIR*EL%BN(2);HY(2,2)=0.0_dp;HY(2,3)=0.0_dp;
    HY(3,1)=0.0_dp;HY(3,2)=0.0_dp;HY(3,3)=0.0_dp;
    CALL EXPCOSY(HX,EL%MATX)
    CALL EXPCOSY(HY,EL%MATY)
    DO I=1,6
       V(I)=0.0_dp
       DO J=1,6
          HL(I,J)=0.0_dp
       ENDDO
    ENDDO
    HL(1,3)=HX(2,3)*X5; HL(2,3)=HX(2,1); HL(3,2)=HX(1,2);
    HL(4,5)=HX(2,1); HL(6,5)=HX(1,2); HL(2,5)=HX(2,3)*X5;
    HL(5,6)=2.0_dp*HX(2,1); HL(3,6)=2.0_dp*HX(2,3)*X5;HL(5,4)=2.0_dp*HX(1,2);
    V(2)=HX(2,3)
    V(6)=HX(1,2)/(1.0_dp+X5)/2.0_dp;
    CALL EXPCOSY6(HL,V,W)
    do i=1,6
       EL%LX(I)=W(I)
    enddo
    DO I=1,6
       V(I)=0.0_dp
       DO J=1,6
          HL(I,J)=0.0_dp
       ENDDO
    ENDDO
    HL(2,3)=HY(2,1); HL(3,2)=HY(1,2);
    HL(4,5)=HY(2,1); HL(6,5)=HY(1,2)
    HL(5,6)=2.0_dp*HY(2,1);HL(5,4)=2.0_dp*HY(1,2);
    V(6)=HY(1,2)/(1.0_dp+X5)/2.0_dp;
    CALL EXPCOSY6(HL,V,W)

    do i=1,3
       EL%LY(I)=W(3+I)
    enddo


    IF(k%TIME) THEN         ! SPECIAL TIME FACTOR
       X6=(X(5)+2.0_dp/EL%P%beta0)/(2.0_dp+X5)              ! DELTA/E
       X5=(1.0_dp/EL%P%beta0+X(5))/(1.0_dp+X5)     ! dDELTA/dE
       EL%MATX(1,3)=EL%MATX(1,3)*X6
       EL%MATX(2,3)=EL%MATX(2,3)*X6
       do i=1,6
          EL%LX(I)=X5*EL%LX(I)
       enddo
       do i=1,3
          EL%LY(I)=X5*EL%LY(I)
       enddo
       ! BUG FOUND BY SCHMIDT
       !       EL%LX(1)=EL%LX(1)+k%TOTALPATH*DH*X5
       EL%LX(1)=EL%LX(1)+DH*X5-(1-k%TOTALPATH)*DH/EL%P%beta0
    ELSE
       EL%LX(1)=EL%LX(1)+k%TOTALPATH*DH
    ENDIF

  END SUBROUTINE GETMATR

  SUBROUTINE GETMATD(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(KTKP),INTENT(INOUT):: EL
    TYPE(REAL_8) HX(3,3),HY(3,3),HL(6,6),V(6),W(6)
    TYPE(REAL_8) DH,X5,X6
    INTEGER I,J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE

    DO I=1,3
       DO J=1,3
          CALL ALLOC(HX(I,J));CALL ALLOC(HY(I,J))
       ENDDO
    ENDDO
    DO I=1,6
       CALL ALLOC(V(I));CALL ALLOC(W(I))
       DO J=1,6
          CALL ALLOC(HL(I,J))
       ENDDO
    ENDDO
    CALL ALLOC(DH);CALL ALLOC(X5);CALL ALLOC(X6);
    IF(EL%P%METHOD==2.AND.OLD_IMPLEMENTATION_OF_SIXTRACK) THEN
       DH=EL%L/EL%P%NST
    ELSE
       IF(EL%P%METHOD/=6) THEN
          DH=EL%L/EL%P%NST/2.0_dp
       ELSE
          DH=EL%L/EL%P%NST/4.0_dp
       ENDIF
    ENDIF

    IF(k%TIME) THEN
       X5=SQRT(1.0_dp+2.0_dp*X(5)/el%P%beta0+x(5)**2)-1
    ELSE
       X5=X(5)
    ENDIF
    HX(1,1)=0.0_dp;HX(1,2)=DH/(1.0_dp+X5);HX(1,3)=0.0_dp;
    HX(2,1)=DIR*DH*(-EL%BN(2)-EL%P%B0*EL%BN(1));HX(2,2)=0.0_dp;HX(2,3)=DH*EL%P%B0;
    HX(3,1)=0.0_dp;HX(3,2)=0.0_dp;HX(3,3)=0.0_dp;
    HY(1,1)=0.0_dp;HY(1,2)=HX(1,2);HY(1,3)=0.0_dp;
    HY(2,1)=DH*DIR*EL%BN(2);HY(2,2)=0.0_dp;HY(2,3)=0.0_dp;
    HY(3,1)=0.0_dp;HY(3,2)=0.0_dp;HY(3,3)=0.0_dp;
    CALL EXPCOSY(HX,EL%MATX)
    CALL EXPCOSY(HY,EL%MATY)
    DO I=1,6
       V(I)=0.0_dp
       DO J=1,6
          HL(I,J)=0.0_dp
       ENDDO
    ENDDO
    HL(1,3)=HX(2,3)*X5; HL(2,3)=HX(2,1); HL(3,2)=HX(1,2);
    HL(4,5)=HX(2,1); HL(6,5)=HX(1,2); HL(2,5)=HX(2,3)*X5;
    HL(5,6)=2.0_dp*HX(2,1); HL(3,6)=2.0_dp*HX(2,3)*X5;HL(5,4)=2.0_dp*HX(1,2);
    V(2)=HX(2,3)
    V(6)=HX(1,2)/(1.0_dp+X5)/2.0_dp;
    CALL EXPCOSY6(HL,V,W)
    do i=1,6
       EL%LX(I)=W(I)
    enddo
    DO I=1,6
       V(I)=0.0_dp
       DO J=1,6
          HL(I,J)=0.0_dp
       ENDDO
    ENDDO
    HL(2,3)=HY(2,1); HL(3,2)=HY(1,2);
    HL(4,5)=HY(2,1); HL(6,5)=HY(1,2)
    HL(5,6)=2.0_dp*HY(2,1);HL(5,4)=2.0_dp*HY(1,2);
    V(6)=HY(1,2)/(1.0_dp+X5)/2.0_dp;
    CALL EXPCOSY6(HL,V,W)

    do i=1,3
       EL%LY(I)=W(3+I)
    enddo

    IF(k%TIME) THEN         ! SPECIAL TIME FACTOR
       X6=(X(5)+2.0_dp/EL%P%beta0)/(2.0_dp+X5)              ! DELTA/E
       X5=(1.0_dp/EL%P%beta0+X(5))/(1.0_dp+X5)     ! dDELTA/dE
       EL%MATX(1,3)=EL%MATX(1,3)*X6
       EL%MATX(2,3)=EL%MATX(2,3)*X6
       do i=1,6
          EL%LX(I)=X5*EL%LX(I)
       enddo
       do i=1,3
          EL%LY(I)=X5*EL%LY(I)
       enddo
       ! BUG FOUND BY SCHMIDT
       !       EL%LX(1)=EL%LX(1)+k%TOTALPATH*DH*X5
       EL%LX(1)=EL%LX(1)+DH*X5-(1-k%TOTALPATH)*DH/EL%P%beta0
    ELSE
       EL%LX(1)=EL%LX(1)+k%TOTALPATH*DH
    ENDIF


    DO I=1,3
       DO J=1,3
          CALL KILL(HX(I,J));CALL KILL(HY(I,J))
       ENDDO
    ENDDO
    DO I=1,6
       CALL KILL(V(I));CALL KILL(W(I))
       DO J=1,6;CALL KILL(HL(I,J))
       ENDDO
    ENDDO
    CALL KILL(DH);CALL KILL(X5);CALL KILL(X6);


  END SUBROUTINE GETMATD

  SUBROUTINE EXPR(H,MATOUT)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: H(3,3),MATOUT(2,3)
    real(dp) AD(3,3),TEMP(3,3)
    real(dp) NORM,NORM0,NORMAT,NORMAT0
    logical(lp) FIRST
    INTEGER I,J,K,N

    DO I=1,2
       DO J=1,3
          MATOUT(I,J)=0.0_dp
       ENDDO
    ENDDO
    DO I=1,3
       DO J=1,3
          AD(I,J)=0.0_dp
          TEMP(I,J)=0.0_dp
       ENDDO
    ENDDO
    MATOUT(1,1)=1.0_dp
    MATOUT(2,2)=1.0_dp
    AD(1,1)=1.0_dp
    AD(2,2)=1.0_dp
    AD(3,3)=1.0_dp
    FIRST=.TRUE.
    NORM=1e6_dp
    NORMAT=2e5_dp
    DO N=1,NMAXI
       !  COMPUTING H**N/N!
       DO I=1,3
          DO J=1,3
             DO K=1,3
                TEMP(I,K)=H(I,J)*AD(J,K)+TEMP(I,K)
             ENDDO
          ENDDO
       ENDDO
       NORM0=NORM
       NORMAT0=NORMAT
       !  ADDING TO MATOUT
       NORM=0.0_dp
       NORMAT=0.0_dp
       DO I=1,3   !2
          DO J=1,3
             AD(I,J)=TEMP(I,J)/N
             IF(I/=3) MATOUT(I,J)=MATOUT(I,J)+AD(I,J)
             IF(I/=3) NORMAT=NORMAT+ABS(MATOUT(I,J))
             TEMP(I,J)=0.0_dp
          ENDDO
       ENDDO
       NORM=ABS(NORMAT-NORMAT0)


       IF(FIRST) THEN
          IF(NORM<EPS_DEF_KIND) THEN
             FIRST=.FALSE.
          ENDIF
       ELSE
          IF(NORM>=NORM0) GOTO 100
       ENDIF


    ENDDO

    w_p=0
    w_p%nc=1
    w_p%fc='(1(1X,A72))'
    write(w_p%c(1),'(A31,1X,I4,1X,A11)') " EXPSOLR FAILED TO CONVERGE IN ",NMAXI," ITERATIONS"
    ! call !write_e(0)

100 CONTINUE

  END SUBROUTINE EXPR

  SUBROUTINE EXPD(H,MATOUT)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: H(3,3),MATOUT(2,3)
    TYPE(REAL_8) AD(3,3),TEMP(3,3)
    real(dp) NORM,NORM0,NORMAT,NORMAT0
    logical(lp) FIRST
    INTEGER I,J,K,N

    DO I=1,2
       DO J=1,3
          MATOUT(I,J)=0.0_dp
       ENDDO
    ENDDO
    DO I=1,3
       DO J=1,3
          CALL ALLOC(AD(I,J))
          CALL ALLOC(TEMP(I,J))
       ENDDO
    ENDDO
    MATOUT(1,1)=1.0_dp
    MATOUT(2,2)=1.0_dp
    AD(1,1)=1.0_dp
    AD(2,2)=1.0_dp
    AD(3,3)=1.0_dp
    FIRST=.TRUE.
    NORM=1e6_dp
    NORMAT=2e5_dp
    DO N=1,NMAXI
       !  COMPUTING H**N/N!
       DO I=1,3
          DO J=1,3
             DO K=1,3
                TEMP(I,K)=H(I,J)*AD(J,K)+TEMP(I,K)
             ENDDO
          ENDDO
       ENDDO
       NORM0=NORM
       NORMAT0=NORMAT
       !  ADDING TO MATOUT
       NORM=0.0_dp
       NORMAT=0.0_dp
       DO I=1,3   !2
          DO J=1,3
             AD(I,J)=TEMP(I,J)/N
             IF(I/=3) MATOUT(I,J)=MATOUT(I,J)+AD(I,J)
             IF(I/=3) NORMAT=NORMAT+ABS(MATOUT(I,J))
             TEMP(I,J)=0.0_dp
          ENDDO
       ENDDO
       NORM=ABS(NORMAT-NORMAT0)


       IF(FIRST) THEN
          IF(NORM<EPS_DEF_KIND) THEN
             FIRST=.FALSE.
          ENDIF
       ELSE
          IF(NORM>=NORM0) GOTO 100
       ENDIF


    ENDDO

    w_p=0
    w_p%nc=1
    w_p%fc='(1(1X,A72))'
    write(w_p%c(1),'(A31,1X,I4,1X,A11)') " EXPSOLR FAILED TO CONVERGE IN ",NMAXI," ITERATIONS"
    ! call !write_e(0)

100 CONTINUE

    DO I=1,3
       DO J=1,3
          CALL KILL(AD(I,J))
          CALL KILL(TEMP(I,J))
       ENDDO
    ENDDO


  END SUBROUTINE EXPD


  SUBROUTINE EXP6R(H,V,MATOUT)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: H(6,6),V(6),MATOUT(6)
    real(dp) AD(6),TEMP(6)
    real(dp) NORM,NORM0,NORMAT,NORMAT0
    logical(lp) FIRST
    INTEGER I,J,N

    DO I=1,6
       MATOUT(I)=V(I)
       AD(I)=V(I)
       TEMP(I)=0.0_dp
    ENDDO
    FIRST=.TRUE.
    NORM=1e6_dp
    NORMAT=2e5_dp
    DO N=1,NMAXI
       !  COMPUTING H**N/N!
       DO I=1,6
          DO J=1,6
             TEMP(I)=H(I,J)*AD(J)+TEMP(I)
          ENDDO
       ENDDO
       NORM0=NORM
       NORMAT0=NORMAT
       !  ADDING TO MATOUT
       NORM=0.0_dp
       NORMAT=0.0_dp
       DO I=1,6   !2
          AD(I)=TEMP(I)/(N+1)
          MATOUT(I)=MATOUT(I)+AD(I)
          NORMAT=NORMAT+ABS(MATOUT(I))
          TEMP(I)=0.0_dp
       ENDDO
       NORM=ABS(NORMAT-NORMAT0)


       IF(FIRST) THEN
          IF(NORM<EPS_DEF_KIND) THEN
             FIRST=.FALSE.
          ENDIF
       ELSE
          IF(NORM>=NORM0) GOTO 100
       ENDIF


    ENDDO

    w_p=0
    w_p%nc=1
    w_p%fc='(1(1X,A72))'
    write(w_p%c(1),'(A31,1X,I4,1X,A11)') " EXPSOLR FAILED TO CONVERGE IN ",NMAXI," ITERATIONS"
    ! call !write_e(0)

100 CONTINUE

  END SUBROUTINE EXP6R


  SUBROUTINE EXP6D(H,V,MATOUT)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: H(6,6),V(6),MATOUT(6)
    TYPE(REAL_8) AD(6),TEMP(6)
    real(dp) NORM,NORM0,NORMAT,NORMAT0
    logical(lp) FIRST
    INTEGER I,J,N

    CALL ALLOC(AD,6)
    CALL ALLOC(TEMP,6)

    DO I=1,6
       MATOUT(I)=V(I)
       AD(I)=V(I)
       TEMP(I)=0.0_dp
    ENDDO
    FIRST=.TRUE.
    NORM=1e6_dp
    NORMAT=2e5_dp
    DO N=1,NMAXI
       !  COMPUTING H**N/N!
       DO I=1,6
          DO J=1,6
             TEMP(I)=H(I,J)*AD(J)+TEMP(I)
          ENDDO
       ENDDO
       NORM0=NORM
       NORMAT0=NORMAT
       !  ADDING TO MATOUT
       NORM=0.0_dp
       NORMAT=0.0_dp
       DO I=1,6   !2
          AD(I)=TEMP(I)/(N+1)
          MATOUT(I)=MATOUT(I)+AD(I)
          NORMAT=NORMAT+ABS(MATOUT(I))
          TEMP(I)=0.0_dp
       ENDDO
       NORM=ABS(NORMAT-NORMAT0)


       IF(FIRST) THEN
          IF(NORM<EPS_DEF_KIND) THEN
             FIRST=.FALSE.
          ENDIF
       ELSE
          IF(NORM>=NORM0) GOTO 100
       ENDIF


    ENDDO

    w_p=0
    w_p%nc=1
    w_p%fc='(1(1X,A72))'
    write(w_p%c(1),'(A31,1X,I4,1X,A11)') " EXPSOLR FAILED TO CONVERGE IN ",NMAXI," ITERATIONS"
    ! call !write_e(0)

100 CONTINUE


    CALL KILL(AD,6)
    CALL KILL(TEMP,6)

  END SUBROUTINE EXP6D
  !  ZEROING AND COPY ROUTINES

  SUBROUTINE INTER_KTK(EL,X,k)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(KTK),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    real(dp) DK,DK2,DK6,DK4,DK5



    SELECT CASE(EL%P%METHOD)
    CASE(2)
       DK2=EL%L/EL%P%NST
       DK=DK2/2.0_dp

       IF(OLD_IMPLEMENTATION_OF_SIXTRACK) THEN

          CALL GETMAT(EL,X,k)
          CALL KICKKTK(EL,DK,X,k)  ! NEW
          CALL KICKPATH(EL,DK,X,k)
          CALL PUSHKTK(EL,X)

          CALL KICKPATH(EL,DK,X,k)
          CALL KICKKTK(EL,DK,X,k)  ! NEW
       ELSE  ! OLD_IMPLEMENTATION_OF_SIXTRACK
          CALL GETMAT(EL,X,k)
          CALL PUSHKTK(EL,X)
          CALL KICKPATH(EL,DK,X,k)
          CALL KICKKTK(EL,DK2,X,k)  ! NEW
          CALL KICKPATH(EL,DK,X,k)
          CALL PUSHKTK(EL,X)

       ENDIF ! OLD_IMPLEMENTATION_OF_SIXTRACK

    CASE(4)
       DK2=EL%L/EL%P%NST/3.0_dp
       DK6=2.0_dp*DK2
       DK=DK2/2.0_dp
       CALL GETMAT(EL,X,k)
       CALL KICKKTK(EL,DK,X,k)    ! NEW
       CALL KICKPATH(EL,DK,X,k)
       CALL PUSHKTK(EL,X)
       CALL KICKPATH(EL,DK2,X,k)
       CALL KICKKTK(EL,DK6,X,k)
       CALL KICKPATH(EL,DK2,X,k)
       CALL PUSHKTK(EL,X)
       CALL KICKPATH(EL,DK,X,k)
       CALL KICKKTK(EL,DK,X,k) ! NEW
    CASE(6)
       DK2=14.0_dp*EL%L/EL%P%NST/90.0_dp
       DK4=32.0_dp*EL%L/EL%P%NST/90.0_dp
       DK6=12.0_dp*EL%L/EL%P%NST/90.0_dp
       DK5=DK6/2.0_dp
       DK=DK2/2.0_dp


       CALL GETMAT(EL,X,k)
       CALL KICKKTK(EL,DK,X,k)   ! NEW
       CALL KICKPATH(EL,DK,X,k)

       CALL PUSHKTK(EL,X)

       CALL KICKKTK(EL,DK4,X,k)
       CALL KICKPATH(EL,DK4,X,k)

       CALL PUSHKTK(EL,X)

       CALL KICKPATH(EL,DK5,X,k)
       CALL KICKKTK(EL,DK6,X,k)   ! SYMMETRY POINT
       CALL KICKPATH(EL,DK5,X,k)

       CALL PUSHKTK(EL,X)

       CALL KICKPATH(EL,DK4,X,k)
       CALL KICKKTK(EL,DK4,X,k)

       CALL PUSHKTK(EL,X)
       CALL KICKPATH(EL,DK,X,k)
       CALL KICKKTK(EL,DK,X,k)   ! NEW

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

  END SUBROUTINE INTER_KTK

  SUBROUTINE INTEP_KTK(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(KTKP),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    TYPE(REAL_8) DK,DK2,DK6,DK4,DK5


    CALL ALLOC(EL)   ! etienne in daresbury

    SELECT CASE(EL%P%METHOD)
    CASE(2)
       CALL ALLOC(DK2,DK)
       DK2=EL%L/EL%P%NST
       DK=DK2/2.0_dp

       IF(OLD_IMPLEMENTATION_OF_SIXTRACK) THEN



          CALL GETMAT(EL,X,k)
          CALL KICKKTK(EL,DK,X,k)  ! NEW
          CALL KICKPATH(EL,DK,X,k)
          CALL PUSHKTK(EL,X)

          CALL KICKPATH(EL,DK,X,k)
          CALL KICKKTK(EL,DK,X,k)  ! NEW
       ELSE  ! OLD_IMPLEMENTATION_OF_SIXTRACK
          CALL GETMAT(EL,X,k)
          CALL PUSHKTK(EL,X)
          CALL KICKPATH(EL,DK,X,k)
          CALL KICKKTK(EL,DK2,X,k)  ! NEW
          CALL KICKPATH(EL,DK,X,k)
          CALL PUSHKTK(EL,X)

       ENDIF ! OLD_IMPLEMENTATION_OF_SIXTRACK
       CALL KILL(DK2,DK)

    CASE(4)
       CALL ALLOC(DK,DK2,DK6)
       DK2=EL%L/EL%P%NST/3.0_dp
       DK6=2.0_dp*DK2
       DK=DK2/2.0_dp
       CALL GETMAT(EL,X,k)
       CALL KICKKTK(EL,DK,X,k)    ! NEW
       CALL KICKPATH(EL,DK,X,k)
       CALL PUSHKTK(EL,X)
       CALL KICKPATH(EL,DK2,X,k)
       CALL KICKKTK(EL,DK6,X,k)
       CALL KICKPATH(EL,DK2,X,k)
       CALL PUSHKTK(EL,X)
       CALL KICKPATH(EL,DK,X,k)
       CALL KICKKTK(EL,DK,X,k) ! NEW
       CALL KILL(DK,DK2,DK6)
    CASE(6)
       CALL ALLOC(DK,DK2,DK4,DK5,DK6)
       DK2=14.0_dp*EL%L/EL%P%NST/90.0_dp
       DK4=32.0_dp*EL%L/EL%P%NST/90.0_dp
       DK6=12.0_dp*EL%L/EL%P%NST/90.0_dp
       DK5=DK6/2.0_dp
       DK=DK2/2.0_dp


       CALL GETMAT(EL,X,k)
       CALL KICKKTK(EL,DK,X,k)   ! NEW
       CALL KICKPATH(EL,DK,X,k)

       CALL PUSHKTK(EL,X)

       CALL KICKKTK(EL,DK4,X,k)
       CALL KICKPATH(EL,DK4,X,k)

       CALL PUSHKTK(EL,X)

       CALL KICKPATH(EL,DK5,X,k)
       CALL KICKKTK(EL,DK6,X,k)   ! SYMMETRY POINT
       CALL KICKPATH(EL,DK5,X,k)

       CALL PUSHKTK(EL,X)

       CALL KICKPATH(EL,DK4,X,k)
       CALL KICKKTK(EL,DK4,X,k)

       CALL PUSHKTK(EL,X)
       CALL KICKPATH(EL,DK,X,k)
       CALL KICKKTK(EL,DK,X,k)   ! NEW
       CALL KILL(DK,DK2,DK4,DK5,DK6)

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT
    CALL kill(EL)

  END SUBROUTINE INTEP_KTK

  SUBROUTINE INTKTKR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(KTK),INTENT(INOUT):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    IF(.NOT.PRESENT(MID))CALL GETMAT(EL,X,k)

    DO I=1,EL%P%NST
       IF(.NOT.PRESENT(MID)) CALL TRACK_SLICE(EL,X,k)
       IF(PRESENT(MID)) CALL XMID(MID,X,I)
    ENDDO


  END SUBROUTINE INTKTKR

  SUBROUTINE INTKTKD(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(KTKP),INTENT(INOUT):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    !    CALL ALLOC(EL)
    !    CALL GETMAT(EL,X,k)


    DO I=1,EL%P%NST
       CALL TRACK_SLICE(EL,X,k)
    ENDDO


    !    CALL KILL(EL)

  END SUBROUTINE INTKTKD


  SUBROUTINE PUSHKTKR(EL,X)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(KTK),INTENT(IN):: EL
    real(dp) T(6)

    T(1)=EL%MATX(1,1)*X(1)+EL%MATX(1,2)*X(2)+EL%MATX(1,3)*X(5)
    T(2)=EL%MATX(2,1)*X(1)+EL%MATX(2,2)*X(2)+EL%MATX(2,3)*X(5)
    T(3)=EL%MATY(1,1)*X(3)+EL%MATY(1,2)*X(4)
    T(4)=EL%MATY(2,1)*X(3)+EL%MATY(2,2)*X(4)
    T(6)=X(6)+EL%LX(1)+EL%LX(2)*X(1)+EL%LX(3)*X(2)
    T(6)=T(6)+EL%LX(4)*X(1)**2+EL%LX(5)*X(1)*X(2)+EL%LX(6)*X(2)**2
    T(6)=T(6)+EL%LY(1)*X(3)**2+EL%LY(2)*X(3)*X(4)+EL%LY(3)*X(4)**2

    X(1)=T(1);X(2)=T(2);X(3)=T(3);X(4)=T(4);X(6)=T(6);

  END SUBROUTINE PUSHKTKR

  SUBROUTINE PUSHKTKD(EL,X)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(KTKP),INTENT(IN):: EL
    TYPE(REAL_8) T(6)

    CALL ALLOC(T)
    T(1)=EL%MATX(1,1)*X(1)+EL%MATX(1,2)*X(2)+EL%MATX(1,3)*X(5)
    T(2)=EL%MATX(2,1)*X(1)+EL%MATX(2,2)*X(2)+EL%MATX(2,3)*X(5)
    T(3)=EL%MATY(1,1)*X(3)+EL%MATY(1,2)*X(4)
    T(4)=EL%MATY(2,1)*X(3)+EL%MATY(2,2)*X(4)
    T(6)=X(6)+EL%LX(1)+EL%LX(2)*X(1)+EL%LX(3)*X(2)
    T(6)=T(6)+EL%LX(4)*X(1)**2+EL%LX(5)*X(1)*X(2)+EL%LX(6)*X(2)**2
    T(6)=T(6)+EL%LY(1)*X(3)**2+EL%LY(2)*X(3)*X(4)+EL%LY(3)*X(4)**2

    X(1)=T(1);X(2)=T(2);X(3)=T(3);X(4)=T(4);X(6)=T(6);

    CALL KILL(T)

  END SUBROUTINE PUSHKTKD


  SUBROUTINE KICKKTKR(EL,YL,X,k)   !ETIENNE
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(KTK),INTENT(IN):: EL
    real(dp),INTENT(IN):: YL
    real(dp) X1,X3,X5,BBYTW,BBXTW,BBYTWT
    INTEGER J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE

    X1=X(1)
    X3=X(3)

    if(k%TIME) then
       X5=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)-1.0_dp
    else
       X5=X(5)
    endif


    IF(EL%P%NMUL>=1) THEN
       BBYTW=EL%BN(EL%P%NMUL)
       BBXTW=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF


    X(2)=X(2)-YL*DIR*(BBYTW-DIR*EL%P%B0-EL%BN(2)*X(1))
    X(4)=X(4)+YL*DIR*(BBXTW-EL%BN(2)*X(3))

    !outvalishev    if(valishev.and.ABS(el%VS)>eps)   then  !valishev
    !outvalishev     call elliptical_b(el%VA,el%VS,x,BBXTW,BBYTW) !valishev
    !outvalishev       X(2)=X(2)-YL*DIR*BBYTW !valishev
    !outvalishev       X(4)=X(4)+YL* DIR*BBXTW !valishev
    !outvalishev    endif !valishev

  END SUBROUTINE KICKKTKR



  SUBROUTINE KICKKTKP(EL,YL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(KTKP),INTENT(IN):: EL
    TYPE(REAL_8),INTENT(IN):: YL
    TYPE(REAL_8) X1,X3,X5,BBYTW,BBXTW,BBYTWT
    INTEGER J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE

    CALL ALLOC(X1)
    CALL ALLOC(X3)
    CALL ALLOC(X5)
    CALL ALLOC(BBYTW)
    CALL ALLOC(BBXTW)
    CALL ALLOC(BBYTWT)


    X1=X(1)
    X3=X(3)
    if(k%TIME) then
       X5=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)-1.0_dp
    else
       X5=X(5)
    endif


    IF(EL%P%NMUL>=1) THEN
       BBYTW=EL%BN(EL%P%NMUL)
       BBXTW=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF


    X(2)=X(2)-YL*DIR*(BBYTW-DIR*EL%P%B0-EL%BN(2)*X(1))
    X(4)=X(4)+YL*DIR*(BBXTW-EL%BN(2)*X(3))

    !outvalishev    if(valishev.and.ABS(el%VS)>eps)   then  !valishev
    !outvalishev     call elliptical_b(el%VA,el%VS,x,BBXTW,BBYTW) !valishev
    !outvalishev       X(2)=X(2)-YL*DIR*BBYTW !valishev
    !outvalishev       X(4)=X(4)+YL* DIR*BBXTW !valishev
    !outvalishev    endif !valishev


    CALL KILL(X1)
    CALL KILL(X3)
    CALL KILL(X5)
    CALL KILL(BBYTW)
    CALL KILL(BBXTW)
    CALL KILL(BBYTWT)

  END SUBROUTINE KICKKTKP

  SUBROUTINE SYMPINTKTKR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(KTK),INTENT(INOUT):: EL
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    IF(.NOT.PRESENT(MID))CALL TRACK_FRINGE(EL6=EL,X=X,k=k,J=1)
    CALL INTKTK(EL,X,k,MID)
    IF(.NOT.PRESENT(MID))CALL TRACK_FRINGE(EL6=EL,X=X,k=k,J=2)

  END SUBROUTINE SYMPINTKTKR

  SUBROUTINE SYMPINTKTKD(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(KTKP),INTENT(INOUT):: EL
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: MID
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL TRACK_FRINGE(EL6=EL,X=X,k=k,J=1)
    CALL INTKTK(EL,X,k)
    CALL TRACK_FRINGE(EL6=EL,X=X,k=k,J=2)

  END SUBROUTINE SYMPINTKTKD


!!!! *************************************************************** !!!!
!!!! *                 End of the slow thick element               * !!!!
!!!! *************************************************************** !!!!


!!!! *************************************************************** !!!!
!!!! *           Beginning of the fast thick element               * !!!!
!!!! *************************************************************** !!!!
  SUBROUTINE GETMAT7R(EL)
    IMPLICIT NONE
    TYPE(TKTF),INTENT(INOUT):: EL
    real(dp) HX(4,4),HY(4,4)
    real(dp) DH
    INTEGER DIR
!!!!  SPEED STUFF !!!
    real(dp) OMEGA, OMEGA2,C,S
    INTEGER S_OMEGA

    IF(MOD(EL%P%METHOD,2)==1) THEN
       DH=(EL%L/EL%P%NST)  ! method=1,3,5
    ELSEIF(EL%P%METHOD/=6) THEN
       DH=(EL%L/EL%P%NST)/EL%P%METHOD   ! method=1,2
       IF(EL%P%METHOD==4) DH=DH*2.0_dp
    ELSE
       DH=EL%L/EL%P%NST/4.0_dp
    ENDIF

    DIR=1
    IF(SPEED) THEN

       S_OMEGA=-1
       OMEGA2=DIR*(EL%BN(2)+EL%P%B0*EL%BN(1))

       IF(OMEGA2<0.0_dp) THEN
          OMEGA2=-OMEGA2
          S_OMEGA=1
       ENDIF
       if(OMEGA2.eq.0.0_dp) then   ! for Lahey bug in quadruple precision
          OMEGA=0.0_dp             ! not done yet on TPSA part
       else
          OMEGA=SQRT(OMEGA2)
       endif

       IF(OMEGA>0.0_dp) THEN
          IF(S_OMEGA==1) THEN
             C=COSH(OMEGA*DH)
             S=SINH(OMEGA*DH)
          ELSE
             C=COS(OMEGA*DH)
             S=SIN(OMEGA*DH)
          ENDIF
          EL%MATX(1,1)=C;
          EL%MATX(1,2)=S/OMEGA;
          EL%MATX(1,3)= EL%P%B0*(C-1.0_dp)/OMEGA2*S_OMEGA;

          EL%MATX(2,1)=S_OMEGA*OMEGA*S; EL%MATX(2,2)=C;
          EL%MATX(2,3)= EL%P%B0*EL%MATX(1,2);
          EL%LX(1)=EL%P%B0*EL%MATX(1,2);   EL%LX(2)=EL%MATX(1,3);
          EL%LX(3)=-EL%P%B0**2*S_OMEGA*(DH-EL%MATX(1,2))/OMEGA2;
       ELSE
          EL%MATX(1,1)=1.0_dp;EL%MATX(1,2)=DH;
          EL%MATX(2,1)=0.0_dp
          EL%MATX(2,2)=1.0_dp
          EL%MATX(2,3)= EL%P%B0*DH;
          EL%MATX(1,3)= EL%MATX(2,3)*DH/2.0_dp;
          EL%LX(1)=EL%MATX(2,3);EL%LX(2)=EL%MATX(1,3);
          EL%LX(3)=EL%MATX(1,3)*EL%P%B0*DH/3.0_dp
       ENDIF

       S_OMEGA=-1
       OMEGA2=-DIR*EL%BN(2)

       IF(OMEGA2<0.0_dp) THEN
          OMEGA2=-OMEGA2
          S_OMEGA=1
       ENDIF
       OMEGA=SQRT(OMEGA2)


       IF(OMEGA>0.0_dp) THEN
          IF(S_OMEGA==1) THEN
             C=COSH(OMEGA*DH)
             S=SINH(OMEGA*DH)
          ELSE
             C=COS(OMEGA*DH)
             S=SIN(OMEGA*DH)
          ENDIF
          EL%MATY(1,1)=C;
          EL%MATY(1,2)=S/OMEGA;
          EL%MATY(1,3)=0.0_dp;
          EL%MATY(2,1)=S_OMEGA*OMEGA*S; EL%MATY(2,2)=C;
          EL%MATY(2,3)=0.0_dp;
       ELSE
          EL%MATY(1,3)=0.0_dp;
          EL%MATY(2,3)=0.0_dp;
          EL%MATY(1,1)=1.0_dp;EL%MATY(1,2)=DH;
          EL%MATY(2,2)=1.0_dp;EL%MATY(2,1)=0.0_dp;
       ENDIF





    ELSE     !  SPEED FALSE OR KNOB TRUE


       HX(1,1)=0.0_dp;HX(1,2)=DH;HX(1,3)=0.0_dp;HX(1,4)=0.0_dp;
       HX(2,1)=-DH*DIR*(EL%BN(2)+EL%P%B0*EL%BN(1));HX(2,2)=0.0_dp;HX(2,3)=DH*EL%P%B0;HX(2,4)=0.0_dp;
       HX(3,1)=0.0_dp;HX(3,2)=0.0_dp;HX(3,3)=0.0_dp;HX(3,4)=0.0_dp;
       HX(4,1)=DH*EL%P%B0;HX(4,2)=0.0_dp;HX(4,3)=0.0_dp;HX(4,4)=0.0_dp;

       HY(1,1)=0.0_dp;HY(1,2)=HX(1,2);HY(1,3)=0.0_dp;HY(1,4)=0.0_dp;
       HY(2,1)=DH*DIR*EL%BN(2);HY(2,2)=0.0_dp;HY(2,3)=0.0_dp;HY(2,4)=0.0_dp;
       HY(3,1)=0.0_dp;HY(3,2)=0.0_dp;HY(3,3)=0.0_dp;HY(3,4)=0.0_dp;
       HY(4,1)=0.0_dp;HY(4,2)=0.0_dp;HY(4,3)=0.0_dp;HY(4,4)=0.0_dp;

       ! BUG FOUND BY SCHMIDT (SUBTLE ONE; AFFECTS PTC LOGIC; YUCK!)

       !    IF(k%TIME) THEN
       !       HX(2,3)=HX(2,3)/el%P%beta0
       !       HX(4,1)=HX(4,1)/el%P%beta0
       !    ENDIF

       CALL EXPCOSY7(HY,EL%MATY,EL%LX)
       CALL EXPCOSY7(HX,EL%MATX,EL%LX)







    ENDIF


    DIR=-1
    IF(SPEED) THEN

       S_OMEGA=-1
       OMEGA2=DIR*(EL%BN(2)+EL%P%B0*EL%BN(1))

       IF(OMEGA2<0.0_dp) THEN
          OMEGA2=-OMEGA2
          S_OMEGA=1
       ENDIF

       if(OMEGA2.eq.0.0_dp) then    ! for Lahey bug in quadruple precision
          OMEGA=0.0_dp
       else
          OMEGA=SQRT(OMEGA2)
       endif

       IF(OMEGA>0.0_dp) THEN
          IF(S_OMEGA==1) THEN
             C=COSH(OMEGA*DH)
             S=SINH(OMEGA*DH)
          ELSE
             C=COS(OMEGA*DH)
             S=SIN(OMEGA*DH)
          ENDIF
          EL%RMATX(1,1)=C;
          EL%RMATX(1,2)=S/OMEGA;
          EL%RMATX(1,3)= EL%P%B0*(C-1.0_dp)/OMEGA2*S_OMEGA;
          EL%RMATX(2,1)=S_OMEGA*OMEGA*S; EL%RMATX(2,2)=C;
          EL%RMATX(2,3)= EL%P%B0*EL%RMATX(1,2);
          EL%RLX(1)=EL%P%B0*EL%RMATX(1,2);   EL%RLX(2)=EL%RMATX(1,3);
          EL%RLX(3)=-EL%P%B0**2*S_OMEGA*(DH-EL%RMATX(1,2))/OMEGA2;
       ELSE
          EL%RMATX(1,1)=1.0_dp;EL%RMATX(1,2)=DH;
          EL%RMATX(2,1)=0.0_dp
          EL%RMATX(2,2)=1.0_dp
          EL%RMATX(2,3)= EL%P%B0*DH;
          EL%RMATX(1,3)= EL%RMATX(2,3)*DH/2.0_dp;
          EL%RLX(1)=EL%RMATX(2,3);EL%RLX(2)=EL%RMATX(1,3);
          EL%RLX(3)=EL%RMATX(1,3)*EL%P%B0*DH/3.0_dp
       ENDIF

       S_OMEGA=-1
       OMEGA2=-DIR*EL%BN(2)

       IF(OMEGA2<0.0_dp) THEN
          OMEGA2=-OMEGA2
          S_OMEGA=1
       ENDIF
       OMEGA=SQRT(OMEGA2)


       IF(OMEGA>0.0_dp) THEN
          IF(S_OMEGA==1) THEN
             C=COSH(OMEGA*DH)
             S=SINH(OMEGA*DH)
          ELSE
             C=COS(OMEGA*DH)
             S=SIN(OMEGA*DH)
          ENDIF
          EL%RMATY(1,1)=C;
          EL%RMATY(1,2)=S/OMEGA;
          EL%RMATY(1,3)=0.0_dp;
          EL%RMATY(2,1)=S_OMEGA*OMEGA*S; EL%RMATY(2,2)=C;
          EL%RMATY(2,3)=0.0_dp;
       ELSE
          EL%RMATY(1,3)=0.0_dp;
          EL%RMATY(2,3)=0.0_dp;
          EL%RMATY(1,1)=1.0_dp;EL%RMATY(1,2)=DH;
          EL%RMATY(2,2)=1.0_dp;EL%RMATY(2,1)=0.0_dp;
       ENDIF





    ELSE     !  SPEED FALSE OR KNOB TRUE


       HX(1,1)=0.0_dp;HX(1,2)=DH;HX(1,3)=0.0_dp;HX(1,4)=0.0_dp;
       HX(2,1)=-DH*DIR*(EL%BN(2)+EL%P%B0*EL%BN(1));HX(2,2)=0.0_dp;HX(2,3)=DH*EL%P%B0;HX(2,4)=0.0_dp;
       HX(3,1)=0.0_dp;HX(3,2)=0.0_dp;HX(3,3)=0.0_dp;HX(3,4)=0.0_dp;
       HX(4,1)=DH*EL%P%B0;HX(4,2)=0.0_dp;HX(4,3)=0.0_dp;HX(4,4)=0.0_dp;

       HY(1,1)=0.0_dp;HY(1,2)=HX(1,2);HY(1,3)=0.0_dp;HY(1,4)=0.0_dp;
       HY(2,1)=DH*DIR*EL%BN(2);HY(2,2)=0.0_dp;HY(2,3)=0.0_dp;HY(2,4)=0.0_dp;
       HY(3,1)=0.0_dp;HY(3,2)=0.0_dp;HY(3,3)=0.0_dp;HY(3,4)=0.0_dp;
       HY(4,1)=0.0_dp;HY(4,2)=0.0_dp;HY(4,3)=0.0_dp;HY(4,4)=0.0_dp;

       ! BUG FOUND BY SCHMIDT (SUBTLE ONE; AFFECTS PTC LOGIC; YUCK!)

       !    IF(k%TIME) THEN
       !       HX(2,3)=HX(2,3)/el%P%beta0
       !       HX(4,1)=HX(4,1)/el%P%beta0
       !    ENDIF

       CALL EXPCOSY7(HY,EL%RMATY,EL%RLX)
       CALL EXPCOSY7(HX,EL%RMATX,EL%RLX)







    ENDIF





  END SUBROUTINE GETMAT7R

  SUBROUTINE GETMAT7D(EL)
    IMPLICIT NONE
    TYPE(TKTFP),INTENT(INOUT):: EL
    TYPE(REAL_8) HX(4,4),HY(4,4)
    TYPE(REAL_8) DH
    INTEGER I,J,DIR
!!!!  SPEED STUFF !!!
    real(dp) OMEGA, OMEGA2,C,S
    INTEGER S_OMEGA

    DO I=1,4
       DO J=1,4
          CALL ALLOC(HX(I,J))
          CALL ALLOC(HY(I,J))
       ENDDO
    ENDDO
    CALL ALLOC(DH)


    IF(MOD(EL%P%METHOD,2)==1) THEN
       DH=(EL%L/EL%P%NST)  ! method=1,2
    ELSEIF(EL%P%METHOD/=6) THEN
       DH=(EL%L/EL%P%NST)/EL%P%METHOD   ! method=1,2
       IF(EL%P%METHOD==4) DH=DH*2.0_dp
    ELSE
       DH=EL%L/EL%P%NST/4.0_dp
    ENDIF

    DIR=1
    IF(SPEED.AND.(.NOT.KNOB)) THEN

       S_OMEGA=-1
       OMEGA2=DIR*(EL%BN(2)+EL%P%B0*EL%BN(1))

       IF(OMEGA2<0.0_dp) THEN
          OMEGA2=-OMEGA2
          S_OMEGA=1
       ENDIF
       OMEGA=SQRT(OMEGA2)


       IF(OMEGA>0.0_dp) THEN
          IF(S_OMEGA==1) THEN
             C=COSH(OMEGA*DH)
             S=SINH(OMEGA*DH)
          ELSE
             C=COS(OMEGA*DH)
             S=SIN(OMEGA*DH)
          ENDIF
          EL%MATX(1,1)=C;
          EL%MATX(1,2)=S/OMEGA;
          EL%MATX(1,3)= EL%P%B0*(C-1.0_dp)/OMEGA2*S_OMEGA;
          EL%MATX(2,1)=S_OMEGA*OMEGA*S; EL%MATX(2,2)=C;
          EL%MATX(2,3)= EL%P%B0*EL%MATX(1,2);
          EL%LX(1)=EL%P%B0*EL%MATX(1,2);   EL%LX(2)=EL%MATX(1,3);
          EL%LX(3)=-EL%P%B0**2*S_OMEGA*(DH-EL%MATX(1,2))/OMEGA2;
       ELSE
          EL%MATX(1,1)=1.0_dp;EL%MATX(1,2)=DH;
          EL%MATX(2,1)=0.0_dp
          EL%MATX(2,2)=1.0_dp
          EL%MATX(2,3)= EL%P%B0*DH;
          EL%MATX(1,3)= EL%MATX(2,3)*DH/2.0_dp;
          EL%LX(1)=EL%MATX(2,3);EL%LX(2)=EL%MATX(1,3);
          EL%LX(3)=EL%MATX(1,3)*EL%P%B0*DH/3.0_dp
       ENDIF


       S_OMEGA=-1
       OMEGA2=-DIR*EL%BN(2)

       IF(OMEGA2<0.0_dp) THEN
          OMEGA2=-OMEGA2
          S_OMEGA=1
       ENDIF
       OMEGA=SQRT(OMEGA2)


       IF(OMEGA>0.0_dp) THEN
          IF(S_OMEGA==1) THEN
             C=COSH(OMEGA*DH)
             S=SINH(OMEGA*DH)
          ELSE
             C=COS(OMEGA*DH)
             S=SIN(OMEGA*DH)
          ENDIF
          EL%MATY(1,1)=C;
          EL%MATY(1,2)=S/OMEGA;
          EL%MATY(1,3)=0.0_dp;
          EL%MATY(2,1)=S_OMEGA*OMEGA*S; EL%MATY(2,2)=C;
          EL%MATY(2,3)=0.0_dp;
       ELSE
          EL%MATY(1,3)=0.0_dp;
          EL%MATY(2,3)=0.0_dp;
          EL%MATY(1,1)=1.0_dp;EL%MATY(1,2)=DH;
          EL%MATY(2,2)=1.0_dp;EL%MATY(2,1)=0.0_dp;
       ENDIF




    ELSE     !  SPEED FALSE OR KNOB TRUE


       HX(1,1)=0.0_dp;HX(1,2)=DH;HX(1,3)=0.0_dp;HX(1,4)=0.0_dp;
       HX(2,1)=-DH*DIR*(EL%BN(2)+EL%P%B0*EL%BN(1));HX(2,2)=0.0_dp;HX(2,3)=DH*EL%P%B0;HX(2,4)=0.0_dp;
       HX(3,1)=0.0_dp;HX(3,2)=0.0_dp;HX(3,3)=0.0_dp;HX(3,4)=0.0_dp;
       HX(4,1)=DH*EL%P%B0;HX(4,2)=0.0_dp;HX(4,3)=0.0_dp;HX(4,4)=0.0_dp;

       HY(1,1)=0.0_dp;HY(1,2)=HX(1,2);HY(1,3)=0.0_dp;HY(1,4)=0.0_dp;
       HY(2,1)=DH*DIR*EL%BN(2);HY(2,2)=0.0_dp;HY(2,3)=0.0_dp;HY(2,4)=0.0_dp;
       HY(3,1)=0.0_dp;HY(3,2)=0.0_dp;HY(3,3)=0.0_dp;HY(3,4)=0.0_dp;
       HY(4,1)=0.0_dp;HY(4,2)=0.0_dp;HY(4,3)=0.0_dp;HY(4,4)=0.0_dp;


       ! BUG FOUND BY SCHMIDT (SUBTLE ONE; AFFECTS PTC LOGIC; YUCK!)

       !    IF(k%TIME) THEN
       !       HX(2,3)=HX(2,3)/el%P%beta0
       !       HX(4,1)=HX(4,1)/el%P%beta0
       !    ENDIF


       CALL EXPCOSY7(HY,EL%MATY,EL%LX)
       CALL EXPCOSY7(HX,EL%MATX,EL%LX)


    ENDIF     !  SPEED FALSE OR KNOB TRUE

    DIR=-1
    IF(SPEED.AND.(.NOT.KNOB)) THEN

       S_OMEGA=-1
       OMEGA2=DIR*(EL%BN(2)+EL%P%B0*EL%BN(1))

       IF(OMEGA2<0.0_dp) THEN
          OMEGA2=-OMEGA2
          S_OMEGA=1
       ENDIF
       OMEGA=SQRT(OMEGA2)


       IF(OMEGA>0.0_dp) THEN
          IF(S_OMEGA==1) THEN
             C=COSH(OMEGA*DH)
             S=SINH(OMEGA*DH)
          ELSE
             C=COS(OMEGA*DH)
             S=SIN(OMEGA*DH)
          ENDIF
          EL%RMATX(1,1)=C;
          EL%RMATX(1,2)=S/OMEGA;
          EL%RMATX(1,3)= EL%P%B0*(C-1.0_dp)/OMEGA2*S_OMEGA;
          EL%RMATX(2,1)=S_OMEGA*OMEGA*S; EL%RMATX(2,2)=C;
          EL%RMATX(2,3)= EL%P%B0*EL%RMATX(1,2);
          EL%RLX(1)=EL%P%B0*EL%RMATX(1,2);   EL%RLX(2)=EL%RMATX(1,3);
          EL%RLX(3)=-EL%P%B0**2*S_OMEGA*(DH-EL%RMATX(1,2))/OMEGA2;
       ELSE
          EL%RMATX(1,1)=1.0_dp;EL%RMATX(1,2)=DH;
          EL%RMATX(2,1)=0.0_dp
          EL%RMATX(2,2)=1.0_dp
          EL%RMATX(2,3)= EL%P%B0*DH;
          EL%RMATX(1,3)= EL%RMATX(2,3)*DH/2.0_dp;
          EL%RLX(1)=EL%RMATX(2,3);EL%RLX(2)=EL%RMATX(1,3);
          EL%RLX(3)=EL%RMATX(1,3)*EL%P%B0*DH/3.0_dp
       ENDIF


       S_OMEGA=-1
       OMEGA2=-DIR*EL%BN(2)

       IF(OMEGA2<0.0_dp) THEN
          OMEGA2=-OMEGA2
          S_OMEGA=1
       ENDIF
       OMEGA=SQRT(OMEGA2)


       IF(OMEGA>0.0_dp) THEN
          IF(S_OMEGA==1) THEN
             C=COSH(OMEGA*DH)
             S=SINH(OMEGA*DH)
          ELSE
             C=COS(OMEGA*DH)
             S=SIN(OMEGA*DH)
          ENDIF
          EL%RMATY(1,1)=C;
          EL%RMATY(1,2)=S/OMEGA;
          EL%RMATY(1,3)=0.0_dp;
          EL%RMATY(2,1)=S_OMEGA*OMEGA*S; EL%RMATY(2,2)=C;
          EL%RMATY(2,3)=0.0_dp;
       ELSE
          EL%RMATY(1,3)=0.0_dp;
          EL%RMATY(2,3)=0.0_dp;
          EL%RMATY(1,1)=1.0_dp;EL%RMATY(1,2)=DH;
          EL%RMATY(2,2)=1.0_dp;EL%RMATY(2,1)=0.0_dp;
       ENDIF




    ELSE     !  SPEED FALSE OR KNOB TRUE


       HX(1,1)=0.0_dp;HX(1,2)=DH;HX(1,3)=0.0_dp;HX(1,4)=0.0_dp;
       HX(2,1)=-DH*DIR*(EL%BN(2)+EL%P%B0*EL%BN(1));HX(2,2)=0.0_dp;HX(2,3)=DH*EL%P%B0;HX(2,4)=0.0_dp;
       HX(3,1)=0.0_dp;HX(3,2)=0.0_dp;HX(3,3)=0.0_dp;HX(3,4)=0.0_dp;
       HX(4,1)=DH*EL%P%B0;HX(4,2)=0.0_dp;HX(4,3)=0.0_dp;HX(4,4)=0.0_dp;

       HY(1,1)=0.0_dp;HY(1,2)=HX(1,2);HY(1,3)=0.0_dp;HY(1,4)=0.0_dp;
       HY(2,1)=DH*DIR*EL%BN(2);HY(2,2)=0.0_dp;HY(2,3)=0.0_dp;HY(2,4)=0.0_dp;
       HY(3,1)=0.0_dp;HY(3,2)=0.0_dp;HY(3,3)=0.0_dp;HY(3,4)=0.0_dp;
       HY(4,1)=0.0_dp;HY(4,2)=0.0_dp;HY(4,3)=0.0_dp;HY(4,4)=0.0_dp;


       ! BUG FOUND BY SCHMIDT (SUBTLE ONE; AFFECTS PTC LOGIC; YUCK!)

       !    IF(k%TIME) THEN
       !       HX(2,3)=HX(2,3)/el%P%beta0
       !       HX(4,1)=HX(4,1)/el%P%beta0
       !    ENDIF

       CALL EXPCOSY7(HY,EL%RMATY,EL%RLX)
       CALL EXPCOSY7(HX,EL%RMATX,EL%RLX)



    ENDIF     !  SPEED FALSE OR KNOB TRUE


    DO I=1,4
       DO J=1,4
          CALL KILL(HX(I,J))
          CALL KILL(HY(I,J))
       ENDDO
    ENDDO
    CALL KILL(DH)





  END SUBROUTINE GETMAT7D

  SUBROUTINE PUSHTKT7R(EL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(TKTF),INTENT(IN):: EL
    real(dp) T(4)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    ! BUG FOUND BY SCHMIDT (SUBTLE ONE; AFFECTS PTC LOGIC; YUCK!)
    !    T(1)=EL%MATX(1,1)*X(1)+EL%MATX(1,2)*X(2)+EL%MATX(1,3)*X(5)
    !    T(2)=EL%MATX(2,1)*X(1)+EL%MATX(2,2)*X(2)+EL%MATX(2,3)*X(5)


    IF(EL%P%DIR*EL%P%CHARGE>0) THEN
       IF(k%TIME) THEN
          T(1)=EL%MATX(1,1)*X(1)+EL%MATX(1,2)*X(2)+EL%MATX(1,3)*X(5)/el%P%beta0
          T(2)=EL%MATX(2,1)*X(1)+EL%MATX(2,2)*X(2)+EL%MATX(2,3)*X(5)/el%P%beta0
          T(3)=EL%MATY(1,1)*X(3)+EL%MATY(1,2)*X(4)
          T(4)=EL%MATY(2,1)*X(3)+EL%MATY(2,2)*X(4)
          X(6)=X(6)+EL%LX(1)*X(1)/el%P%beta0+EL%LX(2)*X(2)/el%P%beta0+EL%LX(3)*X(5)
       ELSE
          T(1)=EL%MATX(1,1)*X(1)+EL%MATX(1,2)*X(2)+EL%MATX(1,3)*X(5)
          T(2)=EL%MATX(2,1)*X(1)+EL%MATX(2,2)*X(2)+EL%MATX(2,3)*X(5)
          T(3)=EL%MATY(1,1)*X(3)+EL%MATY(1,2)*X(4)
          T(4)=EL%MATY(2,1)*X(3)+EL%MATY(2,2)*X(4)
          X(6)=X(6)+EL%LX(1)*X(1)+EL%LX(2)*X(2)+EL%LX(3)*X(5)
       ENDIF
    ELSE
       IF(k%TIME) THEN
          T(1)=EL%RMATX(1,1)*X(1)+EL%RMATX(1,2)*X(2)+EL%RMATX(1,3)*X(5)/el%P%beta0
          T(2)=EL%RMATX(2,1)*X(1)+EL%RMATX(2,2)*X(2)+EL%RMATX(2,3)*X(5)/el%P%beta0
          T(3)=EL%RMATY(1,1)*X(3)+EL%RMATY(1,2)*X(4)
          T(4)=EL%RMATY(2,1)*X(3)+EL%RMATY(2,2)*X(4)
          X(6)=X(6)+EL%RLX(1)*X(1)/el%P%beta0+EL%RLX(2)*X(2)/el%P%beta0+EL%RLX(3)*X(5)
       ELSE
          T(1)=EL%RMATX(1,1)*X(1)+EL%RMATX(1,2)*X(2)+EL%RMATX(1,3)*X(5)
          T(2)=EL%RMATX(2,1)*X(1)+EL%RMATX(2,2)*X(2)+EL%RMATX(2,3)*X(5)
          T(3)=EL%RMATY(1,1)*X(3)+EL%RMATY(1,2)*X(4)
          T(4)=EL%RMATY(2,1)*X(3)+EL%RMATY(2,2)*X(4)
          X(6)=X(6)+EL%RLX(1)*X(1)+EL%RLX(2)*X(2)+EL%RLX(3)*X(5)
       ENDIF
    ENDIF

    X(1)=T(1);X(2)=T(2);X(3)=T(3);X(4)=T(4);

  END SUBROUTINE PUSHTKT7R

  SUBROUTINE PUSHTKT7D(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(TKTFP),INTENT(IN):: EL
    TYPE(REAL_8) T(4)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(T,4)

    ! BUG FOUND BY SCHMIDT (SUBTLE ONE; AFFECTS PTC LOGIC; YUCK!)
    !    T(1)=EL%MATX(1,1)*X(1)+EL%MATX(1,2)*X(2)+EL%MATX(1,3)*X(5)
    !    T(2)=EL%MATX(2,1)*X(1)+EL%MATX(2,2)*X(2)+EL%MATX(2,3)*X(5)
    IF(EL%P%DIR*EL%P%CHARGE>0) THEN
       IF(k%TIME) THEN
          T(1)=EL%MATX(1,1)*X(1)+EL%MATX(1,2)*X(2)+EL%MATX(1,3)*X(5)/el%P%beta0
          T(2)=EL%MATX(2,1)*X(1)+EL%MATX(2,2)*X(2)+EL%MATX(2,3)*X(5)/el%P%beta0
          T(3)=EL%MATY(1,1)*X(3)+EL%MATY(1,2)*X(4)
          T(4)=EL%MATY(2,1)*X(3)+EL%MATY(2,2)*X(4)
          X(6)=X(6)+EL%LX(1)*X(1)/el%P%beta0+EL%LX(2)*X(2)/el%P%beta0+EL%LX(3)*X(5)
       ELSE
          T(1)=EL%MATX(1,1)*X(1)+EL%MATX(1,2)*X(2)+EL%MATX(1,3)*X(5)
          T(2)=EL%MATX(2,1)*X(1)+EL%MATX(2,2)*X(2)+EL%MATX(2,3)*X(5)
          T(3)=EL%MATY(1,1)*X(3)+EL%MATY(1,2)*X(4)
          T(4)=EL%MATY(2,1)*X(3)+EL%MATY(2,2)*X(4)
          X(6)=X(6)+EL%LX(1)*X(1)+EL%LX(2)*X(2)+EL%LX(3)*X(5)
       ENDIF
    ELSE
       IF(k%TIME) THEN
          T(1)=EL%RMATX(1,1)*X(1)+EL%RMATX(1,2)*X(2)+EL%RMATX(1,3)*X(5)/el%P%beta0
          T(2)=EL%RMATX(2,1)*X(1)+EL%RMATX(2,2)*X(2)+EL%RMATX(2,3)*X(5)/el%P%beta0
          T(3)=EL%RMATY(1,1)*X(3)+EL%RMATY(1,2)*X(4)
          T(4)=EL%RMATY(2,1)*X(3)+EL%RMATY(2,2)*X(4)
          X(6)=X(6)+EL%RLX(1)*X(1)/el%P%beta0+EL%RLX(2)*X(2)/el%P%beta0+EL%RLX(3)*X(5)
       ELSE
          T(1)=EL%RMATX(1,1)*X(1)+EL%RMATX(1,2)*X(2)+EL%RMATX(1,3)*X(5)
          T(2)=EL%RMATX(2,1)*X(1)+EL%RMATX(2,2)*X(2)+EL%RMATX(2,3)*X(5)
          T(3)=EL%RMATY(1,1)*X(3)+EL%RMATY(1,2)*X(4)
          T(4)=EL%RMATY(2,1)*X(3)+EL%RMATY(2,2)*X(4)
          X(6)=X(6)+EL%RLX(1)*X(1)+EL%RLX(2)*X(2)+EL%RLX(3)*X(5)
       ENDIF
    ENDIF

    X(1)=T(1);X(2)=T(2);X(3)=T(3);X(4)=T(4);

    CALL KILL(T,4)

  END SUBROUTINE PUSHTKT7D

  !***********************************************************************
  ! ALMOST SAME AS ELEMENT KTK AND KTKP (POLYMORPH) CUT AND PASTE PLEASE *
  !***********************************************************************
  SUBROUTINE KICKTKT7R(EL,YL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(TKTF),INTENT(IN):: EL
    real(dp),INTENT(IN):: YL
    real(dp) X1,X3,X5,BBYTW,BBXTW,BBYTWT
    INTEGER J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE

    X1=X(1)
    X3=X(3)

    if(k%TIME) then
       X5=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)-1.0_dp
       X(2)=X(2)+YL*EL%P%B0*(X5-X(5)/EL%P%BETA0)
       X(6)=X(6)+YL*EL%P%B0*(  (X(5)+1.0_dp/EL%P%beta0)/(1.0_dp+X5) - 1.0_dp/EL%P%beta0  )*X(1)
    else
       X5=X(5)
    endif


    IF(EL%P%NMUL>=1) THEN
       BBYTW=EL%BN(EL%P%NMUL)
       BBXTW=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF

    X(2)=X(2)-YL*DIR*(BBYTW-DIR*EL%P%B0-EL%BN(2)*X(1))
    X(4)=X(4)+YL*DIR*(BBXTW-EL%BN(2)*X(3))

    !outvalishev    if(valishev.and.ABS(el%VS)>eps)   then  !valishev
    !outvalishev     call elliptical_b(el%VA,el%VS,x,BBXTW,BBYTW) !valishev
    !outvalishev       X(2)=X(2)-YL*DIR*BBYTW !valishev
    !outvalishev       X(4)=X(4)+YL* DIR*BBXTW !valishev
    !outvalishev    endif !valishev

  END SUBROUTINE KICKTKT7R



  SUBROUTINE KICKTKT7P(EL,YL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(TKTFP),INTENT(IN):: EL
    TYPE(REAL_8),INTENT(IN):: YL
    TYPE(REAL_8) X1,X3,X5,BBYTW,BBXTW,BBYTWT
    INTEGER J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE


    CALL ALLOC(X1)
    CALL ALLOC(X3)
    CALL ALLOC(X5)
    CALL ALLOC(BBYTW)
    CALL ALLOC(BBXTW)
    CALL ALLOC(BBYTWT)


    X1=X(1)
    X3=X(3)

    if(k%TIME) then
       X5=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)-1.0_dp
       X(2)=X(2)+YL*EL%P%B0*(X5-X(5)/EL%P%BETA0)
       X(6)=X(6)+YL*EL%P%B0*( (X(5)+1.0_dp/EL%P%beta0)/(1.0_dp+X5) - 1.0_dp/EL%P%beta0  )*X(1)
    else
       X5=X(5)
    endif


    IF(EL%P%NMUL>=1) THEN
       BBYTW=EL%BN(EL%P%NMUL)
       BBXTW=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF

    X(2)=X(2)-YL*DIR*(BBYTW-DIR*EL%P%B0-EL%BN(2)*X(1))
    X(4)=X(4)+YL*DIR*(BBXTW-EL%BN(2)*X(3))

    !outvalishev    if(valishev.and.ABS(el%VS)>eps)   then  !valishev
    !outvalishev     call elliptical_b(el%VA,el%VS,x,BBXTW,BBYTW) !valishev
    !outvalishev       X(2)=X(2)-YL*DIR*BBYTW !valishev
    !outvalishev       X(4)=X(4)+YL* DIR*BBXTW !valishev
    !outvalishev    endif !valishev


    CALL KILL(X1)
    CALL KILL(X3)
    CALL KILL(X5)
    CALL KILL(BBYTW)
    CALL KILL(BBXTW)
    CALL KILL(BBYTWT)

  END SUBROUTINE KICKTKT7P


  SUBROUTINE KICKPATH6R(EL,YL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(KTK),INTENT(IN):: EL
    real(dp),INTENT(IN):: YL
    real(dp) PZ,PZ0
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    ! ETIENNE
    IF(.NOT.EL%P%EXACT) RETURN
    if(k%TIME) then
       PZ=root(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2-X(2)**2-X(4)**2)
       PZ0=root(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
       X(6)=X(6)+YL*(1.0_dp/EL%P%beta0+x(5))*(X(2)**2+X(4)**2)*(1.0_dp/PZ/(PZ+PZ0)-1.0_dp/PZ0**2/2.0_dp) &
            &     /PZ0
       PZ=(X(2)**2+X(4)**2)/PZ/PZ0/(PZ+PZ0)   ! = (one/PZ-one/PZ0)
       X(1)=X(1)+YL*X(2)*PZ
       X(3)=X(3)+YL*X(4)*PZ
    else
       PZ=root((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
       PZ0=1.0_dp+X(5)
       X(6)=X(6)+YL*(X(2)**2+X(4)**2)*(1.0_dp/PZ/(PZ+PZ0)-1.0_dp/PZ0**2/2.0_dp)
       PZ=(X(2)**2+X(4)**2)/PZ/PZ0/(PZ+PZ0)   ! = (one/PZ-one/PZ0)
       X(1)=X(1)+YL*X(2)*PZ
       X(3)=X(3)+YL*X(4)*PZ
    endif

  END SUBROUTINE KICKPATH6R

  SUBROUTINE KICKPATH6P(EL,YL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(KTKP),INTENT(IN):: EL
    TYPE(REAL_8),INTENT(IN):: YL
    TYPE(REAL_8) PZ,PZ0
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    ! ETIENNE
    IF(.NOT.EL%P%EXACT) RETURN
    CALL ALLOC(PZ,PZ0)
    if(k%TIME) then
       PZ=sqrt(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2-X(2)**2-X(4)**2)
       PZ0=sqrt(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
       X(6)=X(6)+YL*(1.0_dp/EL%P%beta0+x(5))*(X(2)**2+X(4)**2)*(1.0_dp/PZ/(PZ+PZ0)-1.0_dp/PZ0**2/2.0_dp) &
            &     /PZ0
       PZ=(X(2)**2+X(4)**2)/PZ/PZ0/(PZ+PZ0)   ! = (one/PZ-one/PZ0)
       X(1)=X(1)+YL*X(2)*PZ
       X(3)=X(3)+YL*X(4)*PZ
    else
       PZ=sqrt((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
       PZ0=1.0_dp+X(5)
       X(6)=X(6)+YL*(X(2)**2+X(4)**2)*(1.0_dp/PZ/(PZ+PZ0)-1.0_dp/PZ0**2/2.0_dp)
       PZ=(X(2)**2+X(4)**2)/PZ/PZ0/(PZ+PZ0)   ! = (one/PZ-one/PZ0)
       X(1)=X(1)+YL*X(2)*PZ
       X(3)=X(3)+YL*X(4)*PZ
    endif
    CALL KILL(PZ,PZ0)

  END SUBROUTINE KICKPATH6P

  SUBROUTINE KICKPATHR(EL,YL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(TKTF),INTENT(IN):: EL
    real(dp),INTENT(IN):: YL
    real(dp) X1,X5,PZ
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    ! ETIENNE
    if(k%TIME) then
       if(EL%P%EXACT) THEN
          PZ=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2-X(2)**2-X(4)**2)
          X(1)=X(1)+YL*X(2)*(1.0_dp/PZ-1.0_dp)
          X(3)=X(3)+YL*X(4)*(1.0_dp/PZ-1.0_dp)
          X(6)=X(6)+YL*(1.0_dp/EL%P%beta0+x(5))/PZ-YL*(1-k%TOTALPATH)/EL%P%beta0
       ELSE
          X5=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)-1.0_dp
          X1=(X(5)+1.0_dp/EL%P%BETA0)/(1.0_dp+X5)
          X(1)=X(1)-X5*YL*X(2)/(1.0_dp+X5)
          X(3)=X(3)-X5*YL*X(4)/(1.0_dp+X5)
          ! BUG FOUND BY SCHMIDT
          !       X(6)=X(6)+X1*YL*( k%TOTALPATH + (X(2)**2+X(4)**2)/two/(one+X5)**2 )
          X(6)=X(6)+X1*YL*( 1.0_dp + (X(2)**2+X(4)**2)/2.0_dp/(1.0_dp+X5)**2 )-YL*(1-k%TOTALPATH)/EL%P%beta0
!! temporary shit almost true   
         if(almost_exact) then       
          x(1)=x(1)/(1.0_dp-yl*EL%P%b0*x(2))
          x(3)=x(3)+yl*EL%P%b0*x(4)*x(1)
          x(2)=x(2)-yl*EL%P%b0*0.5_dp*(x(2)**2+x(4)**2)
         endif 
!!
       ENDIF
    else
       if(EL%P%EXACT) THEN
          PZ=ROOT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          X(1)=X(1)+YL*X(2)*(1.0_dp/PZ-1.0_dp)
          X(3)=X(3)+YL*X(4)*(1.0_dp/PZ-1.0_dp)
          X(6)=X(6)+YL*(1.0_dp+x(5))/PZ-YL*(1-k%TOTALPATH)
       ELSE
          X(1)=X(1)-X(5)*YL*X(2)/(1.0_dp+X(5))
          X(3)=X(3)-X(5)*YL*X(4)/(1.0_dp+X(5))
          X(6)=X(6)+YL*( k%TOTALPATH + (X(2)**2+X(4)**2)/2.0_dp/(1.0_dp+X(5))**2 )
!! temporary shit almost true   
         if(almost_exact) then       
          x(1)=x(1)/(1.0_dp-yl*EL%P%b0*x(2))
          x(3)=x(3)+yl*EL%P%b0*x(4)*x(1)
          x(2)=x(2)-yl*EL%P%b0*0.5_dp*(x(2)**2+x(4)**2)
         endif 
!!
       endif
    endif

  END SUBROUTINE KICKPATHR

  SUBROUTINE KICKPATHD(EL,YL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(TKTFP),INTENT(IN):: EL
    TYPE(REAL_8),INTENT(IN):: YL
    TYPE(REAL_8) X1,X5,PZ
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    if(k%TIME) then
       if(EL%P%EXACT) THEN
          CALL ALLOC(PZ)
          PZ=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2-X(2)**2-X(4)**2)
          X(1)=X(1)+YL*X(2)*(1.0_dp/PZ-1.0_dp)
          X(3)=X(3)+YL*X(4)*(1.0_dp/PZ-1.0_dp)
          X(6)=X(6)+YL*(1.0_dp/EL%P%beta0+x(5))/PZ-YL*(1-k%TOTALPATH)/EL%P%beta0
          CALL KILL(PZ)
       ELSE
          CALL ALLOC(X1,X5)
          X5=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)-1.0_dp
          X1=(X(5)+1.0_dp/EL%P%BETA0)/(1.0_dp+X5)
          X(1)=X(1)-X5*YL*X(2)/(1.0_dp+X5)
          X(3)=X(3)-X5*YL*X(4)/(1.0_dp+X5)
          ! BUG FOUND BY SCHMIDT
          !       X(6)=X(6)+X1*YL*( k%TOTALPATH + (X(2)**2+X(4)**2)/two/(one+X5)**2 )
          X(6)=X(6)+X1*YL*( 1.0_dp + (X(2)**2+X(4)**2)/2.0_dp/(1.0_dp+X5)**2 )-YL*(1-k%TOTALPATH)/EL%P%beta0
!! temporary shit almost true   
         if(almost_exact) then       
          x(1)=x(1)/(1.0_dp-yl*EL%P%b0*x(2))
          x(3)=x(3)+yl*EL%P%b0*x(4)*x(1)
          x(2)=x(2)-yl*EL%P%b0*0.5_dp*(x(2)**2+x(4)**2)
         endif 
!!
          CALL KILL(X1,X5)
       ENDIF
    else
       if(EL%P%EXACT) THEN
          CALL ALLOC(PZ)
          PZ=SQRT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          X(1)=X(1)+YL*X(2)*(1.0_dp/PZ-1.0_dp)
          X(3)=X(3)+YL*X(4)*(1.0_dp/PZ-1.0_dp)
          X(6)=X(6)+YL*(1.0_dp+x(5))/PZ-YL*(1-k%TOTALPATH)
          CALL KILL(PZ)
       ELSE
          X(1)=X(1)-X(5)*YL*X(2)/(1.0_dp+X(5))
          X(3)=X(3)-X(5)*YL*X(4)/(1.0_dp+X(5))
          X(6)=X(6)+YL*( k%TOTALPATH + (X(2)**2+X(4)**2)/2.0_dp/(1.0_dp+X(5))**2 )
       endif
!! temporary shit almost true   
         if(almost_exact) then       
          x(1)=x(1)/(1.0_dp-yl*EL%P%b0*x(2))
          x(3)=x(3)+yl*EL%P%b0*x(4)*x(1)
          x(2)=x(2)-yl*EL%P%b0*0.5_dp*(x(2)**2+x(4)**2)
         endif 
!!
    endif

  END SUBROUTINE KICKPATHD

  SUBROUTINE INTER_TKTF(EL,X,k,pos)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(TKTF),INTENT(INOUT):: EL
    integer,optional :: pos
    INTEGER f1
    real(dp) DK,DK2,DK6,DK4,DK5
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    !   if(.not.CHECK_STABLE) return
    !   if(s_aperture_CHECK.and.associated(el%p%A).AND.CHECK_MADX_APERTURE)  &
    !    call check_S_APERTURE(el%p,pos,x)

    SELECT CASE(EL%P%METHOD)
    CASE(1)
       if(EL%F==1) then
          f1=0
       else
          f1=EL%F+1
       endif
       DK2=EL%L/(EL%P%NST/EL%F/2)
       DK=DK2/2.0_dp

       IF(MOD(POS,2*EL%F)==f1) THEN
          CALL KICKPATH(EL,DK,X,k)
          CALL KICKTKT7(EL,DK2,X,k)
          CALL KICKPATH(EL,DK,X,k)
       ENDIF
       CALL PUSHTKT7(EL,X,k)
    CASE(2)
       DK2=EL%L/EL%P%NST
       DK=DK2/2.0_dp

       CALL PUSHTKT7(EL,X,k)
       CALL KICKPATH(EL,DK,X,k)
       CALL KICKTKT7(EL,DK2,X,k)
       CALL KICKPATH(EL,DK,X,k)
       CALL PUSHTKT7(EL,X,k)

    CASE(3)

       if(EL%F==1) then
          f1=0
       else
          f1=EL%F+1
       endif
       DK=EL%L/(EL%P%NST/EL%F/2)/6.0_dp
       DK2=DK*2.0_dp
       DK6=2.0_dp*DK2

       if(mod(pos,EL%F*2)==F1) then
          CALL KICKPATH(EL,DK2,X,k)
          CALL KICKTKT7(EL,DK6,X,k)    ! 2/3
          CALL KICKPATH(EL,DK2,X,k)
          CALL PUSHTKT7(EL,X,k)
          if(f1==0.and.pos==EL%P%NST) then   ! this becomes nst
             CALL KICKPATH(EL,DK,X,k)
             CALL KICKTKT7(EL,DK,X,k)
          endif
       elseif(mod(pos,EL%F*2)==1.and.pos/=1) then
          CALL KICKPATH(EL,DK,X,k)
          CALL KICKTKT7(EL,DK2,X,k)    ! 1/3
          CALL KICKPATH(EL,DK,X,k)
          CALL PUSHTKT7(EL,X,k)
       elseif(pos==1) then             ! 1/6
          CALL KICKTKT7(EL,DK,X,k)
          CALL KICKPATH(EL,DK,X,k)
          CALL PUSHTKT7(EL,X,k)
       elseif(pos==EL%P%NST) then             ! 1/6
          CALL PUSHTKT7(EL,X,k)
          CALL KICKPATH(EL,DK,X,k)
          CALL KICKTKT7(EL,DK,X,k)
       else
          CALL PUSHTKT7(EL,X,k)
       endif


    CASE(4)
       DK2=EL%L/EL%P%NST/3.0_dp
       DK6=2.0_dp*DK2
       DK=DK2/2.0_dp

       CALL KICKTKT7(EL,DK,X,k)    ! NEW
       CALL KICKPATH(EL,DK,X,k)
       CALL PUSHTKT7(EL,X,k)
       CALL KICKPATH(EL,DK2,X,k)
       CALL KICKTKT7(EL,DK6,X,k)

       CALL KICKPATH(EL,DK2,X,k)
       CALL PUSHTKT7(EL,X,k)
       CALL KICKPATH(EL,DK,X,k)
       CALL KICKTKT7(EL,DK,X,k) ! NEW

    CASE(5)

       if(EL%F==1) then
          f1=0
       else
          f1=3*EL%F+1
       endif

       DK2=14.0_dp*EL%L/(EL%P%NST/EL%F/4)/90.0_dp  ! 14/90
       DK4=32.0_dp*EL%L/(EL%P%NST/EL%F/4)/90.0_dp  ! 32/90
       DK6=12.0_dp*EL%L/(EL%P%NST/EL%F/4)/90.0_dp  ! 12/90
       DK5=DK6/2.0_dp  ! 6/90
       DK=DK2/2.0_dp    ! 7/90

       if(mod(pos,EL%F*4)==EL%F+1) then
          CALL KICKTKT7(EL,DK4,X,k)  ! 32/90
          CALL KICKPATH(EL,DK4,X,k)  ! 32/90
          CALL PUSHTKT7(EL,X,k)
       elseif(mod(pos,EL%F*4)==f1) then
          CALL KICKPATH(EL,DK4,X,k)  ! 32/90
          CALL KICKTKT7(EL,DK4,X,k)  ! 32/90
          CALL PUSHTKT7(EL,X,k)
          if(f1==0.and.pos==EL%P%NST) then   ! this becomes nst
             CALL KICKPATH(EL,DK,X,k)  ! 7/90
             CALL KICKTKT7(EL,DK,X,k) !  7/90
          endif
       elseif(mod(pos,EL%F*4)==2*EL%F+1) then
          CALL KICKPATH(EL,DK5,X,k)  ! 6/90
          CALL KICKTKT7(EL,DK6,X,k)  ! 12/90
          CALL KICKPATH(EL,DK5,X,k)  ! 6/90
          CALL PUSHTKT7(EL,X,k)
       elseif(mod(pos,EL%F*4)==1.and.pos/=1) then
          CALL KICKPATH(EL,DK,X,k)  ! 7/90
          CALL KICKTKT7(EL,DK2,X,k) ! 14/90
          CALL KICKPATH(EL,DK,X,k)  ! 7/90
          CALL PUSHTKT7(EL,X,k)
       elseif(pos==1) then
          CALL KICKTKT7(EL,DK,X,k)  ! 7/90
          CALL KICKPATH(EL,DK,X,k)  ! 7/90
          CALL PUSHTKT7(EL,X,k)
       elseif(pos==EL%P%NST) then
          CALL PUSHTKT7(EL,X,k)
          CALL KICKPATH(EL,DK,X,k)  ! 7/90
          CALL KICKTKT7(EL,DK,X,k) !  7/90
       else
          CALL PUSHTKT7(EL,X,k)
       endif

    CASE(6)
       DK2=14.0_dp*EL%L/EL%P%NST/90.0_dp  ! 14/90
       DK4=32.0_dp*EL%L/EL%P%NST/90.0_dp  ! 32/90
       DK6=12.0_dp*EL%L/EL%P%NST/90.0_dp  ! 12/90
       DK5=DK6/2.0_dp  ! 6/90
       DK=DK2/2.0_dp    ! 7/90

       CALL KICKTKT7(EL,DK,X,k)  ! NEW
       CALL KICKPATH(EL,DK,X,k)

       CALL PUSHTKT7(EL,X,k)

       CALL KICKTKT7(EL,DK4,X,k)
       CALL KICKPATH(EL,DK4,X,k)

       CALL PUSHTKT7(EL,X,k)

       CALL KICKPATH(EL,DK5,X,k)
       CALL KICKTKT7(EL,DK6,X,k)   ! SYMMETRY POINT

       CALL KICKPATH(EL,DK5,X,k)

       CALL PUSHTKT7(EL,X,k)

       CALL KICKPATH(EL,DK4,X,k)
       CALL KICKTKT7(EL,DK4,X,k)

       CALL PUSHTKT7(EL,X,k)
       CALL KICKPATH(EL,DK,X,k)
       CALL KICKTKT7(EL,DK,X,k)  ! NEW

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT
    !       if(s_aperture_CHECK.and.associated(el%p%A).AND.CHECK_MADX_APERTURE) &
    !       call check_S_APERTURE_out(el%p,pos,x)

  END SUBROUTINE INTER_TKTF

  SUBROUTINE INTEP_TKTF(EL,X,k,pos)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(TKTFP),INTENT(INOUT):: EL
    integer,optional :: pos
    INTEGER f1
    TYPE(REAL_8) DK,DK2,DK6,DK4,DK5
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K



    SELECT CASE(EL%P%METHOD)
    CASE(1)
       CALL ALLOC(DK,DK2)
       if(EL%F==1) then
          f1=0
       else
          f1=EL%F+1
       endif
       DK2=EL%L/(EL%P%NST/EL%F/2)
       DK=DK2/2.0_dp

       IF(MOD(POS,2*EL%F)==f1) THEN
          CALL KICKPATH(EL,DK,X,k)
          CALL KICKTKT7(EL,DK2,X,k)
          CALL KICKPATH(EL,DK,X,k)
       ENDIF
       CALL PUSHTKT7(EL,X,k)
       CALL KILL(DK,DK2)
    CASE(2)
       CALL ALLOC(DK,DK2)

       DK2=EL%L/EL%P%NST
       DK=DK2/2.0_dp

       CALL PUSHTKT7(EL,X,k)
       CALL KICKPATH(EL,DK,X,k)
       CALL KICKTKT7(EL,DK2,X,k)
       CALL KICKPATH(EL,DK,X,k)
       CALL PUSHTKT7(EL,X,k)


       CALL KILL(DK,DK2)

    CASE(3)

       CALL ALLOC(DK,DK2,DK6)

       if(EL%F==1) then
          f1=0
       else
          f1=EL%F+1
       endif
       DK=EL%L/(EL%P%NST/EL%F/2)/6.0_dp
       DK2=DK*2.0_dp
       DK6=2.0_dp*DK2

       if(mod(pos,EL%F*2)==F1) then
          CALL KICKPATH(EL,DK2,X,k)
          CALL KICKTKT7(EL,DK6,X,k)    ! 2/3
          CALL KICKPATH(EL,DK2,X,k)
          CALL PUSHTKT7(EL,X,k)
          if(f1==0.and.pos==EL%P%NST) then   ! this becomes nst
             CALL KICKPATH(EL,DK,X,k)
             CALL KICKTKT7(EL,DK,X,k)
          endif
       elseif(mod(pos,EL%F*2)==1.and.pos/=1) then
          CALL KICKPATH(EL,DK,X,k)
          CALL KICKTKT7(EL,DK2,X,k)    ! 1/3
          CALL KICKPATH(EL,DK,X,k)
          CALL PUSHTKT7(EL,X,k)
       elseif(pos==1) then             ! 1/6
          CALL KICKTKT7(EL,DK,X,k)
          CALL KICKPATH(EL,DK,X,k)
          CALL PUSHTKT7(EL,X,k)
       elseif(pos==EL%P%NST) then             ! 1/6
          CALL PUSHTKT7(EL,X,k)
          CALL KICKPATH(EL,DK,X,k)
          CALL KICKTKT7(EL,DK,X,k)
       else
          CALL PUSHTKT7(EL,X,k)
       endif

       CALL KILL(DK,DK2,DK6)

    CASE(4)
       CALL ALLOC(DK,DK2,DK6)

       DK2=EL%L/EL%P%NST/3.0_dp
       DK6=2.0_dp*DK2
       DK=DK2/2.0_dp

       CALL KICKTKT7(EL,DK,X,k)    ! NEW
       CALL KICKPATH(EL,DK,X,k)
       CALL PUSHTKT7(EL,X,k)
       CALL KICKPATH(EL,DK2,X,k)
       CALL KICKTKT7(EL,DK6,X,k)

       CALL KICKPATH(EL,DK2,X,k)
       CALL PUSHTKT7(EL,X,k)
       CALL KICKPATH(EL,DK,X,k)
       CALL KICKTKT7(EL,DK,X,k) ! NEW

       CALL KILL(DK,DK2,DK6)

    CASE(5)

       CALL ALLOC(DK,DK2,DK6,DK4,DK5)
       if(EL%F==1) then
          f1=0
       else
          f1=3*EL%F+1
       endif

       DK2=14.0_dp*EL%L/(EL%P%NST/EL%F/4)/90.0_dp  ! 14/90
       DK4=32.0_dp*EL%L/(EL%P%NST/EL%F/4)/90.0_dp  ! 32/90
       DK6=12.0_dp*EL%L/(EL%P%NST/EL%F/4)/90.0_dp  ! 12/90
       DK5=DK6/2.0_dp  ! 6/90
       DK=DK2/2.0_dp    ! 7/90

       if(mod(pos,EL%F*4)==EL%F+1) then
          CALL KICKTKT7(EL,DK4,X,k)  ! 32/90
          CALL KICKPATH(EL,DK4,X,k)  ! 32/90
          CALL PUSHTKT7(EL,X,k)
       elseif(mod(pos,EL%F*4)==f1) then
          CALL KICKPATH(EL,DK4,X,k)  ! 32/90
          CALL KICKTKT7(EL,DK4,X,k)  ! 32/90
          CALL PUSHTKT7(EL,X,k)
          if(f1==0.and.pos==EL%P%NST) then   ! this becomes nst
             CALL KICKPATH(EL,DK,X,k)  ! 7/90
             CALL KICKTKT7(EL,DK,X,k) !  7/90
          endif
       elseif(mod(pos,EL%F*4)==2*EL%F+1) then
          CALL KICKPATH(EL,DK5,X,k)  ! 6/90
          CALL KICKTKT7(EL,DK6,X,k)  ! 12/90
          CALL KICKPATH(EL,DK5,X,k)  ! 6/90
          CALL PUSHTKT7(EL,X,k)
       elseif(mod(pos,EL%F*4)==1.and.pos/=1) then
          CALL KICKPATH(EL,DK,X,k)  ! 7/90
          CALL KICKTKT7(EL,DK2,X,k) ! 14/90
          CALL KICKPATH(EL,DK,X,k)  ! 7/90
          CALL PUSHTKT7(EL,X,k)
       elseif(pos==1) then
          CALL KICKTKT7(EL,DK,X,k)  ! 7/90
          CALL KICKPATH(EL,DK,X,k)  ! 7/90
          CALL PUSHTKT7(EL,X,k)
       elseif(pos==EL%P%NST) then
          CALL PUSHTKT7(EL,X,k)
          CALL KICKPATH(EL,DK,X,k)  ! 7/90
          CALL KICKTKT7(EL,DK,X,k) !  7/90
       else
          CALL PUSHTKT7(EL,X,k)
       endif
       CALL KILL(DK,DK2,DK6,DK4,DK5)

    CASE(6)
       CALL ALLOC(DK,DK2,DK6,DK4,DK5)

       DK2=14.0_dp*EL%L/EL%P%NST/90.0_dp
       DK4=32.0_dp*EL%L/EL%P%NST/90.0_dp
       DK6=12.0_dp*EL%L/EL%P%NST/90.0_dp
       DK5=DK6/2.0_dp
       DK=DK2/2.0_dp

       CALL KICKTKT7(EL,DK,X,k)  ! NEW
       CALL KICKPATH(EL,DK,X,k)

       CALL PUSHTKT7(EL,X,k)

       CALL KICKTKT7(EL,DK4,X,k)
       CALL KICKPATH(EL,DK4,X,k)

       CALL PUSHTKT7(EL,X,k)

       CALL KICKPATH(EL,DK5,X,k)
       CALL KICKTKT7(EL,DK6,X,k)   ! SYMMETRY POINT

       CALL KICKPATH(EL,DK5,X,k)

       CALL PUSHTKT7(EL,X,k)

       CALL KICKPATH(EL,DK4,X,k)
       CALL KICKTKT7(EL,DK4,X,k)

       CALL PUSHTKT7(EL,X,k)
       CALL KICKPATH(EL,DK,X,k)
       CALL KICKTKT7(EL,DK,X,k)  ! NEW

       CALL KILL(DK,DK2,DK6,DK4,DK5)

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

  END SUBROUTINE INTEP_TKTF

  SUBROUTINE INTTKT7R(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(TKTF),INTENT(INOUT):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    DO I=1,EL%P%NST
       IF(.NOT.PRESENT(MID))CALL TRACK_SLICE(EL,X,k,I)
       IF(PRESENT(MID)) CALL XMID(MID,X,I)
    ENDDO


  END SUBROUTINE INTTKT7R

  SUBROUTINE INTTKT7D(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: MID
    TYPE(TKTFP),INTENT(INOUT):: EL
    INTEGER I
    logical(lp) BN,L
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF((EL%BN(2)%KIND==3.OR.EL%L%KIND==3).AND.KNOB) THEN
       CALL GETMAT7(EL)                                      ! RECOMPUTES ONLY IF KNOB (SPEED)
    ENDIF

    DO I=1,EL%P%NST
       CALL TRACK_SLICE(EL,X,k,I)
    ENDDO

    IF(KNOB) THEN
       BN=.FALSE.
       L=.FALSE.
       IF(EL%BN(2)%KIND==3) THEN
          BN=.TRUE.
       ENDIF
       IF(EL%L%KIND==3) THEN
          L=.TRUE.
       ENDIF
       IF(BN.OR.L) THEN
          EL%BN(2)%KIND=1
          EL%L%KIND=1
          CALL KILL(EL)                               ! RECOMPUTES ONLY IF KNOB (SPEED)
          CALL ALLOC(EL)                               ! KNOB IS REMOVED THE SLOW WAY(SPEED)
          CALL GETMAT7(EL)
          IF(BN) EL%BN(2)%KIND=3
          IF(L)  EL%L%KIND=3
       ENDIF
    ENDIF


  END SUBROUTINE INTTKT7D

  SUBROUTINE SYMPINTTKT7R(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(TKTF),INTENT(INOUT):: EL
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(.NOT.PRESENT(MID))CALL TRACK_FRINGE(EL7=EL,X=X,k=k,J=1)
    CALL INTTKT7(EL,X,k,MID)
    IF(.NOT.PRESENT(MID))CALL TRACK_FRINGE(EL7=EL,X=X,k=k,J=2)


  END SUBROUTINE SYMPINTTKT7R

  SUBROUTINE SYMPINTTKT7D(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(TKTFP),INTENT(INOUT):: EL
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: MID
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    CALL TRACK_FRINGE(EL7=EL,X=X,k=k,J=1)
    CALL INTTKT7(EL,X,k)
    CALL TRACK_FRINGE(EL7=EL,X=X,k=k,J=2)

  END SUBROUTINE SYMPINTTKT7D

  SUBROUTINE EXPR7(H,MATOUT,LX)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: H(4,4),MATOUT(2,3),LX(3)
    real(dp) AD(4,4),TEMP(4,4)
    real(dp) NORM,NORM0,NORMAT,NORMAT0
    logical(lp) FIRST
    INTEGER I,J,K,N

    DO I=1,2
       DO J=1,3
          MATOUT(I,J)=0.0_dp
       ENDDO
    ENDDO
    DO I=1,3
       LX(I)=0.0_dp
    ENDDO

    DO I=1,4
       DO J=1,4
          AD(I,J)=0.0_dp
          TEMP(I,J)=0.0_dp
       ENDDO
    ENDDO
    MATOUT(1,1)=1.0_dp
    MATOUT(2,2)=1.0_dp
    AD(1,1)=1.0_dp
    AD(2,2)=1.0_dp
    AD(3,3)=1.0_dp
    AD(4,4)=1.0_dp
    FIRST=.TRUE.
    NORM=1e6_dp
    NORMAT=2e5_dp
    DO N=1,NMAXI
       !  COMPUTING H**N/N!
       DO I=1,4
          DO J=1,4
             DO K=1,4
                TEMP(I,K)=H(I,J)*AD(J,K)+TEMP(I,K)
             ENDDO
          ENDDO
       ENDDO
       NORM0=NORM
       NORMAT0=NORMAT
       !  ADDING TO MATOUT
       NORM=0.0_dp
       NORMAT=0.0_dp
       DO I=1,4   !2
          DO J=1,4
             AD(I,J)=TEMP(I,J)/N
             IF(I<3.AND.J<4)  THEN
                MATOUT(I,J)=MATOUT(I,J)+AD(I,J)
                NORMAT=NORMAT+ABS(MATOUT(I,J))
             ENDIF
             IF(I==4.AND.J<4) THEN
                LX(J)=LX(J)+AD(I,J)
                NORMAT=NORMAT+ABS(LX(J))
             ENDIF
             TEMP(I,J)=0.0_dp
          ENDDO
       ENDDO

       NORM=ABS(NORMAT-NORMAT0)


       IF(FIRST) THEN
          IF(NORM<EPS_DEF_KIND) THEN
             FIRST=.FALSE.
          ENDIF
       ELSE
          IF(NORM>=NORM0) GOTO 100
       ENDIF


    ENDDO

    w_p=0
    w_p%nc=1
    w_p%fc='(1(1X,A72))'
    write(w_p%c(1),'(A31,1X,I4,1X,A11)') " EXPSOLR FAILED TO CONVERGE IN ",NMAXI," ITERATIONS"
    ! call !write_e(0)

100 CONTINUE

  END SUBROUTINE EXPR7


  SUBROUTINE EXPD7(H,MATOUT,LX)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: H(4,4),MATOUT(2,3),LX(3)
    TYPE(REAL_8) AD(4,4),TEMP(4,4)
    real(dp) NORM,NORM0,NORMAT,NORMAT0
    logical(lp) FIRST
    INTEGER I,J,K,N

    DO I=1,2
       DO J=1,3
          MATOUT(I,J)=0.0_dp
       ENDDO
    ENDDO
    DO I=1,3
       LX(I)=0.0_dp
    ENDDO

    DO I=1,4
       DO J=1,4
          CALL ALLOC(AD(I,J))
          CALL ALLOC(TEMP(I,J))
       ENDDO
    ENDDO
    MATOUT(1,1)=1.0_dp
    MATOUT(2,2)=1.0_dp
    AD(1,1)=1.0_dp
    AD(2,2)=1.0_dp
    AD(3,3)=1.0_dp
    AD(4,4)=1.0_dp
    FIRST=.TRUE.
    NORM=1e6_dp
    NORMAT=2e5_dp
    DO N=1,NMAXI
       !  COMPUTING H**N/N!
       DO I=1,4
          DO J=1,4
             DO K=1,4
                TEMP(I,K)=H(I,J)*AD(J,K)+TEMP(I,K)
             ENDDO
          ENDDO
       ENDDO
       NORM0=NORM
       NORMAT0=NORMAT
       !  ADDING TO MATOUT
       NORM=0.0_dp
       NORMAT=0.0_dp
       DO I=1,4   !2
          DO J=1,4
             AD(I,J)=TEMP(I,J)/N

             IF(I<3.AND.J<4)  THEN
                MATOUT(I,J)=MATOUT(I,J)+AD(I,J)
                NORMAT=NORMAT+ABS(MATOUT(I,J))
             ENDIF
             IF(I==4.AND.J<4) THEN
                LX(J)=LX(J)+AD(I,J)
                NORMAT=NORMAT+ABS(LX(J))
             ENDIF
             TEMP(I,J)=0.0_dp
          ENDDO
       ENDDO
       NORM=ABS(NORMAT-NORMAT0)


       IF(FIRST) THEN
          IF(NORM<EPS_DEF_KIND) THEN
             FIRST=.FALSE.
          ENDIF
       ELSE
          IF(NORM>=NORM0) GOTO 100
       ENDIF


    ENDDO

    w_p=0
    w_p%nc=1
    w_p%fc='(1(1X,A72))'
    write(w_p%c(1),'(A31,1X,I4,1X,A11)') " EXPSOLR FAILED TO CONVERGE IN ",NMAXI," ITERATIONS"
    ! call !write_e(0)

100 CONTINUE

    DO I=1,4
       DO J=1,4
          CALL KILL(AD(I,J))
          CALL KILL(TEMP(I,J))
       ENDDO
    ENDDO


  END SUBROUTINE EXPD7

!!!!!!!!!!!!!!!!!!!!  the smi  !!!!!!!!!!!!!!!!!!!!!!!!!!!

  subroutine push_Nsmi_r(el,x,k,MID)
    implicit none
    TYPE (NSMI),INTENT(IN)::EL
    TYPE(WORM), OPTIONAL,INTENT(INOUT):: MID
    real(dp) ,INTENT(INOUT)::x(6)
    real(dp) ekk,CRKVE,CIKVE,CRKVEUK,XL,ZL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    XL=X(1)
    ZL=X(3)
    CRKVE=XL
    CIKVE=ZL

    EKK=-EL%P%DIR*EL%P%CHARGE*EL%BN(EL%P%NMUL)/2.0_dp                      ! ANTI-SIXTRACK UNIT

    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    select case(el%P%NMUL)


       !--HORIZONTAL DIPOLE
    case(1)
       X(2)=X(2)+EKK
       !--NORMAL QUADRUPOLE
    case(2)
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL SEXTUPOLE
    case(3)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !--NORMAL OCTUPOLE
    case(4)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !--NORMAL DECAPOLE
    case(5)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL DODECAPOL
    case(6)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 14-POL
    case(7)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 16-POL
    case(8)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 18-POL
    case(9)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 20-POL
    case(10)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
    END SELECT

    IF(PRESENT(MID)) CALL XMID(MID,X,1)

    select case(el%P%NMUL)


       !--HORIZONTAL DIPOLE
    case(1)
       X(2)=X(2)+EKK
       !--NORMAL QUADRUPOLE
    case(2)
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL SEXTUPOLE
    case(3)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !--NORMAL OCTUPOLE
    case(4)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !--NORMAL DECAPOLE
    case(5)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL DODECAPOL
    case(6)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 14-POL
    case(7)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 16-POL
    case(8)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 18-POL
    case(9)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 20-POL
    case(10)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
    END SELECT

    !    IF(PRESENT(MID)) CALL XMID(MID,X,2)

  end subroutine push_Nsmi_r

  subroutine push_Nsmi_D(el,x,k)
    implicit none
    TYPE (NSMIP),INTENT(IN)::EL
    ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: MID
    TYPE(real_8) ,INTENT(INOUT)::x(6)
    TYPE(real_8)ekk,CRKVE,CIKVE,CRKVEUK,XL,ZL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(ekk);CALL ALLOC(CRKVE);CALL ALLOC(CIKVE);
    CALL ALLOC(CRKVEUK);CALL ALLOC(XL);CALL ALLOC(ZL);

    XL=X(1)
    ZL=X(3)
    CRKVE=XL
    CIKVE=ZL

    EKK=-EL%P%DIR*EL%P%CHARGE*EL%BN(EL%P%NMUL)/2.0_dp                      ! ANTI-SIXTRACK UNIT

    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    select case(el%P%NMUL)


       !--HORIZONTAL DIPOLE
    case(1)
       X(2)=X(2)+EKK
       !--NORMAL QUADRUPOLE
    case(2)
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL SEXTUPOLE
    case(3)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !--NORMAL OCTUPOLE
    case(4)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !--NORMAL DECAPOLE
    case(5)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL DODECAPOL
    case(6)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 14-POL
    case(7)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 16-POL
    case(8)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 18-POL
    case(9)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 20-POL
    case(10)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
    END SELECT

    !    IF(PRESENT(MID)) CALL XMID(MID,X,1)

    select case(el%P%NMUL)


       !--HORIZONTAL DIPOLE
    case(1)
       X(2)=X(2)+EKK
       !--NORMAL QUADRUPOLE
    case(2)
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL SEXTUPOLE
    case(3)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !--NORMAL OCTUPOLE
    case(4)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !--NORMAL DECAPOLE
    case(5)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL DODECAPOL
    case(6)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 14-POL
    case(7)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 16-POL
    case(8)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 18-POL
    case(9)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
       !---NORMAL 20-POL
    case(10)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CRKVE
       X(4)=X(4)-EKK*CIKVE
    END SELECT

    !    IF(PRESENT(MID)) CALL XMID(MID,X,2)

    CALL KILL(ekk);CALL KILL(CRKVE);CALL KILL(CIKVE);
    CALL KILL(CRKVEUK);CALL KILL(XL);CALL KILL(ZL);



  end subroutine push_Nsmi_D

  subroutine push_Ssmi_r(el,x,k,MID)
    implicit none
    TYPE (SSMI),INTENT(IN)::EL
    TYPE(WORM), OPTIONAL,INTENT(INOUT):: MID
    real(dp) ,INTENT(INOUT)::x(6)
    real(dp) ekk,CRKVE,CIKVE,CRKVEUK,XL,ZL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    XL=X(1)
    ZL=X(3)
    CRKVE=XL
    CIKVE=ZL

    EKK=EL%P%DIR*EL%P%CHARGE*EL%AN(EL%P%NMUL)/2.0_dp
    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    select case(el%P%NMUL)

       !---VERTICAL DIPOLE
    CASE(1)
       X(4)=X(4)+EKK
       !---SKEW QUADRUPOLE
    CASE(2)
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW SEXTUPOLE
    CASE(3)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW OCTUPOLE
    CASE(4)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW DECAPOLE
    CASE(5)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW DODECAPOL
    CASE(6)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 14-POL
    CASE(7)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 16-POL
    CASE(8)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 18-POL
    CASE(9)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 20-POL
    CASE(10)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE

    END SELECT

    IF(PRESENT(MID)) CALL XMID(MID,X,1)

    select case(el%P%NMUL)

       !---VERTICAL DIPOLE
    CASE(1)
       X(4)=X(4)+EKK
       !---SKEW QUADRUPOLE
    CASE(2)
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW SEXTUPOLE
    CASE(3)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW OCTUPOLE
    CASE(4)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW DECAPOLE
    CASE(5)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW DODECAPOL
    CASE(6)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 14-POL
    CASE(7)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 16-POL
    CASE(8)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 18-POL
    CASE(9)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 20-POL
    CASE(10)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE

    END SELECT
    !    IF(PRESENT(MID)) CALL XMID(MID,X,2)

  end subroutine push_Ssmi_r

  subroutine push_Ssmi_D(el,x,k)
    implicit none
    TYPE (SSMIP),INTENT(IN)::EL
    ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: MID
    TYPE(real_8) ,INTENT(INOUT)::x(6)
    TYPE(real_8)ekk,CRKVE,CIKVE,CRKVEUK,XL,ZL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(ekk);CALL ALLOC(CRKVE);CALL ALLOC(CIKVE);
    CALL ALLOC(CRKVEUK);CALL ALLOC(XL);CALL ALLOC(ZL);

    XL=X(1)
    ZL=X(3)
    CRKVE=XL
    CIKVE=ZL

    EKK=EL%P%DIR*EL%P%CHARGE*EL%AN(EL%P%NMUL)/2.0_dp
    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    select case(el%P%NMUL)

       !---VERTICAL DIPOLE
    CASE(1)
       X(4)=X(4)+EKK
       !---SKEW QUADRUPOLE
    CASE(2)
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW SEXTUPOLE
    CASE(3)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW OCTUPOLE
    CASE(4)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW DECAPOLE
    CASE(5)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW DODECAPOL
    CASE(6)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 14-POL
    CASE(7)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 16-POL
    CASE(8)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 18-POL
    CASE(9)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 20-POL
    CASE(10)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE

    END SELECT

    !    IF(PRESENT(MID)) CALL XMID(MID,X,1)

    select case(el%P%NMUL)

       !---VERTICAL DIPOLE
    CASE(1)
       X(4)=X(4)+EKK
       !---SKEW QUADRUPOLE
    CASE(2)
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW SEXTUPOLE
    CASE(3)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW OCTUPOLE
    CASE(4)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW DECAPOLE
    CASE(5)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW DODECAPOL
    CASE(6)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 14-POL
    CASE(7)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 16-POL
    CASE(8)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 18-POL
    CASE(9)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE
       !---SKEW 20-POL
    CASE(10)
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       CRKVEUK=CRKVE*XL-CIKVE*ZL
       CIKVE=CRKVE*ZL+CIKVE*XL
       CRKVE=CRKVEUK
       X(2)=X(2)+EKK*CIKVE
       X(4)=X(4)+EKK*CRKVE

    END SELECT
    !    IF(PRESENT(MID)) CALL XMID(MID,X,2)

    CALL KILL(ekk);CALL KILL(CRKVE);CALL KILL(CIKVE);
    CALL KILL(CRKVEUK);CALL KILL(XL);CALL KILL(ZL);

  end subroutine push_Ssmi_D

!!!! *************************************************************** !!!!
!!!! *           Beginning of the teapot element                   * !!!!
!!!! *************************************************************** !!!!
  SUBROUTINE GETANBNR(EL)
    IMPLICIT NONE
    TYPE(TEAPOT),INTENT(INOUT):: EL
    INTEGER I,J,K,POW,nmul

    !    nmul=EL%P%NMUL
    !    IF(EL%P%NMUL> SECTOR_NMUL) THEN

    nmul=SECTOR_NMUL

    !    ENDIF

    DO I=1,S_B(NMUL)%N_MONO
       EL%BF_X(I)=0.0_dp
       EL%BF_Y(I)=0.0_dp
    ENDDO
    DO I=1,NMUL
       DO J=1,S_B(NMUL)%N_MONO
          K=S_B(NMUL)%I(J)+S_B(NMUL)%J(J)
          POW=K+1-I
          IF(K+1>=I) THEN


             EL%BF_X(J)=EL%BF_X(J)+(EL%AN(I)*S_B(NMUL)%A_X(I,J)+EL%BN(I)*S_B(NMUL)%B_X(I,J))*EL%P%B0**POW
             EL%BF_Y(J)=EL%BF_Y(J)+(EL%AN(I)*S_B(NMUL)%A_Y(I,J)+EL%BN(I)*S_B(NMUL)%B_Y(I,J))*EL%P%B0**POW

          ENDIF
       ENDDO
    ENDDO


  END SUBROUTINE GETANBNR

  SUBROUTINE GETANBNP(EL)
    IMPLICIT NONE
    TYPE(TEAPOTP),INTENT(INOUT):: EL
    INTEGER I,J,K,POW,nmul

    !    nmul=EL%P%NMUL
    !    IF(EL%P%NMUL> SECTOR_NMUL) THEN

    nmul=SECTOR_NMUL

    !    ENDIF

    DO I=1,S_B(NMUL)%N_MONO
       EL%BF_X(I)=0.0_dp
       EL%BF_Y(I)=0.0_dp
    ENDDO
    DO I=1,NMUL
       DO J=1,S_B(NMUL)%N_MONO
          K=S_B(NMUL)%I(J)+S_B(NMUL)%J(J)
          POW=K+1-I
          IF(K+1>=I) THEN

             EL%BF_X(J)=EL%BF_X(J)+(EL%AN(I)*S_B(NMUL)%A_X(I,J)+EL%BN(I)*S_B(NMUL)%B_X(I,J))*EL%P%B0**POW
             EL%BF_Y(J)=EL%BF_Y(J)+(EL%AN(I)*S_B(NMUL)%A_Y(I,J)+EL%BN(I)*S_B(NMUL)%B_Y(I,J))*EL%P%B0**POW

          ENDIF
       ENDDO
    ENDDO

  END SUBROUTINE GETANBNP



  SUBROUTINE GETELECTRICR(EL,X)
    IMPLICIT NONE
    TYPE(TEAPOT),INTENT(INOUT):: EL
    REAL(DP), INTENT(IN) :: X(6)
    REAL(DP) VAL(0:NO_E,0:NO_E),V
    INTEGER I,J,K,POW

!    VAL(0,0)=1

    val(0,0)=1.0_dp
    val(1,0)=x(1)
    val(0,1)=x(3)
    
    do pow=2,NO_E
     val(0,pow)=val(0,pow-1)*x(3)
     val(pow,0)=val(pow-1,0)*x(1)
     do j=1,pow-1
      k=pow-j
      val(j,k)=val(j-1,k-1)*x(1)*x(3)
     enddo
    enddo

      EL%E_X=0.0_dp
      EL%E_Y=0.0_dp
      EL%PHI=0.0_dp
      
      do i=0,NO_E
      do j=0,NO_E  
      if(i+j>NO_E) cycle 
      DO K=1,NO_E
       V=EL%AE(K)*EL%AS(k,i,j)+EL%BE(K)*EL%BS(k,i,j)
                     
       EL%PHI=EL%PHI+val(i,j)*V
       IF(I/=0) EL%E_X=EL%E_X-val(i-1,j)*I*V
       IF(J/=0) EL%E_Y=EL%E_Y-val(i,j-1)*I*V
      enddo
      
      enddo
      enddo

  END SUBROUTINE GETELECTRICR

  SUBROUTINE GETELECTRICP(EL,X)
    IMPLICIT NONE
    TYPE(TEAPOTP),INTENT(INOUT):: EL
    type(real_8), INTENT(IN) :: X(6)
    type(real_8)  VAL(0:NO_E,0:NO_E),V
    INTEGER I,J,K,POW

    call alloc(v)
    do i=0,no_e
    do j=0,no_e
    call alloc(val(i,j))
    enddo
    enddo

!    VAL(0,0)=1

    val(0,0)=1.0_dp
    val(1,0)=x(1)
    val(0,1)=x(3)
    
    do pow=2,NO_E
     val(0,pow)=val(0,pow-1)*x(3)
     val(pow,0)=val(pow-1,0)*x(1)
     do j=1,pow-1
      k=pow-j
      val(j,k)=val(j-1,k-1)*x(1)*x(3)
     enddo
    enddo

      EL%E_X=0.0_dp
      EL%E_Y=0.0_dp
      EL%PHI=0.0_dp
      
      do i=0,NO_E
      do j=0,NO_E  
      if(i+j>NO_E) cycle 
      DO K=1,NO_E
       V=EL%AE(K)*EL%AS(k,i,j)+EL%BE(K)*EL%BS(k,i,j)
                     
       EL%PHI=EL%PHI+val(i,j)*V
       IF(I/=0) EL%E_X=EL%E_X-val(i-1,j)*I*V
       IF(J/=0) EL%E_Y=EL%E_Y-val(i,j-1)*I*V
      enddo
      
      enddo
      enddo

    call kill(v)
    do i=0,no_e
    do j=0,no_e
    call kill(val(i,j))
    enddo
    enddo


  END SUBROUTINE GETELECTRICP

  SUBROUTINE GETMULB_TEAPOTR(EL,B,X)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6),B(3)
    TYPE(TEAPOT),INTENT(IN):: EL
    real(dp) X1,X3,BX,BY,BTX,BTY,BtYT
    INTEGER J,M,A,K

    X1=X(1)
    X3=X(3)

    BX=0.0_dp
    BY=0.0_dp

    k=0
    m=EL%P%nmul-1
    do a=m,1,-1
       BTX=0.0_dp
       BTY=0.0_dp
       do j=m-a,1,-1
          k=k+1
          !b%i(k)=a
          !b%j(k)=j
          BTX= (BTX+EL%BF_X(k))*X3  !x1
          BTY= (BTY+EL%BF_Y(k))*X3
       enddo

       k=k+1
       !  b%i(k)=a
       !  b%j(k)=0
       BTX= (BTX+EL%BF_X(k))
       BTY= (BTY+EL%BF_Y(k))
       BX= (BX+BTX)*X1
       BY= (BY+BTY)*X1
    enddo
    BTX=0.0_dp
    BTY=0.0_dp
    do j=m,1,-1
       k=k+1
       !  b%i(k)=0
       !  b%j(k)=j
       BTX= (BTX+EL%BF_X(k))*X3
       BTY= (BTY+EL%BF_Y(k))*X3
    enddo
    k=k+1
    !    b%i(k)=0
    !    b%j(k)=0
    BX= BX+BTX+EL%BF_X(k)  !+X3
    BY= BY+BTY+EL%BF_Y(k)  !+X3

    ! etienne
    IF(EL%P%NMUL>SECTOR_NMUL) THEN
       BtY=EL%BN(EL%P%NMUL)
       BtX=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,SECTOR_NMUL+1,-1
          BtYT=X1*BtY-X3*BtX+EL%BN(J)
          BtX =X3*BtY+X1*BtX+EL%AN(J)
          BtY =BtYT
       ENDDO

       DO  J=SECTOR_NMUL, 1,-1
          BtYT=X1*BtY-X3*BtX
          BtX =X3*BtY+X1*BtX
          BtY =BtYT
       ENDDO

       BX= BX-BTy       !!!! bug 2011 JUly 18
       BY= BY+BTx       !!!! bug 2011 JUly 18

    ENDIF



    B(1)=BY/(1.0_dp+EL%P%B0*X(1))
    B(2)=-BX/(1.0_dp+EL%P%B0*X(1))
    B(3)=0.0_dp

  END SUBROUTINE GETMULB_TEAPOTR

  SUBROUTINE GETMULB_TEAPOTP(EL,B,X)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6),B(3)
    TYPE(TEAPOTP),INTENT(IN):: EL
    TYPE(REAL_8) X1,X3,BX,BY,BTX,BTY,BtYT
    INTEGER J,M,A,K

    CALL ALLOC(X1,X3,BX,BY,BTX,BTY,BtYT)

    X1=X(1)
    X3=X(3)

    BX=0.0_dp
    BY=0.0_dp

    k=0
    m=EL%P%nmul-1
    do a=m,1,-1
       BTX=0.0_dp
       BTY=0.0_dp
       do j=m-a,1,-1
          k=k+1
          !b%i(k)=a
          !b%j(k)=j
          BTX= (BTX+EL%BF_X(k))*X3  !x1
          BTY= (BTY+EL%BF_Y(k))*X3
       enddo

       k=k+1
       !  b%i(k)=a
       !  b%j(k)=0
       BTX= (BTX+EL%BF_X(k))
       BTY= (BTY+EL%BF_Y(k))
       BX= (BX+BTX)*X1
       BY= (BY+BTY)*X1
    enddo
    BTX=0.0_dp
    BTY=0.0_dp
    do j=m,1,-1
       k=k+1
       !  b%i(k)=0
       !  b%j(k)=j
       BTX= (BTX+EL%BF_X(k))*X3
       BTY= (BTY+EL%BF_Y(k))*X3
    enddo
    k=k+1
    !    b%i(k)=0
    !    b%j(k)=0
    BX= BX+BTX+EL%BF_X(k)  !+X3
    BY= BY+BTY+EL%BF_Y(k)  !+X3

    ! etienne
    IF(EL%P%NMUL>SECTOR_NMUL) THEN
       BtY=EL%BN(EL%P%NMUL)
       BtX=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,SECTOR_NMUL+1,-1
          BtYT=X1*BtY-X3*BtX+EL%BN(J)
          BtX =X3*BtY+X1*BtX+EL%AN(J)
          BtY =BtYT
       ENDDO

       DO  J=SECTOR_NMUL, 1,-1
          BtYT=X1*BtY-X3*BtX
          BtX =X3*BtY+X1*BtX
          BtY =BtYT
       ENDDO

       BX= BX-BTy       !!!! bug 2011 JUly 18
       BY= BY+BTx       !!!! bug 2011 JUly 18

    ENDIF



    B(1)=BY/(1.0_dp+EL%P%B0*X(1))
    B(2)=-BX/(1.0_dp+EL%P%B0*X(1))
    B(3)=0.0_dp

    CALL KILL(X1,X3,BX,BY,BTX,BTY,BtYT)

  END SUBROUTINE GETMULB_TEAPOTP


  ! cav_trav

  subroutine feval_teapotr(X,k,f,EL)   ! MODELLED BASED ON DRIFT
    IMPLICIT NONE
    real(dp), INTENT(INout) :: X(6)
    real(dp), INTENT(INOUT) :: F(6)
    REAL(DP) PZ,DEL,H,B(3)
    TYPE(teapot),  INTENT(INOUT) :: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
 
     call GETELECTRIC(EL,X)
     CALL GETMULB_TEAPOT(EL,B,X)
     IF(EL%P%EXACT) THEN
        if(k%TIME) then
           H=1.0_dp+EL%P%B0*X(1)
           DEL=1.0_dp/EL%P%BETA0+x(5)-EL%PHI
           PZ=ROOT(DEL**2-1.0_dp/EL%P%GAMBET**2-X(2)**2-X(4)**2)
           F(1)=X(2)*H/PZ
           F(3)=X(4)*H/PZ
           F(2)=EL%P%B0*PZ-B(2)*H+H*DEL*EL%E_X/PZ
           F(4)=B(1)*H+H*DEL*EL%E_Y/PZ
           F(5)=0.0_dp
           F(6)=H*DEL/PZ
        else
           H=1.0_dp+X(1)
           DEL=1.0_dp+x(5)-EL%PHI
           PZ=ROOT(DEL**2-X(2)**2-X(4)**2)
           F(1)=X(2)*H/PZ
           F(3)=X(4)*H/PZ
           F(2)=EL%P%B0*PZ-B(2)*H+H*DEL*EL%E_X/PZ
           F(4)=B(1)*H+H*DEL*EL%E_Y/PZ
           F(5)=0.0_dp
           F(6)=H*DEL/PZ
        endif
     ELSE
      STOP 468
!        if(k%TIME) then
!        else
!        endif
     ENDIF
     
   END subroutine feval_teapotr
 
  subroutine feval_teapotp(X,k,f,EL)   ! MODELLED BASED ON DRIFT
    IMPLICIT NONE
    type(real_8), INTENT(INout) :: X(6)
    type(real_8),  INTENT(INOUT) :: F(6)
    type(real_8) PZ,DEL,H,B(3)
    TYPE(teapotp),  INTENT(INOUT) :: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
     
     call alloc(PZ,DEL,H,B(1),B(2),B(3))
     call GETELECTRIC(EL,X)
     CALL GETMULB_TEAPOT(EL,B,X)
     IF(EL%P%EXACT) THEN
        if(k%TIME) then
           H=1.0_dp+EL%P%B0*X(1)
           DEL=1.0_dp/EL%P%BETA0+x(5)-EL%PHI
           PZ=SQRT(DEL**2-1.0_dp/EL%P%GAMBET**2-X(2)**2-X(4)**2)
           F(1)=X(2)*H/PZ
           F(3)=X(4)*H/PZ
           F(2)=EL%P%B0*PZ-B(2)*H+H*DEL*EL%E_X/PZ
           F(4)=B(1)*H+H*DEL*EL%E_Y/PZ
           F(5)=0.0_dp
           F(6)=H*DEL/PZ
        else
           H=1.0_dp+X(1)
           DEL=1.0_dp+x(5)-EL%PHI
           PZ=SQRT(DEL**2-X(2)**2-X(4)**2)
           F(1)=X(2)*H/PZ
           F(3)=X(4)*H/PZ
           F(2)=EL%P%B0*PZ-B(2)*H+H*DEL*EL%E_X/PZ
           F(4)=B(1)*H+H*DEL*EL%E_Y/PZ
           F(5)=0.0_dp
           F(6)=H*DEL/PZ
        endif
     ELSE
      STOP 468
!        if(k%TIME) then
!        else
!        endif
     ENDIF
     call KILL(PZ,DEL,H,B(1),B(2),B(3))
     
   END subroutine feval_teapotp
 
   subroutine rk2_teapotr(h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    real(dp), INTENT(INOUT)::  y(ne)
    real(dp)  yt(ne),f(ne),a(ne),b(ne)
    type (teapot) ,INTENT(INOUT)::  GR
    integer j
    real(dp), intent(inout) :: h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call feval_teapot(y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+b(j)
    enddo

    return
  end  subroutine rk2_teapotr

  ! 2 order Runge
  subroutine rk2_teapotp(h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    type (real_8), INTENT(INOUT)::  y(ne)
    type (real_8)  yt(ne),f(ne),a(ne),b(ne)
    type (teapotp) ,INTENT(INOUT)::  GR
    integer j
    type(real_8), intent(inout) :: h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call alloc(yt,ne)
    call alloc(f,ne)
    call alloc(a,ne)
    call alloc(b,ne)


    call feval_teapot(y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+b(j)
    enddo

    call kill(yt,ne)
    call kill(f,ne)
    call kill(a,ne)
    call kill(b,ne)

    return
  end  subroutine rk2_teapotp

  subroutine rk4_teapotr(h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    real(dp), INTENT(INOUT)::  y(ne)
    real(dp)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne)
    type (teapot) ,INTENT(INOUT)::  GR
    integer j
    real(dp), intent(inout) :: h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    call feval_teapot(y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + b(j)/2.0_dp
    enddo


    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+c(j)
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo


    do  j=1,ne
       y(j) = y(j)+(a(j)+2.0_dp*b(j)+2.0_dp*c(j)+d(j))/6.0_dp
    enddo

    return
  end  subroutine rk4_teapotr

  subroutine rk4_teapotp(h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    type(real_8), INTENT(INOUT)::  y(ne)
    type (teapotp) ,INTENT(INOUT)::  GR
    type(real_8), intent(inout) :: h
    type(real_8)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne)
    integer j
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call alloc(yt)
    call alloc(f)
    call alloc(a)
    call alloc(b)
    call alloc(c)
    call alloc(d)

    call feval_teapot(y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + b(j)/2.0_dp
    enddo


    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+c(j)
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo


    do  j=1,ne
       y(j) = y(j)+(a(j)+2.0_dp*b(j)+2.0_dp*c(j)+d(j))/6.0_dp
    enddo

    call kill(yt)
    call kill(f)
    call kill(a)
    call kill(b)
    call kill(c)
    call kill(d)

    return
  end  subroutine rk4_teapotp

  subroutine rk6_teapotr(h,GR,y,k)
    IMPLICIT none
    !  Written by Rob Ryne, Spring 1986, based on a routine of
    !c  J. Milutinovic.
    !c  For a reference, see page 76 of F. Ceschino and J Kuntzmann,
    !c  Numerical Solution of Initial Value Problems, Prentice Hall 1966.
    !c  This integration routine makes local truncation errors at each
    !c  step of order h**7.
    !c  That is, it is locally correct through terms of order h**6.
    !c  Each step requires 8 function evaluations.

    integer ne
    parameter (ne=6)
    real(dp), INTENT(INOUT)::  y(ne)
    real(dp)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne),e(ne),g(ne),o(ne),p(ne)
    type (teapot) ,INTENT(INOUT)::  GR
    integer j
    real(dp), intent(inout) :: h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    call feval_teapot(y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/9.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + (a(j) + 3.0_dp*b(j))/24.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j)+(a(j)-3.0_dp*b(j)+4.0_dp*c(j))/6.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (-5.0_dp*a(j) + 27.0_dp*b(j) - 24.0_dp*c(j) + 6.0_dp*d(j))/8.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       e(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (221.0_dp*a(j) - 981.0_dp*b(j) + 867.0_dp*c(j)- 102.0_dp*d(j) + e(j))/9.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do   j=1,ne
       g(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(-183.0_dp*a(j)+678.0_dp*b(j)-472.0_dp*c(j)-66.0_dp*d(j)+80.0_dp*e(j) + 3.0_dp*g(j))/48.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       o(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(716.0_dp*a(j)-2079.0_dp*b(j)+1002.0_dp*c(j)+834.0_dp*d(j)-454.0_dp*e(j)-9.0_dp*g(j)+72.0_dp*o(j))/82.0_dp
    enddo


    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       p(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+(41.0_dp*a(j)+216.0_dp*c(j)+27.0_dp*d(j)+272.0_dp*e(j)+27.0_dp*g(j)+216.0_dp*o(j)+41.0_dp*p(j))/840.0_dp
    enddo


    return
  end  subroutine rk6_teapotr



  ! sixth order Runge
  subroutine rk6_teapotp(h,GR,y,k)
    IMPLICIT none


    integer ne
    parameter (ne=6)
    type (real_8), INTENT(INOUT)::  y(ne)
    type (real_8)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne),e(ne),g(ne),o(ne),p(ne)
    type (teapotp) ,INTENT(INOUT)::  GR
    integer j
    type(real_8), intent(inout) :: h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call alloc(yt,ne)
    call alloc(f,ne)
    call alloc(a,ne)
    call alloc(b,ne)
    call alloc(c,ne)
    call alloc(d,ne)
    call alloc(e,ne)
    call alloc(g,ne)
    call alloc(o,ne)
    call alloc(p,ne)

    call feval_teapot(y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/9.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + (a(j) + 3.0_dp*b(j))/24.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j)+(a(j)-3.0_dp*b(j)+4.0_dp*c(j))/6.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (-5.0_dp*a(j) + 27.0_dp*b(j) - 24.0_dp*c(j) + 6.0_dp*d(j))/8.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       e(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (221.0_dp*a(j) - 981.0_dp*b(j) + 867.0_dp*c(j)- 102.0_dp*d(j) + e(j))/9.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do   j=1,ne
       g(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(-183.0_dp*a(j)+678.0_dp*b(j)-472.0_dp*c(j)-66.0_dp*d(j)+80.0_dp*e(j) + 3.0_dp*g(j))/48.0_dp
    enddo

    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       o(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(716.0_dp*a(j)-2079.0_dp*b(j)+1002.0_dp*c(j)+834.0_dp*d(j)-454.0_dp*e(j)-9.0_dp*g(j)+72.0_dp*o(j))/82.0_dp
    enddo


    call feval_teapot(yt,k,f,gr)
    do  j=1,ne
       p(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+(41.0_dp*a(j)+216.0_dp*c(j)+27.0_dp*d(j)+272.0_dp*e(j)+27.0_dp*g(j)+216.0_dp*o(j)+41.0_dp*p(j))/840.0_dp
    enddo

    call kill(yt,ne)
    call kill(f,ne)
    call kill(a,ne)
    call kill(b,ne)
    call kill(c,ne)
    call kill(d,ne)
    call kill(e,ne)
    call kill(g,ne)
    call kill(o,ne)
    call kill(p,ne)

    return
  end  subroutine rk6_teapotp
 
   SUBROUTINE SSECH1R(EL,YL,DL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN):: YL,DL
    TYPE(TEAPOT),INTENT(IN):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    ! if(abs(x(1))+abs(x(3))+abs(x(2))+abs(x(4))>absolute_aperture.or.(.not.CHECK_MADX_APERTURE)) then
    !    if(CHECK_MADX_APERTURE) c_%message="exceed absolute_aperture in SSECH1R"
    !    CHECK_STABLE=.false.
    ! endif
    ! if(.not.CHECK_STABLE) return

    IF(EL%DRIFTKICK) THEN
       CALL Sprot(EL,YL,DL,X,k)
    ELSE
       CALL SSEC(EL,YL,DL,X,k)
    ENDIF

  END SUBROUTINE SSECH1R

  SUBROUTINE SSECH1P(EL,YL,DL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN):: YL
    real(dp),INTENT(IN):: DL
    TYPE(TEAPOTP),INTENT(IN):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(EL%DRIFTKICK) THEN
       CALL Sprot(EL,YL,DL,X,k)
    ELSE
       CALL SSEC(EL,YL,DL,X,k)
    ENDIF

  END SUBROUTINE SSECH1P

  SUBROUTINE Sprotr(EL,YL,DL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN):: YL,DL
    TYPE(TEAPOT),INTENT(IN):: EL
    real(dp) XN(6),PZ,PT
    real(dp)  A,b,R
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    if(EL%P%B0/=0.0_dp) then
       A=YL*EL%P%B0
       R=1.0_dp/EL%P%B0
       if(k%TIME) then
          B=EL%P%BETA0
          PZ=ROOT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(2)**2-X(4)**2)
          PT=1.0_dp-X(2)*TAN(A)/PZ
          !       XN(1)=(X(1)+R)/COS(A)/PT-R
          XN(1)=(X(1)+R*(2.0_dp*sin(a/2.0_dp)**2+X(2)*sin(A)/PZ))/COS(A)/PT
          XN(2)=X(2)*COS(A)+SIN(A)*PZ
          XN(3)=X(3)+X(4)*(X(1)+R)*TAN(A)/PZ/PT
          XN(6)=X(6)+(X(1)+R)*TAN(A)/PZ/PT*(1.0_dp/b+x(5))
          XN(6)=XN(6)+(k%TOTALPATH-1)*DL/EL%P%BETA0
       else
          PZ=ROOT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          PT=1.0_dp-X(2)*TAN(A)/PZ
          XN(1)=(X(1)+R*(2.0_dp*sin(a/2.0_dp)**2+X(2)*sin(A)/PZ))/COS(A)/PT
          XN(2)=X(2)*COS(A)+SIN(A)*PZ
          XN(3)=X(3)+X(4)*(X(1)+R)*TAN(A)/PZ/PT
          XN(6)=X(6)+(1.0_dp+X(5))*(X(1)+R)*TAN(A)/PZ/PT
          XN(6)=XN(6)+(k%TOTALPATH-1)*DL
       endif
       X(1)=XN(1)
       X(2)=XN(2)
       X(3)=XN(3)
       X(6)=XN(6)
    else
       CALL DRIFT(YL,DL,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    endif
    !    CALL CHECK_STABILITY(X)
    call check_root_drift(el%p,X,k)
  END SUBROUTINE Sprotr

  SUBROUTINE SPROTP(EL,YL,DL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN):: YL
    real(dp),INTENT(IN):: DL
    TYPE(TEAPOTP),INTENT(IN):: EL
    TYPE(REAL_8) XN(6),PZ,PT,A,ah
    real(dp)  b,R
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    if(EL%P%B0/=0.0_dp) then
       CALL ALLOC( XN,6)
       CALL ALLOC( PZ)
       CALL ALLOC( PT)
       CALL ALLOC( A,ah)
       A=YL*EL%P%B0
       ah=a/2.0_dp
       R=1.0_dp/EL%P%B0
       if(k%TIME) then
          B=EL%P%BETA0
          PZ=SQRT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(2)**2-X(4)**2)
          PT=1.0_dp-X(2)*TAN(A)/PZ
          !          XN(1)=(X(1)+R)/COS(A)/PT-R
          XN(1)=(X(1)+R*(2.0_dp*sin(ah)**2+X(2)*sin(A)/PZ))/COS(A)/PT
          XN(2)=X(2)*COS(A)+SIN(A)*PZ
          XN(3)=X(3)+X(4)*(X(1)+R)*TAN(A)/PZ/PT
          XN(6)=X(6)+(X(1)+R)*TAN(A)/PZ/PT*(1.0_dp/b+x(5))
          XN(6)=XN(6)+(k%TOTALPATH-1)*DL/EL%P%BETA0
       else
          PZ=SQRT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          PT=1.0_dp-X(2)*TAN(A)/PZ
          XN(1)=(X(1)+R*(2.0_dp*sin(ah)**2+X(2)*sin(A)/PZ))/COS(A)/PT
          XN(2)=X(2)*COS(A)+SIN(A)*PZ
          XN(3)=X(3)+X(4)*(X(1)+R)*TAN(A)/PZ/PT
          XN(6)=X(6)+(1.0_dp+X(5))*(X(1)+R)*TAN(A)/PZ/PT
          XN(6)=XN(6)+(k%TOTALPATH-1)*DL
       endif
       X(1)=XN(1)
       X(2)=XN(2)
       X(3)=XN(3)
       X(6)=XN(6)

       CALL KILL( XN,6)
       CALL KILL( PZ)
       CALL KILL( PT)
       CALL KILL( A,ah)
    else
       CALL DRIFT(YL,DL,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    endif
  END SUBROUTINE SPROTP

  SUBROUTINE Ssecr(EL,YL,DL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN):: YL,DL
    TYPE(TEAPOT),INTENT(IN):: EL
    real(dp) XN(6),PZ,PZS,DPX,PT
    real(dp)  A,b,R
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE

    A=YL*EL%P%B0
    R=1.0_dp/EL%P%B0
    if(k%TIME) then
       B=EL%P%BETA0
       PZ=ROOT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(2)**2-X(4)**2)
       XN(2)=X(2)*COS(A)+(PZ-DIR*EL%BN(1)*(R+X(1)))*SIN(A)
       DPX=(-X(2)*SIN(A)+(PZ-DIR*EL%BN(1)*(R+X(1)))*COS(A))/DIR/EL%BN(1)  !DPX*R/B1
       PT=ROOT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(4)**2)
       PZS=ROOT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-XN(2)**2-X(4)**2)
       XN(1)=PZS/DIR/EL%BN(1)-DPX-R

       XN(3)=(A+ARCSIN(X(2)/PT)-ARCSIN(XN(2)/PT))/DIR/EL%BN(1)

       XN(6)=X(6)+XN(3)*(1.0_dp/b+x(5))
       XN(6)=XN(6)+(k%TOTALPATH-1)*DL/EL%P%BETA0

       XN(3)=X(3)+X(4)*XN(3)
    else
       PZ=ROOT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
       XN(2)=X(2)*COS(A) + ( PZ-DIR*EL%BN(1)*(R+X(1)) ) *SIN(A)
       DPX=(-X(2)*SIN(A)+(PZ-DIR*EL%BN(1)*(R+X(1)))*COS(A))/DIR/EL%BN(1)  !DPX*R/B1
       PT=ROOT((1.0_dp+X(5))**2-X(4)**2)
       PZS=ROOT((1.0_dp+X(5))**2-XN(2)**2-X(4)**2)
       XN(1)=PZS/DIR/EL%BN(1)-DPX-R

       XN(3)=(A+ARCSIN(X(2)/PT)-ARCSIN(XN(2)/PT))/DIR/EL%BN(1)

       XN(6)=X(6)+XN(3)*(1.0_dp+X(5))
       XN(6)=XN(6)+(k%TOTALPATH-1)*DL
       XN(3)=X(3)+X(4)*XN(3)

    endif
    X(1)=XN(1)
    X(2)=XN(2)
    X(3)=XN(3)
    X(6)=XN(6)
    !    CALL CHECK_STABILITY(X)
    call check_root_drift(EL%P,X,k)
  END SUBROUTINE Ssecr


  SUBROUTINE SsecP(EL,YL,DL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN):: YL
    real(dp),INTENT(IN):: DL
    TYPE(TEAPOTP),INTENT(IN):: EL
    TYPE(REAL_8) XN(6),PZ,PT,A,PZS,DPX
    real(dp)  b,R
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE



    CALL ALLOC( XN,6)
    CALL ALLOC( PZ,PT,A,PZS,DPX)
    A=YL*EL%P%B0
    R=1.0_dp/EL%P%B0
    if(k%TIME) then
       B=EL%P%BETA0
       PZ=SQRT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(2)**2-X(4)**2)
       XN(2)=X(2)*COS(A)+(PZ-DIR*EL%BN(1)*(R+X(1)))*SIN(A)
       DPX=(-X(2)*SIN(A)+(PZ-DIR*EL%BN(1)*(R+X(1)))*COS(A))/DIR/EL%BN(1)  !DPX*R/B1
       PT=SQRT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(4)**2)
       PZS=SQRT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-XN(2)**2-X(4)**2)
       XN(1)=PZS/DIR/EL%BN(1)-DPX-R

       XN(3)=(A+ASIN(X(2)/PT)-ASIN(XN(2)/PT))/DIR/EL%BN(1)

       XN(6)=X(6)+XN(3)*(1.0_dp/b+x(5))
       XN(6)=XN(6)+(k%TOTALPATH-1)*DL/EL%P%BETA0

       XN(3)=X(3)+X(4)*XN(3)
    else
       PZ=SQRT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
       XN(2)=X(2)*COS(A) + ( PZ-DIR*EL%BN(1)*(R+X(1)) ) *SIN(A)
       DPX=(-X(2)*SIN(A)+(PZ-DIR*EL%BN(1)*(R+X(1)))*COS(A))/DIR/EL%BN(1)  !DPX*R/B1
       PT=SQRT((1.0_dp+X(5))**2-X(4)**2)
       PZS=SQRT((1.0_dp+X(5))**2-XN(2)**2-X(4)**2)
       XN(1)=PZS/DIR/EL%BN(1)-DPX-R

       XN(3)=(A+ASIN(X(2)/PT)-ASIN(XN(2)/PT))/DIR/EL%BN(1)

       XN(6)=X(6)+XN(3)*(1.0_dp+X(5))
       XN(6)=XN(6)+(k%TOTALPATH-1)*DL
       XN(3)=X(3)+X(4)*XN(3)

    endif
    X(1)=XN(1)
    X(2)=XN(2)
    X(3)=XN(3)
    X(6)=XN(6)

    CALL KILL( XN,6)
    CALL KILL( PZ,PT,A,PZS,DPX)
  END SUBROUTINE SsecP

  SUBROUTINE SKICKR(EL,YL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN):: YL
    TYPE(TEAPOT),INTENT(IN):: EL
    real(dp) X1,X3,X5,BX,BY,BTX,BTY,BtYT
    INTEGER J,M,A,K1
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    !    if(abs(x(1))+abs(x(3))+abs(x(2))+abs(x(4))>absolute_aperture.or.(.not.CHECK_MADX_APERTURE)) then
    !       if(CHECK_MADX_APERTURE) c_%message="exceed absolute_aperture in SKICKR"
    !       CHECK_STABLE=.false.
    !    endif
    !    if(.not.CHECK_STABLE) return

    DIR=EL%P%DIR*EL%P%CHARGE


    X1=X(1)
    X3=X(3)

    if(k%TIME) then
       X5=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)-1.0_dp
    else
       X5=X(5)
    endif


    BX=0.0_dp
    BY=0.0_dp

    k1=0

    m=SECTOR_NMUL-1
    !    m=EL%P%nmul-1
    do a=m,1,-1
       BTX=0.0_dp
       BTY=0.0_dp
       do j=m-a,1,-1
          k1=k1+1
          !b%i(k)=a
          !b%j(k)=j
          BTX= (BTX+EL%BF_X(k1))*X3  !x1
          BTY= (BTY+EL%BF_Y(k1))*X3
       enddo

       k1=k1+1
       !  b%i(k)=a
       !  b%j(k)=0
       BTX= (BTX+EL%BF_X(k1))
       BTY= (BTY+EL%BF_Y(k1))
       BX= (BX+BTX)*X1
       BY= (BY+BTY)*X1
    enddo
    BTX=0.0_dp
    BTY=0.0_dp
    do j=m,1,-1
       k1=k1+1
       !  b%i(k)=0
       !  b%j(k)=j
       BTX= (BTX+EL%BF_X(k1))*X3
       BTY= (BTY+EL%BF_Y(k1))*X3
    enddo
    k1=k1+1
    !    b%i(k)=0
    !    b%j(k)=0
    BX= BX+BTX+EL%BF_X(k1)  !+X3
    BY= BY+BTY+EL%BF_Y(k1)  !+X3
    ! etienne

    IF(EL%P%NMUL>SECTOR_NMUL) THEN
       BtY=EL%BN(EL%P%NMUL)
       BtX=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,SECTOR_NMUL+1,-1
          BtYT=X1*BtY-X3*BtX+EL%BN(J)
          BtX =X3*BtY+X1*BtX+EL%AN(J)
          BtY =BtYT
       ENDDO

       DO  J=SECTOR_NMUL, 1,-1
          BtYT=X1*BtY-X3*BtX
          BtX =X3*BtY+X1*BtX
          BtY =BtYT
       ENDDO

       BX= BX-BTy
       BY= BY+BTx
       ! 2010 january 4

    ENDIF

    X(2)=X(2)+YL*DIR*BX
    X(4)=X(4)+YL*DIR*BY
    IF(.NOT.EL%DRIFTKICK) THEN
       X(2)=X(2)+YL*DIR*EL%BN(1)*(1.0_dp+X(1)*EL%P%B0)
    ENDIF

  END SUBROUTINE SKICKR


  SUBROUTINE SKICKP(EL,YL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN):: YL
    TYPE(TEAPOTP),INTENT(IN):: EL
    TYPE(REAL_8) X1,X3,BX,BY,BTX,BTY,X5,B(3),B2,BTYt
    INTEGER J,M,A,K1
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir


    DIR=EL%P%DIR*EL%P%CHARGE

    CALL ALLOC(X1,X3,BX,BY,BTX,BTY,X5,B2,BTYt)
    CALL ALLOC(B,3)
!!!!!!!!!!!!!!!!!!!!!!!!!
    X1=X(1)
    X3=X(3)
    !x1=1.d0.mono.1
    !x3=1.d0.mono.3
    !pause  23423423
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    if(k%TIME) then
       X5=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)-1.0_dp
    else
       X5=X(5)
    endif


    BX=0.0_dp
    BY=0.0_dp

    ! x1=one.mono.'1'
    ! x3=one.mono.'01'
    k1=0
    m=SECTOR_NMUL-1
    !    m=EL%P%nmul-1
    do a=m,1,-1
       BTX=0.0_dp
       BTY=0.0_dp
       do j=m-a,1,-1
          k1=k1+1
          !b%i(k)=a
          !b%j(k)=j
          BTX= (BTX+EL%BF_X(k1))*X3
          BTY= (BTY+EL%BF_Y(k1))*X3
       enddo

       k1=k1+1
       !  b%i(k)=a
       !  b%j(k)=0
       BTX= (BTX+EL%BF_X(k1))
       BTY= (BTY+EL%BF_Y(k1))
       BX= (BX+BTX)*X1
       BY= (BY+BTY)*X1
    enddo
    BTX=0.0_dp
    BTY=0.0_dp
    do j=m,1,-1
       k1=k1+1
       !  b%i(k)=0
       !  b%j(k)=j
       BTX= (BTX+EL%BF_X(k1))*X3
       BTY= (BTY+EL%BF_Y(k1))*X3
    enddo
    k1=k1+1
    !    b%i(k)=0
    !    b%j(k)=0
    BX= BX+BTX+EL%BF_X(k1)  !+X3
    BY= BY+BTY+EL%BF_Y(k1)  !+X3

    ! etienne
    IF(EL%P%NMUL>SECTOR_NMUL) THEN
       BtY=EL%BN(EL%P%NMUL)
       BtX=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,SECTOR_NMUL+1,-1
          BtYT=X1*BtY-X3*BtX+EL%BN(J)
          BtX =X3*BtY+X1*BtX+EL%AN(J)
          BtY =BtYT
       ENDDO

       DO  J=SECTOR_NMUL, 1,-1
          BtYT=X1*BtY-X3*BtX
          BtX =X3*BtY+X1*BtX
          BtY =BtYT
       ENDDO

       BX= BX-BTy
       BY= BY+BTx
       ! 2010 january 4

    ENDIF
!!!!!!!!!!!!!!!!!
    !bx=-bx/(one+EL%P%B0*X(1))
    !by=by/(one+EL%P%B0*X(1))
    !call print(bx,6)
    !pause 2341
    !call print(by,6)
    !pause 2342
!!!!!!!!!!!!!!
    X(2)=X(2)+YL*DIR*BX
    X(4)=X(4)+YL*DIR*BY
    IF(.NOT.EL%DRIFTKICK) THEN
       X(2)=X(2)+YL*DIR*EL%BN(1)*(1.0_dp+X(1)*EL%P%B0)
    ENDIF

    CALL KILL(X1,X3,BX,BY,BTX,BTY,X5,B2,BtYT)
    CALL KILL(B,3)

  END SUBROUTINE SKICKP

  SUBROUTINE INTER_TEAPOT(EL,X,k,pos)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(TEAPOT),INTENT(IN):: EL
    real(dp) D,DH,DD
    real(dp) D1,D2,DK1,DK2
    real(dp) DD1,DD2
    real(dp) DF(4),DK(4),DDF(4)
    INTEGER I,J,f1
    integer,optional :: pos
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    SELECT CASE(EL%P%METHOD)
    CASE(1)
       if(EL%F==1) then
          f1=0
       else
          f1=EL%F+1
       endif
       DH=EL%L/EL%P%NST
       D=EL%L/(EL%P%NST/EL%F/2)
       DD=EL%P%LD/EL%P%NST

       IF(MOD(POS,2*EL%F)==f1) THEN
          CALL SKICK (EL,D,X,k)
       ENDIF
       CALL SSECH1(EL,DH,DD,X,k)
    CASE(2)
       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       DD=EL%P%LD/2.0_dp/EL%P%NST

       CALL SSECH1(EL,DH,DD,X,k)
       CALL SKICK(EL,D,X,k)
       CALL SSECH1(EL,DH,DD,X,k)
    CASE(4)
       D1=EL%L*FD1/EL%P%NST
       D2=EL%L*FD2/EL%P%NST
       DD1=EL%P%LD*FD1/EL%P%NST
       DD2=EL%P%LD*FD2/EL%P%NST
       DK1=EL%L*FK1/EL%P%NST
       DK2=EL%L*FK2/EL%P%NST

       CALL SSECH1(EL,D1,DD1,X,k)
       CALL SKICK (EL,DK1,X,k)
       CALL SSECH1(EL,D2,DD2,X,k)
       CALL SKICK (EL,DK2,X,k)

       CALL SSECH1(EL,D2,DD2,X,k)
       CALL SKICK (EL,DK1,X,k)
       CALL SSECH1(EL,D1,DD1,X,k)



    CASE(6)
       DO I =1,4
          DF(I)=EL%L*YOSD(I)/EL%P%NST
          DDF(I)=EL%P%LD*YOSD(I)/EL%P%NST
          DK(I)=EL%L*YOSK(I)/EL%P%NST
       ENDDO

       DO J=4,2,-1
          CALL SSECH1(EL,DF(J),DDF(J),X,k)
          CALL SKICK (EL,DK(J),X,k)
       ENDDO
       CALL SSECH1(EL,DF(1),DDF(1),X,k)
       CALL SKICK (EL,DK(1),X,k)

       CALL SSECH1(EL,DF(1),DDF(1),X,k)
       DO J=2,4
          CALL SKICK (EL,DK(J),X,k)
          CALL SSECH1(EL,DF(J),DDF(J),X,k)
       ENDDO



    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

  END SUBROUTINE INTER_TEAPOT

  SUBROUTINE INTEP_TEAPOT(EL,X,k,pos)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(TEAPOTP),INTENT(IN):: EL
    real(dp) DD
    real(dp) DD1,DD2
    real(dp) DDF(4)
    TYPE(REAL_8) DH,D,D1,D2,DK1,DK2,DF(4),DK(4)
    INTEGER I,J,f1
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    integer,optional :: pos


    SELECT CASE(EL%P%METHOD)
    CASE(1)
       CALL ALLOC(DH,D)
       if(EL%F==1) then
          f1=0
       else
          f1=EL%F+1
       endif
       DH=EL%L/EL%P%NST
       D=EL%L/(EL%P%NST/EL%F/2)
       DD=EL%P%LD/EL%P%NST

       IF(MOD(POS,2*EL%F)==f1) THEN
          CALL SKICK (EL,D,X,k)
       ENDIF
       CALL SSECH1(EL,DH,DD,X,k)
       CALL kill(DH,D)
    CASE(2)

       CALL ALLOC(DH,D)

       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       DD=EL%P%LD/2.0_dp/EL%P%NST

       CALL SSECH1(EL,DH,DD,X,k)
       CALL SKICK(EL,D,X,k)
       CALL SSECH1(EL,DH,DD,X,k)

       CALL KILL(DH,D)

    CASE(4)
       CALL ALLOC(D1,D2,DK1,DK2)
       D1=EL%L*FD1/EL%P%NST
       D2=EL%L*FD2/EL%P%NST
       DD1=EL%P%LD*FD1/EL%P%NST
       DD2=EL%P%LD*FD2/EL%P%NST
       DK1=EL%L*FK1/EL%P%NST
       DK2=EL%L*FK2/EL%P%NST

       CALL SSECH1(EL,D1,DD1,X,k)
       CALL SKICK (EL,DK1,X,k)
       CALL SSECH1(EL,D2,DD2,X,k)
       CALL SKICK (EL,DK2,X,k)

       CALL SSECH1(EL,D2,DD2,X,k)
       CALL SKICK (EL,DK1,X,k)
       CALL SSECH1(EL,D1,DD1,X,k)

       CALL KILL(D1,D2,DK1,DK2)

    CASE(6)
       CALL ALLOC(DF,4);CALL ALLOC(DK,4);
       DO I =1,4
          DF(I)=EL%L*YOSD(I)/EL%P%NST
          DDF(I)=EL%P%LD*YOSD(I)/EL%P%NST
          DK(I)=EL%L*YOSK(I)/EL%P%NST
       ENDDO

       DO J=4,2,-1
          CALL SSECH1(EL,DF(J),DDF(J),X,k)
          CALL SKICK (EL,DK(J),X,k)
       ENDDO
       CALL SSECH1(EL,DF(1),DDF(1),X,k)
       CALL SKICK (EL,DK(1),X,k)

       CALL SSECH1(EL,DF(1),DDF(1),X,k)
       DO J=2,4
          CALL SKICK (EL,DK(J),X,k)
          CALL SSECH1(EL,DF(J),DDF(J),X,k)
       ENDDO

       CALL KILL(DF,4);CALL KILL(DK,4);

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

  END SUBROUTINE INTEP_TEAPOT

  SUBROUTINE SINTER(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(TEAPOT),INTENT(IN):: EL
    TYPE(WORM), OPTIONAL,INTENT(INOUT):: MID
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    DO I=1,EL%P%NST
       IF(.NOT.PRESENT(MID))CALL TRACK_SLICE(EL,X,k,I)
       IF(PRESENT(MID)) CALL XMID(MID,X,I)
    ENDDO

  END SUBROUTINE SINTER

  SUBROUTINE SINTEP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(TEAPOTP),INTENT(INOUT):: EL
    INTEGER I
    logical(lp) CHECK_KNOB
    integer(2), pointer,dimension(:)::AN,BN
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    CALL MAKEPOTKNOB(EL,CHECK_KNOB,AN,BN)

    DO I=1,EL%P%NST
       CALL TRACK_SLICE(EL,X,k,I)
    ENDDO


    CALL UNMAKEPOTKNOB(EL,CHECK_KNOB,AN,BN)




  END SUBROUTINE SINTEP

  SUBROUTINE CHECKPOTKNOB(EL,CHECK_KNOB)
    IMPLICIT NONE
    TYPE(TEAPOTP),INTENT(IN):: EL
    logical(lp) CHECK_KNOB
    integer I

    CHECK_KNOB=.FALSE.
    I=1
    DO WHILE(I<=EL%P%NMUL.AND.(.NOT.CHECK_KNOB))
       IF(EL%BN(I)%KIND>=2) CHECK_KNOB=.TRUE.
       IF(EL%AN(I)%KIND>=2) CHECK_KNOB=.TRUE.
       I=I+1
    ENDDO
    IF(EL%L%KIND==3) CHECK_KNOB=.TRUE.

  END SUBROUTINE CHECKPOTKNOB

  SUBROUTINE MAKEPOTKNOB(EL,CHECK_KNOB,AN,BN,K)
    IMPLICIT NONE
    TYPE(TEAPOTP),INTENT(INOUT):: EL
    integer(2), pointer,dimension(:)::AN,BN
    LOGICAL(LP) CHECK_KNOB,doit
    type(internal_state), optional :: k 
    integer I
    doit=.false.
    if(present(k)) then
        IF(K%PARA_IN ) doit=.TRUE.
    endif
    IF(KNOB.or.doit) THEN
       CALL CHECKPOTKNOB(EL,CHECK_KNOB) ! RECOMPUTES ONLY IF KNOB (SPEED)
       IF(CHECK_KNOB) THEN
          ALLOCATE(AN(EL%P%NMUL),BN(EL%P%NMUL))
          DO I=1,EL%P%NMUL
             BN(I)=0
             AN(I)=0
             IF(EL%BN(I)%KIND>=2) BN(I)=EL%BN(I)%KIND
             IF(EL%AN(I)%KIND>=2) AN(I)=EL%AN(I)%KIND  ! g-2 modification
          ENDDO
          if(doit.and.(.not.knob)) then
           knob=.true.
           call GETANBN(EL)
           knob=.false.
          else
           call GETANBN(EL)
          endif 
       ENDIF
    ENDIF
  END SUBROUTINE MAKEPOTKNOB

  SUBROUTINE UNMAKEPOTKNOB(EL,CHECK_KNOB,AN,BN,k)
    IMPLICIT NONE
    TYPE(TEAPOTP),INTENT(INOUT):: EL
    integer(2), pointer,dimension(:)::AN,BN
    LOGICAL(LP) CHECK_KNOB,doit
    integer I,ERROR
        type(internal_state), optional :: k 

    doit=.false.
    if(present(k)) then
        IF(K%PARA_IN ) doit=.TRUE.
    endif
    
     IF(KNOB.or.doit) THEN
       IF(CHECK_KNOB) THEN
          DO I=1,EL%P%NMUL
             EL%BN(I)%KIND=1
             EL%AN(I)%KIND=1
          ENDDO
          CALL KILL(EL)                               ! RECOMPUTES ONLY IF KNOB (SPEED)
          CALL ALLOC(EL)
          CALL GETANBN(EL)                            ! KNOB IS REMOVED THE SLOW WAY(SPEED)
          DO I=1,EL%P%NMUL
             IF(AN(I)>0) EL%AN(I)%KIND=AN(I)
             IF(BN(I)>0) EL%BN(I)%KIND=BN(I)
          ENDDO
          DEALLOCATE (AN, STAT = error)
          IF(ERROR/=0) THEN
             w_p=0
             w_p%nc=1
             w_p%fc='(1(1X,A72))'
             w_p%c(1)= " AN ARRAY not DEALLOCATED : PROBLEMS"
             ! call !write_e(357)
          ENDIF
          DEALLOCATE (BN, STAT = error)
          IF(ERROR/=0) THEN
             w_p=0
             w_p%nc=1
             w_p%fc='(1(1X,A72))'
             w_p%c(1)= " BN ARRAY not DEALLOCATED : PROBLEMS"
             ! call !write_e(357)
          ENDIF
       ENDIF
    ENDIF
  END SUBROUTINE UNMAKEPOTKNOB

  ! CALL FRINGE_teapot(EL%TP10,X,T%CAS)
  SUBROUTINE fringe_TEAPOTr(EL,X,k,J)
    IMPLICIT NONE
    logical(lp) :: doneitt=.true.
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(TEAPOT),INTENT(IN):: EL
    integer,INTENT(IN):: J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(EL%P%DIR==1) THEN

       IF(J==1) THEN

          IF(EL%P%EDGE(1)/=0.0_dp) THEN
             CALL ROT_XZ(EL%P%EDGE(1),X,EL%P%BETA0,DONEITT,k%TIME)
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
             IF(k%FRINGE.or.el%p%permfringe) then
                CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
                x(2)=x(2)+EL%P%EDGE(1)*el%bn(2)*(wedge_coeff(1)*x(1)**2-wedge_coeff(2)*x(3)**2*0.5_dp)
                x(4)=x(4)-EL%P%EDGE(1)*el%bn(2)*(wedge_coeff(2)*x(1)*x(3))
             ELSEIF(MAD8_WEDGE) THEN
                x(2)=x(2)+EL%P%EDGE(1)*el%bn(2)*(x(1)**2-x(3)**2)
                x(4)=x(4)-EL%P%EDGE(1)*el%bn(2)*(2.0_dp*x(1)*x(3))
             endif
             CALL WEDGE(-EL%P%EDGE(1),X,k,EL2=EL)
          ELSE
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
          ENDIF

       ELSE ! J=2

          IF(EL%P%EDGE(2)/=0.0_dp) THEN
             CALL WEDGE(-EL%P%EDGE(2),X,k,EL2=EL)
             IF(k%FRINGE.or.el%p%permfringe) then
                x(2)=x(2)+EL%P%EDGE(2)*el%bn(2)*(wedge_coeff(1)*x(1)**2-wedge_coeff(2)*x(3)**2*0.5_dp)
                x(4)=x(4)-EL%P%EDGE(2)*el%bn(2)*(wedge_coeff(2)*x(1)*x(3))
                CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             ELSEIF(MAD8_WEDGE) THEN
                x(2)=x(2)+EL%P%EDGE(2)*el%bn(2)*(x(1)**2-x(3)**2)
                x(4)=x(4)-EL%P%EDGE(2)*el%bn(2)*(2.0_dp*x(1)*x(3))
             endif
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
             CALL ROT_XZ(EL%P%EDGE(2),X,EL%P%BETA0,DONEITT,k%TIME)
          ELSE
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
          ENDIF
       ENDIF ! J=2
    ELSE


       IF(J==1) THEN

          IF(EL%P%EDGE(2)/=0.0_dp) THEN
             CALL ROT_XZ(EL%P%EDGE(2),X,EL%P%BETA0,DONEITT,k%TIME)
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
             IF(k%FRINGE.or.el%p%permfringe) then
                CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
                x(2)=x(2)-EL%P%EDGE(2)*el%bn(2)*(wedge_coeff(1)*x(1)**2-wedge_coeff(2)*x(3)**2*0.5_dp)
                x(4)=x(4)+EL%P%EDGE(2)*el%bn(2)*(wedge_coeff(2)*x(1)*x(3))
             ELSEIF(MAD8_WEDGE) THEN
                x(2)=x(2)-EL%P%EDGE(2)*el%bn(2)*(x(1)**2-x(3)**2)
                x(4)=x(4)+EL%P%EDGE(2)*el%bn(2)*(2.0_dp*x(1)*x(3))
             endif
             CALL WEDGE(-EL%P%EDGE(2),X,k,EL2=EL)
          ELSE
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
          ENDIF

       ELSE ! J=2

          IF(EL%P%EDGE(1)/=0.0_dp) THEN
             CALL WEDGE(-EL%P%EDGE(1),X,k,EL2=EL)
             IF(k%FRINGE.or.el%p%permfringe) then
                x(2)=x(2)-EL%P%EDGE(1)*el%bn(2)*(wedge_coeff(1)*x(1)**2-wedge_coeff(2)*x(3)**2*0.5_dp)
                x(4)=x(4)+EL%P%EDGE(1)*el%bn(2)*(wedge_coeff(2)*x(1)*x(3))
                CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             ELSEIF(MAD8_WEDGE) THEN
                x(2)=x(2)-EL%P%EDGE(1)*el%bn(2)*(x(1)**2-x(3)**2)
                x(4)=x(4)+EL%P%EDGE(1)*el%bn(2)*(2.0_dp*x(1)*x(3))
             endif
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
             CALL ROT_XZ(EL%P%EDGE(1),X,EL%P%BETA0,DONEITT,k%TIME)
          ELSE
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
          ENDIF

       ENDIF

    ENDIF

  END SUBROUTINE fringe_TEAPOTr

  SUBROUTINE fringe_TEAPOTP(EL,X,k,J)
    IMPLICIT NONE
    logical(lp) :: doneitt=.true.
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(TEAPOTP),INTENT(IN):: EL
    integer,INTENT(IN):: J

    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(EL%P%DIR==1) THEN

       IF(J==1) THEN

          IF(EL%P%EDGE(1)/=0.0_dp) THEN
             CALL ROT_XZ(EL%P%EDGE(1),X,EL%P%BETA0,DONEITT,k%TIME)
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
             IF(k%FRINGE.or.el%p%permfringe) then
                CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
                x(2)=x(2)+EL%P%EDGE(1)*el%bn(2)*(wedge_coeff(1)*x(1)**2-wedge_coeff(2)*x(3)**2*0.5_dp)
                x(4)=x(4)-EL%P%EDGE(1)*el%bn(2)*(wedge_coeff(2)*x(1)*x(3))
             ELSEIF(MAD8_WEDGE) THEN
                x(2)=x(2)+EL%P%EDGE(1)*el%bn(2)*(x(1)**2-x(3)**2)
                x(4)=x(4)-EL%P%EDGE(1)*el%bn(2)*(2.0_dp*x(1)*x(3))
             endif
             CALL WEDGE(-EL%P%EDGE(1),X,k,EL2=EL)
          ELSE
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
          ENDIF

       ELSE ! J=2

          IF(EL%P%EDGE(2)/=0.0_dp) THEN
             CALL WEDGE(-EL%P%EDGE(2),X,k,EL2=EL)
             IF(k%FRINGE.or.el%p%permfringe) then
                x(2)=x(2)+EL%P%EDGE(2)*el%bn(2)*(wedge_coeff(1)*x(1)**2-wedge_coeff(2)*x(3)**2*0.5_dp)
                x(4)=x(4)-EL%P%EDGE(2)*el%bn(2)*(wedge_coeff(2)*x(1)*x(3))
                CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             ELSEIF(MAD8_WEDGE) THEN
                x(2)=x(2)+EL%P%EDGE(2)*el%bn(2)*(x(1)**2-x(3)**2)
                x(4)=x(4)-EL%P%EDGE(2)*el%bn(2)*(2.0_dp*x(1)*x(3))
             endif
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
             CALL ROT_XZ(EL%P%EDGE(2),X,EL%P%BETA0,DONEITT,k%TIME)
          ELSE
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
          ENDIF
       ENDIF ! J=2
    ELSE


       IF(J==1) THEN

          IF(EL%P%EDGE(2)/=0.0_dp) THEN
             CALL ROT_XZ(EL%P%EDGE(2),X,EL%P%BETA0,DONEITT,k%TIME)
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
             IF(k%FRINGE.or.el%p%permfringe) then
                CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
                x(2)=x(2)-EL%P%EDGE(2)*el%bn(2)*(wedge_coeff(1)*x(1)**2-wedge_coeff(2)*x(3)**2*0.5_dp)
                x(4)=x(4)+EL%P%EDGE(2)*el%bn(2)*(wedge_coeff(2)*x(1)*x(3))
             ELSEIF(MAD8_WEDGE) THEN
                x(2)=x(2)-EL%P%EDGE(2)*el%bn(2)*(x(1)**2-x(3)**2)
                x(4)=x(4)+EL%P%EDGE(2)*el%bn(2)*(2.0_dp*x(1)*x(3))
             endif
             CALL WEDGE(-EL%P%EDGE(2),X,k,EL2=EL)
          ELSE
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
          ENDIF

       ELSE ! J=2

          IF(EL%P%EDGE(1)/=0.0_dp) THEN
             CALL WEDGE(-EL%P%EDGE(1),X,k,EL2=EL)
             IF(k%FRINGE.or.el%p%permfringe) then
                x(2)=x(2)-EL%P%EDGE(1)*el%bn(2)*(wedge_coeff(1)*x(1)**2-wedge_coeff(2)*x(3)**2*0.5_dp)
                x(4)=x(4)+EL%P%EDGE(1)*el%bn(2)*(wedge_coeff(2)*x(1)*x(3))
                CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             ELSEIF(MAD8_WEDGE) THEN
                x(2)=x(2)-EL%P%EDGE(1)*el%bn(2)*(x(1)**2-x(3)**2)
                x(4)=x(4)+EL%P%EDGE(1)*el%bn(2)*(2.0_dp*x(1)*x(3))
             endif
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
             CALL ROT_XZ(EL%P%EDGE(1),X,EL%P%BETA0,DONEITT,k%TIME)
          ELSE
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
          ENDIF

       ENDIF

    ENDIF

  END SUBROUTINE fringe_TEAPOTP


  SUBROUTINE SSYMPINTR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(TEAPOT),INTENT(IN):: EL
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(.NOT.PRESENT(MID))call fringe_TEAPOT(EL,X,k,1)

    CALL SINTE(EL,X,k,MID)

    IF(.NOT.PRESENT(MID))call fringe_TEAPOT(EL,X,k,2)


  END SUBROUTINE SSYMPINTR

  SUBROUTINE SSYMPINTP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(TEAPOTP),INTENT(INOUT):: EL
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: MID
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    call fringe_TEAPOT(EL,X,k,1)

    CALL SINTE(EL,X,k)

    call fringe_TEAPOT(EL,X,k,2)


  END SUBROUTINE SSYMPINTP

  !  monitor stuff


  SUBROUTINE MONTR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM), OPTIONAL,INTENT(INOUT):: MID
    TYPE(mon),INTENT(INOUT):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    DO I=1,EL%P%NST
       CALL MONTI(EL,X,k,I,MID)
    ENDDO
    !    IF(PRESENT(MID)) CALL XMID(MID,X,2)

  END SUBROUTINE MONTR




  SUBROUTINE MONTP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: MID
    TYPE(monP),INTENT(INOUT):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    DO I=1,EL%P%NST
       CALL MONTI(EL,X,k,I)
    ENDDO
    !    IF(PRESENT(MID)) CALL XMID(MID,X,2)


  END SUBROUTINE MONTP

  SUBROUTINE MONTIR(EL,X,k,I,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM), OPTIONAL,INTENT(INOUT):: MID
    TYPE(mon),INTENT(INOUT):: EL
    INTEGER, INTENT(IN) :: I
    real(dp) DH,DD
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    DH=EL%L/2.0_dp/el%p%nst
    DD=EL%P%LD/2.0_dp/el%p%nst

    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    if(mod(el%p%nst,2)==1) then
       if(i==(el%p%nst+1)/2) THEN
          EL%X=X(1);EL%Y=X(3);
       ENDIF
    endif
    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    if(mod(el%p%nst,2)==0) then
       if(i==el%p%nst/2) THEN
          EL%X=X(1);EL%Y=X(3);
       ENDIF
    ENDIF
    IF(PRESENT(MID))  CALL XMID(MID,X,i)

  END SUBROUTINE MONTIR


  SUBROUTINE MONTIP(EL,X,k,I)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: MID
    TYPE(monP),INTENT(INOUT):: EL
    real(dp) DD
    TYPE(REAL_8) DH
    INTEGER, INTENT(IN) :: I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    CALL ALLOC(DH)

    DH=EL%L/2.0_dp/el%p%nst
    DD=EL%P%LD/2.0_dp/el%p%nst

    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    if(mod(el%p%nst,2)==1) then
       if(i==(el%p%nst+1)/2) THEN
          EL%X=X(1);EL%Y=X(3);
       ENDIF
    endif
    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    if(mod(el%p%nst,2)==0) then
       if(i==el%p%nst/2) THEN
          EL%X=X(1);EL%Y=X(3);
       ENDIF
    endif
    !       IF(PRESENT(MID)) CALL XMID(MID,X,i)

    CALL KILL(DH)

  END SUBROUTINE MONTIP

  !  RCOLLIMATOR STUFF

  SUBROUTINE RCOLLIMATORR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM), OPTIONAL,INTENT(INOUT):: MID
    TYPE(RCOL),INTENT(INOUT):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    DO I=1,EL%P%NST
       CALL RCOLLIMATORi(EL,X,k,i,MID)
    ENDDO
    !    IF(PRESENT(MID)) CALL XMID(MID,X,2)

  END SUBROUTINE RCOLLIMATORR

  SUBROUTINE RCOLLIMATORP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: MID
    TYPE(RCOLP),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    INTEGER I

    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    DO I=1,EL%P%NST
       CALL RCOLLIMATORi(EL,X,k,i)
    ENDDO
    !    IF(PRESENT(MID)) CALL XMID(MID,X,2)

  END SUBROUTINE RCOLLIMATORP

  SUBROUTINE RCOLLIMATORiR(EL,X,k,i,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM), OPTIONAL,INTENT(INOUT):: MID
    TYPE(RCOL),INTENT(INOUT):: EL
    real(dp) DH,DD
    logical(lp) aper
    integer, intent(in) :: i
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    DH=EL%L/2.0_dp/el%p%nst
    DD=EL%P%LD/2.0_dp/el%p%nst

    aper=APERTURE_FLAG
    APERTURE_FLAG=.true.

    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    if(mod(el%p%nst,2)==1) then
       !       IF(PRESENT(MID)) THEN
       !          if(i==(el%p%nst+1)/2)  CALL XMID(MID,X,1)
       !       ENDIF
    endif
    CALL CHECK_APERTURE(EL%p%APERTURE,X)
!    CALL CHECK_APERTURE(EL%A,X)

    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    if(mod(el%p%nst,2)==0) then
       !       IF(PRESENT(MID)) THEN
       !          if(i==el%p%nst/2)  CALL XMID(MID,X,1)
       !       ENDIF
    endif

    IF(PRESENT(MID)) CALL XMID(MID,X,I)

    APERTURE_FLAG=aper

  END SUBROUTINE RCOLLIMATORiR

  SUBROUTINE RCOLLIMATORiP(EL,X,k,i)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: MID
    TYPE(RCOLP),INTENT(INOUT):: EL
    real(dp) DD
    TYPE(REAL_8) DH
    logical(lp) aper
    integer, intent(in) :: i
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(DH)
    DH=EL%L/2.0_dp/el%p%nst
    DD=EL%P%LD/2.0_dp/el%p%nst

    aper=APERTURE_FLAG
    APERTURE_FLAG=.true.

    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    if(mod(el%p%nst,2)==1) then
       !       IF(PRESENT(MID)) THEN
       !          if(i==(el%p%nst+1)/2)  CALL XMID(MID,X,1)
       !       ENDIF
    endif
     CALL CHECK_APERTURE(EL%p%APERTURE,X)
!    CALL CHECK_APERTURE(EL%A,X)

    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    if(mod(el%p%nst,2)==0) then
       !       IF(PRESENT(MID)) THEN
       !          if(i==el%p%nst/2)  CALL XMID(MID,X,1)
       !       ENDIF
    endif

    !IF(PRESENT(MID)) CALL XMID(MID,X,I)

    APERTURE_FLAG=aper

    CALL kill(DH)

  END SUBROUTINE RCOLLIMATORiP

  !  ECOLLIMATOR STUFF

  SUBROUTINE ECOLLIMATORR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM), OPTIONAL,INTENT(INOUT):: MID
    TYPE(ECOL),INTENT(INOUT):: EL
    !   logical(lp) aper
    !   real(dp) DH,DD
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    DO I=1,EL%P%NST
       CALL ECOLLIMATORi(EL,X,k,i,MID)
    ENDDO


    !    DH=EL%L/two
    !    DD=EL%P%LD/two
    !    aper=APERTURE_FLAG
    !    APERTURE_FLAG=.true.
    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    !    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    !    CALL CHECK_APERTURE(EL%A,X)
    !    IF(PRESENT(MID)) CALL XMID(MID,X,1)
    !    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    !    IF(PRESENT(MID)) CALL XMID(MID,X,2)
    !    APERTURE_FLAG=aper


  END SUBROUTINE ECOLLIMATORR

  SUBROUTINE ECOLLIMATORP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(ECOLP),INTENT(INOUT):: EL
    ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: MID
    !    real(dp) DD
    !    TYPE(REAL_8) DH
    !    logical(lp) aper
    INTEGER I
    !    CALL ALLOC(DH)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K



    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    DO I=1,EL%P%NST
       CALL ECOLLIMATORi(EL,X,k,i)
    ENDDO




    !    DH=EL%L/two
    !    DD=EL%P%LD/two
    !    aper=APERTURE_FLAG
    !    APERTURE_FLAG=.true.
    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    !    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    !    CALL CHECK_APERTURE(EL%A,X)
    !    IF(PRESENT(MID)) CALL XMID(MID,X,1)
    !    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    !    IF(PRESENT(MID)) CALL XMID(MID,X,2)
    !    APERTURE_FLAG=aper

    !    CALL KILL(DH)

  END SUBROUTINE ECOLLIMATORP

  SUBROUTINE ECOLLIMATORiR(EL,X,k,i,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM), OPTIONAL,INTENT(INOUT):: MID
    TYPE(ECOL),INTENT(INOUT):: EL
    real(dp) DH,DD
    logical(lp) aper
    integer, intent(in) :: i
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    DH=EL%L/2.0_dp/el%p%nst
    DD=EL%P%LD/2.0_dp/el%p%nst

    aper=APERTURE_FLAG
    APERTURE_FLAG=.true.

    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    if(mod(el%p%nst,2)==1) then
       IF(PRESENT(MID)) THEN
          if(i==(el%p%nst+1)/2)  CALL XMID(MID,X,1)
       ENDIF
    endif
    CALL CHECK_APERTURE(EL%p%APERTURE,X)
!    CALL CHECK_APERTURE(EL%A,X)

    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    if(mod(el%p%nst,2)==0) then
       IF(PRESENT(MID)) THEN
          if(i==el%p%nst/2)  CALL XMID(MID,X,1)
       ENDIF
    endif

    APERTURE_FLAG=aper

  END SUBROUTINE ECOLLIMATORiR

  SUBROUTINE ECOLLIMATORiP(EL,X,k,i)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: MID
    TYPE(ECOLP),INTENT(INOUT):: EL
    real(dp) DD
    TYPE(REAL_8) DH
    logical(lp) aper
    integer, intent(in) :: i
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(DH)
    DH=EL%L/2.0_dp/el%p%nst
    DD=EL%P%LD/2.0_dp/el%p%nst

    aper=APERTURE_FLAG
    APERTURE_FLAG=.true.

    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    !    if(mod(el%p%nst,2)==1) then
    !       IF(PRESENT(MID)) THEN
    !          if(i==(el%p%nst+1)/2)  CALL XMID(MID,X,1)
    !       ENDIF
    !    endif
    CALL CHECK_APERTURE(EL%p%APERTURE,X)
!    CALL CHECK_APERTURE(EL%A,X)
    CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
    !    if(mod(el%p%nst,2)==0) then
    !       IF(PRESENT(MID)) THEN
    !          if(i==el%p%nst/2)  CALL XMID(MID,X,1)
    !       ENDIF
    !    endif

    APERTURE_FLAG=aper

    CALL kill(DH)

  END SUBROUTINE ECOLLIMATORiP

  !  Electric septum

  SUBROUTINE SEPR(EL,X,k,i,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(ESEPTUM),INTENT(INOUT):: EL
    TYPE(WORM), OPTIONAL,INTENT(INOUT):: MID
    real(dp) K1,SH_X,SH,CH,CHM,PZ,E1,XT(2),ARG
    integer, intent(IN) ::i
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    !    if(EL%P%EXACT) THEN
    if(.true.) then

       K1=EL%P%CHARGE*EL%VOLT*1e-3_dp/EL%P%P0C


       if(k%TIME) then
          PZ=ROOT((1.0_dp/EL%P%BETA0+X(5)+K1*X(3))**2-(EL%P%GAMMA0I/EL%P%BETA0)**2-X(2)**2-X(4)**2)
          E1=1.0_dp/EL%P%BETA0+X(5)
       else
          PZ=ROOT((1.0_dp+X(5)+K1*X(3))**2-X(2)**2-X(4)**2)
          E1=1.0_dp+X(5)
       endif
       ARG=(EL%L/2.0_dp/el%p%nst)*K1/PZ
       SH_X=(EL%L/2.0_dp/el%p%nst)*SINeHX_X(ARG)/PZ
       SH=SINeH(ARG)
       CH=COSeH(ARG)
       ARG=ARG*0.5_dp
       CHM=(EL%L/2.0_dp/el%p%nst)*SINeHX_X(ARG)/PZ*SINeH(ARG)
       ARG=ARG*2.0_dp

       X(1)=X(1)+X(2)*(EL%L/2.0_dp/el%p%nst)/PZ
       XT(1)=CH*X(3)+SH_X*X(4)+CHM*E1
       XT(2)=CH*X(4)+K1*SH*X(3)+SH*E1
       X(6)=X(6)+CHM*X(4)+SH*X(3)+E1*SH_X

       X(3)=XT(1)
       X(4)=XT(2)

       if(k%TIME) then
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/EL%P%BETA0/2.0_dp/el%p%nst
       else
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/2.0_dp/el%p%nst
       endif

       IF(PRESENT(MID)) THEN
          if(mod(el%p%nst,2)==1) then
             if(i==(el%p%nst+1)/2)  CALL XMID(MID,X,1)
          endif
       ENDIF

       K1=EL%P%CHARGE*EL%VOLT*1e-3_dp/EL%P%P0C    ! added 2004.06.09

       if(k%TIME) then
          PZ=ROOT((1.0_dp/EL%P%BETA0+X(5)+K1*X(3))**2-(EL%P%GAMMA0I/EL%P%BETA0)**2-X(2)**2-X(4)**2)
          E1=1.0_dp/EL%P%BETA0+X(5)
       else
          PZ=ROOT((1.0_dp+X(5)+K1*X(3))**2-X(2)**2-X(4)**2)
          E1=1.0_dp+X(5)
       endif

       ARG=(EL%L/2.0_dp/el%p%nst)*K1/PZ
       SH_X=(EL%L/2.0_dp/el%p%nst)*SINeHX_X(ARG)/PZ
       SH=SINeH(ARG)
       CH=COSeH(ARG)
       ARG=ARG*0.5_dp
       CHM=(EL%L/2.0_dp/el%p%nst)*SINeHX_X(ARG)/PZ*SINeH(ARG)
       ARG=ARG*2.0_dp

       X(1)=X(1)+X(2)*(EL%L/2.0_dp/el%p%nst)/PZ
       XT(1)=CH*X(3)+SH_X*X(4)+CHM*E1
       XT(2)=CH*X(4)+K1*SH*X(3)+SH*E1
       X(6)=X(6)+CHM*X(4)+SH*X(3)+E1*SH_X

       X(3)=XT(1)
       X(4)=XT(2)

       if(k%TIME) then
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/EL%P%BETA0/2.0_dp/el%p%nst
       else
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/2.0_dp/el%p%nst
       endif

       IF(PRESENT(MID)) THEN
          if(mod(el%p%nst,2)==0) then
             if(i==el%p%nst/2)  CALL XMID(MID,X,1)
          endif
       ENDIF
    else

       K1=EL%P%CHARGE*EL%VOLT*1e-3_dp/EL%P%P0C



       if(k%TIME) then
          PZ=root((1.0_dp/EL%P%BETA0+X(5)+K1*X(3))**2-(EL%P%GAMMA0I/EL%P%BETA0)**2)
          E1=1.0_dp/EL%P%BETA0+X(5)
       else
          PZ=(1.0_dp+X(5)+K1*X(3))
          E1=1.0_dp+X(5)
       endif

       ARG=(EL%L/2.0_dp/el%p%nst)*K1/PZ
       SH_X=(EL%L/2.0_dp/el%p%nst)*SINeHX_X(ARG)/PZ
       SH=SINeH(ARG)
       CH=COSeH(ARG)
       ARG=ARG*0.5_dp
       CHM=(EL%L/2.0_dp/el%p%nst)*SINeHX_X(ARG)/PZ*SINeH(ARG)
       ARG=ARG*2.0_dp

       X(1)=X(1)+X(2)*(EL%L/2.0_dp/el%p%nst)/PZ
       XT(1)=CH*X(3)+SH_X*X(4)+CHM*E1
       XT(2)=CH*X(4)+K1*SH*X(3)+SH*E1
       X(6)=X(6)+CHM*X(4)+SH*X(3)+E1*SH_X

       X(3)=XT(1)
       X(4)=XT(2)

       if(k%TIME) then
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/EL%P%BETA0/2.0_dp/el%p%nst
       else
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/2.0_dp/el%p%nst
       endif

       IF(PRESENT(MID)) THEN
          if(mod(el%p%nst,2)==1) then
             if(i==(el%p%nst+1)/2)  CALL XMID(MID,X,1)
          endif
       ENDIF


       K1=EL%P%CHARGE*EL%VOLT*1e-3_dp/EL%P%P0C    ! added 2004.06.09

       if(k%TIME) then
          PZ=root((1.0_dp/EL%P%BETA0+X(5)+K1*X(3))**2-(EL%P%GAMMA0I/EL%P%BETA0)**2)
          E1=1.0_dp/EL%P%BETA0+X(5)
       else
          PZ=(1.0_dp+X(5)+K1*X(3))
          E1=1.0_dp+X(5)
       endif

       ARG=(EL%L/2.0_dp/el%p%nst)*K1/PZ
       SH_X=(EL%L/2.0_dp/el%p%nst)*SINeHX_X(ARG)/PZ
       SH=SINeH(ARG)
       CH=COSeH(ARG)
       ARG=ARG*0.5_dp
       CHM=(EL%L/2.0_dp/el%p%nst)*SINeHX_X(ARG)/PZ*SINeH(ARG)
       ARG=ARG*2.0_dp

       X(1)=X(1)+X(2)*(EL%L/2.0_dp/el%p%nst)/PZ
       XT(1)=CH*X(3)+SH_X*X(4)+CHM*E1
       XT(2)=CH*X(4)+K1*SH*X(3)+SH*E1
       X(6)=X(6)+CHM*X(4)+SH*X(3)+E1*SH_X

       X(3)=XT(1)
       X(4)=XT(2)

       if(k%TIME) then
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/EL%P%BETA0/2.0_dp/el%p%nst
       else
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/2.0_dp/el%p%nst
       endif

       IF(PRESENT(MID)) THEN
          if(mod(el%p%nst,2)==0) then
             if(i==el%p%nst/2)  CALL XMID(MID,X,1)
          endif
       ENDIF

    endif


  END SUBROUTINE SEPR

  SUBROUTINE SEPP(EL,X,k,I)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(ESEPTUMP),INTENT(INOUT):: EL
    ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: MID
    TYPE(REAL_8) K1,SH_X,SH,CH,CHM,PZ,E1,XT(2),ARG
    integer, intent(IN) ::i
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    !    if(EL%P%EXACT) THEN
    if(.true.) then

       CALL ALLOC( K1,SH_X,SH,CH,CHM,PZ,E1)
       CALL ALLOC( XT,2)

       K1=EL%P%CHARGE*EL%VOLT*1e-3_dp/EL%P%P0C


       if(k%TIME) then
          PZ=SQRT((1.0_dp/EL%P%BETA0+X(5)+K1*X(3))**2-(EL%P%GAMMA0I/EL%P%BETA0)**2-X(2)**2-X(4)**2)
          E1=1.0_dp/EL%P%BETA0+X(5)
       else
          PZ=SQRT((1.0_dp+X(5)+K1*X(3))**2-X(2)**2-X(4)**2)
          E1=1.0_dp+X(5)
       endif

       ARG=(EL%L/2.0_dp/el%p%nst)*K1/PZ
       SH_X=(EL%L/2.0_dp/el%p%nst)*SINHX_X(ARG)/PZ
       SH=SINH(ARG)
       CH=COSH(ARG)
       ARG=ARG*0.5_dp
       CHM=(EL%L/2.0_dp/el%p%nst)*SINHX_X(ARG)/PZ*SINH(ARG)
       ARG=2.0_dp*ARG

       X(1)=X(1)+X(2)*(EL%L/2.0_dp/el%p%nst)/PZ
       XT(1)=CH*X(3)+SH_X*X(4)+CHM*E1
       XT(2)=CH*X(4)+K1*SH*X(3)+SH*E1
       X(6)=X(6)+CHM*X(4)+SH*X(3)+E1*SH_X

       X(3)=XT(1)
       X(4)=XT(2)

       if(k%TIME) then
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/EL%P%BETA0/2.0_dp/el%p%nst
       else
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/2.0_dp/el%p%nst
       endif

       !       IF(PRESENT(MID)) THEN
       !          if(mod(el%p%nst,2)==1) then
       !             if(i==(el%p%nst+1)/2)  CALL XMID(MID,X,1)
       !          endif
       !       ENDIF


       K1=EL%P%CHARGE*EL%VOLT*1e-3_dp/EL%P%P0C    ! added 2004.06.09
       if(k%TIME) then
          PZ=SQRT((1.0_dp/EL%P%BETA0+X(5)+K1*X(3))**2-(EL%P%GAMMA0I/EL%P%BETA0)**2-X(2)**2-X(4)**2)
          E1=1.0_dp/EL%P%BETA0+X(5)
       else
          PZ=SQRT((1.0_dp+X(5)+K1*X(3))**2-X(2)**2-X(4)**2)
          E1=1.0_dp+X(5)
       endif


       ARG=(EL%L/2.0_dp/el%p%nst)*K1/PZ
       SH_X=(EL%L/2.0_dp/el%p%nst)*SINHX_X(ARG)/PZ
       SH=SINH(ARG)
       CH=COSH(ARG)
       ARG=ARG*0.5_dp
       CHM=(EL%L/2.0_dp/el%p%nst)*SINHX_X(ARG)/PZ*SINH(ARG)
       ARG=2.0_dp*ARG

       X(1)=X(1)+X(2)*(EL%L/2.0_dp/el%p%nst)/PZ
       XT(1)=CH*X(3)+SH_X*X(4)+CHM*E1
       XT(2)=CH*X(4)+K1*SH*X(3)+SH*E1
       X(6)=X(6)+CHM*X(4)+SH*X(3)+E1*SH_X

       X(3)=XT(1)
       X(4)=XT(2)

       if(k%TIME) then
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/EL%P%BETA0/2.0_dp/el%p%nst
       else
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/2.0_dp/el%p%nst
       endif
       !       IF(PRESENT(MID)) THEN
       !          if(mod(el%p%nst,2)==0) then
       !             if(i==el%p%nst/2)  CALL XMID(MID,X,1)
       !          endif
       !       ENDIF


       CALL KILL( K1,SH_X,SH,CH,CHM,PZ,E1,ARG)
       CALL KILL( XT,2)
    else

       CALL ALLOC( K1,SH_X,SH,CH,CHM,PZ,E1)
       CALL ALLOC( XT,2)

       K1=EL%P%CHARGE*EL%VOLT*1e-3_dp/EL%P%P0C

       if(k%TIME) then
          PZ=SQRT((1.0_dp/EL%P%BETA0+X(5)+K1*X(3))**2-(EL%P%GAMMA0I/EL%P%BETA0)**2)
          E1=1.0_dp/EL%P%BETA0+X(5)
       else
          PZ=(1.0_dp+X(5)+K1*X(3))
          E1=1.0_dp+X(5)
       endif

       ARG=(EL%L/2.0_dp/el%p%nst)*K1/PZ
       SH_X=(EL%L/2.0_dp/el%p%nst)*SINHX_X(ARG)/PZ
       SH=SINH(ARG)
       CH=COSH(ARG)
       ARG=ARG*0.5_dp
       CHM=(EL%L/2.0_dp/el%p%nst)*SINHX_X(ARG)/PZ*SINH(ARG)
       ARG=2.0_dp*ARG

       X(1)=X(1)+X(2)*(EL%L/2.0_dp/el%p%nst)/PZ
       XT(1)=CH*X(3)+SH_X*X(4)+CHM*E1
       XT(2)=CH*X(4)+K1*SH*X(3)+SH*E1
       X(6)=X(6)+CHM*X(4)+SH*X(3)+E1*SH_X

       X(3)=XT(1)
       X(4)=XT(2)

       if(k%TIME) then
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/EL%P%BETA0/2.0_dp/el%p%nst
       else
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/2.0_dp/el%p%nst
       endif

       !       IF(PRESENT(MID)) THEN
       !          if(mod(el%p%nst,2)==1) then
       !             if(i==(el%p%nst+1)/2)  CALL XMID(MID,X,1)
       !          endif
       !       ENDIF


       K1=EL%P%CHARGE*EL%VOLT*1e-3_dp/EL%P%P0C    ! added 2004.06.09
       if(k%TIME) then
          PZ=SQRT((1.0_dp/EL%P%BETA0+X(5)+K1*X(3))**2-(EL%P%GAMMA0I/EL%P%BETA0)**2)
          E1=1.0_dp/EL%P%BETA0+X(5)
       else
          PZ=(1.0_dp+X(5)+K1*X(3))
          E1=1.0_dp+X(5)
       endif


       ARG=(EL%L/2.0_dp/el%p%nst)*K1/PZ
       SH_X=(EL%L/2.0_dp/el%p%nst)*SINHX_X(ARG)/PZ
       SH=SINH(ARG)
       CH=COSH(ARG)
       ARG=ARG*0.5_dp
       CHM=(EL%L/2.0_dp/el%p%nst)*SINHX_X(ARG)/PZ*SINH(ARG)
       ARG=2.0_dp*ARG

       X(1)=X(1)+X(2)*(EL%L/2.0_dp/el%p%nst)/PZ
       XT(1)=CH*X(3)+SH_X*X(4)+CHM*E1
       XT(2)=CH*X(4)+K1*SH*X(3)+SH*E1
       X(6)=X(6)+CHM*X(4)+SH*X(3)+E1*SH_X

       X(3)=XT(1)
       X(4)=XT(2)

       if(k%TIME) then
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/EL%P%BETA0/2.0_dp/el%p%nst
       else
          X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/2.0_dp/el%p%nst
       endif

       !       IF(PRESENT(MID)) THEN
       !          if(mod(el%p%nst,2)==0) then
       !             if(i==el%p%nst/2)  CALL XMID(MID,X,1)
       !          endif
       !       ENDIF


       CALL KILL( K1,SH_X,SH,CH,CHM,PZ,E1,ARG)
       CALL KILL( XT,2)

    ENDIF
  END SUBROUTINE SEPP

  SUBROUTINE SYMPSEPR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(ESEPTUM),INTENT(INOUT):: EL
    TYPE(WORM), OPTIONAL,INTENT(INOUT):: MID
    integer i
    !    LOGICAL(LP) EXACT
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    do i=1,el%p%nst
       CALL SEPTTRACK(EL,X,k,i,MID)
    enddo

    IF(PRESENT(MID)) CALL XMID(MID,X,1)

  END SUBROUTINE SYMPSEPR

  SUBROUTINE SYMPSEPP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(ESEPTUMP),INTENT(INOUT):: EL
    ! TYPE(WORM_8), OPTIONAL,INTENT(INOUT):: MID
    integer i
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)
    do i=1,el%p%nst
       CALL SEPTTRACK(EL,X,k,i)
    enddo
    !    IF(PRESENT(MID)) CALL XMID(MID,X,1)


  END SUBROUTINE SYMPSEPP

  !  New kind for straigth exact

  SUBROUTINE KICKEXR(EL,YL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(STREX),INTENT(IN):: EL
    real(dp),INTENT(IN):: YL
    real(dp) X1,X3,BBYTW,BBXTW,BBYTWT !,X5
    INTEGER J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE

    X1=X(1)
    X3=X(3)

    !   if(k%TIME) then
    !      X5=ROOT(one+two*X(5)/EL%P%beta0+x(5)**2)-one
    !!  else
    !      X5=X(5)
    !   endif

    IF(EL%P%NMUL>=1) THEN
       BBYTW=EL%BN(EL%P%NMUL)
       BBXTW=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF


    X(2)=X(2)-YL*DIR*BBYTW
    X(4)=X(4)+YL*DIR*BBXTW

    IF(.NOT.EL%DRIFTKICK) THEN
       X(2)=X(2)+YL*DIR*EL%BN(1)
    ENDIF
    !outvalishev    if(valishev.and.ABS(el%VS)>eps)   then  !valishev
    !outvalishev     call elliptical_b(el%VA,el%VS,x,BBXTW,BBYTW) !valishev
    !outvalishev       X(2)=X(2)-YL*DIR*BBYTW !valishev
    !outvalishev       X(4)=X(4)+YL* DIR*BBXTW !valishev
    !outvalishev    endif !valishev

  END SUBROUTINE KICKEXR

  SUBROUTINE KICKEXP(EL,YL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(STREXP),INTENT(IN):: EL
    TYPE(REAL_8),INTENT(IN):: YL
    TYPE(REAL_8) X1,X3,BBYTW,BBXTW,BBYTWT !5
    INTEGER J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE

    CALL ALLOC(X1)
    CALL ALLOC(X3)
    !   CALL ALLOC(X5)
    CALL ALLOC(BBYTW)
    CALL ALLOC(BBXTW)
    CALL ALLOC(BBYTWT)

    X1=X(1)
    X3=X(3)
    !   if(k%TIME) then
    !      X5=SQRT(one+two*X(5)/EL%P%beta0+x(5)**2)-one
    !   else
    !      X5=X(5)
    !   endif


    IF(EL%P%NMUL>=1) THEN
       BBYTW=EL%BN(EL%P%NMUL)
       BBXTW=EL%AN(EL%P%NMUL)


       DO  J=EL%P%NMUL-1,1,-1
          BBYTWT=X1*BBYTW-X3*BBXTW+EL%BN(J)
          BBXTW=X3*BBYTW+X1*BBXTW+EL%AN(J)
          BBYTW=BBYTWT
       ENDDO
    ELSE
       BBYTW=0.0_dp
       BBXTW=0.0_dp
    ENDIF

    X(2)=X(2)-YL*DIR*BBYTW
    X(4)=X(4)+YL*DIR*BBXTW
    IF(.NOT.EL%DRIFTKICK) THEN
       X(2)=X(2)+YL*DIR*EL%BN(1)
    ENDIF
    !outvalishev    if(valishev.and.ABS(el%VS)>eps)   then  !valishev
    !outvalishev     call elliptical_b(el%VA,el%VS,x,BBXTW,BBYTW) !valishev
    !outvalishev       X(2)=X(2)-YL*DIR*BBYTW !valishev
    !outvalishev       X(4)=X(4)+YL* DIR*BBXTW !valishev
    !outvalishev    endif !valishev

    CALL KILL(X1)
    CALL KILL(X3)
    !   CALL KILL(X5)
    CALL KILL(BBYTW)
    CALL KILL(BBXTW)
    CALL KILL(BBYTWT)

  END SUBROUTINE KICKEXP

  SUBROUTINE INTER_STREX(EL,X,k,pos)
    IMPLICIT NONE
    TYPE(STREX),INTENT(IN):: EL
    real(dp), INTENT(INOUT) ::  X(6)
    real(dp) D,DH,DD
    real(dp) D1,D2,DK1,DK2
    real(dp) DD1,DD2
    real(dp) DF(4),DK(4),DDF(4)
    INTEGER I,J,f1,pos
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(EL%DRIFTKICK) THEN

       SELECT CASE(EL%P%METHOD)
       CASE(1)
          if(EL%F==1) then
             f1=0
          else
             f1=EL%F+1
          endif
          DH=EL%L/EL%P%NST
          D=EL%L/(EL%P%NST/EL%F/2)
          DD=EL%P%LD/EL%P%NST

          IF(MOD(POS,2*EL%F)==f1) THEN
             CALL KICKEX (EL,D,X,k)
          ENDIF
          CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
       CASE(2)
          DH=EL%L/2.0_dp/EL%P%NST
          D=EL%L/EL%P%NST
          DD=EL%P%LD/2.0_dp/EL%P%NST

          CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKEX (EL,D,X,k)
          CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)

       CASE(4)
          D1=EL%L*FD1/EL%P%NST
          D2=EL%L*FD2/EL%P%NST
          DD1=EL%P%LD*FD1/EL%P%NST
          DD2=EL%P%LD*FD2/EL%P%NST
          DK1=EL%L*FK1/EL%P%NST
          DK2=EL%L*FK2/EL%P%NST

          CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKEX (EL,DK1,X,k)
          CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKEX (EL,DK2,X,k)
          CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKEX (EL,DK1,X,k)
          CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)

       CASE(6)
          DO I =1,4
             DF(I)=EL%L*YOSD(I)/EL%P%NST
             DDF(I)=EL%P%LD*YOSD(I)/EL%P%NST
             DK(I)=EL%L*YOSK(I)/EL%P%NST
          ENDDO

          DO J=4,2,-1
             CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
             CALL KICKEX (EL,DK(J),X,k)
          ENDDO
          CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKEX (EL,DK(1),X,k)
          CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          DO J=2,4
             CALL KICKEX (EL,DK(J),X,k)
             CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          ENDDO

       CASE DEFAULT
          w_p=0
          w_p%nc=1
          w_p%fc='(1(1X,A72))'
          WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
          ! call !write_e(357)
       END SELECT
    ELSE
       SELECT CASE(EL%P%METHOD)
       CASE(2)
          DH=EL%L/2.0_dp/EL%P%NST
          D=EL%L/EL%P%NST
          DD=EL%P%LD/2.0_dp/EL%P%NST

          CALL SPAR(EL,DH,DD,X,k)
          CALL KICKEX (EL,D,X,k)
          CALL SPAR(EL,DH,DD,X,k)

       CASE(4)
          D1=EL%L*FD1/EL%P%NST
          D2=EL%L*FD2/EL%P%NST
          DD1=EL%P%LD*FD1/EL%P%NST
          DD2=EL%P%LD*FD2/EL%P%NST
          DK1=EL%L*FK1/EL%P%NST
          DK2=EL%L*FK2/EL%P%NST

          CALL SPAR(EL,D1,DD1,X,k)
          CALL KICKEX (EL,DK1,X,k)
          CALL SPAR(EL,D2,DD2,X,k)
          CALL KICKEX (EL,DK2,X,k)
          CALL SPAR(EL,D2,DD2,X,k)
          CALL KICKEX (EL,DK1,X,k)
          CALL SPAR(EL,D1,DD1,X,k)

       CASE(6)
          DO I =1,4
             DF(I)=EL%L*YOSD(I)/EL%P%NST
             DDF(I)=EL%P%LD*YOSD(I)/EL%P%NST
             DK(I)=EL%L*YOSK(I)/EL%P%NST
          ENDDO

          DO J=4,2,-1
             CALL SPAR(EL,DF(J),DDF(J),X,k)
             CALL KICKEX (EL,DK(J),X,k)
          ENDDO
          CALL SPAR(EL,DF(1),DDF(1),X,k)
          CALL KICKEX (EL,DK(1),X,k)
          CALL SPAR(EL,DF(1),DDF(1),X,k)
          DO J=2,4
             CALL KICKEX (EL,DK(J),X,k)
             CALL SPAR(EL,DF(J),DDF(J),X,k)
          ENDDO

       CASE DEFAULT
          w_p=0
          w_p%nc=1
          w_p%fc='(1(1X,A72))'
          WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
          ! call !write_e(357)
       END SELECT

    ENDIF


  END SUBROUTINE INTER_STREX

  SUBROUTINE INTEP_STREX(EL,X,k,pos)
    IMPLICIT NONE
    TYPE(STREXP),INTENT(IN):: EL
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    real(dp) DD
    real(dp) DD1,DD2
    real(dp) DDF(4)
    TYPE(REAL_8) DH,D,D1,D2,DK1,DK2,DF(4),DK(4)
    INTEGER I,J,f1,pos
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(EL%DRIFTKICK) THEN

       SELECT CASE(EL%P%METHOD)
       CASE(1)
          if(EL%F==1) then
             f1=0
          else
             f1=EL%F+1
          endif
          CALL ALLOC(DH,D)
          DH=EL%L/EL%P%NST
          D=EL%L/(EL%P%NST/EL%F/2)
          DD=EL%P%LD/EL%P%NST

          IF(MOD(POS,2*EL%F)==f1) THEN
             CALL KICKEX (EL,D,X,k)
          ENDIF
          CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL kill(DH,D)
       CASE(2)
          CALL ALLOC(DH,D)
          DH=EL%L/2.0_dp/EL%P%NST
          D=EL%L/EL%P%NST
          DD=EL%P%LD/2.0_dp/EL%P%NST

          CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKEX (EL,D,X,k)
          CALL DRIFT(DH,DD,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KILL(DH,D)

       CASE(4)
          CALL ALLOC(D1,D2,DK1,DK2)
          D1=EL%L*FD1/EL%P%NST
          D2=EL%L*FD2/EL%P%NST
          DD1=EL%P%LD*FD1/EL%P%NST
          DD2=EL%P%LD*FD2/EL%P%NST
          DK1=EL%L*FK1/EL%P%NST
          DK2=EL%L*FK2/EL%P%NST

          CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKEX (EL,DK1,X,k)
          CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKEX (EL,DK2,X,k)
          CALL DRIFT(D2,DD2,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKEX (EL,DK1,X,k)
          CALL DRIFT(D1,DD1,EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KILL(D1,D2,DK1,DK2)

       CASE(6)
          CALL ALLOC(DF,4);CALL ALLOC(DK,4);
          DO I =1,4
             DF(I)=EL%L*YOSD(I)/EL%P%NST
             DDF(I)=EL%P%LD*YOSD(I)/EL%P%NST
             DK(I)=EL%L*YOSK(I)/EL%P%NST
          ENDDO

          DO J=4,2,-1
             CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
             CALL KICKEX (EL,DK(J),X,k)
          ENDDO
          CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          CALL KICKEX (EL,DK(1),X,k)
          CALL DRIFT(DF(1),DDF(1),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          DO J=2,4
             CALL KICKEX (EL,DK(J),X,k)
             CALL DRIFT(DF(J),DDF(J),EL%P%beta0,k%TOTALPATH,EL%P%EXACT,k%TIME,X)
          ENDDO
          CALL KILL(DF,4);CALL KILL(DK,4);

       CASE DEFAULT
          w_p=0
          w_p%nc=1
          w_p%fc='(1(1X,A72))'
          WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
          ! call !write_e(357)
       END SELECT
    ELSE
       SELECT CASE(EL%P%METHOD)
       CASE(2)
          CALL ALLOC(DH,D)
          DH=EL%L/2.0_dp/EL%P%NST
          D=EL%L/EL%P%NST
          DD=EL%P%LD/2.0_dp/EL%P%NST

          CALL SPAR(EL,DH,DD,X,k)
          CALL KICKEX (EL,D,X,k)
          CALL SPAR(EL,DH,DD,X,k)
          CALL KILL(DH,D)

       CASE(4)
          CALL ALLOC(D1,D2,DK1,DK2)
          D1=EL%L*FD1/EL%P%NST
          D2=EL%L*FD2/EL%P%NST
          DD1=EL%P%LD*FD1/EL%P%NST
          DD2=EL%P%LD*FD2/EL%P%NST
          DK1=EL%L*FK1/EL%P%NST
          DK2=EL%L*FK2/EL%P%NST

          CALL SPAR(EL,D1,DD1,X,k)
          CALL KICKEX (EL,DK1,X,k)
          CALL SPAR(EL,D2,DD2,X,k)
          CALL KICKEX (EL,DK2,X,k)
          CALL SPAR(EL,D2,DD2,X,k)
          CALL KICKEX (EL,DK1,X,k)
          CALL SPAR(EL,D1,DD1,X,k)
          CALL KILL(D1,D2,DK1,DK2)

       CASE(6)
          CALL ALLOC(DF,4);CALL ALLOC(DK,4);
          DO I =1,4
             DF(I)=EL%L*YOSD(I)/EL%P%NST
             DDF(I)=EL%P%LD*YOSD(I)/EL%P%NST
             DK(I)=EL%L*YOSK(I)/EL%P%NST
          ENDDO

          DO J=4,2,-1
             CALL SPAR(EL,DF(J),DDF(J),X,k)
             CALL KICKEX (EL,DK(J),X,k)
          ENDDO
          CALL SPAR(EL,DF(1),DDF(1),X,k)
          CALL KICKEX (EL,DK(1),X,k)
          CALL SPAR(EL,DF(1),DDF(1),X,k)
          DO J=2,4
             CALL KICKEX (EL,DK(J),X,k)
             CALL SPAR(EL,DF(J),DDF(J),X,k)
          ENDDO
          CALL KILL(DF,4);CALL KILL(DK,4);

       CASE DEFAULT
          w_p=0
          w_p%nc=1
          w_p%fc='(1(1X,A72))'
          WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
          ! call !write_e(357)
       END SELECT

    ENDIF


  END SUBROUTINE INTEP_STREX

  SUBROUTINE INTEEXR(EL,X,k,MID)
    IMPLICIT NONE
    TYPE(STREX),INTENT(IN):: EL
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM) ,OPTIONAL,INTENT(INOUT):: MID
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    INTEGER I

    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    DO I=1,EL%P%NST
       IF(.NOT.PRESENT(MID))CALL TRACK_SLICE(EL,X,k,i)
       IF(PRESENT(MID)) CALL XMID(MID,X,I)
    ENDDO


  END SUBROUTINE INTEEXR





  SUBROUTINE INTEEXP(EL,X,k)
    IMPLICIT NONE
    TYPE(STREXP),INTENT(IN):: EL
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    INTEGER I


    DO I=1,EL%P%NST
       CALL TRACK_SLICE(EL,X,k,i)
    ENDDO

  END SUBROUTINE INTEEXP

  SUBROUTINE  fringe_STREXr(EL,X,k,J)
    IMPLICIT NONE
    logical(lp) :: doneitt=.true.
    integer,INTENT(IN):: J
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(STREX),INTENT(IN):: EL
    real(dp) ANGH

    ! J=1 front
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(EL%P%DIR==1) THEN

       IF(J==1) THEN

          IF(EL%LIKEMAD) THEN

             ANGH=EL%P%B0*EL%P%LD*0.5_dp-EL%P%EDGE(1)
             CALL ROT_XZ(EL%P%EDGE(1),X,EL%P%BETA0,DONEITT,k%TIME)
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             CALL  WEDGE(ANGH,X,k,EL1=EL)

          ELSE
             CALL EDGE_TRUE_PARALLEL(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,1,X,k)
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
          ENDIF

       ELSE  ! J==2


          IF(EL%LIKEMAD) THEN
             ANGH=EL%P%B0*EL%P%LD*0.5_dp-EL%P%EDGE(2)
             CALL  WEDGE(ANGH,X,k,EL1=EL)
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
             CALL ROT_XZ(EL%P%EDGE(2),X,EL%P%BETA0,DONEITT,k%TIME)
          ELSE
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             CALL EDGE_TRUE_PARALLEL(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,2,X,k)
          ENDIF

       ENDIF ! J

    ELSE

       IF(J==1) THEN

          IF(EL%LIKEMAD) THEN

             ANGH=EL%P%B0*EL%P%LD*0.5_dp-EL%P%EDGE(2)
             CALL ROT_XZ(EL%P%EDGE(2),X,EL%P%BETA0,DONEITT,k%TIME)
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             CALL  WEDGE(ANGH,X,k,EL1=EL)
          ELSE
             CALL EDGE_TRUE_PARALLEL(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,2,X,k)
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
          ENDIF


       ELSE ! J==2

          IF(EL%LIKEMAD) THEN
             ANGH=EL%P%B0*EL%P%LD*0.5_dp-EL%P%EDGE(1)
             CALL  WEDGE(ANGH,X,k,EL1=EL)
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
             CALL ROT_XZ(EL%P%EDGE(1),X,EL%P%BETA0,DONEITT,k%TIME)
          ELSE
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             CALL EDGE_TRUE_PARALLEL(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,1,X,k)
          ENDIF

       ENDIF ! J

    ENDIF

  END SUBROUTINE fringe_STREXr

  SUBROUTINE  fringe_STREXP(EL,X,k,J)
    IMPLICIT NONE
    logical(lp) :: doneitt=.true.
    integer,INTENT(IN):: J
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(STREXP),INTENT(IN):: EL
    real(dp) ANGH
    ! J=1 front
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(EL%P%DIR==1) THEN

       IF(J==1) THEN

          IF(EL%LIKEMAD) THEN

             ANGH=EL%P%B0*EL%P%LD*0.5_dp-EL%P%EDGE(1)
             CALL ROT_XZ(EL%P%EDGE(1),X,EL%P%BETA0,DONEITT,k%TIME)
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             CALL  WEDGE(ANGH,X,k,EL1=EL)

          ELSE
             CALL EDGE_TRUE_PARALLEL(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,1,X,k)
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
          ENDIF

       ELSE  ! J==2


          IF(EL%LIKEMAD) THEN
             ANGH=EL%P%B0*EL%P%LD*0.5_dp-EL%P%EDGE(2)
             CALL  WEDGE(ANGH,X,k,EL1=EL)
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
             CALL ROT_XZ(EL%P%EDGE(2),X,EL%P%BETA0,DONEITT,k%TIME)
          ELSE
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             CALL EDGE_TRUE_PARALLEL(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,2,X,k)
          ENDIF

       ENDIF ! J

    ELSE

       IF(J==1) THEN

          IF(EL%LIKEMAD) THEN

             ANGH=EL%P%B0*EL%P%LD*0.5_dp-EL%P%EDGE(2)
             CALL ROT_XZ(EL%P%EDGE(2),X,EL%P%BETA0,DONEITT,k%TIME)
             CALL FACE(EL%P,EL%BN,EL%H2,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,2,X,k)
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
             CALL  WEDGE(ANGH,X,k,EL1=EL)
          ELSE
             CALL EDGE_TRUE_PARALLEL(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,2,X,k)
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,2,X,k)
          ENDIF


       ELSE ! J==2

          IF(EL%LIKEMAD) THEN
             ANGH=EL%P%B0*EL%P%LD*0.5_dp-EL%P%EDGE(1)
             CALL  WEDGE(ANGH,X,k,EL1=EL)
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             CALL FRINGE_dipole(EL%P,EL%BN,EL%FINT,EL%HGAP,1,X,k)
             CALL FACE(EL%P,EL%BN,EL%H1,X,k)
             CALL ROT_XZ(EL%P%EDGE(1),X,EL%P%BETA0,DONEITT,k%TIME)
          ELSE
             IF(k%FRINGE.or.el%p%permfringe) CALL MULTIPOLE_FRINGE(EL%P,EL%AN,EL%BN,1,X,k)
             CALL EDGE_TRUE_PARALLEL(EL%P,EL%BN,EL%H1,EL%H2,EL%FINT,EL%HGAP,1,X,k)
          ENDIF

       ENDIF ! J

    ENDIF

  END SUBROUTINE fringe_STREXP

  SUBROUTINE SYMPINTEXR(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(STREX),INTENT(IN):: EL
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    !etienne
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(.NOT.PRESENT(MID))CALL fringe_STREX(EL,X,k,1)

    CALL INTE_strex(EL,X,k,mid)

    IF(.NOT.PRESENT(MID))CALL fringe_STREX(EL,X,k,2)





  END SUBROUTINE SYMPINTEXR

  SUBROUTINE SYMPINTEXP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(STREXP),INTENT(IN):: EL
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: MID
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL fringe_STREX(EL,X,k,1)

    CALL INTE_strex(EL,X,k)

    CALL fringe_STREX(EL,X,k,2)

  END SUBROUTINE SYMPINTEXP

  SUBROUTINE SPARr(EL,YL,DL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN):: YL,DL
    TYPE(STREX),INTENT(IN):: EL
    real(dp) XN(6),PZ,PZS,PT
    real(dp)  b
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE

    if(k%TIME) then
       B=EL%P%BETA0
       PZ=ROOT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(2)**2-X(4)**2)
       XN(2)=X(2)-YL*DIR*EL%BN(1)
       PT=ROOT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(4)**2)
       PZS=ROOT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-XN(2)**2-X(4)**2)
       XN(1)=X(1)+(PZS-PZ)/DIR/EL%BN(1)

       XN(3)=(ARCSIN(X(2)/PT)-ARCSIN(XN(2)/PT))/DIR/EL%BN(1)

       XN(6)=X(6)+XN(3)*(1.0_dp/b+x(5))
       XN(6)=XN(6)+(k%TOTALPATH-1)*DL/b

       XN(3)=X(3)+X(4)*XN(3)
    else
       PZ=ROOT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
       XN(2)=X(2)-YL*DIR*EL%BN(1)
       PT=ROOT((1.0_dp+X(5))**2-X(4)**2)
       PZS=ROOT((1.0_dp+X(5))**2-XN(2)**2-X(4)**2)
       XN(1)=X(1)+(PZS-PZ)/DIR/EL%BN(1)

       XN(3)=(ARCSIN(X(2)/PT)-ARCSIN(XN(2)/PT))/DIR/EL%BN(1)

       XN(6)=X(6)+XN(3)*(1.0_dp+X(5))
       XN(6)=XN(6)+(k%TOTALPATH-1)*DL

       XN(3)=X(3)+X(4)*XN(3)

    endif
    X(1)=XN(1)
    X(2)=XN(2)
    X(3)=XN(3)
    X(6)=XN(6)

  END SUBROUTINE SPARr

  SUBROUTINE SPARP(EL,YL,DL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(IN):: YL
    real(dp),INTENT(IN):: DL
    TYPE(STREXP),INTENT(IN):: EL
    TYPE(REAL_8) XN(6),PZ,PZS,PT
    real(dp)  b
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    real(dp) dir

    DIR=EL%P%DIR*EL%P%CHARGE

    CALL ALLOC(XN,6)
    CALL ALLOC(PZ,PZS,PT)

    if(k%TIME) then
       B=EL%P%BETA0
       PZ=SQRT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(2)**2-X(4)**2)
       XN(2)=X(2)-YL*DIR*EL%BN(1)
       PT=SQRT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(4)**2)
       PZS=SQRT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-XN(2)**2-X(4)**2)
       XN(1)=X(1)+(PZS-PZ)/DIR/EL%BN(1)

       XN(3)=(ASIN(X(2)/PT)-ASIN(XN(2)/PT))/DIR/EL%BN(1)

       XN(6)=X(6)+XN(3)*(1.0_dp/b+x(5))
       XN(6)=XN(6)+(k%TOTALPATH-1)*DL/b

       XN(3)=X(3)+X(4)*XN(3)
    else
       PZ=SQRT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
       XN(2)=X(2)-YL*DIR*EL%BN(1)
       PT=SQRT((1.0_dp+X(5))**2-X(4)**2)
       PZS=SQRT((1.0_dp+X(5))**2-XN(2)**2-X(4)**2)
       XN(1)=X(1)+(PZS-PZ)/DIR/EL%BN(1)

       XN(3)=(ASIN(X(2)/PT)-ASIN(XN(2)/PT))/DIR/EL%BN(1)

       XN(6)=X(6)+XN(3)*(1.0_dp+X(5))
       XN(6)=XN(6)+(k%TOTALPATH-1)*DL

       XN(3)=X(3)+X(4)*XN(3)

    endif
    X(1)=XN(1)
    X(2)=XN(2)
    X(3)=XN(3)
    X(6)=XN(6)

    CALL KILL(XN,6)
    CALL KILL(PZ,PZS,PT)


  END SUBROUTINE SPARP

  SUBROUTINE check_root_drift(p,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    type(magnet_chart),intent(in):: p
    real(dp) PZ
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(P%EXACT) THEN
       if(k%TIME) then
          PZ=ROOT(1.0_dp+2.0_dp*X(5)/P%BETA0+x(5)**2-X(2)**2-X(4)**2)
       else
          PZ=ROOT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
       endif
    ENDIF
    !       write(30,*) x(1:5),c_%check_stable
    if(.not.c_%check_stable)x=0.0_dp

  END SUBROUTINE check_root_drift


  SUBROUTINE wedger(A,X,k,EL1,EL2)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN):: A
    TYPE(STREX),optional,INTENT(IN):: EL1
    TYPE(TEAPOT),optional,INTENT(IN):: EL2
    real(dp) XN(6),PZ,PZS,PT,B1
    real(dp)  b
    integer TOTALPATH
    logical(lp) time,EXACT
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    EXACT=.TRUE.

    !    if(abs(x(1))+abs(x(3))+abs(x(2))+abs(x(4))>absolute_aperture.or.(.not.CHECK_MADX_APERTURE)) then
    !       if(CHECK_MADX_APERTURE) c_%message="exceed absolute_aperture in wedger"
    !       CHECK_STABLE=.false.
    !    endif
    !    if(.not.CHECK_STABLE) return


    IF(PRESENT(EL1)) THEN
       B1=EL1%P%DIR*EL1%P%CHARGE*EL1%BN(1)
       B=EL1%P%BETA0
       TOTALPATH=k%TOTALPATH
       time=k%TIME
       b=EL1%P%BETA0
    ELSEIF(PRESENT(EL2)) THEN
       B1=EL2%P%DIR*EL2%P%CHARGE*EL2%BN(1)
       B=EL2%P%BETA0
       TOTALPATH=k%TOTALPATH
       time=k%TIME
       b=EL2%P%BETA0
    ELSE
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       w_p%c(1)= " ERROR IN WEDGER "
       ! call !write_e(101)
    ENDIF

    IF(B1==0.0_dp) THEN
       call ROT_XZ(A,X,B,EXACT,time)

    ELSE


       if(TIME) then
          PZ=ROOT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(2)**2-X(4)**2)

          XN(2)=X(2)*COS(A)+(PZ-B1*X(1))*SIN(A)

          PT=ROOT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(4)**2)
          PZS=ROOT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-XN(2)**2-X(4)**2)

          XN(1)=X(1)*COS(A)+(X(1)*X(2)*SIN(2.0_dp*A)+SIN(A)**2*(2.0_dp*X(1)*PZ-B1*X(1)**2) )&
               & /(PZS+PZ*COS(A)-X(2)*SIN(A))
          XN(3)=(A+ARCSIN(X(2)/PT)-ARCSIN(XN(2)/PT))/B1

          XN(6)=X(6)+XN(3)*(1.0_dp/b+x(5))

          XN(3)=X(3)+X(4)*XN(3)
       else
          PZ=ROOT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          XN(2)=X(2)*COS(A)+(PZ-B1*X(1))*SIN(A)
          PT=ROOT((1.0_dp+X(5))**2-X(4)**2)
          PZS=ROOT((1.0_dp+X(5))**2-XN(2)**2-X(4)**2)
          XN(1)=X(1)*COS(A)+(X(1)*X(2)*SIN(2.0_dp*A)+SIN(A)**2*(2.0_dp*X(1)*PZ-B1*X(1)**2))&
               & /(PZS+PZ*COS(A)-X(2)*SIN(A))

          XN(3)=(A+ARCSIN(X(2)/PT)-ARCSIN(XN(2)/PT))/B1

          XN(6)=X(6)+XN(3)*(1.0_dp+X(5))

          XN(3)=X(3)+X(4)*XN(3)

       endif
       X(1)=XN(1)
       X(2)=XN(2)
       X(3)=XN(3)
       X(6)=XN(6)
    ENDIF
    !    CALL CHECK_STABILITY(X)

  END SUBROUTINE wedger


  SUBROUTINE wedgeP(A,X,k,EL1,EL2)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    real(dp),INTENT(IN):: A
    TYPE(STREXP),optional,INTENT(IN):: EL1
    TYPE(TEAPOTP),optional,INTENT(IN):: EL2
    TYPE(REAL_8) XN(6),PZ,PZS,PT,B1
    real(dp)  b
    integer TOTALPATH
    logical(lp) time,EXACT
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    EXACT=.TRUE.

    CALL ALLOC(PZ,PZS,PT,B1)
    CALL ALLOC(XN,6)


    IF(PRESENT(EL1)) THEN
       B1=EL1%P%DIR*EL1%P%CHARGE*EL1%BN(1)
       B=EL1%P%BETA0
       TOTALPATH=k%TOTALPATH
       time=k%TIME
       b=EL1%P%BETA0
    ELSEIF(PRESENT(EL2)) THEN
       B1=EL2%P%DIR*EL2%P%CHARGE*EL2%BN(1)
       B=EL2%P%BETA0
       TOTALPATH=k%TOTALPATH
       time=k%TIME
       b=EL2%P%BETA0
    ELSE
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       w_p%c(1)= " ERROR IN WEDGEP "
       ! call !write_e(102)
    ENDIF

    IF(B1==0.0_dp) THEN
       call ROT_XZ(A,X,B,EXACT,time)

    ELSE

       if(TIME) then
          PZ=SQRT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(2)**2-X(4)**2)
          XN(2)=X(2)*COS(A)+(PZ-B1*X(1))*SIN(A)
          PT=SQRT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-X(4)**2)
          PZS=SQRT(1.0_dp+2.0_dp*x(5)/b+X(5)**2-XN(2)**2-X(4)**2)
          XN(1)=X(1)*COS(A)+(X(1)*X(2)*SIN(2.0_dp*A)+SIN(A)**2*(2.0_dp*X(1)*PZ-B1*X(1)**2))&
               & /(PZS+PZ*COS(A)-X(2)*SIN(A))

          XN(3)=(A+ASIN(X(2)/PT)-ASIN(XN(2)/PT))/B1

          XN(6)=X(6)+XN(3)*(1.0_dp/b+x(5))

          XN(3)=X(3)+X(4)*XN(3)
       else
          PZ=SQRT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          XN(2)=X(2)*COS(A)+(PZ-B1*X(1))*SIN(A)
          PT=SQRT((1.0_dp+X(5))**2-X(4)**2)
          PZS=SQRT((1.0_dp+X(5))**2-XN(2)**2-X(4)**2)
          XN(1)=X(1)*COS(A)+(X(1)*X(2)*SIN(2.0_dp*A)+SIN(A)**2*(2.0_dp*X(1)*PZ-B1*X(1)**2))&
               & /(PZS+PZ*COS(A)-X(2)*SIN(A))

          XN(3)=(A+ASIN(X(2)/PT)-ASIN(XN(2)/PT))/B1

          XN(6)=X(6)+XN(3)*(1.0_dp+X(5))

          XN(3)=X(3)+X(4)*XN(3)

       endif
       X(1)=XN(1)
       X(2)=XN(2)
       X(3)=XN(3)
       X(6)=XN(6)
    ENDIF
    CALL KILL(PZ,PZS,PT,B1)
    CALL KILL(XN,6)

  END SUBROUTINE wedgeP

  !  CAV_TRAV

  SUBROUTINE ADJUSTR_TIME_CAV_TRAV_OUT(EL,X,k,J)
    IMPLICIT NONE
    REAL(DP), INTENT(INOUT) :: X(6)
    TYPE(CAV_TRAV),INTENT(INOUT):: EL
    integer,INTENT(IN):: J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(J==1) RETURN

    if(k%TIME) then
       X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/EL%P%BETA0
    else
       X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD
    endif

  END SUBROUTINE ADJUSTR_TIME_CAV_TRAV_OUT

  SUBROUTINE ADJUSTP_TIME_CAV_TRAV_OUT(EL,X,k,J)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(CAV_TRAVP),INTENT(INOUT):: EL
    integer,INTENT(IN):: J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(J==1) RETURN

    if(k%TIME) then
       X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD/EL%P%BETA0
    else
       X(6)=X(6)-(1-k%TOTALPATH)*EL%P%LD
    endif

  END SUBROUTINE ADJUSTP_TIME_CAV_TRAV_OUT

  SUBROUTINE INTER_CAV_TRAV(EL,X,kt,j)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(CAV_TRAV),INTENT(INOUT):: EL

    integer , INTENT(IN) :: j
    real(dp) D1
    REAL(DP) Z0
    INTEGER TOTALPATH
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    TYPE(INTERNAL_STATE) kt !,OPTIONAL :: K

    D1=el%p%dir*EL%L/EL%P%NST
    IF(EL%P%DIR==1) THEN
       Z0=(j-1)*d1
    ELSE
       Z0=EL%L+(j-1)*d1
    ENDIF

    k=kt
    TOTALPATH=k%TOTALPATH
    k%TOTALPATH=1
    SELECT CASE(EL%P%METHOD)
    CASE(2)

       call rk2_cav(z0,d1,el,X,k)

    CASE(4)

       call rk4_cav(z0,d1,el,X,k)

    CASE(6)

       call rk6_cav(z0,d1,el,X,k)
    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

    !    IF(k%FRINGE)

    k%TOTALPATH=TOTALPATH

  END SUBROUTINE INTER_CAV_TRAV

  SUBROUTINE INTEP_CAV_TRAV(EL,X,kt,j)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(CAV_TRAVP),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    TYPE(INTERNAL_STATE) kt !,OPTIONAL :: K

    !    TYPE(REAL_8), INTENT(IN) :: Z
    integer, INTENT(IN) :: j
    TYPE(REAL_8) Z0,D1
    INTEGER TOTALPATH

    CALL ALLOC(Z0,D1)

    D1=el%p%dir*EL%L/EL%P%NST
    IF(EL%P%DIR==1) THEN
       Z0=(j-1)*d1
    ELSE
       Z0=EL%L+(j-1)*d1
    ENDIF
    k=kt
    TOTALPATH=k%TOTALPATH
    k%TOTALPATH=1

    SELECT CASE(EL%P%METHOD)
    CASE(2)

       call rk2_cav(z0,d1,el,X,k)

    CASE(4)

       call rk4_cav(z0,d1,el,X,k)

    CASE(6)

       call rk6_cav(z0,d1,el,X,k)

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

    !    IF(k%FRINGE)

    k%TOTALPATH=TOTALPATH

    CALL KILL(Z0,D1)


  END SUBROUTINE INTEP_CAV_TRAV


  SUBROUTINE CAVER_TRAV(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(CAV_TRAV),INTENT(INOUT):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    !    IF(k%FRINGE)
    !
    IF(.NOT.PRESENT(MID))CALL FRINGE_CAV_TRAV(EL,X,k,1)

    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    DO I=1,EL%P%NST
       IF(.NOT.PRESENT(MID)) call track_slice(el,x,k,i)
       IF(PRESENT(MID)) CALL XMID(MID,X,I)
    ENDDO
    !
    IF(.NOT.PRESENT(MID))CALL FRINGE_CAV_TRAV(EL,X,k,2)


    call ADJUST_TIME_CAV_TRAV_OUT(EL,X,k,2)

  END SUBROUTINE CAVER_TRAV

  SUBROUTINE CAVEP_TRAV(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(CAV_TRAVP),INTENT(INOUT):: EL
    INTEGER I
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    !    IF(k%FRINGE)
    CALL FRINGE_CAV_TRAV(EL,X,k,1)


    DO I=1,EL%P%NST
       call track_slice(el,x,k,i)
    ENDDO

    CALL FRINGE_CAV_TRAV(EL,X,k,2)


    call ADJUST_TIME_CAV_TRAV_OUT(EL,X,k,2)

  END SUBROUTINE CAVEP_TRAV

  SUBROUTINE FRINGECAVR_TRAV(EL,I,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(CAV_TRAV),INTENT(INOUT):: EL
    integer, intent(in) :: i
    real(dp) C1,S1,C2,S2,V,O,Z0,CPSI,SPSI
    integer eps1,eps2
    real(dp) dv
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(k%NOCAVITY) RETURN

        IF(I==1.AND.EL%P%KILL_ENT_FRINGE) RETURN
        IF(I==-1.AND.EL%P%KILL_EXI_FRINGE) RETURN
    eps1=1
    eps2=-1
    if(EL%P%DIR*I==1) then
       Z0=0.0_dp
       dv=0.0_dp
    else
       Z0=EL%L
       dv=EL%dvds*z0
    endif

    CPSI=COS(EL%PSI)
    SPSI=SIN(EL%PSI)

    O=EL%freq*twopi/CLIGHT
    C1=(eps1+(EL%P%DIR-eps1)*0.5_dp)*COS(O*(x(6)-Z0)+EL%PHAS+EL%phase0)
    C2=(eps2+(EL%P%DIR-eps2)*0.5_dp)*COS(O*(x(6)+Z0)+EL%PHAS+EL%phase0+EL%DPHAS)
    ! REMOVE FRINGE IN OPPOSITE DIRECTION  ULTRA RELATIVISTIC
    S1=(eps1+(EL%P%DIR-eps1)*0.5_dp)*SIN(O*(x(6)-Z0)+EL%PHAS+EL%phase0)
    S2=(eps2+(EL%P%DIR-eps2)*0.5_dp)*SIN(O*(x(6)+ Z0)+EL%PHAS+EL%phase0+EL%DPHAS)
    ! REMOVE FRINGE IN OPPOSITE DIRECTION   ULTRA RELATIVISTIC
    V=I*EL%P%CHARGE*(EL%volt-dv)*1e-3_dp/EL%P%P0C

    X(2)=X(2)+V*(CPSI*S1+SPSI*S2)*X(1)
    X(4)=X(4)+V*(CPSI*S1+SPSI*S2)*X(3)
    x(5)=x(5)-0.5_dp*(X(1)**2+X(3)**2)*V*(CPSI*C1+SPSI*C2)*O

  END SUBROUTINE FRINGECAVR_TRAV

  SUBROUTINE FRINGECAVP_TRAV(EL,I,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(CAV_TRAVP),INTENT(INOUT):: EL
    integer, intent(in) :: i
    TYPE(REAL_8) C1,S1,C2,S2,V,O,Z0,F,CPSI,SPSI,dv
    integer eps1,eps2
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    IF(k%NOCAVITY) RETURN

        IF(I==1.AND.EL%P%KILL_ENT_FRINGE) RETURN
        IF(I==-1.AND.EL%P%KILL_EXI_FRINGE) RETURN

    CALL ALLOC(C1,S1,C2,S2,V,O,Z0,F,CPSI,SPSI)
    call alloc(dv)

    eps1=1
    eps2=-1
    if(EL%P%DIR*I==1) then
       Z0=0.0_dp
       dv=0.0_dp
    else
       Z0=EL%L
       dv=EL%dvds*z0
    endif

    CPSI=COS(EL%PSI)
    SPSI=SIN(EL%PSI)

    O=EL%freq*twopi/CLIGHT
    C1=(eps1+(EL%P%DIR-eps1)*0.5_dp)*COS(O*(x(6)-Z0)+EL%PHAS+EL%phase0)
    C2=(eps2+(EL%P%DIR-eps2)*0.5_dp)*COS(O*(x(6)+Z0)+EL%PHAS+EL%phase0+EL%DPHAS)
    ! REMOVE FRINGE IN OPPOSITE DIRECTION  ULTRA RELATIVISTIC
    S1=(eps1+(EL%P%DIR-eps1)*0.5_dp)*SIN(O*(x(6)-Z0)+EL%PHAS+EL%phase0)
    S2=(eps2+(EL%P%DIR-eps2)*0.5_dp)*SIN(O*(x(6)+Z0)+EL%PHAS+EL%phase0+EL%DPHAS)
    ! REMOVE FRINGE IN OPPOSITE DIRECTION   ULTRA RELATIVISTIC
    V=I*EL%P%CHARGE*(EL%volt-dv)*1e-3_dp/EL%P%P0C


    X(2)=X(2)+V*(CPSI*S1+SPSI*S2)*X(1)
    X(4)=X(4)+V*(CPSI*S1+SPSI*S2)*X(3)
    x(5)=x(5)-0.5_dp*(X(1)**2+X(3)**2)*V*(CPSI*C1+SPSI*C2)*O




    call KILL(dv)
    CALL KILL(C1,S1,C2,S2,V,O,Z0,F,CPSI,SPSI)
  END SUBROUTINE FRINGECAVP_TRAV

  SUBROUTINE  FRINGE_CAV_TRAVR(EL,X,k,J)
    IMPLICIT NONE
    !      TYPE(BEAM), INTENT(INOUT) ::B
    integer,INTENT(IN):: J
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(CAV_TRAV),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    ! J=1 front
    IF(J==1) THEN

       CALL FRINGECAV_TRAV(EL,EL%P%DIR,X,k)

    ELSE

       CALL FRINGECAV_TRAV(EL,-EL%P%DIR,X,k)

    ENDIF

  END SUBROUTINE FRINGE_CAV_TRAVR

  SUBROUTINE  FRINGE_CAV_TRAVP(EL,X,k,J)
    IMPLICIT NONE
    !      TYPE(BEAM), INTENT(INOUT) ::B
    integer,INTENT(IN):: J
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(CAV_TRAVP),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    ! J=1 front
    IF(J==1) THEN

       CALL FRINGECAV_TRAV(EL,EL%P%DIR,X,k)

    ELSE

       CALL FRINGECAV_TRAV(EL,-EL%P%DIR,X,k)

    ENDIF

  END SUBROUTINE FRINGE_CAV_TRAVP



  SUBROUTINE ZEROR_CAV_TRAV(EL,I)
    IMPLICIT NONE
    TYPE(CAV_TRAV), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%DPHAS)) then
          deallocate(EL%PSI)
          deallocate(EL%DPHAS)
          deallocate(EL%DVDS)
          deallocate(EL%cavity_totalpath)
          deallocate(EL%phase0)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%phase0)
       NULLIFY(EL%cavity_totalpath)
       NULLIFY(EL%PSI)
       NULLIFY(EL%DPHAS)
       NULLIFY(EL%DVDS)
    endif

  END SUBROUTINE ZEROR_CAV_TRAV

  SUBROUTINE ZEROP_CAV_TRAV(EL,I)
    IMPLICIT NONE
    TYPE(CAV_TRAVP), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%DPHAS)) then
          CALL KILL(EL%DPHAS)
          deallocate(EL%DPHAS)
          CALL KILL(EL%PSI)
          deallocate(EL%PSI)
          CALL KILL(EL%DVDS)
          deallocate(EL%DVDS)
          deallocate(EL%cavity_totalpath)
          deallocate(EL%phase0)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%phase0)
       NULLIFY(EL%cavity_totalpath)
       NULLIFY(EL%PSI)
       NULLIFY(EL%DPHAS)
       NULLIFY(EL%DVDS)
    endif

  END SUBROUTINE ZEROP_CAV_TRAV


  SUBROUTINE ZEROr_mon(EL,I)
    IMPLICIT NONE
    TYPE(MON), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%x)) deallocate(EL%x)
       if(ASSOCIATED(EL%y)) deallocate(EL%y)

    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%x)
       NULLIFY(EL%y)

    endif


  END SUBROUTINE ZEROr_mon

  SUBROUTINE ZEROP_mon(EL,I)
    IMPLICIT NONE
    TYPE(MONP), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k,j
    IF(I==-1) THEN
       if(ASSOCIATED(EL%x)) deallocate(EL%x)
       if(ASSOCIATED(EL%y)) deallocate(EL%y)

    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%x)
       NULLIFY(EL%y)

    endif

  END SUBROUTINE ZEROP_mon

  SUBROUTINE ZEROr_RCOL(EL,I)
    IMPLICIT NONE
    TYPE(RCOL), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
     return
    IF(I==-1) THEN
     !  if(ASSOCIATED(EL%A)) THEN
     !     CALL KILL(EL%A)
     !     deallocate(EL%A)
     !  ENDIF

    elseif(i==0)       then          ! nullifies

     !  NULLIFY(EL%A)

    endif


  END SUBROUTINE ZEROr_RCOL

  SUBROUTINE ZEROP_RCOL(EL,I)
    IMPLICIT NONE
    TYPE(RCOLP), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k,j
    return 
   IF(I==-1) THEN
!       if(ASSOCIATED(EL%A)) THEN
!          CALL KILL(EL%A)
!          deallocate(EL%A)
!       ENDIF

    elseif(i==0)       then          ! nullifies

 !      NULLIFY(EL%A)

    endif

  END SUBROUTINE ZEROP_RCOL


  SUBROUTINE ZEROr_ECOL(EL,I)
    IMPLICIT NONE
    TYPE(ECOL), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
     return 
   IF(I==-1) THEN
  !     if(ASSOCIATED(EL%A)) THEN
  !        CALL KILL(EL%A)
  !        deallocate(EL%A)
  !     ENDIF

    elseif(i==0)       then          ! nullifies

   !    NULLIFY(EL%A)

    endif

  END SUBROUTINE ZEROr_ECOL

  SUBROUTINE ZEROP_ECOL(EL,I)
    IMPLICIT NONE
    TYPE(ECOLP), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k,j
    IF(I==-1) THEN
     !  if(ASSOCIATED(EL%A)) THEN
     !     CALL KILL(EL%A)
     !     deallocate(EL%A)
     !  ENDIF

    elseif(i==0)       then          ! nullifies

     !  NULLIFY(EL%A)

    endif

  END SUBROUTINE ZEROP_ECOL


  ! TYPE multip


  SUBROUTINE ZEROr_DKD2(EL,I)
    IMPLICIT NONE
    TYPE(DKD2), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%F)) deallocate(EL%F)
    elseif(i==0)       then          ! nullifies
       NULLIFY(EL%F)
    endif

  END SUBROUTINE ZEROr_DKD2

  SUBROUTINE ZEROp_DKD2(EL,I)
    IMPLICIT NONE
    TYPE(DKD2P), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%F)) deallocate(EL%F)
    elseif(i==0)       then          ! nullifies
       NULLIFY(EL%F)
    endif

  END SUBROUTINE ZEROp_DKD2


  SUBROUTINE ZEROr_KTK(EL,I)
    IMPLICIT NONE
    TYPE(KTK), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%MATX)) then
          deallocate(EL%MATX)
          deallocate(EL%LX)
       endif
       if(ASSOCIATED(EL%MATY)) then
          deallocate(EL%MATY)
          deallocate(EL%LY)
       endif

    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%MATX)
       NULLIFY(EL%MATY)
       NULLIFY(EL%LX)
       NULLIFY(EL%LY)
    endif

  END SUBROUTINE ZEROr_KTK

  SUBROUTINE ZEROP_KTK(EL,I)
    IMPLICIT NONE
    TYPE(KTKP), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k,j
    IF(I==-1) THEN
       if(ASSOCIATED(EL%MATX)) then
          deallocate(EL%MATX)
          deallocate(EL%LX)
       endif
       if(ASSOCIATED(EL%MATY)) then
          deallocate(EL%MATY)
          deallocate(EL%LY)
       endif

    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%MATX)
       NULLIFY(EL%MATY)
       NULLIFY(EL%LX)
       NULLIFY(EL%LY)

    endif

  END SUBROUTINE ZEROP_KTK

  SUBROUTINE ALLOCKTK(EL)
    IMPLICIT NONE
    TYPE(KTKP), INTENT(INOUT)::EL
    INTEGER I,J

    DO I=1,2
       DO J=1,3
          CALL ALLOC(EL%MATX(I,J))
          CALL ALLOC(EL%MATY(I,J))
       ENDDO
    ENDDO

    DO I=1,6
       CALL ALLOC(EL%LX(I))
    ENDDO
    DO I=1,3
       CALL ALLOC(EL%LY(I))
    ENDDO

  END SUBROUTINE ALLOCKTK

  SUBROUTINE KILLKTK(EL)
    IMPLICIT NONE
    TYPE(KTKP), INTENT(INOUT)::EL
    INTEGER I,J

    DO I=1,2
       DO J=1,3
          CALL KILL(EL%MATX(I,J))
          CALL KILL(EL%MATY(I,J))
       ENDDO
    ENDDO

    DO I=1,6
       CALL KILL(EL%LX(I))
    ENDDO
    DO I=1,3
       CALL KILL(EL%LY(I))
    ENDDO

  END SUBROUTINE KILLKTK

  SUBROUTINE ZEROr_TKT7(EL,I)
    IMPLICIT NONE
    TYPE(TKTF), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%F)) deallocate(EL%F)
       if(ASSOCIATED(EL%MATX)) then
          deallocate(EL%MATX)
       endif
       if(ASSOCIATED(EL%MATY)) then
          deallocate(EL%MATY)
       endif
       if(ASSOCIATED(EL%LX)) then
          deallocate(EL%LX)
       endif
       if(ASSOCIATED(EL%RMATX)) then
          deallocate(EL%RMATX)
       endif
       if(ASSOCIATED(EL%RMATY)) then
          deallocate(EL%RMATY)
       endif
       if(ASSOCIATED(EL%RLX)) then
          deallocate(EL%RLX)
       endif
       !       if(ASSOCIATED(EL%dx)) then
       !          deallocate(EL%dx)
       !       endif
       !       if(ASSOCIATED(EL%dy)) then
       !          deallocate(EL%dy)
       !       endif
    elseif(i==0)       then          ! nullifies

       !       NULLIFY(EL%dx)
       !       NULLIFY(EL%dy)
       NULLIFY(EL%F)
       NULLIFY(EL%MATX)
       NULLIFY(EL%MATY)
       NULLIFY(EL%LX)
       NULLIFY(EL%RMATX)
       NULLIFY(EL%RMATY)
       NULLIFY(EL%RLX)
    endif

  END SUBROUTINE ZEROr_TKT7

  SUBROUTINE ZEROP_TKT7(EL,I)
    IMPLICIT NONE
    TYPE(TKTFP), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    integer k,j

    IF(I==-1) THEN
       if(ASSOCIATED(EL%F)) deallocate(EL%F)
       if(ASSOCIATED(EL%MATX)) then
          DO K=1,2
             DO J=1,3
                CALL KILL(EL%MATX(K,J))   ! not used, will be used locally only
             ENDDO
          ENDDO
          deallocate(EL%MATX)
       endif
       if(ASSOCIATED(EL%MATY)) then
          DO K=1,2
             DO J=1,3
                CALL KILL(EL%MATY(K,J))   ! not used, will be used locally only
             ENDDO
          ENDDO
          deallocate(EL%MATY)
       endif

       if(ASSOCIATED(EL%LX)) then
          DO J=1,3
             CALL KILL(EL%LX(J))   ! not used, will be used locally only
          ENDDO
          deallocate(EL%LX)
       endif
       if(ASSOCIATED(EL%RMATX)) then
          DO K=1,2
             DO J=1,3
                CALL KILL(EL%RMATX(K,J))   ! not used, will be used locally only
             ENDDO
          ENDDO
          deallocate(EL%RMATX)
       endif
       if(ASSOCIATED(EL%RMATY)) then
          DO K=1,2
             DO J=1,3
                CALL KILL(EL%RMATY(K,J))   ! not used, will be used locally only
             ENDDO
          ENDDO
          deallocate(EL%RMATY)
       endif

       if(ASSOCIATED(EL%RLX)) then
          DO J=1,3
             CALL KILL(EL%RLX(J))   ! not used, will be used locally only
          ENDDO
          deallocate(EL%RLX)
       endif
       !       if(ASSOCIATED(EL%dx)) then
       !          deallocate(EL%dx)
       !       endif
       !       if(ASSOCIATED(EL%dy)) then
       !          deallocate(EL%dy)
       !       endif

    elseif(i==0)       then          ! nullifies

       !       NULLIFY(EL%dx)
       !       NULLIFY(EL%dy)
       NULLIFY(EL%MATX)
       NULLIFY(EL%MATY)
       NULLIFY(EL%LX)
       NULLIFY(EL%RMATX)
       NULLIFY(EL%RMATY)
       NULLIFY(EL%RLX)

    endif

  END SUBROUTINE ZEROP_TKT7

  SUBROUTINE ALLOCTKT7(EL)
    IMPLICIT NONE
    TYPE(TKTFP), INTENT(INOUT)::EL
    INTEGER I,J

    DO I=1,2
       DO J=1,3
          CALL ALLOC(EL%MATX(I,J))
          CALL ALLOC(EL%MATY(I,J))
          CALL ALLOC(EL%RMATX(I,J))
          CALL ALLOC(EL%RMATY(I,J))
       ENDDO
    ENDDO

    DO I=1,3
       CALL ALLOC(EL%LX(I))
       CALL ALLOC(EL%RLX(I))
    ENDDO

  END SUBROUTINE ALLOCTKT7

  SUBROUTINE KILLTKT7(EL)
    IMPLICIT NONE
    TYPE(TKTFP), INTENT(INOUT)::EL
    INTEGER I,J

    DO I=1,2
       DO J=1,3
          CALL KILL(EL%MATX(I,J))
          CALL KILL(EL%MATY(I,J))
          CALL KILL(EL%RMATX(I,J))
          CALL KILL(EL%RMATY(I,J))
       ENDDO
    ENDDO
    DO I=1,3
       CALL KILL(EL%LX(I))
       CALL KILL(EL%RLX(I))
    ENDDO

  END SUBROUTINE KILLTKT7




!       if(ASSOCIATED(EL%bf_x)) then
!          CALL KILL(EL%bf_x,S_B0%N_MONO)   ! not used, will be used locally only
!          deallocate(EL%bf_x)
!       endif
!       if(ASSOCIATED(EL%bf_Y)) then
!          CALL KILL(EL%bf_Y,S_B0%N_MONO)   ! not used, will be used locally only
!          deallocate(EL%bf_Y)
!       endif


SUBROUTINE ZEROr_teapot(EL,I)
    IMPLICIT NONE
    TYPE(TEAPOT), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%F)) deallocate(EL%F)
       if(ASSOCIATED(EL%bf_x)) then
          deallocate(EL%bf_x)
       endif
       if(ASSOCIATED(EL%bf_y)) then
          deallocate(EL%bf_y)
       endif
       if(ASSOCIATED(EL%DRIFTKICK)) then
          deallocate(EL%DRIFTKICK)
       endif
       if(ASSOCIATED(EL%e_x)) then
         deallocate(EL%e_x,EL%e_y,EL%PHI,EL%AE,EL%BE,EL%As,EL%Bs)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%f)
       NULLIFY(EL%bf_x)
       NULLIFY(EL%bf_y)
       NULLIFY(EL%DRIFTKICK)
       NULLIFY(EL%e_x,EL%e_y,EL%PHI,EL%AE,EL%BE,EL%As,EL%Bs)
    endif

  END SUBROUTINE ZEROr_teapot

  SUBROUTINE ZEROP_teapot(EL,I)
    IMPLICIT NONE
    TYPE(TEAPOTP), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I

    IF(I==-1) THEN
       if(ASSOCIATED(EL%F)) deallocate(EL%F)
       if(ASSOCIATED(EL%bf_x)) then
          CALL KILL(EL%bf_x,S_B(SECTOR_NMUL)%N_MONO)   ! not used, will be used locally only
          !          CALL KILL(EL%bf_x,S_B(EL%P%NMUL)%N_MONO)   ! not used, will be used locally only
          deallocate(EL%bf_x)
       endif
       if(ASSOCIATED(EL%bf_Y)) then
          CALL KILL(EL%bf_Y,S_B(SECTOR_NMUL)%N_MONO)   ! not used, will be used locally only
          !          CALL KILL(EL%bf_Y,S_B(EL%P%NMUL)%N_MONO)   ! not used, will be used locally only
          deallocate(EL%bf_Y)
       endif
       if(ASSOCIATED(EL%DRIFTKICK)) then
          deallocate(EL%DRIFTKICK)
       endif
       if(ASSOCIATED(EL%e_x)) then
         CALL KILL(EL%e_x)
         CALL KILL(EL%e_y,EL%PHI)
         CALL KILL(EL%AE)
         CALL KILL(EL%BE)
         deallocate(EL%e_x,EL%e_y,EL%AE,EL%BE,EL%PHI)
       endif

    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%f)
       NULLIFY(EL%bf_x)
       NULLIFY(EL%bf_Y)
       NULLIFY(EL%DRIFTKICK)
       NULLIFY(EL%e_x,EL%e_y,EL%AE,EL%BE,EL%PHI)

    endif

  END SUBROUTINE ZEROP_teapot


  SUBROUTINE ZEROR_CAV4(EL,I)
    IMPLICIT NONE
    TYPE(CAV4), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%N_BESSEL)) then
          deallocate(EL%N_BESSEL)
       endif
       if(ASSOCIATED(EL%t)) then
          deallocate(EL%t)
       endif
       if(ASSOCIATED(EL%NF)) then
          deallocate(EL%NF)
       endif
       if(ASSOCIATED(EL%F)) then
          deallocate(EL%F)
       endif
       if(ASSOCIATED(EL%PH)) then
          deallocate(EL%PH)
       endif
       if(ASSOCIATED(EL%A)) then
          deallocate(EL%A)
       endif
       if(ASSOCIATED(EL%R)) then
          deallocate(EL%R)
       endif
       if(ASSOCIATED(EL%always_on)) then
          deallocate(EL%always_on)
       endif

       if(ASSOCIATED(EL%CAVITY_TOTALPATH)) then
          deallocate(EL%CAVITY_TOTALPATH)
       endif
       if(ASSOCIATED(EL%phase0)) then
          deallocate(EL%phase0)
       endif
       if(ASSOCIATED(EL%ACC)) then
       call kill_acceleration(EL%ACC)
          deallocate(EL%ACC)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%ACC)
       NULLIFY(EL%t)
       NULLIFY(EL%phase0)
       NULLIFY(EL%CAVITY_TOTALPATH)
       NULLIFY(EL%N_BESSEL)
       NULLIFY(EL%NF)
       NULLIFY(EL%F)
       NULLIFY(EL%A)
       NULLIFY(EL%R)
       NULLIFY(EL%always_on)
       NULLIFY(EL%PH)
    endif

  END SUBROUTINE ZEROR_CAV4

  SUBROUTINE ZEROP_CAV4(EL,I)
    IMPLICIT NONE
    TYPE(CAV4P), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%t)) then
          deallocate(EL%t)
       endif
       if(ASSOCIATED(EL%N_BESSEL)) then
          deallocate(EL%N_BESSEL)
       endif
       if(ASSOCIATED(EL%CAVITY_TOTALPATH)) then
          deallocate(EL%CAVITY_TOTALPATH)
       endif
       if(ASSOCIATED(EL%phase0)) then
          deallocate(EL%phase0)
       endif
       if(ASSOCIATED(EL%F)) then
          CALL KILL(EL%F,EL%NF)
          deallocate(EL%F)
       endif
       if(ASSOCIATED(EL%PH)) then
          CALL KILL(EL%PH,EL%NF)
          deallocate(EL%PH)
       endif
       if(ASSOCIATED(EL%R)) then
          CALL KILL(EL%R)
          deallocate(EL%R)
       endif
       if(ASSOCIATED(EL%always_on)) then
          deallocate(EL%always_on)
       endif
       if(ASSOCIATED(EL%A)) then
          CALL KILL(EL%A)
          deallocate(EL%A)
       endif
       if(ASSOCIATED(EL%NF)) then
          deallocate(EL%NF)
       endif
       if(ASSOCIATED(EL%ACC)) then
       call kill_acceleration(EL%ACC)
          deallocate(EL%ACC)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%ACC)
       NULLIFY(EL%t)
       NULLIFY(EL%phase0)
       NULLIFY(EL%CAVITY_TOTALPATH)
       NULLIFY(EL%N_BESSEL)
       NULLIFY(EL%NF)
       NULLIFY(EL%F)
       NULLIFY(EL%A)
       NULLIFY(EL%R)
       NULLIFY(EL%always_on)
       NULLIFY(EL%PH)
    endif

  END SUBROUTINE ZEROP_CAV4

  SUBROUTINE ZEROR_RAMP(EL,I)
    IMPLICIT NONE
    TYPE(RAMPING), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
     call kill_ramping(EL)
    elseif(i==0)       then          ! nullifies

     call nullify_ramping(EL)

    endif

  END SUBROUTINE ZEROR_RAMP



!!!!!!!!!!!!!!!!! cav4 acceleration !!!!!!!!!!!!!!!!!!! 
   SUBROUTINE alloc_acceleration(acc,nst,n,n_max,filename)
   implicit none
   type(acceleration), target :: acc
   integer i,n,n_max,nst
   character(*) filename
   allocate(acc%n)
   acc%n=n
   allocate(acc%tableau(n))
   allocate(acc%fichier)
   allocate(acc%r)
!   allocate(acc%unit_time)
   allocate(acc%w1)
   allocate(acc%nst)
   allocate(acc%de(nst))
   allocate(acc%e_in(nst))
   allocate(acc%w2)
   allocate(acc%pos)
   nullify(acc%next)
   acc%de=0.0_dp
   acc%e_in=0.0_dp
   acc%nst=nst
   acc%pos=0
!   acc%w1=0   not yet defined, done later
!   acc%w2=0
   acc%r=1.0_dp
   acc%fichier=' '
   
   if(len(filename)>255) then
    write(6,*)  " Name of file too long (>255) "
    stop 1945
   endif 
   acc%fichier=filename
   
   do i=1,n
    call alloc_tableau(acc%tableau(i),n_max)
   enddo
   
   end SUBROUTINE alloc_acceleration
   
   SUBROUTINE alloc_tableau(tableau,n)
   implicit none
   type(temps_energie), target, intent(inout) :: tableau
   integer n
   allocate(tableau%volt(n),tableau%phase(n),tableau%temps,tableau%energie,tableau%tc)
    tableau%volt=0.0_dp
    tableau%phase=0.0_dp
    tableau%temps=0.0_dp
    tableau%energie=0.0_dp
    tableau%tc=0.0_dp
   end SUBROUTINE alloc_tableau
 
   SUBROUTINE kill_tableau(tableau)
   implicit none
   type(temps_energie), target, intent(inout)  :: tableau
   deallocate(tableau%volt,tableau%phase,tableau%temps,tableau%energie,tableau%tc)

   end SUBROUTINE kill_tableau
 
   SUBROUTINE kill_acceleration(acc)
   implicit none
   type(acceleration), target , intent(inout) :: acc
   integer i
   
   do i=1,acc%n
    call kill_tableau(acc%tableau(i))
   enddo
   
   deallocate(acc%tableau)
   nullify(acc%next)
   nullify(acc%previous)
   deallocate(acc%pos)
!   deallocate(acc%unit_time)
   deallocate(acc%n)
   deallocate(acc%r)
   deallocate(acc%w1)
   deallocate(acc%w2)
   deallocate(acc%de)
   deallocate(acc%e_in)
   deallocate(acc%nst)
   deallocate(acc%fichier)
   
   end SUBROUTINE kill_acceleration

   SUBROUTINE nullify_acceleration(acc)
   implicit none
   type(acceleration), target , intent(inout) :: acc
   
   nullify(acc%w1)
   nullify(acc%w2)
   nullify(acc%r)
   nullify(acc%n)
   nullify(acc%POS)
   nullify(acc%NEXT)
   nullify(acc%previous)
!   nullify(acc%unit_time)
   nullify(acc%nst)
   nullify(acc%de)
   nullify(acc%e_in)
   nullify(acc%tableau)
   nullify(acc%fichier)
   
   end SUBROUTINE nullify_acceleration

   SUBROUTINE copy_tableau(tableau1,tableau2)
   implicit none
   type(temps_energie), target, intent(in) :: tableau1
   type(temps_energie), target,  intent(inout)  :: tableau2

    if(associated(tableau2%volt)) call kill_tableau(tableau2)
    call alloc_tableau(tableau2,size(tableau1%phase))
    
    tableau2%volt=tableau1%volt
    tableau2%phase=tableau1%phase
    tableau2%temps=tableau1%temps
    tableau2%energie=tableau1%energie
    tableau2%tc=tableau1%tc
   end SUBROUTINE copy_tableau
 
   SUBROUTINE copy_acceleration(acc1,acc2)
   implicit none
   type(acceleration), target, intent(in) :: acc1
   type(acceleration), target,  intent(inout)  :: acc2
   integer i
   
   if(associated(acc2%n)) call kill_acceleration(acc2)
   call alloc_acceleration(acc2,acc1%nst,size(acc1%tableau),size(acc1%tableau(1)%volt),acc1%fichier)
   acc2%previous=>acc1%previous
   acc2%next=>acc1%next
   acc2%pos=acc1%pos
   acc2%nst=acc1%nst
   acc2%de=acc1%de
   acc2%e_in=acc1%e_in
!   acc2%unit_time=acc1%unit_time
   acc2%r=acc1%r
   do i=1,acc2%n
!    acc2%tableau(i)=acc1%tableau(i)
    call copy_tableau(acc1%tableau(i),acc2%tableau(i))
   enddo
   

   end SUBROUTINE copy_acceleration
 

   SUBROUTINE lecture_fichier(EL,fichier)
   implicit none
   type(element), target, intent(inout) :: EL
   type(elementp), pointer :: elp
   character(*) fichier
   integer mf,i,n_mode,n_max,j,n,cavpath,pos
   integer, allocatable :: js(:)
   real(dp) r,ut,tc
   
   if(ASSOCIATED(ACC)) THEN
    ACC%NEXT=>el%parent_fibre
    pos=acc%pos+1
   else
   pos=1
   paccfirst=>el%parent_fibre
   ENDIF
   
   if(el%kind/=kind4) then
    write(6,*) " error not a standard cavity "
    stop 1946
   endif
   
   call kanalnummer(mf,fichier)
   read(mf,*) n,ut,r,cavpath,n_mode   ! r percentage of acceleration from that cavity
  ! n is number of lines in files
  ! r is the percentage of acceleration done by that cavity
  ! cavpath is 0 or 1  usual fake pill box parameter
  ! n_mode number of mode

   allocate(js(n_mode))
   
   allocate(el%c4%acc)
   
   acc=> el%c4%acc
   
      if(.not.ASSOCIATED(paccfirst,el%parent_fibre)) THEN
      acc%previous=>paccthen
      else
      accfirst=>acc
      endif
   
   read(mf,*) js

   n_max=0
   do i=1,n_mode
    if(js(i)>n_max) n_max=js(i)
   enddo


   
   call alloc_acceleration(acc,el%p%nst,n,n_max,fichier)
   

!    acc%unit_time=ut

   
   acc%pos=pos
   acc%r=r
   do i=1,acc%n
    if(read_tc) then
     read(mf,*) acc%tableau(i)%temps,acc%tableau(i)%energie,   &
     (acc%tableau(i)%volt(js(j)),acc%tableau(i)%phase(js(j)),j=1,n_mode ),acc%tableau(i)%tc
    else
     read(mf,*) acc%tableau(i)%temps,acc%tableau(i)%energie,   &
     (acc%tableau(i)%volt(js(j)),acc%tableau(i)%phase(js(j)),j=1,n_mode )
     acc%tableau(i)%tc=0.0_dp
    endif 
  !  acc%tableau(i)%phase(2)=-acc%tableau(i)%phase(2)
  !  write(6,*) acc%tableau(i)%phase(2)
     acc%tableau(i)%temps=acc%tableau(i)%temps*ut
   enddo
   
   close(mf)
   
   deallocate(js)
   elp=>el%parent_fibre%magp
   if(.not.associated(elp%c4%acc)) then
    allocate(elp%c4%acc)
      call nullify_acceleration(elp%c4%acc)
   endif

     ! write(6,*) " initial time shift in cavity ",el%c4%t
      tc=0.0_dp   !el%c4%t
      call copy_acceleration(acc,elp%c4%acc)

      if(size(acc%tableau(1)%volt)/=el%c4%nf) then
       el%c4%nf=size(acc%tableau(1)%volt)
       elp%c4%nf=size(acc%tableau(1)%volt)
       call kill(elp%c4%f)
       deallocate(elp%c4%f)
       deallocate(el%c4%f)
       allocate(el%c4%f(el%c4%nf));el%c4%f=0.0_dp;el%c4%f(1)=1.0_dp;
       allocate(elp%c4%f(el%c4%nf))
       call alloc(elp%c4%f,el%c4%nf)
       elp%c4%f(1)=1.0_dp    

       call kill(elp%c4%ph)
       deallocate(elp%c4%ph)
       deallocate(el%c4%ph)
       allocate(el%c4%ph(el%c4%nf));el%c4%ph=0.0_dp; 
       allocate(elp%c4%ph(el%c4%nf))
       call alloc(elp%c4%ph,el%c4%nf)
      endif
      
      el%c4%volt =1.0_dp
      elp%c4%volt =1.0_dp
      el%c4%phas  =0.0_dp
      elp%c4%phas =0.0_dp
      el%c4%phase0  =0.0_dp
      elp%c4%phase0 =0.0_dp      
      el%c4%t  =tc
      elp%c4%t =tc
     
         do i=1,el%c4%nf
          el%c4%f(i)   = acc%tableau(1)%volt(i)
          el%c4%ph(i)  = acc%tableau(1)%phase(i)
          elp%c4%f(i)  = acc%tableau(1)%volt(i)
          elp%c4%ph(i) = acc%tableau(1)%phase(i)
         enddo
     if(cavpath==0.or. cavpath==1) then   
     el%c4%cavity_totalpath=cavpath    
     elp%c4%cavity_totalpath=cavpath 
     else
     write(6,*) "cavpath is wrong ",cavpath  
     endif  
    
     NULLIFY(ACC%NEXT) 
     
     paccthen=>el%parent_fibre
     
   END SUBROUTINE lecture_fichier 
 
 !!!!!!!!!!!!! ramping !!!!!!!!!!!!! 
 
 !  SUBROUTINE alloc_ramping(acc,unit_time,t_max,n,n_max,filename)
  SUBROUTINE alloc_ramping(acc,t_max,n,n_max,filename)
   implicit none
   type(ramping), target :: acc
   integer i,n,n_max
   character(*) filename
   real(dp) t_max   !unit_time,
   
   allocate(acc%n)
   acc%n=n
   allocate(acc%table(0:n))
   allocate(acc%file)
   allocate(acc%r,acc%t_max)
!   allocate(acc%unit_time)
   acc%r=1.0_dp
   acc%t_max=t_max
!   acc%unit_time=unit_time
   acc%file=' '
   
   if(len(filename)>255) then
    write(6,*)  " Name of file too long (>255) "
    stop 1945
   endif 
   acc%file=filename
   
   do i=0,n
    call alloc_table(acc%table(i),n_max)
   enddo
   
   end SUBROUTINE alloc_ramping
   
   SUBROUTINE alloc_table(tableau,n)
   implicit none
   type(time_energy), target, intent(inout) :: tableau
   integer n
   allocate(tableau%an(n),tableau%bn(n),tableau%time,tableau%energy,tableau%b_t)
    tableau%an=0.0_dp
    tableau%bn=0.0_dp
    tableau%time=0.0_dp
    tableau%energy=0.0_dp
    tableau%b_t=0.0_dp
   end SUBROUTINE alloc_table 
 
   SUBROUTINE kill_table(tableau)
   implicit none
   type(time_energy), target, intent(inout)  :: tableau
   deallocate(tableau%an,tableau%bn,tableau%time,tableau%energy,tableau%b_t)

   end SUBROUTINE kill_table
 
   SUBROUTINE kill_ramping(acc)
   implicit none
   type(ramping), target , intent(inout) :: acc
   integer i
   
   do i=0,acc%n
    call kill_table(acc%table(i))
   enddo
   
   deallocate(acc%table)
   deallocate(acc%n)
   deallocate(acc%r)
   deallocate(acc%t_max)
!   deallocate(acc%unit_time)
   deallocate(acc%file)
   
   end SUBROUTINE kill_ramping
!!!!!!!!!!!!!!!!! cav4 acceleration !!!!!!!!!!!!!!!!!!! 
!  TYPE time_energy
!     real(dp),pointer :: time
!     real(dp),pointer :: energy
!     real(dp),pointer :: an(:),bn(:)
!  END TYPE time_energy
  
!  TYPE ramping
!     integer,pointer :: n 
!     real(dp), pointer :: r, unit_time 
!     type(time_energy),pointer :: table(:)
!     character(255), pointer :: file
!  END TYPE ramping

!!!!!!!!!!!!!!!!! cav4 acceleration !!!!!!!!!!!!!!!!!!! 

   SUBROUTINE nullify_ramping(acc)
   implicit none
   type(ramping), target , intent(inout) :: acc
   
   nullify(acc%r)
   nullify(acc%n)
   nullify(acc%file)
   nullify(acc%table)
!   nullify(acc%unit_time)
   
   
   end SUBROUTINE nullify_ramping

   SUBROUTINE copy_table(tableau1,tableau2)
   implicit none
   type(time_energy), target, intent(in) :: tableau1
   type(time_energy), target,  intent(inout)  :: tableau2

    if(associated(tableau2%an)) call kill_table(tableau2)
    call alloc_table(tableau2,size(tableau1%an))
    
    tableau2%an=tableau1%an
    tableau2%bn=tableau1%bn
    tableau2%time=tableau1%time
    tableau2%energy=tableau1%energy
    tableau2%b_t=tableau1%b_t
   end SUBROUTINE copy_table
 
   SUBROUTINE copy_ramping(acc1,acc2)
   implicit none
   type(ramping), target, intent(in) :: acc1
   type(ramping), target,  intent(inout)  :: acc2
   integer i
   
   if(associated(acc2%n)) call kill_ramping(acc2)
   call alloc_ramping(acc2,acc1%t_max,acc1%n,size(acc1%table(1)%an),acc1%file)
!   call alloc_ramping(acc2,acc1%unit_time,acc1%t_max,acc1%n,size(acc1%table(1)%an),acc1%file)
   
   do i=0,acc2%n
!    acc2%tableau(i)=acc1%tableau(i)
    call copy_table(acc1%table(i),acc2%table(i))
   enddo
   

   end SUBROUTINE copy_ramping
 

   SUBROUTINE reading_file(EL,fichier)
   implicit none
   type(element), target, intent(inout) :: EL
   type(elementp), pointer :: elp
   type(ramping), pointer :: acc
   character(*) fichier
   integer mf,i,n_mode,n_max,j,n,cavpath,pos,np
   integer, allocatable :: js(:)
   real(dp) ut
   character(255) line
   character(7) car
   logical timepatch
   timepatch=.false.


   np=1
   
   call kanalnummer(mf,fichier)
   read(mf,'(a255)') line
    if(index(line,"#")/=0) then
     read(line,*) n,ut,n_mode,car,np
    else
     read(line,*) n,ut,n_mode
    endif
    if(index(line,"T")/=0.or.index(line,"t")/=0) timepatch=.true.
!   read(mf,*) n,unit_time,n_mode
  ! write(6,*) n,r,cavpath,n_mode
   allocate(js(n_mode))
   
   allocate(el%ramp)
   
   acc=> el%ramp
   read(mf,*) js

   n_max=0
   do i=1,n_mode
    if(js(i)>n_max) n_max=js(i)
   enddo
   
   if(n_max<el%p%nmul) n_max = el%p%nmul
   
!   call alloc_ramping(acc,unit_time,0.0_dp,n,n_max,fichier)
   call alloc_ramping(acc,0.0_dp,n,n_max,fichier)
   acc%r=1.0_dp
   do i=1,acc%n
    if(timepatch) then
     read(mf,*) acc%table(i)%time,   &
     (acc%table(i)%bn(js(j)),acc%table(i)%an(js(j)),j=1,n_mode ),acc%table(i)%b_t
    else
     read(mf,*) acc%table(i)%time,   &
     (acc%table(i)%bn(js(j)),acc%table(i)%an(js(j)),j=1,n_mode )
        acc%table(i)%b_t=0.0_dp
    endif
    acc%table(i)%energy=0.d0
    acc%table(i)%time=acc%table(i)%time*ut
   enddo
   
   close(mf)
    acc%t_max= acc%table(1)%time+np*(acc%table(acc%n)%time-acc%table(1)%time)

   deallocate(js)
   elp=>el%parent_fibre%magp
   if(.not.associated(elp%ramp)) then
    allocate(elp%ramp)
      call nullify_ramping(elp%ramp)
   endif
      call copy_ramping(acc,elp%ramp)


   END SUBROUTINE reading_file 

!!!!!! !!!!!! end ramping !!!!!! !!!!!!

  SUBROUTINE ZEROR_KICKT3(EL,I)
    IMPLICIT NONE
    TYPE(KICKT3), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%thin_h_foc)) then
          deallocate(EL%hf)
          deallocate(EL%vf)
          deallocate(EL%thin_h_foc)
          deallocate(EL%thin_v_foc)
          deallocate(EL%thin_h_angle)
          deallocate(EL%thin_v_angle)
          deallocate(EL%ls)
          deallocate(EL%patch)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%hf)
       NULLIFY(EL%vf)
       NULLIFY(EL%thin_h_foc)
       NULLIFY(EL%thin_v_foc)
       NULLIFY(EL%thin_h_angle)
       NULLIFY(EL%ls)
       NULLIFY(EL%thin_v_angle)
       NULLIFY(EL%patch)
    endif

  END SUBROUTINE ZEROR_KICKT3

  SUBROUTINE ZEROP_KICKT3(EL,I)
    IMPLICIT NONE
    TYPE(KICKT3P), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%thin_h_foc)) then
          CALL KILL(EL%hf)
          CALL KILL(EL%vf)
          CALL KILL(EL%thin_h_foc)
          CALL KILL(EL%thin_v_foc)
          CALL KILL(EL%thin_h_angle)
          CALL KILL(EL%thin_v_angle)

          deallocate(EL%hf)
          deallocate(EL%vf)
          deallocate(EL%thin_h_foc)
          deallocate(EL%thin_v_foc)
          deallocate(EL%thin_h_angle)
          deallocate(EL%thin_v_angle)
          deallocate(EL%patch)
          deallocate(EL%ls)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%hf)
       NULLIFY(EL%vf)
       NULLIFY(EL%thin_h_foc)
       NULLIFY(EL%thin_v_foc)
       NULLIFY(EL%thin_h_angle)
       NULLIFY(EL%thin_v_angle)
       NULLIFY(EL%patch)
       NULLIFY(EL%ls)
    endif

  END SUBROUTINE ZEROP_KICKT3


  SUBROUTINE ZEROr_STREX(EL,I)
    IMPLICIT NONE
    TYPE(STREX), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%DRIFTKICK)) then
          deallocate(EL%DRIFTKICK)
       endif
       if(ASSOCIATED(EL%LIKEMAD)) then
          deallocate(EL%LIKEMAD)
       endif
       if(ASSOCIATED(EL%F)) deallocate(EL%F)
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%F)
       NULLIFY(EL%DRIFTKICK)
       NULLIFY(EL%LIKEMAD)
    endif

  END SUBROUTINE ZEROr_STREX

  SUBROUTINE ZEROP_STREX(EL,I)
    IMPLICIT NONE
    TYPE(STREXP), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%DRIFTKICK)) then
          deallocate(EL%DRIFTKICK)
       endif
       if(ASSOCIATED(EL%LIKEMAD)) then
          deallocate(EL%LIKEMAD)
       endif
       if(ASSOCIATED(EL%F)) deallocate(EL%F)
       NULLIFY(EL%LIKEMAD)
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%F)
       NULLIFY(EL%DRIFTKICK)
    endif

  END SUBROUTINE ZEROP_STREX


  SUBROUTINE ALLOCTEAPOT(EL)
    IMPLICIT NONE
    TYPE(TEAPOTP), INTENT(INOUT)::EL
   ! CALL ALLOC(EL%bf_x,S_B0%N_MONO)
   ! CALL ALLOC(EL%bf_Y,S_B0%N_MONO)
        CALL ALLOC(EL%bf_x,S_B(EL%P%NMUL)%N_MONO)
        CALL ALLOC(EL%bf_Y,S_B(EL%P%NMUL)%N_MONO)
    ! 2010 January 6
  END SUBROUTINE ALLOCTEAPOT

  SUBROUTINE KILLTEAPOT(EL)
    IMPLICIT NONE
    TYPE(TEAPOTP), INTENT(INOUT)::EL

    CALL KILL(EL%bf_x,S_B(SECTOR_NMUL)%N_MONO)
    CALL KILL(EL%bf_Y,S_B(SECTOR_NMUL)%N_MONO)
!    CALL KILL(EL%bf_x,S_B0%N_MONO)
!    CALL KILL(EL%bf_Y,S_B0%N_MONO)
    ! 2010 January 6

  END SUBROUTINE KILLTEAPOT

!!!!!!!!!!!!!! Pancake starts here !!!!!!!!!!!!!!!

  subroutine fxr(f,x,k,b,p)
    implicit none

    real(dp)  d(3),c(6),BETA0,GAMMA0I,hcurv
    real(dp) ,intent(in) :: b(3)
    type(MAGNET_CHART), pointer:: p
    real(dp) ,intent(inout) :: x(6)
    real(dp), intent(out):: f(6)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    if(k%time) then
       beta0=p%beta0;GAMMA0I=p%GAMMA0I;
    else
       beta0=1.0_dp;GAMMA0I=0.0_dp;
    endif

    hcurv=p%b0

    d(1)=root(x(2)**2+x(4)**2+(1.0_dp+hcurv*x(1))**2)
    d(2)=(d(1)**3)/root(1.0_dp+2*x(5)/beta0+x(5)**2)
    d(3)=1.0_dp+hcurv*x(1)

    c(1)=d(1)**2-x(2)**2
    c(2)=-x(2)*x(4)
    c(3)= x(2)*x(4)
    c(4)=-d(1)**2+x(4)**2
    c(5)=d(2)*(x(4)*b(3)-d(3)*b(2)) +hcurv*d(3)*(d(1)**2+x(2)**2)
    c(6)=d(2)*(x(2)*b(3)-d(3)*b(1)) -hcurv*d(3)*c(3)

    d(3)=c(1)*c(4)-c(2)*c(3)
    f(1)=x(2)
    f(2)=(c(4)*c(5)-c(2)*c(6))/d(3)
    f(3)=x(4)
    f(4)=(c(1)*c(6)-c(3)*c(5))/d(3)
    d(2)=1.0_dp+2.0_dp*x(5)/beta0+x(5)**2
    d(2)=gamma0I/beta0/d(2)
    f(6)=root((1+d(2)**2))*d(1)  ! (time)-prime = dt/dz

    !    if(p%radiation) then
    !       c(1)=x(2)/d(1)
    !       c(2)=x(4)/d(1)
    !       c(3)=one/d(1)
    !       B2=zero
    !       B2=(B(2)*c(3)-B(3)*c(2))**2+B2
    !       B2=(B(1)*c(2)-B(2)*c(1))**2+B2
    !       B2=(B(3)*c(1)-B(1)*c(3))**2+B2
    !       f(5)=-CRADF(P)*(one+X(5))**2*B2*f(6)
    !    else
    f(5)=0.0_dp
    !    endif


  end subroutine fxr

  subroutine fxp(f,x,k,b,p)
    implicit none

    type(real_8)  d(3),c(6)
    type(real_8) ,intent(inout) :: x(6)
    type(real_8) ,intent(in) :: b(3)
    real(dp)   BETA0,GAMMA0I,hcurv
    type(real_8), intent(out):: f(6)
    type(MAGNET_CHART), pointer:: p
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call alloc(d,3)
    call alloc(c,6)
    hcurv=p%b0
    if(k%time) then
       beta0=p%beta0;GAMMA0I=p%GAMMA0I;
    else
       beta0=1.0_dp;GAMMA0I=0.0_dp;
    endif

    d(1)=SQRT(x(2)**2+x(4)**2+(1.0_dp+hcurv*x(1))**2)
    d(2)=(d(1)**3)/SQRT(1.0_dp+2*x(5)/beta0+x(5)**2)
    d(3)=1.0_dp+hcurv*x(1)

    c(1)=d(1)**2-x(2)**2
    c(2)=-x(2)*x(4)
    c(3)= x(2)*x(4)
    c(4)=-d(1)**2+x(4)**2
    c(5)=d(2)*(x(4)*b(3)-d(3)*b(2)) +hcurv*d(3)*(d(1)**2+x(2)**2)
    c(6)=d(2)*(x(2)*b(3)-d(3)*b(1)) -hcurv*d(3)*c(3)

    d(3)=c(1)*c(4)-c(2)*c(3)
    f(1)=x(2)
    f(2)=(c(4)*c(5)-c(2)*c(6))/d(3)
    f(3)=x(4)
    f(4)=(c(1)*c(6)-c(3)*c(5))/d(3)
    f(5)=0.0_dp
    d(2)=1.0_dp+2.0_dp*x(5)/beta0+x(5)**2
    !   d(2)=SQRT((one+d(2)*gambet)/d(2)/gambet)
    !   f(6)=d(2)*d(1)

    d(2)=gamma0I/beta0/d(2)
    f(6)=SQRT((1+d(2)**2))*d(1)  ! (time)-prime = dt/dz

    f(5)=0.0_dp

    call kill(d,3)
    call kill(c,6)
  end subroutine fxp

  ! TYPE PANCAKE


  SUBROUTINE ZEROr_PANCAKE(EL,I)
    IMPLICIT NONE
    TYPE(PANCAKE), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%B)) then
          CALL KILL(EL%B)    ! forgotten???
          deallocate(EL%B)
          !          deallocate(EL%Ax)
          !          deallocate(EL%Ay)

          deallocate(EL%SCALE)
          !          deallocate(EL%D_IN)
          !          deallocate(EL%D_OUT)
          !          deallocate(EL%ANG_IN)
          !          deallocate(EL%ANG_OUT)
       endif

    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%B)
       NULLIFY(EL%SCALE)
       !       NULLIFY(EL%Ax)
       !       NULLIFY(EL%Ay)
       !       NULLIFY(EL%D_IN)
       !       NULLIFY(EL%D_OUT)
       !       NULLIFY(EL%ANG_IN)
       !       NULLIFY(EL%ANG_OUT)
    endif

  END SUBROUTINE ZEROr_PANCAKE

  SUBROUTINE ZEROP_PANCAKE(EL,I)
    IMPLICIT NONE
    TYPE(PANCAKEP), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%B)) then
          CALL KILL(EL%SCALE)
          CALL KILL(EL%B)
          !          CALL KILL(EL%Ax)
          !          CALL KILL(EL%Ay)

          !          deallocate(EL%Ax)
          !          deallocate(EL%Ay)
          deallocate(EL%B)
          deallocate(EL%SCALE)
          !          deallocate(EL%D_IN)
          !          deallocate(EL%D_OUT)
          !          deallocate(EL%ANG_IN)
          !          deallocate(EL%ANG_OUT)
       endif

    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%B)
       !       NULLIFY(EL%Ax)
       !       NULLIFY(EL%Ay)
       NULLIFY(EL%SCALE)
       !       NULLIFY(EL%D_IN)
       !       NULLIFY(EL%D_OUT)
       !       NULLIFY(EL%ANG_IN)
       !       NULLIFY(EL%ANG_OUT)
    endif

  END SUBROUTINE ZEROP_PANCAKE

  SUBROUTINE POINTERS_PANCAKER(EL,T) !,t_ax,t_ay)
    IMPLICIT NONE
    TYPE(PANCAKE), INTENT(INOUT)::EL
    TYPE(TREE_ELEMENT), INTENT(IN)::T(:) !,T_ax(:) ,T_ay(:)  ! DATA PASSED HERE SPECIAL
    INTEGER I

    ALLOCATE(EL%B(2*el%p%NST+1))
    !    ALLOCATE(EL%Ax(el%p%NST))
    !    ALLOCATE(EL%Ay(el%p%NST))
    ALLOCATE(  EL%SCALE )
    !    ALLOCATE(  EL%D_IN(3) )
    !    ALLOCATE(  EL%D_OUT(3) )
    !    ALLOCATE(  EL%ANG_IN(3) )
    !    ALLOCATE(  EL%ANG_OUT(3) )

    DO I=1,2*el%p%NST+1
       CALL ALLOC_TREE(EL%B(I),T(I)%N,3)
       !       CALL ALLOC_TREE(EL%Ax(I),T_ax(I)%N,2)
       !       CALL ALLOC_TREE(EL%Ay(I),T_ay(I)%N,2)
       EL%B(I)%CC=T(I)%CC
       EL%B(I)%JL=T(I)%JL
       EL%B(I)%JV=T(I)%JV
       EL%B(I)%N=T(I)%N
       EL%B(I)%ND2=T(I)%ND2
       EL%B(I)%no=T(I)%no
       !       EL%ax(I)%CC=t_ax(I)%CC
       !       EL%ax(I)%JL=t_ax(I)%JL
       !       EL%ax(I)%JV=t_ax(I)%JV
       !       EL%ax(I)%N=t_ax(I)%N
       !       EL%ax(I)%ND2=t_ax(I)%ND2
       !
       !       EL%ay(I)%CC=t_ay(I)%CC
       !       EL%ay(I)%JL=t_ay(I)%JL
       !       EL%ay(I)%JV=t_ay(I)%JV
       !       EL%ay(I)%N=t_ay(I)%N
       !       EL%ay(I)%ND2=t_ay(I)%ND2
    ENDDO



    EL%SCALE=1.0_dp
    !    EL%D_IN=ZERO
    !    EL%D_OUT=ZERO
    !    EL%ANG_IN=ZERO
    !    EL%ANG_OUT=ZERO

  END SUBROUTINE POINTERS_PANCAKER

  SUBROUTINE POINTERS_PANCAKEP(EL,T) !,t_ax,t_ay)
    IMPLICIT NONE
    TYPE(PANCAKEP), INTENT(INOUT)::EL
    TYPE(TREE_ELEMENT), INTENT(IN)::T(:) !,t_ax(:),t_ay(:) ! DATA PASSED HERE SPECIAL
    INTEGER I



    ALLOCATE(EL%B(2*el%p%NST+1))
    !    ALLOCATE(EL%Ax(el%p%NST))
    !    ALLOCATE(EL%Ay(el%p%NST))
    ALLOCATE(  EL%SCALE )
    !    ALLOCATE(  EL%D_IN(3) )
    !    ALLOCATE(  EL%D_OUT(3) )
    !    ALLOCATE(  EL%ANG_IN(3) )
    !    ALLOCATE(  EL%ANG_OUT(3) )

    DO I=1,2*el%p%NST+1
       CALL ALLOC_TREE(EL%B(I),T(I)%N,3)
       !       CALL ALLOC_TREE(EL%Ax(I),T_ax(I)%N,2)
       !       CALL ALLOC_TREE(EL%Ay(I),T_ay(I)%N,2)
       EL%B(I)%CC=T(I)%CC
       EL%B(I)%JL=T(I)%JL
       EL%B(I)%JV=T(I)%JV
       EL%B(I)%N=T(I)%N
       EL%B(I)%ND2=T(I)%ND2
       EL%B(I)%no=T(I)%no
       !       EL%ax(I)%CC=t_ax(I)%CC
       !       EL%ax(I)%JL=t_ax(I)%JL
       !       EL%ax(I)%JV=t_ax(I)%JV
       !       EL%ax(I)%N=t_ax(I)%N
       !       EL%ax(I)%ND2=t_ax(I)%ND2
       !
       !       EL%ay(I)%CC=t_ay(I)%CC
       !       EL%ay(I)%JL=t_ay(I)%JL
       !       EL%ay(I)%JV=t_ay(I)%JV
       !       EL%ay(I)%N=t_ay(I)%N
       !       EL%ay(I)%ND2=t_ay(I)%ND2
    ENDDO



    !    EL%D_IN=ZERO
    !    EL%D_OUT=ZERO
    !    EL%ANG_IN=ZERO
    !    EL%ANG_OUT=ZERO
    ! EL%SCALE MUST BE CREATED IN SETFAMILYP
  END SUBROUTINE POINTERS_PANCAKEP

  SUBROUTINE copyPANCAKE_el_elp(EL,ELP)
    IMPLICIT NONE
    TYPE(PANCAKE), INTENT(in)::EL
    TYPE(PANCAKEP), INTENT(inout)::ELP

    CALL COPY_TREE_N(EL%B,ELP%B)
    !    CALL COPY_TREE_N(EL%ax,ELP%ax)
    !    CALL COPY_TREE_N(EL%ay,ELP%ay)
    !
    !!    ELP%D_IN    =  EL%D_IN
    !    ELP%D_OUT    =  EL%D_OUT
    !    ELP%ANG_IN    =  EL%ANG_IN
    !    ELP%ANG_OUT    =  EL%ANG_OUT
    ELP%SCALE  = EL%SCALE
  END SUBROUTINE copyPANCAKE_el_elp

  SUBROUTINE copyPANCAKE_el_el(EL,ELP)
    IMPLICIT NONE
    TYPE(PANCAKE), INTENT(in)::EL
    TYPE(PANCAKE), INTENT(inout)::ELP

    CALL COPY_TREE_N(EL%B,ELP%B)
    !    CALL COPY_TREE_N(EL%ax,ELP%ax)
    !    CALL COPY_TREE_N(EL%ay,ELP%ay)
    !
    !!    ELP%D_IN    =  EL%D_IN
    !    ELP%D_OUT    =  EL%D_OUT
    !    ELP%ANG_IN    =  EL%ANG_IN
    !    ELP%ANG_OUT    =  EL%ANG_OUT
    ELP%SCALE  = EL%SCALE
  END SUBROUTINE copyPANCAKE_el_el

  SUBROUTINE copyPANCAKE_elP_el(EL,ELP)
    IMPLICIT NONE
    TYPE(PANCAKEP), INTENT(in)::EL
    TYPE(PANCAKE), INTENT(inout)::ELP

    CALL COPY_TREE_N(EL%B,ELP%B)
    !    CALL COPY_TREE_N(EL%ax,ELP%ax)
    !    CALL COPY_TREE_N(EL%ay,ELP%ay)
    !
    !!    ELP%D_IN    =  EL%D_IN
    !    ELP%D_OUT    =  EL%D_OUT
    !    ELP%ANG_IN    =  EL%ANG_IN
    !    ELP%ANG_OUT    =  EL%ANG_OUT
    ELP%SCALE  = EL%SCALE
  END SUBROUTINE copyPANCAKE_elP_el

  SUBROUTINE reset_pa(EL)
    IMPLICIT NONE
    TYPE(PANCAKEP), INTENT(INOUT)::EL
    ! CALL resetpoly_R31 ON ALL THE INTERNAL POLYMORPHS

    call resetpoly_R31(EL%SCALE)

  END SUBROUTINE reset_pa

  subroutine feval_PANCAkEr(POS,X,k,f,EL)
    IMPLICIT NONE
    real(dp), INTENT(INout) :: X(6)
    INTEGER, INTENT(INOUT) :: POS
    real(dp), INTENT(OUT) :: F(6)
    TYPE(PANCAKE),  INTENT(INOUT) :: EL
    real(dp) B(3)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    B(1)=X(1);
    B(2)=X(3);
    B(3)=0.0_dp;

    !       CALL track3(EL%B(POS),B)
    CALL trackg(EL%B(POS),B)

    b(1)=EL%SCALE*el%p%charge*el%p%dir*b(1)
    b(2)=EL%SCALE*el%p%charge*el%p%dir*b(2)
    !    b(3)=EL%SCALE*el%p%charge*el%p%dir*b(3)
    b(3)=EL%SCALE*el%p%charge*b(3)

    CALL f_M(f,x,k,b,EL%p)

  END subroutine feval_PANCAkEr

  subroutine feval_PANCAkEP(POS,X,k,f,EL)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INout) :: X(6)
    INTEGER, INTENT(INOUT) :: POS
    TYPE(REAL_8), INTENT(OUT) :: F(6)
    TYPE(PANCAKEP),  INTENT(INOUT) :: EL
    TYPE(REAL_8) B(3)
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    CALL ALLOC(B)
    B(1)=X(1);
    B(2)=X(3);
    B(3)=0.0_dp;

    !       CALL track3(EL%B(POS),B)
    CALL trackg(EL%B(POS),B)

    b(1)=EL%SCALE*el%p%charge*el%p%dir*b(1)
    b(2)=EL%SCALE*el%p%charge*el%p%dir*b(2)
    !    b(3)=EL%SCALE*el%p%charge*el%p%dir*b(3)
    b(3)=EL%SCALE*el%p%charge*b(3)

    CALL f_M(f,x,k,b,EL%p)

    CALL KILL(B)

  END subroutine feval_PANCAkEP

  ! 4 order Runge
  subroutine rk4_pancaker(ti,h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    real(dp), INTENT(INOUT)::  y(ne)
    real(dp)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne)
    type (pancake) ,INTENT(INOUT)::  GR
    integer j
    real(dp), intent(inout) :: h
    integer, intent(inout) :: ti
    INTEGER TT
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    call feval(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    tt=tI+GR%p%dir
    call feval(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + b(j)/2.0_dp
    enddo


    tt=tI+GR%p%dir
    call feval(tt,yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+c(j)
    enddo

    tt=tI+2*GR%p%dir
    call feval(tt,yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+(a(j)+2.0_dp*b(j)+2.0_dp*c(j)+d(j))/6.0_dp
    enddo
    tI=ti+2*GR%p%dir

    if(k%TIME) then
       Y(6)=Y(6)-(1-k%TOTALPATH)*GR%P%LD/GR%P%beta0/GR%P%nst
    else
       Y(6)=Y(6)-(1-k%TOTALPATH)*GR%P%LD/GR%P%nst
    endif

    return
  end  subroutine rk4_pancaker

  subroutine rk4_pancakeP(ti,h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    TYPE(REAL_8), INTENT(INOUT)::  y(ne)
    TYPE(REAL_8)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne)
    type (pancakeP) ,INTENT(INOUT)::  GR
    integer j
    TYPE(REAL_8), intent(inout) :: h
    integer, intent(inout) :: ti
    INTEGER TT
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    call alloc(yt,ne)
    call alloc(f,ne)
    call alloc(a,ne)
    call alloc(b,ne)
    call alloc(c,ne)
    call alloc(d,ne)


    call feval(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    tt=tI+GR%p%dir
    call feval(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + b(j)/2.0_dp
    enddo


    tt=tI+GR%p%dir
    call feval(tt,yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+c(j)
    enddo

    tt=tI+2*GR%p%dir
    call feval(tt,yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo


    do  j=1,ne
       y(j) = y(j)+(a(j)+2.0_dp*b(j)+2.0_dp*c(j)+d(j))/6.0_dp
    enddo
    tI=ti+2*GR%p%dir

    if(k%TIME) then
       Y(6)=Y(6)-(1-k%TOTALPATH)*GR%P%LD/GR%P%beta0/GR%P%nst
    else
       Y(6)=Y(6)-(1-k%TOTALPATH)*GR%P%LD/GR%P%nst
    endif

    call KILL(yt,ne)
    call KILL(f,ne)
    call KILL(a,ne)
    call KILL(b,ne)
    call KILL(c,ne)
    call KILL(d,ne)

    return
  end  subroutine rk4_pancakeP

  SUBROUTINE conv_to_xpr(EL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(PANCAKE),INTENT(INOUT):: EL
    real(dp) ti
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    if(k%TIME) then
       ti=ROOT(1.0_dp+2.0_dp*X(5)/el%p%beta0+x(5)**2-X(2)**2-X(4)**2)
       x(2)=(1.0_dp+el%p%B0*X(1))*x(2)/ti
       x(4)=(1.0_dp+el%p%B0*X(1))*x(4)/ti
    else
       ti=ROOT((1.0_dp+x(5))**2-X(2)**2-X(4)**2)
       x(2)=(1.0_dp+el%p%B0*X(1))*x(2)/ti
       x(4)=(1.0_dp+el%p%B0*X(1))*x(4)/ti
    endif

  end SUBROUTINE conv_to_xpr

  SUBROUTINE conv_to_xpp(EL,X,k)
    IMPLICIT NONE
    type(real_8),INTENT(INOUT):: X(6)
    TYPE(PANCAKEp),INTENT(INOUT):: EL
    type(real_8) ti
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    call alloc(ti)
    if(k%TIME) then
       ti=sqrt(1.0_dp+2.0_dp*X(5)/el%p%beta0+x(5)**2-X(2)**2-X(4)**2)
       x(2)=(1.0_dp+el%p%B0*X(1))*x(2)/ti
       x(4)=(1.0_dp+el%p%B0*X(1))*x(4)/ti
    else
       ti=sqrt((1.0_dp+x(5))**2-X(2)**2-X(4)**2)
       x(2)=(1.0_dp+el%p%B0*X(1))*x(2)/ti
       x(4)=(1.0_dp+el%p%B0*X(1))*x(4)/ti
    endif
    call kill(ti)

  end SUBROUTINE conv_to_xpp

  SUBROUTINE conv_to_pxr(EL,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(PANCAKE),INTENT(INOUT):: EL
    real(dp) ti
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    ti=ROOT((1.0_dp+el%p%B0*X(1))**2+X(2)**2+X(4)**2)
    if(k%TIME) then
       x(2)=x(2)*ROOT(1.0_dp+2.0_dp*X(5)/el%p%beta0+x(5)**2)/ti
       x(4)=x(4)*ROOT(1.0_dp+2.0_dp*X(5)/el%p%beta0+x(5)**2)/ti
    else
       x(2)=x(2)*(1.0_dp+x(5))/ti
       x(4)=x(4)*(1.0_dp+x(5))/ti
    endif
  end SUBROUTINE conv_to_pxr

  SUBROUTINE conv_to_pxp(EL,X,k)
    IMPLICIT NONE
    type(real_8),INTENT(INOUT):: X(6)
    TYPE(PANCAKEp),INTENT(INOUT):: EL
    type(real_8) ti
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K
    call alloc(ti)
    ti=SQRT((1.0_dp+el%p%B0*X(1))**2+X(2)**2+X(4)**2)
    if(k%TIME) then
       x(2)=x(2)*sqrt(1.0_dp+2.0_dp*X(5)/el%p%beta0+x(5)**2)/ti
       x(4)=x(4)*sqrt(1.0_dp+2.0_dp*X(5)/el%p%beta0+x(5)**2)/ti
    else
       x(2)=x(2)*(1.0_dp+x(5))/ti
       x(4)=x(4)*(1.0_dp+x(5))/ti
    endif
    call kill(ti)

  end SUBROUTINE conv_to_pxp


  ! ETIENNE_PANCAKE

  SUBROUTINE ADJUSTR_PANCAKE(EL,X,k,J)
    IMPLICIT NONE
    real(dp), INTENT(INOUT) :: X(6)
    TYPE(PANCAKE),INTENT(INOUT):: EL

    INTEGER, INTENT(IN) :: J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(J==1) then
       call conv_to_xp(el,x,k)
    else
       call conv_to_px(el,x,k)
    endif

  END SUBROUTINE ADJUSTR_PANCAKE

  SUBROUTINE ADJUSTP_PANCAKE(EL,X,k,J)
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INOUT) :: X(6)
    TYPE(PANCAKEP),INTENT(INOUT):: EL

    INTEGER, INTENT(IN) :: J
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    IF(J==1) then
       call conv_to_xp(el,x,k)
    else
       call conv_to_px(el,x,k)
    endif

  END SUBROUTINE ADJUSTP_PANCAKE

  SUBROUTINE INTER_PANCAKE(EL,X,k,POS)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(PANCAKE),INTENT(INOUT):: EL
    integer, intent(in) :: POS
    INTEGER IS
    real(dp) h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    H=el%L/el%p%NST

    SELECT CASE(EL%P%METHOD)
    CASE(4)
       IF(EL%P%DIR==1) THEN
          IS=-1+2*POS    ! POS=3 BEGINNING
          call rk4_m(IS,h,el,X,k)
       else
          IS=2*el%p%NST+3-2*pos
          call rk4_m(IS,h,el,X,k)
       ENDIF

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT


  END SUBROUTINE INTER_PANCAKE

  SUBROUTINE INTEP_PANCAKE(EL,X,k,POS)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(PANCAKEP),INTENT(INOUT):: EL
    integer, intent(in) :: POS
    INTEGER IS
    TYPE(REAL_8) ti,h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(TI,H)

    H=el%L/el%p%NST

    SELECT CASE(EL%P%METHOD)
    CASE(4)
       IF(EL%P%DIR==1) THEN
          IS=-1+2*POS    ! POS=3 BEGINNING

          call rk4_m(IS,h,el,X,k)
       else
          IS=2*el%p%NST+3-2*pos
          call rk4_m(IS,h,el,X,k)
       ENDIF

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT

    CALL KILL(TI,H)

  END SUBROUTINE INTEP_PANCAKE


  SUBROUTINE INTPANCAKER(EL,X,k,MID)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: MID
    TYPE(PANCAKE),INTENT(INOUT):: EL
    INTEGER I,IS
    real(dp) h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    H=el%L/el%p%NST

    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    SELECT CASE(EL%P%METHOD)
    CASE(4)
       call conv_to_xp(EL,X,k)
       IF(EL%P%DIR==1) THEN
          IS=1
          DO I=1,el%p%NST
             IF(.NOT.PRESENT(MID)) call rk4_m(IS,h,el,X,k)
             IF(PRESENT(MID)) CALL XMID(MID,X,I)
          ENDDO
       else
          IS=2*el%p%NST+1
          DO I=1,el%p%NST
             IF(.NOT.PRESENT(MID)) call rk4_m(IS,h,el,X,k)
             IF(PRESENT(MID)) CALL XMID(MID,X,I)
          ENDDO

       ENDIF
       call conv_to_px(EL,X,k)

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT




  END SUBROUTINE INTPANCAKER

  SUBROUTINE INTPANCAKEP(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    ! TYPE(WORM_8),OPTIONAL,INTENT(INOUT):: MID
    TYPE(PANCAKEP),INTENT(INOUT):: EL
    INTEGER I,IS
    TYPE(REAL_8) ti,h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(TI,H)


    H=el%L/el%p%NST




    !    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    SELECT CASE(EL%P%METHOD)
    CASE(4)
       call conv_to_xp(EL,X,k)
       IF(EL%P%DIR==1) THEN
          IS=1
          DO I=1,el%p%NST
             call rk4_m(IS,h,el,X,k)
          ENDDO
       else
          IS=2*el%p%NST+1
          DO I=1,el%p%NST
             call rk4_m(IS,h,el,X,k)
          ENDDO

       ENDIF


       call conv_to_px(EL,X,k)
       !       CASE(2)
       !          IS=1
       !          call DRIFT_pancake(EL,hh,is,1,X,k)
       !          call DRIFT_pancake(EL,hh,is,2,X,k)
       !          call KICKPATH(EL,hf,X,k)
       !          DO I=1,el%p%NST-2
       !             IS=is+1
       !             call DRIFT_pancake(EL,hh,is,2,X,k)
       !             call DRIFT_pancake(EL,hf,is,1,X,k)
       !             call DRIFT_pancake(EL,hh,is,2,X,k)
       !             call KICKPATH(EL,hf,X,k)
       !          ENDDO
       !          IS=is+1
       !          call DRIFT_pancake(EL,hh,is,2,X,k)
       !          call DRIFT_pancake(EL,hf,is,1,X,k)
       !          a(1)=x(1)
       !          a(2)=x(3)
       !          CALL trackg(EL%ax(is),A)
       !          X(2)=X(2)-EL%SCALE*el%p%charge*A(1)
       !          a(1)=x(1)
       !          a(2)=x(3)
       !          CALL trackg(EL%ay(is),A)
       !          X(4)=X(4)-EL%SCALE*el%p%charge*A(1)
       !

    CASE DEFAULT
       w_p=0
       w_p%nc=1
       w_p%fc='(1(1X,A72))'
       WRITE(w_p%c(1),'(a12,1x,i4,1x,a17)') " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ! call !write_e(357)
    END SELECT




    CALL KILL(TI,H)

  END SUBROUTINE INTPANCAKEP

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! cav_trav

  subroutine feval_CAVR(Z0,X,k,f,D) 
    IMPLICIT NONE
    real(dp), INTENT(INout) :: X(6)
    real(dp),INTENT(INOUT):: Z0
    real(dp), INTENT(INOUT) :: F(6)
    REAL(DP) A(3),AD(2),PZ
    TYPE(CAV_TRAV),  INTENT(INOUT) :: D
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    A=0.0_dp;AD=0.0_dp;
    CALL A_TRANS(D,Z0,X,k,A,AD)

    X(2)=X(2)-A(1)
    X(4)=X(4)-A(2)

    IF(D%P%EXACT) THEN
       if(k%TIME) then
          PZ=ROOT(1.0_dp+2.0_dp*X(5)/D%P%BETA0+x(5)**2-X(2)**2-X(4)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp/D%P%BETA0+X(5))/PZ-(1-k%TOTALPATH)/D%P%BETA0
       else
          PZ=ROOT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp+X(5))/PZ-(1-k%TOTALPATH)
       endif
    ELSE
       if(k%TIME) then
          PZ=ROOT(1.0_dp+2.0_dp*X(5)/D%P%BETA0+x(5)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=((X(2)*X(2)+X(4)*X(4))/2.0_dp/pz**2+1.0_dp)*(1.0_dp/D%P%BETA0+x(5))/pz
          F(6)=F(6)-(1-k%TOTALPATH)/D%P%BETA0
       else
          F(1)=X(2)/(1.0_dp+X(5))
          F(3)=X(4)/(1.0_dp+X(5))
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp/(1.0_dp+X(5)))*(X(2)*X(2)+X(4)*X(4))/2.0_dp/(1.0_dp+X(5))+k%TOTALPATH
       endif
    ENDIF

    X(2)=X(2)+A(1)
    X(4)=X(4)+A(2)

  END subroutine feval_CAVR

  subroutine feval_CAVP(Z0,X,k,f,D)   ! MODELLED BASED ON DRIFT
    IMPLICIT NONE
    TYPE(REAL_8), INTENT(INout) :: X(6)
    TYPE(REAL_8), INTENT(INOUT):: Z0
    TYPE(REAL_8), INTENT(INOUT) :: F(6)
    TYPE(REAL_8)  A(3),AD(2),PZ
    TYPE(CAV_TRAVp),  INTENT(INOUT) :: D
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    CALL ALLOC(A)
    CALL ALLOC(AD)
    CALL ALLOC(PZ)


    CALL A_TRANS(D,Z0,X,k,A,AD)

    X(2)=X(2)-A(1)
    X(4)=X(4)-A(2)

    IF(D%P%EXACT) THEN
       if(k%TIME) then
          PZ=sqrt(1.0_dp+2.0_dp*X(5)/D%P%BETA0+x(5)**2-X(2)**2-X(4)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp/D%P%BETA0+X(5))/PZ-(1-k%TOTALPATH)/D%P%BETA0
       else
          PZ=sqrt((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp+X(5))/PZ-(1-k%TOTALPATH)
       endif
    ELSE
       if(k%TIME) then
          PZ=sqrt(1.0_dp+2.0_dp*X(5)/D%P%BETA0+x(5)**2)
          F(1)=X(2)/PZ
          F(3)=X(4)/PZ
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=((X(2)*X(2)+X(4)*X(4))/2.0_dp/pz**2+1.0_dp)*(1.0_dp/D%P%BETA0+x(5))/pz
          F(6)=F(6)-(1-k%TOTALPATH)/D%P%BETA0
       else
          F(1)=X(2)/(1.0_dp+X(5))
          F(3)=X(4)/(1.0_dp+X(5))
          F(2)=F(1)*AD(1)
          F(4)=F(3)*AD(1)
          F(5)=-(F(1)*X(1)+F(3)*X(3))*AD(2)+A(3)
          F(6)=(1.0_dp/(1.0_dp+X(5)))*(X(2)*X(2)+X(4)*X(4))/2.0_dp/(1.0_dp+X(5))+k%TOTALPATH
       endif
    ENDIF

    X(2)=X(2)+A(1)
    X(4)=X(4)+A(2)

    CALL KILL(A)
    CALL KILL(AD)
    CALL KILL(PZ)


  END subroutine feval_CAVP

  SUBROUTINE A_TRANSR(EL,Z0,X,k,A,AD)    ! EXP(-I:(X^2+Y^2)/2*A_TRANS:)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    real(dp),INTENT(INOUT):: Z0,A(3),ad(2)
    TYPE(CAV_TRAV),INTENT(INOUT):: EL
    real(dp) C1,S1,C2,S2,V,O
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    !    IF(k%NOCAVITY.OR.(.NOT.k%FRINGE)) RETURN
    IF(k%NOCAVITY) RETURN

    O=EL%freq*twopi/CLIGHT
    C1=COS(O*(x(6)-Z0)+EL%PHAS+EL%phase0)
    C2=COS(O*(x(6)+Z0)+EL%PHAS+EL%phase0+EL%DPHAS)
    S1=SIN(O*(x(6)-Z0)+EL%PHAS+EL%phase0)
    S2=SIN(O*(x(6)+Z0)+EL%PHAS+EL%phase0+EL%DPHAS)
    V=EL%P%CHARGE*(EL%volt-el%dvds*z0)*1e-3_dp/EL%P%P0C

    AD(1)=0.5_dp*V*(COS(EL%PSI)*S1-SIN(EL%PSI)*S2)
    AD(2)=O*0.5_dp*V*(COS(EL%PSI)*C1-SIN(EL%PSI)*C2)
    A(1)=AD(1)*X(1)
    A(2)=AD(1)*X(3)
    A(3)=-EL%P%DIR*V*(COS(EL%PSI)*S1+SIN(EL%PSI)*S2)


  END SUBROUTINE A_TRANSR


  SUBROUTINE A_TRANSP(EL,Z0,X,k,A,AD)    ! EXP(-I:(X^2+Y^2)/2*A_TRANS:)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8),INTENT(INOUT):: Z0,A(3),ad(2)
    TYPE(CAV_TRAVP),INTENT(INOUT):: EL
    TYPE(REAL_8) C1,S1,C2,S2,V,O
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    !    IF(k%NOCAVITY.OR.(.NOT.k%FRINGE)) RETURN
    IF(k%NOCAVITY) RETURN

    CALL ALLOC(C1,S1,C2,S2,V,O)
    O=EL%freq*twopi/CLIGHT
    C1=COS(O*(x(6)-Z0)+EL%PHAS+EL%phase0)
    C2=COS(O*(x(6)+Z0)+EL%PHAS+EL%phase0+EL%DPHAS)
    S1=SIN(O*(x(6)-Z0)+EL%PHAS+EL%phase0)
    S2=SIN(O*(x(6)+Z0)+EL%PHAS+EL%phase0+EL%DPHAS)
    V=EL%P%CHARGE*(EL%volt-el%dvds*z0)*1e-3_dp/EL%P%P0C

    AD(1)=0.5_dp*V*(COS(EL%PSI)*S1-SIN(EL%PSI)*S2)
    AD(2)=O*0.5_dp*V*(COS(EL%PSI)*C1-SIN(EL%PSI)*C2)
    A(1)=AD(1)*X(1)
    A(2)=AD(1)*X(3)
    A(3)=-EL%P%DIR*V*(COS(EL%PSI)*S1+SIN(EL%PSI)*S2)

    CALL KILL(C1,S1,C2,S2,V,O)

  END SUBROUTINE A_TRANSP

  subroutine rk2_cavr(ti,h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    real(dp), INTENT(INOUT)::  y(ne)
    real(dp)  yt(ne),f(ne),a(ne),b(ne)
    real(dp)  tt
    type (cav_trav) ,INTENT(INOUT)::  GR
    integer j
    real(dp), intent(inout) :: ti,h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    call feval_cav(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    tt=tI+h/2.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+b(j)
    enddo
    tI=ti+h

    return
  end  subroutine rk2_cavr

  ! 2 order Runge
  subroutine rk2_cavp(ti,h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    type (real_8), INTENT(INOUT)::  y(ne)
    type (real_8)  yt(ne),f(ne),a(ne),b(ne)
    type (real_8)  tt
    type (cav_travp) ,INTENT(INOUT)::  GR
    integer j
    type(real_8), intent(inout) :: ti,h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call alloc(yt,ne)
    call alloc(f,ne)
    call alloc(a,ne)
    call alloc(b,ne)

    call alloc(tt)

    call feval_cav(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    tt=tI+h/2.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+b(j)
    enddo
    tI=ti+h

    call kill(tt)
    call kill(yt,ne)
    call kill(f,ne)
    call kill(a,ne)
    call kill(b,ne)

    return
  end  subroutine rk2_cavp

  subroutine rk4_cavr(ti,h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    real(dp), INTENT(INOUT)::  y(ne)
    real(dp)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne)
    type (CAV_TRAV) ,INTENT(INOUT)::  GR
    integer j
    real(dp), intent(inout) :: h
    real(dp), intent(inout) :: ti
    real(dp) TT
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    call feval_cav(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    tt=tI+h/2.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + b(j)/2.0_dp
    enddo


    !      tt=tI+1
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+c(j)
    enddo

    tt=tI+h
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo


    do  j=1,ne
       y(j) = y(j)+(a(j)+2.0_dp*b(j)+2.0_dp*c(j)+d(j))/6.0_dp
    enddo
    tI=tt

    return
  end  subroutine rk4_cavr

  subroutine rk4_cavp(ti,h,GR,y,k)
    IMPLICIT none

    integer ne
    parameter (ne=6)
    type(real_8), INTENT(INOUT)::  y(ne)
    type (CAV_TRAVp) ,INTENT(INOUT)::  GR
    type(real_8), intent(inout) :: h
    type(real_8), intent(inout) :: ti
    type(real_8)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne)
    type(real_8) TT
    integer j
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call alloc(tt)
    call alloc(yt)
    call alloc(f)
    call alloc(a)
    call alloc(b)
    call alloc(c)
    call alloc(d)

    call feval_cav(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/2.0_dp
    enddo

    tt=tI+h/2.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + b(j)/2.0_dp
    enddo


    !      tt=tI+1
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+c(j)
    enddo

    tt=tI+h
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo


    do  j=1,ne
       y(j) = y(j)+(a(j)+2.0_dp*b(j)+2.0_dp*c(j)+d(j))/6.0_dp
    enddo
    tI=tt

    call kill(tt)
    call kill(yt)
    call kill(f)
    call kill(a)
    call kill(b)
    call kill(c)
    call kill(d)

    return
  end  subroutine rk4_cavp

  subroutine rk6_cavr(ti,h,GR,y,k)
    IMPLICIT none
    !  Written by Rob Ryne, Spring 1986, based on a routine of
    !c  J. Milutinovic.
    !c  For a reference, see page 76 of F. Ceschino and J Kuntzmann,
    !c  Numerical Solution of Initial Value Problems, Prentice Hall 1966.
    !c  This integration routine makes local truncation errors at each
    !c  step of order h**7.
    !c  That is, it is locally correct through terms of order h**6.
    !c  Each step requires 8 function evaluations.

    integer ne
    parameter (ne=6)
    real(dp), INTENT(INOUT)::  y(ne)
    real(dp)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne),e(ne),g(ne),o(ne),p(ne)
    real(dp)  tt
    type (CAV_TRAV) ,INTENT(INOUT)::  GR
    integer j
    real(dp), intent(inout) :: ti,h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K


    call feval_cav(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/9.0_dp
    enddo
    tt=tI+h/9.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + (a(j) + 3.0_dp*b(j))/24.0_dp
    enddo
    tt=tI+h/6.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j)+(a(j)-3.0_dp*b(j)+4.0_dp*c(j))/6.0_dp
    enddo

    tt=tI+h/3.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (-5.0_dp*a(j) + 27.0_dp*b(j) - 24.0_dp*c(j) + 6.0_dp*d(j))/8.0_dp
    enddo
    tt=tI+0.5_dp*h
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       e(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (221.0_dp*a(j) - 981.0_dp*b(j) + 867.0_dp*c(j)- 102.0_dp*d(j) + e(j))/9.0_dp
    enddo
    tt = tI+2.0_dp*h/3.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do   j=1,ne
       g(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(-183.0_dp*a(j)+678.0_dp*b(j)-472.0_dp*c(j)-66.0_dp*d(j)+80.0_dp*e(j) + 3.0_dp*g(j))/48.0_dp
    enddo
    tt = tI + 5.0_dp*h/6.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       o(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(716.0_dp*a(j)-2079.0_dp*b(j)+1002.0_dp*c(j)+834.0_dp*d(j)-454.0_dp*e(j)-9.0_dp*g(j)+72.0_dp*o(j))/82.0_dp
    enddo

    tt = tI + h
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       p(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+(41.0_dp*a(j)+216.0_dp*c(j)+27.0_dp*d(j)+272.0_dp*e(j)+27.0_dp*g(j)+216.0_dp*o(j)+41.0_dp*p(j))/840.0_dp
    enddo
    tI=ti+h

    return
  end  subroutine rk6_cavr



  ! sixth order Runge
  subroutine rk6_cavp(ti,h,GR,y,k)
    IMPLICIT none


    integer ne
    parameter (ne=6)
    type (real_8), INTENT(INOUT)::  y(ne)
    type (real_8)  yt(ne),f(ne),a(ne),b(ne),c(ne),d(ne),e(ne),g(ne),o(ne),p(ne)
    type (real_8)  tt
    type (cav_travp) ,INTENT(INOUT)::  GR
    integer j
    type(real_8), intent(inout) :: ti,h
    TYPE(INTERNAL_STATE) k !,OPTIONAL :: K

    call alloc(yt,ne)
    call alloc(f,ne)
    call alloc(a,ne)
    call alloc(b,ne)
    call alloc(c,ne)
    call alloc(d,ne)
    call alloc(e,ne)
    call alloc(g,ne)
    call alloc(o,ne)
    call alloc(p,ne)
    call alloc(tt)

    call feval_cav(tI,y,k,f,gr)
    do  j=1,ne
       a(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j)=y(j)+a(j)/9.0_dp
    enddo
    tt=tI+h/9.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       b(j)=h*f(j)
    enddo
    do   j=1,ne
       yt(j)=y(j) + (a(j) + 3.0_dp*b(j))/24.0_dp
    enddo
    tt=tI+h/6.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       c(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j)+(a(j)-3.0_dp*b(j)+4.0_dp*c(j))/6.0_dp
    enddo

    tt=tI+h/3.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       d(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (-5.0_dp*a(j) + 27.0_dp*b(j) - 24.0_dp*c(j) + 6.0_dp*d(j))/8.0_dp
    enddo
    tt=tI+0.5_dp*h
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       e(j)=h*f(j)
    enddo

    do  j=1,ne
       yt(j)=y(j) + (221.0_dp*a(j) - 981.0_dp*b(j) + 867.0_dp*c(j)- 102.0_dp*d(j) + e(j))/9.0_dp
    enddo
    tt = tI+2.0_dp*h/3.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do   j=1,ne
       g(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(-183.0_dp*a(j)+678.0_dp*b(j)-472.0_dp*c(j)-66.0_dp*d(j)+80.0_dp*e(j) + 3.0_dp*g(j))/48.0_dp
    enddo
    tt = tI + 5.0_dp*h/6.0_dp
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       o(j)=h*f(j)
    enddo
    do  j=1,ne
       yt(j) = y(j)+(716.0_dp*a(j)-2079.0_dp*b(j)+1002.0_dp*c(j)+834.0_dp*d(j)-454.0_dp*e(j)-9.0_dp*g(j)+72.0_dp*o(j))/82.0_dp
    enddo

    tt = tI + h
    call feval_cav(tt,yt,k,f,gr)
    do  j=1,ne
       p(j)=h*f(j)
    enddo

    do  j=1,ne
       y(j) = y(j)+(41.0_dp*a(j)+216.0_dp*c(j)+27.0_dp*d(j)+272.0_dp*e(j)+27.0_dp*g(j)+216.0_dp*o(j)+41.0_dp*p(j))/840.0_dp
    enddo
    tI=ti+h
    call kill(tt)
    call kill(yt,ne)
    call kill(f,ne)
    call kill(a,ne)
    call kill(b,ne)
    call kill(c,ne)
    call kill(d,ne)
    call kill(e,ne)
    call kill(g,ne)
    call kill(o,ne)
    call kill(p,ne)

    return
  end  subroutine rk6_cavp

!!!!!!!!!!!!!!!!!  Helical dipole !!!!!!!!!!!!!!!!!!!!!!!!!!!!

  SUBROUTINE ZEROR_HE22(EL,I)
    IMPLICIT NONE
    TYPE(HELICAL_DIPOLE), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%N_BESSEL)) then
          deallocate(EL%N_BESSEL)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%N_BESSEL)
    endif

  END SUBROUTINE ZEROR_HE22

  SUBROUTINE ZEROP_HE22(EL,I)
    IMPLICIT NONE
    TYPE(HELICAL_DIPOLEP), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%N_BESSEL)) then
          deallocate(EL%N_BESSEL)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%N_BESSEL)
    endif

  END SUBROUTINE ZEROP_HE22

  SUBROUTINE computeR_f4(EL,X,Z,DA2,B,A,d,int_ax_dy,int_aY_dX)
    IMPLICIT NONE
    TYPE(HELICAL_DIPOLE), INTENT(INOUT)::EL
    real(dp),  INTENT(IN)::X(6),Z
    real(dp), OPTIONAL, INTENT(INOUT)::DA2(2),B(3),A(2),int_ax_dy,int_aY_dX
    real(dp), OPTIONAL, INTENT(INOUT)::d(3,3)
    REAL(DP) R2,DF,AR,PHIR,PHIZ,PHASE ,DFR,DFR2,co,si,F,DA(3,3)
    REAL(DP) x1,y1,k
    real(dp) int_x2_f_by_x_dy,int_y2_f_by_y_dx,int_f

    x1=x(1)
    y1=x(3)
    R2=x1**2+y1**2
    k=EL%FREQ
    DF=k**2/4.0_DP
    F=1.0_dp+DF*R2/2.0_DP+DF*DF*R2**2/12.0_DP
    DFR=DF+DF*DF*R2/3.0_DP
    DFR2=DF+DF*DF*R2


    PHASE=k*Z+EL%PHAS
    CO=COS(PHASE)
    SI=SIN(PHASE)
    PHIR=EL%BN(1)*X(1)*SI +EL%AN(1)*X(3)*CO
    AR=-k*F*PHIR
    IF(PRESENT(A)) THEN
       A(1)=X(1)*AR
       A(2)=X(3)*AR
    ENDIF

    IF(PRESENT(B).or.present(d)) THEN
       da=0.0_dp
       DA(1,1)=-k*F*(EL%BN(1)*X(1)*SI +PHIR) &
            -X(1)**2*k*PHIR*DFR
       DA(1,2)=-k*F*(EL%AN(1)*X(1)*CO ) &
            -X(1)*X(3)*k*PHIR*DFR        !!!
       DA(2,1)=-k*F*(EL%BN(1)*X(3)*SI ) &    !!!! x(3)
            -X(1)*X(3)*k*PHIR*DFR
       DA(2,2)=-k*F*(EL%AN(1)*X(3)*CO +PHIR) &
            -X(3)**2*k*PHIR*DFR
       PHIZ=-EL%BN(1)*X(1)*CO +EL%AN(1)*X(3)*SI

       DA(1,3)=k**2*PHIZ*F*X(1)
       DA(2,3)=k**2*PHIZ*F*X(3)

       DA(3,1)=(F+R2*DFR)*(-EL%BN(1)*CO)+PHIZ*(2.0_dp*DFR+DFR2)*X(1)
       DA(3,2)=(F+R2*DFR)*(EL%AN(1)*SI)+ PHIZ*(2.0_dp*DFR+DFR2)*X(3)
       if(present(d)) d=da
    ENDIF
    IF(PRESENT(DA2)) THEN  !!
       PHIZ=-EL%BN(1)*X(1)*CO +EL%AN(1)*X(3)*SI

       DA2(1)=(F+R2*DFR)*(-EL%BN(1)*CO)+PHIZ*(2.0_dp*DFR+DFR2)*X(1)
       DA2(2)=(F+R2*DFR)*(EL%AN(1)*SI)+ PHIZ*(2.0_dp*DFR+DFR2)*X(3)
    ENDIF

    IF(PRESENT(B)) THEN
       B(1)=DA(3,2)-DA(2,3)
       B(2)=DA(1,3)-DA(3,1)
       B(3)=DA(2,1)-DA(1,2)
    ENDIF
    !int_x2_f_by_x= (x1**3*(35*k**4*Y1**4+840*k**2*Y1**2+6720)+x1**5*(42*k**4*Y1**2+504 &
    !            *k**2)+15*k**4*x1**7)/20160.0_dp

    !int_y2_f_by_y= (15*k**4*Y1**7+(42*k**4*x1**2+504*k**2)*Y1**5+(35*k**4*x1**4+840*k &
    !       **2*x1**2+6720)*Y1**3)/20160.0_dp


    if(present(int_ax_dy)) then
       int_f=r2/2.0_dp+k**2*r2**2/32.0_dp+k**4*r2**3/24.0_dp/48.0_dp
       int_x2_f_by_x_dy=(x1**3*(140*k**4*Y1**3+1680*k**2*Y1)+84*k**4*x1**5*Y1)/20160.0_dp
       int_ax_dy=k*EL%BN(1)*SI*int_x2_f_by_x_dy+ k*EL%AN(1)*CO*(int_f+Y1**2*F)
       int_ax_dy=-int_ax_dy
    endif
    if(present(int_aY_dX)) then
       int_f=r2/2.0_dp+k**2*r2**2/32.0_dp+k**4*r2**3/24.0_dp/48.0_dp
       int_y2_f_by_y_dx=(84*k**4*x1*Y1**5+(140*k**4*x1**3+1680*k**2*x1)*Y1**3)/20160.0_dp
       int_aY_dX=k*EL%BN(1)*SI*(int_f+x1**2*F) + k*EL%AN(1)*CO*int_y2_f_by_y_dx
       int_aY_dX=-int_aY_dX
    endif
  END SUBROUTINE computeR_f4

  SUBROUTINE computeP_f4(EL,X,Z,DA2,B,A,d,int_ax_dy,int_aY_dX)
    IMPLICIT NONE
    TYPE(HELICAL_DIPOLEP), INTENT(INOUT)::EL
    type(real_8),  INTENT(IN)::X(6),Z
    type(real_8), OPTIONAL, INTENT(INOUT):: DA2(2),B(3),A(2),int_ax_dy,int_aY_dX
    type(real_8)  R2,DF,AR,PHIR,PHIZ,PHASE ,DFR,DFR2,co,si
    type(real_8), OPTIONAL, INTENT(INOUT):: d(3,3)
    type(real_8) x1,y1,k,F,FR,DA(3,3)
    type(real_8) int_x2_f_by_x_dy,int_y2_f_by_y_dx,int_f
    INTEGER j,kk

    call alloc(R2,DF,AR,PHIR,PHIZ,PHASE ,DFR,DFR2,co,si)
    call alloc(x1,y1,k,F,FR )
    call alloc(int_x2_f_by_x_dy,int_y2_f_by_y_dx,int_f)
    x1=x(1)
    y1=x(3)
    R2=x1**2+y1**2
    k=EL%FREQ
    DF=k**2/4.0_DP
    F=1.0_dp  +DF*R2/2.0_DP +DF*DF*R2**2/12.0_DP
    DFR=0.0_dp+DF  +DF*DF*R2/3.0_DP
    DFR2=0.0_dp+DF +DF*DF*R2



    PHASE=k*Z+EL%PHAS
    CO=COS(PHASE)
    SI=SIN(PHASE)
    PHIR=EL%BN(1)*X(1)*SI +EL%AN(1)*X(3)*CO
    AR=-k*F*PHIR
    IF(PRESENT(A)) THEN
       A(1)=X(1)*AR
       A(2)=X(3)*AR
    ENDIF

    IF(PRESENT(B).or.present(d)) THEN
       do j=1,3
          do kk=1,3
             call alloc(da(j,kk))
          enddo
       enddo
       DA(1,1)=-k*F*(EL%BN(1)*X(1)*SI +PHIR) &
            -X(1)**2*k*PHIR*DFR
       DA(1,2)=-k*F*(EL%AN(1)*X(1)*CO ) &
            -X(1)*X(3)*k*PHIR*DFR        !!!
       DA(2,1)=-k*F*(EL%BN(1)*X(3)*SI ) &    !!!! x(3)
            -X(1)*X(3)*k*PHIR*DFR
       DA(2,2)=-k*F*(EL%AN(1)*X(3)*CO +PHIR) &
            -X(3)**2*k*PHIR*DFR
       PHIZ=-EL%BN(1)*X(1)*CO +EL%AN(1)*X(3)*SI

       DA(1,3)=k**2*PHIZ*F*X(1)
       DA(2,3)=k**2*PHIZ*F*X(3)

       DA(3,1)=(F+R2*DFR)*(-EL%BN(1)*CO)+PHIZ*(2.0_dp*DFR+DFR2)*X(1)
       DA(3,2)=(F+R2*DFR)*(EL%AN(1)*SI)+ PHIZ*(2.0_dp*DFR+DFR2)*X(3)

       do j=1,3
          do kk=1,3
             if(present(d)) d(j,kk)=da(j,kk)
             !SRM DEBUG ... mmy
             !             call kill(da(j,kk))
          enddo
       enddo

    ENDIF
    IF(PRESENT(DA2)) THEN  !!
       PHIZ=-EL%BN(1)*X(1)*CO +EL%AN(1)*X(3)*SI

       DA2(1)=(F+R2*DFR)*(-EL%BN(1)*CO)+PHIZ*(2.0_dp*DFR+DFR2)*X(1)
       DA2(2)=(F+R2*DFR)*(EL%AN(1)*SI)+ PHIZ*(2.0_dp*DFR+DFR2)*X(3)
    ENDIF

    IF(PRESENT(B)) THEN
       B(1)=DA(3,2)-DA(2,3)
       B(2)=DA(1,3)-DA(3,1)
       B(3)=DA(2,1)-DA(1,2)
    ENDIF

    !SRM DEBUG ... alloc/kill mmy
    IF(PRESENT(B).or.present(d)) THEN
       do j=1,3
          do kk=1,3
             call kill(da(j,kk))
          enddo
       enddo
    ENDIF


    !int_x2_f_by_x= (x1**3*(35*k**4*Y1**4+840*k**2*Y1**2+6720)+x1**5*(42*k**4*Y1**2+504 &
    !            *k**2)+15*k**4*x1**7)/20160.0_dp

    !int_y2_f_by_y= (15*k**4*Y1**7+(42*k**4*x1**2+504*k**2)*Y1**5+(35*k**4*x1**4+840*k &
    !       **2*x1**2+6720)*Y1**3)/20160.0_dp


    if(present(int_ax_dy)) then
       int_f=r2/2.0_dp+k**2*r2**2/32.0_dp+k**4*r2**3/24.0_dp/48.0_dp
       int_x2_f_by_x_dy=(x1**3*(140*k**4*Y1**3+1680*k**2*Y1)+84*k**4*x1**5*Y1)/20160.0_dp
       int_ax_dy=k*EL%BN(1)*SI*int_x2_f_by_x_dy+ k*EL%AN(1)*CO*(int_f+Y1**2*F)
       int_ax_dy=-int_ax_dy
    endif
    if(present(int_aY_dX)) then
       int_f=r2/2.0_dp+k**2*r2**2/32.0_dp+k**4*r2**3/24.0_dp/48.0_dp
       int_y2_f_by_y_dx=(84*k**4*x1*Y1**5+(140*k**4*x1**3+1680*k**2*x1)*Y1**3)/20160.0_dp
       int_aY_dX=k*EL%BN(1)*SI*(int_f+x1**2*F) + k*EL%AN(1)*CO*int_y2_f_by_y_dx
       int_aY_dX=-int_aY_dX
    endif


    call kill(R2,DF,AR,PHIR,PHIZ,PHASE ,DFR,DFR2,co,si)
    call kill(x1,y1,k,F,FR )
    call kill(int_x2_f_by_x_dy,int_y2_f_by_y_dx,int_f)

  END SUBROUTINE computeP_f4


  SUBROUTINE KICKR_HE(EL,L,Z,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(HELICAL_DIPOLE),INTENT(INOUT):: EL
    real(dp),INTENT(IN):: L,Z
    real(dp) DA2(2)
    TYPE(INTERNAL_STATE) K

    CALL compute_f4(EL,X,Z,DA2=DA2)
    X(2)=X(2)+EL%p%charge*el%p%dir*L*DA2(1)
    X(4)=X(4)+EL%p%charge*el%p%dir*L*DA2(2)

  END SUBROUTINE KICKR_HE

  SUBROUTINE KICKP_HE(EL,L,Z,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(HELICAL_DIPOLEP),INTENT(INOUT):: EL
    TYPE(REAL_8),INTENT(IN):: L,Z
    TYPE(REAL_8) DA2(2)
    TYPE(INTERNAL_STATE) K

    CALL ALLOC(DA2,2)
    CALL compute_f4(EL,X,Z,DA2=DA2)
    X(2)=X(2)+EL%p%charge*el%p%dir*L*DA2(1)
    X(4)=X(4)+EL%p%charge*el%p%dir*L*DA2(2)
    CALL KILL(DA2,2)

  END SUBROUTINE KICKP_HE


  SUBROUTINE INTR_HE(EL,X,k,i)
    IMPLICIT NONE
    integer ipause, mypause
    real(dp),INTENT(INOUT):: X(6)
    TYPE(HELICAL_DIPOLE),INTENT(INOUT):: EL
    integer,INTENT(IN):: I
    real(dp) Z
    real(dp) D,DH
    real(dp) D1,D2,DK1,DK2
    real(dp) DF(4),DK(4)
    INTEGER J
    TYPE(INTERNAL_STATE)  K

    !    CALL SET_W(EL%W)

    SELECT CASE(EL%P%METHOD)
    CASE(2)
       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       IF(EL%P%DIR==1) THEN
          Z=(i-1)*d
       ELSE
          Z=EL%L-(i-1)*d
       ENDIF

       Z=Z+EL%P%DIR*DH
       CALL DRIFT(EL,DH,Z,1,X,K)
       CALL DRIFT(EL,DH,Z,2,X,K)
       CALL KICKPATH(EL,DH,Z,X,K)
       CALL KICK_HE(EL,D,Z,X,K)
       CALL KICKPATH(EL,DH,Z,X,K)
       CALL DRIFT(EL,DH,Z,2,X,K)
       CALL DRIFT(EL,DH,Z,1,X,K)
       !       Z=Z+EL%P%DIR*DH

    CASE(4)
       D=EL%L/EL%P%NST

       DK1=D*FK1
       D1=DK1/2.0_dp
       DK2=D*FK2
       D2=DK2/2.0_dp
       IF(EL%P%DIR==1) THEN
          Z=(i-1)*d
       ELSE
          Z=EL%L-(i-1)*d
       ENDIF

       Z=Z+EL%P%DIR*D1
       CALL DRIFT(EL,D1,Z,1,X,K)
       CALL DRIFT(EL,D1,Z,2,X,K)
       CALL KICKPATH(EL,D1,Z,X,K)
       CALL KICK_HE(EL,DK1,Z,X,K)
       CALL KICKPATH(EL,D1,Z,X,K)
       CALL DRIFT(EL,D1,Z,2,X,K)
       CALL DRIFT(EL,D1,Z,1,X,K)
       Z=Z+EL%P%DIR*(D1+D2)
       CALL DRIFT(EL,D2,Z,1,X,K)
       CALL DRIFT(EL,D2,Z,2,X,K)
       CALL KICKPATH(EL,D2,Z,X,K)
       CALL KICK_HE(EL,DK2,Z,X,K)
       CALL KICKPATH(EL,D2,Z,X,K)
       CALL DRIFT(EL,D2,Z,2,X,K)
       CALL DRIFT(EL,D2,Z,1,X,K)
       Z=Z+EL%P%DIR*(D1+D2)
       CALL DRIFT(EL,D1,Z,1,X,K)
       CALL DRIFT(EL,D1,Z,2,X,K)
       CALL KICKPATH(EL,D1,Z,X,K)
       CALL KICK_HE(EL,DK1,Z,X,K)
       CALL KICKPATH(EL,D1,Z,X,K)
       CALL DRIFT(EL,D1,Z,2,X,K)
       CALL DRIFT(EL,D1,Z,1,X,K)

    CASE(6)
       DO j =1,4
          DK(j)=EL%L*YOSK(J)/EL%P%NST
          DF(j)=DK(j)/2.0_dp
       ENDDO
       D=EL%L/EL%P%NST
       IF(EL%P%DIR==1) THEN
          Z=(i-1)*d
       ELSE
          Z=EL%L-(i-1)*d
       ENDIF
       DO J=4,1,-1
          Z=Z+EL%P%DIR*DF(J)
          CALL DRIFT(EL,DF(J),Z,1,X,K)
          CALL DRIFT(EL,DF(J),Z,2,X,K)
          CALL KICKPATH(EL,DF(J),Z,X,K)
          CALL KICK_HE(EL,DK(J),Z,X,K)
          CALL KICKPATH(EL,DF(J),Z,X,K)
          CALL DRIFT(EL,DF(J),Z,2,X,K)
          CALL DRIFT(EL,DF(J),Z,1,X,K)
          Z=Z+EL%P%DIR*DF(J)
       ENDDO
       DO J=2,4
          Z=Z+EL%P%DIR*DF(J)
          CALL DRIFT(EL,DF(J),Z,1,X,K)
          CALL DRIFT(EL,DF(J),Z,2,X,K)
          CALL KICKPATH(EL,DF(J),Z,X,K)
          CALL KICK_HE(EL,DK(J),Z,X,K)
          CALL KICKPATH(EL,DF(J),Z,X,K)
          CALL DRIFT(EL,DF(J),Z,2,X,K)
          CALL DRIFT(EL,DF(J),Z,1,X,K)
          Z=Z+EL%P%DIR*DF(J)
       ENDDO

    CASE DEFAULT
       WRITE(6,*) " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ipause=mypause(357)
    END SELECT

  END SUBROUTINE INTR_HE

  SUBROUTINE INTP_HE(EL,X,k,i)
    IMPLICIT NONE
    integer ipause, mypause
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(HELICAL_DIPOLEP),INTENT(INOUT):: EL
    integer,INTENT(IN):: I
    TYPE(REAL_8) Z
    TYPE(REAL_8) D,DH
    TYPE(REAL_8) D1,D2,DK1,DK2
    TYPE(REAL_8) DF(4),DK(4)
    INTEGER J
    TYPE(INTERNAL_STATE),OPTIONAL :: K

    CALL ALLOC(Z,D,DH,D1,D2,DK1,DK2)
    CALL ALLOC(DF,4)
    CALL ALLOC(DK,4)

    !    CALL SET_W(EL%W)
    SELECT CASE(EL%P%METHOD)
    CASE(2)
       DH=EL%L/2.0_dp/EL%P%NST
       D=EL%L/EL%P%NST
       IF(EL%P%DIR==1) THEN
          Z=(i-1)*d
       ELSE
          Z=EL%L-(i-1)*d
       ENDIF

       Z=Z+EL%P%DIR*DH
       CALL DRIFT(EL,DH,Z,1,X,K)
       CALL DRIFT(EL,DH,Z,2,X,K)
       CALL KICKPATH(EL,DH,Z,X,K)
       CALL KICK_HE(EL,D,Z,X,K)
       CALL KICKPATH(EL,DH,Z,X,K)
       CALL DRIFT(EL,DH,Z,2,X,K)
       CALL DRIFT(EL,DH,Z,1,X,K)
       !       Z=Z+EL%P%DIR*DH

    CASE(4)
       D=EL%L/EL%P%NST

       DK1=D*FK1
       D1=DK1/2.0_dp
       DK2=D*FK2
       D2=DK2/2.0_dp
       IF(EL%P%DIR==1) THEN
          Z=(i-1)*d
       ELSE
          Z=EL%L-(i-1)*d
       ENDIF

       Z=Z+EL%P%DIR*D1
       CALL DRIFT(EL,D1,Z,1,X,K)
       CALL DRIFT(EL,D1,Z,2,X,K)
       CALL KICKPATH(EL,D1,Z,X,K)
       CALL KICK_HE(EL,DK1,Z,X,K)
       CALL KICKPATH(EL,D1,Z,X,K)
       CALL DRIFT(EL,D1,Z,2,X,K)
       CALL DRIFT(EL,D1,Z,1,X,K)
       Z=Z+EL%P%DIR*(D1+D2)
       CALL DRIFT(EL,D2,Z,1,X,K)
       CALL DRIFT(EL,D2,Z,2,X,K)
       CALL KICKPATH(EL,D2,Z,X,K)
       CALL KICK_HE(EL,DK2,Z,X,K)
       CALL KICKPATH(EL,D2,Z,X,K)
       CALL DRIFT(EL,D2,Z,2,X,K)
       CALL DRIFT(EL,D2,Z,1,X,K)
       Z=Z+EL%P%DIR*(D1+D2)
       CALL DRIFT(EL,D1,Z,1,X,K)
       CALL DRIFT(EL,D1,Z,2,X,K)
       CALL KICKPATH(EL,D1,Z,X,K)
       CALL KICK_HE(EL,DK1,Z,X,K)
       CALL KICKPATH(EL,D1,Z,X,K)
       CALL DRIFT(EL,D1,Z,2,X,K)
       CALL DRIFT(EL,D1,Z,1,X,K)

    CASE(6)
       DO j =1,4
          DK(j)=EL%L*YOSK(j)/EL%P%NST
          DF(j)=DK(j)/2.0_dp
       ENDDO
       D=EL%L/EL%P%NST
       IF(EL%P%DIR==1) THEN
          Z=(i-1)*d
       ELSE
          Z=EL%L-(i-1)*d
       ENDIF
       DO J=4,1,-1
          Z=Z+EL%P%DIR*DF(J)
          CALL DRIFT(EL,DF(J),Z,1,X,K)
          CALL DRIFT(EL,DF(J),Z,2,X,K)
          CALL KICKPATH(EL,DF(J),Z,X,K)
          CALL KICK_HE(EL,DK(J),Z,X,K)
          CALL KICKPATH(EL,DF(J),Z,X,K)
          CALL DRIFT(EL,DF(J),Z,2,X,K)
          CALL DRIFT(EL,DF(J),Z,1,X,K)
          Z=Z+EL%P%DIR*DF(J)
       ENDDO
       DO J=2,4
          Z=Z+EL%P%DIR*DF(J)
          CALL DRIFT(EL,DF(J),Z,1,X,K)
          CALL DRIFT(EL,DF(J),Z,2,X,K)
          CALL KICKPATH(EL,DF(J),Z,X,K)
          CALL KICK_HE(EL,DK(J),Z,X,K)
          CALL KICKPATH(EL,DF(J),Z,X,K)
          CALL DRIFT(EL,DF(J),Z,2,X,K)
          CALL DRIFT(EL,DF(J),Z,1,X,K)
          Z=Z+EL%P%DIR*DF(J)
       ENDDO

    CASE DEFAULT
       WRITE(6,*) " THE METHOD ",EL%P%METHOD," IS NOT SUPPORTED"
       ipause=mypause(357)
    END SELECT

    CALL KILL(Z,D,DH,D1,D2,DK1,DK2)
    CALL KILL(DF,4)
    CALL KILL(DK,4)

  END SUBROUTINE INTP_HE

  SUBROUTINE INTR_HE_TOT(EL,X,k,mid)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(HELICAL_DIPOLE),INTENT(INOUT):: EL
    TYPE(WORM),OPTIONAL,INTENT(INOUT):: mid
    INTEGER I
    TYPE(INTERNAL_STATE)  K

    !    CALL SET_W(EL%W)
    IF(PRESENT(MID)) CALL XMID(MID,X,0)

    DO I=1,EL%P%NST
       call track_slice(el,x,k,i)
       IF(PRESENT(MID)) CALL XMID(MID,X,i)
    ENDDO


  END SUBROUTINE INTR_HE_TOT

  SUBROUTINE INTP_HE_TOT(EL,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(HELICAL_DIPOLEP),INTENT(INOUT):: EL
    TYPE(INTERNAL_STATE)  K

    INTEGER I

    !    CALL SET_W(EL%W)


    DO I=1,EL%P%NST
       call track_slice(el,x,k,i)
    ENDDO


  END SUBROUTINE INTP_HE_TOT
  ! ETIENNE
  SUBROUTINE KICKPATHR_HE(EL,L,Z,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(HELICAL_DIPOLE),INTENT(INOUT):: EL
    real(dp),INTENT(IN):: L,Z
    real(dp) PZ,PZ0,DPZ
    TYPE(INTERNAL_STATE),OPTIONAL :: K
    ! ETIENNE
    !     CALL compute_f4(EL,X,Z,A=A,int_ax_dy=int_ax_dy)
    !      X(2)=X(2)-el%p%charge*A(1)
    !      X(4)=X(4)-el%p%charge*int_ax_dy
    !      CALL compute_f4(EL,X,Z,A=A,int_ax_dy=int_ax_dy)
    !       X(2)=X(2)+el%p%charge*A(1)
    !       X(4)=X(4)+el%p%charge*int_ax_dy

    IF(EL%P%EXACT) THEN
       ! CALL compute_f4(EL,X,Z,A=A)    !,int_ax_dy=int_ax_dy)
       !  X(2)=X(2)-el%p%charge*A(1)
       !  X(4)=X(4)-el%p%charge*A(2)

       if(k%TIME) then
          PZ=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2-X(2)**2-X(4)**2)
          PZ0=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
          DPZ=(X(2)**2+X(4)**2)/PZ/PZ0/(PZ+PZ0)   ! = (one/PZ-one/PZ0)
          X(1)=X(1)+L*X(2)*DPZ
          X(3)=X(3)+L*X(4)*DPZ

          X(6)=X(6)+L*(PZ0/PZ-(X(2)**2+X(4)**2)/PZ0**2/2.0_dp)*   &
               (1.0_dp/EL%P%BETA0+X(5))/PZ0 +(k%TOTALPATH-1)*L/EL%P%BETA0
       else
          PZ=ROOT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          PZ0=1.0_dp+X(5)
          DPZ=(X(2)**2+X(4)**2)/PZ/PZ0/(PZ+PZ0)   ! = (one/PZ-one/PZ0)
          X(1)=X(1)+L*X(2)*DPZ
          X(3)=X(3)+L*X(4)*DPZ
          X(6)=X(6)+L*(PZ0/PZ-(X(2)**2+X(4)**2)/PZ0**2/2.0_dp)+(k%TOTALPATH-1)*L
       endif
       !      CALL compute_f4(EL,X,Z,A=A) !,int_ax_dy=int_ax_dy)
       !       X(2)=X(2)+el%p%charge*A(1)
       !       X(4)=X(4)+el%p%charge*A(2)
    ELSE
       if(k%TIME) then
          PZ0=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
          X(6)=X(6)+L*(1.0_dp/EL%P%BETA0+x(5))/PZ0+(k%TOTALPATH-1)*L/EL%P%BETA0
       else
          X(6)=X(6)+k%TOTALPATH*L
       endif
    ENDIF

  END SUBROUTINE KICKPATHR_HE

  SUBROUTINE KICKPATHR_HE_exact_nonsymp(EL,L,Z,X,k)
    IMPLICIT NONE
    real(dp),INTENT(INOUT):: X(6)
    TYPE(HELICAL_DIPOLE),INTENT(INOUT):: EL
    real(dp),INTENT(IN):: L,Z
    real(dp) PZ
    real(dp) A(3),da(3,3) !,int_ax_dy !,int_aY_dX
    TYPE(INTERNAL_STATE),OPTIONAL :: K
    ! ETIENNE

    IF(EL%P%EXACT) THEN
       CALL compute_f4(EL,X,Z,A=A,d=da)    !,int_ax_dy=int_ax_dy)
       X(2)=X(2) -el%p%charge*A(1)
       X(4)=X(4) -el%p%charge*A(2)
       if(k%TIME) then
          PZ=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2-X(2)**2-X(4)**2)
          X(1)=X(1)+L*X(2)/PZ
          X(3)=X(3)+L*X(4)/PZ
          ! multiply by el%p%charge forgotten
          X(2)=X(2)+el%p%charge*(L*X(4)/PZ*da(2,1)+L*X(2)/PZ*da(1,1))
          X(4)=X(4)+el%p%charge*(L*X(4)/PZ*da(2,2)+L*X(2)/PZ*da(1,2))
          X(6)=X(6)+L*(1.0_dp/EL%P%BETA0+X(5))/PZ+(k%TOTALPATH-1)*L/EL%P%BETA0
       else
          PZ=SQRT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          X(1)=X(1)+L*X(2)/PZ
          X(3)=X(3)+L*X(4)/PZ
          X(2)=X(2)+el%p%charge*(L*X(4)/PZ*da(2,1)+L*X(2)/PZ*da(1,1))
          X(4)=X(4)+el%p%charge*(L*X(4)/PZ*da(2,2)+L*X(2)/PZ*da(1,2))
          X(6)=X(6)+L*(1.0_dp+X(5))/PZ+(k%TOTALPATH-1)*L
       endif
       !      CALL compute_f4(EL,X,Z,A=A) !,int_ax_dy=int_ax_dy)
       X(2)=X(2) +el%p%charge*A(1)
       X(4)=X(4) +el%p%charge*A(2)
    ELSE
       if(k%TIME) then
          PZ=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
          X(6)=X(6)+L*(1.0_dp/EL%P%BETA0+x(5))/PZ+(k%TOTALPATH-1)*L/EL%P%BETA0
       else
          X(6)=X(6)+k%TOTALPATH*L
       endif
    ENDIF


  END SUBROUTINE KICKPATHR_HE_exact_nonsymp

  SUBROUTINE KICKPATHP_HE_exact_nonsymp(EL,L,Z,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(HELICAL_DIPOLEP),INTENT(INOUT):: EL
    TYPE(REAL_8),INTENT(IN):: L,Z
    TYPE(REAL_8) PZ,da(3,3),a(3)
    TYPE(INTERNAL_STATE),OPTIONAL :: K
    integer j,kk
    ! ETIENNE
    CALL ALLOC(PZ)
    IF(EL%P%EXACT) THEN
       CALL ALLOC(PZ)
       do j=1,3
          do kk=1,3
             call alloc(da(j,kk))
          enddo
       enddo
       call alloc(a)
       CALL compute_f4(EL,X,Z,A=A,d=da)    !,int_ax_dy=int_ax_dy)
       X(2)=X(2) -el%p%charge*A(1)
       X(4)=X(4) -el%p%charge*A(2)
       if(k%TIME) then
          PZ=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2-X(2)**2-X(4)**2)
          X(1)=X(1)+L*X(2)/PZ
          X(3)=X(3)+L*X(4)/PZ
          ! multiply by el%p%charge forgotten
          X(2)=X(2)+el%p%charge*(L*X(4)/PZ*da(2,1)+L*X(2)/PZ*da(1,1))
          X(4)=X(4)+el%p%charge*(L*X(4)/PZ*da(2,2)+L*X(2)/PZ*da(1,2))
          X(6)=X(6)+L*(1.0_dp/EL%P%BETA0+X(5))/PZ+(k%TOTALPATH-1)*L/EL%P%BETA0
       else
          PZ=SQRT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          X(1)=X(1)+L*X(2)/PZ
          X(3)=X(3)+L*X(4)/PZ
          X(2)=X(2)+el%p%charge*(L*X(4)/PZ*da(2,1)+L*X(2)/PZ*da(1,1))
          X(4)=X(4)+el%p%charge*(L*X(4)/PZ*da(2,2)+L*X(2)/PZ*da(1,2))
          X(6)=X(6)+L*(1.0_dp+X(5))/PZ+(k%TOTALPATH-1)*L
       endif
       do j=1,3
          do kk=1,3
             call kill(da(j,kk))
          enddo
       enddo
       !      CALL compute_f4(EL,X,Z,A=A) !,int_ax_dy=int_ax_dy)
       X(2)=X(2) +el%p%charge*A(1)
       X(4)=X(4) +el%p%charge*A(2)
       call kill(a)
    ELSE
       if(k%TIME) then
          PZ=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
          X(6)=X(6)+L*(1.0_dp/EL%P%BETA0+x(5))/PZ+(k%TOTALPATH-1)*L/EL%P%BETA0
       else
          X(6)=X(6)+k%TOTALPATH*L
       endif
    ENDIF
    CALL KILL(PZ)


  END SUBROUTINE KICKPATHP_HE_exact_nonsymp

  SUBROUTINE KICKPATHP_HE(EL,L,Z,X,k)
    IMPLICIT NONE
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(HELICAL_DIPOLEP),INTENT(INOUT):: EL
    TYPE(REAL_8),INTENT(IN):: L,Z
    TYPE(REAL_8) PZ,PZ0,DPZ
    TYPE(INTERNAL_STATE),OPTIONAL :: K
    ! ETIENNE
    CALL ALLOC(PZ,PZ0,DPZ)
    IF(EL%P%EXACT) THEN
       if(k%TIME) then
          PZ=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2-X(2)**2-X(4)**2)
          PZ0=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
          DPZ=(X(2)**2+X(4)**2)/PZ/PZ0/(PZ+PZ0)   ! = (one/PZ-one/PZ0)
          X(1)=X(1)+L*X(2)*DPZ
          X(3)=X(3)+L*X(4)*DPZ

          X(6)=X(6)+L*(PZ0/PZ-(X(2)**2+X(4)**2)/PZ0**2/2.0_dp)*   &
               (1.0_dp/EL%P%BETA0+X(5))/PZ0 +(k%TOTALPATH-1)*L/EL%P%BETA0
       else
          PZ=SQRT((1.0_dp+X(5))**2-X(2)**2-X(4)**2)
          PZ0=1.0_dp+X(5)
          DPZ=(X(2)**2+X(4)**2)/PZ/PZ0/(PZ+PZ0)   ! = (one/PZ-one/PZ0)
          X(1)=X(1)+L*X(2)*DPZ
          X(3)=X(3)+L*X(4)*DPZ
          X(6)=X(6)+L*(PZ0/PZ-(X(2)**2+X(4)**2)/PZ0**2/2.0_dp)+(k%TOTALPATH-1)*L
       endif
    ELSE
       if(k%TIME) then
          PZ0=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%beta0+x(5)**2)
          X(6)=X(6)+L*(1.0_dp/EL%P%BETA0+x(5))/PZ0+(k%TOTALPATH-1)*L/EL%P%BETA0
       else
          X(6)=X(6)+k%TOTALPATH*L
       endif
    ENDIF
    CALL KILL(PZ,PZ0,DPZ)


  END SUBROUTINE KICKPATHP_HE

  SUBROUTINE DRIFTR_HE(EL,L,Z,PLANE,X,k)
    IMPLICIT NONE
    TYPE(HELICAL_DIPOLE),INTENT(INOUT):: EL
    real(dp),INTENT(INOUT):: X(6)
    real(dp), INTENT(IN):: L,Z
    INTEGER, INTENT(IN)::PLANE
    real(dp) PZ,A(3),int_ax_dy,int_aY_dX
    TYPE(INTERNAL_STATE) K
    !DRIFT(EL,DH,Z,1,X,K)
    if(el%p%exact) return
    IF(PLANE==1) THEN
       CALL compute_f4(EL,X,Z,A=A,int_ax_dy=int_ax_dy)
       X(2)=X(2)-el%p%charge*A(1)
       X(4)=X(4)-el%p%charge*int_ax_dy
       if(k%TIME) then
          PZ=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%BETA0+x(5)**2)
          X(1)=X(1)+L*X(2)/pz
          X(6)=X(6)+((X(2)*X(2))/2.0_dp/pz**2)*(1.0_dp/EL%P%BETA0+x(5))*L/pz
       else
          X(1)=X(1)+L*X(2)/(1.0_dp+X(5))
          X(6)=X(6)+(L/(1.0_dp+X(5)))*(X(2)*X(2))/2.0_dp/(1.0_dp+X(5))
       endif
       CALL compute_f4(EL,X,Z,A=A,int_ax_dy=int_ax_dy)
       X(2)=X(2)+el%p%charge*A(1)
       X(4)=X(4)+el%p%charge*int_ax_dy
    ELSE
       CALL compute_f4(EL,X,Z,A=A,int_aY_dX=int_aY_dX)
       X(2)=X(2)-el%p%charge*int_aY_dX
       X(4)=X(4)-el%p%charge*A(2)
       if(k%TIME) then
          PZ=ROOT(1.0_dp+2.0_dp*X(5)/EL%P%BETA0+x(5)**2)
          X(3)=X(3)+L*X(4)/pz
          X(6)=X(6)+((X(4)*X(4))/2.0_dp/pz**2)*(1.0_dp/EL%P%BETA0+x(5))*L/pz
       else
          X(3)=X(3)+L*X(4)/(1.0_dp+X(5))
          X(6)=X(6)+(L/(1.0_dp+X(5)))*(X(4)*X(4))/2.0_dp/(1.0_dp+X(5))
       endif
       CALL compute_f4(EL,X,Z,A=A,int_aY_dX=int_aY_dX)
       X(2)=X(2)+el%p%charge*int_aY_dX
       X(4)=X(4)+el%p%charge*A(2)
    ENDIF
  END SUBROUTINE DRIFTR_HE

  SUBROUTINE DRIFTP_HE(EL,L,Z,PLANE,X,k)
    IMPLICIT NONE
    TYPE(HELICAL_DIPOLEP),INTENT(INOUT):: EL
    TYPE(REAL_8),INTENT(INOUT):: X(6)
    TYPE(REAL_8), INTENT(IN):: L,Z
    INTEGER, INTENT(IN)::PLANE
    TYPE(REAL_8) PZ,A(3),int_ax_dy,int_aY_dX
    TYPE(INTERNAL_STATE) K
    if(el%p%exact) return

    CALL ALLOC(PZ,int_ax_dy,int_aY_dX)
    CALL ALLOC(A,3)
    IF(PLANE==1) THEN

       CALL compute_f4(EL,X,Z,A=A,int_ax_dy=int_ax_dy)

       X(2)=X(2)-el%p%charge*A(1)
       X(4)=X(4)-el%p%charge*int_ax_dy

       if(k%TIME) then
          PZ=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%BETA0+x(5)**2)
          X(1)=X(1)+L*X(2)/pz
          X(6)=X(6)+((X(2)*X(2))/2.0_dp/pz**2)*(1.0_dp/EL%P%BETA0+x(5))*L/pz
       else
          X(1)=X(1)+L*X(2)/(1.0_dp+X(5))
          X(6)=X(6)+(L/(1.0_dp+X(5)))*(X(2)*X(2))/2.0_dp/(1.0_dp+X(5))
       endif
       CALL compute_f4(EL,X,Z,A=A,int_ax_dy=int_ax_dy)
       X(2)=X(2)+el%p%charge*A(1)
       X(4)=X(4)+el%p%charge*int_ax_dy
    ELSE
       CALL compute_f4(EL,X,Z,A=A,int_aY_dX=int_aY_dX)
       X(2)=X(2)-el%p%charge*int_aY_dX
       X(4)=X(4)-el%p%charge*A(2)
       if(k%TIME) then
          PZ=SQRT(1.0_dp+2.0_dp*X(5)/EL%P%BETA0+x(5)**2)
          X(3)=X(3)+L*X(4)/pz
          X(6)=X(6)+((X(4)*X(4))/2.0_dp/pz**2)*(1.0_dp/EL%P%BETA0+x(5))*L/pz
       else
          X(3)=X(3)+L*X(4)/(1.0_dp+X(5))
          X(6)=X(6)+(L/(1.0_dp+X(5)))*(X(4)*X(4))/2.0_dp/(1.0_dp+X(5))
       endif
       CALL compute_f4(EL,X,Z,A=A,int_aY_dX=int_aY_dX)
       X(2)=X(2)+el%p%charge*int_aY_dX
       X(4)=X(4)+el%p%charge*A(2)
    ENDIF
    CALL KILL(PZ,int_ax_dy,int_aY_dX)
    CALL KILL(A,3)
  END SUBROUTINE DRIFTP_HE

!!!!   Enge function
  SUBROUTINE enge_f(EL,z0)
    IMPLICIT NONE
    type(enge), intent(inout) :: el
    real(dp), intent(inout) :: z0
    type(my_1D_taylor)z,dz
    integer i

    EL%F=0.0_dp
    z=z0
    dz=1.0_dp
    z%a(1)=1.0_dp

    do i=0,N_ENGE
       EL%F=EL%F+EL%A(I)*DZ
       dz=dz*(Z-EL%L/2.0_dp)/EL%D
    enddo
    EL%F=1.0_dp/(1.0_dp+EXP(EL%F))
  end subroutine enge_f

  SUBROUTINE ZEROr_enge(EL,I)
    IMPLICIT NONE
    TYPE(ENGE), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%D)) then
          deallocate(EL%D)
          deallocate(EL%A)
          deallocate(EL%NBESSEL)
          deallocate(EL%F)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%D)
       NULLIFY(EL%NBESSEL)
       NULLIFY(EL%A)
       NULLIFY(EL%F)
    endif

  END SUBROUTINE ZEROr_enge

  SUBROUTINE ZEROP_enge(EL,I)
    IMPLICIT NONE
    TYPE(ENGEP), INTENT(INOUT)::EL
    INTEGER, INTENT(IN)::I
    !    integer k
    IF(I==-1) THEN
       if(ASSOCIATED(EL%D)) then
          deallocate(EL%D)
          deallocate(EL%A)
          deallocate(EL%NBESSEL)
          deallocate(EL%F)
       endif
    elseif(i==0)       then          ! nullifies

       NULLIFY(EL%D)
       NULLIFY(EL%NBESSEL)
       NULLIFY(EL%A)
       NULLIFY(EL%F)
    endif

  END SUBROUTINE ZEROP_enge

  SUBROUTINE elliptical_b_r(st,sc,coord,bx,by)
    ! Tracking subroutine for elliptical lens
    ! A.Valishev (valishev@fnal.gov) October 19, 2010
    ! Modified by E. Forest for PTC
    !
    ! U(u,v)=(u*sqrt(u**2-1)+v*sqrt(1-v**2)*(-pi/2+acos(v))/(u**2-v**2)
    !st=lens strength
    ! sc=c
    ! b= bfield in x and y

    implicit none

    !global variables

    real(dp), intent(inout) ::  coord(6),bx,by
    real(dp), intent(in) :: st,sc

    real(dp) dd, u, v, dUu, dUv, dux, duy, dvx, dvy, x, y

    bx=0.0_dp
    by=0.0_dp
    IF(ABS(SC)<=eps) RETURN
    x = coord(1)/sc
    y =  coord(3)/sc
    u=0.5_dp*sqrt((x-1.0_dp)**2+y**2)+0.5_dp*sqrt((x+1.0_dp)**2+y**2)
    v=0.5_dp*sqrt((x+1.0_dp)**2+y**2)-0.5_dp*sqrt((x-1.0_dp)**2+y**2)
    if (u.eq.1.0_dp) then
       dd=0.0_dp
    else
       dd=u**2*log(u+sqrt(u*u-1.0_dp))/sqrt(u**2-1.0_dp)
    end if
    dUu=(u+log(u+sqrt(u*u-1.0_dp))*sqrt(u**2-1.0_dp)+dd)/(u**2-v**2) &
         -2.0_dp*u*(u*log(u+sqrt(u*u-1.0_dp))*sqrt(u**2-1.0_dp) &
         +v*(acos(v)-0.5_dp*pi)*sqrt(1.0_dp-v**2)) /(u**2-v**2)**2
    dUv=2.0_dp*v*(u*log(u+sqrt(u*u-1.0_dp))*sqrt(u**2-1.0_dp) &
         +v*(acos(v)-0.5_dp*pi)*sqrt(1.0_dp-v**2)) /(u**2-v**2)**2 &
         -(v-(acos(v)-0.5_dp*pi)*sqrt(1.0_dp-v**2)+v**2*(acos(v)-0.5_dp*pi)/sqrt(1.0_dp-v**2))&
         /(u**2-v**2)
    dux=0.5_dp*(x-1.0_dp)/sqrt((x-1.0_dp)**2+y**2) +0.5_dp*(x+1.0_dp)/sqrt((x+1.0_dp)**2+y**2)
    duy=0.5_dp*y/sqrt((x-1.0_dp)**2+y**2) +0.5_dp*y/sqrt((x+1.0_dp)**2+y**2)
    dvx=0.5_dp*(x+1.0_dp)/sqrt((x+1.0_dp)**2+y**2) -0.5_dp*(x-1.0_dp)/sqrt((x-1.0_dp)**2+y**2)
    dvy=0.5_dp*y/sqrt((x+1.0_dp)**2+y**2) -0.5_dp*y/sqrt((x-1.0_dp)**2+y**2)

    by=-st*(dUu*dux+dUv*dvx)/sc
    bx=st*(dUu*duy+dUv*dvy)/sc

  end SUBROUTINE elliptical_b_r

  SUBROUTINE elliptical_b_p(st,sc,coord,bx,by)
    ! Tracking subroutine for elliptical lens
    ! A.Valishev (valishev@fnal.gov) October 19, 2010
    ! Modified by E. Forest for PTC
    !
    ! U(u,v)=(u*sqrt(u**2-1)+v*sqrt(1-v**2)*(-pi/2+acos(v))/(u**2-v**2)
    !st=lens strength
    ! sc=c
    ! b= bfield in x and y

    implicit none

    !global variables

    type(real_8), intent(inout) :: coord(6),bx,by
    type(real_8), intent(in) :: st,sc
    type(real_8) dd,ac,sqv,u, v, dUu, dUv, dux, duy, dvx, dvy, x, y,dv,uv2,uv,sqb,sqbm
    integer i,n
    real(dp) xu,x1,x2

    bx=0.0_dp
    by=0.0_dp
    IF(ABS(SC)<=eps) RETURN

    call alloc(u, v, dUu, dUv, dux, duy, dvx, dvy, x, y)
    call alloc(dd,dv,uv,uv2,ac,sqv,sqb,sqbm)

    bx=st*2.0_dp/sc**2*coord(3)
    by=st*2.0_dp/sc**2*coord(1)

    x = coord(1)/sc
    y =  coord(3)/sc
    sqb=sqrt((x+1.0_dp)**2+y**2)
    sqbm=sqrt((x-1.0_dp)**2+y**2)

    u=0.5_dp*sqbm+0.5_dp*sqb
    v=0.5_dp*sqb-0.5_dp*sqbm
    xu=u
    if (xu<1.1_dp) then
       !if (valishev) then
       !write(6,*) " xu expanded", xu
       dUu=u-1.0_dp
       dUv=1.0_dp
       dv=0.0_dp
       !   do i=0,(nvalishev-1)/2
       do i=0,(size(val_del%a)-1)/2
          dv=val_del%a(i)*duv+dv
          duv=duv*dUu
          ! write(6,*) i, val_del%a(i)
       enddo
       dd=dv*u**2/sqrt(u+1.0_dp)
       dv=dv*sqrt(u+1.0_dp)*(u-1.0_dp)
    else
       ! write(6,*) " xu normal", xu
       dd=u**2*log(u+sqrt(u*u-1.0_dp))/sqrt(u**2-1.0_dp)
       dv=log(u+sqrt(u*u-1.0_dp))/sqrt(u-1.0_dp)
       dv=dv*sqrt(u+1.0_dp)*(u-1.0_dp)
    end if
    uv=(u**2-v**2)
    uv2=uv**2
    ac=acos(v)


    sqv=sqrt(1.0_dp-v**2)

    dUu=(u+dv+dd)/uv-2.0_dp*u*(u*dv+v*(ac-0.5_dp*pi)*sqv) /uv2
    dUv=2.0_dp*v*(u*dv+v*(ac-0.5_dp*pi)*sqv) /uv2
    dUv=dUv-(v-(ac-0.5_dp*pi)*sqv+v**2*(ac-0.5_dp*pi)/sqv)/uv

    dux=0.5_dp*(x-1.0_dp)/sqbm +0.5_dp*(x+1.0_dp)/sqb

    duy=0.5_dp*y/sqbm +0.5_dp*y/sqb
    dvx=0.5_dp*(x+1.0_dp)/sqb -0.5_dp*(x-1.0_dp)/sqbm
    dvy=0.5_dp*y/sqb -0.5_dp*y/sqbm

    by=-st*(dUu*dux+dUv*dvx)/sc
    bx=st*(dUu*duy+dUv*dvy)/sc

    !call print(by,10)
    !call print(bx,10)
    !goto 100

100 call kill(u, v, dUu, dUv, dux, duy, dvx, dvy, x, y)
    call kill(dd,dv,uv,uv2,ac,sqv,sqb,sqbm)


  end SUBROUTINE elliptical_b_p

 !!!!!!!!!!!!!!!!!!!!    electric field testing !!!!!!!!!!!!!!!!!!!!
 subroutine invert_electric_teapot(asni,bsni)
 implicit none
 real(dp) a(no_e,no_e),b(no_e,no_e),asni(no_e,0:no_e,0:no_e), &
  bsni(no_e,0:no_e,0:no_e)
 integer no,np,nd,k,n,l,jc(2),ier,i,j
 type(taylor) fh,x,y,h
 type(taylorresonance) fhr
 type(complextaylor) fhc
 type(taylor) phi,e(2)
 type(taylor)   as(no_e),bs(no_e)
 real(dp)   asn(no_e,0:no_e,0:no_e),bsn(no_e,0:no_e,0:no_e)
 real(dp) h0
 type(damap) m
 no=no_e 
 nd=1
 np=0
 h0=1.d-1
 call init(no,nd,np,0)
 asn=0.0_dp
 bsn=0.0_dp
 a=0.0_dp
 b=0.0_dp
 call alloc(as,no)
 call alloc(bs,no)
 call alloc(m)
 call alloc(e)
 call alloc(fhc)
 call alloc(phi)
 call alloc(fhr)
 call alloc(fh,x,y,h)
 h=h0 !+one.mono.3
 m=1
 m%v(2)=0.0_dp
 
 do n=1,no
 x=1.0_dp.mono.1
 y=1.0_dp.mono.2
 fhc=-(x+i_*y)**n/n
 
 fh=fhc%r
 fhr=fh
 phi=0.0_dp 

do k=1,c_%no+2
 call integrate_electric_teapot(fh,phi,h)
 !x=one+h*(one.mono.1)
 bs(n)=fh+phi
 !y= ((((y.d.1)*x).d.1)/x)+((y.d.2).d.2)
enddo
! call print(y,6)
 e(1)=-(bs(n).d.1)*m
 !call print(e(1),6)
  jc=0
 do l=1,no
  jc(1)=l-1
  b(l,n)=e(1).sub.jc
 enddo
 ! write(6,*) b(n,1:no)

 fh=fhc%i
 fhr=fh
 phi=0.0_dp 

do k=1,c_%no
 call integrate_electric_teapot(fh,phi,h)
! x=one+h*(one.mono.1)
 as(n)=fh+phi
! y= ((((y.d.1)*x).d.1)/x)+((y.d.2).d.2)
enddo
! call print(y,6)
 e(2)=-(as(n).d.2)*m
! call print(e(2),6)
   jc=0
 do l=1,no
  jc(1)=l-1
  a(l,n)=e(2).sub.jc
 enddo
 !write(6,*) a(n,1:no)
 !pause 12
enddo
   call matinv(a,a,no,no,ier)
   if(ier/=0) then
    write(6,*) ier
    stop 9
   endif
   call matinv(b,b,no,no,ier)
   if(ier/=0) then
    write(6,*) ier
    stop 10
   endif
  
   do k=1,no
    do i=0,no
     do j=0,no
      if(i+j>no) cycle
      jc(1)=i
      jc(2)=j
      asn(k,i,j)=as(k).sub.jc
      bsn(k,i,j)=bs(k).sub.jc
     enddo
    enddo
   enddo


  do i=0,no
  do j=0,no
  do k=1,no
  do l=1,no
   asni(l,i,j)=a(k,l)*asn(k,i,j)+asni(l,i,j)
   bsni(l,i,j)=b(k,l)*bsn(k,i,j)+bsni(l,i,j)
  enddo
  enddo
  enddo
  enddo

 call kill(fh,x,y,h)
 call kill(fhr)
 call kill(fhc)
 call kill(phi)
 call kill(e)
 call kill(m)
 call kill(as,no)
 call kill(bs,no)
 
 end  subroutine invert_electric_teapot
 
 subroutine integrate_electric_teapot(fh,phi,h)
 implicit none
 integer n1,i
 type(taylor) fh
 type(taylorresonance) tr
 type(taylorresonance) ur
 type(complextaylor) u
 type(taylor) phi,h,f
 integer, allocatable :: jc(:)
 real(dp) val
  
  call alloc(u)
  call alloc(tr)
  call alloc(ur)
  call alloc(f)
  
  
  f=fh+phi
  f=f.d.1
  f=-(h/(1.0_dp+h*(1.0_dp.mono.1))  )*f
  
  tr=f
  allocate(jc(c_%nv))
 u=0.0_dp
    call taylor_cycle(tr%cos,size=n1)

    do i=1,n1
     
     jc=0
       call taylor_cycle(tr%cos,ii=i,value=val,j=jc)
       
       jc(1)=jc(1)+1
       jc(2)=jc(2)+1
        val=val/4.0_dp/jc(1)/jc(2)
        u=u+(val.mono.jc)  
    enddo

    call taylor_cycle(tr%sin,size=n1)

    do i=1,n1
     
     jc=0
       call taylor_cycle(tr%sin,ii=i,value=val,j=jc)
       
       jc(1)=jc(1)+1
       jc(2)=jc(2)+1
        val=val/4.0_dp/jc(1)/jc(2)
        u=u+i_*(val.mono.jc)  
    enddo
    
    tr%cos=u%r
    tr%sin=u%i
    phi=tr
  deallocate(jc)   
  call kill(f)
  call kill(u)
  call kill(ur)
  call kill(tr)

end subroutine integrate_electric_teapot


END MODULE S_DEF_KIND