!=======================================================================
!
!  PROGRAM  PHASE/0 2014.01 (rev.375)
!
!  "First-principles Electronic Structure Calculation Program"
!
!  PROGRAM: vdW-Soler
!
!  AUTHOR(S): Y. Ono
!  
!  Contact address :  Phase System Consortium
!                     E-mail: phase_system@nims.go.jp URL https://azuma.nims.go.jp
!  
!
!
!=======================================================================
!
!   The original version of this set of the computer programs "PHASE" was developed by 
!  the members of the Theory Group of Joint Research Center for Atom Technology 
!  (JRCAT), based in Tsukuba, in the period 1993-2001.  
!   Since 2002, this program set had been intensively developed as a part of the following 
!  national projects supported by the Ministry of Education, Culture, Sports, Science and 
!  Technology (MEXT) of Japan; "Frontier Simulation Software for Industrial Science 
!  (FSIS)" from 2002 to 2005, "Revolutionary Simulation Software (RSS21)" from 2006 to 
!  2008. "Research and Development of Innovative Simulation Software (RISS)" from 2008 
!  to 2013. These projects is lead by the Center for Research on Innovative Simulation 
!  Software (CISS), the Institute of Industrial Science (IIS), the University of Tokyo.
!   Since 2013, this program set has been further developed centering on PHASE System 
!  Consortium. 
!   The activity of development of this program set has been supervised by Takahisa Ohno.
!

!********************************** Note ******************************************
! This program calculates the non-local correlation energy (Ecnl) and 
! the local correlation energy (EcLDA) as the post calculation by utilizing
! the output files from the PHASE. By adding these correlation terms as
!    E_total = E_total(GGAx) + EcLDA + Ecnl,
! the van der Waals interaction will be included into the total energy.
!
! This program follows the Dion et al's 1-shot method (so called vdW-DF), and 
! the Roman-Perez et al's convolution algorithm. Because of this convolution,
! the CPU cost in this program is reduced to O(NlogN) from the original O(N**2).
!                                 (Reference; M.Dion et al. PRL 92 (2004) 246401.)
!                         (Reference; G.Roman-Perez et al. PRL 103 (2009) 096102.)
!
!
! Periodic systems are assumed.
! The atomic units (Hartree) are used.
!
!
!
! ++++++++ List of subroutines ++++++
! All subroutine files listed below are included in this file.
! In addition to the below list, it is necessary to link to a FFT library, for example FFTW3.
!
! CPU_TIME             : Check the calculation time.
! derivation           : Calculate the derivations of the electron density distribution.
! d_q0                 : Obtain q(rho(r)) from the electron density rho(r) and its derivations.
! spline               : Determine the function 'p(q)' for bi-cubic spline interpolation. 
!                        Here p(r) is defined as, phi(q1,q2,r12) = SUM_ab(p(qa)*p(qb)*phi(qa,qb,r12)).
! theta_ab             : Multiply theta(r) = p(r)*rho(r) by use of the given parameter qa or qb.
! RtoG                 : Calculate the Fourier transform of theta(r) within the FFT algorithm.
! phiab                : Calculate the Fourier transform of the kernel phi(r) by use of the given 
!                        parameter qa and qb. phi(r) does not depends on angular components,
!                        so that it can be done within the radial mesh.
! convolution_3d       : Calculate the integral SUM(dk*theta_a(k)*theta_b(k)*phi(k)).
! piDphi               : Calculate the local part of dr**2*rho(r1)*rho(r2)*phi(r1,r2,r12) directory.
!                        The local part includes the singular point, thus it is necessary to execute
!                        the 3D space integral directory.
! cLDA                 : Obtain the LDA version of correlation term EcLDA.
! outputs              : Output the results.
! kernel_phi           : Calculate the value of kernel phi(d1,d2).
! gauleg               : Prepare the grid points for the Gauss-Legendre integral.
!
!
!
! ++++++++ Input & Output +++++++++++
! Input files  (Both of the input files will be output by PHASE.)
!   nfchr.cube        : An electron density distribution file given by
!                       GGA(exchange only) calculation
!   nfefn.data        : The total energy given by GGA(exchange only) calculation
!
! Output   E_total(vdW-DF) = E_total(GGAx) + EcLDA + Ecnl
!   E_total(GGAx)     : Total energy given by GGA(exchange only) calculation
!   Ecnl              : Non-local Correlation energy
!   EcLDA             : LDA Correlation energy
!
!
!
! ++++++ Internal parameters ++++++++
! dq      (       )   : The smallest distance between the grid points for bi-cubic 
!                       spline interpolation. The grid points are plotted in logarithmic manner.
! lamda   (       )   : The power of dq
! nr12    (       )   : The number of the grid points for the kernel phi(r12)
! phi0    (       )   : One of the coefficients in the 'soft' function, 
!                       phi_s(r12) = phi0 + phi2*d**2 + phi4*d**4. phi2 and phi4 will be 
!                       eventually determined to match the value and the slope of phi_s and 
!                       those of phi at d=d_s, in the program.
! ds      (       )   : The connection point of phi_s and phi
! r12max  (       )   : The cutoff for r12
! rhomin  (       )   : Minimum value of electron density. 
!                       If the electron density was smaller than rhomin, then the program 
!                       will read as this minimum value in order to avoid a divergence.
! nk      (       )   : The number of the grid points plotted for the Fourier 
!                       transformed kernel phi(k)
! maxk    (       )   : The cutoff for k
!
!
!                                              Written by Youky Ono in June/2013
!**********************************************************************************


 Program vdW_Soler
 Implicit None


!++++++++++++++++++++++++++ VARIABLES ++++++++++++++++++++++++++
! Physical values
   Real(8) ExGGA,Ecnl,Ecnl_12,Ecnl_12_ab,Ecnl_3,Ecnl_3s,EcLDA

! Integers
   Integer i,j,k, cir,cia,cib,cic, cjr,cja,cjb,cjc, ckr,cka,ckb,ckc, ca,cb

! The unit cell and the electron density information
   Integer na,nb,nc,nabc
   Character*4   ::  acube,bcube
   Integer       ::  ncube
   Real(8) n1,n2,n3,dcube(3,3),aa(3,3),dv
   Real(8), Allocatable :: rho(:,:,:),dxrho(:,:,:),dyrho(:,:,:),dzrho(:,:,:),atom(:,:)


! Grid points
!!!! Spline curves
      Integer nq0,cqa,cqb
      Real(8) q0,qa,qb,q0max,q0min,lamda,dq,q0cut
      Parameter (dq=0.05, lamda=1.03, q0cut=3)
      Real(8), Allocatable :: mW(:,:)

!!!! The table of phidD
      Real(8) ds
      Parameter (ds=0.05)

