! ************************************************************* 
!
!   This is a software package CIAO
!
!     developed as a part of the national project "Research and 
!     Development of Innovative Simulation software",which is   
!     supported by the next-generation IT program of MEXT of Japan
!
!   Version history: 
!
!     4.0:  2013/03/01
!           codes for spin-polarized pseudopotential generation are added
!     4.1:  2013/11/22 - 
!           Info of core wfns and energy contributions can be added to gncpp2
!     4.2:  2014/07/23 - 
!           gncpp2 can be geregated even when nmesh /= 1501
!
! ************************************************************* 
module dion_analysis
    use parameters
    implicit none
    private
    
    public:: write_dion
    
contains

    subroutine write_dion
        integer:: ln,tn,lm,tm
        integer:: lt,ltt,ltlt
        integer:: ll,ll_core,nn
        integer:: ir,mnrcl,ier
        integer,pointer:: nrcl(:,:)
        real(8):: r,tmp,dion_ae,dion_ps,dion_qps
        real(8),pointer:: vion_qps(:),vh_qps(:),vxc_qps(:)
        real(8),pointer:: vion_wps(:),vh_wps(:),vxc_wps(:),vloc_wps(:)
        real(8),pointer:: vion_wae(:),vh_wae(:),vxc_wae(:),vloc_wae(:),vcor_wae(:)
        real(8),pointer:: ekin_wps(:),ekin_wps2(:)
        real(8),pointer:: ekin_wae(:),ekin_wae2(:)
        real(8),pointer:: drphin(:),drphim(:),ddrphim(:)
        real(8),pointer:: drpsin(:),drpsim(:),ddrpsim(:)
        real(8),pointer:: wght(:),wght2(:)
        real(8),pointer:: emphnphm(:)
        real(8),pointer:: empsnpsm(:)
        real(8),pointer:: dh_ae(:),dh_ps(:),dh_qps(:)
        real(8):: bmat_tmp
        
        allocate(vion_qps(num_lttx_us))
        allocate(vh_qps(num_lttx_us))
        allocate(vxc_qps(num_lttx_us))
        allocate(vion_wps(num_lttx_us))
        allocate(vh_wps(num_lttx_us))
        allocate(vxc_wps(num_lttx_us))
        allocate(vloc_wps(num_lttx_us))
        allocate(vion_wae(num_lttx_us))
        allocate(vh_wae(num_lttx_us))
        allocate(vxc_wae(num_lttx_us))
        allocate(vloc_wae(num_lttx_us))
        allocate(vcor_wae(num_lttx_us))
        allocate(ekin_wps(num_lttx_us))
        allocate(ekin_wae(num_lttx_us))
        allocate(ekin_wps2(num_lttx_us))
        allocate(ekin_wae2(num_lttx_us))
        allocate(emphnphm(num_lttx_us))
        allocate(empsnpsm(num_lttx_us))
        allocate(dh_ae(num_lttx_us))
        allocate(dh_ps(num_lttx_us))
        allocate(dh_qps(num_lttx_us))
        allocate(drphin(nmesh))
        allocate(drphim(nmesh))
        allocate(ddrphim(nmesh))
        allocate(drpsin(nmesh))
        allocate(drpsim(nmesh))
        allocate(ddrpsim(nmesh))
        allocate(wght(nmesh))
        allocate(wght2(nmesh))
    
        vion_qps=0.d0
        vh_qps=0.d0
        vxc_qps=0.d0
        vion_wps=0.d0
        vh_wps=0.d0
        vxc_wps=0.d0
        vloc_wps=0.d0
        vion_wae=0.d0
        vh_wae=0.d0
        vxc_wae=0.d0
        vloc_wae=0.d0
        vcor_wae=0.d0
        wght=0.d0
        ekin_wps=0.d0
        ekin_wae=0.d0
        ekin_wps2=0.d0
        ekin_wae2=0.d0
        emphnphm=0.d0
        empsnpsm=0.d0
        drphin=0.d0
        drphim=0.d0
        drpsin=0.d0
        drpsim=0.d0
        dh_ae=0.d0
        dh_ps=0.d0
        dh_qps=0.d0
        
        allocate(nrcl(lmax+1,nref_max_us))
        do ln=0,lmax
            do tn=1,nref_us(ln)
                lt=lt_n_us(ln,tn)
                nrcl(ln+1,tn)=nrcut_phi_us(lt)
            end do
        end do

        if(is_core == PATOM) then
            ll_core=0
        else
            ll_core=lmax_core
        end if
        
        mnrcl=maxval(nrcl)
        call set_weight_exp(ier,1,mnrcl,rpos,wght)
        call set_weight_exp(ier,1,nmesh,rpos,wght2)
        do ltt=1,num_lttx_us
            ll=l_ltt_us(ltt)
            tn=tn_ltt_us(ltt)
            tm=tm_ltt_us(ltt)
            ltlt=ltlt_nm_us(ll,tn,ll,tm)
            ln=lt_n_us(ll,tn)
            lm=lt_n_us(ll,tm)
            call calc_diff_exp(ier,5,mnrcl,rpos,rphi_us(1,ln),drphin)
            call calc_diff_exp(ier,5,mnrcl,rpos,rphi_us(1,lm),drphim)
            call calc_diff_exp(ier,5,mnrcl,rpos,rpsi_us(1,ln),drpsin)
            call calc_diff_exp(ier,5,mnrcl,rpos,rpsi_us(1,lm),drpsim)
