!
!  Software name : CIAO (Code for Investigating Atomic Orbitals)
!  Subroutine(s) : opt_poly_fn, calc_poly_fn, calc_dpoly_fn
!                : calc_ddpoly_fn, calc_dddpoly_fn, calc_ddddpoly_fn
!                : calc_poly_rchi, opt_poly_qps, opt_ub_to_bound
!                : set_vloc_poly10
!  Function(s)   : fn_rexp, fn_hfact, fn_patom_poly12
!  Author(s)     : Masakuni Okamoto (August 25, 2003)
!
!
!  Contact address :  Phase System Consortium
!                     E-mail: phase_system@nims.go.jp URL https://azuma.nims.go.jp
!
!
!  The license of the code and contact address :
!  See the files, COPYRIGHT and LICENSE (or LICENSE_J.pdf)
!
!=====================================================================
   subroutine opt_poly_fn(ier,ifile,ll,ss, &
                 nr_mesh,rpos,f,nk,nrc,fc,ng_mesh,gmin,gmax,np,cp)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: ifile, ll, ss, nr_mesh, nk, nrc, ng_mesh, np
   real(8),intent(in)  :: rpos(nr_mesh), f(nr_mesh), fc(0:nk), &
                          gmin, gmax
   integer,intent(out) :: ier
   real(8),intent(out) :: cp(0:np)
   integer :: ir, ig, ip, jp, ik, jk, ifac, itmp, is_debug
   real(8) :: g, r, sum, eps_invmat, det
   real(8),allocatable :: &
      amat(:,:), bvec(:), cmat(:,:), ainv(:,:), &
      a(:,:), b(:), lambda(:), &
      achk(:,:), bchk(:), gr(:), js(:), &
      gpos(:), wg(:), wt1(:), wt2(:), f_in(:,:), f_out(:)
   is_debug = 1
   eps_invmat = 1.d-3
  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   allocate(wt1(nr_mesh),wt2(nr_mesh),gr(nr_mesh),js(nr_mesh), &
            amat(0:np,0:np),bvec(0:np),cmat(0:np,0:nk))
   allocate(gpos(ng_mesh),wg(ng_mesh), &
            f_in(0:np,ng_mesh),f_out(ng_mesh))
  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   if (is_debug /= 0) then
   write(ifile,*)
   write(ifile,*) 'nk ...',nk
   do ik = 0,nk
      write(ifile,*) 'k,fc ...',ik,fc(ik)
   end do
   end if
   do ig = 1,ng_mesh
      gpos(ig) = gmin + dble(ig-1)/dble(ng_mesh-1)*(gmax-gmin)
   end do
   call set_weight_unif(ier,1,ng_mesh,gpos,wg)
   call set_weight_exp(ier,1,nrc,rpos,wt1)
   call set_weight_exp(ier,nrc,nr_mesh,rpos,wt2)
   f_in(:,:) = 0.d0 ; f_out(:) = 0.d0
   do ig = 1,ng_mesh
      gr(:) = gpos(ig)*rpos(:)
      call bessel_js(ll,nr_mesh,gr,js)
      do ip = 0,np
      do ir = 1,nrc
         r = rpos(ir)
         f_in(ip,ig) = f_in(ip,ig) &
            + r*r * wt1(ir) * r**(2*ip+ll) * js(ir)
      end do
      end do
      do ir = nrc,nr_mesh
         r = rpos(ir)
         f_out(ig) = f_out(ig) &
            + r*r * wt2(ir) * f(ir) * js(ir)
      end do
   end do
   amat(:,:) = 0.d0
   do ip = 0,np
   do jp = ip,np
      do ig = 1,ng_mesh
         g = gpos(ig)
         amat(ip,jp) = amat(ip,jp) &
            + 2.d0 * g*g*(g**ss) * wg(ig) * f_in(ip,ig) * f_in(jp,ig)
      end do
      amat(jp,ip) = amat(ip,jp)
   end do
   end do
   bvec(:) = 0.d0
   do ip = 0,np
      do ig = 1,ng_mesh
         g = gpos(ig)
         bvec(ip) = bvec(ip) &
            + 2.d0 * g*g*(g**ss) * wg(ig) * f_in(ip,ig) * f_out(ig)
      end do
   end do
   do ip = 0,np
      do ik = 0,nk
         if (2*ip+ll < ik) then
            ifac = 0
         else
            ifac = 1
            if (ik > 0) then
               do itmp = 1,ik
                  ifac = ifac * (2*ip+ll-itmp+1)
               end do
            end if
         end if
         cmat(ip,ik) = rpos(nrc)**(2*ip+ll-ik) * dble(ifac)
      end do
   end do
  !+++++++++++++++++++++++++++++++
   deallocate(gpos,wg,f_in,f_out)
   allocate(ainv(0:np,0:np))
   allocate(achk(0:np,0:np))
  !+++++++++++++++++++++++++++++++
   call det_real_matrix(ier,np+1,amat(0,0),det)
   call inv_real_matrix(ier,np+1,amat(0,0),ainv(0,0))
   write(ifile,*) '### CHECK ### det(Aij) ...',det
   achk = matmul(amat,ainv)
   do ip = 0,np
   do jp = 0,np
      if (ip == jp) then
         if (abs(achk(ip,jp) - 1.d0) > eps_invmat) then
            write(ifile,*) '### ERROR ### A * inv(A) != 1'
            write(ifile,*) '   ip          ...',ip
            write(ifile,*) '   jp          ...',jp
            write(ifile,*) '   achk(ip,jp) ...',achk(ip,jp)
            write(ifile,*) '   eps_invmat  ...',eps_invmat
            ier = 1 ; go to 99
         end if
      else
         if (abs(achk(ip,jp)) > eps_invmat) then
            write(ifile,*) '### ERROR ### A * inv(A) != 1'
            write(ifile,*) '   ip          ...',ip
            write(ifile,*) '   jp          ...',jp
            write(ifile,*) '   achk(ip,jp) ...',achk(ip,jp)
            write(ifile,*) '   eps_invmat  ...',eps_invmat
            ier = 2 ; go to 99
         end if
      end if
   end do
   end do
  !++++++++++++++++++++++++++++++++++++++++++++
   deallocate(achk)
   allocate(a(0:nk,0:nk),b(0:nk),lambda(0:nk))
  !++++++++++++++++++++++++++++++++++++++++++++
   a(:,:) = 0.d0
   do ik = 0,nk
   do jk = ik,nk
      do ip = 0,np
      do jp = 0,np
         a(ik,jk) = a(ik,jk) &
            - ainv(ip,jp) * cmat(ip,ik) * cmat(jp,jk)
      end do
      end do
      a(jk,ik) = a(ik,jk)
   end do
   end do
   b(:) = 0.d0
   do ik = 0,nk
      do ip = 0,np
      do jp = 0,np
         b(ik) = b(ik) &
            + ainv(ip,jp) * cmat(ip,ik) * bvec(jp)
      end do
      end do
      b(ik) = b(ik) + fc(ik)
   end do
  !+++++++++++++++++++++
   allocate(bchk(0:nk))
  !+++++++++++++++++++++
   call det_real_matrix(ier,nk+1,a(0,0),det)
   write(ifile,*) '### CHECK ### det(a) ...',det
   call axb_real_matrix(ier,nk+1,1,a(0,0),lambda(0),b(0))
   if (ier /= 0) then
      write(ifile,*) '### ERROR ### in axb_real_matrix'
      write(ifile,*) '### ERROR ###    det(a) ...',det
      go to 99
   end if
   bchk(:) = 0.d0
   do ik = 0,nk
      do jk = 0,nk
         bchk(ik) = bchk(ik) + a(ik,jk) * lambda(jk)
      end do
   end do
   do ik = 0,nk
      if (abs(bchk(ik) - b(ik))/(abs(b(ik))+1.d-15) > 1.d-6) then
         write(ifile,*) '### ERROR ### a * lambda != b'
         write(ifile,*) '   ik         ...',ik
         write(ifile,*) '   a * lambda ...',bchk(ik)
         write(ifile,*) '   b          ...',b(ik)
         ier = 3 ; go to 99
      end if
   end do
  
   if (is_debug /= 0) then
   write(ifile,*)
   write(ifile,*) 'nk ...',nk
   do ik = 0,nk
      write(ifile,*) 'k,lambda ...',ik,lambda(ik)
   end do
   end if
  !+++++++++++++++++
   deallocate(bchk)
  !+++++++++++++++++
   cp(:) = 0.d0
   do ip = 0,np
      do jp = 0,np
         sum = 0.d0
         do ik = 0,nk
            sum = sum + cmat(jp,ik) * lambda(ik)
         end do
         cp(ip) = cp(ip) - ainv(ip,jp) * (bvec(jp) + sum)
      end do
   end do
   
   if (is_debug /= 0) then
   write(ifile,*)
   write(ifile,*) 'np ...',np
   do ip = 0,np
      write(ifile,*) 'ip,cp ...',ip,cp(ip)
   end do
   end if
  !++++++++++++++++++++++++++++++++++++++++++++++
   deallocate(a,b,lambda)
   deallocate(wt1,wt2,gr,js,amat,bvec,cmat,ainv)
  !++++++++++++++++++++++++++++++++++++++++++++++
