! ************************************************************* 
!
!   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
!
! ************************************************************* 
!
!  Software name : CIAO (Code for Investigating Atomic Orbitals)
!  Subroutine(s) : calc_tmpp_us, check_rphi_tm, write_checked_rphi_tm
!                : write_coeff_tmpp_us, lhs_tmpp_us, set_amat_tm
!  Function(s)   : fn_p_tm, fn_dp_tm, fn_ddp_tm, fn_dddp_tm
!                : fn_ddddp_tm
!  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 calc_tmpp_us(ier,ifile,is_bound_state, &
              nmesh,rpos,wr,wt,chi,veff,chi_ps,veff_ps, &
              ll,ee,nrc,gcut0,gcut1,gcut2,gcut3,gcut4, &
              coeff_tm)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: ifile, is_bound_state, nmesh, ll, nrc
   real(8),intent(in)  :: rpos(nmesh), wr(nmesh), chi(nmesh), &
                          veff(nmesh), &
                          ee, gcut0, gcut1, gcut2, gcut3, gcut4
   integer,intent(out) :: ier
   real(8),intent(out) :: wt(nmesh), chi_ps(nmesh), veff_ps(nmesh), &
                          coeff_tm(0:12)
   integer :: ir, maxloop, loop, &
              isample, nsample, i, j, ierr_count
   real(8) :: rcut, sum, gg, r, rhs, lhs, lhsmin, lhsmid, lhsmax, &
              fn_p_tm, fn_dp_tm, fn_ddp_tm, p, dp, ddp, &
              c2min, c2mid, c2max, eps_conv, &
              c0, c2, c4, c6, c8, c10, c12, &
              c_sum(0:4),lhs_sum(0:2),acoeff(0:2), &
              lhs_bottom, c2_bottom, c2min_trial(3), c2max_trial(3), &
              c2_solved
   integer :: n_mat, n_vec
   real(8),allocatable :: mat_a(:,:), vec_x(:,:), vec_b(:,:)
   maxloop  = 100
   nsample  = 100
   eps_conv = 1.d-12
   if (is_bound_state == 1) then
      sum = 0.d0
      do ir = 1,nmesh
         sum = sum + chi(ir)**2*wr(ir)
      end do
      write(ifile,*) '%%% BOUND state %%% ll --->',ll
      write(ifile,*) '   check norm of < chi | chi > ...',sum
      if (abs(sum-1.d0) > 1.d-5) then
         write(ifile,*) '### ERROR ### < chi | chi > != 1'
         ier = 1 ; go to 99
      end if
   else
      call set_weight_exp(ier,1,nrc,rpos,wt)
      sum = 0.d0
      do ir = 1,nrc
         sum = sum + chi(ir)**2*wt(ir)
      end do
      write(ifile,*) '%%% UNBOUND state %%% ll --->',ll
      write(ifile,*) '   check norm of < chi | chi >R ...',sum
      write(ifile,*) '                            nrc ...',nrc
      if (abs(sum-1.d0) > 1.d-5) then
         write(ifile,*) '### ERROR ### < chi | chi >R != 1'
         ier = 1 ; go to 99
      end if
   end if
   rcut = rpos(nrc)
   call set_weight_exp(ier,1,nrc,rpos,wt)
   gg = 0.d0
   do ir = 1,nrc
      gg = gg + chi(ir)**2 * wt(ir)
   end do
   rhs = log(gg)
   write(ifile,*) 'RHS         ...',rhs
   write(ifile,*) '... finding c2 which gives minimum of lhs ...'
   c2min = (-30.d0-ee)/dble(2*ll+3)
   c2max = ( 10.d0-ee)/dble(2*ll+3)
   c_sum(:) = 0.d0 ; lhs_sum(:) = 0.d0
   do isample = 1,nsample
      c2 = c2min + (c2max-c2min)*dble(isample-1)/dble(nsample-1)
      call lhs_tmpp_us(ier,ifile,nmesh,ll,nrc, &
                  gcut0,gcut1,gcut2,gcut3,gcut4, &
                  rpos,wt,c0,c2,c4,c6,c8,c10,c12,lhs)
      if (ier /= 0) then
         write(ifile,*) '### ERROR ### in lhs_tmpp' ; go to 99
      end if
      do i = 0,4
         c_sum(i) = c_sum(i) + c2**i
      end do
      do i = 0,2
         lhs_sum(i) = lhs_sum(i) + lhs*c2**i
      end do
   end do
   c_sum  (:) = c_sum  (:)/dble(nsample)
   lhs_sum(:) = lhs_sum(:)/dble(nsample)
   n_mat = 3 ; n_vec = 1
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   allocate(mat_a(n_mat,n_mat),vec_x(n_mat,n_vec),vec_b(n_mat,n_vec))
      mat_a = 0.d0 ; vec_x = 0.d0 ; vec_b = 0.d0
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   do i = 1,n_mat
      do j = 1,n_mat
         mat_a(i,j) = c_sum(i+j-2)
      end do
      vec_b(i,1) = lhs_sum(i-1)
   end do
   call axb_real_matrix(ier,n_mat,n_vec,mat_a,vec_x,vec_b)
   do i = 1,n_mat
      acoeff(i-1) = vec_x(i,1)
   end do
  !++++++++++++++++++++++++++++++
   deallocate(mat_a,vec_x,vec_b)
  !++++++++++++++++++++++++++++++
   lhs_bottom =   acoeff(0) - acoeff(1)**2 / (4.d0*acoeff(2))
   c2_bottom  = - acoeff(1) / (2.d0*acoeff(2))
   write(ifile,*) '!!! c2 & bottom !!! ..............', &
                       c2_bottom,lhs_bottom
   if (lhs_bottom > rhs) then
      write(ifile,*) '### ERROR ### lhs_bottom > rhs'
      write(ifile,*) '   lhs_bottom ...',lhs_bottom
      write(ifile,*) '   rhs        ...',rhs
      ier = 1 ; go to 99
   end if
   c2min_trial(1) = (-100.d0-ee)/dble(2*ll+3)
   c2max_trial(1) = (  30.d0-ee)/dble(2*ll+3)
   if (c2_bottom > 0.d0) then
      c2min = c2min_trial(1)
      c2max = c2_bottom
   else
      c2min = c2_bottom
      c2max = c2max_trial(1)
   end if
   ierr_count = 0
   c2mid = 0.5d0*(c2min + c2max)
   write(ifile,'(1x,a21,3f20.10)') &
      'c2min,c2mid,c2max ...',c2min,c2mid,c2max