!!!! The function phi_ab
      Integer nr12,cr12
      Parameter (nr12=4500)
      Real(8) r12,r12max,phi0,phi_ab(0:nr12)
      Parameter (phi0=2.77, r12max=15)
! End Grid points


! Internal parameters
   Real(8) rhomin 
   Parameter (rhomin=1d-9)

! Real-space and reciprocal-space Functions
   Complex*16, Allocatable :: theta_G(:,:,:),     &
&                             theta_G_ab(:,:,:,:),theta_G_a(:,:,:),theta_G_b(:,:,:)
   Real(8), Allocatable :: theta_R(:,:,:)

! Variables for check
   Real(8) term1,term2,term3,term4,term5,q1,q2,n,nnx,nny,nnz

! Estimate running time
   Real(8) time
   Integer hh,mm,ss
!++++++++++++++++++++++++ end VARIABLES ++++++++++++++++++++++++



!++++++++++++++ Read the file nfefn.data and nfchr.cube ++++++++
!++++++++++++++ and be ready for the calculation +++++++++++++++
   Call CPU_TIME(time)

   i = 0
   Open(7,FILE='nfefn.data',status='old')
   Do
     Read(7,'()',END=999)
     i = i + 1
   Enddo
   999 close(7)
   Open(6,file='nfefn.data')
   Read(6,*) acube
   Do j = 1,i-1
     Read(6,*) n1,n2,n3
   Enddo
   ExGGA = n3
   Close(6)

   Open(5,file='nfchr.cube')
   Read(5,*) acube
   Read(5,*) bcube

   Read(5,*) ncube,n1,n2,n3
   Read(5,*) na,aa(1,1),aa(1,2),aa(1,3)
   Read(5,*) nb,aa(2,1),aa(2,2),aa(2,3)
   Read(5,*) nc,aa(3,1),aa(3,2),aa(3,3)
   Allocate(atom(ncube,5))

   Read(5,*) ((atom(i,j),j=1,5),i=1,ncube)
   Allocate(rho(na,nb,nc))
      Read(5,*) (((rho(i,j,k),k=1,nc),j=1,nb),i=1,na)
   Close(5)

   Allocate(dxrho(na,nb,nc))
   Allocate(dyrho(na,nb,nc))
   Allocate(dzrho(na,nb,nc))
   Allocate(theta_G(-(na/2-1):na/2,-(nb/2-1):nb/2,-(nc/2-1):nc/2))
   Allocate(theta_R(na,nb,nc))
   Allocate(theta_G_a(-(na/2-1):na/2,-(nb/2-1):nb/2,-(nc/2-1):nc/2))
   Allocate(theta_G_b(-(na/2-1):na/2,-(nb/2-1):nb/2,-(nc/2-1):nc/2))

   Call derivation(na,nb,nc,aa,rho,dv,dxrho,dyrho,dzrho)

   q0max = q0cut*1.01
   q0min = 0.09

   nq0 = NINT(LOG((q0max-q0min)*(lamda-1.0)/dq+1.0)/LOG(lamda))+1
!   write(*,*) q0max,q0min,nq0

   Allocate(mW(nq0,nq0))
   Allocate(theta_G_ab(nq0,-(na/2-1):na/2,-(nb/2-1):nb/2,-(nc/2-1):nc/2))

   Call spline(nq0,dq,lamda,mW)
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++



!!! HOT Spot !!!
!+++++++++++++++ Execute FFT for theta_R_ab ++++++++++++++++++++
   Do cqa = 1,nq0
      Call theta_ab(na,nb,nc,cqa,nq0,q0min,q0max,dq,lamda,rho,dxrho,dyrho,dzrho,rhomin,mW,theta_R)
      Call RtoG(na,nb,nc,theta_R,theta_G)
      Do cia = -(na/2-1),na/2
      Do cib = -(nb/2-1),nb/2
      Do cic = -(nc/2-1),nc/2
         theta_G_ab(cqa,cia,cib,cic) = theta_G(cia,cib,cic)
      Enddo
      Enddo
      Enddo
   Enddo
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++



!+++++++++++++++ Start double-roop cqa and cqb +++++++++++++++++
   Ecnl_12 = 0.0
! When cqa < cqb
   Do cqa = 1,nq0-1
      Do cia = -(na/2-1),na/2
      Do cib = -(nb/2-1),nb/2
      Do cic = -(nc/2-1),nc/2
         theta_G_a(cia,cib,cic) = theta_G_ab(cqa,cia,cib,cic)
      Enddo
      Enddo
      Enddo

      Do cqb = cqa+1,nq0
         Do cia = -(na/2-1),na/2
         Do cib = -(nb/2-1),nb/2
         Do cic = -(nc/2-1),nc/2
            theta_G_b(cia,cib,cic) = theta_G_ab(cqb,cia,cib,cic)
         Enddo
         Enddo
         Enddo

         Call phiab(cqa,cqb,nr12,r12max,ds,nq0,q0min,dq,lamda,phi0,phi_ab)
         Call convolution_3d(nq0,na,nb,nc,cqa,cqb,aa,nr12,r12max,theta_G_a,theta_G_b,phi_ab,Ecnl_12_ab)

         Ecnl_12 = Ecnl_12 + Ecnl_12_ab

      Enddo
   Enddo

   Ecnl_12 = Ecnl_12 * 2.0


! When cqa = cqb
   Do cqa = 1,nq0
      cqb = cqa
      Do cia = -(na/2-1),na/2
      Do cib = -(nb/2-1),nb/2
      Do cic = -(nc/2-1),nc/2
         theta_G_a(cia,cib,cic) = theta_G_ab(cqa,cia,cib,cic)
         theta_G_b(cia,cib,cic) = theta_G_ab(cqb,cia,cib,cic)
      Enddo
      Enddo
      Enddo

      Call phiab(cqa,cqb,nr12,r12max,ds,nq0,q0min,dq,lamda,phi0,phi_ab)
      Call convolution_3d(nq0,na,nb,nc,cqa,cqb,aa,nr12,r12max,theta_G_a,theta_G_b,phi_ab,Ecnl_12_ab)

      Ecnl_12 = Ecnl_12 + Ecnl_12_ab

   Enddo
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++



!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   Call piDphi(na,nb,nc,rho,dxrho,dyrho,dzrho,rhomin,q0min,q0max,dv,ds,Ecnl_3,Ecnl_3s,phi0)
   Call cLDA(na,nb,nc,rho,rhomin,dv,EcLDA)
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++