99 continue
   end subroutine opt_poly_fn

!=====================================================================
   subroutine calc_poly_fn( &
      ir1,ir2,rpos,ll,ncoeff,coeff,poly_fn)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: ir1, ir2, ll, ncoeff
   real(8),intent(in)  :: rpos(*), coeff(0:*)
   real(8),intent(out) :: poly_fn(*)
   integer :: ir, icoeff
   real(8) :: r
   do ir = ir1,ir2
      poly_fn(ir) = coeff(ncoeff)
   end do
   do icoeff = ncoeff-1,0,-1
      do ir = ir1,ir2
         r = rpos(ir)
         poly_fn(ir) = poly_fn(ir)*r*r + coeff(icoeff)
      end do
   end do
   do ir = ir1,ir2
      poly_fn(ir) = poly_fn(ir) * rpos(ir)**(ll)
   end do
   end subroutine calc_poly_fn

!=====================================================================
   subroutine calc_dpoly_fn( &
      ir1,ir2,rpos,ll,ncoeff,coeff,dpoly_fn)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: ir1, ir2, ll, ncoeff
   real(8),intent(in)  :: rpos(*), coeff(0:*)
   real(8),intent(out) :: dpoly_fn(*)
   integer :: ir, icoeff
   real(8) :: r
   do ir = ir1,ir2
      dpoly_fn(ir) = coeff(ncoeff) * dble(2*ncoeff+ll)
   end do
   do icoeff = ncoeff-1,0,-1
      do ir = ir1,ir2
         r = rpos(ir)
         dpoly_fn(ir) = dpoly_fn(ir)*r*r &
                      + coeff(icoeff) * dble(2*icoeff+ll)
      end do
   end do
   do ir = ir1,ir2
      dpoly_fn(ir) = dpoly_fn(ir) * rpos(ir)**(ll-1)
   end do
   end subroutine calc_dpoly_fn