SRCH_C2:do loop = 1,maxloop
   call lhs_tmpp_us(ier,ifile,nmesh,ll,nrc, &
                    gcut0,gcut1,gcut2,gcut3,gcut4, &
                    rpos,wt,c0,c2min,c4,c6,c8,c10,c12,lhsmin)
      if (ier /= 0) then
         write(ifile,*) '### ERROR ### in lhs_tmpp'
         write(ifile,*) '   c2min  ...',c2min
         write(ifile,*) '   lhsmin ...',lhsmin
         go to 99
      end if
   call lhs_tmpp_us(ier,ifile,nmesh,ll,nrc, &
                    gcut0,gcut1,gcut2,gcut3,gcut4, &
                    rpos,wt,c0,c2mid,c4,c6,c8,c10,c12,lhsmid)
      if (ier /= 0) then
         write(ifile,*) '### ERROR ### in lhs_tmpp'
         write(ifile,*) '   c2mid  ...',c2mid
         write(ifile,*) '   lhsmid ...',lhsmid
         go to 99
      end if
   call lhs_tmpp_us(ier,ifile,nmesh,ll,nrc, &
                    gcut0,gcut1,gcut2,gcut3,gcut4, &
                    rpos,wt,c0,c2max,c4,c6,c8,c10,c12,lhsmax)
      if (ier /= 0) then
         write(ifile,*) '### ERROR ### in lhs_tmpp'
         write(ifile,*) '   c2max  ...',c2max
         write(ifile,*) '   lhsmax ...',lhsmax
         go to 99
      end if
   
   if ((lhsmin-rhs)*(lhsmax-rhs) > 0.d0) then
      if (ierr_count == 0) then
         write(ifile,*) '### CAUTION ### rhs is out of range'
         write(ifile,*) '   rhs    ...',rhs
         write(ifile,*) '   lhsmin ...',lhsmin
         write(ifile,*) '   lhsmid ...',lhsmid
         write(ifile,*) '   lhsmax ...',lhsmax
         ierr_count = ierr_count+1   
         if (c2_bottom < 0.d0) then  
            c2min = c2min_trial(1)   
            c2max = c2_bottom        
         else                        
            c2min = c2_bottom        
            c2max = c2max_trial(1)   
         end if
         c2mid = 0.5d0*(c2min + c2max)
      else
         write(ifile,*) '### ERROR ### rhs is out of range'
         write(ifile,*) '   rhs    ...',rhs
         write(ifile,*) '   lhsmin ...',lhsmin
         write(ifile,*) '   lhsmid ...',lhsmid
         write(ifile,*) '   lhsmax ...',lhsmax
         write(ifile,*) 'Error count exceeds the limit !!!'
         ier = 1 ; go to 99
      end if
   else if (lhsmid == rhs) then
      c2max = rhs
      c2min = rhs
   else if ((lhsmin-rhs)*(lhsmid-rhs) < 0.d0) then
      c2max = c2mid
      c2mid = 0.5d0*(c2min + c2max)
   else if ((lhsmid-rhs)*(lhsmax-rhs) < 0.d0) then
      c2min = c2mid
      c2mid = 0.5d0*(c2min + c2max)
   else
      write(ifile,*) '### ERROR ### rhs is an accidental value'
      write(ifile,*) '   rhs    ...',rhs
      write(ifile,*) '   lhsmin ...',lhsmin
      write(ifile,*) '   lhsmid ...',lhsmid
      write(ifile,*) '   lhsmax ...',lhsmax
      ier = 1 ; go to 99
   end if
   write(ifile,'(1x,a21,3f20.10)') &
      'c2min,c2mid,c2max ...',c2min,c2mid,c2max
   if (abs(c2max-c2min) < eps_conv) then 
      exit SRCH_C2                       
   end if                                
   if (loop > maxloop) then
      write(ifile,*) '### ERROR ### c2 was not found !'
      ier = 1 ; go to 99
   end if