!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   Call outputs(ExGGA,EcLDA,Ecnl_12,Ecnl_3,Ecnl_3s)
   Call CPU_TIME(time)
      ss=time
      hh=time/3600
      ss=Mod(ss,3600)
      mm=ss/60
      ss=Mod(ss,60)
      time=time-3600*hh-60*mm-ss
      Write(*,16) hh,mm,ss+time
 16    Format('# Calculation time ',I5,':',I2,':',F7.4)
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


 End Program vdW_Soler
!*******************************************************************************************************
!*** End of the main program  **************************************************************************
!*******************************************************************************************************





!** SUBROUTINE CPU_TIME ********************************************************************************
 Subroutine CPU_TIME(time)
   REAL(8) time
   Integer count,count_rate,hh,mm,ss

   Call System_clock(count,count_rate)
   If(count_rate.Eq.0) Then
      time=REAL(count)/count_rate
   Else
      time=-1
   End If

 End Subroutine CPU_TIME
!** End SUBROUTINE CPU_TIME ****************************************************************************



!** SUBROUTINE gauleg **********************************************************************************
 Subroutine gauleg(x1,x2,n,xi,wi)
 Implicit none


!++++++++++++++++++++++++++ VARIABLES ++++++++++++++++++++++++++
   Integer  m,j,i,n
   REAL(8)  x1,x2,z1,z,xm,xl,pp,p3,p2,p1,pi,eta
   Parameter (pi=3.1415926535897932 , eta=0.0000000001)

   REAL(8)  ::  xi(n),wi(n)
!++++++++++++++++++++++++ end VARIABLES ++++++++++++++++++++++++



!---------------------- Calculation Start ----------------------
   m=(n+1)/2
   xm=0.5*(x2+x1)
   xl=0.5*(x2-x1)
   Do i=1,m
      z=COS(pi*(i-0.25)/(n+0.5))
      z1=1.d+10
      Do While (ABS(z-z1).GT.eta)
         p1=1.0
         p2=0.0

         Do j=1,n
            p3=p2
            P2=p1
            p1=((2.0*j-1.0)*z*p2-(j-1.0)*p3)/j
         Enddo

         pp=n*(z*p1-p2)/(z*z-1.0)
         z1=z
         z=z1-p1/pp

      Enddo

      xi(i) = xm-xl*z
      xi(n+1-i) = xm+xl*z
      wi(i) = 2.0*xl/((1.0-z*z)*pp*pp)
      wi(n+1-i) = wi(i)

   Enddo
 End Subroutine gauleg
!** End SUBROUTINE gauleg ******************************************************************************



!** SUBROUTINE piDphi **********************************************************************************
 Subroutine piDphi(nx,ny,nz,rho,dxrho,dyrho,dzrho,rhomin,q0min,q0max,dv,ds,Ecii,Ecii_s,phi0)
 implicit none


!++++++++++++++++++++++++++ VARIABLES ++++++++++++++++++++++++++
   Integer  nx,ny,nz,nspin
   Real(8) da,db,a1,a2,dr
   Parameter (dr = 0.001)
   Integer  ci,cj,ck,ca,cb

! Gauss-Legendre integration
   Integer cD,nD
   Parameter (nD=10)
   Real(8) rhomin,maxD,minD,dD,LD,PLD,LDxi(nD),LDwi(nD)
   Parameter (minD=0)

   Integer  cix,ciy,ciz,cir,cjx,cjy,cjz,cjr
   Real(8)  di,dj,dk,d_di,d_dj,d_dk,eta,dx,dy,dz,dv,n,ni,nj,nk
   Integer  i,j,k,zxp,zxm,zyp,zym,zzp,zzm
!   Parameter (eta=0.00000001)

   Real(8) x,nnx,nny,nnz,nn2,r,r12
   Real(8) nxp,nxm,nyp,nym,nzp,nzm
   Real(8) zx(-3:3),zy(-3:3),zz(-3:3),rn(3,-3:3)
   Real(8)  ::  rho(nx,ny,nz) &
&            ,dxrho(nx,ny,nz),dyrho(nx,ny,nz),dzrho(nx,ny,nz)

   Real(8) pi,q0,term,term1,term2,q0min,q0max
   Parameter (pi=3.1415926535897932)

   Real(8) phi

   Real(8) Ecii,Ecii_s,temp,ds,rs,phid_s,phid_s1,d_phid_s,phi0,phi2,phi4

! The table of phi1D
      Integer c1D,n1D
      Parameter(n1D = 1000)
      Real(8) d1D,max1D,D,phix,phiy
      Real(8) phi1D(0:n1D+1)
!++++++++++++++++++++++++ end VARIABLES ++++++++++++++++++++++++



!---------------------- Calculation Start ----------------------
! Make the table of phi1D
 max1D = ds
 d1D = max1D/REAL(n1D)
 Do c1D = 0,n1D+1
    D = REAL(c1D)*d1D
    Call kernel_phi(D,D,phi)
    phi1D(c1D) = phi
 Enddo


 Ecii = 0
 Do cjr = 1,nx*ny*nz
    cjx = 1+(cjr-1-MOD(cjr-1+ny*nz,ny*nz))/(ny*nz)
    cjy = 1+(cjr-ny*nz*(cjx-1)-1-MOD(cjr-1+nz,nz))/nz
    cjz = cjr-nz*(ny*(cjx-1)-1+cjy)

    n = MAX(rho(cjx,cjy,cjz),rhomin)

    nnx = dxrho(cjx,cjy,cjz)
    nny = dyrho(cjx,cjy,cjz)
    nnz = dzrho(cjx,cjy,cjz)

    Call d_q0(n,nnx,nny,nnz,q0min,q0max,q0)
    maxD=ds

    Call gauleg(minD,maxD,nD,LDxi,LDwi)

    temp = 0
    Do cD=1,nD
       LD = LDxi(cD)

        c1D = AINT(LD/d1D)
        phix = LD - d1D*REAL(c1D)
        phiy = 1.0 - phix
        temp = temp + LDwi(cD)*4*pi*(LD**2) * (phiy*phi1D(c1D) + phix*phi1D(c1D+1))

    Enddo

    Ecii = Ecii + dv*0.5*(n**2)*temp/(q0**3)

 Enddo


 Ecii_s = 0
 Do cjr = 1,nx*ny*nz
    cjx = 1+(cjr-1-MOD(cjr-1+ny*nz,ny*nz))/(ny*nz)
    cjy = 1+(cjr-ny*nz*(cjx-1)-1-MOD(cjr-1+nz,nz))/nz
    cjz = cjr-nz*(ny*(cjx-1)-1+cjy)

    n = MAX(rho(cjx,cjy,cjz),rhomin)

    nnx = dxrho(cjx,cjy,cjz)
    nny = dyrho(cjx,cjy,cjz)
    nnz = dzrho(cjx,cjy,cjz)