!            call calc_ddiff_exp(ier,5,mnrcl,rpos,rphi_us(1,lm),drphim,ddrphim)
!            call calc_ddiff_exp(ier,5,mnrcl,rpos,rpsi_us(1,lm),drpsim,ddrpsim)
            if(ltlt/=0) then
                do ir=1,mnrcl
                    r=rpos(ir)
                    tmp=r*r*wght(ir)*qps_us(ir,ltlt,0)

! ================================================ modified by K. T. ========= 4.0
!                    vion_qps(ltt)   =vion_qps(ltt)  +tmp*vloc_ion_sol(ir)
!                    vh_qps(ltt)     =vh_qps(ltt)    +tmp*vh_sol(ir)
!                    vxc_qps(ltt)    =vxc_qps(ltt)   +tmp*(vx_sol(ir)+vc_sol(ir))
!
                    vion_qps(ltt)   =vion_qps(ltt)  +tmp*vloc_ion_sol(ir,1)
                    vh_qps(ltt)     =vh_qps(ltt)    +tmp*vh_sol(ir)
                    vxc_qps(ltt)    =vxc_qps(ltt)   +tmp*(vx_sol(ir,1)+vc_sol(ir,1))
! ============================================================================== 4.0
                end do
            else
                vion_qps(ltt)=0.d0
                vh_qps(ltt)=0.d0
                vxc_qps(ltt)=0.d0
            end if
            bmat_tmp=0.d0
            do ir=1,mnrcl
                r=rpos(ir)
                tmp=wght(ir)*rphi_us(ir,ln)*rphi_us(ir,lm)

! ======================================== modified by K. T. ============= 4.0
!                vion_wps(ltt)   =vion_wps(ltt)  +tmp*vloc_ion_sol(ir)
!                vh_wps(ltt)     =vh_wps(ltt)    +tmp*vh_sol(ir)
!                vxc_wps(ltt)    =vxc_wps(ltt)   +tmp*(vx_sol(ir)+vc_sol(ir))
!                vloc_wps(ltt)   =vloc_wps(ltt)  +tmp*vloc_scr_sol(ir)
!
                vion_wps(ltt)   =vion_wps(ltt)  +tmp*vloc_ion_sol(ir,1)
                vh_wps(ltt)     =vh_wps(ltt)    +tmp*vh_sol(ir)
                vxc_wps(ltt)    =vxc_wps(ltt)   +tmp*(vx_sol(ir,1)+vc_sol(ir,1))
                vloc_wps(ltt)   =vloc_wps(ltt)  +tmp*vloc_scr_sol(ir,1)
