!
!  Software name : CIAO (Code for Investigating Atomic Orbitals)
!  Subroutine(s) : calc_tmso_pp_rel, write_param_tmso, find_nrc_tmso,
!                  calc_vh_tmso, calc_vxc_exc_tmso,
!                  write_tmsopp, write_rcut_tmso
!  Author(s)     : Masakuni Okamoto (May 22, 2007)
!
!
!  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_tmso_pp_rel(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ips, iso, ishell, ll, kk, i, ir, is_solved, node, nrm, &
              loop, ntries, is_converged
   integer :: nn, tt, tn, nrc, ll_core, &
              is_bound_state, nk_tm, n1, n2, isdiff, icoeff, lt, nodes
   real(8) :: eref, deref, gcut0, gcut1, gcut2, gcut3, gcut4, rcut, &
              sumpsi_exact, sumphi_num, arg
   integer,allocatable :: nrcut_tmp(:)
   real(8),allocatable :: drpsi_tmp(:), rphi_tmp(:), chi_g_tmp(:)

! ============================================== modiifed by K. T. ========= 4.0
!   rho_ps(:) = 0.d0
   rho_ps = 0.d0
! ========================================================================== 4.0

   chi_ps(:,:,:) = 0.d0
   veff_ps(:,:,:) = 0.d0

   nk_tm = 4
   ncoeff_phi_tm = 6
  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   allocate(nrcut_tmp(nps)) ; nrcut_tmp = 0
   allocate(chi_g_tmp(nmesh)) ; chi_g_tmp = 0.d0
   allocate(coeff_tm(0:12,nps,2))
   allocate(coeff_phi_tm(0:ncoeff_phi_tm,nps,2))
   allocate(drpsi_tmp(0:nk_tm),rphi_tmp(nmesh))
      coeff_tm  = 0.d0 ; coeff_phi_tm = 0.d0
      drpsi_tmp = 0.d0 ; rphi_tmp     = 0.d0
  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   do ips = 1,nps
      rcut = rcut_phi_ps(ips,1)
      nrc = 0
      do i = nmesh,1,-1
         if (rpos(i) < rcut) then
            nrc = i ; exit
         end if
      end do
      if (nrc > 0) then
         nrcut_tmp(ips) = nrc
      else
         write(IFLOG,*) '### ERROR ### nrc was not found.'
         write(IFLOG,*) '   ips ...',ips
         stop
      end if
   end do
   coeff_phi_tm(:,:,:) = 0.d0
   !chi_g_tmp(:,:) = chi_g(:,:)
   do ips = 1,nps
   do iso = 1,num_so_ps(ips)
      ishell = ishell_ps(ips,iso)
      nn = n_qnum(ishell)
      ll = l_qnum(ishell)
      write(IFLOG,*)
      write(IFLOG,'(1x,a23,6i5)') &
            '??? lt,ips,nn,ll,iso ...',lt,ips,nn,ll,iso
      nrc = nrcut_tmp(ips)
      rcut = rpos(nrc)
      if (is_solve(ishell) /= 0) then
         if (abs(engy(ishell)) > 1.d-6) then
            is_bound_state = 1
         else
            is_bound_state = 0
         end if
      else
         is_bound_state = 0
      end if
      chi_g_tmp(:) = chi_g(:,ishell)
      select case (is_bound_state)
      case (0)
         call set_weight_exp(ier,1,nrc,rpos,wt)
         arg = 0.d0
         do ir = 1,nrc
            arg = arg + chi_g_tmp(ir)**2*wt(ir)
         end do
         eref = 0.d0
      case (1)
         arg = 0.d0 
         do ir = 1,nmesh 
            arg = arg + chi_g_tmp(ir)**2*wr(ir)
         end do
         eref = engy(ishell)
      end select
      chi_g_tmp(:) = chi_g_tmp(:) / sqrt(arg)
      n1 = nrc - 10 ; n2 = nrc + 10
      if (n1 < 1) then
         n1 = 1 ; n2 = 1 + 10*2
      else if (n2 > nmesh) then
         n1 = nmesh - 10*2 ; n2 = nmesh
      end if
      isdiff = 4
      call diff4_exp(ier,isdiff,n1,n2,rpos,chi_g_tmp(1),rcut, &
                     gcut0,gcut1,gcut2,gcut3,gcut4)
      if (gcut0 < 0.d0) then
         write(IFLOG,*) '### ERROR ### gcut0 < 0'
         write(IFLOG,*) '   gcut0 ...',gcut0
         write(IFLOG,*) '   gcut1 ...',gcut1
         write(IFLOG,*) '   gcut2 ...',gcut2
         write(IFLOG,*) '   gcut3 ...',gcut3
         write(IFLOG,*) '   gcut4 ...',gcut4
         ier = 1 ; go to 99
      end if
      call calc_tmpp_us(ier,IFLOG,is_bound_state, &
           nmesh,rpos,wr,wt, &
           chi_g_tmp(1),veff(1,1,ll_core), &
           chi_ps(1,ips,iso),veff_ps(1,ips,iso), &
           ll,eref,nrc,gcut0,gcut1,gcut2,gcut3,gcut4, &
           coeff_tm(0,ips,iso))
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_tmpp_us'
         go to 99
      end if
      if (is_bound_state == 0) then
         do ir = nrc+1,nmesh
            veff_ps(ir,ips,iso) = veff(ir,1,ll_core)
         end do
      end if
      call set_weight_exp(ier,1,nrc,rpos,wt)
      sumpsi_exact = 0.d0
      sumphi_num   = 0.d0
      do ir = 1,nrc
         sumpsi_exact = sumpsi_exact + chi_g_tmp(ir)**2      * wt(ir)
         sumphi_num   = sumphi_num   + chi_ps(ir,ips,iso)**2 * wt(ir)
      end do
      drpsi_tmp(0) = gcut0 ; drpsi_tmp(1) = gcut1
      drpsi_tmp(2) = gcut2 ; drpsi_tmp(3) = gcut3
      drpsi_tmp(4) = gcut4
      rphi_tmp(:) = chi_ps(:,ips,iso) 
      do icoeff = 0,ncoeff_phi_tm
         coeff_phi_tm(icoeff,ips,iso) = coeff_tm(2*icoeff,ips,iso)
      end do
      call check_rphi_tm(ier,ips,nn,ll,tt,eref,deref,nrc,nk_tm, &
                         drpsi_tmp,rphi_tmp, &
                         sumpsi_exact,sumphi_num)

! ======================================= modified by K. T. =========== 4.0
!      rho_ps(:) = rho_ps(:) + focc(ishell)*chi_ps(:,ips,iso)**2
      rho_ps(:,1) = rho_ps(:,1) + focc(ishell)*chi_ps(:,ips,iso)**2
! ===================================================================== 4.0

   end do
   end do

! ======================================== modified by K. T. =========== 4.0
!   rho_ps(:) = rho_ps(:) / (4.d0*PI*rpos(:)**2)
!   write(IFLOG,*) 'TMSO: sum of rho_ps(:) ...',sum(4.d0*PI*rpos(:)**2*rho_ps(:)*wr(:))
!
   rho_ps(:,1) = rho_ps(:,1) / (4.d0*PI*rpos(:)**2)
   write(IFLOG,*) 'TMSO: sum of rho_ps(:) ...',sum(4.d0*PI*rpos(:)**2*rho_ps(:,1)*wr(:))
! ====================================================================== 4.0

   if (is_pcc == PCC) then
      select case (is_pcc_method)
      case (BHSPCC)
         write(IFLOG,*) 'PCC: using special PCC of the BHS type'
         write(IFSUM,*) 'PCC: using special PCC of the BHS type'
         do ir = 1,nmesh
            arg = a_bhspcc * rpos(ir) * rpos(ir)
            arg = min(arg,99.d0)
            rho_pcore(ir) = b_bhspcc * exp(-arg) / (4.d0*PI)
         end do
      case (POLYNOMIAL, SBESSEL)
         call calc_rho_pcore_sol(ier)
      end select
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in calc_rho_pcore_sol' ; go to 99
      end if
      !!!call check_rho_pcore_sol(ier)
      !!!call calc_pcc_fourier_sol(ier)
      !if (ier /= 0) then
      !   write(IFLOG,*) '### ERROR ### in calc_pcc_fourier_sol' ; go to 99
      !end if
   end if
  !++++++++++++++++++++++++++++++++++++++++++++++++++++++
   if (is_xc_class == GGA) then

! ============================================= modified by K. T. ========= 4.0
!      allocate(drho_ps(nmesh),ddrho_ps(nmesh))
      allocate(drho_ps(nmesh,1),ddrho_ps(nmesh,1))
! ========================================================================= 4.0

      drho_ps = 0.d0 ; ddrho_ps = 0.d0
      
      allocate(drho_core(nmesh),ddrho_core(nmesh))
         drho_core = 0.d0 ; ddrho_core = 0.d0
      if (is_pcc == PCC) then
         allocate(drho_pcore(nmesh),ddrho_pcore(nmesh))
            drho_pcore = 0.d0 ; ddrho_pcore = 0.d0
      end if
   end if
  !++++++++++++++++++++++++++++++++++++++++++++++++++++++
   if (is_xc_class == GGA) then
      call calc_drho_ddrho_ps(ier)
   end if
   call calc_vh_tmso(ier,nmesh,rpos,rho_ps,vh_ps)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in calc_vh_tmso' ; go to 99
   end if

! =============================================== modified by K. T. =========== 4.0
!   vx_ps(:) = 0.d0 ; vxpc_ps(:) = 0.d0
!   vc_ps(:) = 0.d0 ; vcpc_ps(:) = 0.d0
!
   vx_ps(:,:) = 0.d0 ; vxpc_ps(:) = 0.d0
   vc_ps(:,:) = 0.d0 ; vcpc_ps(:) = 0.d0
! ============================================================================== 4.0

   ex_ps(:) = 0.d0 ; expc_ps(:) = 0.d0
   ec_ps(:) = 0.d0 ; ecpc_ps(:) = 0.d0

   call calc_vxc_exc_tmso(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in calc_vxc_exc_tmso' ; go to 99
   end if
   vion_ps(:,:,:) = 0.d0
   do ips = 1,nps
   do iso = 1,num_so_ps(ips)
      vion_ps(:,ips,iso) = veff_ps(:,ips,iso) &
! ========================================== modified by K. T. ================ 4.0
!         - vh_ps(:) - vx_ps(:) - vc_ps(:)
         - vh_ps(:) - vx_ps(:,1) - vc_ps(:,1)
! ============================================================================= 4.0
   end do
   end do
   vscr_tmso(:,:) = 0.d0
   vion_tmso(:,:) = 0.d0
   vso_tmso(:,:)  = 0.d0
   do ips = 1,nps
      do iso = 1,num_so_ps(ips)
         ishell = ishell_ps(ips,iso)
         ll = l_qnum(ishell)
         kk = k_qnum(ishell)
         if (ll == 0) then
            vscr_tmso(:,ips) = veff_ps(:,ips,iso)
            vion_tmso(:,ips) = vion_ps(:,ips,iso)
            vso_tmso (:,ips) = 0.d0
         else if (kk < 0) then
            vscr_tmso(:,ips) = vscr_tmso(:,ips) + veff_ps(:,ips,iso)*dble(ll+1)
            vion_tmso(:,ips) = vion_tmso(:,ips) + vion_ps(:,ips,iso)*dble(ll+1)
            vso_tmso (:,ips) = vso_tmso (:,ips) + vion_ps(:,ips,iso)*2.d0
         else
            vscr_tmso(:,ips) = vscr_tmso(:,ips) + veff_ps(:,ips,iso)*dble(ll)
            vion_tmso(:,ips) = vion_tmso(:,ips) + vion_ps(:,ips,iso)*dble(ll)
            vso_tmso (:,ips) = vso_tmso (:,ips) - vion_ps(:,ips,iso)*2.d0
         end if
      end do
      vscr_tmso(:,ips) = vscr_tmso(:,ips) / dble(2*ll+1)
      vion_tmso(:,ips) = vion_tmso(:,ips) / dble(2*ll+1)
      vso_tmso (:,ips) = vso_tmso (:,ips) / dble(2*ll+1)
   end do

  !+++++++++++++++++++++++++++++++++++++++++
   if (is_xc_class == GGA) then
      deallocate(drho_core,ddrho_core)
      if (is_pcc == PCC) then
         deallocate(drho_pcore,ddrho_pcore)
      end if
   end if
  !+++++++++++++++++++++++++++++++++++++++++
99 continue
   end subroutine calc_tmso_pp_rel
   
!=====================================================================
   subroutine write_param_tmso(ier,ifile,ips,iso)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in)  :: ifile, ips, iso
   integer,intent(out) :: ier
   integer :: n1, l1, ishell, n2, l2, k2, jj
   real(8) :: psi2_sum, g2_sum, f2_sum, vmax, vmin
   ier = 0
   n1 = n_val_label_ps(ips)
   l1 = l_val_label_ps(ips)
   ishell = ishell_ps(ips,iso)
   n2 = n_qnum(ishell)
   l2 = l_qnum(ishell)
   k2 = k_qnum(ishell)
   jj = j2_qnum(ishell)
   write(ifile,*)
   write(ifile,*) 'ips,iso   ...',ips,iso
   write(ifile,*) 'n1,l1     ...',n1,l1
   write(ifile,*) 'n2,l2,k2  ...',n2,l2,k2
   write(ifile,*) '2*j       ...',jj
   write(ifile,*) 'ishell    ...',ishell
   write(ifile,*) 'focc      ...',focc(ishell)
   write(ifile,*) 'Rcut      ...',rcut_phi_ps(ips,1)
   write(ifile,*) 'Rcut (A)  ...',rcut_phi_ps(ips,1)*BOHR
   write(ifile,*) 'is_gen_ps ...',is_gen_ps(ips,iso)
   write(ifile,*) 'is_solve  ...',is_solve(ishell)
   write(ifile,*) 'E         ...',engy(ishell)
   write(ifile,*) 'E (eV)    ...',engy(ishell)*HARTREE
   g2_sum = sum(chi_g(:,ishell)**2*wr(:))
   f2_sum = sum(chi_f(:,ishell)**2*wr(:))
   psi2_sum = g2_sum + f2_sum
   !write(ifile,*) 'g2_sum    ...',g2_sum
   !write(ifile,*) 'f2_sum    ...',f2_sum
   write(ifile,*) 'psi2_sum  ...',psi2_sum
   write(ifile,*) 'nrm       ...',nrm_pos(ishell)
   write(ifile,*) 'Rm        ...',rpos(nrm_pos(ishell))
   write(ifile,*) 'Rm (A)    ...',rpos(nrm_pos(ishell))*BOHR
   vmax = maxval(veff(:,nspin,lmax_core))
   vmin = minval(veff(:,nspin,lmax_core))
   write(ifile,*) 'Vmax      ...',vmax
   write(ifile,*) 'Vmin      ...',vmin
   end subroutine write_param_tmso

!=====================================================================
   subroutine find_nrc_tmso(ier,nmesh,rpos,rcut,nrc)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: nmesh
   real(8),intent(in)  :: rpos(nmesh), rcut
   integer,intent(out) :: ier, nrc
   integer :: ir
   ier = 0
   do ir = nmesh,10,-1
      if (rpos(ir) < rcut) then
         nrc = ir+1 ; exit
      end if
      if (ir == 10) then
         write(*,*) '### ERROR ### nrc was not found.'
         ier = 1 ; go to 99
      end if
   end do
99 continue
   end subroutine find_nrc_tmso

!=====================================================================
   subroutine calc_vh_tmso(ier,nmesh,rpos,rho,vh)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: nmesh
   real(8),intent(in)  :: rpos(nmesh), rho(nmesh)
   integer,intent(out) :: ier
   real(8),intent(out) :: vh(nmesh)
   integer :: ir, ii, i0, is, j, jr
   real(8) :: sum1, sum2
   real(8),allocatable :: wt(:)
   real(8),parameter :: &
      PI = 3.1415926535897932384626433832795028d0
   ier = 0
  !++++++++++++++++++++++++++++++++
   allocate(wt(nmesh)) ; wt = 0.d0
  !++++++++++++++++++++++++++++++++
   do ir = 1,nmesh
      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,wt)
            do j = 1,4
               sum1 = sum1 &
                  + rpos(i0+j*is)**2*rho(i0+j*is)*wt(i0+j*is)
            end do
         end do
      else
         call set_weight_exp(ier,1,ir,rpos,wt)
         do jr = 1,ir
            sum1 = sum1 + rpos(jr)**2*rho(jr)*wt(jr)
         end do
      end if
      sum1 = sum1*(4.d0*PI/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,wt)
            do j = 1,4
               sum2 = sum2 &
                    - rpos(i0+j*is)**2*rho(i0+j*is)*wt(i0+j*is)
            end do
         end do
      else
         call set_weight_exp(ier,ir,nmesh,rpos,wt)
         do jr = ir,nmesh
            sum2 = sum2 + rpos(jr)*rho(jr)*wt(jr)
         end do
      end if
      sum2 = sum2*(4.d0*PI)
      vh(ir) = sum1 + sum2
   end do
  !+++++++++++++++
   deallocate(wt)
  !+++++++++++++++
