        !COMPILER-GENERATED INTERFACE MODULE: Fri May 22 16:58:30 2020
        ! This source file is for reference only and may not completely
        ! represent the generated interface used by the compiler.
        MODULE COMPUTE_COUPLING_ACOUSTIC_EL__genmod
          INTERFACE
            SUBROUTINE COMPUTE_COUPLING_ACOUSTIC_EL(DISPL_ELASTIC,      &
     &DISPL_ELASTIC_OLD,POTENTIAL_DOT_DOT_ACOUSTIC,                     &
     &PML_BOUNDARY_CONDITIONS)
              USE SPECFEM_PAR, ONLY :                                   &
     &          NUM_FLUID_SOLID_EDGES,                                  &
     &          IBOOL,                                                  &
     &          WXGLL,                                                  &
     &          WZGLL,                                                  &
     &          XIX,                                                    &
     &          XIZ,                                                    &
     &          GAMMAX,                                                 &
     &          GAMMAZ,                                                 &
     &          JACOBIAN,                                               &
     &          IVALUE,                                                 &
     &          JVALUE,                                                 &
     &          IVALUE_INVERSE,                                         &
     &          JVALUE_INVERSE,                                         &
     &          FLUID_SOLID_ACOUSTIC_ISPEC,                             &
     &          FLUID_SOLID_ACOUSTIC_IEDGE,                             &
     &          FLUID_SOLID_ELASTIC_ISPEC,                              &
     &          FLUID_SOLID_ELASTIC_IEDGE,                              &
     &          AXISYM,                                                 &
     &          COORD,                                                  &
     &          IS_ON_THE_AXIS,                                         &
     &          XIGLJ,                                                  &
     &          WXGLJ,                                                  &
     &          NSPEC_PML,                                              &
     &          K_X_STORE,                                              &
     &          K_Z_STORE,                                              &
     &          D_X_STORE,                                              &
     &          D_Z_STORE,                                              &
     &          ALPHA_X_STORE,                                          &
     &          ALPHA_Z_STORE,                                          &
     &          IS_PML,                                                 &
     &          SPEC_TO_PML,                                            &
     &          REGION_CPML,                                            &
     &          RMEMORY_FSB_DISPL_ELASTIC,                              &
     &          TIMEVAL,                                                &
     &          DELTAT,                                                 &
     &          RMEMORY_FSB_DISPL_ELASTIC_LDDRK,                        &
     &          I_STAGE,                                                &
     &          STAGE_TIME_SCHEME,                                      &
     &          ALPHA_LDDRK,                                            &
     &          BETA_LDDRK,                                             &
     &          NGLOB_ACOUSTIC,                                         &
     &          NGLOB_ELASTIC
              REAL(KIND=4) :: DISPL_ELASTIC(3,NGLOB_ELASTIC)
              REAL(KIND=4) :: DISPL_ELASTIC_OLD(3,NGLOB_ELASTIC)
              REAL(KIND=4) :: POTENTIAL_DOT_DOT_ACOUSTIC(NGLOB_ACOUSTIC)
              LOGICAL(KIND=4) :: PML_BOUNDARY_CONDITIONS
            END SUBROUTINE COMPUTE_COUPLING_ACOUSTIC_EL
          END INTERFACE
        END MODULE COMPUTE_COUPLING_ACOUSTIC_EL__genmod


!
! Copyright (C) 2004-2011 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!-------------------------------------------------------------------
module funct
!-------------------------------------------------------------------
! This module contains data defining the DFT functional in use
! and a number of functions and subroutines to manage them.
! Data are PRIVATE and are accessed and set only by function calls.
! Basic drivers to compute XC quantities are also included.
!
!  setting routines:   set_dft_from_name (previously which_dft)
!                      set_dft_from_indices
!                      enforce_input_dft
!                      start_exx
!                      stop_exx
!                      set_finite_size_volume
!  retrieve functions: get_dft_name
!                      get_iexch
!                      get_icorr
!                      get_igcx
!                      get_igcc
!                      get_exx_fraction
!                      dft_name
!                      write_dft_name
!  logical functions:  dft_is_gradient
!                      dft_is_meta
!                      dft_is_hybrid
!                      dft_is_nonlocc
!                      exx_is_active
!                      dft_has_finite_size_correction
!
!  XC computation drivers: xc, xc_spin, gcxc, gcx_spin, gcc_spin, gcc_spin_more
!  derivatives of XC computation drivers: dmxc, dmxc_spin, dmxc_nc, dgcxc,
!                                         dgcxc_spin
!
  USE io_global, ONLY: stdout
  USE kinds,     ONLY: DP
  IMPLICIT NONE
  PRIVATE
  SAVE
  ! subroutines/functions managing dft name and indices
  PUBLIC  :: set_dft_from_indices, set_dft_from_name
  PUBLIC  :: enforce_input_dft, write_dft_name, dft_name
  PUBLIC  :: get_dft_name, get_iexch, get_icorr, get_igcx, get_igcc, get_inlc
  PUBLIC  :: dft_is_gradient

  ! additional subroutines/functions for hybrid functionals
  ! additional subroutines/functions for finite size corrections
  ! driver subroutines computing XC
  PUBLIC  :: xc, xc_spin, gcxc, gcx_spin, gcc_spin
  PUBLIC  :: dmxc, dmxc_spin
  PUBLIC  :: dgcxc, dgcxc_spin
  !
  ! PRIVATE variables defining the DFT functional
  !
  PRIVATE :: dft, dft_shortname, iexch, icorr, igcx, igcc, inlc
  PRIVATE :: discard_input_dft
  PRIVATE :: isgradient, ismeta, ishybrid
  PRIVATE :: exx_fraction, exx_started
  PRIVATE :: has_finite_size_correction, &
             finite_size_cell_volume,  finite_size_cell_volume_set
  !
  character (len=25) :: dft = 'not set'
  character (len=6)  :: dft_shortname = ' '
  !
  ! dft is the exchange-correlation functional, described by
  ! one of the following keywords ("dft_shortname"):
  !              "pz"    = "sla+pz"            = Perdew-Zunger LDA
  !              "pbe"   = "sla+pw+pbx+pbc"    = PBE
  ! References:
  !              pz      J.P.Perdew and A.Zunger, PRB 23, 5048 (1981)
  !              pbe     J.P.Perdew, K.Burke, M.Ernzerhof, PRL 77, 3865 (1996)
  !
  integer, parameter:: notset = -1
  !
  integer :: iexch = notset
  integer :: icorr = notset
  integer :: igcx  = notset
  integer :: igcc  = notset
  integer :: inlc  = notset
  real(DP):: exx_fraction = 0.0_DP
  real(DP):: screening_parameter = 0.0_DP
  logical :: isgradient  = .false.
  logical :: ismeta      = .false.
  logical :: ishybrid    = .false.
  logical :: exx_started = .false.
  logical :: has_finite_size_correction = .false.
  logical :: finite_size_cell_volume_set = .false.
  real(DP):: finite_size_cell_volume = notset

  logical :: isnonlocc       = .false.

  logical :: discard_input_dft = .false.
  !
  ! internal indices for exchange-correlation
  !    iexch: type of exchange
  !    icorr: type of correlation
  !    igcx:  type of gradient correction on exchange
  !    igcc:  type of gradient correction on correlation
  !    inlc:  type of non local correction on correlation
  !
  !    ismeta: .TRUE. if gradient correction is of meta-gga type
  !    ishybrid: .TRUE. if the xc functional is an HF+DFT hybrid like
  !              PBE0, B3LYP, HSE or HF itself
  !
  ! see comments above and routine "set_dft_from_name" below
  !
  ! data
  integer :: nxc, ncc, ngcx, ngcc, ncnl

  parameter (nxc = 8, ncc =11, ngcx =16, ngcc = 10, ncnl=2)

  character (len=4) :: exc, corr
  character (len=4) :: gradx, gradc, nonlocc
  dimension exc (0:nxc), corr (0:ncc), gradx (0:ngcx), gradc (0: ngcc), nonlocc (0: ncnl)

  data exc / 'NOX', 'SLA', 'SL1', 'RXC', 'OEP', 'HF', 'PB0X', 'B3LP', 'KZK' /
  data corr / 'NOC', 'PZ', 'VWN', 'LYP', 'PW', 'WIG', 'HL', 'OBZ', &
              'OBW', 'GL' , 'B3LP', 'KZK' /
  data gradx / 'NOGX', 'B88', 'GGX', 'PBX',  'RPB', 'HCTH', 'OPTX',&
               'META', 'PB0X', 'B3LP','PSX', 'WCX', 'HSE', 'RW86', 'PBE', &
               'TPSS', 'C09X' /

  data gradc / 'NOGC', 'P86', 'GGC', 'BLYP', 'PBC', 'HCTH', 'META',&
                'B3LP', 'PSC', 'PBE', 'TPSS' /

  data nonlocc / '    ', 'VDW1', 'VDW2' /