! ============================================================================= 4.0

                tmp=wght(ir)*rpsi_us(ir,ln)*rpsi_us(ir,lm)
                vion_wae(ltt)   =vion_wae(ltt)  +tmp*vion(ir,ll_core)
                vh_wae(ltt)     =vh_wae(ltt)    +tmp*vh(ir)
                vxc_wae(ltt)    =vxc_wae(ltt)   +tmp*(vx(ir,1)+vc(ir,1))
                vloc_wae(ltt)   =vloc_wae(ltt)  +tmp*veff(ir,1,lmax_core)
                ekin_wps(ltt)   =ekin_wps(ltt)  + &
                                            0.5d0*(drphin(ir)*drphim(ir)+ &
                                                dble(ll*(ll+1))* &
                                                rphi_us(ir,ln)*rphi_us(ir,lm)/r/r)* &
                                                wght(ir)
                ekin_wae(ltt)   =ekin_wae(ltt)  + &
                                            0.5d0*(drpsin(ir)*drpsim(ir)+ &
                                                dble(ll*(ll+1))* &
                                                rpsi_us(ir,ln)*rpsi_us(ir,lm)/r/r)* &
                                                wght(ir)
!                ekin_wps(ltt)   =ekin_wps(ltt)  + &
!                                            0.5d0*(-drphin(ir)*ddrphim(ir)+ &
!                                                dble(ll*(ll+1))* &
!                                                rphi_us(ir,ln)*rphi_us(ir,lm)/r/r)* &
!                                                wght(ir)
!                ekin_wae(ltt)   =ekin_wae(ltt)  + &
!                                            0.5d0*(-drpsin(ir)*ddrpsim(ir)+ &
!                                                dble(ll*(ll+1))* &
!                                                rpsi_us(ir,ln)*rpsi_us(ir,lm)/r/r)* &
!                                                wght(ir)
                emphnphm(ltt)=emphnphm(ltt) + &
                            wght(ir)*eref_us(lm)*rphi_us(ir,ln)*rphi_us(ir,lm)
                empsnpsm(ltt)=empsnpsm(ltt) + &
                            wght(ir)*eref_us(lm)*rpsi_us(ir,ln)*rpsi_us(ir,lm)
            end do
            do ir=1,nmesh
                bmat_tmp=bmat_tmp+wght2(ir)*rphi_us(ir,ln)*rchi_us(ir,lm)
            end do
            
!            ekin_wps2(ltt)=emphnphm(ltt)-bmat_us(ltt)-vion_wps(ltt)-vh_wps(ltt)-vxc_wps(ltt)
!            ekin_wps2(ltt)=emphnphm(ltt)-bmat_us(ltt)-vloc_wps(ltt)
            ekin_wps2(ltt)=emphnphm(ltt)-bmat_tmp-vloc_wps(ltt)