!=====================================================================
   subroutine calc_ddpoly_fn( &
      ir1,ir2,rpos,ll,ncoeff,coeff,ddpoly_fn)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: ir1, ir2, ll, ncoeff
   real(8),intent(in)  :: rpos(*), coeff(0:*)
   real(8),intent(out) :: ddpoly_fn(*)
   integer :: ir, icoeff
   real(8) :: r
   do ir = ir1,ir2
      ddpoly_fn(ir) = coeff(ncoeff) &
                    * dble((2*ncoeff+ll)*(2*ncoeff+ll-1))
   end do
   do icoeff = ncoeff-1,0,-1
      do ir = ir1,ir2
         r = rpos(ir)
         ddpoly_fn(ir) = ddpoly_fn(ir)*r*r &
            + coeff(icoeff) * dble((2*icoeff+ll)*(2*icoeff+ll-1))
      end do
   end do
   do ir = ir1,ir2
      ddpoly_fn(ir) = ddpoly_fn(ir) * rpos(ir)**(ll-2)
   end do
   end subroutine calc_ddpoly_fn

!=====================================================================
   subroutine calc_dddpoly_fn( &
      ir1,ir2,rpos,ll,ncoeff,coeff,dddpoly_fn)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: ir1, ir2, ll, ncoeff
   real(8),intent(in)  :: rpos(*), coeff(0:*)
   real(8),intent(out) :: dddpoly_fn(*)
   integer :: ir, icoeff
   real(8) :: r
   do ir = ir1,ir2
      dddpoly_fn(ir) = coeff(ncoeff) &
         * dble((2*ncoeff+ll)*(2*ncoeff+ll-1)*(2*ncoeff+ll-2))
   end do
   
   do icoeff = ncoeff-1,0,-1
      do ir = ir1,ir2
         r = rpos(ir)
         dddpoly_fn(ir) = dddpoly_fn(ir)*r*r &
            + coeff(icoeff) &
               * dble((2*icoeff+ll)*(2*icoeff+ll-1)*(2*icoeff+ll-2))
      end do
   end do
   do ir = ir1,ir2
      dddpoly_fn(ir) = dddpoly_fn(ir) * rpos(ir)**(ll-3)
   end do
   end subroutine calc_dddpoly_fn

