!
!  Software name : CIAO (Code for Investigating Atomic Orbitals)
!  Subroutine(s) : sizeof_dipole_l_us, sizeof_dipole_l_ps,
!                : calc_dipole_l_us, calc_dipole_l_ps,
!                : write_dipole_l_us, write_dipole_l_ps,
!                : sizeof_dipole_lm_us, sizeof_dipole_lm_ps,
!                : calc_dipole_lm_us, calc_dipole_lm_ps,
!                : write_rdipole_lm_us, write_rdipole_lm_ps,
!                : write_pdipole_lm_us, write_pdipole_lm_ps,
!                : write_cubic_ylm, set_pxyz, set_phase_ylm
!  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 sizeof_dipole_l_us(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: lt1, lt2, l1, l2, ltlt
   ier = 0
   ltlt = 0
   do lt1 = 1,num_ltx_us
   do lt2 = 1,num_ltx_us
      l1 = l_lt_us(lt1) ; l2 = l_lt_us(lt2)
      if (abs(l1-l2) == 1) then
         ltlt = ltlt + 1
      end if
   end do
   end do
   num_dipole_l_us = ltlt
99 continue
   end subroutine sizeof_dipole_l_us

!======================================= added by K. T. ================= 4.0
subroutine sizeof_dipole_l_us_kt(ier)
  use parameters
  implicit none

  integer,intent(out) :: ier
  integer :: lt1, lt2, l1, l2, ltlt
  integer :: ispin1, ispin2

  ier = 0
  ltlt = 0

  do lt1 = 1,num_ltx_us
     do lt2 = 1,num_ltx_us
        l1 = l_lt_us(lt1) ; l2 = l_lt_us(lt2)

        ispin1 = spin_index_lt_us(lt1)
        ispin2 = spin_index_lt_us(lt2)

        if ( abs(l1-l2) == 1 .and. ispin1 == ispin2 ) then
           ltlt = ltlt + 1
        end if
     end do
  end do

  num_dipole_l_us = ltlt

99 continue

end subroutine sizeof_dipole_l_us_kt
! ============================================================================ 4.0

!=====================================================================
   subroutine sizeof_dipole_l_ps(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: l1, l2, ishell1, ishell2, ips1, ips2, isol1, isol2, nlnl
   ier = 0
   nlnl = 0
   do ips1 = 1,nps
   do ips2 = 1,nps
      ishell1 = ishell_ps(ips1,1) ; ishell2 = ishell_ps(ips2,1)
      l1 = l_qnum(ishell1)        ; l2 = l_qnum(ishell2)
      isol1 = is_solve(ishell1)   ; isol2 = is_solve(ishell2)
      if ((abs(l1-l2) == 1).and.(isol1*isol2 /= 0)) then
         nlnl = nlnl + 1
      end if
   end do
   end do
   num_dipole_l_ps = nlnl
99 continue
   end subroutine sizeof_dipole_l_ps

!============================================ added by K. T. =========== 4.0
subroutine sizeof_dipole_l_ps_kt(ier)
  use parameters
  implicit none

  integer,intent(out) :: ier

  integer :: l1, l2, ishell1, ishell2, ips1, ips2, isol1, isol2, nlnl
  integer :: ispin1, ispin2

  ier = 0
  nlnl = 0

  do ips1 = 1,nps
     do ips2 = 1,nps
        ishell1 = ishell_ps(ips1,1) ; ishell2 = ishell_ps(ips2,1)
        l1 = l_qnum(ishell1)        ; l2 = l_qnum(ishell2)

        ispin1 = spin(ishell1)
        ispin2 = spin(ishell2)

        isol1 = is_solve(ishell1)   ; isol2 = is_solve(ishell2)

        if ((abs(l1-l2) == 1).and.(ispin1==ispin2).and.(isol1*isol2 /= 0)) then
           nlnl = nlnl + 1
        end if
     end do
  end do

  num_dipole_l_ps = nlnl

99 continue

end subroutine sizeof_dipole_l_ps_kt
! ============================================================================= 4.0

!=====================================================================
   subroutine calc_dipole_l_us(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: lt1, lt2, ir, n1, l1, t1, n2, l2, t2, ltlt, lt, nrc
   real(8) :: sum1, sum2, sum3, r
   ier = 0
   drpsi_us(:,:) = 0.d0 ; drphi_us(:,:) = 0.d0
   do lt = 1,num_ltx_us
      call calc_diff_exp(ier,10,nmesh,rpos(1), &
                         rpsi_us(1,lt),drpsi_us(1,lt))
      call calc_diff_exp(ier,10,nmesh,rpos(1), &
                         rphi_us(1,lt),drphi_us(1,lt))
   end do
   nrc = nrcut_phi_max_us
   call set_weight_exp(ier,1,nrc,rpos,wt)
   dipole_r_us(:)  = 0.d0
   dipole_ri_us(:) = 0.d0
   dipole_pr_us(:) = 0.d0
   ltlt = 0
MAIN1:do lt1 = 1,num_ltx_us
MAIN2:do lt2 = 1,num_ltx_us
      n1 = n_lt_us(lt1) ; n2 = n_lt_us(lt2)
      l1 = l_lt_us(lt1) ; l2 = l_lt_us(lt2)
      t1 = t_lt_us(lt1) ; t2 = t_lt_us(lt2)
      if (abs(l1-l2) == 1) then
         ltlt = ltlt + 1
         lt1_dipole_l_us(ltlt) = lt1 ; lt2_dipole_l_us(ltlt) = lt2
         n1_dipole_l_us (ltlt) = n1  ; n2_dipole_l_us (ltlt) = n2
         l1_dipole_l_us (ltlt) = l1  ; l2_dipole_l_us (ltlt) = l2
         t1_dipole_l_us (ltlt) = t1  ; t2_dipole_l_us (ltlt) = t2
      else
         cycle MAIN2
      end if
      sum1 = 0.d0 ; sum2 = 0.d0 ; sum3 = 0.d0
      do ir = 1,nrc
         r = rpos(ir)
         sum1 = sum1 + wt(ir) * r * ( &
              rpsi_us(ir,lt1) * rpsi_us(ir,lt2) &
            - rphi_us(ir,lt1) * rphi_us(ir,lt2) )
         sum2 = sum2 + wt(ir) / r * ( &
              rpsi_us(ir,lt1) * rpsi_us(ir,lt2) &
            - rphi_us(ir,lt1) * rphi_us(ir,lt2) )
         sum3 = sum3 + wt(ir) * ( &
              rpsi_us(ir,lt1) * drpsi_us(ir,lt2) &
            - rphi_us(ir,lt1) * drphi_us(ir,lt2) )
      end do
      dipole_r_us (ltlt) = sum1
      dipole_ri_us(ltlt) = sum2
      dipole_pr_us(ltlt) = sum3
end do MAIN2
end do MAIN1
   if (ltlt /= num_dipole_l_us) then
      write(IFLOG,*) '### ERROR ### ltlt /= num_dipole_l_us'
      write(IFLOG,*) '   ltlt            ...',ltlt
      write(IFLOG,*) '   num_dipole_l_us ...',num_dipole_l_us
      ier = 1 ; go to 99
   end if
   
99 continue
   end subroutine calc_dipole_l_us

!======================================== added by K. T. ==================== 4.0
subroutine calc_dipole_l_us_kt(ier)
  use parameters
  implicit none

  integer,intent(out) :: ier

  integer :: lt1, lt2, ir, n1, l1, t1, n2, l2, t2, ltlt, lt, nrc
  integer :: ispin1, ispin2

  real(8) :: sum1, sum2, sum3, r

  ier = 0
  drpsi_us(:,:) = 0.d0 ; drphi_us(:,:) = 0.d0

  do lt = 1,num_ltx_us
     call calc_diff_exp(ier,10,nmesh,rpos(1), &
          rpsi_us(1,lt),drpsi_us(1,lt))
     call calc_diff_exp(ier,10,nmesh,rpos(1), &
          rphi_us(1,lt),drphi_us(1,lt))
  end do

  nrc = nrcut_phi_max_us

  call set_weight_exp(ier,1,nrc,rpos,wt)

  dipole_r_us(:)  = 0.d0
  dipole_ri_us(:) = 0.d0
  dipole_pr_us(:) = 0.d0

  ltlt = 0

  MAIN1:do lt1 = 1,num_ltx_us

     MAIN2:do lt2 = 1,num_ltx_us

        n1 = n_lt_us(lt1) ; n2 = n_lt_us(lt2)
        l1 = l_lt_us(lt1) ; l2 = l_lt_us(lt2)
        t1 = t_lt_us(lt1) ; t2 = t_lt_us(lt2)

        ispin1 = spin_index_lt_us(lt1)
        ispin2 = spin_index_lt_us(lt2)

        if (abs(l1-l2) == 1 .and. ispin1==ispin2 ) then
           ltlt = ltlt + 1
           lt1_dipole_l_us(ltlt) = lt1 ; lt2_dipole_l_us(ltlt) = lt2
           n1_dipole_l_us (ltlt) = n1  ; n2_dipole_l_us (ltlt) = n2
           l1_dipole_l_us (ltlt) = l1  ; l2_dipole_l_us (ltlt) = l2
           t1_dipole_l_us (ltlt) = t1  ; t2_dipole_l_us (ltlt) = t2

           spin1_index_dipole_l_us(ltlt) = ispin1

        else
           cycle MAIN2
        end if

        sum1 = 0.d0 ; sum2 = 0.d0 ; sum3 = 0.d0
        do ir = 1,nrc
           r = rpos(ir)
           sum1 = sum1 + wt(ir) * r * ( &
                rpsi_us(ir,lt1) * rpsi_us(ir,lt2) &
                - rphi_us(ir,lt1) * rphi_us(ir,lt2) )
           sum2 = sum2 + wt(ir) / r * ( &
                rpsi_us(ir,lt1) * rpsi_us(ir,lt2) &
                - rphi_us(ir,lt1) * rphi_us(ir,lt2) )
           sum3 = sum3 + wt(ir) * ( &
                rpsi_us(ir,lt1) * drpsi_us(ir,lt2) &
                - rphi_us(ir,lt1) * drphi_us(ir,lt2) )
        end do

        dipole_r_us (ltlt) = sum1
        dipole_ri_us(ltlt) = sum2
        dipole_pr_us(ltlt) = sum3

     end do MAIN2
  end do MAIN1

  if (ltlt /= num_dipole_l_us) then
     write(IFLOG,*) '### ERROR ### ltlt /= num_dipole_l_us'
     write(IFLOG,*) '   ltlt            ...',ltlt
     write(IFLOG,*) '   num_dipole_l_us ...',num_dipole_l_us
     ier = 1 ; go to 99
  end if
   
99 continue

end subroutine calc_dipole_l_us_kt
! ============================================================================ 4.0

!=====================================================================
   subroutine calc_dipole_l_ps(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ips, ishell, ips1, ips2, ishell1, ishell2, ir, &
              n1, l1, n2, l2, isol1, isol2, nlnl, iss
   real(8) :: sum1, sum2, sum3, sum4, sum5, sum6, r
   ier = 0
   rpsi_ps(:,:) = 0.d0 ; rphi_ps(:,:) = 0.d0
   do ips = 1,nps
      ishell = ishell_ps(ips,1)
      rpsi_ps(:,ips) = chi_g(:,ishell)
      if ((is_solve_pp_spin /= NO).and.(is_spin_ss == RESTRICTED)) then
         do iss = 1,nss
            if (ishell_ss(iss) == ishell) then
               rphi_ps(:,ips) = rphi_ss(:,iss) ; exit
            end if
            if (iss == nss) then
               write(IFLOG,*) '### ERROR ### iss was not found'
               ier = 1 ; go to 99
            end if
         end do
      else
         rphi_ps(:,ips) = rphi_sol(:,ips)
      end if
   end do
   drpsi_ps(:,:) = 0.d0 ; drphi_ps(:,:) = 0.d0
   do ips = 1,nps
      call calc_diff_exp(ier,10,nmesh,rpos(1), &
                         rpsi_ps(1,ips),drpsi_ps(1,ips))
      call calc_diff_exp(ier,10,nmesh,rpos(1), &
                         rphi_ps(1,ips),drphi_ps(1,ips))
   end do
   dipole_r_ae (:) = 0.d0 ; dipole_r_pp (:) = 0.d0
   dipole_ri_ae(:) = 0.d0 ; dipole_ri_pp(:) = 0.d0
   dipole_pr_ae(:) = 0.d0 ; dipole_pr_pp(:) = 0.d0
   nlnl = 0
MAIN1:do ips1 = 1,nps
MAIN2:do ips2 = 1,nps
      ishell1 = ishell_ps(ips1,1) ; ishell2 = ishell_ps(ips2,1)
      n1 = n_qnum(ishell1)        ; n2 = n_qnum(ishell2)
      l1 = l_qnum(ishell1)        ; l2 = l_qnum(ishell2)
      isol1 = is_solve(ishell1)   ; isol2 = is_solve(ishell2)
      if ((abs(l1-l2) == 1).and.(isol1*isol2 /= 0)) then
         nlnl = nlnl + 1
         ips1_dipole_l_ps(nlnl) = ips1 ; ips2_dipole_l_ps(nlnl) = ips2
         n1_dipole_l_ps(nlnl) = n1     ; n2_dipole_l_ps(nlnl) = n2
         l1_dipole_l_ps(nlnl) = l1     ; l2_dipole_l_ps(nlnl) = l2
      else
         cycle MAIN2
      end if
      sum1 = 0.d0 ; sum2 = 0.d0 ; sum3 = 0.d0
      sum4 = 0.d0 ; sum5 = 0.d0 ; sum6 = 0.d0
      do ir = 1,nmesh
         r = rpos(ir)
         sum1 = sum1 + wr(ir) * r &
              * rpsi_ps(ir,ips1) * rpsi_ps(ir,ips2)
         sum2 = sum2 + wr(ir) / r &
              * rpsi_ps(ir,ips1) * rpsi_ps(ir,ips2)
         sum3 = sum3 + wr(ir) &
              * rpsi_ps(ir,ips1) * drpsi_ps(ir,ips2)
         sum4 = sum4 + wr(ir) * r &
              * rphi_ps(ir,ips1) * rphi_ps(ir,ips2)
         sum5 = sum5 + wr(ir) / r &
              * rphi_ps(ir,ips1) * rphi_ps(ir,ips2)
         sum6 = sum6 + wr(ir) &
              * rphi_ps(ir,ips1) * drphi_ps(ir,ips2)
      end do
      dipole_r_ae (nlnl) = sum1 ; dipole_r_pp (nlnl) = sum4
      dipole_ri_ae(nlnl) = sum2 ; dipole_ri_pp(nlnl) = sum5
      dipole_pr_ae(nlnl) = sum3 ; dipole_pr_pp(nlnl) = sum6
end do MAIN2
end do MAIN1
99 continue
   end subroutine calc_dipole_l_ps

!================================================== added by K. T. ========== 4.0
subroutine calc_dipole_l_ps_kt(ier)
  use parameters
  implicit none

  integer,intent(out) :: ier

  integer :: ips, ishell, ips1, ips2, ishell1, ishell2, ir, &
       n1, l1, n2, l2, isol1, isol2, nlnl, iss
  integer :: ispin1, ispin2

  real(8) :: sum1, sum2, sum3, sum4, sum5, sum6, r

  ier = 0
  rpsi_ps(:,:) = 0.d0 ; rphi_ps(:,:) = 0.d0

  do ips = 1,nps
     ishell = ishell_ps(ips,1)
     rpsi_ps(:,ips) = chi_g(:,ishell)

     if ( (nspin==1).and.(is_solve_pp_spin /= NO).and.(is_spin_ss == RESTRICTED)) then
        do iss = 1,nss
           if (ishell_ss(iss) == ishell) then
              rphi_ps(:,ips) = rphi_ss(:,iss) ; exit
           end if
           if (iss == nss) then
              write(IFLOG,*) '### ERROR ### iss was not found'
              ier = 1 ; go to 99
           end if
        end do
     else
        rphi_ps(:,ips) = rphi_sol(:,ips)
     end if
  end do

  drpsi_ps(:,:) = 0.d0 ; drphi_ps(:,:) = 0.d0

  do ips = 1,nps
     call calc_diff_exp(ier,10,nmesh,rpos(1), &
          rpsi_ps(1,ips),drpsi_ps(1,ips))
     call calc_diff_exp(ier,10,nmesh,rpos(1), &
          rphi_ps(1,ips),drphi_ps(1,ips))
  end do

  dipole_r_ae (:) = 0.d0 ; dipole_r_pp (:) = 0.d0
  dipole_ri_ae(:) = 0.d0 ; dipole_ri_pp(:) = 0.d0
  dipole_pr_ae(:) = 0.d0 ; dipole_pr_pp(:) = 0.d0

  nlnl = 0

  MAIN1:do ips1 = 1,nps

     MAIN2:do ips2 = 1,nps
     
        ishell1 = ishell_ps(ips1,1) ; ishell2 = ishell_ps(ips2,1)
        n1 = n_qnum(ishell1)        ; n2 = n_qnum(ishell2)
        l1 = l_qnum(ishell1)        ; l2 = l_qnum(ishell2)

        ispin1 = ( 1 -spin(ishell1) )/2 +1
        ispin2 = ( 1- spin(ishell2) )/2 +1

        isol1 = is_solve(ishell1)   ; isol2 = is_solve(ishell2)

        if ((abs(l1-l2) == 1).and.(ispin1==ispin2).and.(isol1*isol2 /= 0)) then
           nlnl = nlnl + 1

           ips1_dipole_l_ps(nlnl) = ips1 ; ips2_dipole_l_ps(nlnl) = ips2
           n1_dipole_l_ps(nlnl) = n1     ; n2_dipole_l_ps(nlnl) = n2
           l1_dipole_l_ps(nlnl) = l1     ; l2_dipole_l_ps(nlnl) = l2

           spin1_index_dipole_l_ps(nlnl) = ispin1

        else
           cycle MAIN2
        end if

        sum1 = 0.d0 ; sum2 = 0.d0 ; sum3 = 0.d0
        sum4 = 0.d0 ; sum5 = 0.d0 ; sum6 = 0.d0

        do ir = 1,nmesh
           r = rpos(ir)
           sum1 = sum1 + wr(ir) * r &
                * rpsi_ps(ir,ips1) * rpsi_ps(ir,ips2)
           sum2 = sum2 + wr(ir) / r &
                * rpsi_ps(ir,ips1) * rpsi_ps(ir,ips2)
           sum3 = sum3 + wr(ir) &
                * rpsi_ps(ir,ips1) * drpsi_ps(ir,ips2)
           sum4 = sum4 + wr(ir) * r &
                * rphi_ps(ir,ips1) * rphi_ps(ir,ips2)
           sum5 = sum5 + wr(ir) / r &
                * rphi_ps(ir,ips1) * rphi_ps(ir,ips2)
           sum6 = sum6 + wr(ir) &
                * rphi_ps(ir,ips1) * drphi_ps(ir,ips2)
        end do

        dipole_r_ae (nlnl) = sum1 ; dipole_r_pp (nlnl) = sum4
        dipole_ri_ae(nlnl) = sum2 ; dipole_ri_pp(nlnl) = sum5
        dipole_pr_ae(nlnl) = sum3 ; dipole_pr_pp(nlnl) = sum6

     end do MAIN2
  end do MAIN1

99 continue

end subroutine calc_dipole_l_ps_kt
! ============================================================================ 4.0

!=====================================================================
   subroutine write_dipole_l_us(ifile)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in) :: ifile
   integer :: n1, l1, t1, n2, l2, t2, ltlt
   character(3) :: ch1, ch2
   character(1) :: fn_label_orbital
   write(ifile,*)
   write(ifile,*) &
      '[n|r|m]   = <psi[n]|r|psi[m]>   - <phi[n]|r|phi[m]>   =  [m|r|n]'
   write(ifile,*) &
      '[n|1/r|m] = <psi[n]|1/r|psi[m]> - <phi[n]|1/r|phi[m]> =  [m|1/r|n]'
   write(ifile,*) &
      '[n|pr|m]  = <psi[n]|pr|psi[m]>  - <phi[n]|pr|phi[m]>  = -[n|pr|m]'
   write(ifile,*) &
      'where pr = (1/r)*(d/dr)*r'
   write(ifile,*)
   write(ifile,*) &
      '   n = (n1,l1,t1), m = (n2,l2,t2)'
   write(ifile,10) '[n]','[m]','[n|r|m]','[n|1/r|m]','[n|pr|m]'
   do ltlt = 1,num_dipole_l_us
      n1 = n1_dipole_l_us(ltlt) ; n2 = n2_dipole_l_us(ltlt)
      l1 = l1_dipole_l_us(ltlt) ; l2 = l2_dipole_l_us(ltlt)
      t1 = t1_dipole_l_us(ltlt) ; t2 = t2_dipole_l_us(ltlt)
      if (l1 > l2) then
         cycle
      end if
      write(ch1,'(i1,a1,i1)') n1, fn_label_orbital(l1), t1
      write(ch2,'(i1,a1,i1)') n2, fn_label_orbital(l2), t2
      write(ifile,11) ch1,ch2, &
         dipole_r_us(ltlt), dipole_ri_us(ltlt), dipole_pr_us(ltlt)
   end do
10 format(1x,(2x,a3,'-',a3,2x),(10x,a7,3x),(10x,a9,1x),(10x,a8,2x))
11 format(1x,(2x,a3,'-',a3,2x),3f20.10)

   end subroutine write_dipole_l_us

!=========================================== added by K. T. ================ 4.0
subroutine write_dipole_l_us_kt(ifile)
  use parameters
  implicit none

  integer,intent(in) :: ifile

  integer :: n1, l1, t1, n2, l2, t2, ltlt
  integer :: ispin1

  character(3) :: ch1, ch2
  character(1) :: fn_label_orbital

  write(ifile,*)
  write(ifile,*) &
       '[n|r|m]   = <psi[n]|r|psi[m]>   - <phi[n]|r|phi[m]>   =  [m|r|n]'
  write(ifile,*) &
       '[n|1/r|m] = <psi[n]|1/r|psi[m]> - <phi[n]|1/r|phi[m]> =  [m|1/r|n]'
  write(ifile,*) &
       '[n|pr|m]  = <psi[n]|pr|psi[m]>  - <phi[n]|pr|phi[m]>  = -[n|pr|m]'
  write(ifile,*) &
       'where pr = (1/r)*(d/dr)*r'

  write(ifile,*)

  if ( nspin == 1 ) then
     write(ifile,*) &
          '   n = (n1,l1,t1), m = (n2,l2,t2)'
     write(ifile,10) '[n]','[m]','[n|r|m]','[n|1/r|m]','[n|pr|m]'
  else if ( nspin == 2 ) then
     write(ifile,*) &
          '   n = (n1,l1,t1,s1), m = (n2,l2,t2,s2)'
     write(ifile,20) '[n]','[m]','[n|r|m]','[n|1/r|m]','[n|pr|m]'
  endif


  do ltlt = 1,num_dipole_l_us
     n1 = n1_dipole_l_us(ltlt) ; n2 = n2_dipole_l_us(ltlt)
     l1 = l1_dipole_l_us(ltlt) ; l2 = l2_dipole_l_us(ltlt)
     t1 = t1_dipole_l_us(ltlt) ; t2 = t2_dipole_l_us(ltlt)

     ispin1 = spin1_index_dipole_l_us(ltlt)

     if (l1 > l2) then
        cycle
     end if

     write(ch1,'(i1,a1,i1)') n1, fn_label_orbital(l1), t1
     write(ch2,'(i1,a1,i1)') n2, fn_label_orbital(l2), t2
     
     if ( nspin == 1 ) then
        write(ifile,11) ch1,ch2, &
             dipole_r_us(ltlt), dipole_ri_us(ltlt), dipole_pr_us(ltlt)

     else if ( nspin == 2 ) then
        if ( ispin1 == 1 ) then
           write(ifile,21) ch1, '_u' ,ch2, '_u', &
                dipole_r_us(ltlt), dipole_ri_us(ltlt), dipole_pr_us(ltlt)

        else if ( ispin1 == 2 ) then
           write(ifile,21) ch1, '_d' ,ch2, '_d', &
                dipole_r_us(ltlt), dipole_ri_us(ltlt), dipole_pr_us(ltlt)

        endif

     endif

  end do

10 format(1x,(2x,a3,'-',a3,2x),(10x,a7,3x),(10x,a9,1x),(10x,a8,2x))
11 format(1x,(2x,a3,'-',a3,2x),3f20.10)
20 format(1x,(4x,a3,'-',a3,4x),(10x,a7,3x),(10x,a9,1x),(10x,a8,2x))
21 format(1x,(2x,a3,a2,'-',a3,a2,2x),3f20.10)

end subroutine write_dipole_l_us_kt
! ========================================================================= 4.0

!=====================================================================
   subroutine write_dipole_l_ps(ifile)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in) :: ifile
   integer :: n1, l1, n2, l2, nlnl
   character(3) :: ch1, ch2
   character(1) :: fn_label_orbital
   write(ifile,*)
   write(ifile,*) &
      'AE psi[boundstate]: n = (n1,l1), m = (n2,l2)'
   write(ifile,10) '[n]','[m]','<n|r|m>','<n|1/r|m>','<n|pr|m>'
   do nlnl = 1,num_dipole_l_ps
      n1 = n1_dipole_l_ps(nlnl) ; n2 = n2_dipole_l_ps(nlnl)
      l1 = l1_dipole_l_ps(nlnl) ; l2 = l2_dipole_l_ps(nlnl)
      if (l1 > l2) then
         cycle
      end if
      write(ch1,'(i1,a1)') n1, fn_label_orbital(l1)
      write(ch2,'(i1,a1)') n2, fn_label_orbital(l2)
      write(ifile,11) ch1,ch2, &
         dipole_r_ae(nlnl), dipole_ri_ae(nlnl), dipole_pr_ae(nlnl)
   end do
   write(ifile,*) &
      'where pr = (1/r)*(d/dr)*r'
   write(ifile,*)
   if ((is_solve_pp_spin /= NO).and.(is_spin_ss == RESTRICTED)) then
   write(ifile,*) &
      'PP phi[solved+polarized]: n = (n1,l1), m = (n2,l2)'
   else
   write(ifile,*) &
      'PP phi[solved+restricted]: n = (n1,l1), m = (n2,l2)'
   end if
   write(ifile,10) '[n]','[m]','<n|r|m>','<n|1/r|m>','<n|pr|m>'
   do nlnl = 1,num_dipole_l_ps
      n1 = n1_dipole_l_ps(nlnl) ; n2 = n2_dipole_l_ps(nlnl)
      l1 = l1_dipole_l_ps(nlnl) ; l2 = l2_dipole_l_ps(nlnl)
      if (l1 > l2) then
         cycle
      end if
      write(ch1,'(i1,a1)') n1, fn_label_orbital(l1)
      write(ch2,'(i1,a1)') n2, fn_label_orbital(l2)
      write(ifile,11) ch1,ch2, &
         dipole_r_pp(nlnl), dipole_ri_pp(nlnl), dipole_pr_pp(nlnl)
   end do
   write(ifile,*) &
      'where pr = (1/r)*(d/dr)*r'
10 format(1x,(1x,a3,'-',a3,1x),(10x,a7,3x),(10x,a9,1x),(10x,a8,2x))
11 format(1x,(2x,a2,'-',a2,2x),3f20.10)
   end subroutine write_dipole_l_ps

!=================================================== added by K. T. ======== 4.0
subroutine write_dipole_l_ps_kt(ifile)
  use parameters
  implicit none

  integer,intent(in) :: ifile

  integer :: n1, l1, n2, l2, nlnl
  character(3) :: ch1, ch2
  character(1) :: fn_label_orbital

  integer :: ispin1

  write(ifile,*)
  
  if ( nspin == 1 ) then
     write(ifile,*) &
          'AE psi[boundstate]: n = (n1,l1), m = (n2,l2)'
     write(ifile,10) '[n]','[m]','<n|r|m>','<n|1/r|m>','<n|pr|m>'
  
  else if ( nspin == 2 ) then
     write(ifile,*) &
          'AE psi[boundstate]: n = (n1,l1,s1), m = (n2,l2,s2)'

     write(ifile,20) '[n]','[m]','<n|r|m>','<n|1/r|m>','<n|pr|m>'
  endif


  do nlnl = 1,num_dipole_l_ps
     n1 = n1_dipole_l_ps(nlnl) ; n2 = n2_dipole_l_ps(nlnl)
     l1 = l1_dipole_l_ps(nlnl) ; l2 = l2_dipole_l_ps(nlnl)

     ispin1 = spin1_index_dipole_l_ps(nlnl)

!     write(*,*) 'ispin = ', ispin1

     if (l1 > l2) then
        cycle
     end if

     write(ch1,'(i1,a1)') n1, fn_label_orbital(l1)
     write(ch2,'(i1,a1)') n2, fn_label_orbital(l2)

     if ( nspin == 1 ) then
        write(ifile,11) ch1,ch2, &
             dipole_r_ae(nlnl), dipole_ri_ae(nlnl), dipole_pr_ae(nlnl)
        
     else if ( nspin == 2 ) then
        if ( ispin1 == 1 ) then 
           write(ifile,21) ch1 , '_u', ch2 , '_u', &
                dipole_r_ae(nlnl), dipole_ri_ae(nlnl), dipole_pr_ae(nlnl)
                
        else if ( ispin1 == 2 ) then 
           write(ifile,21) ch1 , '_d', ch2, '_d', &
                dipole_r_ae(nlnl), dipole_ri_ae(nlnl), dipole_pr_ae(nlnl)
        endif
     end if

  end do

  write(ifile,*) &
       'where pr = (1/r)*(d/dr)*r'

  write(ifile,*)

  if ((nspin==1).and.(is_solve_pp_spin /= NO).and.(is_spin_ss == RESTRICTED)) then
     write(ifile,*) &
          'PP phi[solved by solpp]: n = (n1,l1), m = (n2,l2)'
     write(ifile,10) '[n]','[m]','<n|r|m>','<n|1/r|m>','<n|pr|m>'
  else
     write(ifile,*) &
          'PP phi[solved by sol]: n = (n1,l1,s1), m = (n2,l2,s2)'
     write(ifile,20) '[n]','[m]','<n|r|m>','<n|1/r|m>','<n|pr|m>'
  end if


  do nlnl = 1,num_dipole_l_ps
     n1 = n1_dipole_l_ps(nlnl) ; n2 = n2_dipole_l_ps(nlnl)
     l1 = l1_dipole_l_ps(nlnl) ; l2 = l2_dipole_l_ps(nlnl)

     ispin1 = spin1_index_dipole_l_ps(nlnl)

     if (l1 > l2) then
        cycle
     end if
     write(ch1,'(i1,a1)') n1, fn_label_orbital(l1)
     write(ch2,'(i1,a1)') n2, fn_label_orbital(l2)

     if ( nspin == 1 ) then
        write(ifile,11) ch1,ch2, &
             dipole_r_pp(nlnl), dipole_ri_pp(nlnl), dipole_pr_pp(nlnl)

     else if ( nspin == 2 ) then
        if ( ispin1 == 1 ) then
           write(ifile,21) ch1, '_u', ch2, '_u', &
                dipole_r_pp(nlnl), dipole_ri_pp(nlnl), dipole_pr_pp(nlnl)

        else if ( ispin1 == 2 ) then
           write(ifile,21) ch1, '_d', ch2, '_d', &
                dipole_r_pp(nlnl), dipole_ri_pp(nlnl), dipole_pr_pp(nlnl)

        endif
     endif

  end do

  write(ifile,*) &
      'where pr = (1/r)*(d/dr)*r'

10 format(1x,(1x,a3,'-',a3,1x),(10x,a7,3x),(10x,a9,1x),(10x,a8,2x))
11 format(1x,(2x,a2,'-',a2,2x),3f20.10)
20 format(1x,(3x,a3,'-',a3,3x),(10x,a7,3x),(10x,a9,1x),(10x,a8,2x))
21 format(1x,(2x,a2,a2,'-',a2,a2,2x),3f20.10)

end subroutine write_dipole_l_ps_kt
! ============================================================================ 4.0

!=====================================================================
   subroutine sizeof_dipole_lm_us(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: l1, l2, m1, m2, ltlt, ltmltm
   ier = 0
   ltmltm = 0
   do ltlt = 1,num_dipole_l_us
      l1 = l1_dipole_l_us(ltlt) ; l2 = l2_dipole_l_us(ltlt)
      do m1 = -l1,l1
      do m2 = -l2,l2
         ltmltm = ltmltm + 1
      end do
      end do
   end do
   num_dipole_lm_us = ltmltm
99 continue
   end subroutine sizeof_dipole_lm_us

!=====================================================================
   subroutine sizeof_dipole_lm_ps(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: l1, l2, m1, m2, nlnl, nlmnlm
   ier = 0
   nlmnlm = 0
   do nlnl = 1,num_dipole_l_ps
      l1 = l1_dipole_l_ps(nlnl) ; l2 = l2_dipole_l_ps(nlnl)
      do m1 = -l1,l1
      do m2 = -l2,l2
         nlmnlm = nlmnlm + 1
      end do
      end do
   end do
   num_dipole_lm_ps = nlmnlm
99 continue
   end subroutine sizeof_dipole_lm_ps

!=====================================================================
   subroutine calc_dipole_lm_us(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: n1, l1, t1, m1, k1, n2, l2, t2, m2, k2, &
              n1p, l1p, t1p, m1p, n2p, l2p, t2p, m2p, &
              ltlt, ltmltm, ltmltmz, ltmltmp, isum
   real(8) :: sum1, sum2, fac1, fac2
   ier = 0
   dipole_z_us (:) = 0.d0 ; dipole_dz_us(:) = 0.d0
   ltmltm = 0
   do ltlt = 1,num_dipole_l_us
      n1 = n1_dipole_l_us(ltlt) ; n2 = n2_dipole_l_us(ltlt)
      l1 = l1_dipole_l_us(ltlt) ; l2 = l2_dipole_l_us(ltlt)
      t1 = t1_dipole_l_us(ltlt) ; t2 = t2_dipole_l_us(ltlt)
      do m1 = -l1,l1
      do m2 = -l2,l2
         ltmltm = ltmltm + 1
         ltmltm_dipole_us(ltlt,m1,m2) = ltmltm
         ltlt_dipole_lm_us(ltmltm) = ltlt
         n1_dipole_lm_us(ltmltm) = n1 ; n2_dipole_lm_us(ltmltm) = n2
         l1_dipole_lm_us(ltmltm) = l1 ; l2_dipole_lm_us(ltmltm) = l2
         t1_dipole_lm_us(ltmltm) = t1 ; t2_dipole_lm_us(ltmltm) = t2
         m1_dipole_lm_us(ltmltm) = m1 ; m2_dipole_lm_us(ltmltm) = m2
         if (m1 /= m2) then
            cycle
         end if
         if (l1 == l2-1) then
            fac2 = sqrt(dble((l2+m2)*(l2-m2))/dble((2*l2+1)*(2*l2-1)))
            dipole_z_us (ltmltm) = fac2*dipole_r_us(ltlt)
            dipole_dz_us(ltmltm) = fac2*( &
               dipole_pr_us(ltlt) + dble(l2)*dipole_ri_us(ltlt) )
         else if (l1-1 == l2) then
            fac1 = sqrt(dble((l1+m1)*(l1-m1))/dble((2*l1+1)*(2*l1-1)))
            dipole_z_us (ltmltm) = fac1*dipole_r_us(ltlt)
            dipole_dz_us(ltmltm) = fac1*( &
               dipole_pr_us(ltlt) - dble(l1)*dipole_ri_us(ltlt) )
         end if
      end do
      end do
   end do
   if (ltmltm /= num_dipole_lm_us) then
      write(IFLOG,*) '### ERROR ### ltmltm /= num_dipole_lm_us'
      write(IFLOG,*) '   ltmltm           ...',ltmltm
      write(IFLOG,*) '   num_dipole_lm_us ...',num_dipole_lm_us
      ier = 1 ; go to 99
   end if
   dipole_x_us (:) = 0.d0 ; dipole_y_us (:) = 0.d0
   dipole_dx_us(:) = 0.d0 ; dipole_dy_us(:) = 0.d0
   do ltmltm = 1,num_dipole_lm_us
      ltlt = ltlt_dipole_lm_us(ltmltm)
      l1 = l1_dipole_lm_us(ltmltm) ; l2 = l2_dipole_lm_us(ltmltm)
      m1 = m1_dipole_lm_us(ltmltm) ; m2 = m2_dipole_lm_us(ltmltm)
      do k1 = -l1,l1
      do k2 = -l2,l2
         ltmltmz = ltmltm_dipole_us(ltlt,k1,k2)
         fac1 = pxyz(m1,k1,l1) * pxyz(m2,k2,l2)
         fac2 = pxyz(k1,m1,l1) * pxyz(k2,m2,l2)
         dipole_x_us(ltmltm) = dipole_x_us(ltmltm) &
            + dipole_z_us(ltmltmz) * fac1
         dipole_y_us(ltmltm) = dipole_y_us(ltmltm) &
            + dipole_z_us(ltmltmz) * fac2
         dipole_dx_us(ltmltm) = dipole_dx_us(ltmltm) &
            + dipole_dz_us(ltmltmz) * fac1
         dipole_dy_us(ltmltm) = dipole_dy_us(ltmltm) &
            + dipole_dz_us(ltmltmz) * fac2
      end do
      end do
   end do
   do ltmltm = 1,num_dipole_lm_us
      n1 = n1_dipole_lm_us(ltmltm) ; n2 = n2_dipole_lm_us(ltmltm)
      l1 = l1_dipole_lm_us(ltmltm) ; l2 = l2_dipole_lm_us(ltmltm)
      t1 = t1_dipole_lm_us(ltmltm) ; t2 = t2_dipole_lm_us(ltmltm)
      m1 = m1_dipole_lm_us(ltmltm) ; m2 = m2_dipole_lm_us(ltmltm)
      do ltmltmp = 1,num_dipole_lm_us
         n1p = n1_dipole_lm_us(ltmltmp) ; n2p = n2_dipole_lm_us(ltmltmp)
         l1p = l1_dipole_lm_us(ltmltmp) ; l2p = l2_dipole_lm_us(ltmltmp)
         t1p = t1_dipole_lm_us(ltmltmp) ; t2p = t2_dipole_lm_us(ltmltmp)
         m1p = m1_dipole_lm_us(ltmltmp) ; m2p = m2_dipole_lm_us(ltmltmp)
         isum = abs(n1-n2p) + abs(l1-l2p) + abs(t1-t2p) + abs(m1-m2p) &
              + abs(n2-n1p) + abs(l2-l1p) + abs(t2-t1p) + abs(m2-m1p)
         if (isum == 0) then
            sum1 = abs(dipole_x_us (ltmltm) - dipole_x_us (ltmltmp)) &
                 + abs(dipole_y_us (ltmltm) - dipole_y_us (ltmltmp)) &
                 + abs(dipole_z_us (ltmltm) - dipole_z_us (ltmltmp))
            sum2 = abs(dipole_dx_us(ltmltm) + dipole_dx_us(ltmltmp)) &
                 + abs(dipole_dy_us(ltmltm) + dipole_dy_us(ltmltmp)) &
                 + abs(dipole_dz_us(ltmltm) + dipole_dz_us(ltmltmp))
            if (abs(sum1) > 1.d-6) then
               write(IFLOG,*) '### ERROR ### [n|r|m] != [m|r|n]'
               write(IFLOG,*) '   n = (n1,l1,t1,m1) ...',n1,l1,t1,m1
               write(IFLOG,*) '   m = (n2,l2,t2,m2) ...',n2,l2,t2,m2
               write(IFLOG,*) '   [n|x|m]           ...',dipole_x_us(ltmltm)
               write(IFLOG,*) '   [m|x|n]           ...',dipole_x_us(ltmltmp)
               write(IFLOG,*) '   [n|y|m]           ...',dipole_y_us(ltmltm)
               write(IFLOG,*) '   [m|y|n]           ...',dipole_y_us(ltmltmp)
               write(IFLOG,*) '   [n|z|m]           ...',dipole_z_us(ltmltm)
               write(IFLOG,*) '   [m|z|n]           ...',dipole_z_us(ltmltmp)
               ier = 1 ; go to 99
            else if (abs(sum2) > 1.d-6) then
               write(IFLOG,*) '### ERROR ### [n|p|m] != -[m|p|n]'
               write(IFLOG,*) '   n = (n1,l1,t1,m1) ...',n1,l1,t1,m1
               write(IFLOG,*) '   m = (n2,l2,t2,m2) ...',n2,l2,t2,m2
               write(IFLOG,*) '   [n|d/dx|m]        ...',dipole_dx_us(ltmltm)
               write(IFLOG,*) '   [m|d/dx|n]        ...',dipole_dx_us(ltmltmp)
               write(IFLOG,*) '   [n|d/dy|m]        ...',dipole_dy_us(ltmltm)
               write(IFLOG,*) '   [m|d/dy|n]        ...',dipole_dy_us(ltmltmp)
               write(IFLOG,*) '   [n|d/dz|m]        ...',dipole_dz_us(ltmltm)
               write(IFLOG,*) '   [m|d/dz|n]        ...',dipole_dz_us(ltmltmp)
               ier = 2 ; go to 99
            else
               exit
            end if
         end if
         if (ltmltmp == num_dipole_lm_us) then
            write(IFLOG,*) '### ERROR ### ltmltmp was not found.'
            ier = 3 ; go to 99
         end if
      end do
   end do
99 continue
   end subroutine calc_dipole_lm_us

!====================================================== added by K. T. ======== 4.0
subroutine calc_dipole_lm_us_kt(ier)
  use parameters
  implicit none

  integer,intent(out) :: ier

  integer :: n1, l1, t1, m1, k1, n2, l2, t2, m2, k2, &
       n1p, l1p, t1p, m1p, n2p, l2p, t2p, m2p, &
       ltlt, ltmltm, ltmltmz, ltmltmp, isum
  integer :: ispin1, ispin2

  real(8) :: sum1, sum2, fac1, fac2

  ier = 0
  dipole_z_us (:) = 0.d0 ; dipole_dz_us(:) = 0.d0

  ltmltm = 0

  do ltlt = 1,num_dipole_l_us
     n1 = n1_dipole_l_us(ltlt) ; n2 = n2_dipole_l_us(ltlt)
     l1 = l1_dipole_l_us(ltlt) ; l2 = l2_dipole_l_us(ltlt)
     t1 = t1_dipole_l_us(ltlt) ; t2 = t2_dipole_l_us(ltlt)

     ispin1 = spin1_index_dipole_l_us(ltlt)

     do m1 = -l1,l1
        do m2 = -l2,l2
           ltmltm = ltmltm + 1

           ltmltm_dipole_us(ltlt,m1,m2) = ltmltm
           ltlt_dipole_lm_us(ltmltm) = ltlt

           n1_dipole_lm_us(ltmltm) = n1 ; n2_dipole_lm_us(ltmltm) = n2
           l1_dipole_lm_us(ltmltm) = l1 ; l2_dipole_lm_us(ltmltm) = l2
           t1_dipole_lm_us(ltmltm) = t1 ; t2_dipole_lm_us(ltmltm) = t2
           m1_dipole_lm_us(ltmltm) = m1 ; m2_dipole_lm_us(ltmltm) = m2

           spin1_index_dipole_lm_us(ltmltm) = ispin1

           if (m1 /= m2) then
              cycle
           end if

           if (l1 == l2-1) then
              fac2 = sqrt(dble((l2+m2)*(l2-m2))/dble((2*l2+1)*(2*l2-1)))
              dipole_z_us (ltmltm) = fac2*dipole_r_us(ltlt)
              dipole_dz_us(ltmltm) = fac2*( &
                   dipole_pr_us(ltlt) + dble(l2)*dipole_ri_us(ltlt) )
           else if (l1-1 == l2) then
              fac1 = sqrt(dble((l1+m1)*(l1-m1))/dble((2*l1+1)*(2*l1-1)))
              dipole_z_us (ltmltm) = fac1*dipole_r_us(ltlt)
              dipole_dz_us(ltmltm) = fac1*( &
                   dipole_pr_us(ltlt) - dble(l1)*dipole_ri_us(ltlt) )
           end if
        end do
     end do

  end do

  if (ltmltm /= num_dipole_lm_us) then
     write(IFLOG,*) '### ERROR ### ltmltm /= num_dipole_lm_us'
     write(IFLOG,*) '   ltmltm           ...',ltmltm
     write(IFLOG,*) '   num_dipole_lm_us ...',num_dipole_lm_us
     ier = 1 ; go to 99
  end if

  dipole_x_us (:) = 0.d0 ; dipole_y_us (:) = 0.d0
  dipole_dx_us(:) = 0.d0 ; dipole_dy_us(:) = 0.d0

  do ltmltm = 1,num_dipole_lm_us
     ltlt = ltlt_dipole_lm_us(ltmltm)
     l1 = l1_dipole_lm_us(ltmltm) ; l2 = l2_dipole_lm_us(ltmltm)
     m1 = m1_dipole_lm_us(ltmltm) ; m2 = m2_dipole_lm_us(ltmltm)

     do k1 = -l1,l1
        do k2 = -l2,l2
           ltmltmz = ltmltm_dipole_us(ltlt,k1,k2)
           fac1 = pxyz(m1,k1,l1) * pxyz(m2,k2,l2)
           fac2 = pxyz(k1,m1,l1) * pxyz(k2,m2,l2)

           dipole_x_us(ltmltm) = dipole_x_us(ltmltm) &
                + dipole_z_us(ltmltmz) * fac1
           dipole_y_us(ltmltm) = dipole_y_us(ltmltm) &
                + dipole_z_us(ltmltmz) * fac2
           dipole_dx_us(ltmltm) = dipole_dx_us(ltmltm) &
                + dipole_dz_us(ltmltmz) * fac1
           dipole_dy_us(ltmltm) = dipole_dy_us(ltmltm) &
                + dipole_dz_us(ltmltmz) * fac2
        end do
     end do
  end do

  do ltmltm = 1,num_dipole_lm_us
     n1 = n1_dipole_lm_us(ltmltm) ; n2 = n2_dipole_lm_us(ltmltm)
     l1 = l1_dipole_lm_us(ltmltm) ; l2 = l2_dipole_lm_us(ltmltm)
     t1 = t1_dipole_lm_us(ltmltm) ; t2 = t2_dipole_lm_us(ltmltm)
     m1 = m1_dipole_lm_us(ltmltm) ; m2 = m2_dipole_lm_us(ltmltm)

     ispin1 = spin1_index_dipole_lm_us(ltmltm)

     do ltmltmp = 1,num_dipole_lm_us
        n1p = n1_dipole_lm_us(ltmltmp) ; n2p = n2_dipole_lm_us(ltmltmp)
        l1p = l1_dipole_lm_us(ltmltmp) ; l2p = l2_dipole_lm_us(ltmltmp)
        t1p = t1_dipole_lm_us(ltmltmp) ; t2p = t2_dipole_lm_us(ltmltmp)
        m1p = m1_dipole_lm_us(ltmltmp) ; m2p = m2_dipole_lm_us(ltmltmp)

        ispin2 = spin1_index_dipole_lm_us(ltmltmp)

        isum = abs(n1-n2p) + abs(l1-l2p) + abs(t1-t2p) + abs(m1-m2p) &
              + abs(n2-n1p) + abs(l2-l1p) + abs(t2-t1p) + abs(m2-m1p)
        
        if (isum == 0 .and. ispin1==ispin2 ) then
           sum1 = abs(dipole_x_us (ltmltm) - dipole_x_us (ltmltmp)) &
                + abs(dipole_y_us (ltmltm) - dipole_y_us (ltmltmp)) &
                + abs(dipole_z_us (ltmltm) - dipole_z_us (ltmltmp))
           sum2 = abs(dipole_dx_us(ltmltm) + dipole_dx_us(ltmltmp)) &
                + abs(dipole_dy_us(ltmltm) + dipole_dy_us(ltmltmp)) &
                + abs(dipole_dz_us(ltmltm) + dipole_dz_us(ltmltmp))

           if (abs(sum1) > 1.d-6) then
              write(IFLOG,*) '### ERROR ### [n|r|m] != [m|r|n]'
              write(IFLOG,*) '   n = (n1,l1,t1,m1,s1) ...',n1,l1,t1,m1, ispin1
              write(IFLOG,*) '   m = (n2,l2,t2,m2,s2) ...',n2,l2,t2,m2, ispin2
              write(IFLOG,*) '   [n|x|m]           ...',dipole_x_us(ltmltm)
              write(IFLOG,*) '   [m|x|n]           ...',dipole_x_us(ltmltmp)
              write(IFLOG,*) '   [n|y|m]           ...',dipole_y_us(ltmltm)
              write(IFLOG,*) '   [m|y|n]           ...',dipole_y_us(ltmltmp)
              write(IFLOG,*) '   [n|z|m]           ...',dipole_z_us(ltmltm)
              write(IFLOG,*) '   [m|z|n]           ...',dipole_z_us(ltmltmp)
              ier = 1 ; go to 99

           else if (abs(sum2) > 1.d-6) then
              write(IFLOG,*) '### ERROR ### [n|p|m] != -[m|p|n]'
              write(IFLOG,*) '   n = (n1,l1,t1,m1,s1) ...',n1,l1,t1,m1, ispin1
              write(IFLOG,*) '   m = (n2,l2,t2,m2,s2) ...',n2,l2,t2,m2, ispin2
              write(IFLOG,*) '   [n|d/dx|m]        ...',dipole_dx_us(ltmltm)
              write(IFLOG,*) '   [m|d/dx|n]        ...',dipole_dx_us(ltmltmp)
              write(IFLOG,*) '   [n|d/dy|m]        ...',dipole_dy_us(ltmltm)
              write(IFLOG,*) '   [m|d/dy|n]        ...',dipole_dy_us(ltmltmp)
              write(IFLOG,*) '   [n|d/dz|m]        ...',dipole_dz_us(ltmltm)
              write(IFLOG,*) '   [m|d/dz|n]        ...',dipole_dz_us(ltmltmp)
              ier = 2 ; go to 99

           else
              exit
           end if

        end if

        if (ltmltmp == num_dipole_lm_us) then
           write(IFLOG,*) '### ERROR ### ltmltmp was not found.'
           ier = 3 ; go to 99
        end if

     end do
  end do

99 continue

end subroutine calc_dipole_lm_us_kt
! =========================================================================== 4.0
   
!=====================================================================
   subroutine calc_dipole_lm_ps(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: n1, l1, m1, k1, n2, l2, m2, k2, &
              n1p, l1p, m1p, n2p, l2p, m2p, &
              nlnl, nlmnlm, nlmnlmz, nlmnlmp, isum
   real(8) :: sum1, sum2, sum3, sum4, fac1, fac2
   ier = 0
   dipole_z_ae (:) = 0.d0 ; dipole_z_pp (:) = 0.d0
   dipole_dz_ae(:) = 0.d0 ; dipole_dz_pp(:) = 0.d0
   nlmnlm = 0
   do nlnl = 1,num_dipole_l_ps
      n1 = n1_dipole_l_ps(nlnl) ; n2 = n2_dipole_l_ps(nlnl)
      l1 = l1_dipole_l_ps(nlnl) ; l2 = l2_dipole_l_ps(nlnl)
      do m1 = -l1,l1
      do m2 = -l2,l2
         nlmnlm = nlmnlm + 1
         nlmnlm_dipole_ps(nlnl,m1,m2) = nlmnlm
         nlnl_dipole_lm_ps(nlmnlm) = nlnl
         n1_dipole_lm_ps(nlmnlm) = n1 ; n2_dipole_lm_ps(nlmnlm) = n2
         l1_dipole_lm_ps(nlmnlm) = l1 ; l2_dipole_lm_ps(nlmnlm) = l2
         m1_dipole_lm_ps(nlmnlm) = m1 ; m2_dipole_lm_ps(nlmnlm) = m2
         if (m1 /= m2) then
            cycle
         end if
         if (l1 == l2-1) then
            fac2 = sqrt(dble((l2+m2)*(l2-m2))/dble((2*l2+1)*(2*l2-1)))
            dipole_z_ae (nlmnlm) = fac2*dipole_r_ae(nlnl)
            dipole_dz_ae(nlmnlm) = fac2*( &
               dipole_pr_ae(nlnl) + dble(l2)*dipole_ri_ae(nlnl) )
            dipole_z_pp (nlmnlm) = fac2*dipole_r_pp(nlnl)
            dipole_dz_pp(nlmnlm) = fac2*( &
               dipole_pr_pp(nlnl) + dble(l2)*dipole_ri_pp(nlnl) )
         else if (l1-1 == l2) then
            fac1 = sqrt(dble((l1+m1)*(l1-m1))/dble((2*l1+1)*(2*l1-1)))
            dipole_z_ae (nlmnlm) = fac1*dipole_r_ae(nlnl)
            dipole_dz_ae(nlmnlm) = fac1*( &
               dipole_pr_ae(nlnl) - dble(l1)*dipole_ri_ae(nlnl) )
            dipole_z_pp (nlmnlm) = fac1*dipole_r_pp(nlnl)
            dipole_dz_pp(nlmnlm) = fac1*( &
               dipole_pr_pp(nlnl) - dble(l1)*dipole_ri_pp(nlnl) )
         end if
      end do
      end do
   end do
   if (nlmnlm /= num_dipole_lm_ps) then
      write(IFLOG,*) '### ERROR ### nlmnlm /= num_dipole_lm_ps'
      write(IFLOG,*) '   nlmnlm           ...',nlmnlm
      write(IFLOG,*) '   num_dipole_lm_ps ...',num_dipole_lm_ps
      ier = 1 ; go to 99
   end if
   dipole_x_ae (:) = 0.d0 ; dipole_y_ae (:) = 0.d0
   dipole_dx_ae(:) = 0.d0 ; dipole_dy_ae(:) = 0.d0
   dipole_x_pp (:) = 0.d0 ; dipole_y_pp (:) = 0.d0
   dipole_dx_pp(:) = 0.d0 ; dipole_dy_pp(:) = 0.d0
   do nlmnlm = 1,num_dipole_lm_ps
      nlnl = nlnl_dipole_lm_ps(nlmnlm)
      l1 = l1_dipole_lm_ps(nlmnlm) ; l2 = l2_dipole_lm_ps(nlmnlm)
      m1 = m1_dipole_lm_ps(nlmnlm) ; m2 = m2_dipole_lm_ps(nlmnlm)
      do k1 = -l1,l1
      do k2 = -l2,l2
         nlmnlmz = nlmnlm_dipole_ps(nlnl,k1,k2)
         fac1 = pxyz(m1,k1,l1) * pxyz(m2,k2,l2)
         fac2 = pxyz(k1,m1,l1) * pxyz(k2,m2,l2)
         dipole_x_ae(nlmnlm) = dipole_x_ae(nlmnlm) &
            + dipole_z_ae(nlmnlmz) * fac1
         dipole_y_ae(nlmnlm) = dipole_y_ae(nlmnlm) &
            + dipole_z_ae(nlmnlmz) * fac2
         dipole_dx_ae(nlmnlm) = dipole_dx_ae(nlmnlm) &
            + dipole_dz_ae(nlmnlmz) * fac1
         dipole_dy_ae(nlmnlm) = dipole_dy_ae(nlmnlm) &
            + dipole_dz_ae(nlmnlmz) * fac2
         dipole_x_pp(nlmnlm) = dipole_x_pp(nlmnlm) &
            + dipole_z_pp(nlmnlmz) * fac1
         dipole_y_pp(nlmnlm) = dipole_y_pp(nlmnlm) &
            + dipole_z_pp(nlmnlmz) * fac2
         dipole_dx_pp(nlmnlm) = dipole_dx_pp(nlmnlm) &
            + dipole_dz_pp(nlmnlmz) * fac1
         dipole_dy_pp(nlmnlm) = dipole_dy_pp(nlmnlm) &
            + dipole_dz_pp(nlmnlmz) * fac2
      end do
      end do
   end do
   do nlmnlm = 1,num_dipole_lm_ps
      n1 = n1_dipole_lm_ps(nlmnlm) ; n2 = n2_dipole_lm_ps(nlmnlm)
      l1 = l1_dipole_lm_ps(nlmnlm) ; l2 = l2_dipole_lm_ps(nlmnlm)
      m1 = m1_dipole_lm_ps(nlmnlm) ; m2 = m2_dipole_lm_ps(nlmnlm)
      do nlmnlmp = 1,num_dipole_lm_ps
         n1p = n1_dipole_lm_ps(nlmnlmp) ; n2p = n2_dipole_lm_ps(nlmnlmp)
         l1p = l1_dipole_lm_ps(nlmnlmp) ; l2p = l2_dipole_lm_ps(nlmnlmp)
         m1p = m1_dipole_lm_ps(nlmnlmp) ; m2p = m2_dipole_lm_ps(nlmnlmp)
         isum = abs(n1-n2p) + abs(l1-l2p) + abs(m1-m2p) &
              + abs(n2-n1p) + abs(l2-l1p) + abs(m2-m1p)
         if (isum == 0) then
            sum1 = abs(dipole_x_ae(nlmnlm) - dipole_x_ae(nlmnlmp)) &
                 + abs(dipole_y_ae(nlmnlm) - dipole_y_ae(nlmnlmp)) &
                 + abs(dipole_z_ae(nlmnlm) - dipole_z_ae(nlmnlmp))
            sum2 = abs(dipole_dx_ae(nlmnlm) + dipole_dx_ae(nlmnlmp)) &
                 + abs(dipole_dy_ae(nlmnlm) + dipole_dy_ae(nlmnlmp)) &
                 + abs(dipole_dz_ae(nlmnlm) + dipole_dz_ae(nlmnlmp))
            sum3 = abs(dipole_x_pp(nlmnlm) - dipole_x_pp(nlmnlmp)) &
                 + abs(dipole_y_pp(nlmnlm) - dipole_y_pp(nlmnlmp)) &
                 + abs(dipole_z_pp(nlmnlm) - dipole_z_pp(nlmnlmp))
            sum4 = abs(dipole_dx_pp(nlmnlm) + dipole_dx_pp(nlmnlmp)) &
                 + abs(dipole_dy_pp(nlmnlm) + dipole_dy_pp(nlmnlmp)) &
                 + abs(dipole_dz_pp(nlmnlm) + dipole_dz_pp(nlmnlmp))
            if (abs(sum1) > 1.d-6) then
               write(IFLOG,*) '### ERROR ### <n|r|m> != <m|r|n>'
               write(IFLOG,*) '   n = (n1,l1,m1) ...',n1,l1,m1
               write(IFLOG,*) '   m = (n2,l2,m2) ...',n2,l2,m2
               write(IFLOG,*) '   <n|x|m>        ...',dipole_x_ae(nlmnlm)
               write(IFLOG,*) '   <m|x|n>        ...',dipole_x_ae(nlmnlmp)
               write(IFLOG,*) '   <n|y|m>        ...',dipole_y_ae(nlmnlm)
               write(IFLOG,*) '   <m|y|n>        ...',dipole_y_ae(nlmnlmp)
               write(IFLOG,*) '   <n|z|m>        ...',dipole_z_ae(nlmnlm)
               write(IFLOG,*) '   <m|z|n>        ...',dipole_z_ae(nlmnlmp)
               ier = 1 ; go to 99
            else if (abs(sum2) > 1.d-6) then
               write(IFLOG,*) '### ERROR ### <n|p|m> != -<m|p|n>'
               write(IFLOG,*) '   n = (n1,l1,m1) ...',n1,l1,m1
               write(IFLOG,*) '   m = (n2,l2,m2) ...',n2,l2,m2
               write(IFLOG,*) '   <n|d/dx|m>     ...',dipole_dx_ae(nlmnlm)
               write(IFLOG,*) '   <m|d/dx|n>     ...',dipole_dx_ae(nlmnlmp)
               write(IFLOG,*) '   <n|d/dy|m>     ...',dipole_dy_ae(nlmnlm)
               write(IFLOG,*) '   <m|d/dy|n>     ...',dipole_dy_ae(nlmnlmp)
               write(IFLOG,*) '   <n|d/dz|m>     ...',dipole_dz_ae(nlmnlm)
               write(IFLOG,*) '   <m|d/dz|n>     ...',dipole_dz_ae(nlmnlmp)
               ier = 2 ; go to 99
            else if (abs(sum3) > 1.d-6) then
               write(IFLOG,*) '### ERROR ### <n|r|m> != <m|r|n>'
               write(IFLOG,*) '   n = (n1,l1,m1) ...',n1,l1,m1
               write(IFLOG,*) '   m = (n2,l2,m2) ...',n2,l2,m2
               write(IFLOG,*) '   <n|x|m>        ...',dipole_x_pp(nlmnlm)
               write(IFLOG,*) '   <m|x|n>        ...',dipole_x_pp(nlmnlmp)
               write(IFLOG,*) '   <n|y|m>        ...',dipole_y_pp(nlmnlm)
               write(IFLOG,*) '   <m|y|n>        ...',dipole_y_pp(nlmnlmp)
               write(IFLOG,*) '   <n|z|m>        ...',dipole_z_pp(nlmnlm)
               write(IFLOG,*) '   <m|z|n>        ...',dipole_z_pp(nlmnlmp)
               ier = 3 ; go to 99
            else if (abs(sum4) > 1.d-6) then
               write(IFLOG,*) '### ERROR ### <n|p|m> != -<m|p|n>'
               write(IFLOG,*) '   n = (n1,l1,m1) ...',n1,l1,m1
               write(IFLOG,*) '   m = (n2,l2,m2) ...',n2,l2,m2
               write(IFLOG,*) '   <n|d/dx|m>     ...',dipole_dx_pp(nlmnlm)
               write(IFLOG,*) '   <m|d/dx|n>     ...',dipole_dx_pp(nlmnlmp)
               write(IFLOG,*) '   <n|d/dy|m>     ...',dipole_dy_pp(nlmnlm)
               write(IFLOG,*) '   <m|d/dy|n>     ...',dipole_dy_pp(nlmnlmp)
               write(IFLOG,*) '   <n|d/dz|m>     ...',dipole_dz_pp(nlmnlm)
               write(IFLOG,*) '   <m|d/dz|n>     ...',dipole_dz_pp(nlmnlmp)
               ier = 4 ; go to 99
            else
               exit
            end if
         end if
         if (nlmnlmp == num_dipole_lm_ps) then
            write(IFLOG,*) '### ERROR ### nlmnlmp was not found.'
            ier = 5 ; go to 99
         end if
      end do
   end do
99 continue
   end subroutine calc_dipole_lm_ps

!======================================================= added by K. T. ======= 4.0
subroutine calc_dipole_lm_ps_kt(ier)
  use parameters
  implicit none

  integer,intent(out) :: ier

  integer :: n1, l1, m1, k1, n2, l2, m2, k2, &
       n1p, l1p, m1p, n2p, l2p, m2p, &
       nlnl, nlmnlm, nlmnlmz, nlmnlmp, isum
  real(8) :: sum1, sum2, sum3, sum4, fac1, fac2

  integer :: ispin1, ispin2

  ier = 0

  dipole_z_ae (:) = 0.d0 ; dipole_z_pp (:) = 0.d0
  dipole_dz_ae(:) = 0.d0 ; dipole_dz_pp(:) = 0.d0

  nlmnlm = 0

  do nlnl = 1,num_dipole_l_ps
     n1 = n1_dipole_l_ps(nlnl) ; n2 = n2_dipole_l_ps(nlnl)
     l1 = l1_dipole_l_ps(nlnl) ; l2 = l2_dipole_l_ps(nlnl)

     ispin1 = spin1_index_dipole_l_ps(nlnl)

     do m1 = -l1,l1
        do m2 = -l2,l2
           nlmnlm = nlmnlm + 1
           nlmnlm_dipole_ps(nlnl,m1,m2) = nlmnlm

           nlnl_dipole_lm_ps(nlmnlm) = nlnl

           n1_dipole_lm_ps(nlmnlm) = n1 ; n2_dipole_lm_ps(nlmnlm) = n2
           l1_dipole_lm_ps(nlmnlm) = l1 ; l2_dipole_lm_ps(nlmnlm) = l2
           m1_dipole_lm_ps(nlmnlm) = m1 ; m2_dipole_lm_ps(nlmnlm) = m2

           spin1_index_dipole_lm_ps(nlmnlm) = ispin1

           if (m1 /= m2) then
              cycle
           end if

           if (l1 == l2-1) then
              fac2 = sqrt(dble((l2+m2)*(l2-m2))/dble((2*l2+1)*(2*l2-1)))

              dipole_z_ae (nlmnlm) = fac2*dipole_r_ae(nlnl)
              dipole_dz_ae(nlmnlm) = fac2*( &
                   dipole_pr_ae(nlnl) + dble(l2)*dipole_ri_ae(nlnl) )
              dipole_z_pp (nlmnlm) = fac2*dipole_r_pp(nlnl)
              dipole_dz_pp(nlmnlm) = fac2*( &
                   dipole_pr_pp(nlnl) + dble(l2)*dipole_ri_pp(nlnl) )

           else if (l1-1 == l2) then
              fac1 = sqrt(dble((l1+m1)*(l1-m1))/dble((2*l1+1)*(2*l1-1)))

              dipole_z_ae (nlmnlm) = fac1*dipole_r_ae(nlnl)
              dipole_dz_ae(nlmnlm) = fac1*( &
                   dipole_pr_ae(nlnl) - dble(l1)*dipole_ri_ae(nlnl) )
              dipole_z_pp (nlmnlm) = fac1*dipole_r_pp(nlnl)
              dipole_dz_pp(nlmnlm) = fac1*( &
                   dipole_pr_pp(nlnl) - dble(l1)*dipole_ri_pp(nlnl) )
           end if

        end do
     end do

  end do

  if (nlmnlm /= num_dipole_lm_ps) then
     write(IFLOG,*) '### ERROR ### nlmnlm /= num_dipole_lm_ps'
     write(IFLOG,*) '   nlmnlm           ...',nlmnlm
     write(IFLOG,*) '   num_dipole_lm_ps ...',num_dipole_lm_ps
     ier = 1 ; go to 99
  end if

  dipole_x_ae (:) = 0.d0 ; dipole_y_ae (:) = 0.d0
  dipole_dx_ae(:) = 0.d0 ; dipole_dy_ae(:) = 0.d0
  dipole_x_pp (:) = 0.d0 ; dipole_y_pp (:) = 0.d0
  dipole_dx_pp(:) = 0.d0 ; dipole_dy_pp(:) = 0.d0

  do nlmnlm = 1,num_dipole_lm_ps
     nlnl = nlnl_dipole_lm_ps(nlmnlm)
     l1 = l1_dipole_lm_ps(nlmnlm) ; l2 = l2_dipole_lm_ps(nlmnlm)
     m1 = m1_dipole_lm_ps(nlmnlm) ; m2 = m2_dipole_lm_ps(nlmnlm)

     do k1 = -l1,l1
        do k2 = -l2,l2
           nlmnlmz = nlmnlm_dipole_ps(nlnl,k1,k2)

           fac1 = pxyz(m1,k1,l1) * pxyz(m2,k2,l2)
           fac2 = pxyz(k1,m1,l1) * pxyz(k2,m2,l2)

           dipole_x_ae(nlmnlm) = dipole_x_ae(nlmnlm) &
                + dipole_z_ae(nlmnlmz) * fac1
           dipole_y_ae(nlmnlm) = dipole_y_ae(nlmnlm) &
                + dipole_z_ae(nlmnlmz) * fac2
           dipole_dx_ae(nlmnlm) = dipole_dx_ae(nlmnlm) &
                + dipole_dz_ae(nlmnlmz) * fac1
           dipole_dy_ae(nlmnlm) = dipole_dy_ae(nlmnlm) &
                + dipole_dz_ae(nlmnlmz) * fac2

           dipole_x_pp(nlmnlm) = dipole_x_pp(nlmnlm) &
                + dipole_z_pp(nlmnlmz) * fac1
           dipole_y_pp(nlmnlm) = dipole_y_pp(nlmnlm) &
                + dipole_z_pp(nlmnlmz) * fac2
           dipole_dx_pp(nlmnlm) = dipole_dx_pp(nlmnlm) &
                + dipole_dz_pp(nlmnlmz) * fac1
           dipole_dy_pp(nlmnlm) = dipole_dy_pp(nlmnlm) &
                + dipole_dz_pp(nlmnlmz) * fac2
        end do
     end do
  end do

  do nlmnlm = 1,num_dipole_lm_ps
     n1 = n1_dipole_lm_ps(nlmnlm) ; n2 = n2_dipole_lm_ps(nlmnlm)
     l1 = l1_dipole_lm_ps(nlmnlm) ; l2 = l2_dipole_lm_ps(nlmnlm)
     m1 = m1_dipole_lm_ps(nlmnlm) ; m2 = m2_dipole_lm_ps(nlmnlm)

     ispin1 = spin1_index_dipole_lm_ps(nlmnlm)

     do nlmnlmp = 1,num_dipole_lm_ps
        n1p = n1_dipole_lm_ps(nlmnlmp) ; n2p = n2_dipole_lm_ps(nlmnlmp)
        l1p = l1_dipole_lm_ps(nlmnlmp) ; l2p = l2_dipole_lm_ps(nlmnlmp)
        m1p = m1_dipole_lm_ps(nlmnlmp) ; m2p = m2_dipole_lm_ps(nlmnlmp)

        ispin2 = spin1_index_dipole_lm_ps(nlmnlmp)

        isum = abs(n1-n2p) + abs(l1-l2p) + abs(m1-m2p) &
             + abs(n2-n1p) + abs(l2-l1p) + abs(m2-m1p)

        if (isum == 0 .and. ispin1==ispin2 ) then
           sum1 = abs(dipole_x_ae(nlmnlm) - dipole_x_ae(nlmnlmp)) &
                + abs(dipole_y_ae(nlmnlm) - dipole_y_ae(nlmnlmp)) &
                + abs(dipole_z_ae(nlmnlm) - dipole_z_ae(nlmnlmp))
           sum2 = abs(dipole_dx_ae(nlmnlm) + dipole_dx_ae(nlmnlmp)) &
                + abs(dipole_dy_ae(nlmnlm) + dipole_dy_ae(nlmnlmp)) &
                + abs(dipole_dz_ae(nlmnlm) + dipole_dz_ae(nlmnlmp))
           sum3 = abs(dipole_x_pp(nlmnlm) - dipole_x_pp(nlmnlmp)) &
                + abs(dipole_y_pp(nlmnlm) - dipole_y_pp(nlmnlmp)) &
                + abs(dipole_z_pp(nlmnlm) - dipole_z_pp(nlmnlmp))
           sum4 = abs(dipole_dx_pp(nlmnlm) + dipole_dx_pp(nlmnlmp)) &
                + abs(dipole_dy_pp(nlmnlm) + dipole_dy_pp(nlmnlmp)) &
                + abs(dipole_dz_pp(nlmnlm) + dipole_dz_pp(nlmnlmp))

           if (abs(sum1) > 1.d-6) then
              write(IFLOG,*) '### ERROR ### <n|r|m> != <m|r|n>'
              write(IFLOG,*) '   n = (n1,l1,m1,s1) ...',n1,l1,m1, ispin1
              write(IFLOG,*) '   m = (n2,l2,m2,s2) ...',n2,l2,m2, ispin2
              write(IFLOG,*) '   <n|x|m>        ...',dipole_x_ae(nlmnlm)
              write(IFLOG,*) '   <m|x|n>        ...',dipole_x_ae(nlmnlmp)
              write(IFLOG,*) '   <n|y|m>        ...',dipole_y_ae(nlmnlm)
              write(IFLOG,*) '   <m|y|n>        ...',dipole_y_ae(nlmnlmp)
              write(IFLOG,*) '   <n|z|m>        ...',dipole_z_ae(nlmnlm)
              write(IFLOG,*) '   <m|z|n>        ...',dipole_z_ae(nlmnlmp)
              ier = 1 ; go to 99

           else if (abs(sum2) > 1.d-6) then
              write(IFLOG,*) '### ERROR ### <n|p|m> != -<m|p|n>'
              write(IFLOG,*) '   n = (n1,l1,m1,s1) ...',n1,l1,m1, ispin1
              write(IFLOG,*) '   m = (n2,l2,m2,s2) ...',n2,l2,m2, ispin2
              write(IFLOG,*) '   <n|d/dx|m>     ...',dipole_dx_ae(nlmnlm)
              write(IFLOG,*) '   <m|d/dx|n>     ...',dipole_dx_ae(nlmnlmp)
              write(IFLOG,*) '   <n|d/dy|m>     ...',dipole_dy_ae(nlmnlm)
              write(IFLOG,*) '   <m|d/dy|n>     ...',dipole_dy_ae(nlmnlmp)
              write(IFLOG,*) '   <n|d/dz|m>     ...',dipole_dz_ae(nlmnlm)
              write(IFLOG,*) '   <m|d/dz|n>     ...',dipole_dz_ae(nlmnlmp)
              ier = 2 ; go to 99

           else if (abs(sum3) > 1.d-6) then
              write(IFLOG,*) '### ERROR ### <n|r|m> != <m|r|n>'
              write(IFLOG,*) '   n = (n1,l1,m1,s1) ...',n1,l1,m1, ispin1
              write(IFLOG,*) '   m = (n2,l2,m2,s2) ...',n2,l2,m2, ispin2
              write(IFLOG,*) '   <n|x|m>        ...',dipole_x_pp(nlmnlm)
              write(IFLOG,*) '   <m|x|n>        ...',dipole_x_pp(nlmnlmp)
              write(IFLOG,*) '   <n|y|m>        ...',dipole_y_pp(nlmnlm)
              write(IFLOG,*) '   <m|y|n>        ...',dipole_y_pp(nlmnlmp)
              write(IFLOG,*) '   <n|z|m>        ...',dipole_z_pp(nlmnlm)
              write(IFLOG,*) '   <m|z|n>        ...',dipole_z_pp(nlmnlmp)
              ier = 3 ; go to 99

           else if (abs(sum4) > 1.d-6) then
              write(IFLOG,*) '### ERROR ### <n|p|m> != -<m|p|n>'
              write(IFLOG,*) '   n = (n1,l1,m1,t1) ...',n1,l1,m1, ispin1
              write(IFLOG,*) '   m = (n2,l2,m2,t2) ...',n2,l2,m2, ispin2
              write(IFLOG,*) '   <n|d/dx|m>     ...',dipole_dx_pp(nlmnlm)
              write(IFLOG,*) '   <m|d/dx|n>     ...',dipole_dx_pp(nlmnlmp)
              write(IFLOG,*) '   <n|d/dy|m>     ...',dipole_dy_pp(nlmnlm)
              write(IFLOG,*) '   <m|d/dy|n>     ...',dipole_dy_pp(nlmnlmp)
              write(IFLOG,*) '   <n|d/dz|m>     ...',dipole_dz_pp(nlmnlm)
              write(IFLOG,*) '   <m|d/dz|n>     ...',dipole_dz_pp(nlmnlmp)
              ier = 4 ; go to 99

           else
              exit
           end if
        end if
        if (nlmnlmp == num_dipole_lm_ps) then
           write(IFLOG,*) '### ERROR ### nlmnlmp was not found.'
           ier = 5 ; go to 99
        end if

     end do
  end do
99 continue

end subroutine calc_dipole_lm_ps_kt
! ========================================================================== 4.0
   
!=====================================================================
subroutine calc_dipole_repaired(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
  use parameters
  implicit none
  integer,intent(out) :: ier
  integer :: l1, m1, ips1, iss1, l2, m2, ips2, iss2, &
       l1p, m1p, lt1, l2p, m2p, lt2, &
       nlnl, nlmnlm, ltlt, ltmltm, iss, isum
  real(8) :: sum1, sum2, sum3, sum4, sum5, sum6, fac
  ier = 0
  dipole_x_ss(:) = 0.d0 ; dipole_dx_ss(:) = 0.d0
  dipole_y_ss(:) = 0.d0 ; dipole_dy_ss(:) = 0.d0
  dipole_z_ss(:) = 0.d0 ; dipole_dz_ss(:) = 0.d0
  do nlmnlm = 1,num_dipole_lm_ps
     l1 = l1_dipole_lm_ps(nlmnlm) ; l2 = l2_dipole_lm_ps(nlmnlm)
     m1 = m1_dipole_lm_ps(nlmnlm) ; m2 = m2_dipole_lm_ps(nlmnlm)
     nlnl = nlnl_dipole_lm_ps(nlmnlm)
     ips1 = ips1_dipole_l_ps(nlnl) ; ips2 = ips2_dipole_l_ps(nlnl)
     do iss = 1,nss
        if (ishell_ss(iss) == ishell_ps(ips1,1)) then
           iss1 = iss ; exit
        end if
        if (iss == nss) then
           write(IFLOG,*) '### ERROR ### iss1 was not found'
           ier = 1 ; go to 99
        end if
     end do
     do iss = 1,nss
        if (ishell_ss(iss) == ishell_ps(ips2,1)) then
           iss2 = iss ; exit
        end if
        if (iss == nss) then
           write(IFLOG,*) '### ERROR ### iss2 was not found'
           ier = 2 ; go to 99
        end if
     end do
     sum1 = 0.d0 ; sum2 = 0.d0 ; sum3 = 0.d0
     sum4 = 0.d0 ; sum5 = 0.d0 ; sum6 = 0.d0
     do ltmltm = 1,num_dipole_lm_us
        l1p = l1_dipole_lm_us(ltmltm) ; l2p = l2_dipole_lm_us(ltmltm)
        m1p = m1_dipole_lm_us(ltmltm) ; m2p = m2_dipole_lm_us(ltmltm)
        ltlt = ltlt_dipole_lm_us(ltmltm)
        lt1 = lt1_dipole_l_us(ltlt) ; lt2 = lt2_dipole_l_us(ltlt)
        fac = beta_phi_ss(lt1,iss1) * beta_phi_ss(lt2,iss2)
        isum = abs(l1-l1p) + abs(l2-l2p) + abs(m1-m1p) + abs(m2-m2p)
        if (isum == 0) then
           sum1 = sum1 + dipole_x_us (ltmltm) * fac
           sum2 = sum2 + dipole_y_us (ltmltm) * fac
           sum3 = sum3 + dipole_z_us (ltmltm) * fac
           sum4 = sum4 + dipole_dx_us(ltmltm) * fac
           sum5 = sum5 + dipole_dy_us(ltmltm) * fac
           sum6 = sum6 + dipole_dz_us(ltmltm) * fac
        end if
     end do
     dipole_x_ss (nlmnlm) = dipole_x_pp (nlmnlm) + sum1
     dipole_y_ss (nlmnlm) = dipole_y_pp (nlmnlm) + sum2
     dipole_z_ss (nlmnlm) = dipole_z_pp (nlmnlm) + sum3
     dipole_dx_ss(nlmnlm) = dipole_dx_pp(nlmnlm) + sum4
     dipole_dy_ss(nlmnlm) = dipole_dy_pp(nlmnlm) + sum5
     dipole_dz_ss(nlmnlm) = dipole_dz_pp(nlmnlm) + sum6
  end do
99 continue
end subroutine calc_dipole_repaired
   
!=====================================================================
subroutine write_rdipole_lm_us(ifile)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
  use parameters
  implicit none
  integer,intent(in) :: ifile
  integer :: n1, l1, t1, m1, n2, l2, t2, m2, ltmltm
  character(3) :: ch1, ch2
  character(1) :: fn_label_orbital
  write(ifile,*)
  write(ifile,*) &
       '[n|x|m] = <psi[n]|x|psi[m]> - <phi[n]|x|phi[m]> = [m|x|n]'
  write(ifile,*) &
       '[n|y|m] = <psi[n]|y|psi[m]> - <phi[n]|y|phi[m]> = [m|y|n]'
  write(ifile,*) &
       '[n|z|m] = <psi[n]|z|psi[m]> - <phi[n]|z|phi[m]> = [m|z|n]'
  write(ifile,*)
  write(ifile,*) &
       '   n = (n1,l1,t1,m1), m = (n2,l2,t2,m2)'
  write(ifile,10) &
       '[n]','[m]','[n|x|m]','[n|y|m]','[n|z|m]'
  do ltmltm = 1,num_dipole_lm_us
     n1 = n1_dipole_lm_us(ltmltm) ; n2 = n2_dipole_lm_us(ltmltm)
     l1 = l1_dipole_lm_us(ltmltm) ; l2 = l2_dipole_lm_us(ltmltm)
     t1 = t1_dipole_lm_us(ltmltm) ; t2 = t2_dipole_lm_us(ltmltm)
     m1 = m1_dipole_lm_us(ltmltm) ; m2 = m2_dipole_lm_us(ltmltm)
     if (l1 > l2) then
        cycle
     end if
     write(ch1,'(i1,a1,i1)') n1, fn_label_orbital(l1), t1
     write(ch2,'(i1,a1,i1)') n2, fn_label_orbital(l2), t2
     write(ifile,11) ch1,m1,ch2,m2,dipole_x_us(ltmltm), &
          dipole_y_us(ltmltm),dipole_z_us(ltmltm)
  end do
10 format(1x,(2x,4x,a3,'-',a3,4x,2x),3(10x,a7,3x))
11 format(1x,(2x,a3,'(',i2,')','-',a3,'(',i2,')',2x),3f20.10)
end subroutine write_rdipole_lm_us

!=================================================== added by K. T. =========== 4.0
subroutine write_rdipole_lm_us_kt(ifile)
  use parameters
  implicit none

  integer,intent(in) :: ifile

  integer :: n1, l1, t1, m1, n2, l2, t2, m2, ltmltm
  character(3) :: ch1, ch2
  character(1) :: fn_label_orbital

  integer :: ispin1

  write(ifile,*)
  write(ifile,*) &
       '[n|x|m] = <psi[n]|x|psi[m]> - <phi[n]|x|phi[m]> = [m|x|n]'
  write(ifile,*) &
       '[n|y|m] = <psi[n]|y|psi[m]> - <phi[n]|y|phi[m]> = [m|y|n]'
  write(ifile,*) &
       '[n|z|m] = <psi[n]|z|psi[m]> - <phi[n]|z|phi[m]> = [m|z|n]'

  write(ifile,*)
  if ( nspin == 1 ) then
     write(ifile,*) &
          '   n = (n1,l1,t1,m1), m = (n2,l2,t2,m2)'
     write(ifile,10) '[n]','[m]','[n|x|m]','[n|y|m]','[n|z|m]'
  else if ( nspin == 2 ) then
     write(ifile,*) &
          '   n = (n1,l1,t1,m1,s1), m = (n2,l2,t2,m2,s2)'
     write(ifile,20) '[n]','[m]','[n|x|m]','[n|y|m]','[n|z|m]'
  end if
  
  
  do ltmltm = 1,num_dipole_lm_us
     n1 = n1_dipole_lm_us(ltmltm) ; n2 = n2_dipole_lm_us(ltmltm)
     l1 = l1_dipole_lm_us(ltmltm) ; l2 = l2_dipole_lm_us(ltmltm)
     t1 = t1_dipole_lm_us(ltmltm) ; t2 = t2_dipole_lm_us(ltmltm)
     m1 = m1_dipole_lm_us(ltmltm) ; m2 = m2_dipole_lm_us(ltmltm)
     
     ispin1 = spin1_index_dipole_lm_us(ltmltm)

     if (l1 > l2) then
        cycle
     end if
     
     write(ch1,'(i1,a1,i1)') n1, fn_label_orbital(l1), t1
     write(ch2,'(i1,a1,i1)') n2, fn_label_orbital(l2), t2

     if ( nspin == 1 ) then
        write(ifile,11) ch1,m1,ch2,m2,dipole_x_us(ltmltm), &
             dipole_y_us(ltmltm),dipole_z_us(ltmltm)

     else if ( nspin == 2 ) then
        if ( ispin1 == 1 ) then
           write(ifile,21) ch1, '_u', m1, ch2,  '_u', m2, &
                &       dipole_x_us(ltmltm), dipole_y_us(ltmltm), dipole_z_us(ltmltm)

        else if ( ispin1 == 2 ) then
           write(ifile,21) ch1, '_d', m1, ch2, '_d', m2, &
                &       dipole_x_us(ltmltm), dipole_y_us(ltmltm), dipole_z_us(ltmltm)

        endif
     endif

  end do
  
10 format(1x,(2x,4x,a3,'-',a3,4x,2x),3(10x,a7,3x))
11 format(1x,(2x,a3,'(',i2,')','-',a3,'(',i2,')',2x),3f20.10)
20 format(1x,(4x,4x,a3,'-',a3,4x,4x),3(10x,a7,3x))
21 format(1x,(2x,a3,a2,'(',i2,')','-',a3,a2,'(',i2,')',2x),3f20.10)

end subroutine write_rdipole_lm_us_kt
! ========================================================================= 4.0

!=====================================================================
subroutine write_rdipole_lm_ps(ifile)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
  use parameters
  implicit none
  integer,intent(in) :: ifile
  integer :: n1, l1, m1, n2, l2, m2, nlmnlm
  character(3) :: ch1, ch2
  character(1) :: fn_label_orbital
  write(ifile,*)
  write(ifile,*) &
       'AE psi[boundstate]: n = (n1,l1,m1), m = (n2,l2,m2)'
  write(ifile,10) &
       '[n]','[m]','<n|x|m>','<n|y|m>','<n|z|m>'
  do nlmnlm = 1,num_dipole_lm_ps
     n1 = n1_dipole_lm_ps(nlmnlm) ; n2 = n2_dipole_lm_ps(nlmnlm)
     l1 = l1_dipole_lm_ps(nlmnlm) ; l2 = l2_dipole_lm_ps(nlmnlm)
     m1 = m1_dipole_lm_ps(nlmnlm) ; m2 = m2_dipole_lm_ps(nlmnlm)
     if (l1 > l2) then
        cycle
     end if
     write(ch1,'(i1,a1)') n1, fn_label_orbital(l1)
     write(ch2,'(i1,a1)') n2, fn_label_orbital(l2)
     write(ifile,11) ch1,m1,ch2,m2,dipole_x_ae(nlmnlm), &
          dipole_y_ae(nlmnlm),dipole_z_ae(nlmnlm)
  end do
  write(ifile,*)
  if ((is_solve_pp_spin /= NO).and.(is_spin_ss == RESTRICTED)) then
     write(ifile,*) &
          'PP phi[solved+polarized]: n = (n1,l1,m1), m = (n2,l2,m2)'
  else
     write(ifile,*) &
          'PP phi[solved+restricted]: n = (n1,l1,m1), m = (n2,l2,m2)'
  end if
  write(ifile,10) &
       '[n]','[m]','<n|x|m>','<n|y|m>','<n|z|m>'
  do nlmnlm = 1,num_dipole_lm_ps
     n1 = n1_dipole_lm_ps(nlmnlm) ; n2 = n2_dipole_lm_ps(nlmnlm)
     l1 = l1_dipole_lm_ps(nlmnlm) ; l2 = l2_dipole_lm_ps(nlmnlm)
     m1 = m1_dipole_lm_ps(nlmnlm) ; m2 = m2_dipole_lm_ps(nlmnlm)
     if (l1 > l2) then
        cycle
     end if
     write(ch1,'(i1,a1)') n1, fn_label_orbital(l1)
     write(ch2,'(i1,a1)') n2, fn_label_orbital(l2)
     write(ifile,11) ch1,m1,ch2,m2,dipole_x_pp(nlmnlm), &
          dipole_y_pp(nlmnlm),dipole_z_pp(nlmnlm)
  end do
  if ((is_solve_pp_spin /= NO).and.(is_spin_ss == RESTRICTED)) then
     write(ifile,*)
     write(ifile,*) &
          'PP phi[repaired]: n = (n1,l1,m1), m = (n2,l2,m2)'
     write(ifile,10) &
          '[n]','[m]','<n|x|m>','<n|y|m>','<n|z|m>'
     do nlmnlm = 1,num_dipole_lm_ps
        n1 = n1_dipole_lm_ps(nlmnlm) ; n2 = n2_dipole_lm_ps(nlmnlm)
        l1 = l1_dipole_lm_ps(nlmnlm) ; l2 = l2_dipole_lm_ps(nlmnlm)
        m1 = m1_dipole_lm_ps(nlmnlm) ; m2 = m2_dipole_lm_ps(nlmnlm)
        if (l1 > l2) then
           cycle
        end if
        write(ch1,'(i1,a1)') n1, fn_label_orbital(l1)
        write(ch2,'(i1,a1)') n2, fn_label_orbital(l2)
        write(ifile,11) ch1,m1,ch2,m2,dipole_x_ss(nlmnlm), &
             dipole_y_ss(nlmnlm),dipole_z_ss(nlmnlm)
     end do
  end if
10 format(1x,(2x,4x,a3,'-',a3,4x,2x),3(10x,a7,3x))
11 format(1x,(3x,a2,'(',i2,')','-',a2,'(',i2,')',3x),3f20.10)
end subroutine write_rdipole_lm_ps

!========================================== added by K. T. ================= 4.0
subroutine write_rdipole_lm_ps_kt(ifile)
  use parameters
  implicit none

  integer,intent(in) :: ifile

  integer :: n1, l1, m1, n2, l2, m2, nlmnlm
  character(3) :: ch1, ch2
  character(1) :: fn_label_orbital

  integer :: ispin1

  write(ifile,*)

  if ( nspin == 1 ) then
     write(ifile,*) &
          'AE psi[boundstate]:  n = (n1,l1,m1), m = (n2,l2,m2)'
     write(ifile,10) '[n]','[m]','<n|x|m>','<n|y|m>','<n|z|m>'

  else if ( nspin == 2 ) then
     write(ifile,*) &
          'AE psi[boundstate]:  n = (n1,l1,m1,s1), m = (n2,l2,m2,s2)'
     write(ifile,20) '[n]','[m]','<n|x|m>','<n|y|m>','<n|z|m>'
  endif
  

  do nlmnlm = 1,num_dipole_lm_ps
     n1 = n1_dipole_lm_ps(nlmnlm) ; n2 = n2_dipole_lm_ps(nlmnlm)
     l1 = l1_dipole_lm_ps(nlmnlm) ; l2 = l2_dipole_lm_ps(nlmnlm)
     m1 = m1_dipole_lm_ps(nlmnlm) ; m2 = m2_dipole_lm_ps(nlmnlm)

     ispin1 = spin1_index_dipole_lm_ps(nlmnlm)

     if (l1 > l2) then
        cycle
     end if
     
     write(ch1,'(i1,a1)') n1, fn_label_orbital(l1)
     write(ch2,'(i1,a1)') n2, fn_label_orbital(l2)

     if ( nspin == 1 ) then
        write(ifile,11) ch1,m1,ch2,m2,dipole_x_ae(nlmnlm), &
             dipole_y_ae(nlmnlm),dipole_z_ae(nlmnlm)

     else if ( nspin == 2 ) then
        if ( ispin1 == 1 ) then
           write(ifile,21) ch1, '_u', m1, ch2, '_u', m2, &
                &   dipole_x_ae(nlmnlm), dipole_y_ae(nlmnlm),dipole_z_ae(nlmnlm)

        else if ( ispin1 == 2 ) then
           write(ifile,21) ch1, '_d', m1, ch2, '_d', m2, &
                &   dipole_x_ae(nlmnlm), dipole_y_ae(nlmnlm),dipole_z_ae(nlmnlm)

        endif
     end if

  end do

  write(ifile,*)
  if ((nspin==1).and.(is_solve_pp_spin /= NO).and.(is_spin_ss == RESTRICTED)) then
     write(ifile,*) &
          'PP phi[solved by solpp]: n = (n1,l1,m1), m = (n2,l2,m2)'
     write(ifile,10) '[n]','[m]','<n|x|m>','<n|y|m>','<n|z|m>'
  else
     write(ifile,*) &
          'PP phi[solved by sol]: n = (n1,l1,m1,s1), m = (n2,l2,m2,s2)'
     write(ifile,20) '[n]','[m]','<n|x|m>','<n|y|m>','<n|z|m>'
  end if


  do nlmnlm = 1,num_dipole_lm_ps
     n1 = n1_dipole_lm_ps(nlmnlm) ; n2 = n2_dipole_lm_ps(nlmnlm)
     l1 = l1_dipole_lm_ps(nlmnlm) ; l2 = l2_dipole_lm_ps(nlmnlm)
     m1 = m1_dipole_lm_ps(nlmnlm) ; m2 = m2_dipole_lm_ps(nlmnlm)

     ispin1 = spin1_index_dipole_lm_ps(nlmnlm)

     if (l1 > l2) then
        cycle
     end if
     write(ch1,'(i1,a1)') n1, fn_label_orbital(l1)
     write(ch2,'(i1,a1)') n2, fn_label_orbital(l2)

     if ( nspin == 1 ) then
        write(ifile,11) ch1,m1,ch2,m2,dipole_x_pp(nlmnlm), &
             dipole_y_pp(nlmnlm),dipole_z_pp(nlmnlm)

     else if ( nspin == 2 ) then
        if ( ispin1 == 1 ) then
           write(ifile,21) ch1, '_u', m1, ch2, '_u', m2, &
                & dipole_x_pp(nlmnlm), dipole_y_pp(nlmnlm),dipole_z_pp(nlmnlm)

        else if ( ispin1 == 2 ) then
           write(ifile,21) ch1, '_d', m1, ch2, '_d', m2, &
                & dipole_x_pp(nlmnlm), dipole_y_pp(nlmnlm),dipole_z_pp(nlmnlm)

        endif
     endif

  end do

  if ( (nspin==1).and.(is_solve_pp_spin /= NO).and.(is_spin_ss == RESTRICTED)) then
     write(ifile,*)
     write(ifile,*) &
          'PP phi[repaired]: n = (n1,l1,m1), m = (n2,l2,m2)'
     write(ifile,10) &
          '[n]','[m]','<n|x|m>','<n|y|m>','<n|z|m>'
     do nlmnlm = 1,num_dipole_lm_ps
        n1 = n1_dipole_lm_ps(nlmnlm) ; n2 = n2_dipole_lm_ps(nlmnlm)
        l1 = l1_dipole_lm_ps(nlmnlm) ; l2 = l2_dipole_lm_ps(nlmnlm)
        m1 = m1_dipole_lm_ps(nlmnlm) ; m2 = m2_dipole_lm_ps(nlmnlm)
        if (l1 > l2) then
           cycle
        end if
        write(ch1,'(i1,a1)') n1, fn_label_orbital(l1)
        write(ch2,'(i1,a1)') n2, fn_label_orbital(l2)
        write(ifile,11) ch1,m1,ch2,m2,dipole_x_ss(nlmnlm), &
             dipole_y_ss(nlmnlm),dipole_z_ss(nlmnlm)
     end do
  end if

10 format(1x,(2x,4x,a3,'-',a3,4x,2x),3(10x,a7,3x))
11 format(1x,(3x,a2,'(',i2,')','-',a2,'(',i2,')',3x),3f20.10)
20 format(1x,(4x,4x,a3,'-',a3,4x,4x),3(10x,a7,3x))
21 format(1x,(3x,a2,a2,'(',i2,')','-',a2,a2,'(',i2,')',3x),3f20.10)

end subroutine write_rdipole_lm_ps_kt

!=====================================================================
subroutine write_pdipole_lm_us(ifile)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in) :: ifile
   integer :: n1, l1, t1, m1, n2, l2, t2, m2, ltmltm
   character(3) :: ch1, ch2
   character(1) :: fn_label_orbital
   write(ifile,*)
   write(ifile,*) &
      '[n|d/dx|m] = <psi[n]|d/dx|psi[m]> - <phi[n]|d/dx|phi[m]> = -[m|d/dx|n]'
   write(ifile,*) &
      '[n|d/dy|m] = <psi[n]|d/dy|psi[m]> - <phi[n]|d/dy|phi[m]> = -[m|d/dy|n]'
   write(ifile,*) &
      '[n|d/dz|m] = <psi[n]|d/dz|psi[m]> - <phi[n]|d/dz|phi[m]> = -[m|d/dz|n]'
   write(ifile,*)
   write(ifile,*) &
      '   n = (n1,l1,t1,m1), m = (n2,l2,t2,m2)'
   write(ifile,10) &
      '[n]','[m]','[n|d/dx|m]','[n|d/dy|m]','[n|d/dz|m]'
   do ltmltm = 1,num_dipole_lm_us
      n1 = n1_dipole_lm_us(ltmltm) ; n2 = n2_dipole_lm_us(ltmltm)
      l1 = l1_dipole_lm_us(ltmltm) ; l2 = l2_dipole_lm_us(ltmltm)
      t1 = t1_dipole_lm_us(ltmltm) ; t2 = t2_dipole_lm_us(ltmltm)
      m1 = m1_dipole_lm_us(ltmltm) ; m2 = m2_dipole_lm_us(ltmltm)
      if (l1 > l2) then
         cycle
      end if
      write(ch1,'(i1,a1,i1)') n1, fn_label_orbital(l1), t1
      write(ch2,'(i1,a1,i1)') n2, fn_label_orbital(l2), t2
      write(ifile,11) ch1,m1,ch2,m2,dipole_dx_us(ltmltm), &
         dipole_dy_us(ltmltm),dipole_dz_us(ltmltm)
   end do
10 format(1x,(2x,4x,a3,'-',a3,4x,2x),3(10x,a10))
11 format(1x,(2x,a3,'(',i2,')','-',a3,'(',i2,')',2x),3f20.10)
 end subroutine write_pdipole_lm_us

!======================================= added by K. T. =================== 4.0
subroutine write_pdipole_lm_us_kt(ifile)
  use parameters
  implicit none

  integer,intent(in) :: ifile

  integer :: n1, l1, t1, m1, n2, l2, t2, m2, ltmltm
  character(3) :: ch1, ch2
  character(1) :: fn_label_orbital

  integer :: ispin1

  write(ifile,*)
  write(ifile,*) &
       '[n|d/dx|m] = <psi[n]|d/dx|psi[m]> - <phi[n]|d/dx|phi[m]> = -[m|d/dx|n]'
  write(ifile,*) &
       '[n|d/dy|m] = <psi[n]|d/dy|psi[m]> - <phi[n]|d/dy|phi[m]> = -[m|d/dy|n]'
  write(ifile,*) &
       '[n|d/dz|m] = <psi[n]|d/dz|psi[m]> - <phi[n]|d/dz|phi[m]> = -[m|d/dz|n]'

  write(ifile,*)

  if ( nspin == 1 ) then
     write(ifile,*) '   n = (n1,l1,t1,m1), m = (n2,l2,t2,m2)'
     write(ifile,10) '[n]','[m]','[n|d/dx|m]','[n|d/dy|m]','[n|d/dz|m]'
  else if ( nspin == 2 ) then
     write(ifile,*) '   n = (n1,l1,t1,m1,s1), m = (n2,l2,t2,m2,s2)'
     write(ifile,20) '[n]','[m]','[n|d/dx|m]','[n|d/dy|m]','[n|d/dz|m]'
  endif


  do ltmltm = 1,num_dipole_lm_us
     n1 = n1_dipole_lm_us(ltmltm) ; n2 = n2_dipole_lm_us(ltmltm)
     l1 = l1_dipole_lm_us(ltmltm) ; l2 = l2_dipole_lm_us(ltmltm)
     t1 = t1_dipole_lm_us(ltmltm) ; t2 = t2_dipole_lm_us(ltmltm)
     m1 = m1_dipole_lm_us(ltmltm) ; m2 = m2_dipole_lm_us(ltmltm)

     ispin1 = spin1_index_dipole_lm_us(ltmltm)

     if (l1 > l2) then
        cycle
     end if

     write(ch1,'(i1,a1,i1)') n1, fn_label_orbital(l1), t1
     write(ch2,'(i1,a1,i1)') n2, fn_label_orbital(l2), t2

     if ( nspin == 1 ) then
        write(ifile,11) ch1,m1,ch2,m2,dipole_dx_us(ltmltm), &
             dipole_dy_us(ltmltm),dipole_dz_us(ltmltm)

     else if ( nspin == 2 ) then
        if ( ispin1 == 1 ) then
           write(ifile,21) ch1, '_u',  m1, ch2,  '_u', m2, &
                &  dipole_dx_us(ltmltm), dipole_dy_us(ltmltm),dipole_dz_us(ltmltm)

        else if ( ispin1 == 2 ) then
           write(ifile,21) ch1,  '_d',  m1, ch2, '_d', m2, &
                &  dipole_dx_us(ltmltm), dipole_dy_us(ltmltm),dipole_dz_us(ltmltm)
        endif

     endif

  end do

10 format(1x,(2x,4x,a3,'-',a3,4x,2x),3(10x,a10))
11 format(1x,(2x,a3,'(',i2,')','-',a3,'(',i2,')',2x),3f20.10)
20 format(1x,(4x,4x,a3,'-',a3,4x,4x),3(10x,a10))
21 format(1x,(2x,a3,a2,'(',i2,')','-',a3,a2,'(',i2,')',2x),3f20.10)

end subroutine write_pdipole_lm_us_kt

!=====================================================================
   subroutine write_pdipole_lm_ps(ifile)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in) :: ifile
   integer :: n1, l1, m1, n2, l2, m2, nlmnlm
   character(3) :: ch1, ch2
   character(1) :: fn_label_orbital
   write(ifile,*)
   write(ifile,*) &
      'AE psi[boundstate]: n = (n1,l1,m1), m = (n2,l2,m2)'
   write(ifile,10) &
      '[n]','[m]','<n|d/dx|m>','<n|d/dy|m>','<n|d/dz|m>'
   do nlmnlm = 1,num_dipole_lm_ps
      n1 = n1_dipole_lm_ps(nlmnlm) ; n2 = n2_dipole_lm_ps(nlmnlm)
      l1 = l1_dipole_lm_ps(nlmnlm) ; l2 = l2_dipole_lm_ps(nlmnlm)
      m1 = m1_dipole_lm_ps(nlmnlm) ; m2 = m2_dipole_lm_ps(nlmnlm)
      if (l1 > l2) then
         cycle
      end if
      write(ch1,'(i1,a1)') n1, fn_label_orbital(l1)
      write(ch2,'(i1,a1)') n2, fn_label_orbital(l2)
      write(ifile,11) ch1,m1,ch2,m2,dipole_dx_ae(nlmnlm), &
         dipole_dy_ae(nlmnlm),dipole_dz_ae(nlmnlm)
   end do
   write(ifile,*)
   if ((is_solve_pp_spin /= NO).and.(is_spin_ss == RESTRICTED)) then
   write(ifile,*) &
      'PP phi[solved+polarized]: n = (n1,l1,m1), m = (n2,l2,m2)'
   else
   write(ifile,*) &
      'PP phi[solved+restricted]: n = (n1,l1,m1), m = (n2,l2,m2)'
   end if
   write(ifile,10) &
      '[n]','[m]','<n|d/dx|m>','<n|d/dy|m>','<n|d/dz|m>'
   do nlmnlm = 1,num_dipole_lm_ps
      n1 = n1_dipole_lm_ps(nlmnlm) ; n2 = n2_dipole_lm_ps(nlmnlm)
      l1 = l1_dipole_lm_ps(nlmnlm) ; l2 = l2_dipole_lm_ps(nlmnlm)
      m1 = m1_dipole_lm_ps(nlmnlm) ; m2 = m2_dipole_lm_ps(nlmnlm)
      if (l1 > l2) then
         cycle
      end if
      write(ch1,'(i1,a1)') n1, fn_label_orbital(l1)
      write(ch2,'(i1,a1)') n2, fn_label_orbital(l2)
      write(ifile,11) ch1,m1,ch2,m2,dipole_dx_pp(nlmnlm), &
         dipole_dy_pp(nlmnlm),dipole_dz_pp(nlmnlm)
   end do
   if ((is_solve_pp_spin /= NO).and.(is_spin_ss == RESTRICTED)) then
   write(ifile,*)
   write(ifile,*) &
      'PP phi[repaired]: n = (n1,l1,m1), m = (n2,l2,m2)'
   write(ifile,10) &
      '[n]','[m]','<n|d/dx|m>','<n|d/dy|m>','<n|d/dz|m>'
   do nlmnlm = 1,num_dipole_lm_ps
      n1 = n1_dipole_lm_ps(nlmnlm) ; n2 = n2_dipole_lm_ps(nlmnlm)
      l1 = l1_dipole_lm_ps(nlmnlm) ; l2 = l2_dipole_lm_ps(nlmnlm)
      m1 = m1_dipole_lm_ps(nlmnlm) ; m2 = m2_dipole_lm_ps(nlmnlm)
      if (l1 > l2) then
         cycle
      end if
      write(ch1,'(i1,a1)') n1, fn_label_orbital(l1)
      write(ch2,'(i1,a1)') n2, fn_label_orbital(l2)
      write(ifile,11) ch1,m1,ch2,m2,dipole_dx_ss(nlmnlm), &
         dipole_dy_ss(nlmnlm),dipole_dz_ss(nlmnlm)
   end do
   end if
10 format(1x,(2x,4x,a3,'-',a3,4x,2x),3(10x,a10))
11 format(1x,(3x,a2,'(',i2,')','-',a2,'(',i2,')',3x),3f20.10)
   end subroutine write_pdipole_lm_ps

!================================================== added by K. T. ============= 4.0
subroutine write_pdipole_lm_ps_kt(ifile)
  use parameters
  implicit none

  integer,intent(in) :: ifile

  integer :: n1, l1, m1, n2, l2, m2, nlmnlm
  character(3) :: ch1, ch2
  character(1) :: fn_label_orbital

  integer :: ispin1

  write(ifile,*)

  if ( nspin == 1 ) then
     write(ifile,*) &
          'AE psi[boundstate]:   n = (n1,l1,m1), m = (n2,l2,m2)'
     write(ifile,10) '[n]','[m]','<n|d/dx|m>','<n|d/dy|m>','<n|d/dz|m>'
  else if ( nspin == 2 ) then
     write(ifile,*) &
          'AE psi[boundstate]:   n = (n1,l1,m1,s1), m = (n2,l2,m2,s2)'
     write(ifile,20) '[n]','[m]','<n|d/dx|m>','<n|d/dy|m>','<n|d/dz|m>'
  endif


  do nlmnlm = 1,num_dipole_lm_ps
     n1 = n1_dipole_lm_ps(nlmnlm) ; n2 = n2_dipole_lm_ps(nlmnlm)
     l1 = l1_dipole_lm_ps(nlmnlm) ; l2 = l2_dipole_lm_ps(nlmnlm)
     m1 = m1_dipole_lm_ps(nlmnlm) ; m2 = m2_dipole_lm_ps(nlmnlm)

     ispin1 = spin1_index_dipole_lm_ps(nlmnlm)

     if (l1 > l2) then
        cycle
     end if

     write(ch1,'(i1,a1)') n1, fn_label_orbital(l1)
     write(ch2,'(i1,a1)') n2, fn_label_orbital(l2)

     if ( nspin == 1 ) then
        write(ifile,11) ch1,m1,ch2,m2,dipole_dx_ae(nlmnlm), &
             dipole_dy_ae(nlmnlm),dipole_dz_ae(nlmnlm)
        
     else if ( nspin == 2 ) then

        if ( ispin1 == 1 ) then
           write(ifile,21) ch1, '_u', m1,ch2, '_u',m2, &
                & dipole_dx_ae(nlmnlm), dipole_dy_ae(nlmnlm),dipole_dz_ae(nlmnlm)

        else if ( ispin1 == 2 ) then
           write(ifile,21) ch1,  '_d', m1,ch2, '_d',m2, &
                & dipole_dx_ae(nlmnlm), dipole_dy_ae(nlmnlm),dipole_dz_ae(nlmnlm)
        endif
     endif

  end do
  
  write(ifile,*)
  if ((nspin==1).and.(is_solve_pp_spin /= NO).and.(is_spin_ss == RESTRICTED)) then
     write(ifile,*) &
          'PP phi[solved by solpp]: n = (n1,l1,m1), m = (n2,l2,m2)'
     write(ifile,10) '[n]','[m]','<n|d/dx|m>','<n|d/dy|m>','<n|d/dz|m>'
  else
     write(ifile,*) &
          'PP phi[solved by sol]: n = (n1,l1,m1,s1), m = (n2,l2,m2,s2)'
     write(ifile,20) '[n]','[m]','<n|d/dx|m>','<n|d/dy|m>','<n|d/dz|m>'
  end if


  do nlmnlm = 1,num_dipole_lm_ps
     n1 = n1_dipole_lm_ps(nlmnlm) ; n2 = n2_dipole_lm_ps(nlmnlm)
     l1 = l1_dipole_lm_ps(nlmnlm) ; l2 = l2_dipole_lm_ps(nlmnlm)
     m1 = m1_dipole_lm_ps(nlmnlm) ; m2 = m2_dipole_lm_ps(nlmnlm)

     ispin1 = spin1_index_dipole_lm_ps(nlmnlm)

     if (l1 > l2) then
        cycle
     end if
     write(ch1,'(i1,a1)') n1, fn_label_orbital(l1)
     write(ch2,'(i1,a1)') n2, fn_label_orbital(l2)

     if ( nspin == 1 ) then
        write(ifile,11) ch1,m1,ch2,m2,dipole_dx_pp(nlmnlm), &
             dipole_dy_pp(nlmnlm),dipole_dz_pp(nlmnlm)

     else if ( nspin == 2 ) then
        if ( ispin1 == 1 ) then
           write(ifile,21) ch1, '_u', m1,ch2, '_u', m2, &
                & dipole_dx_pp(nlmnlm), dipole_dy_pp(nlmnlm),dipole_dz_pp(nlmnlm)

        else if ( ispin1 == 2 ) then
           write(ifile,21) ch1, '_d', m1,ch2, '_d', m2, &
                & dipole_dx_pp(nlmnlm), dipole_dy_pp(nlmnlm),dipole_dz_pp(nlmnlm)
        endif
     endif

  end do

  if ((nspin==1).and.(is_solve_pp_spin /= NO).and.(is_spin_ss == RESTRICTED)) then
     write(ifile,*)
     write(ifile,*) &
          'PP phi[repaired]: n = (n1,l1,m1), m = (n2,l2,m2)'
     write(ifile,10) &
          '[n]','[m]','<n|d/dx|m>','<n|d/dy|m>','<n|d/dz|m>'

     do nlmnlm = 1,num_dipole_lm_ps
        n1 = n1_dipole_lm_ps(nlmnlm) ; n2 = n2_dipole_lm_ps(nlmnlm)
        l1 = l1_dipole_lm_ps(nlmnlm) ; l2 = l2_dipole_lm_ps(nlmnlm)
        m1 = m1_dipole_lm_ps(nlmnlm) ; m2 = m2_dipole_lm_ps(nlmnlm)
        if (l1 > l2) then
           cycle
        end if
        write(ch1,'(i1,a1)') n1, fn_label_orbital(l1)
        write(ch2,'(i1,a1)') n2, fn_label_orbital(l2)
        write(ifile,11) ch1,m1,ch2,m2,dipole_dx_ss(nlmnlm), &
             dipole_dy_ss(nlmnlm),dipole_dz_ss(nlmnlm)
     end do
  end if

10 format(1x,(2x,4x,a3,'-',a3,4x,2x),3(10x,a10))
11 format(1x,(3x,a2,'(',i2,')','-',a2,'(',i2,')',3x),3f20.10)
20 format(1x,(4x,4x,a3,'-',a3,4x,4x),3(10x,a10))
21 format(1x,(3x,a2,a2,'(',i2,')','-',a2,a2,'(',i2,')',3x),3f20.10)

end subroutine write_pdipole_lm_ps_kt
! ============================================================================= 4.0

!=====================================================================
   subroutine write_cubic_ylm(ifile,lmax)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: ifile,lmax
   write(ifile,*)
   write(ifile,*) &
   'Definition of cubic harmonics : Yc[l,m] = Z[l,m]/{sqrt(4*pi)*r^l}'
   write(ifile,*) &
   'where r = sqrt(x*x+y*y+z*z), and Z[l,m] is defined by'
   write(ifile,*)
   if (lmax >= 0) then
      write(ifile,*) 'Z[0, 0] = 1'
   end if
   if (lmax >= 1) then
      write(ifile,*) 'Z[1, 1] = sqrt(3) * x'
      write(ifile,*) 'Z[1, 0] = sqrt(3) * z'
      write(ifile,*) 'Z[1,-1] = sqrt(3) * y'
   end if
   if (lmax >= 2) then
      write(ifile,*) 'Z[2, 2] = sqrt(15)/2 * (x*x-y*y)'
      write(ifile,*) 'Z[2, 1] = sqrt(15)   * x*z'
      write(ifile,*) 'Z[2, 0] = sqrt(5)/2  * (3*z*z-r*r)'
      write(ifile,*) 'Z[2,-1] = sqrt(15)   * y*z'
      write(ifile,*) 'Z[2,-2] = sqrt(15)   * x*y'
   end if
   if (lmax >= 3) then
      write(ifile,*) 'Z[3, 3] = sqrt(70)/4  * x*(x*x-3*y*y)'
      write(ifile,*) 'Z[3, 2] = sqrt(105)/2 * z*(x*x-y*y)'
      write(ifile,*) 'Z[3, 1] = sqrt(42)/4  * x*(5*z*z-r*r)'
      write(ifile,*) 'Z[3, 0] = sqrt(7)/2   * z*(5*z*z-3*r*r)'
      write(ifile,*) 'Z[3,-1] = sqrt(42)/4  * y*(5*z*z-r*r)'
      write(ifile,*) 'Z[3,-2] = sqrt(105)   * x*y*z'
      write(ifile,*) 'Z[3,-3] = sqrt(70)/4  * y*(3*x*x-y*y)'
   end if
   if (lmax >= 4) then
      write(ifile,*) 'Z[4, 4] = 3*sqrt(35)/8 * (x^4-6*x^2*y^2+y^4)'
      write(ifile,*) 'Z[4, 3] = 3*sqrt(70)/4 * x*z*(x*x-3*y*y)'
      write(ifile,*) 'Z[4, 2] = 3*sqrt(5)/4  * (x*x-y*y)*(7*z*z-r*r)'
      write(ifile,*) 'Z[4, 1] = 3*sqrt(10)/4 * x*z*(7*z*z-3*r*r)'
      write(ifile,*) 'Z[4, 0] = 3/8          * (3*r^4-30*r^2*z^2+35*z^4)'
      write(ifile,*) 'Z[4,-1] = 3*sqrt(10)/4 * y*z*(7*z*z-3*r*r)'
      write(ifile,*) 'Z[4,-2] = 3*sqrt(5)/2  * x*y*(7*z*z-r*r)'
      write(ifile,*) 'Z[4,-3] = 3*sqrt(70)/4 * y*z*(3*x*x-y*y)'
      write(ifile,*) 'Z[4,-4] = 3*sqrt(35)/2 * x*y*(x*x-y*y)'
   end if
   if (lmax >= 5) then
      write(ifile,*) 'Z[5, 5] = 3*sqrt(154)/16 * x*(x^4-10*x^2*y^2+5*y^4)'
      write(ifile,*) 'Z[5, 4] = 3*sqrt(385)/8  * z*(x^4-6*x^2*y^2+y^4)'
      write(ifile,*) 'Z[5, 3] = sqrt(770)/16   * x*(x*x-3*y*y)*(9*z*z-r*r)'
      write(ifile,*) 'Z[5, 2] = sqrt(1155)/4   * (x*x-y*y)*z*(3*z*z-r*r)'
      write(ifile,*) 'Z[5, 1] = sqrt(165)/8    * x*(21*z^4-14*z^2*r^2+r^4)'
      write(ifile,*) 'Z[5, 0] = sqrt(11)/8     * z*(63*z^4-70*z^2*r^2+15*r^4)'
      write(ifile,*) 'Z[5,-1] = sqrt(165)/8    * y*(21*z^4-14*z^2*r^2+r^4)'
      write(ifile,*) 'Z[5,-2] = sqrt(1155)/2   * x*y*z*(3*z*z-r*r)'
      write(ifile,*) 'Z[5,-3] = sqrt(770)/16   * y*(3*x*x-y*y)*(9*z*z-r*r)'
      write(ifile,*) 'Z[5,-4] = 3*sqrt(385)/2  * x*y*z*(x*x-y*y)'
      write(ifile,*) 'Z[5,-5] = 3*sqrt(154)/16 * y*(5*x^4-10*x^2*y^2+y^4)'
   end if
   if (lmax >= 6) then
      write(ifile,*) 'Z[6, 6] = sqrt(6006)/32   * (x*x-y*y)*(x^4-14*x^2*y^2+y^4)'
      write(ifile,*) 'Z[6, 5] = 3*sqrt(2002)/16 * x*z*(x^4-10*x^2*y^2+5*y^4)'
      write(ifile,*) 'Z[6, 4] = 3*sqrt(91)/16   * (11*z*z-r*r)*(x^4-6*x^2*y^2+y^4)'
      write(ifile,*) 'Z[6, 3] = sqrt(2730)/16   * x*z*(x*x-3*y*y)*(11*z*z-r*r)'
      write(ifile,*) 'Z[6, 2] = sqrt(2730)/32   * (x*x-y*y)*(33*z^4-18*z^2*r^2+r^4)'
      write(ifile,*) 'Z[6, 1] = sqrt(273)/8     * x*z*(33*z^4-30*z^2*r^2+5*r^4)'
      write(ifile,*) 'Z[6, 0] = sqrt(13)/16     * (231*z^6-315*z^4*r^2+105*z^2*r^4-5*r^6)'
      write(ifile,*) 'Z[6,-1] = sqrt(273)/8     * y*z*(33*z^4-30*z^2*r^2+5*r^4)'
      write(ifile,*) 'Z[6,-2] = sqrt(2730)/16   * x*y*(33*z^4-18*z^2*r^2+r^4)'
      write(ifile,*) 'Z[6,-3] = sqrt(2730)/16   * y*z*(3*x*x-y*y)*(11*z*z-3*r*r)'
      write(ifile,*) 'Z[6,-4] = 3*sqrt(91)/4    * x*y*(x*x-y*y)*(11*z*z-r*r)'
      write(ifile,*) 'Z[6,-5] = 3*sqrt(2002)/16 * y*z*(5*x^4-10*x^2*y^2+y^4)'
      write(ifile,*) 'Z[6,-6] = sqrt(6006)/16   * x*y*(x*x-3*y*y)*(3*x*x-y*y)'
   end if
   end subroutine write_cubic_ylm

!=====================================================================
   subroutine set_pxyz(ier,ifile,lmax,pxyz)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)  :: ifile,lmax
   real(8),intent(out) :: pxyz(-lmax:lmax,-lmax:lmax,0:lmax)
   integer,intent(out) :: ier
   integer :: ll, m1, m2
   real(8) :: tmp
   real(8),allocatable :: cmat(:,:)
   ier = 0
   pxyz(:,:,:) = 0.d0
   if (lmax >= 0) then
      pxyz( 0, 0, 0) =  1.000000000000000d0
   end if
   if (lmax >= 1) then
      pxyz(-1, 1, 1) =  1.000000000000000d0
      pxyz( 1, 0, 1) =  1.000000000000000d0
      pxyz( 0,-1, 1) =  1.000000000000000d0
   end if
   if (lmax >= 2) then
      pxyz( 2, 2, 2) = -0.500000000000000d0
      pxyz( 2, 0, 2) =  0.866025403784439d0
      pxyz( 1,-1, 2) =  1.000000000000000d0
      pxyz( 0, 2, 2) = -0.866025403784439d0
      pxyz( 0, 0, 2) = -0.500000000000000d0
      pxyz(-1,-2, 2) =  1.000000000000000d0
      pxyz(-2, 1, 2) =  1.000000000000000d0
   end if
   if (lmax >= 3) then
      pxyz( 3, 2, 3) = -0.612372435695794d0
      pxyz( 3, 0, 3) =  0.790569415042095d0
      pxyz( 2,-1, 3) =  0.790569415042095d0
      pxyz( 2,-3, 3) = -0.612372435695794d0
      pxyz( 1, 2, 3) = -0.790569415042095d0
      pxyz( 1, 0, 3) = -0.612372435695794d0
      pxyz( 0,-1, 3) = -0.612372435695794d0
      pxyz( 0,-3, 3) = -0.790569415042095d0
      pxyz(-1, 3, 3) = -0.968245836551854d0
      pxyz(-1, 1, 3) = -0.250000000000000d0
      pxyz(-2,-2, 3) =  1.000000000000000d0
      pxyz(-3, 3, 3) = -0.250000000000000d0
      pxyz(-3, 1, 3) =  0.968245836551854d0
   end if
   if (lmax >= 4) then
      pxyz( 4, 4, 4) =  0.125000000000000d0
      pxyz( 4, 2, 4) = -0.661437827766148d0
      pxyz( 4, 0, 4) =  0.739509972887452d0
      pxyz( 3,-1, 4) =  0.661437827766148d0
      pxyz( 3,-3, 4) = -0.750000000000000d0
      pxyz( 2, 4, 4) =  0.661437827766148d0
      pxyz( 2, 2, 4) = -0.500000000000000d0
      pxyz( 2, 0, 4) = -0.559016994374947d0
      pxyz( 1,-1, 4) = -0.750000000000000d0
      pxyz( 1,-3, 4) = -0.661437827766148d0
      pxyz( 0, 4, 4) =  0.739509972887452d0
      pxyz( 0, 2, 4) =  0.559016994374947d0
      pxyz( 0, 0, 4) =  0.375000000000000d0
      pxyz(-1,-2, 4) = -0.353553390593274d0
      pxyz(-1,-4, 4) = -0.935414346693485d0
      pxyz(-2, 3, 4) = -0.935414346693485d0
      pxyz(-2, 1, 4) = -0.353553390593274d0
      pxyz(-3,-2, 4) =  0.935414346693485d0
      pxyz(-3,-4, 4) = -0.353553390593274d0
      pxyz(-4, 3, 4) = -0.353553390593274d0
      pxyz(-4, 1, 4) =  0.935414346693485d0
   end if
   if (lmax >= 5) then
      pxyz( 5, 4, 5) =  0.197642353760524d0
      pxyz( 5, 2, 5) = -0.684653196881458d0
      pxyz( 5, 0, 5) =  0.701560760020114d0
      pxyz( 4,-1, 5) =  0.572821961869480d0
      pxyz( 4,-3, 5) = -0.795495128834866d0
      pxyz( 4,-5, 5) =  0.197642353760524d0
      pxyz( 3, 4, 5) =  0.795495128834866d0
      pxyz( 3, 2, 5) = -0.306186217847897d0
      pxyz( 3, 0, 5) = -0.522912516583797d0
      pxyz( 2,-1, 5) = -0.661437827766148d0
      pxyz( 2,-3, 5) = -0.306186217847897d0
      pxyz( 2,-5, 5) =  0.684653196881458d0
      pxyz( 1, 4, 5) =  0.572821961869480d0
      pxyz( 1, 2, 5) =  0.661437827766148d0
      pxyz( 1, 0, 5) =  0.484122918275927d0
      pxyz( 0,-1, 5) =  0.484122918275927d0
      pxyz( 0,-3, 5) =  0.522912516583797d0
      pxyz( 0,-5, 5) =  0.701560760020114d0
      pxyz(-1, 5, 5) =  0.905711046636840d0
      pxyz(-1, 3, 5) =  0.405046293650491d0
      pxyz(-1, 1, 5) =  0.125000000000000d0
      pxyz(-2,-2, 5) = -0.500000000000000d0
      pxyz(-2,-4, 5) = -0.866025403784439d0
      pxyz(-3, 5, 5) =  0.419262745781211d0
      pxyz(-3, 3, 5) = -0.812500000000000d0
      pxyz(-3, 1, 5) = -0.405046293650491d0
      pxyz(-4,-2, 5) =  0.866025403784439d0
      pxyz(-4,-4, 5) = -0.500000000000000d0
      pxyz(-5, 5, 5) =  0.062500000000000d0
      pxyz(-5, 3, 5) = -0.419262745781211d0
      pxyz(-5, 1, 5) =  0.905711046636840d0
   end if
   if (lmax >= 6) then
      pxyz( 6, 6, 6) = -0.031250000000000d0
      pxyz( 6, 4, 6) =  0.253876200144874d0
      pxyz( 6, 2, 6) = -0.695268608165218d0
      pxyz( 6, 0, 6) =  0.671693289381396d0
      pxyz( 5,-1, 6) =  0.507752400289748d0
      pxyz( 5,-3, 6) = -0.802827036166571d0
      pxyz( 5,-5, 6) =  0.312500000000000d0
      pxyz( 4, 6, 6) = -0.253876200144874d0
      pxyz( 4, 4, 6) =  0.812500000000000d0
      pxyz( 4, 2, 6) = -0.171163299220364d0
      pxyz( 4, 0, 6) = -0.496078370824611d0
      pxyz( 3,-1, 6) = -0.592927061281571d0
      pxyz( 3,-3, 6) = -0.062500000000000d0
      pxyz( 3,-5, 6) =  0.802827036166571d0
      pxyz( 2, 6, 6) = -0.695268608165218d0
      pxyz( 2, 4, 6) =  0.171163299220364d0
      pxyz( 2, 2, 6) =  0.531250000000000d0
      pxyz( 2, 0, 6) =  0.452855523318420d0
      pxyz( 1,-1, 6) =  0.625000000000000d0
      pxyz( 1,-3, 6) =  0.592927061281571d0
      pxyz( 1,-5, 6) =  0.507752400289748d0
      pxyz( 0, 6, 6) = -0.671693289381396d0
      pxyz( 0, 4, 6) = -0.496078370824611d0
      pxyz( 0, 2, 6) = -0.452855523318420d0
      pxyz( 0, 0, 6) = -0.312500000000000d0
      pxyz(-1,-2, 6) =  0.197642353760524d0
      pxyz(-1,-4, 6) =  0.433012701892219d0
      pxyz(-1,-6, 6) =  0.879452954966893d0
      pxyz(-2, 5, 6) =  0.802827036166571d0
      pxyz(-2, 3, 6) =  0.562500000000000d0
      pxyz(-2, 1, 6) =  0.197642353760524d0
      pxyz(-3,-2, 6) = -0.562500000000000d0
      pxyz(-3,-4, 6) = -0.684653196881458d0
      pxyz(-3,-6, 6) =  0.463512405443479d0
      pxyz(-4, 5, 6) =  0.586301969977929d0
      pxyz(-4, 3, 6) = -0.684653196881458d0
      pxyz(-4, 1, 6) = -0.433012701892219d0
      pxyz(-5,-2, 6) =  0.802827036166571d0
      pxyz(-5,-4, 6) = -0.586301969977929d0
      pxyz(-5,-6, 6) =  0.108253175473055d0
      pxyz(-6, 5, 6) =  0.108253175473055d0
      pxyz(-6, 3, 6) = -0.463512405443479d0
      pxyz(-6, 1, 6) =  0.879452954966893d0
   end if
  !++++++++++++++++++++++++++++++++++++++++++++++++++++
   allocate(cmat(-lmax:lmax,-lmax:lmax)) ; cmat = 0.d0
  !++++++++++++++++++++++++++++++++++++++++++++++++++++
   do ll = 0,lmax
      cmat(:,:) = matmul(matmul(pxyz(:,:,ll),pxyz(:,:,ll)),pxyz(:,:,ll))
      do m1 = -ll,ll
      do m2 = -ll,ll
         if (m1 == m2) then
            tmp = abs(cmat(m1,m2) - 1.d0)
         else
            tmp = abs(cmat(m1,m2))
         end if
         if (tmp > 1.d-6) then
            write(ifile,*) '### ERROR ### sigma**3 != 1'
            write(ifile,*) '   m1,m2,ll ...',m1,m2,ll
            write(ifile,*) '   pxyz**3  ...',cmat(m1,m2)
            ier = 1 ; go to 99
         end if
      end do
      end do
   end do
  !+++++++++++++++++
   deallocate(cmat)
  !+++++++++++++++++
99 continue
   end subroutine set_pxyz

!=====================================================================
subroutine set_phase_ylm(ier,lmax,phase_ylm)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
  implicit none
  integer,intent(in)  :: lmax
  integer,intent(out) :: phase_ylm(0:lmax,-lmax:lmax)
  integer,intent(out) :: ier
  ier = 0
  if (lmax >= 0) then
     phase_ylm(0, 0) =  1
  end if
  if (lmax >= 1) then
     phase_ylm(1, 1) =  2
     phase_ylm(1, 0) =  4
     phase_ylm(1,-1) =  3
  end if
  if (lmax >= 2) then
     phase_ylm(2, 2) =  6
     phase_ylm(2, 1) =  9
     phase_ylm(2, 0) =  5
     phase_ylm(2,-1) =  8
     phase_ylm(2,-2) =  7
  end if
  if (lmax >= 3) then
     phase_ylm(3, 3) = 15
     phase_ylm(3, 2) = 13
     phase_ylm(3, 1) = 11
     phase_ylm(3, 0) = 10
     phase_ylm(3,-1) = 12
     phase_ylm(3,-2) = 14
     phase_ylm(3,-3) = 16
  end if
  if (lmax >= 4) then
     phase_ylm(4, 4) = 24
     phase_ylm(4, 3) = 22
     phase_ylm(4, 2) = 20
     phase_ylm(4, 1) = 18
     phase_ylm(4, 0) = 17
     phase_ylm(4,-1) = 19
     phase_ylm(4,-2) = 21
     phase_ylm(4,-3) = 23
     phase_ylm(4,-4) = 25
  end if
99 continue
end subroutine set_phase_ylm

! ========== KT_add ======================================= 4.1
subroutine check_if_corestates
  use parameters
  implicit none
  
  integer :: l1, ishell
  real(8) :: emin
  
  emin = 1.0D10
  Do ishell=1, nshell
     if ( is_valence(ishell) /= 0 ) then
        emin = min( emin, engy(ishell) )
     endif
!     write(*,*) ishell, is_valence(ishell), n_qnum(ishell), l_qnum(ishell)
  End Do
!  stop

  allocate( is_core_states(nshell) );  is_core_states = 0
  num_core_states = 0

  lmax_core_states = 0
  
  Do ishell=1, nshell
     if ( is_valence(ishell) /= 0 )  cycle

!!     if ( engy(ishell) < emin ) then
     if ( engy(ishell) < emin .or. &
          & focc(ishell) > 0 ) then
        is_core_states( ishell ) = 1
        num_core_states = num_core_states +1
        
        l1 = l_qnum(ishell)
        lmax_core_states = max( lmax_core_states, l1 )
     endif
  End Do
  
end subroutine check_if_corestates

subroutine count_felec_core
  use parameters
  implicit none
  
  integer :: ishell

  felec_core = 0.0d0
  Do ishell=1, nshell
     if ( is_core_states(ishell) == 1 ) then
        felec_core = felec_core + focc( ishell )
     endif
  End do
!  write(IFLOG,*) 'Felec core = ', felec_core

end subroutine count_felec_core

subroutine calc_ekin_core_zora_asymm( ekin_core ) ! asymm +zora
  use parameters
  implicit none
  real(8), intent(out) :: ekin_core

  real(8), parameter :: c_vel = 137.035999679D0

  integer :: ishell, ir, ll, ier, ispin
  real(8) :: r, coeff1, c1, c2, c3, c4, c5, term1, term2, vv
  real(8), allocatable :: psi_i(:), dpsi_i(:), ddpsi_i(:), d_veff(:,:)
  real(8), allocatable :: psi_j(:), dpsi_j(:), ddpsi_j(:)

  allocate( d_veff(nmesh,nspin) );  d_veff = 0.0d0
  allocate(   psi_i(nmesh) );         psi_i = 0.0d0;  
  allocate(  dpsi_i(nmesh) );        dpsi_i = 0.0d0;  
  allocate( ddpsi_i(nmesh) );       ddpsi_i = 0.0d0
  if ( is_calc == REL ) then
     allocate(   psi_j(nmesh) );         psi_j = 0.0d0;  
     allocate(  dpsi_j(nmesh) );        dpsi_j = 0.0d0;  
     allocate( ddpsi_j(nmesh) );       ddpsi_j = 0.0d0
  endif

  Do ispin=1, nspin
     call calc_diff_exp( ier,iord_diff, nmesh, rpos(1), veff(1,ispin,lmax_core), &
          &              d_veff(1,ispin) )
  End Do

  ekin_core = 0.0d0

  do ishell = 1,nshell
     if ( is_core_states(ishell) == 0 ) cycle

     ispin = (1-spin(ishell))/2 + 1

     if ( is_calc /= REL ) then     ! SREL 
        ll = l_qnum(ishell)
        coeff1 = dble( ll )*dble( ll +1 )

        psi_i(:) = chi_g(:,ishell)
        call calc_ddiff_exp( ier, iord_diff, nmesh, rpos, psi_i, dpsi_i, ddpsi_i )

        do ir = 1,nmesh
           vv = veff(ir, ispin, lmax_core)
           c1 = 1.0d0 /( 2.0d0 -vv /c_vel**2 )
           c2 = psi_i(ir) *( dpsi_i(ir) -psi_i(ir)/rpos(ir) ) 
           c3 = psi_i(ir) *ddpsi_i(ir) -coeff1 *psi_i(ir) *psi_i(ir) /rpos(ir)**2

           term1 = -d_veff(ir,ispin) /c_vel**2 *c1**2 *c2
           term2 = -c1 *c3

           ekin_core = ekin_core +focc(ishell) *wr(ir) *( term1 +term2 )
        end do
     else
        ll = l_qnum(ishell)
        coeff1 = dble( ll )*dble( ll +1 )

        psi_i(:) = chi_g(:,ishell)
        psi_j(:) = chi_f(:,ishell)
        call calc_ddiff_exp( ier, iord_diff, nmesh, rpos, psi_i, dpsi_i, ddpsi_i )
        call calc_ddiff_exp( ier, iord_diff, nmesh, rpos, psi_j, dpsi_j, ddpsi_j )

        do ir = 1,nmesh
           vv = veff(ir, ispin, lmax_core)
           c1 = 1.0d0 /( 2.0d0 -vv /c_vel**2 )
           c2 = psi_i(ir) *( dpsi_i(ir) -psi_i(ir)/rpos(ir) ) 
           c3 = psi_i(ir) *ddpsi_i(ir) -coeff1 *psi_i(ir) *psi_i(ir) /rpos(ir)**2

           c4 = psi_j(ir) *( dpsi_j(ir) -psi_j(ir)/rpos(ir) ) 
           c5 = psi_j(ir) *ddpsi_j(ir) -coeff1 *psi_j(ir) *psi_j(ir) /rpos(ir)**2

           term1 = -d_veff(ir,ispin) /c_vel**2 *c1**2 *( c2 +c4 )
           term2 = -c1 *( c3 +c5)

           ekin_core = ekin_core +focc(ishell) *wr(ir) *( term1 +term2 )
        end do
     endif
  end do

  deallocate( d_veff )
  deallocate( psi_i );  deallocate( dpsi_i );  deallocate( ddpsi_i )
  if ( is_calc == REL ) then
     deallocate( psi_j );  deallocate( dpsi_j );  deallocate( ddpsi_j )
  endif
end subroutine calc_ekin_core_zora_asymm

subroutine calc_ekin_core_dirac_asymm( ekin_core ) ! asymm +dirac ????
  use parameters
  implicit none
  real(8), intent(out) :: ekin_core

  real(8), parameter :: c_vel = 137.035999679D0

  integer :: ishell, ir, ll, ier, ispin
  real(8) :: r, coeff1, c1, c2, c3, c4, c5, term1, term2, vv
  real(8), allocatable :: psi_i(:), dpsi_i(:), ddpsi_i(:), d_veff(:,:)
  real(8), allocatable :: psi_j(:), dpsi_j(:), ddpsi_j(:)

  allocate( d_veff(nmesh,nspin) );  d_veff = 0.0d0
  allocate(   psi_i(nmesh) );         psi_i = 0.0d0;  
  allocate(  dpsi_i(nmesh) );        dpsi_i = 0.0d0;  
  allocate( ddpsi_i(nmesh) );       ddpsi_i = 0.0d0
  if ( is_calc == REL ) then
     allocate(   psi_j(nmesh) );         psi_j = 0.0d0;  
     allocate(  dpsi_j(nmesh) );        dpsi_j = 0.0d0;  
     allocate( ddpsi_j(nmesh) );       ddpsi_j = 0.0d0
  endif

  Do ispin=1, nspin
     call calc_diff_exp( ier,iord_diff, nmesh, rpos(1), veff(1,ispin,lmax_core), &
          &              d_veff(1,ispin) )
  End Do

  ekin_core = 0.0d0

  do ishell = 1,nshell
     if ( is_core_states(ishell) == 0 ) cycle

     ispin = (1-spin(ishell))/2 + 1

     if ( is_calc /= REL ) then     ! SREL 
        ll = l_qnum(ishell)
        coeff1 = dble( ll )*dble( ll +1 )

        psi_i(:) = chi_g(:,ishell)
        call calc_ddiff_exp( ier, iord_diff, nmesh, rpos, psi_i, dpsi_i, ddpsi_i )

        do ir = 1,nmesh
           vv = veff(ir, ispin, lmax_core) -engy(ishell)
           c1 = 1.0d0 /( 2.0d0 -vv /c_vel**2 )
           c2 = psi_i(ir) *( dpsi_i(ir) -psi_i(ir)/rpos(ir) ) 
           c3 = psi_i(ir) *ddpsi_i(ir) -coeff1 *psi_i(ir) *psi_i(ir) /rpos(ir)**2

           term1 = -d_veff(ir,ispin) /c_vel**2 *c1**2 *c2
           term2 = -c1 *c3

           ekin_core = ekin_core +focc(ishell) *wr(ir) *( term1 +term2 )
        end do
     else
        ll = l_qnum(ishell)
        coeff1 = dble( ll )*dble( ll +1 )

        psi_i(:) = chi_g(:,ishell)
        psi_j(:) = chi_f(:,ishell)
        call calc_ddiff_exp( ier, iord_diff, nmesh, rpos, psi_i, dpsi_i, ddpsi_i )
        call calc_ddiff_exp( ier, iord_diff, nmesh, rpos, psi_j, dpsi_j, ddpsi_j )

        do ir = 1,nmesh
           vv = veff(ir, ispin, lmax_core) -engy(ishell)
           c1 = 1.0d0 /( 2.0d0 -vv /c_vel**2 )
           c2 = psi_i(ir) *( dpsi_i(ir) -psi_i(ir)/rpos(ir) ) 
           c3 = psi_i(ir) *ddpsi_i(ir) -coeff1 *psi_i(ir) *psi_i(ir) /rpos(ir)**2

           c4 = psi_j(ir) *( dpsi_j(ir) -psi_j(ir)/rpos(ir) ) 
           c5 = psi_j(ir) *ddpsi_j(ir) -coeff1 *psi_j(ir) *psi_j(ir) /rpos(ir)**2

           term1 = -d_veff(ir,ispin) /c_vel**2 *c1**2 *( c2 +c4 )
           term2 = -c1 *( c3 +c5)

           ekin_core = ekin_core +focc(ishell) *wr(ir) *( term1 +term2 )
        end do
     endif
  end do

  deallocate( d_veff )
  deallocate( psi_i );  deallocate( dpsi_i );  deallocate( ddpsi_i )
  if ( is_calc == REL ) then
     deallocate( psi_j );  deallocate( dpsi_j );  deallocate( ddpsi_j )
  endif
end subroutine calc_ekin_core_dirac_asymm

subroutine calc_ekin_val_asymm( ekin_val )       ! asymm.
  use parameters
  implicit none

  real(8), intent(out) :: ekin_val
  integer :: ishell, ir, ll, ier, coeff1
  real(8) :: r, c3, c4
  real(8), allocatable :: psi_i(:), dpsi_i(:), ddpsi_i(:)
  real(8), allocatable :: psi_j(:), dpsi_j(:), ddpsi_j(:)

  allocate(   psi_i(nmesh) );         psi_i = 0.0d0;  
  allocate(  dpsi_i(nmesh) );        dpsi_i = 0.0d0;  
  allocate( ddpsi_i(nmesh) );       ddpsi_i = 0.0d0

  if ( is_calc == REL ) then
     allocate(   psi_j(nmesh) );         psi_j = 0.0d0;  
     allocate(  dpsi_j(nmesh) );        dpsi_j = 0.0d0;  
     allocate( ddpsi_j(nmesh) );       ddpsi_j = 0.0d0
  endif
  ekin_val = 0.d0

  do ishell = 1,nshell
     if ( is_core_states(ishell) == 1 ) cycle

     if ( is_calc /= REL ) then
        ll = l_qnum(ishell)
        coeff1 = dble( ll )*dble( ll +1 )

        psi_i(:) = chi_g(:,ishell)
        call calc_ddiff_exp( ier, iord_diff, nmesh, rpos, psi_i, dpsi_i, ddpsi_i )
        do ir = 1,nmesh
           c3 = psi_i(ir) *ddpsi_i(ir) -coeff1 *psi_i(ir) *psi_i(ir) /rpos(ir)**2
           ekin_val = ekin_val -focc(ishell) *0.5d0 *wr(ir) *c3
        end do
     else
        ll = l_qnum(ishell)
        coeff1 = dble( ll )*dble( ll +1 )

        psi_i(:) = chi_g(:,ishell)
        psi_j(:) = chi_f(:,ishell)
        call calc_ddiff_exp( ier, iord_diff, nmesh, rpos, psi_i, dpsi_i, ddpsi_i )
        call calc_ddiff_exp( ier, iord_diff, nmesh, rpos, psi_j, dpsi_j, ddpsi_j )

        do ir = 1,nmesh
           c3 = psi_i(ir) *ddpsi_i(ir) -coeff1 *psi_i(ir) *psi_i(ir) /rpos(ir)**2
           c4 = psi_j(ir) *ddpsi_j(ir) -coeff1 *psi_j(ir) *psi_j(ir) /rpos(ir)**2
           ekin_val = ekin_val -focc(ishell) *0.5d0 *wr(ir) *( c3 +c4 )
        end do
     endif
  end do

  deallocate( psi_i );  deallocate( dpsi_i );  deallocate( ddpsi_i )
  if ( is_calc == REL ) then
     deallocate( psi_j );  deallocate( dpsi_j );  deallocate( ddpsi_j )
  endif
end subroutine calc_ekin_val_asymm

subroutine calc_ekin_val_symm1( ekin_val )         ! symm. ????
  use parameters
  implicit none

  real(8), intent(out) :: ekin_val
  integer :: ishell, ir, ll
  real(8) :: r

  ekin_val = 0.d0
  do ishell = 1,nshell
     if ( is_core_states(ishell) == 1 ) cycle
     if ( is_calc /= REL ) then
        do ir = 1,nmesh
           ll = l_qnum(ishell)
           r  = rpos(ir)
           ekin_val = ekin_val + focc(ishell) &
                * 0.5d0*wr(ir) &
                *( (dxchi_g(ir,ishell)/r)**2 &
                + dble(ll*(ll+1))*(chi_g(ir,ishell)/r)**2 )
        end do
     else
        do ir = 1,nmesh
           ll = l_qnum(ishell)
           r  = rpos(ir)
           ekin_val = ekin_val + focc(ishell) &
                * 0.5d0*wr(ir) &
                *( (dxchi_g(ir,ishell)/r)**2 &
                + dble(ll*(ll+1))*(chi_g(ir,ishell)/r)**2 &
                + (dxchi_f(ir,ishell)/r)**2 &
                + dble(ll*(ll+1))*(chi_f(ir,ishell)/r)**2 )
        end do
     endif
  end do
end subroutine calc_ekin_val_symm1

subroutine calc_ekin_core0( ekin_core )
  use parameters
  implicit none

  real(8), intent(out) :: ekin_core
  integer :: ishell, ir, ll
  real(8) :: r

  ekin_core = 0.d0
  do ishell = 1,nshell
     if ( is_core_states(ishell) == 0) cycle

     do ir = 1,nmesh
        ll = l_qnum(ishell)
        r  = rpos(ir)
        ekin_core = ekin_core + focc(ishell) &
             * 0.5d0*wr(ir) &
             *( (dxchi_g(ir,ishell)/r)**2 &
             + dble(ll*(ll+1))*(chi_g(ir,ishell)/r)**2 )
     end do
  end do
end subroutine calc_ekin_core0

subroutine calc_rho_core_kt(ier)
  use parameters
  implicit none

  integer,intent(out) :: ier
  integer :: ir, ishell
  real(8) :: sum, pi4
  real(8),parameter :: RHOMIN = 1.d-99

  ier = 0
  pi4 = 4.d0 * PI
  rho_core(:) = 0.d0

  do ishell = 1,nshell
     if ( is_core_states(ishell) == 0 ) cycle

     select case (is_calc)
     case (NONREL,SREL)
        do ir = 1,nmesh
           rho_core(ir) = rho_core(ir) &
                + focc(ishell) * (chi_g(ir,ishell)/rpos(ir))**2 / pi4
        end do
     case (REL)
        do ir = 1,nmesh
           rho_core(ir) = rho_core(ir) &
                + focc(ishell) * ( (chi_g(ir,ishell)/rpos(ir))**2 &
                +(chi_f(ir,ishell)/rpos(ir))**2 )/ pi4
        end do
     end select
  end do

  do ir = 1,nmesh
     if (rho_core(ir) < RHOMIN) then
        rho_core(ir) = 0.d0
     end if
  end do
end subroutine calc_rho_core_kt

subroutine calc_vh_core( vh_core, ier )
  use parameters
  implicit none

  real(8), intent(out) :: vh_core( nmesh )
  integer,intent(out) :: ier

  integer :: ir, ii, i0, is, j, jr, ispin
  real(8) :: sum1, sum2

  ier = 0;  vh_core = 0.0d0

  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_core(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_core(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_core(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_core(jr)*wt(jr)
        end do
     end if
     sum2 = sum2*(4.d0*PI)
     vh_core(ir) = sum1 + sum2
  end do
99 continue
end subroutine calc_vh_core

subroutine calc_eion_core( eion_core )
  use parameters
  implicit none

  real(8), intent(out) :: eion_core

  integer :: ir, ishell, ll, ll_core

  eion_core = 0.d0
  
  do ishell = 1,nshell
     if ( is_core_states(ishell) == 0 ) cycle
     
     ll = l_qnum(ishell)
     if (is_core == PATOM) then
        ll_core = ll
     else
        ll_core = lmax_core
     end if
     
     select case (is_calc)
     case (NONREL,SREL)
        do ir = 1,nmesh
           eion_core = eion_core &
                + wr(ir) * focc(ishell) &
                * chi_g(ir,ishell)**2 * vion(ir,ll_core)
        end do
     case (REL)
        do ir = 1,nmesh
           eion_core = eion_core &
                + wr(ir) * focc(ishell) * vion(ir,ll_core) &
                * (chi_g(ir,ishell)**2 + chi_f(ir,ishell)**2)
        end do
     end select
  end do
end subroutine calc_eion_core

subroutine calc_eh_core( eh_core )
  use parameters
  implicit none

  real(8), intent(out) :: eh_core

  integer :: ir, ier
  real(8) :: r
  real(8), allocatable :: vh_core(:)

  allocate( vh_core(nmesh) );  vh_core = 0.0d0
  call calc_rho_core_kt( ier )
  call calc_vh_core( vh_core, ier )

  eh_core = 0.0d0
  do ir = 1,nmesh
     r = rpos(ir)
     eh_core = eh_core &
          + 2.d0*PI*r*r*wr(ir)*rho_core(ir)*vh_core(ir)
  end do
  deallocate( vh_core )

end subroutine calc_eh_core

subroutine sizeof_dipole_cor2val_l_us(ier)
  use parameters
  implicit none
  
  integer,intent(out) :: ier
  
  integer :: ishell, n1, n2
  integer :: lt1, lt2, l1, l2, ltlt
  integer :: ispin1, ispin2
  
  ier = 0;   ltlt = 0
  
  do ishell=1, nshell
     n1 = n_qnum(ishell); l1 = l_qnum(ishell)
     ispin1 = (1-spin(ishell))/2 +1

!        write(*,*) 'n1 l1 valence ', n1, l1, is_valence(ishell)

     lt1 = ishell
     
     if ( is_core_states(ishell) == 0 ) cycle
     
     do lt2 = 1,num_ltx_us
        n2 = n_lt_us(lt2)
        l2 = l_lt_us(lt2)
        ispin2 = spin_index_lt_us(lt2)

        if ( abs(l1-l2) == 1 .and. ispin1 == ispin2 ) then
!              write(*,*) 'XX', n1, l1, n2, l2, ispin2

           ltlt = ltlt + 1
        end if
     end do
  end do
  
  num_dipole_cor2val_l_us = ltlt
  
99 continue
  
end subroutine sizeof_dipole_cor2val_l_us

subroutine sizeof_dipole_cor2val_lm_us(ier)
  use parameters
  implicit none
  
  integer,intent(out) :: ier
  
  integer :: l1, l2, m1, m2, ltlt, ltmltm
  
  ier = 0
  ltmltm = 0
  do ltlt = 1,num_dipole_cor2val_l_us
     l1 = l1_dipole_cor2val_l_us(ltlt) ; l2 = l2_dipole_cor2val_l_us(ltlt)
     
     !        write(*,*) 'YY ', l1, l2
     
     do m1 = -l1,l1
        do m2 = -l2,l2
           ltmltm = ltmltm + 1
        end do
     end do
  end do
  
  num_dipole_cor2val_lm_us = ltmltm
99 continue
  
end subroutine sizeof_dipole_cor2val_lm_us

subroutine calc_dipole_cor2val_l_us(ier)
  use parameters
  implicit none
  
  integer,intent(out) :: ier
  
  integer :: ishell, ispin1, ispin2
  integer :: lt1, lt2, ir, n1, l1, t1, n2, l2, t2, ltlt, lt, nrc
  real(8) :: sum1, sum2, sum3, r
  
  ier = 0
  if ( is_calc == REL ) return
  
  drpsi_us(:,:) = 0.d0 ; drphi_us(:,:) = 0.d0
  do lt = 1,num_ltx_us
     call calc_diff_exp(ier,10,nmesh,rpos(1),rpsi_us(1,lt),drpsi_us(1,lt))
     call calc_diff_exp(ier,10,nmesh,rpos(1),rphi_us(1,lt),drphi_us(1,lt))
  end do
  
  nrc = nrcut_phi_max_us
  call set_weight_exp(ier,1,nrc,rpos,wt)
  
  dipole_cor2val_r_us(:) = 0.d0; 
  dipole_cor2val_ri_us(:) = 0.d0
  dipole_cor2val_pr_us(:) = 0.d0
  
  lt1 = 0; ltlt = 0

! -----
!     MAIN1: do icor2val = 1,num_cor2val_hole
!        n1 = n_val_label_cor2val_hole(icor2val)
!        l1 = l_val_label_cor2val_hole(icor2val)
!        t1 = 1
!        ishell = ishell_cor2val_hole(icor2val)
!        ispin1 = (1-spin(ishell))/2 + 1

!        lt1 = icor2val
! -----
     
  MAIN1: do ishell=1, nshell
     n1 = n_qnum(ishell); l1 = l_qnum(ishell); t1 = 1
     ispin1 = (1-spin(ishell))/2 +1
     
     if ( is_core_states( ishell ) == 0 ) cycle
     
     lt1 = lt1 +1
     
     MAIN2:do lt2 = 1,num_ltx_us
        n2 = n_lt_us(lt2)
        l2 = l_lt_us(lt2)
        t2 = t_lt_us(lt2)
        ispin2 = spin_index_lt_us(lt2)
        
        if ( abs(l1-l2) == 1 .and. ispin1==ispin2 ) then
           ltlt = ltlt + 1
           lt1_dipole_cor2val_l_us(ltlt) = lt1; lt2_dipole_cor2val_l_us(ltlt) = lt2
           n1_dipole_cor2val_l_us (ltlt) = n1 ; n2_dipole_cor2val_l_us (ltlt) = n2
           l1_dipole_cor2val_l_us (ltlt) = l1 ; l2_dipole_cor2val_l_us (ltlt) = l2
           t1_dipole_cor2val_l_us (ltlt) = t1 ; t2_dipole_cor2val_l_us (ltlt) = t2
           
           spin1_indx_dipole_cor2val_l_us(ltlt) = ispin1
           
        else
           cycle MAIN2
        end if
        
        sum1 = 0.d0 ; sum2 = 0.d0 ; sum3 = 0.d0
        
        do ir = 1,nrc
           r = rpos(ir)
           sum1 = sum1 + wt(ir) * r * ( &
                &               chi_g(ir,ishell) *rpsi_us(ir,lt2) &
                &             - chi_g(ir,ishell) *rphi_us(ir,lt2) )
           sum2 = sum2 + wt(ir) / r * ( &
                &               chi_g(ir,ishell) *rpsi_us(ir,lt2) &
                &             - chi_g(ir,ishell) *rphi_us(ir,lt2) )
           sum3 = sum3 + wt(ir) * ( &
                &               chi_g(ir,ishell) *drpsi_us(ir,lt2) &
                &              -chi_g(ir,ishell) *drphi_us(ir,lt2) )
        end do
        dipole_cor2val_r_us(ltlt) = sum1
        dipole_cor2val_ri_us(ltlt) = sum2
        dipole_cor2val_pr_us(ltlt) = sum3
        
     end do MAIN2
  end do MAIN1

  if (ltlt /= num_dipole_cor2val_l_us) then
     write(IFLOG,*) '### ERROR ### ltlt /= num_dipole_cor2val_l_us'
     write(IFLOG,*) '   ltlt            ...',ltlt
     write(IFLOG,*) '   num_dipole_cor2val_l_us ...',num_dipole_cor2val_l_us
     ier = 1 ; go to 99
  end if

99 continue

end subroutine calc_dipole_cor2val_l_us

subroutine calc_dipole_cor2val_lm_us(ier)
  use parameters
  implicit none
  
  integer,intent(out) :: ier
  
  integer :: n1, l1, t1, m1, k1, n2, l2, t2, m2, k2, &
       &     n1p, l1p, t1p, m1p, n2p, l2p, t2p, m2p, &
       &     ltlt, ltmltm, ltmltmz, ltmltmp, isum
  integer :: ispin1, ispin2
  
  real(8) :: sum1, sum2, fac1, fac2
  
  ier = 0
  dipole_cor2val_z_us (:) = 0.d0 ; dipole_cor2val_dz_us(:) = 0.d0
  
  ltmltm = 0
  
  do ltlt = 1,num_dipole_cor2val_l_us
     n1 = n1_dipole_cor2val_l_us(ltlt) ; n2 = n2_dipole_cor2val_l_us(ltlt)
     l1 = l1_dipole_cor2val_l_us(ltlt) ; l2 = l2_dipole_cor2val_l_us(ltlt)
     t1 = t1_dipole_cor2val_l_us(ltlt) ; t2 = t2_dipole_cor2val_l_us(ltlt)
     
     ispin1 = spin1_indx_dipole_cor2val_l_us(ltlt)
     
!        write(*,*) 'ZZ', ltlt, l1, l2

     do m1 = -l1,l1
        do m2 = -l2,l2
           ltmltm = ltmltm + 1
           
           ltmltm_dipole_cor2val_us(ltlt,m1,m2) = ltmltm
           
!              write(500,*) 'GGG ', ltlt, m1, m2, ltmltm,  ltmltm_dipole_cor2val_us(ltlt,m1,m2)

           ltlt_dipole_cor2val_lm_us(ltmltm) = ltlt
           
           n1_dipole_cor2val_lm_us(ltmltm)=n1; n2_dipole_cor2val_lm_us(ltmltm)=n2
           l1_dipole_cor2val_lm_us(ltmltm)=l1; l2_dipole_cor2val_lm_us(ltmltm)=l2
           t1_dipole_cor2val_lm_us(ltmltm)=t1; t2_dipole_cor2val_lm_us(ltmltm)=t2
           m1_dipole_cor2val_lm_us(ltmltm)=m1; m2_dipole_cor2val_lm_us(ltmltm)=m2
           
           spin1_indx_dipole_cor2val_lm_us(ltmltm) = ispin1
           
           if (m1 /= m2) then
              cycle
           end if
           
           if (l1 == l2-1) then
              fac2 = sqrt(dble((l2+m2)*(l2-m2))/dble((2*l2+1)*(2*l2-1)))
              dipole_cor2val_z_us (ltmltm) = fac2*dipole_cor2val_r_us(ltlt)
              dipole_cor2val_dz_us(ltmltm) = fac2*( &
                   dipole_cor2val_pr_us(ltlt) + dble(l2)*dipole_cor2val_ri_us(ltlt) )
              
           else if (l1-1 == l2) then
              fac1 = sqrt(dble((l1+m1)*(l1-m1))/dble((2*l1+1)*(2*l1-1)))
              
              dipole_cor2val_z_us (ltmltm) = fac1*dipole_cor2val_r_us(ltlt)
              dipole_cor2val_dz_us(ltmltm) = fac1*( &
                   dipole_cor2val_pr_us(ltlt) - dble(l1)*dipole_cor2val_ri_us(ltlt) )
           end if
        end do
     end do
     
  end do

!     stop
  
  if (ltmltm /= num_dipole_cor2val_lm_us) then
     write(IFLOG,*) '### ERROR ### ltmltm /= num_dipole_cor2val_lm_us'
     write(IFLOG,*) '   ltmltm           ...',ltmltm
     write(IFLOG,*) '   num_dipole_cor2val_lm_us ...',num_dipole_cor2val_lm_us
     ier = 1 ; go to 99
  end if
  
  dipole_cor2val_x_us (:) = 0.d0 ; dipole_cor2val_y_us (:) = 0.d0
  dipole_cor2val_dx_us(:) = 0.d0 ; dipole_cor2val_dy_us(:) = 0.d0
  
  do ltmltm = 1,num_dipole_cor2val_lm_us
     ltlt = ltlt_dipole_cor2val_lm_us(ltmltm)
     l1 = l1_dipole_cor2val_lm_us(ltmltm); l2 = l2_dipole_cor2val_lm_us(ltmltm)
     m1 = m1_dipole_cor2val_lm_us(ltmltm); m2 = m2_dipole_cor2val_lm_us(ltmltm)
     
     do k1 = -l1,l1
        do k2 = -l2,l2
           ltmltmz = ltmltm_dipole_cor2val_us(ltlt,k1,k2)

!              write(600,*) 'aaaa ', ltlt, k1, k2, m1, m2, ltmltmz
           
           fac1 = pxyz(m1,k1,l1) * pxyz(m2,k2,l2)
           fac2 = pxyz(k1,m1,l1) * pxyz(k2,m2,l2)
           
           dipole_cor2val_x_us(ltmltm) = dipole_cor2val_x_us(ltmltm) &
                + dipole_cor2val_z_us(ltmltmz) * fac1
           dipole_cor2val_y_us(ltmltm) = dipole_cor2val_y_us(ltmltm) &
                + dipole_cor2val_z_us(ltmltmz) * fac2
           dipole_cor2val_dx_us(ltmltm) = dipole_cor2val_dx_us(ltmltm) &
                + dipole_cor2val_dz_us(ltmltmz) * fac1
           dipole_cor2val_dy_us(ltmltm) = dipole_cor2val_dy_us(ltmltm) &
                + dipole_cor2val_dz_us(ltmltmz) * fac2
        end do
           
!           write(*,*) 'ltmltm = ', ltmltm, num_dipole_cor2val_lm_us
     end do
  end do

!     stop 'aaaaaaap'

  return
  
  do ltmltm = 1,num_dipole_cor2val_lm_us
     n1 = n1_dipole_cor2val_lm_us(ltmltm); n2 = n2_dipole_cor2val_lm_us(ltmltm)
     l1 = l1_dipole_cor2val_lm_us(ltmltm); l2 = l2_dipole_cor2val_lm_us(ltmltm)
     t1 = t1_dipole_cor2val_lm_us(ltmltm); t2 = t2_dipole_cor2val_lm_us(ltmltm)
     m1 = m1_dipole_cor2val_lm_us(ltmltm); m2 = m2_dipole_cor2val_lm_us(ltmltm)
     
     ispin1 = spin1_indx_dipole_cor2val_lm_us(ltmltm)
     
     do ltmltmp = 1,num_dipole_cor2val_lm_us
        n1p = n1_dipole_cor2val_lm_us(ltmltmp); n2p = n2_dipole_cor2val_lm_us(ltmltmp)
        l1p = l1_dipole_cor2val_lm_us(ltmltmp); l2p = l2_dipole_cor2val_lm_us(ltmltmp)
        t1p = t1_dipole_cor2val_lm_us(ltmltmp); t2p = t2_dipole_cor2val_lm_us(ltmltmp)
        m1p = m1_dipole_cor2val_lm_us(ltmltmp); m2p = m2_dipole_cor2val_lm_us(ltmltmp)
        
        ispin2 = spin1_indx_dipole_cor2val_lm_us(ltmltmp)
        
        isum = abs(n1-n2p) + abs(l1-l2p) + abs(t1-t2p) + abs(m1-m2p) &
             + abs(n2-n1p) + abs(l2-l1p) + abs(t2-t1p) + abs(m2-m1p)
        
        if (isum == 0 .and. ispin1==ispin2 ) then
           sum1 = abs(dipole_cor2val_x_us (ltmltm) -dipole_cor2val_x_us (ltmltmp)) &
                + abs(dipole_cor2val_y_us (ltmltm) -dipole_cor2val_y_us (ltmltmp)) &
                + abs(dipole_cor2val_z_us (ltmltm) -dipole_cor2val_z_us (ltmltmp))
           sum2 = abs(dipole_cor2val_dx_us(ltmltm) +dipole_cor2val_dx_us(ltmltmp)) &
                + abs(dipole_cor2val_dy_us(ltmltm) +dipole_cor2val_dy_us(ltmltmp)) &
                + abs(dipole_cor2val_dz_us(ltmltm) +dipole_cor2val_dz_us(ltmltmp))
           
           if (abs(sum1) > 1.d-6) then
              write(IFLOG,*) '### ERROR ### [n|r|m] != [m|r|n]'
              write(IFLOG,*) '   n = (n1,l1,t1,m1,s1) ...',n1,l1,t1,m1, ispin1
              write(IFLOG,*) '   m = (n2,l2,t2,m2,s2) ...',n2,l2,t2,m2, ispin2
              write(IFLOG,*) '   [n|x|m]           ...',dipole_cor2val_x_us(ltmltm)
              write(IFLOG,*) '   [m|x|n]           ...',dipole_cor2val_x_us(ltmltmp)
              write(IFLOG,*) '   [n|y|m]           ...',dipole_cor2val_y_us(ltmltm)
              write(IFLOG,*) '   [m|y|n]           ...',dipole_cor2val_y_us(ltmltmp)
              write(IFLOG,*) '   [n|z|m]           ...',dipole_cor2val_z_us(ltmltm)
              write(IFLOG,*) '   [m|z|n]           ...',dipole_cor2val_z_us(ltmltmp)
              ier = 1 ; go to 99
              
           else if (abs(sum2) > 1.d-6) then
              write(IFLOG,*) '### ERROR ### [n|p|m] != -[m|p|n]'
              write(IFLOG,*) '   n = (n1,l1,t1,m1,s1) ...',n1,l1,t1,m1, ispin1
              write(IFLOG,*) '   m = (n2,l2,t2,m2,s2) ...',n2,l2,t2,m2, ispin2
              write(IFLOG,*) '   [n|d/dx|m]        ...',dipole_cor2val_dx_us(ltmltm)
              write(IFLOG,*) '   [m|d/dx|n]        ...',dipole_cor2val_dx_us(ltmltmp)
              write(IFLOG,*) '   [n|d/dy|m]        ...',dipole_cor2val_dy_us(ltmltm)
              write(IFLOG,*) '   [m|d/dy|n]        ...',dipole_cor2val_dy_us(ltmltmp)
              write(IFLOG,*) '   [n|d/dz|m]        ...',dipole_cor2val_dz_us(ltmltm)
              write(IFLOG,*) '   [m|d/dz|n]        ...',dipole_cor2val_dz_us(ltmltmp)
              ier = 2 ; go to 99
              
           else
              exit
           end if
           
        end if
        
        if (ltmltmp == num_dipole_cor2val_lm_us) then
           write(IFLOG,*) '### ERROR ### ltmltmp was not found.'
           ier = 3 ; go to 99
        end if
        
     end do
  end do
  
99 continue

end subroutine calc_dipole_cor2val_lm_us

subroutine write_cor2val_file(ier)
  use parameters 
  implicit none
  
  integer, intent(out) :: ier
  
  integer :: ltmltm, ishell, ir, ispin
  integer :: n1, n2, l1, l2, m1, m2, t1, t2, j2
!
  character(10) :: xc_name
  real(8), allocatable :: array_tmp(:)
  
  if ( is_with_dipole_cor2val == 0) return

  open( IFCOR2VAL, file=trim(file_cor2val), status='unknown' )

  call date_time(day_now);  call write_title(IFCOR2VAL,day_now)
  
  write(IFCOR2VAL,*)
  write(IFCOR2VAL,'(a)') '### Atomic label'
  write(IFCOR2VAL,'((a12,8x),a2,7x,a20)') &
       'atomic_label', atom_label(zatom), atom_name(zatom)
    
  write(IFCOR2VAL,*)
  write(IFCOR2VAL,'(a)') '### Atomic charge : Z, Za, Zc, Zv, (Ne, Nc, Nv)'
  write(IFCOR2VAL,'((a13,6x),(i3,4x),3f11.5)') &
       'atomic_charge', zatom, fatom, fcore, fval
  write(IFCOR2VAL,'((13x,6x),(3x,4x),3f11.5)') felec, felec_core, felec_val
  
  write(IFCOR2VAL,*)
  write(IFCOR2VAL,'(a)') '### 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 ; return
  end select
  
  write(IFCOR2VAL,'((a12,8x),a7,5x,a5)') &
       'xc_potential', xc_name, xc_approx
  write(IFCOR2VAL,*)
  write(IFCOR2VAL,'(a)') '### r-Mesh : Nmesh, rmin, rmax'
  write(IFCOR2VAL,'(a5,5x,a11)') 'rmesh','logarithmic'
  write(IFCOR2VAL,'(i10,2(1pe25.15))') nmesh, rmin, rmax
  write(IFCOR2VAL,*)
  
  write(IFCOR2VAL,'(A)') '### All-electron energy Levels of core states'
  write(IFCOR2VAL,'(A,I4)') 'Num of core states : ', num_core_states
  write(IFCOR2VAL,'(A)') 
  
  write(IFCOR2VAL,'(A)') '  n  l  2j s      Energy (Ha)   nocc   focc'
  
  Do ishell=1, nshell
     if ( is_core_states( ishell ) == 0 ) cycle
     
     n1 = n_qnum(ishell); l1 = l_qnum(ishell); j2 = j2_qnum(ishell)
     ispin = (1-spin(ishell))/2 + 1
     
     write(IFCOR2VAL,'(4I3,F20.12,I3,F10.5)') n1, l1, j2, ispin, engy(ishell), &
          &                          nocc(ishell),focc(ishell)
  End do
  write(IFCOR2VAL,*)

! -----
  write(IFCOR2VAL,'(A)') "### All-electron SCF wavefunctions : r*psi[n](r)"
  write(IFCOR2VAL,'(A)') "ae_wave_function_rpsi"
  
  allocate( array_tmp( nmesh) ) 
  
  Do ishell=1, nshell
     if ( is_core_states( ishell ) == 0 ) cycle
     
     n1 = n_qnum(ishell); l1 = l_qnum(ishell); j2 = j2_qnum(ishell)
     ispin = (1-spin(ishell))/2 + 1
     
     write(IFCOR2VAL,*)
     write(IFCOR2VAL,'(1x,a31,4i3)') &
          'r*psi[n](r): n = (n,l,2j,s) -->',n1, l1, j2, ispin
     do ir = 1,nmesh
        if (abs(chi_g(ir,ishell)) < 1.d-99) then
           array_tmp(ir) = 0.d0
        else
           array_tmp(ir) = chi_g(ir,ishell)
        end if
     end do
     
     write(IFCOR2VAL,15) ( array_tmp(ir),ir=1,nmesh)
  End Do
  
  deallocate( array_tmp ) 

  write(IFCOR2VAL,*)
! -----

  write(IFCOR2VAL,'(a)') &
       '### Dipole moment : [n|d/dx|m], [n|d/dy|m], [n|d/dz|m]'
  write(IFCOR2VAL,'(a)') &
       '#  [n|d/dx|m] = <psi[n]|d/dx|psi[m]> - <phi[n]|d/dx|phi[m]>'
  write(IFCOR2VAL,'(a)') &
       '#  [n|d/dy|m] = <psi[n]|d/dy|psi[m]> - <phi[n]|d/dy|phi[m]>'
  write(IFCOR2VAL,'(a)') &
       '#  [n|d/dz|m] = <psi[n]|d/dz|psi[m]> - <phi[n]|d/dz|phi[m]>'
  write(IFCOR2VAL,'(a)') &
       '#     n = (n1,l1,t1,m1), m = (n2,l2,t2,m2)'
  write(IFCOR2VAL,'(a)') "#               ( n: core orbitals, m: valence orbitals )"
  
  write(IFCOR2VAL,'(A)') 'dipole'
  write(IFCOR2VAL,*) num_dipole_cor2val_lm_us
  
  write(IFCOR2VAL,'(8(1x,a2),3(4x,a10,4x),2(1x,a2))') &
       'n1','l1','t1','m1','n2','l2','t2','m2', &
       '[n|d/dx|m]','[n|d/dy|m]','[n|d/dz|m]','y1','y2'
  
  do ltmltm = 1,num_dipole_cor2val_lm_us
     n1 = n1_dipole_cor2val_lm_us(ltmltm); n2 = n2_dipole_cor2val_lm_us(ltmltm)
     l1 = l1_dipole_cor2val_lm_us(ltmltm); l2 = l2_dipole_cor2val_lm_us(ltmltm)
     t1 = t1_dipole_cor2val_lm_us(ltmltm); t2 = t2_dipole_cor2val_lm_us(ltmltm)
     m1 = m1_dipole_cor2val_lm_us(ltmltm); m2 = m2_dipole_cor2val_lm_us(ltmltm)
     
!        if (l1 > l2) then
!           cycle
!        end if

     write(IFCOR2VAL,53) n1,l1,t1,m1,n2,l2,t2,m2, &
          &            dipole_cor2val_dx_us(ltmltm),&
          &            dipole_cor2val_dy_us(ltmltm), &
          &            dipole_cor2val_dz_us(ltmltm), &
          &            phase_ylm(l1,m1),phase_ylm(l2,m2)
  end do
    
15 format(4e20.12)
53 format(8i3,3e18.10,2i3)

  close(IFCOR2VAL)
     
end subroutine write_cor2val_file

subroutine write_cor2val_to_gncpp2(ier)
  use parameters 
  implicit none
  
  integer, intent(out) :: ier
  
  integer :: ltmltm, ishell, ir, ispin
  integer :: n1, n2, l1, l2, m1, m2, t1, t2, j2
!
  character(10) :: xc_name
  real(8) :: ekin_core, eion_core, eh_core, ekin_val
  real(8), allocatable :: array_tmp(:)
  
  if ( is_with_dipole_cor2val == 0) return

  write(IFGNCPP2,'(A)') 'CORE STATES'
  write(IFGNCPP2,'(I4)') num_core_states

  allocate( array_tmp( nmesh) ) 
    
  Do ishell=1, nshell
     if ( is_core_states( ishell ) == 0 ) cycle
     
     n1 = n_qnum(ishell); l1 = l_qnum(ishell); j2 = j2_qnum(ishell)
     ispin = (1-spin(ishell))/2 + 1
     
     write(IFGNCPP2,'(2I4,F28.15,F12.5,A)') n1, l1, engy(ishell), focc(ishell), &
          &                                 "    n  l  engy  focc"
     do ir = 1,nmesh
        if (abs(chi_g(ir,ishell)) < 1.d-99) then
           array_tmp(ir) = 0.d0
        else
           array_tmp(ir) = chi_g(ir,ishell)
        end if
     end do
     
     write(IFGNCPP2,15) ( array_tmp(ir),ir=1,nmesh)
  End Do
  
  deallocate( array_tmp ) 
  
! ------------
  select case( method_ekin_core )
  case (0)
     call calc_ekin_core0( ekin_core )            ! same as before
  case (-1)
     call calc_ekin_val_symm1( ekin_val )            ! symm. 
     if (is_calc == NONREL) then
        ekin_core = ekin_sum1 -ekin_val
     else
        ekin_core = ekin_sum -ekin_val
     endif
  case (-2)
     call calc_ekin_val_asymm( ekin_val )            ! asymm. 
     if (is_calc == NONREL) then
        ekin_core = ekin_sum1 -ekin_val
     else
        ekin_core = ekin_sum -ekin_val
     endif
  case (1)
     call calc_ekin_core_dirac_asymm( ekin_core )          ! asymm., dirac ???
  case (2)
     call calc_ekin_core_zora_asymm( ekin_core )            ! asymm., zora
  end select

  call calc_eion_core( eion_core )
  call calc_eh_core( eh_core )

  write(IFGNCPP2,'(A)') 'CORE ENERGY CONTRIB'
  write(IFGNCPP2,'(E20.12,A10)') ekin_core, " kin  "
  write(IFGNCPP2,'(E20.12,A10)') eion_core, " ion  "
  write(IFGNCPP2,'(E20.12,A10)') eh_core,   " hartr"
! -----------

! ================== KT_add =================== 4.2
   if ( is_write_soc_core /= 0 ) then
      call calc_soc_core_kt
   endif
! ============================================= 4.2

  write(IFGNCPP2,'(A)') 'DIPOLE-CORE-TO-VALENCE'
  write(IFGNCPP2,'(I6)') num_dipole_cor2val_lm_us
  
  do ltmltm = 1,num_dipole_cor2val_lm_us
     n1 = n1_dipole_cor2val_lm_us(ltmltm); n2 = n2_dipole_cor2val_lm_us(ltmltm)
     l1 = l1_dipole_cor2val_lm_us(ltmltm); l2 = l2_dipole_cor2val_lm_us(ltmltm)
     t1 = t1_dipole_cor2val_lm_us(ltmltm); t2 = t2_dipole_cor2val_lm_us(ltmltm)
     m1 = m1_dipole_cor2val_lm_us(ltmltm); m2 = m2_dipole_cor2val_lm_us(ltmltm)
       
!        if (l1 > l2) then
!           cycle
!        end if

     write(IFGNCPP2,53) n1,l1,t1,m1,n2,l2,t2,m2, &
          &            dipole_cor2val_dx_us(ltmltm),&
          &            dipole_cor2val_dy_us(ltmltm), &
          &            dipole_cor2val_dz_us(ltmltm), &
          &            phase_ylm(l1,m1),phase_ylm(l2,m2)
  end do
  
15 format(4e20.12)
53 format(8i3,3e18.10,2i3)

end subroutine write_cor2val_to_gncpp2

subroutine write_cor2val_to_ciaopp
  use parameters 
  implicit none
  
  integer :: ltmltm, ishell, ir, ispin1
  integer :: n1, n2, l1, l2, m1, m2, t1, t2, j2
!
  character(10) :: xc_name
  real(8) :: ekin_core, eion_core, eh_core, ekin_val
  real(8), allocatable :: array_tmp(:)
  
  if ( is_with_dipole_cor2val == 0) return

  write(IFCIAOPP,*)
  write(IFCIAOPP,'(A)') 'CORE STATES'
  write(IFCIAOPP,'(I4)') num_core_states

  allocate( array_tmp( nmesh) ) 
    
  Do ishell=1, nshell
     if ( is_core_states( ishell ) == 0 ) cycle
     
     n1 = n_qnum(ishell); l1 = l_qnum(ishell); j2 = j2_qnum(ishell)
     ispin1 = (1-spin(ishell))/2 + 1
     
     if ( nspin == 1 ) then
        write(IFCIAOPP,'(2I4,F28.15,F12.5,A)') n1, l1, engy(ishell), focc(ishell), &
             &                                 "    n  l  engy  focc"
     else if ( nspin == 2 ) then
        write(IFCIAOPP,'(3I4,F28.15,F12.5,A)') n1, l1, ispin1, &
             &                                 engy(ishell), focc(ishell), &
             &                                 "    n  l  spin  engy  focc"
     endif
     do ir = 1,nmesh
        if (abs(chi_g(ir,ishell)) < 1.d-99) then
           array_tmp(ir) = 0.d0
        else
           array_tmp(ir) = chi_g(ir,ishell)
        end if
     end do
     
     write(IFCIAOPP,15) ( array_tmp(ir),ir=1,nmesh)
  End Do
  
  deallocate( array_tmp ) 
  
! ------------
  select case( method_ekin_core )
  case (0)
     call calc_ekin_core0( ekin_core )            ! same as before
  case (-1)
     call calc_ekin_val_symm1( ekin_val )            ! symm. 
     if (is_calc == NONREL) then
        ekin_core = ekin_sum1 -ekin_val
     else
        ekin_core = ekin_sum -ekin_val
     endif
  case (-2)
     call calc_ekin_val_asymm( ekin_val )            ! asymm. 
     if (is_calc == NONREL) then
        ekin_core = ekin_sum1 -ekin_val
     else
        ekin_core = ekin_sum -ekin_val
     endif
  case (1)
     call calc_ekin_core_dirac_asymm( ekin_core )          ! asymm., dirac ???
  case (2)
     call calc_ekin_core_zora_asymm( ekin_core )            ! asymm., zora
  end select

  call calc_eion_core( eion_core )
  call calc_eh_core( eh_core )

  write(IFCIAOPP,*)
  write(IFCIAOPP,'(A)') 'CORE ENERGY CONTRIB'
  write(IFCIAOPP,'(E20.12,A10)') ekin_core, " kin  "
  write(IFCIAOPP,'(E20.12,A10)') eion_core, " ion  "
  write(IFCIAOPP,'(E20.12,A10)') eh_core,   " hartr"
! -----------

  write(IFCIAOPP,*)
  write(IFCIAOPP,'(a)') &
       '### Dipole moment core to valence : [n|d/dx|m], [n|d/dy|m], [n|d/dz|m]'

  if ( nspin == 1 ) then
     write(IFCIAOPP,'(a)') &
          '#     n = (n1,l1,t1,m1), m = (n2,l2,t2,m2)'
  else if ( nspin == 2 ) then
     write(IFCIAOPP,'(a)') &
          '#     n = (n1,l1,t1,m1,s1), m = (n2,l2,t2,m2,s2)'
  endif
  
  write(IFCIAOPP,'(A)') 'DIPOLE-CORE-TO-VALENCE'
  write(IFCIAOPP,'(I6)') num_dipole_cor2val_lm_us
   
   do ltmltm = 1,num_dipole_cor2val_lm_us
      n1 = n1_dipole_cor2val_lm_us(ltmltm); n2 = n2_dipole_cor2val_lm_us(ltmltm)
      l1 = l1_dipole_cor2val_lm_us(ltmltm); l2 = l2_dipole_cor2val_lm_us(ltmltm)
      t1 = t1_dipole_cor2val_lm_us(ltmltm); t2 = t2_dipole_cor2val_lm_us(ltmltm)
      m1 = m1_dipole_cor2val_lm_us(ltmltm); m2 = m2_dipole_cor2val_lm_us(ltmltm)

      ispin1 = spin1_indx_dipole_cor2val_lm_us(ltmltm)
       
!        if (l1 > l2) then
!           cycle
!        end if

      if ( nspin == 1 ) then
          write(IFCIAOPP,'(8i3,3(1pe18.10),2i3)') &
               &       n1,l1,t1,m1,n2,l2,t2,m2, &
               &       dipole_cor2val_dx_us(ltmltm),&
               &       dipole_cor2val_dy_us(ltmltm), &
               &       dipole_cor2val_dz_us(ltmltm), &
               &       phase_ylm(l1,m1),phase_ylm(l2,m2)
       else if ( nspin == 2 ) then
          write(IFCIAOPP,'(10i3,3(1pe18.10),2i3)') &
               &       n1,l1,t1,m1, ispin1, n2,l2,t2,m2, ispin1, &
               &       dipole_cor2val_dx_us(ltmltm),&
               &       dipole_cor2val_dy_us(ltmltm), &
               &       dipole_cor2val_dz_us(ltmltm), &
               &       phase_ylm(l1,m1),phase_ylm(l2,m2)
       endif
   end do
   
15 format(4e20.12)

end subroutine write_cor2val_to_ciaopp
! ========================================================= 4.1