end do SRCH_C2
   c2_solved = c2mid
   c2 = c2_solved
   write(ifile,*) '%%% CHECK : ll,c2_solved ...',ll,c2_solved
   write(ifile,*) & 
      'Troullier-Martins norm-conserving p(r) was solved for ll =',ll
   write(ifile,10) '   c0  ...',c0
   write(ifile,10) '   c2  ...',c2
   write(ifile,10) '   c4  ...',c4
   write(ifile,10) '   c6  ...',c6
   write(ifile,10) '   c8  ...',c8
   write(ifile,10) '   c10 ...',c10
   write(ifile,10) '   c12 ...',c12
10 format(1x,a10,f20.10)
   coeff_tm(0) = c0 ; coeff_tm(2) = c2 ; coeff_tm(4) = c4
   coeff_tm(6) = c6 ; coeff_tm(8) = c8 ; coeff_tm(10)= c10
   coeff_tm(12)= c12
   do ir = 1,nrc
      r   = rpos(ir)
      dp  = fn_dp_tm (r,c0,c2,c4,c6,c8,c10,c12)
      ddp = fn_ddp_tm(r,c0,c2,c4,c6,c8,c10,c12)
      veff_ps(ir) = ee + dble(ll+1)/r*dp + 0.5d0*(ddp+dp*dp)
   end do
   do ir = nrc,nmesh
      veff_ps(ir) = veff(ir)
   end do
   do ir = 1,nrc
      r = rpos(ir)
      p = fn_p_tm(r,c0,c2,c4,c6,c8,c10,c12)
      chi_ps(ir) = r**(ll+1) * exp(p)
   end do
   do ir = nrc,nmesh
      chi_ps(ir) = chi(ir)
   end do
   if (is_bound_state == 1) then
      sum = 0.d0
      do ir = 1,nmesh
         sum = sum + chi_ps(ir)**2*wr(ir)
      end do
      write(ifile,*) '%%% check norm of chi_ps for ll --->',ll
      write(ifile,*) '   < chi_ps | chi_ps > ...',sum
   else if (is_bound_state == 0) then
      call set_weight_exp(ier,1,nrc,rpos,wt)
      sum = 0.d0
      do ir = 1,nrc
         sum = sum + chi_ps(ir)**2*wt(ir)
      end do
      write(ifile,*) '%%% check norm of chi_ps for ll --->',ll
      write(ifile,*) '   < chi_ps | chi_ps >R ...',sum
   else
      write(ifile,*) '### ERROR ### is_bound_state is out of range'
      write(ifile,*) '   is_bound_state ...',is_bound_state
      ier = 1 ; go to 99
   end if
   sum = sqrt(sum)
   chi_ps(:) = chi_ps(:) / sum