!            ekin_wae2(ltt)=empsnpsm(ltt)-vion_wae(ltt)-vh_wae(ltt)-vxc_wae(ltt) 
            ekin_wae2(ltt)=empsnpsm(ltt)-vloc_wae(ltt)
            
            call make_vcor_wae(ln,lm,mnrcl,vcor_wae(ltt))  
            call make_dh_ae(ln,lm,mnrcl,dh_ae(ltt))
            call make_dh_ps(ln,lm,mnrcl,dh_ps(ltt))
            if(ltlt/=0) then
                call make_dh_qps(ltlt,mnrcl,dh_qps(ltt))
            else
                dh_qps(ltt)=0.d0
            end if
        end do
  
        write(IFLOG,*) 
        write(IFLOG,*) 'Dion analysis for PHASE PAW'
        write(IFLOG,'("    mnrcl = ",i5)') mnrcl
        do ltt=1,num_lttx_us
            ll=l_ltt_us(ltt)
            tn=tn_ltt_us(ltt)
            tm=tm_ltt_us(ltt)
            write(IFLOG,'(3i5)') ll,tn,tm
            write(IFLOG,'("ekin_ae                    : ",e19.10)') ekin_wae(ltt) 
            write(IFLOG,'("ekin_ae2                   : ",e19.10)') ekin_wae2(ltt) 
            write(IFLOG,'("vion_ae                    : ",e19.10)') vion_wae(ltt) 
            write(IFLOG,'("vh_ae                      : ",e19.10)') vh_wae(ltt) 
            write(IFLOG,'("vxc_ae                     : ",e19.10)') vxc_wae(ltt) 
            write(IFLOG,'("vcor_ae                    : ",e19.10)') vcor_wae(ltt) 
            write(IFLOG,'("kine_ps                    : ",e19.10)') ekin_wps(ltt) 
            write(IFLOG,'("kine_ps2                   : ",e19.10)') ekin_wps2(ltt) 
            write(IFLOG,'("vion_ps                    : ",e19.10)') vion_wps(ltt) 
            write(IFLOG,'("vh_ps                      : ",e19.10)') vh_wps(ltt) 
            write(IFLOG,'("vxc_ps                     : ",e19.10)') vxc_wps(ltt) 
            write(IFLOG,'("vion_qps                   : ",e19.10)') vion_qps(ltt) 
            write(IFLOG,'("vh_qps                     : ",e19.10)') vh_qps(ltt) 
            write(IFLOG,'("vxc_qps                    : ",e19.10)') vxc_qps(ltt) 
            write(IFLOG,'("ekin_ae -kine_ps           : ",e19.10)') ekin_wae(ltt)-ekin_wps(ltt) 
            write(IFLOG,'("ekin_ae2-kine_ps2          : ",e19.10)') ekin_wae2(ltt)-ekin_wps2(ltt)
            dion_ae=ekin_wae(ltt)+vion_wae(ltt)+vh_wae(ltt)+vxc_wae(ltt)
            write(IFLOG,'("dion_ae                    : ",e19.10)') dion_ae
            dion_ps=ekin_wps(ltt)+vion_wps(ltt)+vh_wps(ltt)+vxc_wps(ltt) 
            write(IFLOG,'("dion_ps                    : ",e19.10)') dion_ps
            dion_qps=vion_qps(ltt)+vh_qps(ltt)+vxc_qps(ltt)
            write(IFLOG,'("dion_ae -dion_ps           : ",e19.10)') dion_ae-dion_ps
            write(IFLOG,'("dion_ae2-dion_ps2          : ",e19.10)') dion_ae-dion_ps- &
                                                                    ekin_wae(ltt)+ekin_wae2(ltt)+ &
                                                                    ekin_wps(ltt)-ekin_wps2(ltt)
            write(IFLOG,'("dion_qps                   : ",e19.10)') dion_qps
            write(IFLOG,'("dion 1                     : ",e19.10)') dion_ae-dion_ps-dion_qps
            write(IFLOG,'("dion 2                     : ",e19.10)') dion_ae-dion_ps-dion_qps- &
                                                                    ekin_wae(ltt)+ekin_wae2(ltt)+ &
                                                                    ekin_wps(ltt)-ekin_wps2(ltt)
            write(IFLOG,'("em_phin_phim               : ",e19.10)') emphnphm(ltt)
            write(IFLOG,'("em_psin_psim               : ",e19.10)') empsnpsm(ltt)
            write(IFLOG,'("bmat_us                    : ",e19.10)') bmat_us(ltt)
            write(IFLOG,'("em_phin_phim-bmat_us       : ",e19.10)') emphnphm(ltt)-bmat_us(ltt)
            write(IFLOG,'("dmat_us                    : ",e19.10)') bmat_us(ltt)+ &
                                                                    empsnpsm(ltt)- &
                                                                    emphnphm(ltt)
            write(IFLOG,'("vlocqps_us                 : ",e19.10)') vlocqps_us(ltt)
            write(IFLOG,'("dion 3                     : ",e19.10)') bmat_us(ltt)+empsnpsm(ltt)- &
                                                                    emphnphm(ltt)-vlocqps_us(ltt)
            write(IFLOG,'("dion_kin_ion               : ",e19.10)') ekin_wae2(ltt)+ &
                                                                    vion_wae(ltt)+ &
                                                                    vcor_wae(ltt)- &
                                                                    ekin_wps2(ltt)- &
                                                                    vion_wps(ltt)- &
                                                                    vion_qps(ltt)
            write(IFLOG,'("dion_hartree               : ",e19.10)') vh_wae(ltt)- &
                                                                    vcor_wae(ltt)- &
                                                                    vh_wps(ltt)- &
                                                                    vh_qps(ltt)
            write(IFLOG,'("dion_vxc                   : ",e19.10)') vxc_wae(ltt)- &
                                                                    vxc_wps(ltt)- &
                                                                    vxc_qps(ltt) 
            write(IFLOG,'("dion_hartree_ae            : ",e19.10)') dh_ae(ltt)
            write(IFLOG,'("dion_hartree_ps            : ",e19.10)') dh_ps(ltt)
            write(IFLOG,'("dion_hartree_qps           : ",e19.10)') dh_qps(ltt)
            write(IFLOG,'("dion_hartree 2             : ",e19.10)') dh_ae(ltt)-dh_ps(ltt)-dh_qps(ltt)
                                                                    
        end do
        
        write(IFLOG,*) 
    
        deallocate(vion_qps,vh_qps,vxc_qps)
        deallocate(vion_wps,vh_wps,vxc_wps,vloc_wps)
        deallocate(vion_wae,vh_wae,vxc_wae,vloc_wae,vcor_wae)
        deallocate(nrcl)
        deallocate(wght,wght2)
        deallocate(ekin_wps,ekin_wae,drphin,drphim,drpsin,drpsim)
        deallocate(ddrphim,ddrpsim)
        deallocate(emphnphm,empsnpsm)
        deallocate(ekin_wps2,ekin_wae2)
        deallocate(dh_ae,dh_ps,dh_qps)
    
    end subroutine write_dion
    
   !========================================
    subroutine make_vcor_wae(ln,lm,nrc,vcor)
   !========================================
        integer,intent(in):: ln,lm,nrc
        real(8),intent(out):: vcor
        integer:: ier,i
        real(8),pointer,dimension(:):: pipj,dsum,wght,rhcor
        real(8):: rr,sum1,sum2,sum0
        integer:: ir,ii,i0,j,jr,is
            
        allocate(pipj(1:nrc))
        allocate(dsum(1:nrc))
        allocate(wght(1:nmesh))
        allocate(rhcor(1:nmesh))
        
        pipj(1:nrc)=rpsi_us(1:nrc,ln)*rpsi_us(1:nrc,lm)
        rhcor(1:nmesh)=4.d0*PI*rpos(1:nmesh)**2*rho_core(1:nmesh)
        
        dsum=0.d0
  !rhcorpw(i,it)      
        do ir=1,nrc
            sum1=0.d0
            sum2=0.d0
            if(ir==1) then
                sum1=0.d0
            else if((ir>=2).and.(ir<=5)) then
                do ii=2,ir
                    i0=ii-1
                    is=1
                    call set_open_weight_exp(ier,i0,is,rpos,wght)
                    do j=1,4
                        sum1=sum1+rhcor(i0+j*is)*wght(i0+j*is)
                    end do
                end do
            else
                call set_weight_exp(ier,1,ir,rpos,wght)
                do jr=1,ir
                    sum1=sum1+rhcor(jr)*wght(jr)
                end do
            end if
            sum1=sum1*pipj(ir)/rpos(ir)
            if(ir==nmesh) then
                sum2=0.d0
            else if((ir<=nmesh-1).and.(ir>=nmesh-4)) then
                do ii=ir,nmesh-1
                    i0=ii+1
                    is=-1
                    call set_open_weight_exp(ier,i0,is,rpos,wght)
                    do j=1,4
                        sum2=sum2+(1.d0/rpos(i0+j*is))* &
                                rhcor(i0+j*is)*wght(i0+j*is)
                    end do
                end do
            else
                call set_weight_exp(ier,ir,nmesh,rpos,wght)
                do jr=ir,nmesh
                    sum2=sum2+(1.d0/rpos(jr))* &
                                rhcor(jr)*wght(jr)
                end do
            end if
            sum2=sum2*pipj(ir)
            dsum(ir)=sum1+sum2
        end do
        
        call set_weight_exp(ier,1,nrc,rpos,wght)
        sum0=0.d0
        do ir=1,nrc
            sum0=sum0+dsum(ir)*wght(ir)
        end do
        
        vcor=sum0
        
        deallocate(pipj,dsum)
        deallocate(wght,rhcor)
        return
   end subroutine make_vcor_wae
   