CONTAINS
  !-----------------------------------------------------------------------
  subroutine set_dft_from_name( dft_ )
    !-----------------------------------------------------------------------
    !
    ! translates a string containing the exchange-correlation name
    ! into internal indices iexch, icorr, igcx, igcc
    !
    implicit none
    ! input
    character(len=*)               :: dft_
    ! local
    integer :: len, l, i
    character (len=50):: dftout
    logical :: dft_defined = .false.
    logical, external :: matches
    character (len=1), external :: capital
    integer ::  save_iexch, save_icorr, save_igcx, save_igcc, save_inlc

    !
    !
    ! Exit if discard_input_dft
    !
    if ( discard_input_dft ) return
    !
    ! save current status of XC indices
    !
    save_iexch = iexch
    save_icorr = icorr
    save_igcx  = igcx
    save_igcc  = igcc
    save_inlc  = inlc
    !
    ! convert to uppercase
    !
    len = len_trim(dft_)
    dftout = ' '
    do l = 1, len
       dftout (l:l) = capital (dft_(l:l) )
    enddo
    !
    ! ----------------------------------------------
    ! FIRST WE CHECK ALL THE SPECIAL NAMES
    ! Note: comparison is now done via exact matching
    !       not using function "matches"
    ! ----------------------------------------------
    !
    if ('PBE' .EQ. TRIM(dftout) ) then
    ! special case : PBE
       call set_dft_value (iexch,1) !Default
       call set_dft_value (icorr,4)
       call set_dft_value (igcx, 3)
       call set_dft_value (igcc, 4)
       call set_dft_value (inlc,0) !Default
       dft_defined = .true.

    ! special cases : PZ  (LDA is equivalent to PZ)
    else IF (('PZ' .EQ. TRIM(dftout) ).OR.('LDA' .EQ. TRIM(dftout) )) THEN
       call set_dft_value (iexch,1)
       call set_dft_value (icorr, 1)
       CALL set_dft_value( igcx,  0)
       call set_dft_value (igcc, 0)
       call set_dft_value (inlc,0)
       dft_defined = .true.

    else

       call errore('set_dft_from_name','only LDA and PZ functionals are supported in mini_DFT',1)

    END IF

    !
    ! Fill variables and exit
    !
    dft = dftout

    dftout = exc (iexch) //'-'//corr (icorr) //'-'//gradx (igcx) //'-' &
         &//gradc (igcc) //'-'// nonlocc(inlc)

    call set_auxiliary_flags
    !
    ! check dft has not been previously set differently
    !
    if (save_iexch .ne. notset .and. save_iexch .ne. iexch) then
       write (stdout,*) iexch, save_iexch
       call errore('set_dft_from_name',' conflicting values for iexch',1)
    end if
    if (save_icorr .ne. notset .and. save_icorr .ne. icorr) then
       write (stdout,*) icorr, save_icorr
       call errore('set_dft_from_name',' conflicting values for icorr',1)
    end if
    if (save_igcx .ne. notset .and. save_igcx .ne. igcx) then
       write (stdout,*) igcx, save_igcx
       call errore('set_dft_from_name',' conflicting values for igcx',1)
    end if
    if (save_igcc .ne. notset .and. save_igcc .ne. igcc) then
       write (stdout,*) igcc, save_igcc
       call errore('set_dft_from_name',' conflicting values for igcc',1)
    end if
    if (save_inlc .ne. notset .and. save_inlc .ne. inlc) then
       write (stdout,*) inlc, save_inlc
       call errore('set_dft_from_name',' conflicting values for inlc',1)
    end if

    return
  end subroutine set_dft_from_name
  !
  !-----------------------------------------------------------------------
  subroutine set_auxiliary_flags
    !-----------------------------------------------------------------------
    ! set logical flags describing the complexity of the xc functional
    ! define the fraction of exact exchange used by hybrid fuctionals
    !
    logical, external :: matches

    !! Reversed as before VDW
    isgradient =  ( (igcx > 0) .or. ( igcc > 0) )

    isnonlocc = (inlc > 0)

    ismeta     =  (igcx == 7)

    ishybrid = ( exx_fraction /= 0.0_DP )

    has_finite_size_correction = ( iexch==8 .or. icorr==11)

    return
  end subroutine set_auxiliary_flags
  !
  !-----------------------------------------------------------------------
  subroutine set_dft_value (m, i)
    !-----------------------------------------------------------------------
    !
    implicit none
    integer :: m, i
    ! local

    if ( m /= notset .and. m /= i) then
         write(*, '(A,2I4)') "parameters", m, i
         call errore ('set_dft_value', 'two conflicting matching values', 1)
    end if
    m = i
    return

  end subroutine set_dft_value

  !-----------------------------------------------------------------------
  subroutine enforce_input_dft (dft_, nomsg)
    !
    ! translates a string containing the exchange-correlation name
    ! into internal indices and force any subsequent call to set_dft_from_name
    ! to return without changing them
    !
    implicit none
    character(len=*), intent(in) :: dft_
    logical, intent(in), optional :: nomsg

     call set_dft_from_name (dft_)
     if (dft == 'not set') call errore('enforce_input_dft','cannot fix unset dft',1)
     discard_input_dft = .true.

     if ( present (nomsg) ) return

     write (stdout,'(/,5x,a)') "IMPORTANT: XC functional enforced from input :"
     call write_dft_name
     write (stdout,'(5x,a)') "Any further DFT definition will be discarded"
     write (stdout,'(5x,a/)') "Please, verify this is what you really want"

     return
  end subroutine enforce_input_dft

  !-----------------------------------------------------------------------
  function get_iexch ()
     integer get_iexch
     get_iexch = iexch
     return
  end function get_iexch
  !-----------------------------------------------------------------------
  function get_icorr ()
     integer get_icorr
     get_icorr = icorr
     return
  end function get_icorr
  !-----------------------------------------------------------------------
  function get_igcx ()
     integer get_igcx
     get_igcx = igcx
     return
  end function get_igcx
  !-----------------------------------------------------------------------
  function get_igcc ()
     integer get_igcc
     get_igcc = igcc
     return
  end function get_igcc
  !-----------------------------------------------------------------------
  function get_inlc ()
     integer get_inlc
     get_inlc = inlc
     return
  end function get_inlc
  function get_dft_name ()
     character (len=25) :: get_dft_name
     get_dft_name = dft
     return
  end function get_dft_name
  !-----------------------------------------------------------------------
  function dft_is_gradient ()
     logical :: dft_is_gradient
     dft_is_gradient = isgradient
     return
  end function dft_is_gradient

  !-----------------------------------------------------------------------
  subroutine set_dft_from_indices(iexch_,icorr_,igcx_,igcc_, inlc_)
     integer :: iexch_, icorr_, igcx_, igcc_, inlc_
     if ( discard_input_dft ) return
     if (iexch == notset) iexch = iexch_
     if (iexch /= iexch_) then
        write (stdout,*) iexch, iexch_
        call errore('set_dft',' conflicting values for iexch',1)
     end if
     if (icorr == notset) icorr = icorr_
     if (icorr /= icorr_) then
        write (stdout,*) icorr, icorr_
        call errore('set_dft',' conflicting values for icorr',1)
     end if
     if (igcx  == notset) igcx = igcx_
     if (igcx /= igcx_) then
        write (stdout,*) igcx, igcx_
        call errore('set_dft',' conflicting values for igcx',1)
     end if
     if (igcc  == notset) igcc = igcc_
     if (igcc /= igcc_) then
        write (stdout,*) igcc, igcc_
        call errore('set_dft',' conflicting values for igcc',1)
     end if
     if (inlc  == notset) inlc = inlc_
     if (inlc /= inlc_) then
        write (stdout,*) inlc, inlc_
        call errore('set_dft',' conflicting values for inlc',1)
     end if
     dft = exc (iexch) //'-'//corr (icorr) //'-'//gradx (igcx) //'-' &
           &//gradc (igcc)//'-'//nonlocc (inlc)
     ! WRITE( stdout,'(a)') dft
     call set_auxiliary_flags
     return
  end subroutine set_dft_from_indices
  !---------------------------------------------------------------------
  subroutine dft_name(iexch_, icorr_, igcx_, igcc_, inlc_, longname_, shortname_)
  !---------------------------------------------------------------------
  ! convert the four indices iexch, icorr, igcx, igcc
  ! into user-readable strings
  !
  implicit none
  integer iexch_, icorr_, igcx_, igcc_, inlc_
  character (len=6) :: shortname_
  character (len=25):: longname_
  !
  if (iexch_==1.and.igcx_==0.and.igcc_==0) then
     shortname_ = corr(icorr_)
  else if (iexch_==1.and.icorr_==4.and.igcx_==3.and.igcc_==4) then
     shortname_ = 'PBE'
  else
     shortname_ = ' '
  end if
  write(longname_,'(5a5)') exc(iexch_),corr(icorr_),gradx(igcx_),gradc(igcc_),nonlocc(inlc_)

  return