99 continue
   end subroutine calc_tmpp_us

!=====================================================================
   subroutine check_rphi_tm(ier,ips,nn,ll,tt,eref,deref,nrc,nk_tm, &
                            drpsi_tmp,rphi_tmp, &
                            sumpsi_exact,sumphi_num)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer,intent(in)  :: ips, nn, ll, tt, nrc, nk_tm
   real(8),intent(in)  :: drpsi_tmp(0:nk_tm), rphi_tmp(nmesh), &
                          eref, deref, sumpsi_exact, sumphi_num
   integer :: n1, n2, isdiff, ik
   real(8) :: f0_exact(0:4), f0_anal(0:4), f0_num(0:4), rcut, &
              c0, c2, c4, c6, c8, c10, c12, &
              p0, dp0, ddp0, dddp0, ddddp0, &
                  dq0, ddq0, dddq0, ddddq0, &
              fn_p_tm, fn_dp_tm, fn_ddp_tm, fn_dddp_tm, fn_ddddp_tm
   ier = 0
   do ik = 0,nk_tm
      f0_exact(ik) = drpsi_tmp(ik)
   end do
   f0_anal(:) = 0.d0
   rcut = rpos(nrc)
   c0  = coeff_phi_tm(0,ips,1) ; c2  = coeff_phi_tm(1,ips,1)
   c4  = coeff_phi_tm(2,ips,1) ; c6  = coeff_phi_tm(3,ips,1)
   c8  = coeff_phi_tm(4,ips,1) ; c10 = coeff_phi_tm(5,ips,1)
   c12 = coeff_phi_tm(6,ips,1)
   p0     = fn_p_tm    (rcut,c0,c2,c4,c6,c8,c10,c12)
   dp0    = fn_dp_tm   (rcut,c0,c2,c4,c6,c8,c10,c12)
   ddp0   = fn_ddp_tm  (rcut,c0,c2,c4,c6,c8,c10,c12)
   dddp0  = fn_dddp_tm (rcut,c0,c2,c4,c6,c8,c10,c12)
   ddddp0 = fn_ddddp_tm(rcut,c0,c2,c4,c6,c8,c10,c12)
   dq0    =       dble(ll+1)/rcut + dp0
   ddq0   =      -dble(ll+1)/rcut/rcut + ddp0
   dddq0  =  2.d0*dble(ll+1)/rcut/rcut/rcut + dddp0
   ddddq0 = -6.d0*dble(ll+1)/rcut/rcut/rcut/rcut + ddddp0
   f0_anal(0) = rcut**(ll+1) * exp(p0)
   f0_anal(1) = f0_anal(0)*dq0
   f0_anal(2) = f0_anal(1)*dq0 + f0_anal(0)*ddq0
   f0_anal(3) = f0_anal(2)*dq0 + 2.d0*f0_anal(1)*ddq0 &
              + f0_anal(0)*dddq0
   f0_anal(4) = f0_anal(3)*dq0 + 3.d0*f0_anal(2)*ddq0 &
              + 3.d0*f0_anal(1)*dddq0 + f0_anal(0)*ddddq0
   f0_num(:)  = 0.d0
   isdiff = nk_tm  
   n1 = nrc - 10
   n2 = nrc + 10
   rcut = rpos(nrc)
   call diff4_exp(ier,isdiff,n1,n2,rpos,rphi_tmp,rcut, &
                  f0_num(0),f0_num(1),f0_num(2),f0_num(3),f0_num(4))
   f0_num(0) = rphi_tmp(nrc)
   call write_checked_rphi_tm(IFLOG,nn,ll,tt, &
           nrc,rcut,eref,deref,ncoeff_phi_tm,coeff_phi_tm(0,ips,1), &
           nk_tm,f0_exact,f0_anal,f0_num,sumpsi_exact,sumphi_num)
   call write_checked_rphi_tm(IFSUM,nn,ll,tt, &
           nrc,rcut,eref,deref,ncoeff_phi_tm,coeff_phi_tm(0,ips,1), &
           nk_tm,f0_exact,f0_anal,f0_num,sumpsi_exact,sumphi_num)
99 continue
   end subroutine check_rphi_tm