!=====================================================================
   subroutine calc_ddddpoly_fn( &
      ir1,ir2,rpos,ll,ncoeff,coeff,ddddpoly_fn)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: ir1, ir2, ll, ncoeff
   real(8),intent(in)  :: rpos(*), coeff(0:*)
   real(8),intent(out) :: ddddpoly_fn(*)
   integer :: ir, icoeff
   real(8) :: r
   do ir = ir1,ir2
      ddddpoly_fn(ir) = coeff(ncoeff) &
         * dble((2*ncoeff+ll)*(2*ncoeff+ll-1) &
               *(2*ncoeff+ll-2)*(2*ncoeff+ll-3))
   end do
   do icoeff = ncoeff-1,0,-1
      do ir = ir1,ir2
         r = rpos(ir)
         ddddpoly_fn(ir) = ddddpoly_fn(ir)*r*r &
            + coeff(icoeff) &
               * dble((2*icoeff+ll)*(2*icoeff+ll-1) &
                     *(2*icoeff+ll-2)*(2*icoeff+ll-3))
      end do
   end do
   do ir = ir1,ir2
      ddddpoly_fn(ir) = ddddpoly_fn(ir) * rpos(ir)**(ll-4)
   end do
   end subroutine calc_ddddpoly_fn

!=====================================================================
   subroutine calc_poly_rchi( &
      ir1,ir2,rpos,ll,ncoeff,coeff,engy,rphi,vloc,poly_rchi)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: ir1, ir2, ll, ncoeff
   real(8),intent(in)  :: rpos(*), coeff(0:*), engy, rphi(*), vloc(*)
   real(8),intent(out) :: poly_rchi(*)
   integer :: ir, icoeff
   real(8) :: fac
   fac = dble((2*ncoeff+2*ll+1)*ncoeff)
   do ir = ir1,ir2
      poly_rchi(ir) = coeff(ncoeff) * fac
   end do
   do icoeff = ncoeff-1,1,-1
      fac = dble((2*icoeff+2*ll+1)*icoeff)
      do ir = ir1,ir2
         poly_rchi(ir) = poly_rchi(ir)*rpos(ir)**2 &
                       + coeff(icoeff) * fac
      end do
   end do
   do ir = ir1,ir2
      poly_rchi(ir) = poly_rchi(ir) * rpos(ir)**(ll+1) &
                    + (engy - vloc(ir)) * rphi(ir)
   end do
   end subroutine calc_poly_rchi

!=====================================================================
   subroutine opt_poly_qps(ier,ifile,ll,ss, &
                 nr_mesh,rpos,f,nk,nrc,fc,fint,ng_mesh,gmin,gmax, &
                 np,cp)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: ifile, ll, ss, nr_mesh, nk, nrc, ng_mesh, np
   real(8),intent(in)  :: rpos(nr_mesh), f(nr_mesh), fc(0:nk), fint, &
                          gmin, gmax
   integer,intent(out) :: ier
   real(8),intent(out) :: cp(0:np)
   integer :: ir, ig, ip, jp, ik, jk, ifac, itmp, is_debug
   real(8) :: g, r, sum, eps_invmat, det
   real(8),allocatable :: &
      amat(:,:), bvec(:), cmat(:,:), ainv(:,:), &
      a(:,:), b(:), lambda(:), &
      achk(:,:), bchk(:), gr(:), js(:), &
      gpos(:), wg(:), wt1(:), wt2(:), f_in(:,:), f_out(:)
   is_debug = 1

! ================================== modified by K. T. ================= 4.0
!   eps_invmat = 1.d-3
!
#ifdef mode_v300
   eps_invmat = 1.d-3
#else
   eps_invmat = 2.0d-3
