!
!  Software name : CIAO (Code for Investigating Atomic Orbitals)
!  Subroutine(s) : write_title_pao, calc_bound_state_pao
!                : calc_nodes_range, calc_beta_phi_pao
!                : write_energy_level_pao, write_pao
!  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 write_title_pao(ifile)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in) :: ifile
   integer :: i
   character(100) :: line1, line2
   do i=1,100
      line1(i:i) = '/'
      line2(i:i) = '/'
   end do
   line2(38:42) = ' PAO '
   write(ifile,*)
   write(ifile,50) line1
   write(ifile,*) 'PAO'
50 format(a80)
   end subroutine write_title_pao

!=====================================================================
   subroutine set_vloc_pao(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: n1_tmp, n2_tmp, ir
   real(8) :: vl_tmp, dvl_tmp, dummy, b_ok(0:3), r
   ier = 0
  !++++++++++++++++++++++++++++++++++++++++++++
   allocate(vloc_pao(nmesh)) ; vloc_pao = 0.d0
  !++++++++++++++++++++++++++++++++++++++++++++
   select case (is_pao_type)
   case (CORE_POTENTIAL_CONFINEMENT)

! ========================================== modiifed by K. T. =============== 4.0
!      vloc_pao(:) = vloc_scr_sol(:)
      vloc_pao(:) = vloc_scr_sol(:,1)
! =========================================================================== 4.0

   case (OZAKI_KINO_CONFINEMENT)
      do ir = nmesh,1,-1
         r = rpos(ir)
         if (r < rcut_ok) then
            nrcut_ok = ir+1 ; exit
         end if
      end do
      n1_tmp = nrcut_ok - 6
      n2_tmp = nrcut_ok + 6
      call diff_exp(ier,1,n1_tmp,n2_tmp,rpos,vloc_scr_sol,rcut_ok-drcl_ok, &
           vl_tmp,dvl_tmp,dummy)
      call calc_coeff_ok_pao(vl_tmp,dvl_tmp,rcut_ok,drcl_ok,h_ok,b_ok)
      do ir = 1,nmesh
         r = rpos(ir)
         if (r < rcut_ok - drcl_ok) then
! ================================================= modified by K. T. ========= 4.0
!            vloc_pao(ir) = vloc_scr_sol(ir)
            vloc_pao(ir) = vloc_scr_sol(ir,1)
! ============================================================================= 4.0
         else if (r < rcut_ok) then
            vloc_pao(ir) = &
               b_ok(0) + r*(b_ok(1) + r*(b_ok(2) + r*b_ok(3)))
         else
            vloc_pao(ir) = h_ok
         end if
      end do
   end select
99 continue
   end subroutine set_vloc_pao

!=====================================================================
   subroutine calc_coeff_ok_pao(vl,dvl,rc,dr,h,b)
!=====================================================================
   implicit none
   real(8),intent(in)  :: vl, dvl, 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) = vl ; bvec(2) = dvl ; 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_pao