! Coefficients phi2 and phi4 in the local part is determined to
! match the non-local part in value and slope at d=d_s.

    Call d_q0(n,nnx,nny,nnz,q0min,q0max,q0)
    rs = ds/SQRT(q0**2+q0**2)
    di = q0*rs
    dk = q0*rs
    c1D = AINT(di/d1D)
    phix = di - d1D*REAL(c1D)
    phiy = 1.0 - phix
    phid_s = phiy*phi1D(c1D) + phix*phi1D(c1D+1)

    di = q0*(rs+dr)
    dk = q0*(rs+dr)
    c1D = AINT(di/d1D)
    phix = di - d1D*REAL(c1D)
    phiy = 1.0 - phix
    phid_s1 = phiy*phi1D(c1D) + phix*phi1D(c1D+1)

    d_phid_s = (phid_s1- phid_s)/dr

    phi2 = ( 2.0/ds**2)*(phid_s-phi0) - (rs/(2.0*ds**2))*d_phid_s
    phi4 = (-1.0/ds**4)*(phid_s-phi0) + (rs/(2.0*ds**4))*d_phid_s

    Ecii_s = Ecii_s + 0.5*4*pi*dv*(n**2)*                   &
&                    (phi0*(rs**3)*(q0**0)/3.0 +            &
&                     phi2*(rs**5)*(q0**2)/5.0 +            &
&                     phi4*(rs**7)*(q0**4)/7.0)


 Enddo

 End Subroutine piDphi
!** End SUBROUTINE piDphi **********************



!** SUBROUTINE cLDA ****************************
 Subroutine cLDA(nx,ny,nz,rho,rhomin,dv,EcLDA)
 Implicit none

!************************ Note *********************************
! This Algorism follows Dion's 1-shot method.
!
! This program is a subroutine.
! This program calculates the correlation energy from LDA.
! The formula is given at Eq.(58) (p.93) of 'Theory of the
!   Inhomogeneous Electron Gas' Lundqvist, March.
!
!
! Input
!   rho(nrxyz,nsipn) : Total density
!
! Output
!   EcLDA : Corrilation energy from LDA.
!
!
!                            Written by Youky Ono in 2009/Jul.
!***************************************************************



!++++++++++++++++++++++++++ VARIABLES ++++++++++++++++++++++++++
      integer  nx,ny,nz,nspin
      integer  ci,cj,ck,cjx,cjy,cjz
      real(8)  dx,dy,dz,dv,eta
      integer  i,j,k
      parameter (eta=0.00000001)

      real(8) rs,x,aB,ec,EcLDA,n,rhomin
      real(8)  ::  rho(nx,ny,nz)
      parameter (aB=1) ! aB=1[a.u.]

      real(8)  pi,e,m
      parameter (pi=3.1415926535897932)
      parameter (e=1,m=1) ! Hatree atomic unit
!++++++++++++++++++++++++ end VARIABLES ++++++++++++++++++++++++



!---------------------- Calculation Start ----------------------
      EcLDA=0
   Do cjx=1,nx
   Do cjy=1,ny
   Do cjz=1,nz
      n = MAX(rho(cjx,cjy,cjz),rhomin)

      rs = ((3/(4*pi*n))**0.3333333333333333)/aB
      x = rs/11.4
      ec = -0.0666*0.5*((1+x**3)*LOG(1+1/x)-x**2+x/2-1/3)

      EcLDA = EcLDA + dv*n*ec

   Enddo
   Enddo
   Enddo


 End Subroutine cLDA
!** End SUBROUTINE cLDA **********************



!** SUBROUTINE RtoG ***************************************************************************
! Execute FFT and transform theta_R to theta_G
  Subroutine RtoG(na,nb,nc,theta_R,theta_G)
  Implicit none

  include "fftw3.f"


!++++++++++++++++++++++++++ VARIABLES ++++++++++++++++++++++++++
  Integer  na,nb,nc,cix,ciy,ciz,ca,cb,cc
  Real(8) rx,ry,rz,kx,ky,kz,ra,rb,rc,ka,kb,kc,rk,r12,x,y,z,term,term1

  Real(8) theta_R(na,nb,nc)
  Complex*16 theta_G(-(na/2-1):na/2,-(nb/2-1):nb/2,-(nc/2-1):nc/2)

! FFTW3 !!!
  integer(8) :: plan
!  Integer(8) plan,FFTW_FORWARD,FFTW_ESTIMATE
!  Parameter(FFTW_FORWARD=-1, FFTW_ESTIMATE=64)
!!$  Complex*16 temp_R(na,nb,nc),temp_G(0:na-1,0:nb-1,0:nc-1)
  Complex*16,allocatable :: temp_R(:,:,:),temp_G(:,:,:)
!+++++++++++++++++++++ End VARIABLES +++++++++++++++++++++++++++

  allocate(temp_R(na,nb,nc))
  allocate(temp_G(0:na-1,0:nb-1,0:nc-1))

!***** FFT **************************************************
  Do cix = 1,na
  Do ciy = 1,nb
  Do ciz = 1,nc
     temp_R(cix,ciy,ciz) = CMPLX(theta_R(cix,ciy,ciz))
  Enddo
  Enddo
  Enddo

! FFTW3 !!!
  call dfftw_plan_dft_3d(plan,na,nb,nc,temp_R,temp_G,FFTW_FORWARD,FFTW_ESTIMATE)
  call dfftw_execute_dft(plan,temp_R,temp_G)
  call dfftw_destroy_plan(plan)

  Do ca = -(na/2-1),na/2
  Do cb = -(nb/2-1),nb/2
  Do cc = -(nc/2-1),nc/2
     cix = MOD(ca+na,na)
     ciy = MOD(cb+nb,nb)
     ciz = MOD(cc+nc,nc)
     theta_G(ca,cb,cc) = temp_G(cix,ciy,ciz) / REAL(na*nb*nc)
  Enddo
  Enddo
  Enddo
!***** END of FFT ******************************************

  deallocate(temp_R)
  deallocate(temp_G)
End subroutine RtoG
!** End SUBROUTINE RtoG ***********************************************************************



!** SUBROUTINE convolution_3d *****************************************************************
  Subroutine convolution_3d(nq0,na,nb,nc,cqa,cqb,aa,nr12,r12max,theta_G_a,theta_G_b,phi_ab,Ecnl_12_ab)

  Implicit none