#endif
! ====================================================================== 4.0

  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   allocate(wt1(nr_mesh),wt2(nr_mesh),gr(nr_mesh),js(nr_mesh), &
            amat(0:np,0:np),bvec(0:np),cmat(0:np,0:nk+1))
   allocate(gpos(ng_mesh),wg(ng_mesh), &
            f_in(0:np,ng_mesh),f_out(ng_mesh))
  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   if (is_debug /= 0) then
   write(ifile,*)
   write(ifile,*) 'nk+1 ...',nk+1
   do ik = 0,nk
      write(ifile,*) 'k,fc   ...',ik,fc(ik)
   end do
      write(ifile,*) 'k,fint ...',nk+1,fint
   end if
   do ig = 1,ng_mesh
      gpos(ig) = gmin + dble(ig-1)/dble(ng_mesh-1)*(gmax-gmin)
   end do
   call set_weight_unif(ier,1,ng_mesh,gpos,wg)
   call set_weight_exp(ier,1,nrc,rpos,wt1)
   call set_weight_exp(ier,nrc,nr_mesh,rpos,wt2)
   f_in(:,:) = 0.d0 ; f_out(:) = 0.d0
   do ig = 1,ng_mesh
      gr(:) = gpos(ig) * rpos(:)
      call bessel_js(ll,nr_mesh,gr,js)
      do ip = 0,np
      do ir = 1,nrc
         r = rpos(ir)
         f_in(ip,ig) = f_in(ip,ig) &
            + r*r * wt1(ir) * r**(2*ip+ll) * js(ir)
      end do
      end do
      do ir = nrc,nr_mesh
         r = rpos(ir)
         f_out(ig) = f_out(ig) &
            + r*r * wt2(ir) * f(ir) * js(ir)
      end do
   end do
   amat(:,:) = 0.d0
   do ip = 0,np
   do jp = ip,np
      do ig = 1,ng_mesh
         g = gpos(ig)
         amat(ip,jp) = amat(ip,jp) &
            + 2.d0 * g**(ss+2) * wg(ig) * f_in(ip,ig) * f_in(jp,ig)
      end do
      amat(jp,ip) = amat(ip,jp)
   end do
   end do
   bvec(:) = 0.d0
   do ip = 0,np
      do ig = 1,ng_mesh
         g = gpos(ig)
         bvec(ip) = bvec(ip) &
            + 2.d0 * g**(ss+2) * wg(ig) * f_in(ip,ig) * f_out(ig)
      end do
   end do
   do ip = 0,np
      do ik = 0,nk
         if (2*ip+ll < ik) then
            ifac = 0
         else
            ifac = 1
            if (ik > 0) then
               do itmp = 1,ik
                  ifac = ifac * (2*ip+ll-itmp+1)
               end do
            end if
         end if
         cmat(ip,ik) = rpos(nrc)**(2*ip+ll-ik) * dble(ifac)
      end do
      cmat(ip,nk+1) = rpos(nrc)**(2*ip+2*ll+3) / dble(2*ip+2*ll+3)
   end do
  !+++++++++++++++++++++++++++++++
   deallocate(gpos,wg,f_in,f_out)
   allocate(ainv(0:np,0:np))
   allocate(achk(0:np,0:np))
  !+++++++++++++++++++++++++++++++
   call det_real_matrix(ier,np+1,amat(0,0),det)
   call inv_real_matrix(ier,np+1,amat(0,0),ainv(0,0))
   write(ifile,*) '### CHECK ### det(Aij) ...',det
   achk = matmul(amat,ainv)
   do ip = 0,np
   do jp = 0,np
      if (ip == jp) then
         if (abs(achk(ip,jp) - 1.d0) > eps_invmat) then
            write(ifile,*) '### ERROR ### A * inv(A) != 1'
            write(ifile,*) '   ip          ...',ip
            write(ifile,*) '   jp          ...',jp
            write(ifile,*) '   achk(ip,jp) ...',achk(ip,jp)
            write(ifile,*) '   eps_invmat  ...',eps_invmat
            ier = 1 ; go to 99
         end if
      else
         if (abs(achk(ip,jp)) > eps_invmat) then
            write(ifile,*) '### ERROR ### A * inv(A) != 1'
            write(ifile,*) '   ip          ...',ip
            write(ifile,*) '   jp          ...',jp
            write(ifile,*) '   achk(ip,jp) ...',achk(ip,jp)
            write(ifile,*) '   eps_invmat  ...',eps_invmat
            ier = 2 ; go to 99
         end if
      end if
   end do
   end do
  !++++++++++++++++++++++++++++++++++++++++++++++++++++
   deallocate(achk)
   allocate(a(0:nk+1,0:nk+1),b(0:nk+1),lambda(0:nk+1))
  !++++++++++++++++++++++++++++++++++++++++++++++++++++
   a(:,:) = 0.d0
   do ik = 0,nk+1
   do jk = ik,nk+1
      do ip = 0,np
      do jp = 0,np
         a(ik,jk) = a(ik,jk) &
            - ainv(ip,jp) * cmat(ip,ik) * cmat(jp,jk)
      end do
      end do
      a(jk,ik) = a(ik,jk)
   end do
   end do
   b(:) = 0.d0
   do ik = 0,nk
      do ip = 0,np
      do jp = 0,np
         b(ik) = b(ik) &
            + ainv(ip,jp) * cmat(ip,ik) * bvec(jp)
      end do
      end do
      b(ik) = b(ik) + fc(ik)
   end do
   ik = nk+1
      do ip = 0,np
      do jp = 0,np
         b(ik) = b(ik) &
            + ainv(ip,jp) * cmat(ip,ik) * bvec(jp)
      end do
      end do
      b(ik) = b(ik) + fint
  !+++++++++++++++++++++++
   allocate(bchk(0:nk+1))
  !+++++++++++++++++++++++
   call det_real_matrix(ier,nk+2,a(0,0),det)
   write(ifile,*) '### CHECK ### det(a) ...',det
   call axb_real_matrix(ier,nk+2,1,a(0,0),lambda(0),b(0))
   if (ier /= 0) then
      write(ifile,*) '### ERROR ### in axb_real_matrix'
      write(ifile,*) '### ERROR ###    det(a) ...',det
      go to 99
   end if
   bchk(:) = 0.d0
   do ik = 0,nk+1
      do jk = 0,nk+1
         bchk(ik) = bchk(ik) + a(ik,jk) * lambda(jk)
      end do
   end do
   do ik = 0,nk+1
      if (abs(bchk(ik) - b(ik))/(abs(b(ik))+1.d-15) > 1.d-6) then
         write(ifile,*) '### ERROR ### a * lambda != b'
         write(ifile,*) '   ik         ...',ik
         write(ifile,*) '   a * lambda ...',bchk(ik)
         write(ifile,*) '   b          ...',b(ik)
         ier = 3 ; go to 99
      end if
   end do
  !+++++++++++++++++
   deallocate(bchk)
  !+++++++++++++++++
   if (is_debug /= 0) then
   write(ifile,*)
   write(ifile,*) 'nk+1 ...',nk+1
   do ik = 0,nk+1
      write(ifile,*) 'k,lambda ...',ik,lambda(ik)
   end do
   end if
   cp(:) = 0.d0
   do ip = 0,np
      do jp = 0,np
         sum = 0.d0
         do ik = 0,nk+1
            sum = sum + cmat(jp,ik) * lambda(ik)
         end do
         cp(ip) = cp(ip) - ainv(ip,jp) * (bvec(jp) + sum)
      end do
   end do
   if (is_debug /= 0) then
   write(ifile,*)
   write(ifile,*) 'np ...',np
   do ip = 0,np
      write(ifile,*) 'ip,cp ...',ip,cp(ip)
   end do
   end if
  !++++++++++++++++++++++++++++++++++++++++++++++
   deallocate(a,b,lambda)
   deallocate(wt1,wt2,gr,js,amat,bvec,cmat,ainv)
  !++++++++++++++++++++++++++++++++++++++++++++++
