! @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ !
! @@                                                                @@ !
! @@       PROGRAM  ASCOT 2014.440 (ver.4.53)                       @@ !
! @@     "Abinitio Simulation Code for Quantum Transport"           @@ !
! @@                                                                @@ !
! @@                                                                @@ !
! @@  AUTHOR(S): Naoki WATANABE, Nobutaka NISHIKAWA (Mizuho I.R.)   @@ !
! @@             Hisashi KONDO (Univ. Tokyo)                        @@ !
! @@                                                09/May/2014     @@ !
! @@                                                                @@ !
! @@  Contact address: Phase System Consortium                      @@ !
! @@                                                                @@ !
! @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ !

module ac_misc_module
  implicit none

  real(8), parameter :: M_PI       = 3.141592653589793238462d0 
  real(8), parameter :: SQRT_PI    = 1.77245385090551602729d0 
  real(8), parameter :: M_2_SQRTPI = 1.12837916709551257390d0 
  real(8), parameter :: M_1_PI     = 0.31830988618379067154d0 
  real(8), parameter :: M_SQRT1_2  = 0.70710678118654752440d0 
  real(8), parameter :: M_LN2      = 0.69314718055994530942d0 
  real(8), parameter :: M_CBRT2    = 1.259921049894873191d0 
  real(8), parameter :: M_CBRT3    = 1.442249570307408302d0 
  real(8), parameter :: M_CBRTPI   = 1.464591887561523142d0 

  real(8), parameter :: RY_TO_AU = 1.d0/2.d0 
  real(8), parameter :: AU_TO_RY = 1.d0/RY_TO_AU 
  real(8), parameter :: AU_TO_AA = 0.529177249d0 
  real(8), parameter :: AA_TO_AU = 1.d0/AU_TO_AA 
  real(8), parameter :: AU_TO_EV = 27.211396212 
  real(8), parameter :: EV_TO_AU = 1.d0/AU_TO_EV 
  real(8), parameter :: KELVIN_TO_AU = 3.166829936860255d-06 
  real(8), parameter :: AU_TO_KELVIN = 1.d0/KELVIN_TO_AU 

  complex(8), parameter :: C1 = (1.0d0, 0.0d0 )
  complex(8), parameter :: C0 = (0.0d0, 0.0d0 )

  real(8), private, parameter :: C00 = 0.282094791773878d0 
  real(8), private, parameter :: C10 = 0.488602511902920d0 
  real(8), private, parameter :: C11 = 0.488602511902920d0 
  real(8), private, parameter :: C20 = 0.315391565252520d0 
  real(8), private, parameter :: C21 = 1.092548430592079d0 
  real(8), private, parameter :: C22 = 0.546274215296040d0 
  real(8), private, parameter :: C30 = 0.373176332590115d0 
  real(8), private, parameter :: C31 = 0.457045799464466d0 
  real(8), private, parameter :: C32 = 1.445305721320277d0 
  real(8), private, parameter :: C33 = 0.590043589926644d0 
  real(8), private, parameter :: C40 = 0.105785546915204d0 
  real(8), private, parameter :: C41 = 0.669046543557289d0 
  real(8), private, parameter :: C42 = 0.473087347878780d0 
  real(8), private, parameter :: C43 = 1.770130769779931d0 
  real(8), private, parameter :: C44 = 0.625835735449176d0 
  real(8), private, parameter :: C50 = 0.116950322453424d0 
  real(8), private, parameter :: C51 = 0.452946651195697d0 
  real(8), private, parameter :: C52 = 2.396768392486662d0 
  real(8), private, parameter :: C53 = 0.489238299435250d0 
  real(8), private, parameter :: C54 = 2.075662314881042d0 
  real(8), private, parameter :: C55 = 0.656382056840170d0 
  real(8), private, parameter :: C60 = 0.063569202267628d0 
  real(8), private, parameter :: C61 = 0.582621362518731d0 
  real(8), private, parameter :: C62 = 0.460602629757462d0 
  real(8), private, parameter :: C63 = 0.921205259514924d0 
  real(8), private, parameter :: C64 = 0.504564900728724d0 
  real(8), private, parameter :: C65 = 2.366619162231752d0 
  real(8), private, parameter :: C66 = 0.683184105191914d0 

  integer, private, parameter :: N = 64  
  real(8), pointer ::  vshx(:)  
  real(8), pointer ::  vshw(:)  


  type Atom_type
     character(5)   :: name   
     integer        :: number 
     real(8)  :: Ro(3)  
     real(8)  :: Rc     
     real(8)  :: Q      
     real(8)  :: polarization 
     real(8)  :: force(3)  
     logical  :: optimize     
     real(8) :: opt_position(3)  
     real(8) :: opt_direction(3) 
     real(8), pointer :: force_past(:,:) 
  end type Atom_type

  type Spline_type
     integer :: N 
     real(8), pointer ::  vx(:) 
     real(8), pointer ::  vf(:) 
     real(8), pointer ::  vb(:) 
     real(8), pointer ::  vc(:) 
     real(8), pointer ::  vd(:) 
  end type Spline_type

  type RadialFunc_type
     integer          ::  l    
     real(8)          ::  Rc   
     real(8), pointer :: vR(:) 
     type(Spline_type):: fR    
     real(8), pointer :: vK(:) 
     real(8)          ::  Q    
  end type RadialFunc_type

  type SphericalBessel_type
     integer          :: Nr     
     integer          :: Nk     
     real(8), pointer :: vrx(:) 
     real(8), pointer :: vrw(:) 
     real(8), pointer :: vkx(:) 
     real(8), pointer :: vkw(:) 
  end type SphericalBessel_type

  type Element_type
     character(5)     :: name 
     integer          :: atomic_number 

     type(RadialFunc_type) :: rhoval 
     type(RadialFunc_type) :: Vval   

     integer          :: npao 
     type(RadialFunc_type), pointer :: vpao(:) 

     type(RadialFunc_type) :: Vloc 

     logical          :: dirac 
     integer          :: nVnon 
     type(RadialFunc_type), pointer :: vVnon(:,:) 


     integer          :: npao2 
     type(RadialFunc_type), pointer :: vpao2(:) 
     type(RadialFunc_type), pointer :: vpao2bar(:) 

     integer          :: nVloc 
     type(RadialFunc_type), pointer :: vVloc(:) 

     logical          :: pcc 
     type(RadialFunc_type) :: rhopcc 

     character(10)    :: namexc_pao 
     character(10)    :: namexc_vps 
  end type Element_type

  type Option_type
     logical :: na      = .true.           
     logical :: cluster = .false.          
     logical :: pcc     = .false.          
     logical :: spin_polar = .false.          
     logical :: spin_orbit = .false.          
     integer :: nspin   = 0                
     logical :: nohar   = .false.          
     logical :: noexc   = .false.          
     logical :: indirect_overlap = .false. 
     logical :: mx      = .false.          
     logical :: projection = .false.      
     logical :: ascot_negf = .false.       
     logical :: optimize   = .false.       
     logical :: atom_move   = .false. 
     character(50) :: optimize_method = "cg" 

     character(50) :: fname_accel_c  = ""  
     character(50) :: fname_accel_r  = ""  
     character(50) :: fname_accel_l  = ""  
     character(50) :: fname_ascot_vd = ""  
     character(50) :: fname_ascot_in = ""  

     character(50) :: fname_rhoscf_in   = "" 
     character(50) :: fname_matrices_in = "" 

     character(10) :: saveat = "every" 
     character(50) :: field_format = ".cube" 
     character(50) :: fname_rhoscf   = "" 
     character(50) :: fname_rhopcc = "" 
     character(50) :: fname_rhoval = "" 
     character(50) :: fname_vext = "" 
     character(50) :: fname_vhar = "" 
     character(50) :: fname_vexc = "" 
     character(50) :: fname_vtot = "" 
     character(50) :: fname_matrices = "" 

     character(50) :: file_ac_tempout
  end type Option_type

  type Cell_type
     real(8) :: La(3)    
     real(8) :: Lb(3)    
     real(8) :: Lc(3)    
     real(8) :: Lo(3)    
     integer        :: Na    
     integer        :: Nb    
     integer        :: Nc    
     real(8) :: dLa(3)   
     real(8) :: dLb(3)   
     real(8) :: dLc(3)   
     real(8) :: dKa(3)   
     real(8) :: dKb(3)   
     real(8) :: dKc(3)   
     real(8)        :: dKa1  
     real(8)        :: dKb1  
     real(8)        :: dKc1  
     real(8)        :: V     
     real(8)        :: dV    
     integer        :: nL    

     real(8), pointer :: vL(:,:) 
     integer, pointer :: vLna(:) 
     integer, pointer :: vLnb(:) 
     integer, pointer :: vLnc(:) 
  end type Cell_type

  type SCF_type
     character(10) :: exc_type = 'PZ81'     
     real(8) :: Te = 300.d0 * KELVIN_TO_AU  
     real(8) :: Ecutoff = 150.d0 * RY_TO_AU 
     integer :: Nka = 1 
     integer :: Nkb = 1 
     integer :: Nkc = 1 
     integer :: nK = 1                      
     real(8), pointer :: vK(:,:)       
     integer, pointer :: i_vK(:)
     complex(8), pointer :: vbloch(:,:)     

     character(16) :: mix_type = 'Simple'   
     character(16) :: mix_target = 'density_matrix'   
     real(8) :: mix_weight  =  0.3d0 
     real(8) :: mix_weight_s  =  -0.3d0
     integer :: mix_history = 4      
     integer :: mix_start   = 4      

     character(16) :: cri_type = 'fermi'    
     real(8) :: criterion = 1.e-6           
     integer ::  iter_max =  100 

     real(8) :: force_criterion = 1.0e-3    
     integer :: opt_iter_max =  0 
  end type SCF_type

  type Integral1D_type
     integer       ::  Nr = 900        
     integer       ::  Nk = 900        
     real(8) :: Ecutoff = 2500.d0 * RY_TO_AU 
  end type Integral1D_type

  type Kpath_type
     real(8) :: ks(3)   
     real(8) :: ke(3)   
     integer :: mesh 
  end type Kpath_type

  type Band_type
     character(64)  :: fname = ""                    
     character(64)  :: fname1 = ""                    
     real(8) :: La(3) = (/0,0,0/)          
     real(8) :: Lb(3) = (/0,0,0/)          
     real(8) :: Lc(3) = (/0,0,0/)          
     real(8) :: dKa(3)                           
     real(8) :: dKb(3)                           
     real(8) :: dKc(3)                           

     integer        :: nKpath                        
     type(Kpath_type), pointer :: vKpath(:)               
     integer        :: nK = 1                        
     real(8), pointer :: vK(:,:)                
     integer        :: num_band = 0                  
  end type Band_type

  type DOS_type
     character(50) :: fname = ""           
     real(8) :: Emin = -10.d0 * EV_TO_AU   
     real(8) :: Emax = +10.d0 * EV_TO_AU   
     real(8) :: GB = 0.1 * EV_TO_AU
     real(8) :: dE                         
     integer :: Ne = 101                   
     integer :: Nka = 0                    
     integer :: Nkb = 0                    
     integer :: Nkc = 0                    
     integer :: nK = 0                     
     character(16) :: method = 'gaussian' 
  end type DOS_type

  type MO_type
     character(50)  :: fbase = ""                    
     character(16)  :: method = 'ho_lumo'            
     integer        :: band_min=0                    
     integer        :: band_max=0                    
     real(8) :: La(3) = (/0,0,0/)          
     real(8) :: Lb(3) = (/0,0,0/)          
     real(8) :: Lc(3) = (/0,0,0/)          
     real(8) :: dKa(3)                           
     real(8) :: dKb(3)                           
     real(8) :: dKc(3)                           
     integer        :: nK = 0                        
     real(8), pointer :: vK(:,:)                 
  end type MO_type

  type Data_type
     character(50) :: path_pao = "." 
     character(50) :: path_vps = "." 
     character(50) :: element_type  = "ciao" 

     real(8) :: Ne_extra 
     real(8) :: Ne 
     real(8) :: g 
     integer                :: nelem    
     type(Element_type), pointer :: velem(:) 
     integer                :: natom    
     type(Atom_type), pointer    :: vatom(:) 

     integer       :: natom_left  = 0   
     integer       :: natom_right = 0   
     character(50), pointer, dimension(:,:) :: velem_file 

     integer          :: npao     
     integer, pointer :: vnpao(:) 
     integer, pointer :: vipao(:) 
     integer          :: nvps     
  end type Data_type

  type Param_type
     character(20)         :: name  = "" 
     type(Option_type)     :: Option     
     type(Cell_type)       :: Cell       
     type(SCF_type)        :: SCF        
     type(Integral1D_type) :: Integral1D 
     type(Band_type)       :: Band       
     type(DOS_type)        :: DOS        
     type(MO_type)         :: MO         
     type(Data_type)       :: Data       
  end type Param_type

  type Screening_type
     real(8) :: alpha 
     real(8), pointer :: PhiK(:,:,:) 
  end type Screening_type

  type Ewald_type
     real(8) :: alpha 
  end type Ewald_type

  type PAO_type
     real(8) :: Ro(3) 
     integer          :: m  
     integer          :: l  
     real(8)          :: Rc 
     type(RadialFunc_type), pointer :: RF 
     integer          :: range(6) 
     real(8), pointer :: wave(:,:,:) 
     real(8), pointer :: waveV(:,:,:) 
     real(8), pointer :: gwave(:,:,:,:) 
     real(8), pointer :: gwaveV(:,:,:,:) 
  end type PAO_type

  type Base_type
     integer            :: npao     
     type(PAO_type), pointer :: vpao(:)  
     integer, pointer   :: vnpao(:) 
     integer, pointer   :: vipao(:) 
  end type Base_type

  type PPcharge_type
     real(8) :: Ro(3) 
     real(8) :: Rc 
     type(RadialFunc_type), pointer :: RF 
  end type PPcharge_type

  type DensityPast_type
     real(8), pointer :: rho(:,:,:,:)    
     real(8), pointer :: drho(:,:,:,:)   
     complex(8), pointer :: rhoLS(:,:,:,:)    
     complex(8), pointer :: drhoLS(:,:,:,:)   
  end type DensityPast_type

  type Density_type
     real(8), pointer :: rho(:,:,:,:)    
     complex(8), pointer :: rhoLS(:,:,:,:)    
     real(8), pointer :: rhoval(:,:,:) 
     real(8), pointer :: rhopcc(:,:,:) 
     type(DensityPast_type), pointer :: vpast(:) 
  end type Density_type

  type PPloc_type
     real(8)        :: Ro(3) 
     real(8)        ::  Q 
     real(8)        :: Rc 
     type(RadialFunc_type), pointer ::  RF 
  end type PPloc_type

  type PPnon_type
     real(8) :: Ro(3) 
     integer        :: m  
     real(8)        :: E  
     integer        :: l  
     real(8)        :: Rc 
     type(RadialFunc_type), pointer :: RF 
  end type PPnon_type

  type Potential_type
     integer :: nVpsnon 
     type(PPnon_type), pointer :: vVpsnon(:,:) 
     integer, pointer :: vnVpsnon(:) 
     integer, pointer :: viVpsnon(:) 

     integer :: nVpsloc 
     integer, pointer :: vnVpsloc(:) 
     integer, pointer :: viVpsloc(:) 
     type(PPnon_type), pointer :: vVpsloc(:) 

     real(8), pointer :: Vext(:,:,:) 
     real(8), pointer :: dVhar(:,:,:) 
     real(8), pointer :: Vexc(:,:,:,:) 
     real(8), pointer :: Vtot(:,:,:,:) 
  end type Potential_type

  type Energy_type
     real(8) :: Ef 
     real(8) :: Etot 
  end type Energy_type

  type DensityMatrixPast_type
     real(8), pointer :: CDM(:,:,:)    
     real(8), pointer :: dCDM(:,:,:)   
     complex(8), pointer :: CDMLS(:,:,:)    
     complex(8), pointer :: dCDMLS(:,:,:)   
  end type DensityMatrixPast_type

  type AtomMatrix_type
     real(8), pointer :: S(:,:)     
     real(8), pointer :: H0(:,:,:)  
     real(8), pointer :: H (:,:,:)  
     complex(8), pointer :: H0LS(:,:,:)  
     complex(8), pointer :: HLS (:,:,:)  
     real(8), pointer :: CDM(:,:,:) 
     real(8), pointer :: EDM(:,:)   
     complex(8), pointer :: CDMLS(:,:,:) 
     real(8), pointer :: EDMLS(:,:)   
     type(DensityMatrixPast_type), pointer :: vpast(:) 
  end type AtomMatrix_type

  type AtomMatrix_Ptr_type
     type(AtomMatrix_type), pointer :: Ptr 
  end type AtomMatrix_Ptr_type

  type BandMatrix_type
     complex(8), pointer :: S(:,:)   
     complex(8), pointer :: H(:,:,:) 
     real(8),    pointer :: E(:,:)   
     real(8),    pointer :: F(:,:)   
  end type BandMatrix_type

  type Hamiltonian_type
     type(AtomMatrix_Ptr_type), pointer :: vAtomMatrix(:,:,:) 
     type(BandMatrix_type), pointer     :: vBandMatrix(:)     
  end type Hamiltonian_type

  type(Param_type), save, public     :: Param 
  type(Base_type), public            :: Base 
  type(Hamiltonian_type), public     :: Hamiltonian 
  type(Density_type), public         :: Density 
  type(Potential_type), public       :: Potential 
  type(Energy_type), public          :: Energy 
  type(Ewald_type), public           :: Ewald 
  type(SphericalBessel_type), public :: SphericalBessel 
  type(Screening_type), public       :: Screening 


  type SpinMatrix_type
     complex(8) :: element(2,2)
  end type SpinMatrix_type