!++++++++++++++++++++++++++ VARIABLES ++++++++++++++++++++++++++
  Integer i,j,k,cx1,nx1,cx2,nx2,cx,nx,nx3,nx4,cx12,nk,cr,ck,cqa,cqb,nq0
  Real(8) dx,dx1,dx2,maxk,x1,x2,x12,pi,T,s,func,dk
  Parameter(pi=3.14159265358979)
  Parameter(nk=7000, maxk=10)

  Complex*16 theta_G_a(-(na/2-1):na/2,-(nb/2-1):nb/2,-(nc/2-1):nc/2)
  Complex*16 theta_G_b(-(na/2-1):na/2,-(nb/2-1):nb/2,-(nc/2-1):nc/2)
  Complex*16 temp_c

  Integer  nabc,na,nb,nc,ncube
  Real(8)  n1,n2,n3,aa(3,3),bb(3,3),ak(3,3),dv,dvk,phix,phiy,Ta,Tb,Tc

  Integer cix,ciy,ciz,cir,cjx,cjy,cjz,cjr,ckx,cky,ckz,ckr,nkx,nky,nkz,ca,cb,cc
  Real(8) rx,ry,rz,kx,ky,kz,ra,rb,rc,ka,kb,kc,rk,r12,x,y,z,term,term1

  Integer nr12
!  Real(8) theta_a(na,nb,nc),theta_b(na,nb,nc),phi_ab(0:nr12),dr12,r12max,Ecnl_12_ab
  Real(8) phi_ab(0:nr12),dr12,r12max,Ecnl_12_ab
!  Real(8) core_G(0:nk-1)
  Real(8),allocatable :: core_G(:)
!+++++++++++++++++++++ End VARIABLES +++++++++++++++++++++++++++


  allocate(core_G(0:nk-1))

  nabc = na*nb*nc

  dv = aa(1,1)*(aa(2,2)*aa(3,3)-aa(2,3)*aa(3,2)) &
&    + aa(1,2)*(aa(2,3)*aa(3,1)-aa(2,1)*aa(3,3)) &
&    + aa(1,3)*(aa(2,1)*aa(3,2)-aa(2,2)*aa(3,1))

  Ta = na*SQRT(aa(1,1)**2 + aa(1,2)**2 + aa(1,3)**2)
  Tb = nb*SQRT(aa(2,1)**2 + aa(2,2)**2 + aa(2,3)**2)
  Tc = nc*SQRT(aa(3,1)**2 + aa(3,2)**2 + aa(3,3)**2)


!***** Make the core function and execute 3d-FFT by hand *****
  dr12 = r12max/REAL(nr12)
  dk = maxk/REAL(nk-1)

  Do ck = 0,0
     rk = dk * Real(ck)
     term = 0
     Do cr = 0,nr12
        r12 = dr12*Real(cr)
        term = term + phi_ab(cr) * (r12**2)
     Enddo
     core_G(ck) = 4.0*pi*dr12 * term
  End do

  Do ck = 1,nk-1
     rk = dk * Real(ck)
     term = 0
     Do cr = 0,nr12
        r12 = dr12*Real(cr)
        term = term + phi_ab(cr) * r12 * SIN(2.0*pi*rk*r12)
     Enddo
     core_G(ck) = 2.0 * dr12 * term / rk
  End do
!***** END of Make the core function *************************



!***** Calculate 'theta_G_a*core_G*theta_G_b'  ***************
  dk = maxk/REAL(nk-1)
  temp_c = (0.0,0.0)
  Do cix = -(na/2-1),na/2
  Do ciy = -(nb/2-1),nb/2
  Do ciz = -(nc/2-1),nc/2

     rk = SQRT((REAL(cix)/Ta)**2 + (REAL(ciy)/Tb)**2 + (REAL(ciz)/Tc)**2)

     If(rk.LT.maxk) Then
        ck = AINT(rk/dk)
        phix = rk - dk*REAL(ck)
        phiy = 1.0 - phix
        term = phiy*core_G(ck) + phix*core_G(ck+1)
     Else
        term = 0.0
     Endif

     temp_c = temp_c +                       &
&           CONJG(theta_G_a(cix,ciy,ciz)) *  &
&                 theta_G_b(cix,ciy,ciz)  *  &
&                 term

  Enddo
  Enddo
  Enddo

  temp_c = temp_c * dv*nabc
  Ecnl_12_ab = 0.5*REAL(temp_c)
!***** End Calculate 'theta_G_a*core_G*theta_G_b'  ***********

  deallocate(core_G)


End subroutine convolution_3d
!** End SUBROUTINE convolution_3d *************************************************************



!** SUBROUTINE d_q0 ***************************************************************************
   Subroutine d_q0(n,nnx,nny,nnz,q0min,q0max,q0)
      Implicit None


!************************ Note *********************************
! This program calculates q0.
!
! Input
!   rho(nrxyz,nsipn) : Total density
!
! Output
!   q0               : 
!
!
!
!                            Written by Youky Ono
!***************************************************************



!++++++++++++++++++++++++++ VARIABLES ++++++++++++++++++++++++++
      Double Precision n,rs,x,nnx,nny,nnz,nn2,r,term1,term2,term3

      Double precision  kF,exc0,exLDA,excLDA,pi,Zab,q0,m,h,e,GxcLDA,eta,q0min,q0max
      Parameter (pi=3.1415926535897932)
      Parameter (e=1.0,m=1.0)
      Parameter (Zab=-0.8491)

!++++++++++++++++++++++++ end VARIABLES ++++++++++++++++++++++++



!---------------------- Calculation Start ----------------------
      nn2 = (nnx**2)+(nny**2)+(nnz**2)

      rs = (3/(4*pi*n))**0.3333333333333333

! Eq.(58), (59) (p.93-94) of Theory of the Inhomogeneous Electron gas.
! S.Lundqvist and N.H.March 1983 Plenum Press, NY
      x = rs/11.4
      GxcLDA = 0.5*((1+x**3)*Log(1+1/x)-x**2+x/2-1/3)
      excLDA = -0.458/rs-0.0666*GxcLDA

      kF = (3*pi*pi*n)**0.3333333333333333
      exLDA = -3*e*kF/(4*pi)

! Eq.(12) of Dion PRL92,246401
      term1 = exLDA*Zab*nn2/(6*kF*n)
      term2 = term1/(6*kF*n)

      exc0 = excLDA - term2


! Eq.(11) of Dion PRL92,246401
      q0 = MIN(exc0*kF/exLDA,q0max)
      q0 = MAX(q0,q0min)

   End Subroutine d_q0
!** End SUBROUTINE d_q0 ***********************************************************************



!** SUBROUTINE derivation *********************************************************************
 Subroutine derivation(na,nb,nc,aa,rho,dv,dxrho,dyrho,dzrho)
 Implicit none


!++++++++++++++++++++++++++ VARIABLES ++++++++++++++++++++++++++
! Integers
   Integer i,j,k,cx,cy,cz