99 continue
   end subroutine opt_poly_qps

!=====================================================================
   subroutine opt_ub_to_bound(ier,iflog,ifsum, &
      nn,ll,tt,eref,deref,nmesh,rpos,nrc,rpsi_ub,rpsi_b)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: iflog, ifsum, nn, ll, tt, nmesh, nrc
   real(8),intent(in)  :: eref, deref, rpos(nmesh), rpsi_ub(nmesh)
   integer,intent(out) :: ier
   real(8),intent(out) :: rpsi_b(nmesh)
   integer :: nk, isdiff, ir, n1, n2, ik, jk, n_mat, n_vec
   real(8) :: kl, rcut, fn_rexp, sum, r
   real(8),allocatable :: &
      f0_num(:), f1_num(:), mat_a(:,:), vec_c(:), vec_ub(:), coeff(:)
   rcut = rpos(nrc)
   kl = dble(ll+2)/2.d0
   nk = 4
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   allocate(f0_num(0:nk),f1_num(0:nk),mat_a(nk+1,nk+1),vec_c(nk+1), &
            vec_ub(nk+1),coeff(0:nk))
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   f0_num(:)  = 0.d0
   isdiff = nk
   n1 = nrc - 10
   n2 = nrc + 10
   rcut = rpos(nrc)
   call diff4_exp(ier,isdiff,n1,n2,rpos,rpsi_ub,rcut, &
                  f0_num(0),f0_num(1),f0_num(2),f0_num(3),f0_num(4))
   f0_num(0) = rpsi_ub(nrc)
   do ik = 0,nk
      vec_ub(ik+1) = f0_num(ik)
   end do
   do ik = 0,nk
      do jk = 0,nk
         mat_a(ik+1,jk+1) = fn_rexp(ik,2*jk+ll+1,-kl,rcut)
      end do
   end do
   n_mat = nk+1
   n_vec = 1
   call axb_real_matrix(ier,n_mat,n_vec,mat_a,vec_c,vec_ub)
   do ik = 0,nk
      coeff(ik) = vec_c(ik+1)
   end do
   do ir = nrc+1,nmesh
      r = rpos(ir)
      sum = 0.d0
      do jk = 0,nk
         sum = sum + coeff(jk)*fn_rexp(0,2*jk+ll+1,-kl,r)
      end do
      rpsi_b(ir) = sum
   end do
   f1_num(:)  = 0.d0
   call diff4_exp(ier,isdiff,n1,n2,rpos,rpsi_b,rcut, &
                  f1_num(0),f1_num(1),f1_num(2),f1_num(3),f1_num(4))
   f1_num(0) = rpsi_b(nrc)