!=====================================================================
   subroutine calc_bound_state_pao(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   real(8),allocatable :: &
      bsum(:), amat(:,:), bvec(:), coeff(:), fmat(:,:), hmat(:,:), &
      h0vec(:), rphi_gl(:,:), dxrphi_gl(:,:)
   integer :: ir, nn, ll, tt, lt, t1, t2, lt1, lt2, &
              ltt, nref, nrm, nrt, node_sum, node, nmesh_max, &
              loop, max_loop, ipao, node_sum_left, node_sum_right, &
              lguess, max_loop_in
   real(8) :: ee, de, r, vv, ss, rr, &
              sign_gr, ee_upper_limit, ee_lower_limit,         &
              ee_upper_limit_in, sum, etest, fguess, gg_norm,  &
              eps_de_tmp = 1.d-9
   ier = 0
   max_loop_in  =  50
  !++++++++++++++++++++++++++++++++++++
   allocate(bsum(nmesh)) ; bsum = 0.d0
  !++++++++++++++++++++++++++++++++++++
   engy_pao(:)       = 1.d0
   rphi_pao(:,:)     = 0.d0
   beta_phi_pao(:,:) = 0.d0
   write(IFLOG,*) 'PAO: num_l_pao ...',num_l_pao
   LOOP_PAO:do ipao = 1,num_pao
      ll = l_pao(ipao)
      nn = n_pao(ipao)
      nref = nref_us(ll)
     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      allocate(amat(nref,nref),bvec(nref),coeff(nref), &
               fmat(nref,nref),hmat(nref,nref),h0vec(nref), &
               rphi_gl(nmesh,0:nref),dxrphi_gl(nmesh,0:nref))
         amat = 0.d0 ; bvec = 0.d0 ; coeff = 0.d0
         fmat = 0.d0 ; hmat = 0.d0 ; h0vec = 0.d0
         rphi_gl = 0.d0 ; dxrphi_gl = 0.d0
     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      fguess = 0.5d0
      lguess = 1
      node = nn - 1
      node_sum = node
      if (mod(node,2) == 0) then
         sign_gr = +1.d0
      else
         sign_gr = -1.d0
      end if
         write(IFLOG,'(1x,a29,5i5)') &
            'PAO: ipao,ll,nn,node ...',ipao,ll,nn,node
      ee = engy_pao(ipao)
      nmesh_max = nrcut_ok + 20
      ee_upper_limit = 20.d0
      ee_upper_limit_in = ee_upper_limit
      ee_lower_limit = minval(engy_sol(:)) - 1.d0
      if ((ee > ee_upper_limit).or.(ee < ee_lower_limit)) then
         ee = 0.5d0*(ee_upper_limit + ee_lower_limit)
      end if
      de = ee_upper_limit - ee_lower_limit
      nrm = max(nrcut_ok &
         - int(dble(nmesh-1)*log(2.d0)/log(dble(rmax)/dble(rmin))), &
           nrcut_ok/2)
      max_loop = max_loop_in
      loop = 0
   SRCH_EE:do while (abs(de) > eps_de_tmp)
      loop = loop + 1
      if (loop > max_loop) then
         if (lguess < 2) then
            lguess = lguess + 1
            fguess = fguess * 0.5d0
            max_loop = max_loop * 2
            loop = 0
            node_sum = node
            cycle SRCH_EE
         end if
         write(IFLOG,*) '### ERROR ### loop > max_loop'
         write(IFLOG,*) '   loop, max_loop    ...',loop,max_loop
         write(IFLOG,*) '   ipao,ll,nn        ...',ipao,ll,nn
         write(IFLOG,*) '   node_sum,node     ...',node_sum,node
         write(IFLOG,*) '   ee_upper_limit    ...',ee_upper_limit
         write(IFLOG,*) '   ee_lower_limit    ...',ee_lower_limit
         write(IFLOG,*) '   ee                ...',ee
         write(IFLOG,*) '   de                ...',de
         ier=1 ; go to 99
      end if
      nrt = nrm + 1 + max(iord_pc,iord_diff)
      bsum(:) = 0.d0
      call set_initpoints_left_sol(ier,nmesh,ll,ee,rpos, &
              chi_gl,chi_fl,dxchi_gl,dxchi_fl,vloc_pao,bsum)
      call int_from_left_sol(ier,nmesh,node_sum,nrt, &
              ll,ee,iord_nec,dx,rpos, &
              chi_gl,chi_fl,dxchi_gl,dxchi_fl,vloc_pao,bsum)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in int_from_left_sol [0]'
         go to 99
      end if
      rphi_gl(:,0)   = chi_gl(:)
      dxrphi_gl(:,0) = dxchi_gl(:)
      do tt = 1,nref
         lt = lt_n_us(ll,tt)
         bsum(:) = -rbeta_us(:,lt)
         call set_initpoints_left_sol(ier,nmesh,ll,ee,rpos, &
                 chi_gl,chi_fl,dxchi_gl,dxchi_fl,vloc_pao,bsum)
         call int_from_left_sol(ier,nmesh,node_sum,nrt, &
                 ll,ee,iord_nec,dx,rpos, &
                 chi_gl,chi_fl,dxchi_gl,dxchi_fl,vloc_pao,bsum)
         if (ier /= 0) then
            write(IFLOG,*) '### ERROR ### in int_from_left_sol [1]'
            go to 99
         end if
         rphi_gl(:,tt)   = chi_gl(:)
         dxrphi_gl(:,tt) = dxchi_gl(:)
      end do
      fmat(:,:) = 0.d0
      do t1 = 1,nref
         lt1 = lt_n_us(ll,t1)
         do t2 = 1,nref
            ltt = ltt_nm_us(ll,t1,t2)
            fmat(t1,t2) = dmat_us(ltt) - ee*q_sum_us(ltt)
            sum = 0.d0
            do ir = 1,nmesh
               sum = sum + rbeta_us(ir,lt1)*rphi_gl(ir,t2)*wr(ir)
            end do
            hmat(t1,t2) = sum
         end do
      end do
      amat(:,:) = matmul(fmat(:,:),hmat(:,:))
      do tt = 1,nref
         amat(tt,tt) = amat(tt,tt) + 1.d0
         lt = lt_n_us(ll,tt)
         sum = 0.d0
         do ir = 1,nmesh
            sum = sum + rbeta_us(ir,lt)*rphi_gl(ir,0)*wr(ir)
         end do
         h0vec(tt) = sum
      end do
      bvec = -matmul(fmat,h0vec)
      call axb_real_matrix(ier,nref,1,amat,coeff,bvec)
      chi_gl(:)   = rphi_gl(:,0)
      dxchi_gl(:) = dxrphi_gl(:,0)
      do tt = 1,nref
         chi_gl(:) = chi_gl(:) + coeff(tt)*rphi_gl(:,tt)
         dxchi_gl(:) = dxchi_gl(:) + coeff(tt)*dxrphi_gl(:,tt)
      end do
      do ir = 1,nrt
         r = rpos(ir)
         chi_fl(ir) = dxchi_gl(ir)/r - dble(ll+1)/r*chi_gl(ir)
      end do
      call calc_nodes_range(nmesh,chi_gl,2,nrm,node_sum_left)
      nmesh_max = nrcut_ok + 20
      if (nmesh_max < nmesh) then
         r  = rpos(nmesh_max)
         vv = vloc_pao(nmesh_max)
         ss = sqrt(2.d0*abs(ee-vv))
         do ir = nmesh_max+1,nmesh
            r  = rpos(ir)
            vv = vloc_pao(ir)
            ss = sqrt(2.d0*abs(ee-vv))
            chi_gr(ir) = exp(-ss*r) * sign_gr
            chi_fr(ir) = -ss * chi_gr(ir) 
            dxchi_gr(ir) = 0.d0
            dxchi_fr(ir) = 0.d0
         end do
      end if
      call set_initpoints_right_sol(ier, &
              nmesh,nmesh_max,ll,ee,rpos, &
              chi_gr,chi_fr,dxchi_gr,dxchi_fr, &
              vloc_pao,bsum,sign_gr)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in set_initpoints_right_sol'
         go to 99
      end if
      nrt = nrm - 1 - max(iord_pc,iord_diff)
      call int_from_right_sol(ier,nmesh,nmesh_max,nrt, &
              ll,ee,iord_nec,dx,rpos, &
              chi_gr,chi_fr,dxchi_gr,dxchi_fr, &
              vloc_pao,bsum)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in int_from_right_sol'
         go to 99
      end if
      call calc_nodes_range(nmesh,chi_gr,nrm,nmesh_max,node_sum_right)
      node_sum = node_sum_left + node_sum_right
      if (node_sum > node) then
         ee_upper_limit = min(ee,ee_upper_limit)
         ee_upper_limit = min(ee_upper_limit_in,ee_upper_limit)
         ee = 0.5d0*(ee + ee_lower_limit)
         cycle SRCH_EE
      else if (node_sum < node) then
         ee_lower_limit = max(ee,ee_lower_limit)
         ee = 0.5d0*(ee_upper_limit + ee)
         cycle SRCH_EE
      end if
      rr = chi_gl(nrm) / chi_gr(nrm)
      do ir = nmesh,nrt,-1
           chi_gr(ir) =   chi_gr(ir) * rr
           chi_fr(ir) =   chi_fr(ir) * rr
         dxchi_gr(ir) = dxchi_gr(ir) * rr
         dxchi_fr(ir) = dxchi_fr(ir) * rr
      end do
      call guess_de_sol(ier,IFLOG,nmesh,nrm,rpos,wt, &
              chi_gl,chi_fl,chi_gr,chi_fr,de,fguess,gg_norm)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in guess_de' ; go to 99
      end if
      etest = ee + de
      if (etest > ee_upper_limit) then
         ee_upper_limit = etest + 0.5d0*de
      else if (etest < ee_lower_limit) then
         ee_lower_limit = etest + 0.5d0*de
      end if
      ee = etest
         write(IFLOG,'(1x,a30,4i5,f25.15,1pe20.10)') &
           'PAO: ipao,ll,nn,node,ee,de ...',ipao,ll,nn,node_sum,ee,de
   end do SRCH_EE
      engy_pao(ipao) = ee
      do ir = 1,nrm
         rphi_pao(ir,ipao) = chi_gl(ir)
         drphi_pao(ir,ipao) = dxchi_gl(ir)
      end do
      do ir = nrm,nmesh
         rphi_pao(ir,ipao) = chi_gr(ir)
         drphi_pao(ir,ipao) = dxchi_gr(ir)
      end do
      call calc_beta_phi_pao(ier,ipao)
      sum = 0.d0
      do ir = 1,nmesh
         sum = sum + rphi_pao(ir,ipao)**2*wr(ir)
      end do
      do t1 = 1,nref
      do t2 = 1,nref
         lt1 = lt_n_us(ll,t1)
         lt2 = lt_n_us(ll,t2)
         ltt = ltt_nm_us(ll,t1,t2)
         sum = sum + q_sum_us(ltt) &
                   * beta_phi_pao(lt1,ipao) &
                   * beta_phi_pao(lt2,ipao)
      end do
      end do
      rphi_pao(:,ipao) = rphi_pao(:,ipao)/sqrt(sum)*sign_gr
      drphi_pao(:,ipao) = drphi_pao(:,ipao)/sqrt(sum)*sign_gr
      call calc_beta_phi_pao(ier,ipao)
      do ir = 1,nmesh
         if (abs(rphi_pao(ir,ipao)) < 1.d-99) then
            rphi_pao(ir,ipao) = 0.d0
         end if
         if (abs(drphi_pao(ir,ipao)) < 1.d-99) then
            drphi_pao(ir,ipao) = 0.d0
         end if
      end do
     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      deallocate(amat,bvec,coeff,fmat,hmat,h0vec,rphi_gl,dxrphi_gl)
     !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   end do LOOP_PAO
99 continue
  !+++++++++++++++++
   deallocate(bsum)
  !+++++++++++++++++
   end subroutine calc_bound_state_pao

!=====================================================================
   subroutine calc_nodes_range(nmesh,func,nr1,nr2,nodes)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: nmesh, nr1, nr2
   real(8),intent(in)  :: func(nmesh)
   integer,intent(out) :: nodes
   integer :: ir
   nodes = 0
   do ir = nr1,nr2
      if (func(ir-1)*func(ir) < 0.d0) then
         nodes = nodes + 1
      end if
   end do
   end subroutine calc_nodes_range

!=====================================================================
   subroutine calc_beta_phi_pao(ier,ipao)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in)  :: ipao
   integer,intent(out) :: ier
   integer :: ir, ll, nref, tt, lt
   real(8) :: sum
   ier = 0
   beta_phi_pao(:,ipao) = 0.d0
   ll = l_pao(ipao)
   nref = nref_us(ll)
   do tt = 1,nref
      lt = lt_n_us(ll,tt)
      if (ll == lloc) then
         sum = 1.d0
      else
         sum = 0.d0
         do ir = 1,nmesh
            sum = sum &
                + wr(ir) * rbeta_us(ir,lt) * rphi_pao(ir,ipao)
         end do
      end if
      beta_phi_pao(lt,ipao) = sum
   end do
