! ************************************************************* 
!
!   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_bound_state, calc_vcoeff, set_initpoints_left
!                : int_from_left, set_initpoints_right, int_from_right
!                : guess_de, write_orbital, analysis_orbital
!  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_bound_state(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ishell, ll, ll_core, nn, ispin, kk, id,  &
              node, node_sum, nrt, nrm, nmesh_max
   real(8) :: r, rr, ee, vv, ss, mass, de, gg_norm, g_norm, &
              sign_gr, ee_upper_limit, ee_lower_limit,      &
              ee_upper_limit_in, engy_minimum,              &
              sum, tmp, etest
   integer :: num_eslides, max_eslides, loop, max_loop, jr
   ier    =  0
   max_eslides  =  25
   if (natom >= 104) then
      max_loop = 1000
   else
      max_loop = 600
   end if
   engy_minimum = 1.d-4
   call calc_vcoeff(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in calc_vcoeff' ; go to 99
   end if
MAIN:do ishell = 1,nshell
      if (is_solve(ishell) == 0) then
         engy(ishell) = 0.d0 ; cycle MAIN
      end if
      ispin = (1-spin(ishell))/2 + 1
      ll = l_qnum(ishell)
      if (is_core == PATOM) then
         ll_core = ll
      else
         ll_core = lmax_core
      end if
      nn = n_qnum(ishell)
      kk = k_qnum(ishell)
      node = nn - ll - 1
      num_eslides = 0
      if (is_core == OZAKI_KINO) then
         nmesh_max = nrcut_ok + 20
      else
         nmesh_max = nmm_pos(ishell)
      end if
         write(IFLOG,'(1x,a31,5i5)') &
            '??? ishell,ispin,nn,ll,node ...',ishell,ispin,nn,ll,node
      if (mod(node,2) == 0) then
         sign_gr = +1.d0
      else
         sign_gr = -1.d0
      end if
      ee = engy(ishell)
      if (is_core == OZAKI_KINO) then
         ee_upper_limit = 100.d0
      else
         ee_upper_limit = veff(nmesh_max,ispin,ll_core) - engy_minimum
         if (ee_upper_limit > -engy_minimum) then
            ee_upper_limit = -engy_minimum
         end if
      end if
      ee_upper_limit_in = ee_upper_limit
      ee_lower_limit = -fatom**2 / dble(nn)**2
      if ((ee > ee_upper_limit).or.(ee < ee_lower_limit)) then
         ee = 0.5d0*(ee_upper_limit + ee_lower_limit)
      end if
      de = ee
      loop = 0
SRCH_EE:do while (abs(de) > eps_de)
      loop = loop + 1
      if (loop > max_loop) then
         if (node_sum < node) then
            write(IFLOG,*) '### CAUTION ### node_sum < node'
            write(IFLOG,*) '   node_sum,node ...',node_sum,node
            write(IFLOG,*) &
               '   Following state may be an unbound state.'
            write(IFLOG,*) '      ishell          ...',ishell
            write(IFLOG,*) '      (nn,ll,kk,spin) ...',nn,ll,kk, &
                            '     ('//spin_label(ishell)(1:1)//')'
            if (abs(focc(ishell)) > eps_check) then
               write(IFLOG,*) '   Since focc of the state is non-zero,'
               write(IFLOG,*) '      calculation continues.'
               exit SRCH_EE
            else
               write(IFLOG,*) &
                  '   The state is removed in the later calc.'
               is_solve(ishell) = 0 ; ee = 0.d0 ; exit SRCH_EE
            end if
         else
            write(IFLOG,*) '### ERROR ### loop > max_loop'
            write(IFLOG,*) '   loop, max_loop    ...',loop,max_loop
            write(IFLOG,*) '   ishell,nn,ll,node ...',ishell,nn,ll,node
            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
            ier=1 ; go to 99
         end if
      end if
      if (num_eslides > max_eslides) then
         write(IFLOG,*) '### CAUTION ### Eigenvalue was not converged !'
         write(IFLOG,*) '      num_eslides     ...',num_eslides
         write(IFLOG,*) '      max_eslides     ...',max_eslides
         write(IFLOG,*) '   Following state may be an unbound state.'
         write(IFLOG,*) '      ishell          ...',ishell
         write(IFLOG,*) '      (nn,ll,kk,spin) ...',nn,ll,kk, &
                            '     ('//spin_label(ishell)(1:1)//')'
         if (abs(focc(ishell)) > eps_check) then
            write(IFLOG,*) '   Since focc of the state is non-zero,'
            write(IFLOG,*) '      calculation continues.'
            exit SRCH_EE
         else
            write(IFLOG,*) '   The state is removed in the later calc.'
            is_solve(ishell) = 0 ; ee = 0.d0 ; exit SRCH_EE
         end if
      end if
SRCH_RT:do ir = nmesh_max,10,-1
         r = rpos(ir)
         tmp = veff(ir,ispin,ll_core)-ee
         if (tmp < 0.d0) then
            nrt = ir ; exit SRCH_RT
         end if
      end do SRCH_RT
      nrt_pos(ishell) = nrt
      id = +1
      call set_initpoints_left(ier,ll,kk,ispin,ee)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in set_initpoints_left'
         go to 99
      end if
      call int_from_left(ier,node_sum,nrt,id,ll,kk,ee,ispin)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in int_from_left' ; go to 99
      end if
      if (node_sum > node) then
         if (ee < ee_upper_limit) then
            ee_upper_limit = ee
         end if
         if (ee_upper_limit > ee_upper_limit_in) then
            ee_upper_limit = ee_upper_limit_in
         end if
         ee = 0.5d0*(ee + ee_lower_limit)
         ee_lower_limit = ee_lower_limit * 1.2d0
         cycle SRCH_EE
      else if (node_sum < node) then
         if (ee > ee_lower_limit) then
            ee_lower_limit = ee
         end if
         ee = 0.5d0*(ee_upper_limit + ee)
         ee_upper_limit = ee_upper_limit_in
         ee = 0.5d0*(ee_upper_limit + ee)
         cycle SRCH_EE
      end if
      nrm = nrt
SRCH_RM:do ir = nrt,10,-1
         if (sign_gr*(chi_gl(ir-1)-chi_gl(ir)) < 0.d0) then
            nrm = ir ; exit SRCH_RM
         end if
         if (ir <= 10) then
            write(IFLOG,*) '### ERROR ### nrm was not found (SRCH_RM)'
            write(IFLOG,*) '   ir  ...',ir
            write(IFLOG,*) '   nrt ...',nrt
            write(IFLOG,*) '   ee      ...',ee
            write(IFLOG,*) '   ispin   ...',ispin
            write(IFLOG,*) '   ll_core ...',ll_core
         if (is_xc_class == GGA) then
            write(IFLOG,*) 'DEBUG:'
            write(IFLOG,*) &
               'DEBUG: jr, rpos, chi_gl, veff, vion, vh, vxc, rho, drho, ddrho'
            do jr = 1,nrt
               write(IFLOG,80) & 
                  jr,rpos(jr),chi_gl(jr),veff(jr,ispin,ll_core), &
                  vion(jr,ll_core),vh(jr),vx(jr,ispin)+vc(jr,ispin), &
                  rho(jr,ispin),drho(jr,ispin),ddrho(jr,ispin)
            end do
            write(IFLOG,*)
               80 format(1x,'DEBUG:',i5,10(1pe15.5))
         end if
            ier = 1 ; go to 99
         end if
      end do SRCH_RM
      nrm_pos(ishell) = nrm
      nmesh_max = nmesh
      do ir = nmesh,10,-1
         r  = rpos(ir)
         vv = veff(ir,ispin,ll_core)
         select case (is_calc)
         case (NONREL)
            ss = sqrt(2.d0*abs(ee-vv))
         case (SREL,REL)
            mass = 1.d0 + 0.5d0 * ALPHA * ALPHA * (ee-vv)
            ss   = sqrt(2.d0*mass*abs(ee-vv))
         end select
         if (ss*r < ARGMAX) then
            nmesh_max = ir ; exit
         end if
      end do
      if (nmesh_max < nmesh) then
         r  = rpos(nmesh_max)
         vv = veff(nmesh_max,ispin,ll_core)
         select case (is_calc)
         case (NONREL)
            ss = sqrt(2.d0*abs(ee-vv))
         case (SREL,REL)
            mass = 1.d0 + 0.5d0 * ALPHA * ALPHA * (ee-vv)
            ss   = sqrt(2.d0*mass*abs(ee-vv))
         end select
      do ir = nmesh_max+1,nmesh
         r  = rpos(ir)
         vv = veff(ir,ispin,ll_core)
         select case (is_calc)
         case (NONREL)
            ss = sqrt(2.d0*abs(ee-vv))
         case (SREL,REL)
            mass = 1.d0 + 0.5d0 * ALPHA * ALPHA * (ee-vv)
            ss   = sqrt(2.d0*mass*abs(ee-vv))
         end select
         select case (is_calc)
         case (NONREL)
            chi_gr(ir) = exp(-ss*r) * sign_gr
            chi_fr(ir) = -ss * chi_gr(ir) 
         case (SREL)
            chi_gr(ir) = exp(-ss*r) * sign_gr
            chi_fr(ir) = -ss/(2.d0*mass) * chi_gr(ir) 
         case (REL)
            chi_gr(ir) = exp(-ss*r) * sign_gr
            chi_fr(ir) = -ss*ALPHA/(2.d0*mass) * chi_gr(ir) 
         end select        
         dxchi_gr(ir) = 0.d0
         dxchi_fr(ir) = 0.d0
      end do
      end if
      id = -1
      call set_initpoints_right(ier,nmesh_max,sign_gr,ispin,ll,ee)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in set_initpoints_right'
         go to 99
      end if
      nrt = nrm-1-max(iord_pc,iord_diff)
      call int_from_right(ier,nmesh_max,nrt,id,ll,kk,ee,ispin)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in int_from_right' ; go to 99
      end if
      rr = chi_gl(nrm) / chi_gr(nrm)
      do ir = nmesh,nrm-1,-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(ier,nrm,ispin,ll_core,ee,de,gg_norm)
      if (ier /= 0) then

! ================================ modified by K. T. ============================ 4.0
!         write(IFLOG,*) '### ERROR ### in guess_de' ; go to 99

#ifdef mode_v300
         write(IFLOG,*) '### ERROR ### in guess_de' ; go to 99
#else
         write(IFLOG,*) '### ERROR ### in guess_de'
         write(IFLOG,*) '# is_solve( ', ishell, ' ) is forced to be 0 '
         is_solve(ishell) = 0
#endif
! ============================================================================== 4.0

      end if
      if (de > 0.d0) then
         ee_lower_limit = ee
      else if (de < 0.d0) then
         ee_upper_limit = ee
         if (ee_upper_limit > ee_upper_limit_in) then
            ee_upper_limit = ee_upper_limit_in
         end if
      end if
      etest = ee + de
      if ((etest-ee_upper_limit)*(etest-ee_lower_limit) < 0.d0) then
         ee = etest
      else
         ee = 0.5d0*(ee_upper_limit + ee_lower_limit)
         num_eslides = num_eslides + 1
      end if
         write(IFLOG,'(1x,a20,i5,f25.15,1pe20.10)') &
           '??? ishell,ee,de ...',ishell,ee,de
end do SRCH_EE
      engy(ishell) = ee
      if (is_solve(ishell) == 0) then
         cycle MAIN
      end if
      g_norm = sqrt(gg_norm)
      select case (is_calc)
      case (NONREL,SREL)
         do ir = 1,nrm
              chi_g(ir,ishell) =   chi_gl(ir)/g_norm
            dxchi_g(ir,ishell) = dxchi_gl(ir)/g_norm
         end do
         do ir = nrm,nmesh
              chi_g(ir,ishell) =   chi_gr(ir)/g_norm
            dxchi_g(ir,ishell) = dxchi_gr(ir)/g_norm
         end do
      case (REL)
         do ir = 1,nrm
              chi_g(ir,ishell) =   chi_gl(ir)/g_norm
            dxchi_g(ir,ishell) = dxchi_gl(ir)/g_norm
              chi_f(ir,ishell) =   chi_fl(ir)/g_norm
            dxchi_f(ir,ishell) = dxchi_fl(ir)/g_norm
         end do
         do ir = nrm,nmesh
              chi_g(ir,ishell) =   chi_gr(ir)/g_norm
            dxchi_g(ir,ishell) = dxchi_gr(ir)/g_norm
              chi_f(ir,ishell) =   chi_fr(ir)/g_norm
            dxchi_f(ir,ishell) = dxchi_fr(ir)/g_norm
         end do
      end select
      sum = 0.d0
      select case (is_calc)
      case (NONREL,SREL)
         do ir = 1,nmesh
            sum = sum + wr(ir)*chi_g(ir,ishell)**2
         end do
      case (REL)
         do ir = 1,nmesh
            sum = sum + wr(ir)*( chi_g(ir,ishell)**2 &
                               + chi_f(ir,ishell)**2 )
         end do
      end select
      sum = sqrt(sum)
      select case (is_calc)
      case (NONREL,SREL)
         do ir = 1,nmesh
              chi_g(ir,ishell) =   chi_g(ir,ishell) / sum * sign_gr
            dxchi_g(ir,ishell) = dxchi_g(ir,ishell) / sum * sign_gr
         end do
      case (REL)
         do ir = 1,nmesh
              chi_g(ir,ishell) =   chi_g(ir,ishell) / sum * sign_gr
            dxchi_g(ir,ishell) = dxchi_g(ir,ishell) / sum * sign_gr
              chi_f(ir,ishell) =   chi_f(ir,ishell) / sum * sign_gr
            dxchi_f(ir,ishell) = dxchi_f(ir,ishell) / sum * sign_gr
         end do
      end select
      nmm_pos(ishell) = nmesh_max
end do MAIN
99 continue
   end subroutine calc_bound_state

!=====================================================================
   subroutine calc_vcoeff(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ncoeff, ispin, ll, ir, i, j
   real(8) :: r
   real(8),allocatable :: rveff(:), rave(:)
   integer :: n_mat, n_vec
   real(8),allocatable :: mat_a(:,:), vec_x(:,:), vec_b(:,:)
   ier = 0
   ncoeff =  iord_coeff
  !+++++++++++++++++++++++++++++++++++++++++
   allocate(rveff(ncoeff),rave(0:2*ncoeff))
      rveff = 0.d0 ; rave = 0.d0
  !+++++++++++++++++++++++++++++++++++++++++
   n_mat = ncoeff ; 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 ll = 0,lmax_core
   do ispin = 1,nspin
      rave(:) = 0.d0 ; rveff(:) = 0.d0
      do ir = 1,20
         r = rpos(ir)
         do i = 0,(n_mat-1)*2
            rave(i) = rave(i) + r**i
         end do
         do i = 1,n_mat
            rveff(i) = rveff(i) + veff(ir,ispin,ll) * r**i
         end do
      end do
      mat_a(:,:) = 0.d0 ; vec_b(:,:) = 0.d0
      do i = 1,n_mat
         vec_b(i,1) = rveff(i)
         do j = 1,n_mat
            mat_a(i,j) = rave(i+j-2)
         end do
      end do
      call axb_real_matrix(ier,n_mat,n_vec,mat_a,vec_x,vec_b)
      if (ier /= 0) then
         write(IFLOG,*) '### ERROR ### in axb_real_matrix'
         go to 99
      end if
      do i = 1,n_mat
         vcoeff(i-2,ispin,ll) = vec_x(i,1)
      end do
   end do
   end do
  !++++++++++++++++++++++++++++++
   deallocate(mat_a,vec_x,vec_b)
   deallocate(rveff,rave)
  !++++++++++++++++++++++++++++++
99 continue
   end subroutine calc_vcoeff

!=====================================================================
   subroutine set_initpoints_left(ier,ll,kk,ispin,ee)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer,intent(in)  :: ll, kk, ispin
   real(8),intent(in)  :: ee
   integer :: ncoeff, icoeff, j, ir, ll_core
   real(8) :: sum, r, mass, power, sum1, sum2, det
   real(8),allocatable :: gcoeff(:), fcoeff(:)
   integer(2) :: n_mat, n_vec
   real(8), allocatable :: mat_a(:,:), vec_b(:,:)
   ier = 0
   ncoeff =  iord_coeff
  !++++++++++++++++++++++++++++++++++++++++++++
   allocate(gcoeff(0:ncoeff),fcoeff(0:ncoeff))
      gcoeff = 0.d0 ; fcoeff = 0.d0
  !++++++++++++++++++++++++++++++++++++++++++++
   if (is_core == PATOM) then
      ll_core = ll
   else
      ll_core = lmax_core
   end if
   select case (is_calc)
   case (NONREL)
      gcoeff(0) = 1.d0
      fcoeff(0) = vcoeff(-1,ispin,ll_core) / dble(ll+1) * gcoeff(0)
      if (ncoeff >= 2) then
         do icoeff = 1,ncoeff-1
            gcoeff(icoeff) =  fcoeff(icoeff-1) / dble(icoeff)
            sum = 0.d0
            do j = -1,icoeff-1
               sum = sum + vcoeff(j,ispin,ll_core)*gcoeff(icoeff-1-j)
            end do
            fcoeff(icoeff) = (-2.d0*ee*gcoeff(icoeff-1)+2.d0*sum) &
                           / dble(icoeff+2*ll+2)
         end do
      end if
      do ir = 1,10
         r = rpos(ir)
         chi_gl(ir) = 0.d0
         chi_fl(ir) = 0.d0
         do icoeff = 0,ncoeff-1
            chi_gl(ir) = chi_gl(ir) &
              + gcoeff(icoeff) * r**(icoeff+ll+1)
            chi_fl(ir) = chi_fl(ir) &
              + fcoeff(icoeff) * r**(icoeff+ll+1)
         end do
         call dgdx_dfdx_nonrel(r,chi_gl(ir),chi_fl(ir), &
              dxchi_gl(ir),dxchi_fl(ir),ll,ee,veff(ir,ispin,ll_core))
      end do
   case (SREL)
      mass = 1.d0 + 0.5d0*ALPHA*ALPHA*(ee-veff(1,ispin,ll_core))
      select case (ll)
      case (0)
         gcoeff(0) = 1.d0 ; power = 1.d0
         do icoeff = 1,ncoeff
            sum = 0.d0
            do j = -1,icoeff-2
               sum = sum + vcoeff(j,ispin,ll_core)*gcoeff(icoeff-j-2)
            end do
            if (icoeff >= 2) then
               sum = sum - ee*gcoeff(icoeff-2)
            end if
            gcoeff(icoeff) = sum * 2.d0*mass &
                                 / dble(icoeff*(icoeff+1))
            fcoeff(icoeff-1) = dble(icoeff) / (2.d0*mass) &
                             * gcoeff(icoeff)
         end do
      case (1:)
         gcoeff(0) = 0.d0 ; gcoeff(1) = 1.d0 ; power = dble(ll)
         fcoeff(0) = dble(ll)/(2.d0*mass) * gcoeff(1)
         if (ncoeff >= 2) then
            do icoeff = 2,ncoeff
               sum = 0.d0
               do j = -1,icoeff-2
                  sum = sum + vcoeff(j,ispin,ll_core) &
                              * gcoeff(icoeff-j-2)
               end do
               sum = sum - ee*gcoeff(icoeff-2)
               gcoeff(icoeff) = sum * 2.d0*mass &
                              / dble((icoeff-1)*(icoeff+2*ll))
               fcoeff(icoeff-1) = dble(icoeff+ll-1) &
                                / (2.d0*mass) * gcoeff(icoeff)
            end do
         end if
      end select
      do ir = 1,10
         r = rpos(ir)
         chi_gl(ir) = 0.d0
         chi_fl(ir) = 0.d0
         do icoeff = 0,ncoeff-1
            chi_gl(ir) = chi_gl(ir) &
              + gcoeff(icoeff) * r**(dble(icoeff)+power)
            chi_fl(ir) = chi_fl(ir) &
              + fcoeff(icoeff) * r**(dble(icoeff)+power)
         end do
         call dgdx_dfdx_srel(r,chi_gl(ir),chi_fl(ir), &
              dxchi_gl(ir),dxchi_fl(ir),ll,ee,veff(ir,ispin,ll_core))
      end do
   case (REL)
      power = sqrt(dble(kk*kk)-(ALPHA*vcoeff(-1,ispin,ll_core))**2)
      if (kk < 0) then
         gcoeff(0) = 1.d0
      else
         gcoeff(0) = ALPHA*ALPHA
      end if
      fcoeff(0) = ALPHA*vcoeff(-1,ispin,ll_core) &
                       / (power-dble(kk)) * gcoeff(0)
      n_mat = 2 ; n_vec = 1
     !++++++++++++++++++++++++++++++++++++++++++++++++
      allocate(mat_a(n_mat,n_mat),vec_b(n_mat,n_vec))
         mat_a = 0.d0 ; vec_b = 0.d0
     !++++++++++++++++++++++++++++++++++++++++++++++++
      if (ncoeff >= 2) then
         do icoeff = 0,ncoeff-2
            mat_a(1,1) = power + dble(icoeff+1+kk)
            mat_a(1,2) = ALPHA*vcoeff(-1,ispin,ll_core)
            mat_a(2,1) = -mat_a(1,2)
            mat_a(2,2) = power + dble(icoeff+1-kk)
            sum1 = 0.d0 ; sum2 = 0.d0
            if (icoeff >= 1) then
               do j = 1,icoeff
                  sum1 = sum1 + vcoeff(j,ispin,ll_core) &
                                * gcoeff(icoeff-j)
                  sum2 = sum2 + vcoeff(j,ispin,ll_core) &
                                * fcoeff(icoeff-j)
               end do
            end if
            vec_b(1,1) = + (2.d0/ALPHA &
                         + ALPHA*(ee-vcoeff(0,ispin,ll_core))) &
                           * fcoeff(icoeff) - ALPHA*sum2
            vec_b(2,1) = - ALPHA*(ee-vcoeff(0,ispin,ll_core)) &
                           * gcoeff(icoeff) + ALPHA*sum1
            det = mat_a(1,1)*mat_a(2,2) - mat_a(1,2)*mat_a(2,1)
            gcoeff(icoeff+1) = (+mat_a(2,2)*vec_b(1,1) &
                                -mat_a(1,2)*vec_b(2,1)) / det
            fcoeff(icoeff+1) = (-mat_a(2,1)*vec_b(1,1) &
                                +mat_a(1,1)*vec_b(2,1)) / det
         end do
      end if
     !++++++++++++++++++++++++
      deallocate(mat_a,vec_b)
     !++++++++++++++++++++++++
      do ir = 1,10
         r = rpos(ir)
         chi_gl(ir) = 0.d0
         chi_fl(ir) = 0.d0
         do icoeff = 0,ncoeff-1
            chi_gl(ir) = chi_gl(ir) &
              + gcoeff(icoeff) * r**(power+dble(icoeff))
            chi_fl(ir) = chi_fl(ir) &
              + fcoeff(icoeff) * r**(power+dble(icoeff))
         end do
         call dgdx_dfdx_rel(r,chi_gl(ir),chi_fl(ir), &
              dxchi_gl(ir),dxchi_fl(ir),kk,ee,veff(ir,ispin,ll_core))
      end do
   end select
99 continue
  !++++++++++++++++++++++++++
   deallocate(gcoeff,fcoeff)
  !++++++++++++++++++++++++++
   end subroutine set_initpoints_left

!=====================================================================
   subroutine int_from_left(ier,node_sum,nrt,id,ll,kk,ee,ispin)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier, node_sum
   integer,intent(in)  :: nrt, id, ll, kk, ispin
   real(8),intent(in)  :: ee
   integer :: nec, ir
   ier = 0
   nec = iord_nec
   node_sum = 0
   select case (iord_pc)
   case(4)
      do ir = 3,nrt+1
         call pc_adams_4(ier,ir,id,ll,kk,ee,nec,ispin)
         if (chi_gl(ir)*chi_gl(ir-1) < 0.d0) then
            node_sum = node_sum + 1
         end if
      end do
   case(5)
      do ir = 4,nrt+1
         call pc_adams_5(ier,ir,id,ll,kk,ee,nec,ispin)
         if (chi_gl(ir)*chi_gl(ir-1) < 0.d0) then
            node_sum = node_sum + 1
         end if
      end do
   case(6)
      do ir = 4,nrt+1
         call pc_adams_6(ier,ir,id,ll,kk,ee,nec,ispin)
         if (chi_gl(ir)*chi_gl(ir-1) < 0.d0) then
            node_sum = node_sum + 1
         end if
      end do
   case(7)
      do ir = 5,nrt+1
         call pc_adams_7(ier,ir,id,ll,kk,ee,nec,ispin)
         if (chi_gl(ir)*chi_gl(ir-1) < 0.d0) then
            node_sum = node_sum + 1
         end if
      end do
   case(8)
      do ir = 6,nrt+1
         call pc_adams_8(ier,ir,id,ll,kk,ee,nec,ispin)
         if (chi_gl(ir)*chi_gl(ir-1) < 0.d0) then
            node_sum = node_sum + 1
         end if
      end do
   case default
      write(IFLOG,*) '### ERROR ### iord_pc is invalid (inc)'
      write(IFLOG,*) '   iord_pc ...',iord_pc
      ier = 1 ; go to 99
   end select
99 continue
   end subroutine int_from_left

!=====================================================================
   subroutine set_initpoints_right(ier,nmesh_max,sign_gr,ispin,ll,ee)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer,intent(in)  :: nmesh_max, ispin, ll
   real(8),intent(in)  :: sign_gr, ee
   integer :: ir, ll_core
   real(8) :: vv, ss, r, mass
   ier = 0
   if (is_core == PATOM) then
      ll_core = ll
   else
      ll_core = lmax_core
   end if
   vv = veff(nmesh_max,ispin,ll_core)
   select case (is_calc)
   case (NONREL)
      ss = sqrt(2.d0*abs(ee-vv))
   case (SREL,REL)
      mass = 1.d0 + 0.5d0 * ALPHA * ALPHA * (ee-vv)
      ss   = sqrt(2.d0*mass*abs(ee-vv))
   end select
   do ir = nmesh_max-10,nmesh_max
      r  = rpos(ir)
      select case (is_calc)
      case (NONREL)
         chi_gr(ir) = exp(-ss*r) * sign_gr
         chi_fr(ir) = -ss * chi_gr(ir)
      case (SREL)
         chi_gr(ir) = exp(-ss*r) * sign_gr
         chi_fr(ir) = -ss/(2.d0*mass) * chi_gr(ir)
      case (REL)
         chi_gr(ir) = exp(-ss*r) * sign_gr
         chi_fr(ir) = -ss*ALPHA/(2.d0*mass) * chi_gr(ir)
      end select
      dxchi_gr(ir) = -ss*r * chi_gr(ir)
      dxchi_fr(ir) = -ss*r * chi_fr(ir)
   end do
99 continue
   end subroutine set_initpoints_right

!=====================================================================
   subroutine int_from_right(ier,nmesh_max,nrm,id,ll,kk,ee,ispin)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer,intent(in)  :: nmesh_max,nrm, id, ll, kk, ispin
   real(8),intent(in)  :: ee
   integer :: nec, ir
   ier = 0
   nec = iord_nec
   select case (iord_pc)
   case (4)
      do ir = nmesh_max-2,nrm-1,-1
         call pc_adams_4(ier,ir,id,ll,kk,ee,nec,ispin)
      end do
   case (5)
      do ir = nmesh_max-3,nrm-1,-1
         call pc_adams_5(ier,ir,id,ll,kk,ee,nec,ispin)
      end do
   case (6)
      do ir = nmesh_max-3,nrm-1,-1
         call pc_adams_6(ier,ir,id,ll,kk,ee,nec,ispin)
      end do
   case (7)
      do ir = nmesh_max-4,nrm-1,-1
         call pc_adams_7(ier,ir,id,ll,kk,ee,nec,ispin)
      end do
   case (8)
      do ir = nmesh_max-4,nrm-1,-1
         call pc_adams_8(ier,ir,id,ll,kk,ee,nec,ispin)
      end do
   case default
      write(IFLOG,*) '### ERROR ### iord_pc is invalid (dec)'
      write(IFLOG,*) '   iord_pc ...',iord_pc
      ier = 1 ; go to 99
   end select
99 continue
   end subroutine int_from_right

!=====================================================================
   subroutine guess_de(ier,nrm,ispin,ll_core,ee,de,gg_norm)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer,intent(in)  :: nrm, ispin, ll_core
   real(8),intent(in)  :: ee
   real(8),intent(out) :: de, gg_norm
   integer :: ir
   real(8) :: sum1, sum2, mass
   ier = 0
   call set_weight_exp(ier,1,nrm,rpos,wt)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in set_weight_exp(1)' ; go to 99
   end if
   sum1 = 0.d0
   select case (is_calc)
   case (NONREL,SREL)
      do ir = 1,nrm
         sum1 = sum1 + chi_gl(ir)**2*wt(ir)
      end do
   case (REL)
      do ir = 1,nrm
         sum1 = sum1 + (chi_gl(ir)**2 + chi_fl(ir)**2)*wt(ir)
      end do
   end select
   call set_weight_exp(ier,nrm,nmesh,rpos,wt)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in set_weight_exp(2)' ; go to 99
   end if
   sum2 = 0.d0
   select case (is_calc)
   case (NONREL,SREL)
      do ir = nrm,nmesh
         sum2 = sum2 + chi_gr(ir)**2*wt(ir)
      end do
   case (REL)
      do ir = nrm,nmesh
         sum2 = sum2 + (chi_gr(ir)**2 + chi_fr(ir)**2)*wt(ir)
      end do
   end select
   gg_norm = sum1 + sum2
   mass = 1.d0 + 0.5d0*ALPHA*ALPHA*(ee-veff(nrm,ispin,ll_core))
   select case (is_calc)
   case (NONREL)
      de = 0.5d0 * chi_gl(nrm) &
                 * (chi_fl(nrm) - chi_fr(nrm)) / gg_norm
   case (SREL)
      de = 0.5d0 * 2.d0*mass * chi_gl(nrm) &
                 * (chi_fl(nrm) - chi_fr(nrm)) / gg_norm
   case (REL)
      de = 0.5d0 * 2.d0*mass/ALPHA * chi_gl(nrm) &
                 * (chi_fl(nrm) - chi_fr(nrm)) / gg_norm
   end select
99 continue
   end subroutine guess_de

!=====================================================================
   subroutine write_orbital(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, nn, ll, j2, ishell, ispin, lshell
   character(10) :: xc_name
   real(8),allocatable :: array_tmp(:)
   ier = 0
  !++++++++++++++++++++++++++++++++++++++++++++++
   allocate(array_tmp(nmesh)) ; array_tmp = 0.d0
  !++++++++++++++++++++++++++++++++++++++++++++++
   open(IFORB,file=trim(orbfile),status='unknown')
   rewind(IFORB)
   write(IFLOG,*) '   Writing ORBITAL -->',IFORB
   call date_time(day_now)
   call write_title(IFORB,day_now)
   write(IFORB,*)
   write(IFORB,'(a16)') '### Atomic label'
   write(IFORB,'((a12,8x),a2,7x,a20)') &
      'atomic_label', atom_label(zatom), atom_name(zatom)
   write(IFORB,*)
   write(IFORB,'(a47)') '### Atomic charge : Z, Za, Zc, Zv, (Ne, Nc, Nv)'
   write(IFORB,'((a13,6x),(i3,4x),3f11.5)') &
      'atomic_charge', zatom, fatom, fcore, fval
   write(IFORB,'((13x,6x),(3x,4x),3f11.5)') &
      felec, felec_core, felec_val
   write(IFORB,*)
   write(IFORB,'(a34)') '### Exchange-correlation potential'
   select case (is_xc)
   case (LDAPZ81)
      xc_name = 'ldapz81'
   case (LDAPW92_MOMO, LDAPW92_MOMO2, LDAPW92_GNCPP)
      xc_name = 'ldapw92'
   case (GGAPW91_MOMO, GGAPW91_MOMO2, GGAPW91_F90, GGAPW91_F77)
      xc_name = 'ggapw91'
   case (GGAPBE96_MOMO, GGAPBE96_MOMO2, GGAPBE96_GNCPP, GGAPBE96_KATO)
      xc_name = 'ggapbe'
   case default
      write(IFLOG,*) '### ERROR ### xc_type'
      write(IFLOG,*) '   is_xc ...', is_xc
      ier = 1 ; go to 99
   end select
   write(IFORB,'((a12,8x),a7,5x,a5)') &
      'xc_potential', xc_name, xc_approx
   write(IFORB,*)
   write(IFORB,'(a30)') '### r-Mesh : Nmesh, rmin, rmax'
   write(IFORB,'(a5,5x,a11)') 'rmesh','logarithmic'
   write(IFORB,'(i10,2(1pe25.15))') nmesh, rmin, rmax
   write(IFORB,*)
   write(IFORB,'(a34)') '### All-electron SCF energy levels'
   select case (is_calc)
   case (NONREL)
      write(IFORB,'(a3,5x,a16)') '#AE','non_relativistic'
   case (SREL)
      write(IFORB,'(a3,5x,a19)') '#AE','scalar_relativistic'
   case (REL)
      write(IFORB,'(a3,5x,a17)') '#AE','full_relativistic'
   end select
   select case (is_spin)
   case (RESTRICTED)
      write(IFORB,'(a3,5x,a15)') '#AE','spin_restricted'
   case (POLARIZED)
      write(IFORB,'(a3,5x,a14)') '#AE','spin_polarized'
   end select
   select case (is_spin)
   case (RESTRICTED)
      select case (is_calc)
      case (NONREL,SREL)
         write(IFORB,21) &
            'symm','Energy (Ha)','Energy (eV)','nocc','focc'
         do ishell = 1,nshell
            lshell = list_shell(ishell)
            if (is_solve(lshell) == NO) then
               cycle
            end if
            write(IFORB,22) state(lshell)(1:2), &
               engy(lshell),engy(lshell)*HARTREE,nocc(lshell),focc(lshell)
         end do
      case (REL)
         write(IFORB,31) &
            'symm','j','Energy (Ha)','Energy (eV)','nocc','focc'
         do ishell = 1,nshell
            lshell = list_shell(ishell)
            if (is_solve(lshell) == NO) then
               cycle
            end if
            write(IFORB,32) state(lshell)(1:2),j2_qnum(lshell), &
               engy(lshell),engy(lshell)*HARTREE,nocc(lshell),focc(lshell)
         end do
      end select
   case (POLARIZED)
      select case (is_calc)
      case (NONREL,SREL)
         write(IFORB,23) &
            'symm','s','Energy (Ha)','Energy (eV)','nocc','focc'
         do ishell = 1,nshell
            lshell = list_shell(ishell)
            if (is_solve(lshell) == NO) then
               cycle
            end if
            write(IFORB,24) state(lshell)(1:2),spin_label(lshell)(1:1), &
               engy(lshell),engy(lshell)*HARTREE,nocc(lshell),focc(lshell)
         end do
      case (REL)
         write(IFORB,33) &
            'symm','j','s','Energy (Ha)','Energy (eV)','nocc','focc'
         do ishell = 1,nshell
            lshell = list_shell(ishell)
            if (is_solve(lshell) == NO) then
               cycle
            end if
            write(IFORB,34) state(lshell)(1:2),j2_qnum(lshell), &
               spin_label(lshell)(1:1), &
               engy(lshell),engy(lshell)*HARTREE,nocc(lshell),focc(lshell)
         end do
      end select
   end select
   select case (is_spin)
   case(RESTRICTED)
      select case (is_calc)
      case (NONREL,SREL)
         write(IFORB,41) 'Total number of electrons',felec
      case (REL)
         write(IFORB,42) 'Total number of electrons',felec
      end select
   case(POLARIZED)
      select case (is_calc)
      case (NONREL,SREL)
         write(IFORB,43) 'Number of electrons (+)',felec1
         write(IFORB,43) '                    (-)',felec2
      case (REL)
         write(IFORB,44) 'Number of electrons (+)',felec1
         write(IFORB,44) '                    (-)',felec2
      end select
   end select
21 format('#AE',(3x,a4),2(9x,a11),(2x,a4),(6x,a4))
22 format('#AE',(4x,a2,1x),2(f20.10),i6,f10.5)
23 format('#AE',(3x,a4),(4x,a1),2(9x,a11),(2x,a4),(6x,a4))
24 format('#AE',(4x,a2,1x),(4x,a1),2(f20.10),i6,f10.5)
31 format('#AE',(3x,a4),(4x,a1,1x),2(9x,a11),(2x,a4),(6x,a4))
32 format('#AE',(4x,a2,1x),(3x,i1,'/2'),2(f20.10),i6,f10.5)
33 format('#AE',(3x,a4),(4x,a1,1x),(4x,a1),2(9x,a11),(2x,a4),(6x,a4))
34 format('#AE',(4x,a2,1x),(3x,i1,'/2'),(4x,a1),2(f20.10),i6,f10.5)
41 format('#AE',2x,a25,26x,f10.5)
42 format('#AE',2x,a25,32x,f10.5)
43 format('#AE',2x,a23,31x,f10.5)
44 format('#AE',2x,a23,37x,f10.5)

   write(IFORB,*)
   write(IFORB,'(a29)') '### All-electron total energy'
   write(IFORB,54) 'Energy (Ha)','Energy (eV)'
   if (is_calc == NONREL) then
   write(IFORB,55) 'Ekin  ',ekin_sum1,ekin_sum1*HARTREE
   else
   write(IFORB,55) 'Ekin  ',ekin_sum ,ekin_sum*HARTREE
   end if
   write(IFORB,55) 'Eion  ',eion_sum ,eion_sum *HARTREE
   write(IFORB,55) 'Eh    ',eh_sum   ,eh_sum   *HARTREE
   write(IFORB,55) 'Exc   ',exc_sum  ,exc_sum  *HARTREE
   if (is_calc == NONREL) then
   write(IFORB,55) 'Etot  ',etot_sum1,etot_sum1*HARTREE
   else
   write(IFORB,55) 'Etot  ',etot_sum ,etot_sum *HARTREE
   end if
54 format('#AE',2x,6x,2(9x,a11))
55 format('#AE',2x,a6,2(f20.10))

   write(IFORB,*)
   write(IFORB,'(a48)') '### All-electron SCF wavefunctions : r*psi[n](r)'
   write(IFORB,'(a21)') 'ae_wave_function_rpsi'
MAIN:do ishell = 1,nshell
      lshell = list_shell(ishell)
      if (is_solve(lshell) == NO) then
         cycle
      end if
      ispin = (1-spin(lshell))/2 + 1
      ll = l_qnum(lshell)
      nn = n_qnum(lshell)
      j2 = j2_qnum(lshell)
      write(IFORB,*)
      write(IFORB,'(1x,a31,4i3)') &
         'r*psi[n](r): n = (n,l,2j,s) -->',nn,ll,j2,ispin
      do ir = 1,nmesh
         if (abs(chi_g(ir,lshell)) < 1.d-99) then
            array_tmp(ir) = 0.d0
         else
            array_tmp(ir) = chi_g(ir,lshell)
         end if
      end do
      write(IFORB,10) (array_tmp(ir),ir=1,nmesh)
      if (is_calc == REL) then
         do ir = 1,nmesh
            if (abs(chi_f(ir,lshell)) < 1.d-99) then
               array_tmp(ir) = 0.d0
            else
               array_tmp(ir) = chi_f(ir,lshell)
            end if
         end do
         write(IFORB,10) (array_tmp(ir),ir=1,nmesh)
      end if
   end do MAIN
   write(IFORB,*)
   write(IFORB,'(a18)') '### End of ORBITAL'
   write(IFORB,'(a3)') 'end'
10 format(3(1pe25.17))
99 continue
   close(IFORB)
  !++++++++++++++++++++++
   deallocate(array_tmp)
  !++++++++++++++++++++++
   end subroutine write_orbital

!=====================================================================
   subroutine analysis_orbital(ier,ifile)
!=====================================================================
!     
!  M. Okamoto
!  
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in)  :: ifile
   integer,intent(out) :: ier
   integer :: nn, ll, j2, ishell, ispin, lshell, l3, i
   real(8) :: ave_rl_tmp(0:3)
   character(100) :: line
   ier = 0
   do i = 1,100
      line(i:i)='-'
   end do
   write(ifile,*)
   write(ifile,*) 'ave  Averaged radius (in a.u.) : < r^L > = < psi[n] | r^L | psi[n] >'
   select case (is_calc)
   case (NONREL,SREL)
      select case (is_spin)
      case (RESTRICTED)
         write(ifile,10) line(1:100)
         write(ifile,11) 'symm','L=0','L=2','L=4','L=6'
         write(ifile,10) line(1:100)
      case (POLARIZED)
         write(ifile,20) line(1:100)
         write(ifile,21) 'symm','s','L=0','L=2','L=4','L=6'
         write(ifile,20) line(1:100)
      end select
   case (REL)
      select case (is_spin)
      case (RESTRICTED)
         write(ifile,30) line(1:100)
         write(ifile,31) 'symm','j','L=0','L=2','L=4','L=6'
         write(ifile,30) line(1:100)
      case (POLARIZED)
         write(ifile,40) line(1:100)
         write(ifile,41) 'symm','j','s','L=0','L=2','L=4','L=6'
         write(ifile,40) line(1:100)
      end select
   end select
MAIN:do ishell = 1,nshell
      lshell = list_shell(ishell)
      if (is_solve(lshell) == NO) then
         cycle
      end if
      ispin = (1-spin(lshell))/2 + 1
      ll = l_qnum(lshell)
      nn = n_qnum(lshell)
      j2 = j2_qnum(lshell)
      ave_rl_tmp(:) = 0.d0
      do l3 = 0,ll
         ave_rl_tmp(l3) = sum(chi_g(:,lshell)**2*wr(:)*rpos(:)**(2*l3))
         if (is_calc == REL) then
            ave_rl_tmp(l3) = ave_rl_tmp(l3) &
               + sum(chi_f(:,lshell)**2*wr(:)*rpos(:)**(2*l3))
         end if
      end do
      select case (is_calc)
      case (NONREL,SREL)
         select case (is_spin)
         case (RESTRICTED)
            write(ifile,12) state(lshell)(1:2),(ave_rl_tmp(l3),l3=0,ll)
         case (POLARIZED)
            write(ifile,22) state(lshell)(1:2),spin_label(lshell)(1:1), &
               (ave_rl_tmp(l3),l3=0,ll)
         end select
      case (REL)
         select case (is_spin)
         case (RESTRICTED)
            write(ifile,32) state(lshell)(1:2),j2_qnum(lshell), &
               (ave_rl_tmp(l3),l3=0,ll)
         case (POLARIZED)
            write(ifile,42) state(lshell)(1:2),j2_qnum(lshell), &
               spin_label(lshell)(1:1), &
               (ave_rl_tmp(l3),l3=0,ll)
         end select
      end select
   end do MAIN
   select case (is_calc)
   case (NONREL,SREL)
      select case (is_spin)
      case (RESTRICTED)
         write(ifile,10) line(1:100)
      case (POLARIZED)
         write(ifile,20) line(1:100)
      end select
   case (REL)
      select case (is_spin)
      case (RESTRICTED)
         write(ifile,30) line(1:100)
      case (POLARIZED)
         write(ifile,40) line(1:100)
      end select
   end select
10 format(1x,'ave',a68)
11 format(1x,'ave',(3x,a4),4(9x,a3,3x))
12 format(1x,'ave',(4x,a2,1x),4(f15.6))
20 format(1x,'ave',a73)
21 format(1x,'ave',(3x,a4),(4x,a1),4(9x,a3,3x))
22 format(1x,'ave',(4x,a2,1x),(4x,a1),4(f15.6))
30 format(1x,'ave',a74)
31 format(1x,'ave',(3x,a4),(4x,a1,1x),4(9x,a3,3x))
32 format(1x,'ave',(4x,a2,1x),(3x,i1,'/2'),4(f15.6))
40 format(1x,'ave',a79)
41 format(1x,'ave',(3x,a4),(4x,a1,1x),(4x,a1),4(9x,a3,3x))
42 format(1x,'ave',(4x,a2,1x),(3x,i1,'/2'),(4x,a1),4(f15.6))
99 continue
   end subroutine analysis_orbital