! The unit cell and the electron density information
   Integer na,nb,nc,nabc
   Real(8) dv,aa(3,3),rho(na,nb,nc),dxrho(na,nb,nc),dyrho(na,nb,nc),dzrho(na,nb,nc)

! Internal valuables
   Integer zx(-3:3),zy(-3:3),zz(-3:3)
   Real(8) rn(3,-3:3),detr,bb(3,3)
!!$   Real(8) darho(na,nb,nc),dbrho(na,nb,nc),dcrho(na,nb,nc)
   Real(8),allocatable ::  darho(:,:,:),dbrho(:,:,:),dcrho(:,:,:)
!+++++++++++++++++++++ End VARIABLES +++++++++++++++++++++++++++

   allocate(darho(na,nb,nc));darho=0.d0
   allocate(dbrho(na,nb,nc));dbrho=0.d0
   allocate(dcrho(na,nb,nc));dcrho=0.d0
   dv = aa(1,1)*(aa(2,2)*aa(3,3)-aa(2,3)*aa(3,2)) &
&     + aa(1,2)*(aa(2,3)*aa(3,1)-aa(2,1)*aa(3,3)) &
&     + aa(1,3)*(aa(2,1)*aa(3,2)-aa(2,2)*aa(3,1))

   Do cx = 1,na
   Do cy = 1,nb
   Do cz = 1,nc

   Do j = -3,3
      zx(j) = MOD(2*na+(cx+j)-1,na)+1
      zy(j) = MOD(2*nb+(cy+j)-1,nb)+1
      zz(j) = MOD(2*nc+(cz+j)-1,nc)+1

      rn(1,j) = rho(zx(j),cy,cz)
      rn(2,j) = rho(cx,zy(j),cz)
      rn(3,j) = rho(cx,cy,zz(j))
   Enddo

   darho(cx,cy,cz) = &
&     (rn(1,3)-9.0*rn(1,2)+45.0*rn(1,1)-45.0*rn(1,-1)+9.0*rn(1,-2)-rn(1,-3))/(60.0)
   dbrho(cx,cy,cz) = &
&     (rn(2,3)-9.0*rn(2,2)+45.0*rn(2,1)-45.0*rn(2,-1)+9.0*rn(2,-2)-rn(2,-3))/(60.0)
   dcrho(cx,cy,cz) = &
&     (rn(3,3)-9.0*rn(3,2)+45.0*rn(3,1)-45.0*rn(3,-1)+9.0*rn(3,-2)-rn(3,-3))/(60.0)
   Enddo
   Enddo
   Enddo

   detr = (aa(1,1)*aa(2,2)*aa(3,3)+aa(1,2)*aa(2,3)*aa(3,1)+aa(1,3)*aa(2,1)*aa(3,2)) &
&       - (aa(1,1)*aa(2,3)*aa(3,2)+aa(1,2)*aa(2,1)*aa(3,3)+aa(1,3)*aa(2,2)*aa(3,1))

   bb(1,1) =  (aa(2,2)*aa(3,3)-aa(2,3)*aa(3,2))/detr
   bb(2,1) = -(aa(2,1)*aa(3,3)-aa(2,3)*aa(3,1))/detr
   bb(3,1) =  (aa(2,1)*aa(3,2)-aa(2,2)*aa(3,1))/detr
   bb(1,2) = -(aa(1,2)*aa(3,3)-aa(1,3)*aa(3,2))/detr
   bb(2,2) =  (aa(1,1)*aa(3,3)-aa(1,3)*aa(3,1))/detr
   bb(3,2) = -(aa(1,1)*aa(3,2)-aa(1,2)*aa(3,1))/detr
   bb(1,3) =  (aa(1,2)*aa(2,3)-aa(1,3)*aa(2,2))/detr
   bb(2,3) = -(aa(1,1)*aa(2,3)-aa(1,3)*aa(2,1))/detr
   bb(3,3) =  (aa(1,1)*aa(2,2)-aa(1,2)*aa(2,1))/detr

   Do cx = 1,na
   Do cy = 1,nb
   Do cz = 1,nc

   dxrho(cx,cy,cz) = &
&    (bb(1,1)*darho(cx,cy,cz) + bb(1,2)*dbrho(cx,cy,cz) + bb(1,3)*dcrho(cx,cy,cz))
   dyrho(cx,cy,cz) = &
&    (bb(2,1)*darho(cx,cy,cz) + bb(2,2)*dbrho(cx,cy,cz) + bb(2,3)*dcrho(cx,cy,cz))
   dzrho(cx,cy,cz) = &
&    (bb(3,1)*darho(cx,cy,cz) + bb(3,2)*dbrho(cx,cy,cz) + bb(3,3)*dcrho(cx,cy,cz))

   Enddo
   Enddo
   Enddo

   deallocate(darho)
   deallocate(dbrho)
   deallocate(dcrho)

 End subroutine derivation
!** End SUBROUTINE derivation *****************************************************************



!** SUBROUTINE kernel_phi *********************************************************************
      Subroutine kernel_phi(di,dk,phi)
      implicit none

!************************ Note *********************************
! This Algorism follows Dion's 1-shot method.
!
! This program is a subroutine.
! This program calculates the kernel function phi.
!
! Input
!
!
! Output
!   phi              : 
!                      
!
!
!                            Written by Youky Ono in 2013/Jan.
!***************************************************************



!++++++++++++++++++++++++++ VARIABLES ++++++++++++++++++++++++++
      Integer ca,na_gl,cb,nb
      Real(8) a,b,di,dk,h,gamma,v1,v2,v3,v4,W,T,phi
      Real(8) e,pi,m,a1,a2
      parameter (pi=3.1415926535897932)
      parameter (e=1,m=1)
      Parameter (na_gl=30, a1=0, a2=60)


! Gauss-Legendre integration
      Real(8) xi(na_gl),wi(na_gl)
!++++++++++++++++++++++++ end VARIABLES ++++++++++++++++++++++++



!---------------------- Calculation Start ----------------------
! Call gauleg for Gauss-Legendre integral
   Call gauleg(a1,a2,na_gl,xi,wi)


  gamma = 4*pi/9
  phi = 0
  Do ca=1,na_gl
  Do cb=1,ca

     a = xi(ca)
     b = xi(cb)

     h = 1-EXP(-gamma*((a/di)**2))
     v1 = (a**2)/(2*h)

     h = 1-EXP(-gamma*((b/di)**2))
     v2 = (b**2)/(2*h)

     h = 1-EXP(-gamma*((a/dk)**2))
     v3 = (a**2)/(2*h)

     h = 1-EXP(-gamma*((b/dk)**2))
     v4 = (b**2)/(2*h)

     W = 2*((3-a*a)*b*COS(b)*SIN(a) + (3-b*b)*a*COS(a)*SIN(b) &
&        + (a*a+b*b-3)*SIN(a)*SIN(b) &
&        -3*a*b*COS(a)*COS(b))/((a*b)**3)