99 continue
   end subroutine calc_beta_phi_pao

!=====================================================================
   subroutine write_energy_level_pao(ifile)
!=====================================================================  
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in) :: ifile
   integer        :: i, nn, ll, ipao, nodes, lpao
   character(100) :: line
   character(1)   :: fn_label_orbital
   integer,allocatable :: idx_tmp(:)
  !+++++++++++++++++++++++++++
   allocate(idx_tmp(num_pao))
  !+++++++++++++++++++++++++++
   call sort_simple(num_pao,engy_pao,idx_tmp)
   do i = 1,100
      line(i:i)='-'
   end do
   write(ifile,*)
   write(ifile,*) 'eng  Energy levels of PAO [Solved]'
   write(ifile,*) 'eng  PAO type ---> ',adjustl(pao_formula)
   write(ifile,10) line(1:100)
   write(ifile,11) 'symm', 'number', 'nodes', &
                   'Energy (Ha)','Energy (eV)'
   write(ifile,10) line(1:100)
   do ipao = 1,num_pao
      lpao = idx_tmp(ipao)
      ll = l_pao(lpao)
      nn = n_pao(lpao)
      nodes = nn - 1
      write(ifile,12) fn_label_orbital(ll),nn,nodes, &
         engy_pao(lpao),engy_pao(lpao)*HARTREE
   end do
   write(ifile,10) line(1:100)