end subroutine dft_name

subroutine write_dft_name
!-----------------------------------------------------------------------
   WRITE( stdout, '(5X,"Exchange-correlation      = ",A, &
        &  " (",5I2,")")') TRIM( dft ), iexch, icorr, igcx, igcc, inlc
   return
end subroutine write_dft_name

!
!-----------------------------------------------------------------------
!-------  LDA DRIVERS --------------------------------------------------
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
subroutine xc (rho, ex, ec, vx, vc)
  !-----------------------------------------------------------------------
  !     lda exchange and correlation functionals - Hartree a.u.
  !
  !     exchange   :  Slater, relativistic Slater
  !     correlation:  Ceperley-Alder (Perdew-Zunger parameters)
  !
  !     input : rho=rho(r)
  !     definitions: E_x = \int E_x(rho) dr, E_x(rho) = rho\epsilon_c(rho)
  !                  same for correlation
  !     output: ex = \epsilon_x(rho) ( NOT E_x(rho) )
  !             vx = dE_x(rho)/drho  ( NOT d\epsilon_x(rho)/drho )
  !             ec, vc as above for correlation
  !
  implicit none

  real(DP) :: rho, ec, vc, ex, vx
  !
  real(DP), parameter :: small = 1.E-10_DP,  third = 1.0_DP / 3.0_DP, &
       pi34 = 0.6203504908994_DP  ! pi34=(3/4pi)^(1/3)
  real(DP) :: rs
  !
  if (rho <= small) then
     ec = 0.0_DP
     vc = 0.0_DP
     ex = 0.0_DP
     vx = 0.0_DP
     return
  else
     rs = pi34 / rho**third
     ! rs as in the theory of metals: rs=(3/(4pi rho))^(1/3)
  endif
  !..exchange
  if (iexch == 1) THEN             !  'sla'
     call slater (rs, ex, vx)
  else
     ex = 0.0_DP
     vx = 0.0_DP
  endif
  !..correlation
  if (icorr == 1) then
     call pz (rs, 1, ec, vc)
  elseif (icorr == 4) then
     call pw (rs, 1, ec, vc)
  else
     ec = 0.0_DP
     vc = 0.0_DP
  endif
  !
  return
end subroutine xc
!!!!!!!!!!!!!!SPIN
!-----------------------------------------------------------------------
subroutine xc_spin (rho, zeta, ex, ec, vxup, vxdw, vcup, vcdw)
  !-----------------------------------------------------------------------
  !     lsd exchange and correlation functionals - Hartree a.u.
  !
  !     exchange  :  Slater (alpha=2/3)
  !     correlation: Ceperley & Alder (Perdew-Zunger parameters)
  !                  Perdew & Wang
  !
  !     input : rho = rhoup(r)+rhodw(r)
  !             zeta=(rhoup(r)-rhodw(r))/rho
  !
  implicit none

  real(DP) :: rho, zeta, ex, ec, vxup, vxdw, vcup, vcdw
  !
  real(DP), parameter :: small= 1.E-10_DP, third = 1.0_DP/3.0_DP, &
       pi34= 0.6203504908994_DP ! pi34=(3/4pi)^(1/3)
  real(DP) :: rs
  !
  if (rho <= small) then
     ec = 0.0_DP
     vcup = 0.0_DP
     vcdw = 0.0_DP
     ex = 0.0_DP
     vxup = 0.0_DP
     vxdw = 0.0_DP
     return
  else
     rs = pi34 / rho**third
  endif
  !..exchange
  IF (iexch == 1) THEN      ! 'sla'
     call slater_spin (rho, zeta, ex, vxup, vxdw)
  ELSE
     ex = 0.0_DP
     vxup = 0.0_DP
     vxdw = 0.0_DP
  ENDIF
  !..correlation
if (icorr == 1) then
     call pz_spin (rs, zeta, ec, vcup, vcdw)
  elseif (icorr == 4) then
     call pw_spin (rs, zeta, ec, vcup, vcdw)
  else
     call errore ('lsda_functional (xc_spin)', 'not implemented', icorr)
  endif
  !
  return
end subroutine xc_spin
!
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!------- GRADIENT CORRECTIONS DRIVERS ----------------------------------
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
subroutine gcxc (rho, grho, sx, sc, v1x, v2x, v1c, v2c)
  !-----------------------------------------------------------------------
  !     gradient corrections for exchange and correlation - Hartree a.u.
  !     See comments at the beginning of module for implemented cases
  !
  !     input:  rho, grho=|\nabla rho|^2
  !     definition:  E_x = \int E_x(rho,grho) dr
  !     output: sx = E_x(rho,grho)
  !             v1x= D(E_x)/D(rho)
  !             v2x= D(E_x)/D( D rho/D r_alpha ) / |\nabla rho|
  !             sc, v1c, v2c as above for correlation
  !
  implicit none

  real(DP) :: rho, grho, sx, sc, v1x, v2x, v1c, v2c
  real(DP) :: sxsr, v1xsr, v2xsr
  real(DP), parameter:: small = 1.E-10_DP

  ! exchange
  if (rho <= small) then
     sx = 0.0_DP
     v1x = 0.0_DP
     v2x = 0.0_DP
  elseif (igcx == 3) then
     call pbex (rho, grho, 1, sx, v1x, v2x)
  else
     sx = 0.0_DP
     v1x = 0.0_DP
     v2x = 0.0_DP
  endif
  ! correlation
  if (rho.le.small) then
     sc = 0.0_DP
     v1c = 0.0_DP
     v2c = 0.0_DP
  elseif (igcc == 4) then
     call pbec (rho, grho, 1, sc, v1c, v2c)
  else
     sc = 0.0_DP
     v1c = 0.0_DP
     v2c = 0.0_DP
  endif
  !
  return