! ***** For Debug *****

   !========================================
    subroutine make_dh_ae(ln,lm,nrc,dh_ae)
   !========================================
        integer,intent(in):: ln,lm,nrc
        real(8),intent(out):: dh_ae
        integer:: ier,i
        real(8),pointer,dimension(:):: pipj,dsum,wght,rhor
        real(8):: rr,sum1,sum2,sum0
        integer:: ir,ii,i0,j,jr,is
            
        allocate(pipj(1:nrc))
        allocate(dsum(1:nrc))
        allocate(wght(1:nrc))
        allocate(rhor(1:nrc))
        
        pipj(1:nrc)=rpsi_us(1:nrc,ln)*rpsi_us(1:nrc,lm)
        rhor=0.d0
        if(nspin.eq.1) then
            rhor(1:nrc)=rho(1:nrc,1)
        else
            rhor(1:nrc)=rho(1:nrc,1)+rho(1:nrc,2)
        end if
        do ir=1,nrc
            rhor(ir)=4.d0*PI*rpos(ir)**2*(rhor(ir)-rho_core(ir))
        end do
        
        dsum=0.d0
  !rhcorpw(i,it)      
        do ir=1,nrc
            sum1=0.d0
            sum2=0.d0
            if(ir==1) then
                sum1=0.d0
            else if((ir>=2).and.(ir<=5)) then
                do ii=2,ir
                    i0=ii-1
                    is=1
                    call set_open_weight_exp(ier,i0,is,rpos,wght)
                    do j=1,4
                        sum1=sum1+rhor(i0+j*is)*wght(i0+j*is)
                    end do
                end do
            else
                call set_weight_exp(ier,1,ir,rpos,wght)
                do jr=1,ir
                    sum1=sum1+rhor(jr)*wght(jr)
                end do
            end if
            sum1=sum1*pipj(ir)/rpos(ir)
            if(ir==nrc) then
                sum2=0.d0
            else if((ir<=nrc-1).and.(ir>=nrc-4)) then
                do ii=ir,nrc-1
                    i0=ii+1
                    is=-1
                    call set_open_weight_exp(ier,i0,is,rpos,wght)
                    do j=1,4
                        sum2=sum2+(1.d0/rpos(i0+j*is))* &
                                rhor(i0+j*is)*wght(i0+j*is)
                    end do
                end do
            else
                call set_weight_exp(ier,ir,nrc,rpos,wght)
                do jr=ir,nrc
                    sum2=sum2+(1.d0/rpos(jr))* &
                                rhor(jr)*wght(jr)
                end do
            end if
            sum2=sum2*pipj(ir)
            dsum(ir)=sum1+sum2
        end do
        
        call set_weight_exp(ier,1,nrc,rpos,wght)
        sum0=0.d0
        do ir=1,nrc
            sum0=sum0+dsum(ir)*wght(ir)
        end do
        
        dh_ae=sum0
        
        deallocate(pipj,dsum)
        deallocate(wght,rhor)
        return
   end subroutine make_dh_ae

   !========================================
    subroutine make_dh_ps(ln,lm,nrc,dh_ps)
   !========================================
        integer,intent(in):: ln,lm,nrc
        real(8),intent(out):: dh_ps
        integer:: ier,i
        real(8),pointer,dimension(:):: pipj,dsum,wght,rhor
        real(8):: rr,sum1,sum2,sum0
        integer:: ir,ii,i0,j,jr,is
            
        allocate(pipj(1:nrc))
        allocate(dsum(1:nrc))
        allocate(wght(1:nrc))
        allocate(rhor(1:nrc))
        
        pipj(1:nrc)=rphi_us(1:nrc,ln)*rphi_us(1:nrc,lm)
        rhor=0.d0
        do ir=1,nrc