10 format(1x,'eng',a72)
11 format(1x,'eng',(6x,a4),(4x,a6),(5x,a5),2(9x,a11))
12 format(1x,'eng',(8x,a1,1x),2i10,2f20.10)
  !++++++++++++++++++++
   deallocate(idx_tmp)
  !++++++++++++++++++++
   end subroutine write_energy_level_pao

!=====================================================================
   subroutine write_pao(ier)
!=====================================================================
!
!  M. Okamoto
!     
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, nn, ll, ipao
   character(1) :: ch_ln, ch_nn, fn_label_orbital
   character(2) :: ch_del
   character(3) :: ch3
   ier = 0
   ch_del = ','//' '
   open(IFPAO,file=trim(paofile),status='unknown')
   write(IFPAO,*) 'PAO primitive orbitals'
   call write_file_header(IFPAO)
   do ipao = 1,num_pao
      nn  = n_pao(ipao)
      ll  = l_pao(ipao)
      ch_ln = fn_label_orbital(ll)
      write(ch_nn,'(i1)') nn
      ch3(1:3) = '_'//ch_ln(1:1)//ch_nn(1:1)
      write(IFPAO,*)
      write(IFPAO,*)  'PAO type ---> ',adjustl(pao_formula)
      write(IFPAO,*)  '(l,n)    --->',ll,nn
      write(IFPAO,20) 'energy   --->',engy_pao(ipao)
      write(IFPAO,20) 'rcut     --->',rcut_ok
      write(IFPAO,20) 'rl       --->',rcut_ok - drcl_ok
      write(IFPAO,20) 'height   --->',h_ok
      write(IFPAO,*)  'nrcut    --->',nrcut_ok
      write(IFPAO,*)  'nmesh    --->',nmesh
      write(IFPAO,*) &
         'rpos'//ch3//ch_del//'rphi'//ch3//ch_del//'drphi'//ch3
      do ir = 1,nmesh
         write(IFPAO,10) rpos(ir), &
            rphi_pao(ir,ipao),drphi_pao(ir,ipao)
      end do
   end do
10 format(10(1pe20.10))
20 format(1x,a13,f20.10)
   close(IFPAO)
   end subroutine write_pao

!=====================================================================
   subroutine set_pao_formula
!=====================================================================
!
!  M. Okamoto
!     
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer :: ipos, il, ll, nn
   character(1) :: fn_label_orbital
   read(atom_label(zatom),*) pao_formula
   ipos = len_trim(pao_formula) + 1
   pao_formula(ipos:ipos) = '-' ; ipos = ipos + 1
   do il = 1,num_l_pao
      ll = lnum_pao(il)
      nn = nnum_pao(il)
      write(pao_formula(ipos:ipos),'(a1)') fn_label_orbital(ll) ; ipos = ipos + 1
      write(pao_formula(ipos:ipos),'(i1)') nn ; ipos = ipos + 1
   end do
   end subroutine set_pao_formula