end subroutine gcxc
!
!!!!!!!!!!!!!!SPIN
!-----------------------------------------------------------------------
subroutine gcx_spin (rhoup, rhodw, grhoup2, grhodw2, &
                     sx, v1xup, v1xdw, v2xup, v2xdw)
  !-----------------------------------------------------------------------
  !     gradient corrections for exchange - Hartree a.u.
  !
  implicit none
  !
  !     dummy arguments
  !
  real(DP) :: rhoup, rhodw, grhoup2, grhodw2, sx, v1xup, v1xdw, &
       v2xup, v2xdw
  ! up and down charge
  ! up and down gradient of the charge
  ! exchange and correlation energies
  ! derivatives of exchange wr. rho
  ! derivatives of exchange wr. grho
  !
  real(DP) :: sxsr, v1xupsr, v2xupsr, v1xdwsr, v2xdwsr
  real(DP), parameter :: small = 1.E-10_DP
  real(DP) :: rho, sxup, sxdw
  integer :: iflag
  !
  !
  ! exchange
  rho = rhoup + rhodw
  if (rho <= small .or. igcx == 0) then
     sx = 0.0_DP
     v1xup = 0.0_DP
     v2xup = 0.0_DP
     v1xdw = 0.0_DP
     v2xdw = 0.0_DP
  elseif (igcx == 3 .or. igcx == 4 .or. igcx == 8 .or. &
          igcx == 10 .or. igcx == 12) then
     ! igcx=3: PBE, igcx=4: revised PBE, igcx=8 PBE0, igcx=10: PBEsol
     ! igcx=12: HSE
     if (rhoup > small .and. sqrt (abs (grhoup2) ) > small) then
        call pbex (2.0_DP * rhoup, 4.0_DP * grhoup2, iflag, sxup, v1xup, v2xup)
     else
        sxup = 0.0_DP
        v1xup = 0.0_DP
        v2xup = 0.0_DP
     endif
     if (rhodw > small .and. sqrt (abs (grhodw2) ) > small) then
        call pbex (2.0_DP * rhodw, 4.0_DP * grhodw2, iflag, sxdw, v1xdw, v2xdw)
     else
        sxdw = 0.0_DP
        v1xdw = 0.0_DP
        v2xdw = 0.0_DP
     endif
     sx = 0.5_DP * (sxup + sxdw)
     v2xup = 2.0_DP * v2xup
     v2xdw = 2.0_DP * v2xdw
     if (igcx == 8 .and. exx_started ) then
       sx = (1.0_DP - exx_fraction) * sx
       v1xup = (1.0_DP - exx_fraction) * v1xup
       v1xdw = (1.0_DP - exx_fraction) * v1xdw
       v2xup = (1.0_DP - exx_fraction) * v2xup
       v2xdw = (1.0_DP - exx_fraction) * v2xdw
     end if
  else
     call errore ('gcx_spin', 'not implemented', igcx)
  endif
  !
  return
end subroutine gcx_spin
!
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
subroutine gcc_spin (rho, zeta, grho, sc, v1cup, v1cdw, v2c)
  !-----------------------------------------------------------------------
  !     gradient corrections for correlations - Hartree a.u.
  !     Implemented:  Perdew86, GGA (PW91), PBE
  !
  implicit none
  !
  !     dummy arguments
  !
  real(DP) :: rho, zeta, grho, sc, v1cup, v1cdw, v2c
  ! the total charge
  ! the magnetization
  ! the gradient of the charge squared
  ! exchange and correlation energies
  ! derivatives of correlation wr. rho
  ! derivatives of correlation wr. grho

  real(DP), parameter :: small = 1.E-10_DP, epsr=1.E-6_DP
  !
  !
  if ( abs(zeta) > 1.0_DP ) then
     sc = 0.0_DP
     v1cup = 0.0_DP
     v1cdw = 0.0_DP
     v2c = 0.0_DP
     return
  else
     !
     ! ... ( - 1.0 + epsr )  <  zeta  <  ( 1.0 - epsr )
     zeta = SIGN( MIN( ABS( zeta ), ( 1.0_DP - epsr ) ) , zeta )
  endif

  if (igcc == 0 .or. rho <= small .or. sqrt(abs(grho)) <= small) then
     sc = 0.0_DP
     v1cup = 0.0_DP
     v1cdw = 0.0_DP
     v2c = 0.0_DP
  elseif (igcc == 4) then
     call pbec_spin (rho, zeta, grho, 1, sc, v1cup, v1cdw, v2c)
  else
     call errore ('lsda_functionals (gcc_spin)', 'not implemented', igcc)
  endif
  !
  return
end subroutine gcc_spin

!-----------------------------------------------------------------------
!------- DRIVERS FOR DERIVATIVES OF XC POTENTIAL -----------------------
!-----------------------------------------------------------------------
!
      !-----------------------------------------------------------------------
      function dmxc (rho)
        !-----------------------------------------------------------------------
        !
        !  derivative of the xc potential with respect to the local density
        !
        !
        implicit none
        !
        real(DP), intent(in) :: rho
        ! input: the charge density ( positive )
        real(DP) :: dmxc
        ! output: the derivative of the xc potential
        !
        ! local variables
        !
        real(DP) :: dr, vxp, vcp, vxm, vcm, vx, ex, ec, rs
        real(DP), external :: dpz
        integer :: iflg
        !
        real(DP), parameter :: small = 1.E-30_DP, e2 = 2.0_DP, &
             pi34 = 0.75_DP / 3.141592653589793_DP, third = 1.0_DP /3.0_DP
        !
        dmxc = 0.0_DP
        if (rho < small) then
           return
        endif
        !
        !    first case: analytical derivatives available
        !
        if (get_iexch() == 1 .and. get_icorr() == 1) then
           rs = (pi34 / rho) **third
           !..exchange
           call slater (rs, ex, vx)
           dmxc = vx / (3.0_DP * rho)
           !..correlation
           iflg = 2
           if (rs < 1.0_DP) iflg = 1
           dmxc = dmxc + dpz (rs, iflg)
        else
           !
           !     second case: numerical derivatives
           !
           dr = min (1.E-6_DP, 1.E-4_DP * rho)
           call xc (rho + dr, ex, ec, vxp, vcp)
           call xc (rho - dr, ex, ec, vxm, vcm)
           dmxc = (vxp + vcp - vxm - vcm) / (2.0_DP * dr)
        endif
        !
        ! bring to rydberg units
        !
        dmxc = e2 * dmxc
        return
        !
      end function dmxc
      !
      !-----------------------------------------------------------------------
      subroutine dmxc_spin (rhoup, rhodw, dmuxc_uu, dmuxc_ud, dmuxc_du, &
           dmuxc_dd)
      !-----------------------------------------------------------------------
        !  derivative of the xc potential with respect to the local density
        !  spin-polarized case
        !
        implicit none
        !
        real(DP), intent(in) :: rhoup, rhodw
        ! input: spin-up and spin-down charge density
        real(DP), intent(out) :: dmuxc_uu, dmuxc_ud, dmuxc_du, dmuxc_dd
        ! output: up-up, up-down, down-up, down-down derivatives of the
        ! XC functional
        !
        ! local variables
        !
        real(DP) :: rhotot, rs, zeta, fz, fz1, fz2, ex, vx, ecu, ecp, vcu, &
             vcp, dmcu, dmcp, aa, bb, cc, dr, dz, ec, vxupm, vxdwm, vcupm, &
             vcdwm, rho, vxupp, vxdwp, vcupp, vcdwp, zeta_eff
        real(DP), external :: dpz, dpz_polarized
        integer :: iflg
        !
        real(DP), parameter :: small = 1.E-30_DP, e2 = 2.0_DP, &
             pi34 = 0.75_DP / 3.141592653589793_DP, third = 1.0_DP/3.0_DP, &
             p43 = 4.0_DP / 3.0_DP, p49 = 4.0_DP / 9.0_DP, m23 = -2.0_DP / 3.0_DP
        !
        dmuxc_uu = 0.0_DP
        dmuxc_du = 0.0_DP
        dmuxc_ud = 0.0_DP
        dmuxc_dd = 0.0_DP
        !
        rhotot = rhoup + rhodw
        if (rhotot <= small) return
        zeta = (rhoup - rhodw) / rhotot

        if (abs (zeta) > 1.0_DP) return
        if (get_iexch() == 1 .and. get_icorr() == 1) then
           !
           !    first case: analytical derivative available
           !
           !..exchange
           rs = (pi34 / (2.0_DP * rhoup) ) **third
           call slater (rs, ex, vx)
           dmuxc_uu = vx / (3.0_DP * rhoup)
           rs = (pi34 / (2.0_DP * rhodw) ) **third
           call slater (rs, ex, vx)
           dmuxc_dd = vx / (3.0_DP * rhodw)
           !..correlation
           rs = (pi34 / rhotot) **third
           iflg = 2
           if (rs < 1.0_DP) iflg = 1
           dmcu = dpz (rs, iflg)
           dmcp = dpz_polarized (rs, iflg)
           call pz (rs, 1, ecu, vcu)
           call pz_polarized (rs, ecp, vcp)
           fz = ( (1.0_DP + zeta) **p43 + (1.0_DP - zeta) **p43 - 2.0_DP) &
                / (2.0_DP**p43 - 2.0_DP)
           fz1 = p43 * ( (1.0_DP + zeta) **third- (1.0_DP - zeta) **third) &
                / (2.0_DP**p43 - 2.0_DP)
           fz2 = p49 * ( (1.0_DP + zeta) **m23 + (1.0_DP - zeta) **m23) &
                / (2.0_DP**p43 - 2.0_DP)
           aa = dmcu + fz * (dmcp - dmcu)
           bb = 2.0_DP * fz1 * (vcp - vcu - (ecp - ecu) ) / rhotot
           cc = fz2 * (ecp - ecu) / rhotot
           dmuxc_uu = dmuxc_uu + aa + (1.0_DP - zeta) * bb + (1.0_DP - zeta)**2 * cc
           dmuxc_du = dmuxc_du + aa + ( - zeta) * bb + (zeta**2 - 1.0_DP) * cc
           dmuxc_ud = dmuxc_du
           dmuxc_dd = dmuxc_dd+aa - (1.0_DP + zeta) * bb + (1.0_DP + zeta)**2 * cc

        else

           rho = rhoup + rhodw
           dr = min (1.E-6_DP, 1.E-4_DP * rho)
           call xc_spin (rho - dr, zeta, ex, ec, vxupm, vxdwm, vcupm, vcdwm)
           call xc_spin (rho + dr, zeta, ex, ec, vxupp, vxdwp, vcupp, vcdwp)
           dmuxc_uu = (vxupp + vcupp - vxupm - vcupm) / (2.0_DP * dr)
           dmuxc_ud = dmuxc_uu
           dmuxc_dd = (vxdwp + vcdwp - vxdwm - vcdwm) / (2.0_DP * dr)
           dmuxc_du = dmuxc_dd
           ! dz = min (1.d-6, 1.d-4 * abs (zeta) )
           dz = 1.E-6_DP