!=====================================================================
   subroutine write_checked_rphi_tm(ifile,nn,ll,tt, &
      nrc,rcut,eref,deref,ncoeff,coeff,nk,f0_exact,f0_anal,f0_num, &
      sumpsi_exact,sumphi_num)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in) :: ifile, nn, ll, tt, nrc, ncoeff, nk
   real(8),intent(in) :: rcut, eref, deref, coeff(0:6), &
                         f0_exact(0:4), f0_anal(0:4), f0_num(0:4), &
                         sumpsi_exact, sumphi_num
   integer :: icoeff, ik             
   write(ifile,*)
   write(ifile,*)  &
      'Troullier-Martins norm-conserving phi[n](r) was solved.'
   write(ifile,15) ' (n,l,t) :', nn,ll,tt,'NC'
   write(ifile,10) ' rc, nrc :', rcut, nrc
   write(ifile,14) 'eref, de :', eref, deref
   write(ifile,11) 'ncoeff,nk:', ncoeff, nk
   write(ifile,14) 'c0,c2,c4 :',(coeff(icoeff),icoeff=0,2)
   write(ifile,14) 'c6,c8,c10:',(coeff(icoeff),icoeff=3,5)
   write(ifile,14) 'c12      :',(coeff(icoeff),icoeff=6,6)
   write(ifile,13) 'rphi(rc)','rphi''(rc)','rphi"(rc)'
   write(ifile,14) 'Exact    :',(f0_exact(ik),ik=0,2)
   write(ifile,14) 'Analytic :',(f0_anal (ik),ik=0,2)
   write(ifile,14) 'Numerical:',(f0_num  (ik),ik=0,2)
   write(ifile,16) 'rphi"''(rc)','rphi""(rc)','<phi|phi>rc'
   write(ifile,14) 'Exact    :',(f0_exact(ik),ik=3,nk),sumpsi_exact
   write(ifile,14) 'Analytic :',(f0_anal (ik),ik=3,nk)
   write(ifile,14) 'Numerical:',(f0_num  (ik),ik=3,nk),sumphi_num
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),(8x,a11,1x))
   end subroutine write_checked_rphi_tm

!=====================================================================
   subroutine write_coeff_tmpp_us(ier,ifile,ips,tt)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer,intent(in)  :: ifile, ips, tt
   integer :: ishell, nn, ll, nrc, lt
   real(8) :: eref, rcut
   ier = 0
   ishell = ishell_ps(ips,1)
   nn = n_qnum(ishell)
   ll = l_qnum(ishell)
   lt = lt_n_us(ll,tt)  
   nrc  = nrcut_phi_us(lt)
   rcut = rpos(nrc)
   eref = eref_us(lt)
   write(ifile,*)
   write(ifile,*)  &
      'Troullier-Martins normconserving p(r) was solved.'
   write(ifile,12) ' (n,l,t) :',nn,ll,tt
   write(ifile,11) ' rc, nrc :',rcut, nrc
   write(ifile,10) '  eref   :',eref
   write(ifile,10) '  c0,  c2:',coeff_tm(0,ips,1),coeff_tm(2,ips,1)
   write(ifile,10) '  c4,  c6:',coeff_tm(4,ips,1),coeff_tm(6,ips,1)
   write(ifile,10) '  c8, c10:',coeff_tm(8,ips,1),coeff_tm(10,ips,1)
   write(ifile,10) ' c12     :',coeff_tm(12,ips,1)
10 format(1x,a10,2f20.10)
11 format(1x,a10,f20.10,i20)
12 format(1x,a10,10x,(i2,2x,i2,2x,i2))
   end subroutine write_coeff_tmpp_us

!=====================================================================
   subroutine lhs_tmpp_us(ier,ifile,nmesh,ll,nrc, &
                          gcut0,gcut1,gcut2,gcut3,gcut4, &
                          rpos,wt,c0,c2,c4,c6,c8,c10,c12,lhs)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: ifile, nmesh, ll, nrc
   real(8),intent(in)  :: rpos(nmesh), &
                          gcut0, gcut1, gcut2, gcut3, gcut4, c2
   integer,intent(out) :: ier
   real(8),intent(out) :: wt(nmesh), c0, c4, c6, c8, c10, c12, lhs
   integer :: ir
   real(8) :: rcut, sum, fn_p_tm, r, arg
   ier = 0
   rcut = rpos(nrc)
   call gtmpp_us(ier,ifile,ll, &
                 rcut,gcut0,gcut1,gcut2,gcut3,gcut4, &
                 c0,c2,c4,c6,c8,c10,c12)
   if (ier /= 0) then
      write(ifile,*) '### ERROR ### in gtmpp_us' ; go to 99
   end if
   call set_weight_exp(ier,1,nrc,rpos,wt)
   sum = 0.d0
   do ir = 1,nrc
      r  = rpos(ir)
      arg = 2.d0 * (fn_p_tm(r,c0,c2,c4,c6,c8,c10,c12) - c0)
      sum = sum + r**(2*ll+2)*exp(arg)*wt(ir)
   end do
   lhs = 2.d0*c0 + log(sum)