! =============================================== modified by K. T. ======== 4.0
!            rhor(ir)=4.d0*PI*rpos(ir)**2*rho_sol(ir)
            rhor(ir)=4.d0*PI*rpos(ir)**2*rho_sol(ir,1)
! ========================================================================== 4.0
        end do
        
        dsum=0.d0
  !rhcorpw(i,it)      
        do ir=1,nrc
            sum1=0.d0
            sum2=0.d0
            if(ir==1) then
                sum1=0.d0
            else if((ir>=2).and.(ir<=5)) then
                do ii=2,ir
                    i0=ii-1
                    is=1
                    call set_open_weight_exp(ier,i0,is,rpos,wght)
                    do j=1,4
                        sum1=sum1+rhor(i0+j*is)*wght(i0+j*is)
                    end do
                end do
            else
                call set_weight_exp(ier,1,ir,rpos,wght)
                do jr=1,ir
                    sum1=sum1+rhor(jr)*wght(jr)
                end do
            end if
            sum1=sum1*pipj(ir)/rpos(ir)
            if(ir==nrc) then
                sum2=0.d0
            else if((ir<=nrc-1).and.(ir>=nrc-4)) then
                do ii=ir,nrc-1
                    i0=ii+1
                    is=-1
                    call set_open_weight_exp(ier,i0,is,rpos,wght)
                    do j=1,4
                        sum2=sum2+(1.d0/rpos(i0+j*is))* &
                                rhor(i0+j*is)*wght(i0+j*is)
                    end do
                end do
            else
                call set_weight_exp(ier,ir,nrc,rpos,wght)
                do jr=ir,nrc
                    sum2=sum2+(1.d0/rpos(jr))* &
                                rhor(jr)*wght(jr)
                end do
            end if
            sum2=sum2*pipj(ir)
            dsum(ir)=sum1+sum2
        end do
        
        call set_weight_exp(ier,1,nrc,rpos,wght)
        sum0=0.d0
        do ir=1,nrc
            sum0=sum0+dsum(ir)*wght(ir)
        end do
        
        dh_ps=sum0
        
        deallocate(pipj,dsum)
        deallocate(wght,rhor)
        return
   end subroutine make_dh_ps
   
   !=========================================
    subroutine make_dh_qps(ltlt,nrc,dh_qps)
   !=========================================
        integer,intent(in):: ltlt,nrc
        real(8),intent(out):: dh_qps
        integer:: ier,i
        real(8),pointer,dimension(:):: pipj,dsum,wght,rhor
        real(8):: rr,sum1,sum2,sum0
        integer:: ir,ii,i0,j,jr,is
            
        allocate(pipj(1:nrc))
        allocate(dsum(1:nrc))
        allocate(wght(1:nrc))
        allocate(rhor(1:nrc))
        
        pipj(1:nrc)=rpos(1:nrc)**2*qps_us(1:nrc,ltlt,0)
        rhor=0.d0
        do ir=1,nrc