!
!          If zeta is too close to +-1, the derivative is computed at a slightly
!          smaller zeta
!
           zeta_eff = SIGN( MIN( ABS( zeta ), ( 1.0_DP - 2.0_DP*dz ) ) , zeta )

           call xc_spin (rho, zeta_eff - dz, ex, ec, vxupm, vxdwm, vcupm, vcdwm)
           call xc_spin (rho, zeta_eff + dz, ex, ec, vxupp, vxdwp, vcupp, vcdwp)
           dmuxc_uu = dmuxc_uu + (vxupp + vcupp - vxupm - vcupm) * &
                (1.0_DP - zeta) / rho / (2.0_DP * dz)
           dmuxc_ud = dmuxc_ud- (vxupp + vcupp - vxupm - vcupm) * &
                (1.0_DP + zeta) / rho / (2.0_DP * dz)
           dmuxc_du = dmuxc_du + (vxdwp + vcdwp - vxdwm - vcdwm) * &
                (1.0_DP - zeta) / rho / (2.0_DP * dz)
           dmuxc_dd = dmuxc_dd- (vxdwp + vcdwp - vxdwm - vcdwm) * &
                (1.0_DP + zeta) / rho / (2.0_DP * dz)
        endif
        !
        ! bring to rydberg units
        !
        dmuxc_uu = e2 * dmuxc_uu
        dmuxc_du = e2 * dmuxc_du
        dmuxc_ud = e2 * dmuxc_ud
        dmuxc_dd = e2 * dmuxc_dd
        !
        return

      end subroutine dmxc_spin

      !
      !-----------------------------------------------------------------------
      subroutine dgcxc (r, s2, vrrx, vsrx, vssx, vrrc, vsrc, vssc)
        !-----------------------------------------------------------------------
        USE kinds, only : DP
        implicit none
        real(DP) :: r, s2, vrrx, vsrx, vssx, vrrc, vsrc, vssc
        real(DP) :: dr, s, ds

        real(DP) :: sx, sc, v1xp, v2xp, v1cp, v2cp, v1xm, v2xm, v1cm, &
             v2cm
        s = sqrt (s2)
        dr = min (1.d-4, 1.d-2 * r)

        ds = min (1.d-4, 1.d-2 * s)
        call gcxc (r + dr, s2, sx, sc, v1xp, v2xp, v1cp, v2cp)

        call gcxc (r - dr, s2, sx, sc, v1xm, v2xm, v1cm, v2cm)
        vrrx = 0.5d0 * (v1xp - v1xm) / dr

        vrrc = 0.5d0 * (v1cp - v1cm) / dr
        vsrx = 0.25d0 * (v2xp - v2xm) / dr

        vsrc = 0.25d0 * (v2cp - v2cm) / dr
        call gcxc (r, (s + ds) **2, sx, sc, v1xp, v2xp, v1cp, v2cp)

        call gcxc (r, (s - ds) **2, sx, sc, v1xm, v2xm, v1cm, v2cm)
        vsrx = vsrx + 0.25d0 * (v1xp - v1xm) / ds / s

        vsrc = vsrc + 0.25d0 * (v1cp - v1cm) / ds / s
        vssx = 0.5d0 * (v2xp - v2xm) / ds / s

        vssc = 0.5d0 * (v2cp - v2cm) / ds / s
        return
      end subroutine dgcxc
      !
      !-----------------------------------------------------------------------
      subroutine dgcxc_spin (rup, rdw, gup, gdw, vrrxup, vrrxdw, vrsxup, &
           vrsxdw, vssxup, vssxdw, vrrcup, vrrcdw, vrscup, vrscdw, vssc, &
           vrzcup, vrzcdw)
        !-----------------------------------------------------------------------
        !
        !    This routine computes the derivative of the exchange and correlatio
        !    potentials with respect to the density, the gradient and zeta
        !
        USE kinds, only : DP
        implicit none
        real(DP), intent(in) :: rup, rdw, gup (3), gdw (3)
        ! input: the charges and the gradient
        real(DP), intent(out):: vrrxup, vrrxdw, vrsxup, vrsxdw, vssxup, &
             vssxdw, vrrcup, vrrcdw, vrscup, vrscdw, vssc, vrzcup, vrzcdw
        ! output: derivatives of the exchange and of the correlation
        !
        !    local variables
        !
        real(DP) :: r, zeta, sup2, sdw2, s2, s, sup, sdw, dr, dzeta, ds, &
             drup, drdw, dsup, dsdw, sx, sc, v1xupp, v1xdwp, v2xupp, v2xdwp, &
             v1xupm, v1xdwm, v2xupm, v2xdwm, v1cupp, v1cdwp, v2cp, v1cupm, &
             v1cdwm, v2cm
        ! charge densities and square gradients
        ! delta charge densities and gra
        ! delta gradients
        ! energies
        ! exchange potentials
        ! exchange potentials
        ! coorelation potentials
        ! coorelation potentials
        real(DP), parameter :: eps = 1.d-6
        !
        r = rup + rdw
        if (r.gt.eps) then
           zeta = (rup - rdw) / r
        else
           zeta = 2.d0
        endif
        sup2 = gup (1) **2 + gup (2) **2 + gup (3) **2
        sdw2 = gdw (1) **2 + gdw (2) **2 + gdw (3) **2

        s2 = (gup (1) + gdw (1) ) **2 + (gup (2) + gdw (2) ) **2 + &
             (gup (3) + gdw (3) ) **2
        sup = sqrt (sup2)
        sdw = sqrt (sdw2)
        s = sqrt (s2)
        !
        !     up part of exchange
        !

        if (rup.gt.eps.and.sup.gt.eps) then
           drup = min (1.d-4, 1.d-2 * rup)
           dsup = min (1.d-4, 1.d-2 * sdw)
           !
           !    derivatives of exchange: up part
           !
           call gcx_spin (rup + drup, rdw, sup2, sdw2, sx, v1xupp, v1xdwp, &
                v2xupp, v2xdwp)

           call gcx_spin (rup - drup, rdw, sup2, sdw2, sx, v1xupm, v1xdwm, &
                v2xupm, v2xdwm)
           vrrxup = 0.5d0 * (v1xupp - v1xupm) / drup
           vrsxup = 0.25d0 * (v2xupp - v2xupm) / drup

           call gcx_spin (rup, rdw, (sup + dsup) **2, sdw2, sx, v1xupp, &
                v1xdwp, v2xupp, v2xdwp)

           call gcx_spin (rup, rdw, (sup - dsup) **2, sdw2, sx, v1xupm, &
                v1xdwm, v2xupm, v2xdwm)
           vrsxup = vrsxup + 0.25d0 * (v1xupp - v1xupm) / dsup / sup
           vssxup = 0.5d0 * (v2xupp - v2xupm) / dsup / sup
        else
           vrrxup = 0.d0
           vrsxup = 0.d0
           vssxup = 0.d0
        endif

        if (rdw.gt.eps.and.sdw.gt.eps) then
           drdw = min (1.d-4, 1.d-2 * rdw)
           dsdw = min (1.d-4, 1.d-2 * sdw)
           !
           !    derivatives of exchange: down part
           !
           call gcx_spin (rup, rdw + drdw, sup2, sdw2, sx, v1xupp, v1xdwp, &
                v2xupp, v2xdwp)

           call gcx_spin (rup, rdw - drdw, sup2, sdw2, sx, v1xupm, v1xdwm, &
                v2xupm, v2xdwm)
           vrrxdw = 0.5d0 * (v1xdwp - v1xdwm) / drdw

           vrsxdw = 0.25d0 * (v2xdwp - v2xdwm) / drdw
           call gcx_spin (rup, rdw, sup2, (sdw + dsdw) **2, sx, v1xupp, &
                v1xdwp, v2xupp, v2xdwp)

           call gcx_spin (rup, rdw, sup2, (sdw - dsdw) **2, sx, v1xupm, &
                v1xdwm, v2xupm, v2xdwm)
           vrsxdw = vrsxdw + 0.25d0 * (v1xdwp - v1xdwm) / dsdw / sdw
           vssxdw = 0.5d0 * (v2xdwp - v2xdwm) / dsdw / sdw
        else
           vrrxdw = 0.d0
           vrsxdw = 0.d0
           vssxdw = 0.d0
        endif
        !
        !     derivatives of correlation
        !

        if (r.gt.eps.and.abs (zeta) .le.1.d0.and.s.gt.eps) then

           dr = min (1.d-4, 1.d-2 * r)
           call gcc_spin (r + dr, zeta, s2, sc, v1cupp, v1cdwp, v2cp)

           call gcc_spin (r - dr, zeta, s2, sc, v1cupm, v1cdwm, v2cm)
           vrrcup = 0.5d0 * (v1cupp - v1cupm) / dr

           vrrcdw = 0.5d0 * (v1cdwp - v1cdwm) / dr

           ds = min (1.d-4, 1.d-2 * s)
           call gcc_spin (r, zeta, (s + ds) **2, sc, v1cupp, v1cdwp, v2cp)

           call gcc_spin (r, zeta, (s - ds) **2, sc, v1cupm, v1cdwm, v2cm)
           vrscup = 0.5d0 * (v1cupp - v1cupm) / ds / s
           vrscdw = 0.5d0 * (v1cdwp - v1cdwm) / ds / s

           vssc = 0.5d0 * (v2cp - v2cm) / ds / s