10 format(1x,a10,f20.10,i20)
11 format(1x,a10,2(i20))
12 format(1x,(a6,i2,a2),f20.10)
13 format(1x,10x,(8x,a8,4x),(8x,a9,3x),(8x,a9,3x))
14 format(1x,a10,5(f20.10))
15 format(1x,a10,(10x,(i2,2x,i2,2x,i2)),(18x,a2))
16 format(1x,10x,2(8x,a10,2x))
   write(iflog,*)
   write(iflog,*)  &
      'Unbound r*psi[n](r) was modified to bound at large r.'
   write(iflog,15) ' (n,l,t) :', nn,ll,tt,'US'
   write(iflog,10) ' rc, nrc :', rcut, nrc
   write(iflog,14) 'eref, de :', eref, deref
   write(iflog,13) 'rpsi(rc)','rpsi''(rc)','rpsi"(rc)'
   write(iflog,14) 'Exact    :',(f0_num(ik),ik=0,2)
   write(iflog,14) 'Numerical:',(f1_num  (ik),ik=0,2)
   write(iflog,16) 'rpsi"''(rc)','rpsi""(rc)'
   write(iflog,14) 'Exact    :',(f0_num(ik),ik=3,nk)
   write(iflog,14) 'Numerical:',(f1_num  (ik),ik=3,nk)
   write(ifsum,*)
   write(ifsum,*)  &
      'Unbound r*psi[n](r) was modified to bound at large r.'
   write(ifsum,15) ' (n,l,t) :', nn,ll,tt,'US'
   write(ifsum,10) ' rc, nrc :', rcut, nrc
   write(ifsum,14) 'eref, de :', eref, deref
   write(ifsum,13) 'rpsi(rc)','rpsi''(rc)','rpsi"(rc)'
   write(ifsum,14) 'Exact    :',(f0_num(ik),ik=0,2)
   write(ifsum,14) 'Numerical:',(f1_num  (ik),ik=0,2)
   write(ifsum,16) 'rpsi"''(rc)','rpsi""(rc)'
   write(ifsum,14) 'Exact    :',(f0_num(ik),ik=3,nk)
   write(ifsum,14) 'Numerical:',(f1_num  (ik),ik=3,nk)
  !+++++++++++++++++++++++++++++++++++++++++++++++++++
   deallocate(f0_num,f1_num,mat_a,vec_c,vec_ub,coeff)
  !+++++++++++++++++++++++++++++++++++++++++++++++++++
   end subroutine opt_ub_to_bound

!=====================================================================
   function fn_rexp(n,a,b,r)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   real(8) :: fn_rexp
   integer,intent(in) :: n, a
   real(8),intent(in) :: b, r
   integer :: m, fn_hfact
   real(8) :: sum
   if (n >= 0) then
      sum = 0.d0
      do m = 0,n
         if (a-m >= 0) then
            sum = sum &
                + dble(fn_hfact(a,n,m)) &
                   * b**(n-m) * r**(a-m) * exp(b*r)
         end if
      end do
   else
      sum = 0.d0
   end if
   fn_rexp = sum
   end function fn_rexp

!=====================================================================
   function fn_hfact(a,n,m)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer(8) :: fn_factorial
   integer :: n, a, m, fn_hfact
   fn_hfact = (fn_factorial(a) / fn_factorial(a-m)) &
            * (fn_factorial(n) / fn_factorial(n-m)) &
            /  fn_factorial(m)
   end function fn_hfact

!=====================================================================
   function fn_patom_poly12(r,fatom,rcut,vcut)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   real(8) :: fn_patom_poly12
   real(8),intent(in) :: r, fatom, rcut, vcut
   integer :: i
   real(8) :: f(0:12), zcut, rr
   zcut  = -fatom/rcut
   rr    = (r/rcut)**2
   f( 0) =        vcut
   f( 2) = - 6.d0*vcut + (3003.d0/256.d0)*zcut
   f( 4) =  15.d0*vcut - (9009.d0/256.d0)*zcut
   f( 6) = -20.d0*vcut + (6435.d0/128.d0)*zcut
   f( 8) =  15.d0*vcut - (5005.d0/128.d0)*zcut
   f(10) = - 6.d0*vcut + (4095.d0/256.d0)*zcut
   f(12) =        vcut - ( 693.d0/256.d0)*zcut
   fn_patom_poly12 = 0.d0
   do i = 0,6
      fn_patom_poly12 = fn_patom_poly12 + f(2*i) * rr**(i)
   end do
   end function fn_patom_poly12