99 continue
   end subroutine calc_vh_tmso

!=====================================================================
   subroutine calc_vxc_exc_tmso(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

! ========================================== modifed by K. T. ========== 4.0
!   allocate(rho_sol(nmesh)) ; rho_sol = 0.d0
!   allocate(ex_sol(nmesh),ec_sol(nmesh),vx_sol(nmesh),vc_sol(nmesh))
   allocate(rho_sol(nmesh,1)) ; rho_sol = 0.d0
   allocate(ex_sol(nmesh),ec_sol(nmesh),vx_sol(nmesh,1),vc_sol(nmesh,1))
! ====================================================================== 4.0

   ex_sol = 0.d0 ; ec_sol = 0.d0
   vx_sol = 0.d0 ; vc_sol = 0.d0
   allocate( &
      expc_sol(nmesh),ecpc_sol(nmesh),vxpc_sol(nmesh),vcpc_sol(nmesh))
      expc_sol = 0.d0 ; ecpc_sol = 0.d0
      vxpc_sol = 0.d0 ; vcpc_sol = 0.d0
   if (is_xc_class == GGA) then
! ============================================ modifed by K. T. ============ 4.0
!      allocate(drho_sol(nmesh),ddrho_sol(nmesh))
      allocate(drho_sol(nmesh,1),ddrho_sol(nmesh,1))
! ========================================================================== 4.0
         drho_sol = 0.d0 ; ddrho_sol = 0.d0
   end if
  !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

! ====================================== modiifed by K. T. ============= 4.0
!   rho_sol(:) = rho_ps(:)
!   if (is_xc_class == GGA) then
!      drho_sol (:) = drho_ps (:)
!      ddrho_sol(:) = ddrho_ps(:)
!   end if
!
   rho_sol(:,:) = rho_ps(:,:)
   if (is_xc_class == GGA) then
      drho_sol (:,:) = drho_ps (:,:)
      ddrho_sol(:,:) = ddrho_ps(:,:)
   end if
! ========================================================================= 4.0

   call calc_vxc_exc_sol(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in calc_vxc_exc_sol' ; go to 99
   end if

! ========================================= modified by K. T. ============= 4.0
!   vx_ps(:) = vx_sol(:)
!   vc_ps(:) = vc_sol(:)
!
   vx_ps(:,:) = vx_sol(:,:)
   vc_ps(:,:) = vc_sol(:,:)
! ========================================================================== 4.0

   ex_ps(:) = ex_sol(:)
   ec_ps(:) = ec_sol(:)

   vxpc_ps(:) = vxpc_sol(:)
   vcpc_ps(:) = vcpc_sol(:)
   expc_ps(:) = expc_sol(:)
   ecpc_ps(:) = ecpc_sol(:)
  !++++++++++++++++++++++++++++++++++++++++++++++++
   if (allocated(drho_sol)) then
      deallocate(drho_sol,ddrho_sol)
   end if
   deallocate(expc_sol,ecpc_sol,vxpc_sol,vcpc_sol)
   deallocate(ex_sol,ec_sol,vx_sol,vc_sol)
   deallocate(rho_sol)
  !++++++++++++++++++++++++++++++++++++++++++++++++
99 continue
   end subroutine calc_vxc_exc_tmso

!=====================================================================
   subroutine write_tmsopp(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ips, ishell, ll, ir
   character(1) :: fn_label_orbital
   ier = 0
   do ips = 1,nps
      !if (is_gen_ps(ips,1) == 0) then
      !   cycle
      !end if
      ishell = ishell_ps(ips,1)
      ll = l_qnum(ishell)
      tmsoppfile = trim(jobname)//'_'//fn_label_orbital(ll)//'.tmsopp'
      open(IFTMSOPP,file=trim(tmsoppfile),status='unknown')
      rewind(IFTMSOPP)
      write(IFLOG,*) '   Writing TMSOPP for l -->',ll
      write(IFTMSOPP,10) 'TMSO pseudopotential for valence-orbital ll =',ll
      write(IFTMSOPP,20) 'r', 'r*psi', 'r*phi', 'rho_core', 'rho_pc', 'rho_pp', &
                        'vae_scr', 'vpp_scr', 'vpp_ion', 'vpp_so'
      do ir = 1,nmesh
         write(IFTMSOPP,21) &
            rpos(ir), &
            chi_g(ir,ishell), &
            !chi_f(ir,ishell), &
            chi_ps(ir,ips,1), &
            !chi_ps(ir,ips,2), &
            rho_core(ir), &
            rho_pcore(ir), &

! ================================================= modified by K. T. ========== 4.0
!            rho_ps(ir), &
            rho_ps(ir,1), &
! ============================================================================= 4.0

            veff(ir,nspin,lmax_core), &
            vscr_tmso(ir,ips), &
            vion_tmso(ir,ips), &
            vso_tmso(ir,ips)
      end do
      write(IFLOG,*) 'TMSOPP data have been saved into ... ',trim(tmsoppfile)
      write(IFSUM,*) 'TMSOPP data have been saved into ... ',trim(tmsoppfile)
      close(IFTMSOPP)
   end do
10 format('#',1x,a45,i5)
20 format(('#',18x,a1),2(15x,a5),(12x,a8),2(14x,a6),3(13x,a7),(14x,a6))
21 format(12(1pe20.10))
   end subroutine write_tmsopp

!=====================================================================
   subroutine write_rcut_tmso(ifile)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in) :: ifile
   integer        :: i, ishell, ips, iso, tt
   real(8)        :: rcut
   character(100) :: line
   do i = 1,100
      line(i:i)='-'
   end do
   write(ifile,*)
   write(ifile,*) 'rcut  Cutoff radii for TMSO-PP'
   write(ifile,10) line(1:100)
   write(ifile,11) 'symm','j', &
                   'rcut (Bohr)','   rcut (A)'
   write(ifile,10) line(1:100)
   do ips = 1,nps
      tt = 1
      !if (is_gen_ps(ips,1) == 0) then
      !   cycle
      !end if
      do iso = 1,num_so_ps(ips)
         ishell = ishell_ps(ips,iso)
         rcut = rcut_phi_ps(ips,tt)
         write(ifile,12) state(ishell)(1:2),j2_qnum(ishell), &
            rcut,rcut*BOHR
      end do
   end do
   write(ifile,10) line(1:100)
10 format(1x,'rcut',a55)
11 format(1x,'rcut',(3x,a4),(4x,a1,1x),2(9x,a11))
12 format(1x,'rcut',(4x,a2,1x),(3x,i1,'/2'),2(f20.10))
   end subroutine write_rcut_tmso