!           dzeta = min (1.d-4, 1.d-2 * abs (zeta) )

           dzeta = 1.d-6
!
!   If zeta is too close to +-1 the derivative is evaluated at a slightly
!   smaller  value
!
           zeta = SIGN( MIN( ABS( zeta ), ( 1.0_DP - 2.0_DP*dzeta ) ) , zeta )

           call gcc_spin (r, zeta + dzeta, s2, sc, v1cupp, v1cdwp, v2cp)

           call gcc_spin (r, zeta - dzeta, s2, sc, v1cupm, v1cdwm, v2cm)
           vrzcup = 0.5d0 * (v1cupp - v1cupm) / dzeta
           vrzcdw = 0.5d0 * (v1cdwp - v1cdwm) / dzeta
        else
           vrrcup = 0.d0
           vrrcdw = 0.d0
           vrscup = 0.d0
           vrscdw = 0.d0
           vssc = 0.d0
           vrzcup = 0.d0
           vrzcdw = 0.d0

        endif
        return
      end subroutine dgcxc_spin

end module funct


      subroutine tffswake(fbound,beg)
      use tfstk
      use ffs
      use ffs_pointer
      use ffs_fit
      use ffs_wake
      use tffitcode
      use iso_c_binding
      implicit none
      type (ffs_bound) ,intent(in):: fbound
      type (ffs_bound) ibound,ibound1
      integer*8 iwbufxy,iwbufxyl,iwl,iwt,iwsl,iwst
      integer*4 itp1,i,j,ii,iutp,iwp,iutp1,np,npf,idx,idy,
     $     nlw,ntw
      real*8 rgetgl1,utwiss1(ntwissfun,-nfam:nfam),sigz,
     $     wbuf(nfam1:nfam),wzl(nfam1:nfam),wzt(nfam1:nfam),dx,dy
      real*8 , pointer::wakel(:,:),waket(:,:),wbufxy(:,:),wbufxyl(:,:)
      logical*4 ,intent(in):: beg
      sigz=rgetgl1('SIGZ')
      ibound1%fb=0.d0
      ibound1%fe=0.d0
      ibound=fbound
      itp1=itwissp(fbound%lb)
      if(.not. beg)then
        do j=nfam1,nfam
          if(uini(mfitbx,j) .le. 0.d0)then
            utwiss(:,j,itp1)=twiss(fbound%lb,0,:)
          else
            utwiss(:,j,itp1)=uini(:,j)
          endif
          utwiss(mfitdx:mfitddp,j,itp1)=
     $         twiss(fbound%lb,0,mfitdx:mfitddp)+uini(mfitdx:mfitddp,j)
        enddo
      endif
      iwsl=0
      iwst=0
      np=nfam-nfam1+1
      iwbufxy=ktaloc(np**2)
      iwbufxyl=ktaloc(np**2)
      call c_f_pointer(c_loc(rlist(iwbufxy)),wbufxy,[np,np])
      call c_f_pointer(c_loc(rlist(iwbufxyl)),wbufxyl,[np,np])
      do iwp=1,nwakep+1
        if(iwp .eq. nwakep+1)then
          ibound%le=fbound%le
          ibound%fe=fbound%fe
        else
          ibound%le=iwakeelm(iwp)
          if(ibound%le .gt. fbound%le)then
            cycle
          endif
          if(ibound%le .eq. fbound%le)then
            ibound%fe=fbound%fe
          else
            ibound%fe=0.d0
          endif
        endif
        if(ibound%le .lt. ibound%lb)then
          cycle
        elseif(ibound%le .gt. ibound%lb .or.
     $         ibound%le .eq. ibound%lb .and. ibound%fe .ne. 0.d0)then
          do i=nfam1,nfam
            ii=min(1,abs(i))
            twiss(ibound%lb,ii,:)=utwiss(:,i,itp1)
            call qcell1(ibound,ii,optstat(i),i .ne. 0,.true.,0)
            call tffssetutwiss(i,nlat,ibound,beg,
     $           ibound%lb .eq. fbound%lb,ibound%le .eq. fbound%le)
          enddo
        elseif(ibound%lb .eq. fbound%le)then
          npf=np*ntwissfun
          if(idtypec(nlat-1) .eq. icMARK)then
            iutp=itwissp(nlat-1)
            utwiss(:,nfam1:nfam,iutp)=utwiss(:,nfam1:nfam,itp1)