!=====================================================================
   subroutine set_vloc_poly10(nmesh,rpos,veff,rcut,vcut,vloc)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)    :: nmesh
   real(8),intent(in)    :: vcut, rpos(nmesh), veff(nmesh)
   real(8),intent(inout) :: rcut
   real(8),intent(out)   :: vloc(nmesh)
   integer :: i, ir, nrc, isdiff, n1, n2, ier
   real(8) :: rr, gcut(0:4)
   real(8) :: coeff(0:5), amat(5,5), bvec(5), xvec(5), rc(10)
   do ir = nmesh,1,-1
      if (rpos(ir) < rcut) then
         nrc = ir ; exit
      end if
      if (ir == 1) then
         write(*,*) '### ERROR ### nrc not found in set_vloc_poly10'
         stop
      end if
   end do
   rcut = rpos(nrc)
   n1 = nrc - 10 ; n2 = nrc + 10
   isdiff = 4
   call diff4_exp(ier,isdiff,n1,n2,rpos,veff,rcut, &
              gcut(0),gcut(1),gcut(2),gcut(3),gcut(4))
   rc(1) = rcut
   do i = 2,10
      rc(i) = rc(i-1) * rcut
   end do
   amat(1,1) =      rc(2)     ; amat(1,2) =       rc(4)
   amat(2,1) = 2.d0*rc(1)     ; amat(2,2) =  4.d0*rc(3)
   amat(3,1) = 2.d0           ; amat(3,2) = 12.d0*rc(2)
   amat(4,1) = 0.d0           ; amat(4,2) = 24.d0*rc(1)
   amat(5,1) = 0.d0           ; amat(5,2) = 24.d0
   amat(1,3) =        rc(6)   ; amat(1,4) =         rc(8)
   amat(2,3) =   6.d0*rc(5)   ; amat(2,4) =    8.d0*rc(7)
   amat(3,3) =  30.d0*rc(4)   ; amat(3,4) =   56.d0*rc(6)
   amat(4,3) = 120.d0*rc(3)   ; amat(4,4) =  336.d0*rc(5)
   amat(5,3) = 360.d0*rc(2)   ; amat(5,4) = 1680.d0*rc(4)
   amat(1,5) =         rc(10) ; bvec(1) = gcut(0) - vcut
   amat(2,5) =   10.d0*rc(9)  ; bvec(2) = gcut(1)
   amat(3,5) =   90.d0*rc(8)  ; bvec(3) = gcut(2)
   amat(4,5) =  720.d0*rc(7)  ; bvec(4) = gcut(3)
   amat(5,5) = 5040.d0*rc(6)  ; bvec(5) = gcut(4)
   call axb_real_matrix(ier,5,1,amat,xvec,bvec)
   coeff(0) = vcut
   do i = 1,5
      coeff(i) = xvec(i)
   end do
   vloc(:) = 0.d0
   do ir = 1,nrc
      rr = rpos(ir)*rpos(ir)
      do i = 0,5
         vloc(ir) = vloc(ir) + coeff(i) * rr**(i)
      end do
   end do
   do ir = nrc+1,nmesh
      vloc(ir) = veff(ir)
   end do
   end subroutine set_vloc_poly10

!=====================================================================
   subroutine calc_coeff_ok_poly3(z,rc,dr,h,b)
!=====================================================================
   implicit none
   real(8),intent(in)  :: z, rc, dr, h
   real(8),intent(out) :: b(0:3)
   real(8) :: amat(4,4), bvec(4), xvec(4), rl
   integer :: ier
   rl = rc - dr
   amat(1,1) = 1.d0 ; amat(1,2) = rl ; amat(1,3) = rl*rl ; amat(1,4) = rl*rl*rl
   amat(2,1) = 0.d0 ; amat(2,2) = 1.d0 ; amat(2,3) = 2.d0*rl ; amat(2,4) = 3.d0*rl*rl
   amat(3,1) = 1.d0 ; amat(3,2) = rc ; amat(3,3) = rc*rc ; amat(3,4) = rc*rc*rc
   amat(4,1) = 0.d0 ; amat(4,2) = 1.d0 ; amat(4,3) = 2.d0*rc ; amat(4,4) = 3.d0*rc*rc
   bvec(1) = -z/rl ; bvec(2) = z/rl/rl ; bvec(3) = h ; bvec(4) = 0.d0
   call axb_real_matrix(ier,4,1,amat,xvec,bvec)
   if (ier /= 0) then
      write(*,*) '### ERROR ### ier != 0 in axb_real_matrix'
      write(*,*) '   ier ...',ier
      stop
   end if
   b(0:3) = xvec(1:4)
   end subroutine calc_coeff_ok_poly3