99 continue
   end subroutine lhs_tmpp_us

!=====================================================================
   subroutine gtmpp_us(ier,ifile,ll, &
                       rcut,gcut0,gcut1,gcut2,gcut3,gcut4, &
                       c0,c2,c4,c6,c8,c10,c12)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: ifile, ll
   real(8),intent(in)  :: rcut, gcut0, gcut1, gcut2, gcut3, gcut4, c2
   integer,intent(out) :: ier
   real(8),intent(out) :: c0, c4, c6, c8, c10, c12
   real(8) :: rcut2, rcut3, rcut4, &
              pcut0, pcut1, pcut2, pcut3, pcut4, &
              k1, k2, k3, k4
   integer :: n_mat, n_vec
   real(8),allocatable :: mat_a(:,:), vec_x(:,:), vec_b(:,:)
   ier = 0
   n_mat = 5 ; n_vec = 1
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   allocate(mat_a(n_mat,n_mat),vec_x(n_mat,n_vec),vec_b(n_mat,n_vec))
      mat_a = 0.d0 ; vec_x = 0.d0 ; vec_b = 0.d0
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   call set_amat_tm(rcut,mat_a)
   k1 = gcut1/gcut0 ; k2 = gcut2/gcut0
   k3 = gcut3/gcut0 ; k4 = gcut4/gcut0
   rcut2 = rcut * rcut
   rcut3 = rcut * rcut2
   rcut4 = rcut * rcut3
   pcut0 = log(gcut0) - dble(ll+1) * log(rcut)
   pcut1 = k1 - dble(ll+1)/rcut
   pcut2 = k2 - k1*k1 + dble(ll+1)/rcut2
   pcut3 = k3 - 3.d0*k2*k1 + 2.d0*k1*k1*k1 - 2.d0*dble(ll+1)/rcut3
   pcut4 = k4 - 4.d0*k3*k1 - 3.d0*k2*k2 + 12.d0*k2*k1*k1 &
         - 6.d0*k1*k1*k1*k1 + 6.d0*dble(ll+1)/rcut4
   c4 = - c2*c2/dble(2*ll+5)
   vec_b(1,1) = pcut0 -      c2*rcut2 -       c4*rcut2*rcut2
   vec_b(2,1) = pcut1 - 2.d0*c2*rcut  -  4.d0*c4*rcut2*rcut
   vec_b(3,1) = pcut2 - 2.d0*c2       - 12.d0*c4*rcut2
   vec_b(4,1) = pcut3                 - 24.d0*c4*rcut
   vec_b(5,1) = pcut4                 - 24.d0*c4
   call axb_real_matrix(ier,n_mat,n_vec,mat_a,vec_x,vec_b)
   if (ier /= 0) then
      write(ifile,*) '### ERROR ### ier != 0 : ier =',ier ; go to 99
   end if
   c0  = vec_x(1,1) ; c6  = vec_x(2,1) ; c8 = vec_x(3,1)
   c10 = vec_x(4,1) ; c12 = vec_x(5,1)
  !++++++++++++++++++++++++++++++
   deallocate(mat_a,vec_x,vec_b)
  !++++++++++++++++++++++++++++++
99 continue
   end subroutine gtmpp_us

!=====================================================================
   function fn_p_tm(r,c0,c2,c4,c6,c8,c10,c12)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   real(8),intent(in) :: r, c0, c2, c4, c6, c8, c10, c12
   real(8) :: fn_p_tm, r2, r4, r6, r8, r10, r12
   r2  = r   * r  ; r4  = r2  * r2 ; r6  = r4  * r2 
   r8  = r6  * r2 ; r10 = r8  * r2 ; r12 = r10 * r2
   fn_p_tm = c0 + c2*r2 + c4*r4 + c6*r6 + c8*r8 + c10*r10 + c12*r12
   end function fn_p_tm