c            call tmov(utwiss(1,nfam1,itp1),
c     $           utwiss(1,nfam1,iutp),npf)
          endif
          if(ibound%lb .lt. nlat)then
            iutp=itwissp(nlat)
            utwiss(:,nfam1:nfam,iutp)=utwiss(:,nfam1:nfam,itp1)
c            call tmov(utwiss(1,nfam1,itp1),
c     $           utwiss(1,nfam1,iutp),npf)
          endif
          return
        endif
        if(iwp .le. nwakep)then
          iutp=itwissp(ibound%le)
          idx=kytbl(kwDX,idtypec(ibound%le))
          if(idx .ne. 0)then
            dx=rlist(latt(ibound%le)+idx)
          else
            dx=0.d0
          endif
          idy=kytbl(kwDY,idtypec(ibound%le))
          if(idy .ne. 0)then
            dy=rlist(latt(ibound%le)+idy)
          else
            dy=0.d0
          endif
          iwl=abs(kwaketbl(1,iwp))
          iwt=abs(kwaketbl(2,iwp))
          nlw=(ilist(1,iwl-1)-1)/2
          ntw=(ilist(1,iwt-1)-1)/2
          call c_f_pointer(c_loc(rlist(iwl)),wakel,[2,nlw])
          call c_f_pointer(c_loc(rlist(iwt)),waket,[2,ntw])
          call tffswakekick(utwiss(1:ntwissfun,-nfam,iutp),utwiss1,
     $         iwl,iwt,wakel,waket,nlw,ntw,
     $         sigz,2.d0*gammab(ibound%le)*amass,nfam,nfam1,
     $         dx,dy,wbuf,wbufxy,wbufxyl,
     $         wzl,wzt,iwsl,iwst)
          ibound1%lb=ibound%le
          ibound1%le=ibound%le+1
          do i=nfam1,nfam
            ii=min(1,abs(i))
            twiss(ibound1%lb,ii,:)=utwiss1(:,i)
            call qcell1(ibound1,ii,optstat(i),i .ne. 0,.true.,0)
            utwiss1(:,i)=twiss(ibound1%le,ii,:)
          enddo
          iutp1=itwissp(ibound1%le)
          call tffswakekick(utwiss1,
     $         utwiss(1:ntwissfun,-nfam,iutp1),
     $         iwl,iwt,wakel,waket,nlw,ntw,
     $         sigz,2.d0*gammab(ibound%le+1)*amass,nfam,nfam1,
     $         dx,dy,wbuf,wbufxy,wbufxyl,
     $         wzl,wzt,iwsl,iwst)
          ibound%lb=ibound%le+1
          ibound%fb=0.d0
          itp1=itwissp(ibound%lb)
        endif
      enddo
      call tfree(iwbufxy)
      call tfree(iwbufxyl)
      return
      end

      subroutine tffswakekick(ut0,ut1,
     $     iwl,iwt,wakel,waket,nlw,ntw,
     $     sigz,p,
     $     nfam,nfam1,dx,dy,
     $     wbuf,wbufxy,wbufxyl,wzl,wzt,iwsl,iwst)
      use tfstk
      use ffs
      use tffitcode
      implicit none
      integer*8,intent(in)::   iwl,iwt
      integer*8,intent(inout):: iwsl,iwst
      integer*4 ,intent(in):: nfam,nfam1,nlw,ntw
      integer*4 i,j,i1,i2,ic,np
      real*8 ,intent(in):: ut0(ntwissfun,-nfam:nfam),
     $     wakel(2,nlw),waket(2,ntw),sigz,p,dx,dy
      real*8 ,intent(out):: ut1(ntwissfun,-nfam:nfam)
      real*8 ,intent(inout):: wbuf(nfam1:nfam),
     $     wbufxy(nfam1:nfam,nfam1:nfam),
     $     wbufxyl(nfam1:nfam,nfam1:nfam),
     $     wzl(nfam1:nfam),wzt(nfam1:nfam)
      real*8 wbufxl(nfam1:nfam),wbufyl(nfam1:nfam),
     $     wbufx(nfam1:nfam),wbufy(nfam1:nfam),
     $     zi,dz,w,sigg,a,dz0,xi,yi,cp0,dsig,ddz0,
     $     z1,z2,d
      logical*4 re
      real*8 , parameter :: fact=.398942280401433d0
      np=nfam-nfam1+1
      ut1(:,nfam1:nfam)=ut0(:,nfam1:nfam)