contains

  function uncomment( line ) result(flag)
    character(len=*), intent(inout) :: line
    logical :: flag

    integer :: i
    integer :: len

    flag = .false.
    len = len_trim(line)

    if( len == 0 ) then
       flag = .true.
       return
    end if

    do i=1, len
       if( line(i:i) == '!' .or. line(i:i) == '#' .or. line(i:i) == '$' ) then
          line(i:len) = ' '
          if( i==1 ) then
             flag = .true.
          end if
          exit
       end if
       if( line(i:i) == '=' ) then
          line(i:i) = ' '
       end if
    end do

    if( len_trim(line) == 0 ) then
       flag = .true.
    end if

    return
  end function uncomment


  function TO_AU( unit ) result(c)
    character(len=*), intent(in) :: unit
    real(8) :: c

    c = 1.d0
    select case(unit)
    case("au", "AU", "a.u.", "A.U.")
       c = 1.d0
    case("hartree", "Hartree", "HARTREE")
       c = 1.d0
    case("hartree/bohr", "Hartree/Bohr", "HARTREE/BOHR")
       c = 1.d0
    case("eV", "ev", "EV")
       c = EV_TO_AU
    case("ry", "Ry", "RY", "rydberg", "Rydberg")
       c = RY_TO_AU
    case("K","kelvin","Kelvin")
       c = KELVIN_TO_AU
    case("ang","Ang","angstrom","Angstrom")
       c = AA_TO_AU
    case default
       open(unit=16,file=Param%Option%file_ac_tempout,position='append')
       write(16,'(a,a)') '      ++++++ Error: unknown unit ', trim(unit)
       close(16)
       stop
    end select

    return
  end function TO_AU


  function AU_TO( unit ) result(c)
    character(len=*), intent(in) :: unit
    real(8) :: c

    c = 1.d0
    select case(unit)
    case("au", "AU", "a.u.", "A.U.")
       c = 1.d0
    case("hartree", "Hartree", "HARTREE")
       c = 1.d0
    case("hartree/bohr", "Hartree/Bohr", "HARTREE/BOHR")
       c = 1.d0
    case("eV", "ev", "EV")
       c = AU_TO_EV
    case("ry", "Ry", "RY", "rydberg", "Rydberg")
       c = AU_TO_RY
    case("K","kelvin","Kelvin")
       c = AU_TO_KELVIN
    case("ang","Ang","angstrom","Angstrom")
       c = AU_TO_AA
    case default
       open(unit=16,file=Param%Option%file_ac_tempout,position='append')
       write(16,'(a,a)') '      ++++++ Error: unknown unit ', trim(unit)
       close(16)
       stop
    end select

    return
  end function AU_TO



  function Position__iszero( r ) result(flag)
    real(8), intent(in) :: r(3)
    logical :: flag

    if( r(1) == 0.0d0 .and. r(2) == 0.0d0 .and. r(3) == 0.0d0 ) then
       flag = .true.
    else
       flag = .false.
    end if

    return
  end function Position__iszero

  function Position__iprod( r1, r2 ) result(d)
    real(8), intent(in) :: r1(3), r2(3)
    real(8) :: d

    d = r1(1)*r2(1) + r1(2)*r2(2) + r1(3)*r2(3)

    return
  end function Position__iprod

  function Position__oprod( r1, r2 ) result(r)
    real(8), intent(in) :: r1(3), r2(3)
    real(8) :: r(3)

    r(1) = r1(2)*r2(3) - r1(3)*r2(2)
    r(2) = r1(3)*r2(1) - r1(1)*r2(3)
    r(3) = r1(1)*r2(2) - r1(2)*r2(1)

    return
  end function Position__oprod

  function Position__length( r ) result(d)
    real(8), intent(in) :: r(3)
    real(8) :: d

    d = sqrt(r(1)*r(1) + r(2)*r(2) + r(3)*r(3)) 

    return
  end function Position__length

  function Position__length2( r ) result(d)
    real(8), intent(in) :: r(3)
    real(8) :: d

    d = r(1)*r(1) + r(2)*r(2) + r(3)*r(3)

    return
  end function Position__length2

  function modp( n, m ) result(r)
    implicit none
    integer, intent(in) :: n, m
    integer :: r

    if( n>=1 ) then
       r=mod(n-1,m)+1
       return
    end if

    r=mod(n-1,m)
    r=mod(r+m,m)+1

    return
  end function modp

  function polar( theta ) result(c)
    implicit none
    real(8), intent(in) :: theta
    complex(8) :: c

    c = Cmplx( cos(theta), sin(theta) )

    return
  end function polar

  function cbrt(a) result(b)
    implicit none
    real(8), intent(in) :: a
    real(8) :: b

    if( a<0.d0 ) then
       b = (-1.0d0)*((-1.0d0)*a)**(1.d0/3.d0)
    else
       b = a**(1.d0/3.d0)
    end if

    return
  end function cbrt

  function log1p(a) result(b)
    implicit none
    real(8), intent(in) :: a
    real(8) :: b

    b = log(1.d0+a)

    return
  end function log1p

  function expm1(a) result(b)
    implicit none
    real(8), intent(in) :: a
    real(8) :: b

    b = exp(a) - 1.d0

    return
  end function expm1

  function Spline__evaluate( spline, x ) result(f)
    implicit none
    type(Spline_type), intent(in)  :: spline
    real(8), intent(in) :: x

    real(8) :: f
    real(8) :: dx
    integer :: i, ia, ib, ic

    if( Param%Option%mx ) then
       f = Spline__evaluateMX(spline,x)
       return
    end if

    if( x < spline%vx(1) ) then
       i=1
    elseif( x > spline%vx(spline%N) ) then
       i=spline%N
    else
       ia=1
       ib=spline%N
       do while( ia+1 < ib )
          ic = (ia+ib)/2
          if( x<spline%vx(ic) ) then
             ib=ic
          else
             ia=ic
          end if
       end do
       i=ia
    end if

    dx = x - spline%vx(i)

    f = spline%vf(i) + dx*(spline%vb(i) + dx*(spline%vc(i) + dx*spline%vd(i)))

    return
  end function Spline__evaluate

  function Spline__derivative( spline, x ) result(df)
    implicit none
    type(Spline_type), intent(in)  :: spline
    real(8), intent(in) :: x

    real(8) :: df

    integer       :: i, ia, ib, ic
    real(8) :: dx

    if( Param%Option%mx ) then
       df = Spline__derivativeMX(spline,x)
       return
    end if

    if( x < spline%vx(1) ) then
       i=1
    elseif( x > spline%vx(spline%N) ) then
       i=spline%N
    else
       ia=1
       ib=spline%N
       do while( ia+1 < ib )
          ic = (ia+ib)/2
          if( x<spline%vx(ic) ) then
             ib=ic
          else
             ia=ic
          end if
       end do
       i=ia
    end if

    dx = x - spline%vx(i)

    df = spline%vb(i) + 2*dx*spline%vc(i) + 3*dx*dx*spline%vd(i)

    return
  end function Spline__derivative

  function Spline__size( spline ) result(N)
    implicit none
    type(Spline_type), intent(in) :: spline

    integer      :: N

    N = spline%N

    return
  end function Spline__size

  function Spline__x(spline, i) result(x)
    implicit none
    type(Spline_type), intent(in)  :: spline
    integer, intent(in)       :: i

    real(8) :: x

    x = spline%vx(i)

    return
  end function Spline__x

  function Spline__xfront(spline) result(x)
    implicit none
    type(Spline_type), intent(in) :: spline
    real(8) :: x

    x = spline%vx(1)

    return
  end function Spline__xfront

  function Spline__xback(spline) result(x)
    implicit none
    type(Spline_type), intent(in)  :: spline
    real(8) :: x

    x = spline%vx(spline%N)

    return
  end function Spline__xback

  function Spline__evaluateMX( spline, x ) result(f)
    implicit none
    type(Spline_type), intent(in)  :: spline
    real(8), intent(in) :: x

    real(8) :: f
    integer :: i, ia, ib, ic
    real(8) :: h1,h2,h3,f1,f2,f3,f4
    real(8) :: g1,g2,x1,x2,y1,y2

    if( spline%vx(spline%N) < x ) then
       i=spline%N
    else if( x < spline%vx(1) ) then
       i=1
    else
       ia=1
       ib=spline%N
       do while( ia+1 < ib )
          ic = (ia+ib)/2
          if( x<spline%vx(ic) )then
             ib=ic
          else
             ia=ic
          end if
       end do
       i=ib
    end if

    if(i<2)then
       i = 3
    else if( spline%N<i )then
       i = spline%N-1
    end if

    if( i==2 ) then
       h2 = spline%vx(i)   - spline%vx(i-1)
       h3 = spline%vx(i+1) - spline%vx(i)

       f2 = spline%vf(i-1)
       f3 = spline%vf(i)
       f4 = spline%vf(i+1)

       h1 = -(h2+h3)
       f1 = f4
    else if (i==spline%N) then
       h1 = spline%vx(i-1) - spline%vx(i-2)
       h2 = spline%vx(i)   - spline%vx(i-1)

       f1 = spline%vf(i-2)
       f2 = spline%vf(i-1)
       f3 = spline%vf(i)

       h3 = -(h1+h2)
       f4 = f1
    else
       h1 = spline%vx(i-1) - spline%vx(i-2)
       h2 = spline%vx(i)   - spline%vx(i-1)
       h3 = spline%vx(i+1) - spline%vx(i)

       f1 = spline%vf(i-2)
       f2 = spline%vf(i-1)
       f3 = spline%vf(i)
       f4 = spline%vf(i+1)
    end if

    g1 = ((f3-f2)*h1/h2 + (f2-f1)*h2/h1)/(h1+h2)
    g2 = ((f4-f3)*h2/h3 + (f3-f2)*h3/h2)/(h2+h3)

    x1 = x - spline%vx(i-1)
    x2 = x - spline%vx(i)
    y1 = x1/h2
    y2 = x2/h2

    f = y2*y2*(3.0*f2 + h2*g1 + (2.0*f2 + h2*g1)*y2) &
         + y1*y1*(3.0*f3 - h2*g2 - (2.0*f3 - h2*g2)*y1)

    return
  end function Spline__evaluateMX

  function Spline__derivativeMX( spline, x ) result(df)
    implicit none
    type(Spline_type), intent(in)  :: spline
    real(8), intent(in) :: x

    real(8) :: df
    integer :: i, ia, ib, ic
    real(8) :: h1,h2,h3,f1,f2,f3,f4
    real(8) :: g1,g2,x1,x2,y1,y2

    if( spline%vx(spline%N) < x ) then
       i=spline%N
    else if( x < spline%vx(1) ) then
       i=1
    else
       ia=1
       ib=spline%N
       do while( ia+1 < ib )
          ic = (ia+ib)/2
          if( x<spline%vx(ic) )then
             ib=ic
          else
             ia=ic
          end if
       end do
       i=ib
    end if

    if(i<3)then
       i = 3
    else if( spline%N<i )then
       i = spline%N-1
    end if

    if( i==2 ) then
       h2 = spline%vx(i)   - spline%vx(i-1)
       h3 = spline%vx(i+1) - spline%vx(i)

       f2 = spline%vf(i-1)
       f3 = spline%vf(i)
       f4 = spline%vf(i+1)

       h1 = -(h2+h3)
       f1 = f4
    else if (i==spline%N) then
       h1 = spline%vx(i-1) - spline%vx(i-2)
       h2 = spline%vx(i)   - spline%vx(i-1)

       f1 = spline%vf(i-2)
       f2 = spline%vf(i-1)
       f3 = spline%vf(i)

       h3 = -(h1+h2)
       f4 = f1
    else
       h1 = spline%vx(i-1) - spline%vx(i-2)
       h2 = spline%vx(i)   - spline%vx(i-1)
       h3 = spline%vx(i+1) - spline%vx(i)

       f1 = spline%vf(i-2)
       f2 = spline%vf(i-1)
       f3 = spline%vf(i)
       f4 = spline%vf(i+1)
    end if

    g1 = ((f3-f2)*h1/h2 + (f2-f1)*h2/h1)/(h1+h2)
    g2 = ((f4-f3)*h2/h3 + (f3-f2)*h3/h2)/(h2+h3)

    x1 = x - spline%vx(i-1)
    x2 = x - spline%vx(i)
    y1 = x1/h2
    y2 = x2/h2

    df = y2*(2.0*(3.0*f2 + h2*g1) + 3.0*(2.0*f2 + h2*g1)*y2)/h2 &
         + y1*(2.0*(3.0*f3 - h2*g2) - 3.0*(2.0*f3 - h2*g2)*y1)/h2

    return
  end function Spline__derivativeMX

  function SphericalBessel__J( l, x ) result(J)
    implicit none
    integer, intent(in) :: l
    real(8), intent(in) :: x
    real(8) :: J

    real(8) :: ix1, ix2

    select case(l)
    case(0)
       if( x<1.0e-2 ) then
          J = 1.0 - 1.0/6.0*x*x
       else
          J = sin(x)/x
       endif

    case(1)
       if( x<1.0e-6 ) then
          J = 1.0/3.0*x - 1.0/30.0*(x**3)
       else
          ix1 = 1.0/x
          J = (sin(x)*ix1-cos(x))*ix1
       endif

    case(2)
       if( x<4.0e-3 ) then
          J = 1.0/15.0*(x**2) - 1.0/210.0*(x**4)
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          J = + (sin(x)*ix1)*(3.0*ix2-1.0) - (cos(x)*ix2)*3.0
       endif

    case(3)
       if( x<2.0e-2 ) then
          J = 1.0/105.0*(x**3) - 1.0/1890.0*(x**5)
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          J = + (sin(x)*ix2)*(15.0*ix2-6.0) &
               - (cos(x)*ix1)*(15.0*ix2-1.0)
       endif

    case(4)
       if( x<6.0e-2 ) then
          J = 1.0/945.0*(x**4) - 1.0/20790.0*(x**6)
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          J = + (sin(x)*ix1)*((105.0*ix2-45.0)*ix2+1.0) &
               - (cos(x)*ix2)*(105.0*ix2-10.0)
       endif

    case(5)
       if( x<1.0e-1 ) then
          J = 1.0/(10395.0)*(x**5) - 1.0/270270.0*(x**7)
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          J = + (sin(x)*ix2)*((945.0*ix2-420.0)*ix2+15.0) &
               - (cos(x)*ix1)*((945.0*ix2-105.0)*ix2+1.0)
       endif

    case(6)
       if( x<5.0e-1 ) then
          J = 1.0/(135135.0)*(x**6) - 1.0/4054050.0*(x**8)
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          J = + (sin(x)*ix1)*(((945.0*11.0*ix2-4725.0)*ix2+210.0)*ix2-1.0) &
               - (cos(x)*ix2)*((945.0*11.0*ix2-1260.0)*ix2+21.0)
       endif

    case default
       J = 0.d0
       write(*,'(a70)') '# Sorry : spherical Bessel function for l>6 is not implemented'
       stop
    end select

    return
  end function SphericalBessel__J

  function SphericalBessel__Jx2( l, x ) result(Jx2)
    implicit none
    integer, intent(in)       :: l
    real(8), intent(in) :: x
    real(8) :: Jx2

    real(8) :: ix1, ix2


    select case(l)
    case(0)
       Jx2 = sin(x)*x

    case(1)
       Jx2 = sin(x) - cos(x)*x

    case(2)
       if( x<4.0e-3 ) then
          Jx2 = 1.0/15.0*(x**4) - 1.0/210.0*(x**6)
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          Jx2 = (sin(x)*x)*(3.0*ix2-1.0) - (cos(x))*3.0
       endif

    case(3)
       if( x<2.0e-2 ) then
          Jx2 = 1.0/105.0*(x**5) - 1.0/1890.0*(x**7)
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          Jx2 = (sin(x))*(15.0*ix2-6.0) - (cos(x)*x)*(15.0*ix2-1.0)
       endif

    case(4)
       if( x<6.0e-2 ) then
          Jx2 = 1.0/945.0*(x**6) - 1.0/20790.0*(x**8)
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          Jx2 = (sin(x)*x)*((105.0*ix2-45.0)*ix2+1.0) &
               - (cos(x))*(105.0*ix2-10.0)
       endif

    case(5)
       if( x<1.0e-1 ) then
          Jx2 = 1.0/(10395.0)*(x**7) - 1.0/270270.0*(x**9)
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          Jx2 = (sin(x))*((945.0*ix2-420.0)*ix2+15.0) &
               - (cos(x)*x)*((945.0*ix2-105.0)*ix2+1.0)
       endif

    case(6)
       if( x<5.0e-1 ) then
          Jx2 = 1.0/(135135.0)*(x**8) - 1.0/4054050.0*(x**10)
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          Jx2 = + (sin(x)*x)*(((945.0*11.0*ix2-4725.0)*ix2+210.0)*ix2-1.0) &
               - (cos(x))*((945.0*11.0*ix2-1260.0)*ix2+21.0)
       endif

    case default
       Jx2 = 0.d0
       write(*,'(a70)') '# Sorry : spherical Bessel function for l>6 is not implemented'
       stop
    end select

    return
  end function SphericalBessel__Jx2

  function SphericalBessel__Jxl( l, x ) result(Jxl)
    implicit none
    integer, intent(in) :: l
    real(8), intent(in) :: x
    real(8) :: Jxl

    real(8) :: ix1, ix2

    select case(l)
    case(0)
       if( x<1.0e-2 ) then
          Jxl = 1.0 - 1.0/6.0*(x**2)
       else
          Jxl = sin(x)/x
       endif

    case(1)
       if( x<1.0e-6 ) then
          Jxl = 1.0/3.0 - 1.0/30.0*(x**2)
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          Jxl = (sin(x)*ix1-cos(x))*ix2
       endif

    case(2)
       if( x<4.0e-3 ) then
          Jxl = 1.0/15.0 - 1.0/210.0*(x**2)
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          Jxl = ((sin(x)*ix1)*(3.0*ix2-1.0) &
               - (cos(x)*ix2)*3.0)*ix2
       endif

    case(3)
       if( x<2.0e-2 ) then
          Jxl = 1.0/105.0 - 1.0/1890.0*(x**2)
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          Jxl = ((sin(x)*ix1)*(15.0*ix2-6.0) &
               - (cos(x))*(15.0*ix2-1.0))*ix2*ix2
       endif

    case(4)
       if( x<6.0e-2 ) then
          Jxl = 1.0/945.0 - 1.0/20790.0*(x**2)
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          Jxl = ((sin(x)*ix1)*((105.0*ix2-45.0)*ix2+1.0) &
               - (cos(x)*ix2)*(105.0*ix2-10.0))*ix2*ix2
       endif

    case(5)
       if( x<1.0e-1 ) then
          Jxl = 1.0/(10395.0) - 1.0/270270.0*(x**2)
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          Jxl = ((sin(x)*ix1)*((945.0*ix2-420.0)*ix2+15.0) &
               - (cos(x))*((945.0*ix2-105.0)*ix2+1.0))*ix2*ix2*ix2
       endif

    case(6)
       if( x<5.0e-1 ) then
          Jxl = 1.0/(135135.0) - 1.0/4054050.0*(x**2)
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          Jxl = ((sin(x)*ix1)*(((945.0*11.0*ix2-4725.0)*ix2+210.0)*ix2-1.0) &
               - (cos(x)*ix2)*((945.0*11.0*ix2-1260.0)*ix2+21.0))*ix2*ix2*ix2
       endif

    case default
       Jxl = 0.d0
       write(*,'(a70)') '# Sorry : spherical Bessel function for l>6 is not implemented'
       stop
    end select

    return
  end function SphericalBessel__Jxl

  function SphericalBessel__dJx2( l, x ) result(dJx2)
    implicit none
    integer, intent(in)       :: l
    real(8), intent(in) :: x
    real(8) :: dJx2

    real(8) :: ix1, ix2

    select case(l)
    case(0)
       dJx2 = sin(x) + cos(x)*x

    case(1)
       dJx2 = sin(x)*x

    case(2)
       if( x<4.0e-3 ) then
          dJx2 = 4.0/15.0*(x**3) - 6.0/210.0*(x**5)
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          dJx2 = sin(x)*(-3.0*ix2+2.0) + cos(x)*(3.0*ix1-x)
       endif

    case(3)
       if( x<2.0e-2 ) then
          dJx2 = 1.0/21.0*(x**4) - 7.0/1890.0*(x**6)
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          dJx2 = sin(x)*((-30.0*ix2+15.0)*ix1-x) + cos(x)*(30.0*ix2-5.0)
       endif

    case(4)
       if( x<6.0e-2 ) then
          dJx2 = 6.0/945.0*(x**5) - 8.0/20790.0*(x**7)
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          dJx2 = sin(x)*((-315.0*ix2+150.0)*ix2-9.0)  &
               + cos(x)*((315.0*ix2-45.0)*ix1+x)
       endif

    case(5)
       if( x<1.0e-1 ) then
          dJx2 = 7.0/10395.0*(x**6) - 9.0/270270.0*(x**8)
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          dJx2 = sin(x)*(((-3780.0*ix2+1785.0)*ix2-105.0)*ix1+x) &
               + cos(x)*((945.0*4.0*ix2-525.0)*ix2+14.0)
       endif

    case(6)
       if( x<5.0e-1 ) then
          dJx2 = 8.0/135135.0*(x**7) - 10.0/4054050.0*(x**9)
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          dJx2 = sin(x)*(((-51975.0*ix2+24570.0)*ix2-1470.0)*ix2+20.0) &
               + cos(x)*((( 51975.0*ix2-7245.0)*ix2+210.0)*ix1-x)
       endif


    case default
       dJx2 = 0.d0
       write(*,'(a70)') '# Sorry : spherical Bessel function for l>6 is not implemented'
       stop
    end select

    return
  end function SphericalBessel__dJx2


  function SphericalBessel__dJxlx( l, x ) result(dJxlx)
    implicit none
    integer, intent(in)       :: l
    real(8), intent(in) :: x
    real(8) :: dJxlx
    real(8) :: ix1, ix2

    select case(l)
    case(0)
       if( x<1.0e-2 ) then
          dJxlx = - 2.0/6.0
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          dJxlx = (cos(x)-(sin(x)*ix1))*ix2
       endif

    case(1)
       if( x<1.0e-6 ) then
          dJxlx = - 2.0/30.0
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          dJxlx = ((1-3*ix2)*(sin(x)*ix1) + 3*(cos(x)*ix2) )*ix2
       endif

    case(2)
       if( x<4.0e-3 ) then
          dJxlx = - 2.0/210.0
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          dJxlx = ((6-15*ix2)*(sin(x)*ix1) &
               + (15*ix2-1)*cos(x))*ix2*ix2
       endif

    case(3)
       if( x<2.0e-2 ) then
          dJxlx = - 2.0/1890.0
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          dJxlx = ( - (1-45*ix2+105*ix2*ix2)*(sin(x)*ix1) &
               - (10*ix2-105)*(cos(x)*ix2) )*ix2*ix2
       endif

    case(4)
       if( x<6.0e-2 ) then
          dJxlx = - 2.0/20790.0
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          dJxlx = -((15-420*ix2+945*ix2*ix2)*(sin(x)*ix1) &
               + (-1+105*ix2-945*ix2*ix2)*cos(x))*ix2*ix2*ix2
       endif

    case(5)
       if( x<1.0e-1 ) then
          dJxlx = - 2.0/270270.0
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          dJxlx = ((1-210*ix2+4725*ix2*ix2-10395*ix2*ix2*ix2)*(sin(x)*ix1) &
               + (21-1260*ix2+10395*ix2*ix2)*(cos(x)*ix2))*ix2*ix2*ix2
       endif

    case(6)
       if( x<5.0e-1 ) then
          dJxlx = - 2.0/4054050.0
       else
          ix1 = 1.0/x
          ix2 = ix1*ix1
          dJxlx = ((28-3150*ix2+62370*ix2*ix2-135135*ix2*ix2*ix2)*(sin(x)*ix1) &
               + (-1+378*ix2-17325*ix2*ix2+135135*ix2*ix2*ix2)*cos(x))*ix2*ix2*ix2*ix2
       endif

    case default
       dJxlx = 0.d0
       write(*,'(a70)') '# Sorry : spherical Bessel function for l>6 is not implemented'
       stop
    end select

    return

  end function SphericalBessel__dJxlx

  function SphericalBessel__integrateS( Ra, Rb, l, r ) result(sum)
    implicit none
    real(8), intent(in) :: Ra(SphericalBessel%Nk)
    real(8), intent(in) :: Rb(SphericalBessel%Nk)
    integer, intent(in) :: l
    real(8), intent(in) :: r

    real(8) :: sum
    integer :: ik
    real(8) :: k, w

    sum=0.d0

    if( r < 1.d-14 ) then
       do ik=1, SphericalBessel%Nk
          k = SphericalBessel%vkx(ik)
          w = SphericalBessel%vkw(ik)

          sum = sum + w*(k**(l+2)) * Ra(ik)*Rb(ik)
       end do

       sum = sum*4*M_PI*SphericalBessel__Jxl(l,0.d0)
       return
    end if

    do ik=1, SphericalBessel%Nk
       k = SphericalBessel%vkx(ik)
       w = SphericalBessel%vkw(ik)

       sum = sum + w*SphericalBessel__Jx2(l,k*r) * Ra(ik)*Rb(ik)
    end do

    sum = sum*4*M_PI/r**(l+2)

    return
  end function SphericalBessel__integrateS

  function SphericalBessel__integrateK( Ra, Rb, l, r ) result(sum)
    implicit none
    real(8), intent(in) :: Ra(SphericalBessel%Nk)
    real(8), intent(in) :: Rb(SphericalBessel%Nk)
    integer, intent(in) :: l
    real(8), intent(in) :: r

    real(8) :: sum
    integer :: ik
    real(8) :: k, w

    sum=0.d0

    if( r < 1.d-14 ) then
       do ik=1, SphericalBessel%Nk
          k = SphericalBessel%vkx(ik)
          w = SphericalBessel%vkw(ik)

          sum = sum + w*(k**(l+4)) * Ra(ik)*Rb(ik)
       end do

       sum = sum*2*M_PI*SphericalBessel__Jxl(l,0.d0)
       return
    end if

    do ik=1, SphericalBessel%Nk
       k = SphericalBessel%vkx(ik)
       w = SphericalBessel%vkw(ik)

       sum = sum + w*k*k*SphericalBessel__Jx2(l,k*r) * Ra(ik)*Rb(ik)
    end do

    sum = sum*2*M_PI/r**(l+2)

    return
  end function SphericalBessel__integrateK

  function SphericalBessel__integratedS( Ra, Rb, l, r ) result(sum)
    implicit none
    real(8), intent(in) :: Ra(SphericalBessel%Nk)
    real(8), intent(in) :: Rb(SphericalBessel%Nk)
    integer, intent(in) :: l
    real(8), intent(in) :: r

    real(8) :: sum
    integer       :: ik
    real(8) :: k, w

    sum=0.d0

    if( r < 1.d-14 ) then
       do ik=1, SphericalBessel%Nk
          k = SphericalBessel%vkx(ik)
          w = SphericalBessel%vkw(ik)

          sum = sum + w*(k**(l+2)) * k**2 * Ra(ik)*Rb(ik)
       end do

       sum = sum*4*M_PI*SphericalBessel__dJxlx(l,0.d0)
       return
    end if

    do ik=1, SphericalBessel%Nk
       k = SphericalBessel%vkx(ik)
       w = SphericalBessel%vkw(ik)

       sum = sum - w*Ra(ik)*Rb(ik)*(l+2)*SphericalBessel__Jx2 (l,k*r)
       sum = sum + w*Ra(ik)*Rb(ik)*(k*r)*SphericalBessel__dJx2(l,k*r)
    end do

    sum = sum*4*M_PI/r**(l+4)

    return 
  end function SphericalBessel__integratedS

  function SphericalBessel__integratedK( Ra, Rb, l, r ) result(sum)
    implicit none
    real(8), intent(in) :: Ra(SphericalBessel%Nk)
    real(8), intent(in) :: Rb(SphericalBessel%Nk)
    integer, intent(in) :: l
    real(8), intent(in) :: r

    real(8) :: sum
    integer :: ik
    real(8) :: k, w

    sum=0.d0

    if( r < 1.d-14 ) then
       do ik=1, SphericalBessel%Nk
          k = SphericalBessel%vkx(ik)
          w = SphericalBessel%vkw(ik)

          sum = sum + w*(k**(l+4)) * k**2 * Ra(ik)*Rb(ik)
       end do

       sum = sum*2*M_PI*SphericalBessel__dJxlx(l,0.d0)
       return
    end if

    do ik=1, SphericalBessel%Nk
       k = SphericalBessel%vkx(ik)
       w = SphericalBessel%vkw(ik)

       sum = sum - w*k*k*Ra(ik)*Rb(ik)* (l+2)*SphericalBessel__Jx2 (l,k*r)
       sum = sum + w*k*k*Ra(ik)*Rb(ik)*(k*r)*SphericalBessel__dJx2(l,k*r)
    end do

    sum = sum*2*M_PI/r**(l+4)

    return
  end function SphericalBessel__integratedK

  function SphericalHarmonic__Theta(l,m,th) result(Theta)
    implicit none
    integer, intent(in) :: l, m
    real(8) :: th
    real(8) :: Theta

    real(8) :: c, s

    c = cos(th)
    s = sin(th)

    Theta = 0.d0

    select case(l)

    case(0)
       select case(abs(m))
       case(0)
          Theta = C00
       end select

    case(1)
       select case(abs(m))
       case(0)
          Theta = C10*c
       case(1)
          Theta = C11*s
       end select

    case(2)
       select case(abs(m))
       case(0)
          Theta = C20*( 3*c*c - 1.0 )
       case(1)
          Theta = C21*( c*s )
       case(2)
          Theta = C22*( s*s )
       end select

    case(3)
       select case(abs(m))
       case(0)
          Theta = C30*c*( 5*c*c - 3.0 )
       case(1)
          Theta = C31*s*( 5*c*c - 1.0 )
       case(2)
          Theta = C32*c*( s*s )
       case(3)
          Theta = C33*s*( s*s )
       end select

    case (4)
       select case(abs(m))
       case(0)
          Theta = C40*( 35*c*c*c*c - 30*c*c + 3 )
       case(1)
          Theta = C41*s*( 7*c*c*c - 3*c )
       case(2)
          Theta = C42*s*s*( 7*c*c - 1 )
       case(3)
          Theta = C43*c*s*s*s
       case(4)
          Theta = C44*s*s*s*s
       end select

    case (5)
       select case(abs(m))
       case(0)
          Theta = C50*c*( 63*c*c*c*c - 70*c*c + 15 )
       case(1)
          Theta = C51*s*( 21*c*c*c*c - 14*c*c + 1 )
       case(2)
          Theta = C52*c*s*s*( 3*c*c - 1 )
       case(3)
          Theta = C53*s*s*s*( 9*c*c - 1 )
       case(4)
          Theta = C54*c*s*s*s*s
       case(5)
          Theta = C55*s*s*s*s*s
       end select

    case(6)
       select case(abs(m))
       case(0)
          Theta = &
               C60*( 231*c*c*c*c*c*c - 315*c*c*c*c + 105*c*c - 5 )
       case(1)
          Theta = &
               C61*c*s*( 33*c*c*c*c - 30*c*c + 5 )
       case(2)
          Theta = &
               C62*s*s*( 33*c*c*c*c - 18*c*c + 1 )
       case(3)
          Theta = &
               C63*c*s*s*s*( 11*c*c - 3 )
       case(4)
          Theta = &
               C64*s*s*s*s*( 11*c*c - 1 )
       case(5)
          Theta = &
               C65*c*s*s*s*s*s
       case(6)
          Theta = &
               C66*s*s*s*s*s*s
       end select

    case default
       Theta = 0.d0
       write(*,'(a70)') '# Sorry : Spherical Harmonic function for l>6 is not implemented.'
       stop

    end select


    return
  end function SphericalHarmonic__Theta

  function SphericalHarmonic__Phi(m,ph) result(Phi)
    implicit none
    integer       :: m
    real(8) :: ph
    real(8) :: Phi

    if( m == 0 ) then
       Phi = 1.d0
    elseif( m > 0 ) then 
       Phi = cos(m*ph)
    else 
       Phi = sin(m*ph)
    endif

    return
  end function SphericalHarmonic__Phi

  function SphericalHarmonic__Gaunt( la, ma, lb, mb, l, m ) result(g)
    implicit none
    integer, intent(in) :: l, la, lb
    integer, intent(in) :: m, ma, mb
    real(8) :: g

    real(8) :: tsum, psum
    integer :: it, ip
    real(8) :: th, ph, weight

    if( abs(abs(ma)-abs(mb)) /= abs(m) .and. abs(ma)+abs(mb) /= abs(m) ) then
       g = 0.d0
       return
    end if

    if( abs(mod(la-lb-l,4)) /= 0 .and. abs(mod(la-lb-l,4)) /= 2 ) then
       g = 0.d0
       return
    end if

    if( (.not. associated(vshx)) ) then
       allocate( vshx(N) )
       allocate( vshw(N) )
       call GaussLegendre__getPoints( N, 0.d0, M_PI, vshx, vshw )
    endif

    tsum=0.d0
    do it=1, N
       th  = vshx(it)
       weight = vshw(it)
       tsum = tsum + weight*sin(th)* &
            SphericalHarmonic__Theta(la,ma,th)* &
            SphericalHarmonic__Theta(lb,mb,th)* &
            SphericalHarmonic__Theta(l,m,th)
    end do

    if( tsum == 0.0 ) then
       g = 0.d0
       return
    endif

    psum=0.d0
    do ip=1, N
       ph     = vshx(ip)*2
       weight = vshw(ip)*2
       psum = psum + weight* &
            SphericalHarmonic__Phi(ma,ph)* &
            SphericalHarmonic__Phi(mb,ph)* &
            SphericalHarmonic__Phi(m,ph)
    end do

    if( psum == 0.0 ) then
       g = 0.d0
       return
    endif

    if( mod(la-lb-l,4) == +2 .or. mod(la-lb-l,4) == -2 ) then
       tsum = -tsum
    endif

    g = tsum*psum


    return
  end function SphericalHarmonic__Gaunt

  function SphericalHarmonic__rlY( l, m, R ) result(rlY)
    implicit none
    integer, intent(in) :: l, m
    real(8), intent(in) :: R(3)
    real(8)  :: rlY
    real(8)  :: x, y, z, dR2

    x = R(1)
    y = R(2)
    z = R(3)
    dR2 = Position__length2(R)
    rlY = 0.d0

    select case(l)
    case(0) 
       rlY = C00 

    case(1) 
       select case(m)
       case(+1)
          rlY = C11*x 
       case(-1)
          rlY = C11*y 
       case( 0)
          rlY = C10*z 
       end select

    case(2) 
       select case(m)
       case( 0)
          rlY = C20*(3*z*z-dR2) 
       case(+2)
          rlY = C22*(x*x-y*y) 
       case(-2)
          rlY = C22*2.0*x*y 
       case(+1)
          rlY = C21*z*x 
       case(-1)
          rlY = C21*y*z 
       end select

    case(3) 
       select case(m)
       case( 0)
          rlY = C30*z * (5*z*z-3*dR2)
       case(+1)
          rlY = C31*x * (5*z*z-dR2)
       case(-1)
          rlY = C31*y * (5*z*z-dR2)
       case(+2)
          rlY = C32*z * (x*x-y*y)
       case(-2)
          rlY = C32*z * (2.0*x*y)
       case(+3)
          rlY = C33*x * (x*x - 3*y*y)
       case(-3)
          rlY = C33*y * (3*x*x - y*y)
       end select


    case(4) 
       select case(m)
       case(0)
          rlY = C40*(35*z*z*z*z - 30*z*z*dR2 + 3*dR2*dR2 )
       case(+1)
          rlY = C41*x*z * (7*z*z-3*dR2)

       case(-1)
          rlY = C41*y*z * (7*z*z-3*dR2)

       case(+2)
          rlY = C42*(x*x-y*y) * (7*z*z-dR2)

       case(-2)
          rlY = C42*2*x*y * (7*z*z-dR2)

       case(+3)
          rlY = C43*x*z * (x*x-3*y*y)

       case(-3)
          rlY = C43*y*z * (3*x*x-y*y)

       case(+4)
          rlY = C44 * (x*x-2*x*y-y*y) * &
               (x*x+2*x*y-y*y)
       case(-4)
          rlY = C44 * (4*x*y) * (x*x-y*y)

       end select


    case(5) 
       select case(m)
       case(0)
          rlY = C50*z* (63*z*z*z*z-70*z*z*dR2+15*dR2*dR2)
       case(+1)
          rlY = C51*x* (21*z*z*z*z-14*z*z*dR2+dR2*dR2 )
       case(-1)
          rlY = C51*y* (21*z*z*z*z-14*z*z*dR2+dR2*dR2 )
       case(+2)
          rlY = C52*z* (x*x-y*y) * (3*z*z-dR2)
       case(-2)
          rlY = C52*z* (2*x*y) * (3*z*z-dR2)
       case(+3)
          rlY = C53*x* (x*x-3*y*y) * (9*z*z-dR2)
       case(-3)
          rlY = C53*y* (3*x*x-y*y) * (9*z*z-dR2)
       case(+4)
          rlY = C54*z* (x*x-2*x*y-y*y) * &
               (x*x+2*x*y-y*y)
       case(-4)
          rlY = C54*z* (4*x*y) * (x*x-y*y)
       case(+5)
          rlY = C55*x* (x*x*x*x-10*x*x*y*y+5*y*y*y*y)
       case(-5)
          rlY = C55*y* (5*x*x*x*x-10*x*x*y*y+y*y*y*y)
       end select

    case(6) 
       select case(m)
       case(0)
          rlY = C60*( 231*z*z*z*z*z*z &
               - 315*z*z*z*z*dR2 + 105*z*z*dR2*dR2 &
               - 5*dR2*dR2*dR2 )
       case(+1)
          rlY = C61*z*x * &
               (33*z*z*z*z-30*z*z*dR2+5*dR2*dR2)
       case(-1)
          rlY = C61*z*y * &
               (33*z*z*z*z-30*z*z*dR2+5*dR2*dR2)
       case(+2)
          rlY = C62*(x*x-y*y) * &
               (33*z*z*z*z-18*z*z*dR2+dR2*dR2)
       case(-2)
          rlY = C62*(2*x*y)* &
               (33*z*z*z*z-18*z*z*dR2+dR2*dR2)
       case(+3)
          rlY = C63*z*x * &
               (x*x-3*y*y) * (11*z*z-3*dR2)
       case(-3)
          rlY = C63*z*y * &
               (3*x*x-y*y) * (11*z*z-3*dR2)
       case(+4)
          rlY = C64*(11*z*z-dR2) * &
               (x*x-2*x*y-y*y) * (x*x+2*x*y-y*y)
       case(-4)
          rlY = C64*(11*z*z-dR2) * &
               4*x*y * (x*x-y*y)
       case(+5)
          rlY = C65*z*x * &
               (x*x*x*x-10*x*x*y*y+5*y*y*y*y)
       case(-5)
          rlY = C65*z*y * &
               (5*x*x*x*x-10*x*x*y*y+y*y*y*y)
       case(+6)
          rlY = C66*(x*x-y*y) * &
               (x*x-4*x*y+y*y) * (x*x+4*x*y+y*y)
       case(-6)
          rlY = C66*2*x*y * &
               (3*x*x-y*y) * (x*x-3*y*y)
       end select

    case default
       rlY = 0.d0
       write(*,'(a70)') &
            '# Sorry : Spherical Harmonic function for l>6 is not implemented.'
       stop

    end select

    return
  end function SphericalHarmonic__rlY


  function SphericalHarmonic__drlY( l, m, R ) result(drlY)
    implicit none
    integer, intent(in) :: l, m
    real(8), intent(in) :: R(3)
    real(8)  :: drlY(3)

    real(8)  :: x, y, z, dR2, dR4

    x = R(1)
    y = R(2)
    z = R(3)
    drlY = (/ 0.d0, 0.d0, 0.d0 /)
    dR2  = Position__length2(R)

    select case(l)
    case(0) 
       drlY = (/ 0.d0, 0.d0, 0.d0 /)

    case(1) 
       select case(m)
       case( 0)
          drlY = (/ 0.d0, 0.d0, C10 /)
       case(+1)
          drlY = (/ C11, 0.d0, 0.d0 /)
       case(-1)
          drlY = (/ 0.d0, C11, 0.d0 /)
       end select

    case(2) 
       select case(m)
       case( 0)
          drlY = C20*(/ -2*x, -2*y, 4*z /) 
       case(+1)
          drlY = C21*(/    z,   0.d0,   x /) 
       case(-1)
          drlY = C21*(/   0.d0,    z,   y /) 
       case(+2)
          drlY = C22*(/  2*x,- 2*y,  0.d0 /) 
       case(-2)
          drlY = C22*(/  2*y,  2*x,  0.d0 /) 
       end select

    case(3) 
       select case(m)
       case( 0)
          drlY = C30*(/ -6*x*z, -6*y*z, 9*z*z-3*dR2 /) 
       case(+1)
          drlY = C31*(/ -2*x*x + 5*z*z - dR2, -2*x*y, 8*x*z /)
       case(-1)
          drlY = C31*(/ -2*x*y,  -2*y*y + 5*z*z - dR2, 8*y*z /)
       case(+2)
          drlY = C32*(/ 2*x*z      , -2*y*z     , x*x-y*y /)
       case(-2)
          drlY = C32*(/ 2*y*z      ,  2*z*x     , 2*x*y /)
       case(+3)
          drlY = C33*(/ 3*(x*x-y*y), -6*x*y     , 0.d0 /)
       case(-3)
          drlY = C33*(/ 6*x*y      , 3*(x*x-y*y), 0.d0 /)
       end select

    case(4) 
       select case(m)
       case( 0)
          drlY = C40*(/ &
               -60*z*z*x + 12*x*dR2, &
               -60*z*z*y + 12*y*dR2, &
               80*z*z*z - 48*z*dR2 /)
       case(+1)
          drlY = C41*(/ &
               z*(7*z*z-3*dR2) - 6*x*x*z, &
               -6*x*y*z, &
               x*(7*z*z-3*dR2) + 8*x*z*z /)
       case(-1)
          drlY = C41*(/ &
               -6*x*y*z, &
               z*( 4*z*z - 3*x*x - 9*y*y), &
               y*(15*z*z-3*dR2)  /)
       case(+2)
          drlY = C42*(/ &
               4*x*(3*z*z - x*x), &
               4*y*( y*y - 3*z*z), &
               12*z*(x*x-y*y) /)
       case(-2)
          drlY = C42*(/ &
               2*y*(6*z*z - 3*x*x - y*y), &
               2*x*(6*z*z -   x*x - 3*y*y), &
               24*x*y*z /)
       case(+3)
          drlY = C43*(/ &
               3*z*(x*x-y*y), &
               -6*x*y*z, &
               x*(x*x-3*y*y) /)
       case(-3)
          drlY = C43*(/ &
               6*x*y*z, &
               3*z*(x*x-y*y), &
               y*(3*x*x-y*y) /)
       case(+4)
          drlY = C44*(/ &
               4*x*(x*x-3*y*y), &
               4*y*(y*y-3*x*x), &
               0.d0 /)
       case(-4)
          drlY = C44*(/ &
               4*y*(3*x*x - y*y), &
               4*x*(x*x - 3*y*y), &
               0.d0 /)
       end select

    case(5) 
       select case(m)
       case( 0)
          drlY = C50*(/ &
               z*(-140*x*z*z + 60*x*dR2), &
               z*(-140*y*z*z + 60*y*dR2), &
               175*z*z*z*z - 150*z*z*dR2 + 15*dR2*dR2 /)
       case(+1)
          drlY = C51*(/ &
               21*z*z*z*z - 14*z*z*dR2 + dR2*dR2 + 4*x*x*(dR2-7*z*z), &
               4*x*y*(dR2-7*z*z), &
               8*x*z*(7*z*z - 3*dR2) /)
       case(-1)
          drlY = C51*(/ &
               4*x*y*(dR2-7*z*z), &
               21*z*z*z*z - 14*z*z*dR2 + dR2*dR2 + 4*y*y*(dR2-7*z*z), &
               8*y*z*(7*z*z - 3*dR2) /)
       case(+2)
          drlY = C52*(/ &
               4*x*z*(z*z-x*x), &
               4*y*z*(y*y-z*z), &
               (7*z*z-dR2)*(x*x-y*y) /)
       case(-2)
          drlY = C52*(/ &
               2*y*z*(2*z*z - 3*x*x - y*y), &
               2*z*x*(2*z*z - 3*y*y - x*x), &
               2*x*y*(6*z*z - x*x - y*y) /)
       case(+3)
          drlY = C53*(/ &
               3*(x*x-y*y)*(9*z*z-dR2) - 2*x*x*(x*x-3*y*y), &
               - 4*x*y*(12*z*z-x*x-3*y*y), &
               + 16*x*z*(x*x-3*y*y) /)
       case(-3)
          drlY = C53*(/ &
               4*x*y*(12*z*z-3*x*x-y*y), &
               3*(x*x-y*y)*(9*z*z-dR2) - 2*y*y*(3*x*x-y*y), &
               16*y*z*(3*x*x-y*y) /)
       case(+4)
          drlY = C54*(/ &
               4*x*z*(x*x-3*y*y), &
               4*y*z*(y*y-3*x*x), &
               (x*x-2*x*y-y*y)*(x*x+2*x*y-y*y) /)
       case(-4)
          drlY = C54*(/ &
               4*y*z*(3*x*x-y*y), &
               4*z*x*(x*x-3*y*y), &
               4*x*y*(x*x-y*y) /)
       case(+5)
          drlY = C55*(/ &
               5*(x*x-2*x*y-y*y)*(x*x+2*x*y-y*y), &
               -20*x*y*(x*x-y*y), &
               0.d0 /)
       case(-5)
          drlY = C55*(/ &
               20*x*y*(x*x-y*y), &
               5*(x*x-2*x*y-y*y)*(x*x+2*x*y-y*y), &
               0.d0 /)
       end select

    case(6) 
       dR4 = dR2*dR2
       select case(m)
       case( 0)
          drlY = C60*(/ &
               -630*x*z*z*z*z + 420*x*z*z*dR2 - 30*x*dR4, &
               -630*y*z*z*z*z + 420*y*z*z*dR2 - 30*y*dR4, &
               756*z*z*z*z*z - 840*z*z*z*dR2 +180*z*dR4 /)
       case(+1)
          drlY = C61*(/ &
               + z*(33*z*z*z*z-30*z*z*dR2+5*dR4) - 20*z*x*x*(3*z*z-dR2), &
               -20*x*y*z*(3*z*z-dR2), &
               x*(105*z*z*z*z-70*z*z*dR2+5*dR4) /)
       case(-1)
          drlY = C61*(/ &
               -20*x*y*z*(3*z*z-dR2), &
               + z*(33*z*z*z*z-30*z*z*dR2+5*dR4) - 20*z*y*y*(3*z*z-dR2), &
               + y*(33*z*z*z*z-30*z*z*dR2+5*dR4)  + 8*z*z*y*(9*z*z-5*dR2) /)
       case(+2)
          drlY = C62*(/ &
               + 2*x*(33*z*z*z*z-18*z*z*dR2+dR4) - 4*x*(x*x-y*y)*(9*z*z-dR2), &
               - 2*y*(33*z*z*z*z-18*z*z*dR2+dR4) - 4*y*(x*x-y*y)*(9*z*z-dR2), &
               32*z*(x*x-y*y)*(3*z*z-dR2) /)
       case(-2) 
          drlY = C62*(/ &
               + 2*y*(33*z*z*z*z-18*z*z*dR2+dR4) - 8*x*x*y*(9*z*z-dR2), &
               + 2*x*(33*z*z*z*z-18*z*z*dR2+dR4) - 8*x*y*y*(9*z*z-dR2), &
               64*x*y*z*(3*z*z-dR2) /)
       case(+3)
          drlY = C63*(/ &
               3*(x*x-y*y)*z*(11*z*z-3*dR2) - 6*x*x*z*(x*x-3*y*y), &
               - 6*x*y*z*((11*z*z-3*dR2)+(x*x-3*y*y)), &
               x*(x*x-3*y*y)*(11*z*z-3*dR2) + 16*x*z*z*(x*x-3*y*y) /)
       case(-3)
          drlY = C63*(/ &
               12*x*y*z*(4*z*z-3*x*x-y*y), &
               3*(x*x-y*y)*z*(11*z*z-3*dR2) - 6*y*y*z*(3*x*x-y*y), &
               y*(3*x*x-y*y)*(11*z*z-3*dR2) + 16*y*z*z*(3*x*x-y*y) /)
       case(+4)
          drlY = C64*(/ &
               2*x*( 20*x*x*z*z - 60*y*y*z*z -3*x*x*x*x + 10*x*x*y*y + 5*y*y*y*y), &
               2*y*( 20*y*y*z*z - 60*x*x*z*z -3*y*y*y*y + 10*x*x*y*y + 5*x*x*x*x), &
               20*z*(x*x-2*x*y-y*y)*(x*x+2*x*y-y*y) /)
       case(-4)
          drlY = C64*(/ &
               + 4*y*( 30*x*x*z*z - 10*y*y*z*z - 5*x*x*x*x + y*y*y*y), &
               - 4*x*( 30*y*y*z*z - 10*x*x*z*z - 5*y*y*y*y + x*x*x*x), &
               80*x*y*z*(x*x-y*y) /)
       case(+5)
          drlY = C65*(/ &
               5*z*(x*x-2*x*y-y*y)*(x*x+2*x*y-y*y), &
               -20*x*y*z*(x*x-y*y), &
               x*(x*x*x*x-10*x*x*y*y+5*y*y*y*y) /)
       case(-5)
          drlY = C65*(/ &
               20*x*y*z*(x*x-y*y), &
               5*z*(x*x-2*x*y-y*y)*(x*x+2*x*y-y*y), &
               y*(5*x*x*x*x-10*x*x*y*y+y*y*y*y) /)
       case(+6)
          drlY = C66*(/ &
               +6*x*(5*y*y*y*y-10*x*x*y*y+x*x*x*x), &
               -6*y*(5*x*x*x*x-10*x*x*y*y+y*y*y*y), &
               0.d0 /)
       case(-6)
          drlY = C66*(/ &
               +6*y*(y*y*y*y-10*x*x*y*y+5*x*x*x*x), &
               +6*x*(x*x*x*x-10*x*x*y*y+5*y*y*y*y), &
               0.d0 /)
       end select

    case default
       drlY = (/ 0.d0, 0.d0, 0.d0 /) 
       write(*,'(a70)') &
            '# Sorry : Spherical Harmonic function for l>6 is not implemented.'
       stop

    end select

    return
  end function SphericalHarmonic__drlY

  subroutine SphericalHarmonic__deallocate
    implicit none

    if( associated(vshx) ) deallocate(vshx)
    if( associated(vshw) ) deallocate(vshw)

    return
  end subroutine SphericalHarmonic__deallocate

  function Param__Cell__inside( Ro, Rc ) result(flag)
    implicit none
    real(8), intent(in) :: Ro(3)
    real(8), intent(in) :: Rc
    logical :: flag
    integer :: range(6)

    call Param__Cell__getRange( range, Ro, Rc )

    if( range(1)<1 .or. Param%Cell%Na<range(2) ) then
       flag = .false.
       return
    end if
    if( range(3)<1 .or. Param%Cell%Nb<range(4) ) then
       flag = .false.
       return
    end if
    if( range(5)<1 .or. Param%Cell%Nc<range(6) ) then
       flag = .false.
       return
    end if

    flag = .true.

    return
  end function Param__Cell__inside

  function Param__Cell__intersect( Ro1, Rc1, Ro2, Rc2 ) result(flag)
    implicit none
    real(8), intent(in) :: Ro1(3), Ro2(3)
    real(8), intent(in)   :: Rc1, Rc2
    logical         :: flag

    flag = ( Position__length2(Ro2-Ro1) < (Rc1+Rc2)*(Rc1+Rc2) )

    return
  end function Param__Cell__intersect

  function Param__Cell__mergeRange1( range, range1, range2 ) result(flag)
    implicit none
    integer, intent(out) :: range(6)
    integer, intent(in)  :: range1(6), range2(6)
    logical :: flag

    range(1) = max(range1(1),range2(1))
    range(2) = min(range1(2),range2(2))

    if( range(1) > range(2) ) then
       flag = .false.
       return
    end if

    range(3) = max(range1(3),range2(3))
    range(4) = min(range1(4),range2(4))

    if( range(3) > range(4) ) then
       flag = .false.
       return
    end if

    range(5) = max(range1(5),range2(5))
    range(6) = min(range1(6),range2(6))

    if( range(5) > range(6) ) then
       flag = .false.
       return
    end if

    flag = .true.

    return
  end function Param__Cell__mergeRange1

  function Param__Cell__mergeRange2( range, Ro1, Rc1, Ro2, l, Rc2 ) result(flag)
    implicit none
    integer, intent(out)       :: range(6)
    real(8), intent(in) :: Ro1(3), Ro2(3)
    real(8), intent(in)  :: Rc1, Rc2
    integer, intent(in)  :: l

    real(8) :: R(3)
    real(8)        :: dR
    logical        :: flag
    integer        :: range1(6), range2(6)

    R(:)  = Ro2 + Param%Cell%vL(:,l) - Ro1(:)
    dR = Position__length(R)

    if( dR > Rc1 + Rc2 ) then
       flag = .false.
       return
    end if

    call Param__Cell__getRange( range1, Ro1, Rc1 )
    call Param__Cell__getRange( range2, Ro2, Rc2 )
    range2(1) = range2(1) + Param%Cell%vLna(l)
    range2(2) = range2(2) + Param%Cell%vLna(l)
    range2(3) = range2(3) + Param%Cell%vLnb(l)
    range2(4) = range2(4) + Param%Cell%vLnb(l)
    range2(5) = range2(5) + Param%Cell%vLnc(l)
    range2(6) = range2(6) + Param%Cell%vLnc(l)

    flag = Param__Cell__mergeRange1( range, range1, range2 )

    return
  end function Param__Cell__mergeRange2

  subroutine Param__Cell__mergeRange3( range, range1, range2 )
    implicit none
    integer, intent(out) :: range(6)
    integer, intent(in)  :: range1(6), range2(6)

    range(1) = min(range1(1),range2(1))
    range(2) = max(range1(2),range2(2))

    range(3) = min(range1(3),range2(3))
    range(4) = max(range1(4),range2(4))

    range(5) = min(range1(5),range2(5))
    range(6) = max(range1(6),range2(6))

    return
  end subroutine Param__Cell__mergeRange3

  function Param__Cell__relative( la, lb ) result(lab)
    integer, intent(in) :: la, lb
    integer :: lab

    do lab=1-Param%Cell%nL, Param%Cell%nL-1
       if(Position__length(Param%Cell%vL(:,lab) - Param%Cell%vL(:,lb) + Param%Cell%vL(:,la))<1.d-10) then
          return
       end if
    end do

    lab = -100 

    return
  end function Param__Cell__relative

  function Base__intersect( pao1, pao2, L ) result(flag)
    implicit none
    type(PAO_type), intent(in)      :: pao1, pao2
    real(8), intent(in) :: L(3)

    logical        :: flag
    real(8) :: R(3)
    real(8)  :: dR

    R  = pao2%Ro + L - pao1%Ro
    dR = Position__length(R)

    flag = dR < pao1%Rc + pao2%Rc

    return
  end function Base__intersect

  function Potential__intersect( pao1, pao2, L ) result(flag)
    implicit none
    type(PAO_type), intent(in)      :: pao1
    type(PPnon_type), intent(in)    :: pao2
    real(8), intent(in) :: L(3)

    logical        :: flag
    real(8) :: R(3)
    real(8)  :: dR

    R  = pao2%Ro + L - pao1%Ro
    dR = Position__length(R)

    flag = dR < pao1%Rc + pao2%Rc

    return
  end function Potential__intersect

  function Potential__intersectI( pao1, pao2, L ) result(flag)
    implicit none
    type(PPnon_type), intent(in)    :: pao1
    type(PAO_type), intent(in)      :: pao2
    real(8), intent(in) :: L(3)

    logical        :: flag
    real(8) :: R(3)
    real(8)  :: dR

    R  = pao2%Ro + L - pao1%Ro
    dR = Position__length(R)

    flag = dR < pao1%Rc + pao2%Rc

    return
  end function Potential__intersectI

  function Param__Data__getElement(name) result(elem)
    implicit none
    character(len=*), intent(in) :: name
    type(Element_type), pointer :: elem
    integer :: i

    do i=1, Param%Data%nelem
       if( Param%Data%velem(i)%name == name ) then
          elem => Param%Data%velem(i)
          return
       end if
    end do
    elem => Param%Data%velem(1) 

    write(*,*) '# Error: atom ', trim(name), ' is not available'
    stop
  end function Param__Data__getElement

  function Element__getNumberOfPAO( elem ) result(npao)
    implicit none
    type(Element_type), intent(in) :: elem
    integer :: npao
    integer :: i

    npao = 0
    do i=1, elem%npao
       npao = npao + 2*(elem%vpao(i)%l) + 1
    end do

    return
  end function Element__getNumberOfPAO

  function Element__getNumberOfPAO2( elem ) result(npao)
    implicit none
    type(Element_type), intent(in) :: elem
    integer :: npao
    integer :: i

    npao = 0
    do i=1, elem%npao2
       npao = npao + 2*(elem%vpao2(i)%l) + 1
    end do

    return
  end function Element__getNumberOfPAO2

  function Element__getNumberOfVPS( elem ) result(nvps)
    implicit none
    type(Element_type), intent(in) :: elem
    integer :: nvps
    integer :: i

    nvps = 0
    do i=1, elem%nVnon
       if((Param%Data%element_type=='ciao_test') &
            .and.(.not. Param%Option%spin_orbit) &
            .and.(elem%dirac) &
            .and.(elem%vVnon(i,1)%l==elem%Vloc%l)) then
          cycle
       end if
       nvps = nvps + 2*(elem%vVnon(i,1)%l) + 1
    end do

    return
  end function Element__getNumberOfVPS

end module ac_misc_module