! ============================================= modified by K. T. ======== 4.0
!            rhor(ir)=4.d0*PI*rpos(ir)**2*rho_sol(ir)
            rhor(ir)=4.d0*PI*rpos(ir)**2*rho_sol(ir,1)
! =========================================================================== 4.0
        end do
        
        dsum=0.d0
  !rhcorpw(i,it)      
        do ir=1,nrc
            sum1=0.d0
            sum2=0.d0
            if(ir==1) then
                sum1=0.d0
            else if((ir>=2).and.(ir<=5)) then
                do ii=2,ir
                    i0=ii-1
                    is=1
                    call set_open_weight_exp(ier,i0,is,rpos,wght)
                    do j=1,4
                        sum1=sum1+rhor(i0+j*is)*wght(i0+j*is)
                    end do
                end do
            else
                call set_weight_exp(ier,1,ir,rpos,wght)
                do jr=1,ir
                    sum1=sum1+rhor(jr)*wght(jr)
                end do
            end if
            sum1=sum1*pipj(ir)/rpos(ir)
            if(ir==nrc) then
                sum2=0.d0
            else if((ir<=nrc-1).and.(ir>=nrc-4)) then
                do ii=ir,nrc-1
                    i0=ii+1
                    is=-1
                    call set_open_weight_exp(ier,i0,is,rpos,wght)
                    do j=1,4
                        sum2=sum2+(1.d0/rpos(i0+j*is))* &
                                rhor(i0+j*is)*wght(i0+j*is)
                    end do
                end do
            else
                call set_weight_exp(ier,ir,nrc,rpos,wght)
                do jr=ir,nrc
                    sum2=sum2+(1.d0/rpos(jr))* &
                                rhor(jr)*wght(jr)
                end do
            end if
            sum2=sum2*pipj(ir)
            dsum(ir)=sum1+sum2
        end do
        
        call set_weight_exp(ier,1,nrc,rpos,wght)
        sum0=0.d0
        do ir=1,nrc
            sum0=sum0+dsum(ir)*wght(ir)
        end do
        
        dh_qps=sum0
        
        deallocate(pipj,dsum)
        deallocate(wght,rhor)
        return
   end subroutine make_dh_qps












end module dion_analysis