c      call tmov(ut0(1,nfam1),ut1(1,nfam1),ntwissfun*np)
      cp0=abs(charge*e*pbunch/np/p)
      sigg=max(1.d-5,sigz/np/anbunch)
      dsig=.1d0*sigg
      if(iwl .ne. 0 .and. lwake)then
        if(iwl .eq. iwsl)then
          ddz0=ut0(mfitdz,nfam1)-wzl(nfam1)
          re=.false.
          do i=nfam1+1,nfam
            if(abs(ut0(mfitdz,i)-wzl(i)-ddz0) .gt. dsig)then
              re=.true.
              exit
            endif
          enddo
        else
          re=.true.
        endif
        if(re)then
          iwsl=iwl
          z1=-1d100
          i1=1
          z2=1d100
          i2=nlw
          call tclr(wbuf,np)
          do i=nfam1,nfam
            zi=ut0(mfitdz,i)
            wzl(i)=zi
            do j=nfam1,nfam
              dz=zi-ut0(mfitdz,j)
              if(dz .ge. -sigg)then
                w=min(1.d0,(dz+sigg)/sigg*.5d0)
                if(dz .le. wakel(1,1))then
                  wbuf(j)=wbuf(j)+w*wakel(2,1)
                elseif(dz .lt. wakel(1,nlw))then
                  if(dz .ge. z2)then
                    i1=i2
                    i2=nlw
                  elseif(dz .lt. z1)then
                    i2=i1
                    i1=1
                  endif
                  do while(i2 .gt. i1+1)
                    ic=i1+(i2-i1)/2
                    if(wakel(1,ic) .gt. dz)then
                      i2=ic
                    else
                      i1=ic
                    endif
                  enddo
                  z1=wakel(1,i1)
                  z2=wakel(1,i2)
                  a=(dz-z1)/(z2-z1)
                  wbuf(j)=wbuf(j)
     $                 +w*((1.d0-a)*wakel(2,i1)+a*wakel(2,i2))
                endif
              endif
            enddo
          enddo
        endif
        ut1(mfitddp,:)=ut0(mfitddp,:)-cp0*wbuf
      endif
      if(iwt .ne. 0 .and. twake)then
        re=.false.
        if(iwt .eq. iwst)then
          ddz0=ut0(mfitdz,nfam1)-wzt(nfam1)
          re=.true.
          do i=nfam1+1,nfam
            if(abs(ut0(mfitdz,i)-wzt(i)-ddz0) .gt. dsig)then
              re=.false.
              exit
            endif
          enddo
        endif
        wbufx=0.d0
        wbufy=0.d0
        wbufxl=0.d0
        wbufyl=0.d0
        if(re)then
          do i=nfam1,nfam
            xi=ut0(mfitdx,i)-dx
            yi=ut0(mfitdy,i)-dy
            wbufx=wbufx+xi*wbufxy(i,:)
            wbufy=wbufy+yi*wbufxy(i,:)
            wbufxl=wbufxl-xi*wbufxyl(i,:)
            wbufyl=wbufyl-yi*wbufxyl(i,:)
          enddo
        else
          iwst=iwt
          i1=1
          z1=-1d100
          i2=ntw
          z2=1d100
          dz0=sigg*fact
          do i=nfam1,nfam
            zi=ut0(mfitdz,i)
            xi=ut0(mfitdx,i)-dx
            yi=ut0(mfitdy,i)-dy
            wzt(i)=zi
            do j=nfam1,nfam
              dz=zi-ut0(mfitdz,j)+dz0
              if(dz .gt. waket(1,1) .and. dz .lt. waket(1,ntw))then
                if(dz .ge. z2)then
                  i1=i2
                  i2=ntw
                elseif(dz .lt. z1)then
                  i2=i1
                  i1=1
                endif
                do while(i2 .gt. i1+1)
                  ic=i1+(i2-i1)/2
                  if(waket(1,ic) .gt. dz)then
                    i2=ic
                  else
                    i1=ic
                  endif
                enddo
                z1=waket(1,i1)
                z2=waket(1,i2)
                a=(dz-z1)/(z2-z1)
                d=(waket(2,i2)-waket(2,i1))/(z2-z1)
                w=waket(2,i1)+d*(dz-z1)
                wbufx(j)=wbufx(j)+xi*w
                wbufy(j)=wbufy(j)+yi*w
                wbufxl(j)=wbufxl(j)-xi*d
                wbufyl(j)=wbufyl(j)-yi*d
                wbufxy(i,j)=w
                wbufxyl(i,j)=d
              else
                wbufxy(i,j)=0.d0
                wbufxyl(i,j)=0.d0
              endif
            enddo
          enddo
        endif
        do i=nfam1,nfam
          ut1(mfitdpx,i)=ut0(mfitdpx,i)+cp0*wbufx(i)
          ut1(mfitdpy,i)=ut0(mfitdpy,i)+cp0*wbufy(i)
          ut1(mfitddp,i)=ut1(mfitddp,i)+
     $         cp0*(wbufxl(i)*(ut0(mfitdx,i)-dx)
     $         +wbufyl(i)*(ut0(mfitdy,i)-dy))
        enddo
      endif
      return
      end

      subroutine tffssetupwake(lfno,irtc)
      use tfstk
      use ffs
      use ffs_pointer
      use tffitcode
      use ffs_wake
      use eeval
      use iso_c_binding
      implicit none
      type (sad_dlist) ,pointer :: kwll,kwtl
      type (sad_descriptor) kx
      type (ffs_bound) fbound
      integer*8 kal,kalj,ktfmalocp,kat,katj
      integer*4 irtc,isp0,isp1,lfno,n,m,lenw,l,itfdownlevel,isp2,
     $     i,j,k
      character*(MAXPNAME+10) name
      integer*8 ifname,ifwfunl,ifwfunt
      save ifname,ifwfunl,ifwfunt
      data ifwfunl,ifwfunt/0,0/
      if(ifwfunl .eq. 0)then
        ifwfunl=ktadaloc(0,2)
        ifwfunt=ktadaloc(0,2)
        dlist(ifwfunl)=dtfcopy1(kxsymbolz('WakeFunction',12))
        klist(ifwfunt)=ktfcopy1(klist(ifwfunl))
        dlist(ifwfunl+1)=kxsymbolz('Longitudinal',12)
        dlist(ifwfunt+1)=kxsymbolz('Transverse',10)
        ifname=ktsalocb(1,name,len(name))
        klist(ifwfunl+2)=ktfstring+ifname
        klist(ifwfunt+2)=ktfstring+ifname
      endif
      call tffsbound(fbound)
      isp0=isp
      do i=fbound%lb,fbound%le-1
        isp1=isp+2
        kal=0
        kat=0
        call elname(i,name)
        ilist(1,ifname)=lenw(name)
        call tfpadstr(name,ifname+1,ilist(1,ifname))
        levele=levele+1
        call descr_sad(dfromk(ktflist+ifwfunl),kwll)
        kx=tfleval(kwll,.true.,irtc)
        if(irtc .ne. 0)then
          if(ierrorprint .ne. 0)then
            call tfaddmessage('WakeFunction Longitudinal',0,lfno)
          endif
          go to 9000
        endif
        if(ktflistq(kx))then
          kal=ktfmalocp(kx,n,m,.false.,.true.,.false.,.false.,irtc)
          if(irtc .eq. 0 .and. m .eq. 2)then
c            call tfdebugprint(kx,'setupwake-l-kx',1)
            isp=isp1
            LOOP_J_1: do j=isp-3,isp0+1,-2
              kalj=abs(ktastk(j))
              if(kalj .ne. 0)then
                if(ilist(1,kal-1) .eq. ilist(1,kalj-1))then
                  do k=0,ilist(1,kal-1)-2
                    if(rlist(kal+k) .ne. rlist(kalj+k))then
                      cycle LOOP_J_1
                    endif
                  enddo
                  call tfree(kal)
                  kal=-kalj
                  go to 20
                endif
              endif
            enddo LOOP_J_1
          else
            kal=0
          endif
        endif
 20     isp2=isp
        call descr_sad(dfromk(ktflist+ifwfunt),kwtl)
        kx=tfleval(kwtl,.true.,irtc)
        isp=isp2
        if(irtc .ne. 0)then
          if(ierrorprint .ne. 0)then
            call tfaddmessage('WakeFunction Transverse',0,lfno)
          endif
          go to 9000
        endif
        if(ktflistq(kx))then
          kat=ktfmalocp(kx,n,m,.false.,.true.,.false.,.false.,irtc)
          if(irtc .eq. 0 .and. m .eq. 2)then
c            call tfdebugprint(kx,'setupwake-t-kx',1)
            isp=isp1
            LOOP_J_2: do j=isp-2,isp0+2,-2
              katj=abs(ktastk(j))
              if(katj .ne. 0)then
                if(ilist(1,kat-1) .eq. ilist(1,katj-1))then
                  do k=0,ilist(1,kat-1)-2
                    if(rlist(kat+k) .ne. rlist(katj+k))then
                      cycle LOOP_J_2
                    endif
                  enddo
                  call tfree(kat)
                  kat=-katj
                  go to 120
                endif
              endif
            enddo LOOP_J_2
          else
            kat=0
          endif
        endif
 120    l=itfdownlevel()
        ktastk(isp1-1)=kal
        ktastk(isp1  )=kat
        ivstk2(1,isp1)=i
      enddo
      nwakep=(isp-isp0)/2
      if(nwakep .gt. 0)then
        kwakep=ktaloc(nwakep*2)
        kwakeelm=ktaloc(nwakep)
        call tmov(ktastk(isp0+1),klist(kwakep),nwakep*2)
        do i=1,nwakep
          ilist(i,kwakeelm)=ivstk2(1,isp0+i*2)
        enddo
      endif
      call c_f_pointer(c_loc(ilist(1,kwakeelm)),iwakeelm,[nwakep])
      call c_f_pointer(c_loc(klist(kwakep)),kwaketbl,[2,nwakep])
      irtc=0
      return
 9000 l=itfdownlevel()
      do i=isp0+1,isp
        if(ktastk(i) .gt. 0)then
          call tfree(ktastk(i))
        endif
      enddo
      isp=isp0
      return
      end

      subroutine tffsclearwake
      use tfstk
      use ffs_wake
      implicit none
      integer*8 i
      if(nwakep .gt. 0)then
        do i=kwakep,kwakep+2*nwakep-1
          if(klist(i) .gt. 0)then
            call tfree(klist(i))
          endif
        enddo
        call tfree(kwakep)
        call tfree(kwakeelm)
      endif
      return
      end