! ((a*b)**2)*T
     T = ((a*b)**2) &
&        * 0.5*(1/(v1+v2) + 1/(v3+v4) ) &
&        * (1/((v1+v3)*(v2+v4)) + 1/((v1+v4)*(v2+v3)))

     phi = phi + wi(ca)*wi(cb)*W*T

  End Do
  End Do

  phi = phi * 2

  Do ca=1,na_gl
     cb=ca
     a = xi(ca)
     b = xi(cb)

     h = 1-EXP(-gamma*((a/di)**2))
     v1 = (a**2)/(2*h)

     h = 1-EXP(-gamma*((b/di)**2))
     v2 = (b**2)/(2*h)

     h = 1-EXP(-gamma*((a/dk)**2))
     v3 = (a**2)/(2*h)

     h = 1-EXP(-gamma*((b/dk)**2))
     v4 = (b**2)/(2*h)

     W = 2*((3-a*a)*b*COS(b)*SIN(a) + (3-b*b)*a*COS(a)*SIN(b) &
&        + (a*a+b*b-3)*SIN(a)*SIN(b) &
&        -3*a*b*COS(a)*COS(b))/((a*b)**3)

! ((a*b)**2)*T
     T = ((a*b)**2) &
&        * 0.5*(1/(v1+v2) + 1/(v3+v4) ) &
&        * (1/((v1+v3)*(v2+v4)) + 1/((v1+v4)*(v2+v3)))

     phi = phi - wi(ca)*wi(cb)*W*T

  End Do

  phi = phi * 2*m*(e**4)/(pi**2)


      end Subroutine kernel_phi
!** End SUBROUTINE kernel_phi *****************************************************************



!** SUBROUTINE outputs ************************************************************************
 Subroutine outputs(ExGGA,EcLDA,Ecnl_12,Ecnl_3,Ecnl_3s)
 Implicit none

  Real(8) ExGGA,EcLDA,Ecnl_12,Ecnl_3,Ecnl_3s,Ecnl

  Ecnl = Ecnl_12 + Ecnl_3 - Ecnl_3s

   Write(*,*)  ' '
   Write(*,11) ExGGA
   Write(*,*)  ' '
   Write(*,12) EcLDA
   Write(*,13) Ecnl
   Write(*,14) EcLDA + Ecnl
   Write(*,*)  ' '
   Write(*,15) EcLDA + Ecnl + ExGGA
   Write(*,*)  ' '
 11    Format('E_total(GGA exchange)      = ',F19.13)

 12    Format('Ec(LDA)                    = ',F19.13)
 13    Format('Ec(nl)                     = ',F19.13)
 14    Format('Ec (= Ec(LDA) + Ec(nl) )   = ',F19.13)

 15    Format('E_total(vdW-DF)            = ',F19.13)

   Write(*,*)  '                  Given in Hartree atomic units'
   Write(*,*)  ' '


 End Subroutine outputs
!** End SUBROUTINE outputs ********************************************************************



!** SUBROUTINE phiab **************************************************************************
 Subroutine phiab(ca,cb,nr12,r12max,ds,nq0,q0min,dq,lamda,phi0,phi_ab)
 Implicit none



!++++++++++++++++++++++++++ VARIABLES ++++++++++++++++++++++++++
   Integer ca,cb,nq0,nr12
   Real(8) dq,dq0,q0min,q0max,r12max,ds,phi0,lamda
   Real(8) phi_ab(0:nr12)

! Internal valuables
   Integer cr12,i
   Real(8) qab,qa,qb,r12,rs,phiD,dr12,phi2,phi4,phid_s,phid_s1,d_phid_s,d1,d2,abs_d
   Real(8) di,dk,tmp,dr
   Parameter(dr=0.001)
!+++++++++++++++++++++ End VARIABLES +++++++++++++++++++++++++++

  dr12 = r12max/REAL(nr12)
  qa = q0min + dq*(lamda**REAL(ca-1)-1.0)/(lamda-1.0)
  qb = q0min + dq*(lamda**REAL(cb-1)-1.0)/(lamda-1.0)
  qab = SQRT(qa**2+qb**2)

! Coefficients phi2 and phi4 in the local part is determined to
! match the non-local part in value and slope at d=d_s.

  rs = ds/qab

  di = qa*rs
  dk = qb*rs
  Call kernel_phi(di,dk,phid_s)

  di = qa*(rs+dr)
  dk = qb*(rs+dr)
  Call kernel_phi(di,dk,phid_s1)

  d_phid_s = (phid_s1 - phid_s)/dr

  phi2 = ( 2.0/ds**2)*(phid_s-phi0) - (rs/(2.0*ds**2))*d_phid_s
  phi4 = (-1.0/ds**4)*(phid_s-phi0) + (rs/(2.0*ds**4))*d_phid_s

  i = AINT((ds/qab)/dr12)

! Non-local part of phi_ab(r12)
  Do cr12 = i+1,nr12
     r12 = REAL(cr12)*dr12

     di = qa*r12
     dk = qb*r12

     Call kernel_phi(di,dk,tmp)
     phi_ab(cr12) = tmp

  Enddo

! Local part of phi_ab(r12)
  Do cr12 = 0,i
     r12 = REAL(cr12)*dr12

     d1 = qa*r12
     d2 = qb*r12
     phiD = qab*r12
     phi_ab(cr12) = phi0 + phi2*phiD**2 + phi4*phiD**4

  Enddo


 End subroutine phiab
!** End SUBROUTINE phiab **********************************************************************



!** SUBROUTINE spline *************************************************************************
 Subroutine spline(nq0,dq,lamda,mW)

   Implicit none

!************************ Note *********************************
! This Algorism follows Dion's 1-shot method.
! This program is a subroutine.
!
! Input
!   nq0               : Number of grid points
!   dq0               : Maximum and minimum of the variable q0
!
! Output
!   mW(nq0,nq0)       : Matrix elements of W
!
!                            Written by Youky Ono in 2012/Sep.
!***************************************************************



!++++++++++++++++++++++++++ VARIABLES ++++++++++++++++++++++++++
  Integer nq0
  Real(8) n,q0,dq0,dq,lamda

  Integer  i,j,k,m
  Real(8) mW(nq0,nq0)
  Real(8) temp

!  T=LU
  Real(8), Allocatable  ::  mT(:,:),mL(:,:),mU(:,:),miT(:,:),miL(:,:),miU(:,:), &