!=====================================================================
   function fn_dp_tm(r,c0,c2,c4,c6,c8,c10,c12)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   real(8),intent(in) :: r, c0, c2, c4, c6, c8, c10, c12
   real(8) :: fn_dp_tm, r2, r3, r5, r7, r9, r11
   r2  = r  * r  ; r3  = r  * r2 ; r5  = r3 * r2
   r7  = r5 * r2 ; r9  = r7 * r2 ; r11 = r9 * r2
   fn_dp_tm = 2.d0*c2*r + 4.d0*c4*r3 + 6.d0*c6*r5 + 8.d0*c8*r7 &
            + 10.d0*c10*r9 + 12.d0*c12*r11
   end function fn_dp_tm

!=====================================================================
   function fn_ddp_tm(r,c0,c2,c4,c6,c8,c10,c12)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   real(8),intent(in) :: r, c0, c2, c4, c6, c8, c10, c12
   real(8) :: fn_ddp_tm, r2, r4, r6, r8, r10
   r2  = r  * r  ; r4  = r2 * r2 ; r6  = r4 * r2
   r8  = r6 * r2 ; r10 = r8 * r2
   fn_ddp_tm = 2.d0*c2 + 12.d0*c4*r2 + 30.d0*c6*r4 + 56.d0*c8*r6 &
            + 90.d0*c10*r8 + 132.d0*c12*r10
   end function fn_ddp_tm

!=====================================================================
   function fn_dddp_tm(r,c0,c2,c4,c6,c8,c10,c12)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   real(8),intent(in) :: r, c0, c2, c4, c6, c8, c10, c12
   real(8) :: fn_dddp_tm, r2, r3, r5, r7, r9

   r2  = r  * r  ; r3  = r  * r2 ; r5  = r3 * r2
   r7  = r5 * r2 ; r9  = r7 * r2
   fn_dddp_tm = 24.d0*c4*r + 120.d0*c6*r3 + 336.d0*c8*r5 &
            + 720.d0*c10*r7 + 1320.d0*c12*r9

   end function fn_dddp_tm

!=====================================================================
   function fn_ddddp_tm(r,c0,c2,c4,c6,c8,c10,c12)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   real(8),intent(in) :: r, c0, c2, c4, c6, c8, c10, c12
   real(8) :: fn_ddddp_tm, r2, r4, r6, r8, r10
   r2  = r  * r  ; r4  = r2 * r2 ; r6  = r4 * r2
   r8  = r6 * r2 ; r10 = r8 * r2
   fn_ddddp_tm = 24.d0*c4 + 360.d0*c6*r2 + 1680.d0*c8*r4 &
            + 5040.d0*c10*r6 + 11880.d0*c12*r8
   end function fn_ddddp_tm

!=====================================================================
   subroutine set_amat_tm(r,amat)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   real(8),intent(in)  :: r
   real(8),intent(out) :: amat(5,5)
   real(8) :: r2, r3, r4, r5, r6, r7, r8, r9, r10, r11, r12
   r2 =r  *r ; r3 =r2 *r ; r4 =r3 *r ; r5 =r4 *r ; r6 =r5 *r
   r7 =r6 *r ; r8 =r7 *r ; r9 =r8 *r ; r10=r9 *r ; r11=r10*r
   r12=r11*r
   amat(1,1) =     1.d0      ; amat(1,2) =     1.d0*r6
   amat(1,3) =     1.d0*r8   ; amat(1,4) =     1.d0*r10
   amat(1,5) =     1.d0*r12  
   amat(2,1) =     0.d0      ; amat(2,2) =     6.d0*r5
   amat(2,3) =     8.d0*r7   ; amat(2,4) =    10.d0*r9
   amat(2,5) =    12.d0*r11
   amat(3,1) =     0.d0      ; amat(3,2) =    30.d0*r4
   amat(3,3) =    56.d0*r6   ; amat(3,4) =    90.d0*r8
   amat(3,5) =   132.d0*r10
   amat(4,1) =     0.d0      ; amat(4,2) =   120.d0*r3
   amat(4,3) =   336.d0*r5   ; amat(4,4) =   720.d0*r7
   amat(4,5) =  1320.d0*r9
   amat(5,1) =     0.d0      ; amat(5,2) =   360.d0*r2
   amat(5,3) =  1680.d0*r4   ; amat(5,4) =  5040.d0*r6
   amat(5,5) = 11880.d0*r8
   end subroutine set_amat_tm