&                           mA(:),mB(:),mC(:),mV(:,:)
!++++++++++++++++++++++++ end VARIABLES ++++++++++++++++++++++++



!---------------------- Calculation Start ----------------------
!!! Prepare the matrix elements T=LU
  Allocate(mT(nq0,nq0))
  Allocate(mL(nq0,nq0))
  Allocate(mU(nq0,nq0))
  Allocate(mV(nq0,nq0))
  Allocate(miT(nq0,nq0))
  Allocate(miL(nq0,nq0))
  Allocate(miU(nq0,nq0))
  Allocate(mA(nq0))
  Allocate(mB(nq0))
  Allocate(mC(nq0))

  mT = 0.0
  mL = 0.0
  mU = 0.0
  mV = 0.0
  miT = 0.0
  miL = 0.0
  miU = 0.0
  mA = 0.0
  mB = 0.0
  mC = 0.0

!  dq0 = (q0max - q0min)/(REAL(nq0-1))
!  dq0 = 1.0

  Do i=1,nq0
  Do j=1,nq0
     mT(i,j) = 0.0
     mL(i,j) = 0.0
     mU(i,j) = 0.0
     mV(i,j) = 0.0
  End do
  End do
  Do i=1,nq0
     dq0 = dq*(lamda**REAL(i-1))
     mT(i,i) = (1.0/3.0)*dq0
       mA(i) = (1.0/3.0)*dq0
     mV(i,i) = -2.0*dq0**(-1.0)
  End do
  Do i=1,nq0-1
     dq0 = dq*(lamda**REAL(i-1))
     mT(i,i+1) = (1.0/6.0)*dq0
         mB(i) = (1.0/6.0)*dq0
     mV(i,i+1) = dq0**(-1.0)
     mT(i+1,i) = (1.0/6.0)*dq0
       mC(i+1) = (1.0/6.0)*dq0
     mV(i+1,i) = dq0**(-1.0)
  End do

  Do i=2,nq0
     mC(i) = -mC(i)/mA(i-1)
     mA(i) = mA(i) + mC(i)*mB(i-1)
  End do

  Do i=1,nq0
     mL(i,i) = 1.0
     mU(i,i) = mA(i)
  End do
  Do i=1,nq0-1
     mL(i+1,i) = -1.0*mC(i+1)
     mU(i,i+1) = mB(i)
  End do


!!! Calculate inverse matrix of L and U.
  Do i=1,nq0
  Do k=1,nq0

     If(i.EQ.k) then
        miL(i,k) = 1.0
        miU(i,k) = (mU(i,k))**(-1.0)
     Else if(i.LT.k) then
        miL(i,k) = 0.0

        temp = 1.0
        Do j = i,k
           temp = temp * (mU(j,j)**(-1.0))
        End do
        Do j = i,k-1
           temp = temp * mU(j,j+1)
        End do

        miU(i,k) = ((-1.0)**(k-i))*temp

     Else if(i.GT.k) then
        temp = 1.0
        Do j = k,i-1
           temp = temp * mL(j+1,j)
        End do
        miL(i,k) = ((-1.0)**(i-k))*temp
     End if

  End do
  End do


!!! iU*iL = iT
  Do i=1,nq0
  Do k=1,nq0
     temp = 0.0
     Do j=1,nq0
        temp = temp + miU(i,j)*miL(j,k)
     End do
     miT(i,k) = temp
  End do  
  End do


!!! iT*V = W
  Do i=1,nq0
  Do k=1,nq0
     temp = 0.0
     Do j=1,nq0
        temp = temp + miT(i,j)*mV(j,k)
     End do
     mW(i,k) = temp
  End do
  End do

  DeAllocate(mT)
  DeAllocate(mL)
  DeAllocate(mU)
  DeAllocate(mV)
  DeAllocate(miT)
  DeAllocate(miL)
  DeAllocate(miU)
  DeAllocate(mA)
  DeAllocate(mB)
  DeAllocate(mC)


  End Subroutine spline
!** End SUBROUTINE spline *********************************************************************



!** SUBROUTINE theta_ab ***********************************************************************
 Subroutine theta_ab(nx,ny,nz,ca,nq0,q0min,q0max,dq,lamda,rho,dxrho,dyrho,dzrho,rhomin,mW,theta_R)
 Implicit none


!++++++++++++++++++++++++++ VARIABLES ++++++++++++++++++++++++++
   Integer nx,ny,nz,ca,nq0
   Real(8) dq,dq0,q0min,q0max,rhomin,lamda
   Real(8) rho(nx,ny,nz),mW(nq0,nq0),dxrho(nx,ny,nz),  &
&          dyrho(nx,ny,nz),dzrho(nx,ny,nz),theta_R(nx,ny,nz)

! Internal valuables
   Integer cir,cix,ciy,ciz,i
   Real(8) ni,nnx,nny,nnz,q0,qi,qi1,A,B,C,D,del_ia,del_i1a,p
!+++++++++++++++++++++ End VARIABLES +++++++++++++++++++++++++++

! For the functions theta_R
  Do cir = 1,nx*ny*nz
     cix = 1+(cir-1-MOD(cir-1+ny*nz,ny*nz))/(ny*nz)
     ciy = 1+(cir-ny*nz*(cix-1)-1-MOD(cir-1+nz,nz))/nz
     ciz = cir-nz*(ny*(cix-1)-1+ciy)

     ni = MAX(rho(cix,ciy,ciz),rhomin)
     nnx = dxrho(cix,ciy,ciz)
     nny = dyrho(cix,ciy,ciz)
     nnz = dzrho(cix,ciy,ciz)

     q0 = q0max
     Call d_q0(ni,nnx,nny,nnz,q0min,q0max,q0)

     i = 1 + AINT(LOG(1.0+(lamda-1)*(q0-q0min)/dq)/LOG(lamda))
     qi  = q0min + dq*(lamda**REAL(i-1)-1.0)/(lamda-1.0)
     qi1 = q0min + dq*(lamda**REAL(i)-1.0)/(lamda-1.0)
     dq0 = dq*(lamda**REAL(i-1))

     A = (qi1 - q0)/dq0
     B = (q0 - qi)/dq0
     C = (A**3 - A)*(dq0**2)/6.0
     D = (B**3 - B)*(dq0**2)/6.0

     del_ia  = 0.0
     del_i1a = 0.0
     If(i.EQ.ca) Then
        del_ia  = 1.0
     Else if(i+1.EQ.ca) Then
        del_i1a = 1.0
     End if

     p = A*del_ia + B*del_i1a + C*mW(i,ca) + D*mW(i+1,ca)

     theta_R(cix,ciy,ciz) = p*ni

  End do


 End subroutine theta_ab
!** End SUBROUTINE theta_ab *******************************************************************
