!
!  Software name : CIAO (Code for Investigating Atomic Orbitals)
!  Subroutine(s) : calc_pp, calc_rcore_rmaxps, write_rcore_rmaxps
!                : sort_ips_ps, calc_felec_val_us, set_ips_loc
!                : write_pp, write_gncpp, write_gncpp2, write_ciaopp
!  Author(s)     : Masakuni Okamoto (August 25, 2003)
!
!
!  Contact address :  Phase System Consortium
!                     E-mail: phase_system@nims.go.jp URL https://azuma.nims.go.jp
!
!
!  The license of the code and contact address :
!  See the files, COPYRIGHT and LICENSE (or LICENSE_J.pdf)
!
!=====================================================================
   subroutine calc_pp(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   call find_ishell_core_hole(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in find_ishell_core_hole'
      go to 99
   end if
   call calc_rho_core(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in calc_rho_core' ; go to 99
   end if
   call calc_rcore_rmaxps(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in calc_rcore_rmaxps' ; go to 99
   end if
   call set_ips_loc(ier)
   if (ier /= 0) then
      write(IFLOG,*) '### ERROR ### in set_ips_loc' ; go to 99
   end if
   select case (is_pp)
   case (GENERAL_PP, TM91)
      select case (is_calc)
      case (NONREL,SREL)
         call calc_general_pp_srel(ier)
         if (ier /= 0) then
            write(IFLOG,*) '### ERROR ### in calc_general_pp_srel' ; go to 99
         end if
         is_pp_generated = YES
         select case (is_pp_calc_class)
         case (NC)
            write(IFLOG,*)
            write(IFLOG,*) &
               'Troullier-Martins pseudopotentials have been calculated.'
            write(IFSUM,*)
            write(IFSUM,*) &
               'Troullier-Martins pseudopotentials have been calculated.'
         case (US)
            write(IFLOG,*)
            write(IFLOG,*) &
               'General pseudopotentials have been calculated.'
            write(IFSUM,*)
            write(IFSUM,*) &
            'General pseudopotentials have been calculated.'
         end select
      case (REL)
         write(IFLOG,*)
         write(IFLOG,*) 'General pseudopotential is not supported for REL.'
         write(IFSUM,*)
         write(IFSUM,*) 'General pseudopotential is not supported for REL.'
      end select
   case (TM91SO)
      select case (is_calc)
      case (NONREL,SREL)
         write(IFLOG,*)
         write(IFLOG,*) 'TMSO pseudopotential is not generated from NONREL/SREL.'
         write(IFSUM,*)
         write(IFSUM,*) 'TMSO pseudopotential is not generated from NONREL/SREL.'
      case (REL)
         call calc_tmso_pp_rel(ier)
         if (ier /= 0) then
            write(IFLOG,*) '### ERROR ### in calc_tmso_pp_rel' ; go to 99
         end if
         is_pp_generated = YES
         select case (is_pp_calc_class)
         case (NC)
            write(IFLOG,*)
            write(IFLOG,*) 'TMSO pseudopotentials have been calculated.'
            write(IFSUM,*)
            write(IFSUM,*) 'TMSO pseudopotentials have been calculated.'
         end select
         call write_tmsopp(ier)
      end select
   case (BHS82)
      select case (is_calc)
      case (NONREL,SREL)
         write(IFLOG,*)
         write(IFLOG,*) 'BHS pseudopotential is not generated from NONREL/SREL.'
         write(IFSUM,*)
         write(IFSUM,*) 'BHS pseudopotential is not generated from NONREL/SREL.'
      case (REL)
         call calc_bhs_pp_rel(ier)
         if (ier /= 0) then
            write(IFLOG,*) '### ERROR ### in calc_bhs_pp_rel' ; go to 99
         end if
         is_pp_generated = YES
         select case (is_pp_calc_class)
         case (NC)
            write(IFLOG,*)
            write(IFLOG,*) 'BHS pseudopotentials have been calculated.'
            write(IFSUM,*)
            write(IFSUM,*) 'BHS pseudopotentials have been calculated.'
         end select
         call write_bhspp(ier)
      end select
   end select
99 continue
   end subroutine calc_pp

!=====================================================================
   subroutine calc_rcore_rmaxps(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ir, ishell, ll
   real(8) :: rcut_tmp
   ier = 0
   if (felec_core > 1.d-5) then
   do ir = nmesh,2,-1
      if (rho_core(ir) > 1.d-10) then
         r_core = rpos(ir) ; exit
      end if
   end do
   else
      r_core = 0.d0
   end if
   rmax_ps = 0.d0
   do ishell = 1,nshell
      if (is_valence(ishell) /= 0) then
         rcut_tmp = rcut_tm(l_qnum(ishell))
         ll       = l_qnum(ishell)
         if (rmax_ps < rcut_tmp) then
            rmax_ps = rcut_tmp
         end if
      end if
   end do
   call write_rcore_rmaxps(IFLOG)
   call write_rcore_rmaxps(IFSUM)
   if (dist_nn(zatom)*0.5d0 < 1.d-6) then
   else if (rmax_ps > dist_nn(zatom)*0.5d0) then
      call write_caution_dist_nn(IFLOG)
      call write_caution_dist_nn(IFSUM)
   end if
99 continue
   end subroutine calc_rcore_rmaxps

!=====================================================================
   subroutine write_caution_dist_nn(ifile)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in) :: ifile
   write(ifile,*)
   write(ifile,*) '#################### CAUTION #####################'
   write(ifile,*) '##  One of cutoff radii is longer than half of  ##'
   write(ifile,*) '##  the nearest neighbour distance.             ##'
   write(ifile,*) '##################################################'
   write(ifile,10) 'Maximum ps radius  (Bohr),(A):', &
      rmax_ps, rmax_ps*BOHR
   write(ifile,10) '1/2 of n.n. distance  (B),(A):', &
      dist_nn(zatom)*0.5d0, dist_nn(zatom)*0.5d0*BOHR
10 format(1x,a30,2(f20.10))
   end subroutine write_caution_dist_nn

!=====================================================================
   subroutine write_rcore_rmaxps(ifile)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(in) :: ifile
   write(ifile,*)
   write(ifile,10) 'Core charge radius (Bohr),(A):', &
      r_core, r_core*BOHR
   write(ifile,10) 'Maximum ps radius  (Bohr),(A):', &
      rmax_ps, rmax_ps*BOHR
   write(ifile,10) '1/2 of n.n. distance  (B),(A):', &
      dist_nn(zatom)*0.5d0, dist_nn(zatom)*0.5d0*BOHR
10 format(1x,a30,2(f20.10))
   end subroutine write_rcore_rmaxps

!=====================================================================
   subroutine sort_ips_ps(ier,nps,nref, &
      n_val_label_ps,l_val_label_ps,is_val_type_ps,nref_ps, &
      rcut_phi_ps,deref_ps,rin_qps_ps,is_gen_ps)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   implicit none
   integer,intent(in)    :: nps, nref
   integer,intent(inout) :: n_val_label_ps(nps), &
                            l_val_label_ps(nps), &
                            is_val_type_ps(nps), &
                            nref_ps(nps),        &
                            is_gen_ps(nps,2)
   real(8),intent(inout) :: rcut_phi_ps(nps,nref), &
                            deref_ps(nps,nref), &
                            rin_qps_ps(nps,nref)
   integer,intent(out)   :: ier
   integer :: ips, jps, l1, l2, tt
   ier = 0
   if (nps > 1) then
      do ips = 1,nps-1
         l1 = l_val_label_ps(ips)
         do jps = ips+1,nps
            l2 = l_val_label_ps(jps)
            if (l1 > l2) then
               call iswap(n_val_label_ps(ips),n_val_label_ps(jps))
               call iswap(l_val_label_ps(ips),l_val_label_ps(jps))
               call iswap(is_val_type_ps(ips),is_val_type_ps(jps))
               call iswap(nref_ps(ips),nref_ps(jps))
               do tt = 1,nref
                  call swap(rcut_phi_ps(ips,tt),rcut_phi_ps(jps,tt))
                  call swap(deref_ps(ips,tt),deref_ps(jps,tt))
                  call swap(rin_qps_ps(ips,tt),rin_qps_ps(jps,tt))
               end do
               do tt = 1,2
                  call iswap(is_gen_ps(ips,tt),is_gen_ps(jps,tt))
               end do
               l1 = l2
            end if
         end do
      end do
   end if
99 continue
   end subroutine sort_ips_ps

!=====================================================================
   subroutine calc_ishell_ps_felec_val(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ishell, n1, l1, n2, l2, k2, ips, &
              is_found, ishell_found, iso
   ier = 0
   felec_val = 0.d0
   is_valence(:) = 0
   num_so_ps(:) = 0
   do ips = 1,nps
      n1 = n_val_label_ps(ips)
      l1 = l_val_label_ps(ips)
      iso = 0
      is_found = 0
      do ishell = 1,nshell
         n2 = n_qnum(ishell)
         l2 = l_qnum(ishell)
         k2 = k_qnum(ishell)
         if ((n1 == n2).and.(l1 == l2)) then
            iso = iso + 1
            ishell_found = ishell
            is_valence(ishell_found) = 1
            ishell_ps(ips,iso) = ishell_found
            is_found = is_found + 1
            felec_val = felec_val + focc(ishell_found)
         end if
      end do
      num_so_ps(ips) = iso
      if (is_found == 0) then
         write(IFLOG,*) '### ERROR ### ishell was not found'
         write(IFLOG,*) &
            'Valence state specified by PP input was not found.'
         write(IFLOG,*) '   (n,l) ...',n1,l1
         ier = 1 ; go to 99
      end if
   end do
99 continue
   end subroutine calc_ishell_ps_felec_val

!=====================================================================
   subroutine set_ips_loc(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ishell, ll, ips
   ier = 0
   if (nps == 0) then
      write(IFLOG,*) '### ERROR ### nps == 0'
      ier = 1 ; go to 99
   end if
   ips_loc = 0
   do ips = 1,nps
      ishell = ishell_ps(ips,1)
      ll = l_qnum(ishell)
      if (ll == lloc) then
         ips_loc = ips
      end if
   end do
99 continue
   end subroutine set_ips_loc

!=====================================================================
   subroutine write_pp(ier)
!=====================================================================
!
!  ### CAUTION ### 2006.08.23 M.O.
!  Temporarily, tt = 1 for veff_ps()
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   integer :: ips, ishell, ir, nn, ll, kk, jj2, ispin, ll_core, lt
   character(1) :: fn_label_orbital
   character(2) :: ch_del, ch2
   ier = 0
   ch_del = ','//' '
   open(IFPP,file=trim(ppfile),status='unknown')
   write(IFPP,*) 'All-electron potential and pseudopotential'
   call write_file_header(IFPP)
   write(IFPP,*)
   select case (nspin)
   case (1)
      write(IFPP,*) 'rpos, rho, rho_ps, vh, vh_ps, vxc_ps, vloc_ion'
      do ir = 1,nmesh
         write(IFPP,10) rpos(ir),rho(ir,1),rho_ps(ir), &
                        vh(ir),vh_ps(ir),vx_ps(ir)+vc_ps(ir), &
                        vloc_ion_us(ir)
      end do
   case (2)
      write(IFPP,*) &
         'rpos, rho1, rho2, rho_ps, vh, vh_ps, vxc_ps, vloc_ion'
      do ir = 1,nmesh
         write(IFPP,10) rpos(ir),rho(ir,1),rho(ir,2),rho_ps(ir), &
                        vh(ir),vh_ps(ir),vx_ps(ir)+vc_ps(ir), &
                        vloc_ion_us(ir)
      end do
   end select
   do ips = 1,nps
      ishell = ishell_ps(ips,1)
      nn = n_qnum(ishell)
      ll = l_qnum(ishell)
      lt = lt_n_us(ll,1)
      if (is_core == PATOM) then
         ll_core = ll
      else
         ll_core = lmax_core
      end if
      kk = k_qnum(ishell)
      jj2 = j2_qnum(ishell)
      ispin = (1-spin(ishell))/2 + 1
      ch2(1:2) = '_'//fn_label_orbital(ll)
      write(IFPP,*)
      write(IFPP,30) nn,ll,jj2,ispin,'(n, l, 2*j, s)'
      write(IFPP,31) eref_us(lt),           'elevel'
      write(IFPP,31) rpos(nrcut_phi_us(lt)),'rcut  '
      write(IFPP,*)
      write(IFPP,*) &
         'rpos'//ch2//ch_del//'chi'//ch2//ch_del//'chi_ps'//ch2 &
         //ch_del//'veff'//ch2//ch_del//'veff_ps'//ch2 &
         //ch_del//'vion'//ch2//ch_del//'vion_ps'//ch2
      do ir = 1,nmesh
         write(IFPP,10) rpos(ir),rpsi_us(ir,lt),rphi_us(ir,lt), &
                        veff(ir,ispin,ll_core),veff_ps(ir,ips,1), &
                        vion(ir,ll_core),vion_ps(ir,ips,1)
      end do
   end do
10 format(10(1pe20.10))
30 format(1x,4i5,   5x,':',1x,a14)
31 format(1x,f20.10,5x,':',1x,a6)
   close(IFPP)
   end subroutine write_pp

!=====================================================================
   subroutine write_gncpp(ier)
!=====================================================================
!
!  ### CAUTION ### 2006.08.23 M.O.
!  Temporarily, tt = 1 for veff_ps()
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   
   character(7) :: xcname
   integer :: ival, iloc, itpcc, ir, ips, ishell, ll, lt, &
              icoeff, ln, tn, lm, tm, l3, tmin, ltlt, ispin, &
              mm, mmmax, mopsw, mopsc, il1, tau1, il2, tau2, il3
   real(8) :: cca1, cca2, ccc1, chgpc
   integer,allocatable :: &
      nrcl(:,:), nrcml(:,:), ivanl(:), itau(:)
   real(8),allocatable :: &
      vscr(:,:), rhvr(:), co1(:,:,:), phiv(:,:,:), eps(:,:), &
      qrsps(:,:,:), copsc(:,:,:), rhpcr(:), coc(:)
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   mmmax = max(ncoeff_phi_us,ncoeff_qps_us)
   allocate(nrcl(lmax+1,nref_max_us),nrcml(num_ltltx_us,l3_max_us+1),&
      ivanl(lmax+1),itau(lmax+1),vscr(nmesh,lmax+1),rhvr(nmesh),&
      co1(0:mmmax,lmax+1,l3_max_us+1),phiv(nmesh,lmax+1,nref_max_us),&
      eps(lmax+1,nref_max_us),qrsps(nmesh,num_ltltx_us,l3_max_us+1),&
      copsc(0:mmmax,num_ltltx_us,l3_max_us+1),rhpcr(nmesh),&
      coc(0:ncoeff_pcc))
      nrcl    = 0 ; nrcml    = 0 ; ivanl    = 0 ; itau     = 0
      vscr = 0.d0 ; rhvr  = 0.d0 ; co1   = 0.d0 ; phiv  = 0.d0
      eps  = 0.d0 ; qrsps = 0.d0 ; copsc = 0.d0 ; rhpcr = 0.d0
      coc  = 0.d0
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   
   open(IFGNCPP,file=trim(gncppfile),status='unknown')
   rewind(IFGNCPP)
   
   write(IFLOG,*) '   Writing GNCPP1 -->',IFGNCPP
   fval = fatom - felec_core
   zval = int(fval + 1.d-6)
   ival   = zval
   iloc   = lloc+1 
   select case (is_pcc)
   case (NONE)
      itpcc = 0
   case (PCC)
      itpcc = 1
   case (FCC)
      itpcc = 2
   end select

   if (abs(fatom-dble(zatom)) < 1.d-6) then
      if (abs(fval-dble(ival)) < 1.d-5) then
         write(IFGNCPP,60) zatom, ival, iloc, itpcc  !!!  GNCPP1
      else
         write(IFGNCPP,61) zatom, fval, iloc, itpcc  !!!  GNCPP1
      end if
   else
      if (abs(fval-dble(ival)) < 1.d-5) then
         write(IFGNCPP,62) fatom, ival, iloc, itpcc  !!!  GNCPP1
      else
         write(IFGNCPP,63) fatom, fval, iloc, itpcc  !!!  GNCPP1
      end if
   end if
60 format(' ',5i4,         '  : zatom, ival, iloc, itpcc ')
61 format(' ',i4,f10.5,3i4,'  : zatom, fval, iloc, itpcc ')
62 format(' ',f10.5,4i4,   '  : fatom, ival, iloc, itpcc ')
63 format(' ',2f10.5,3i4,  '  : fatom, fval, iloc, itpcc ')

   select case (is_xc)
   case (LDAPZ81)
      xcname = 'ldapz81'
   case (LDAPW92_MOMO, LDAPW92_MOMO2, LDAPW92_GNCPP)
      xcname = 'ldapw91'
   case (GGAPW91_MOMO, GGAPW91_MOMO2, GGAPW91_F90, GGAPW91_F77)
      xcname = 'ggapw91'
   case (GGAPBE96_MOMO, GGAPBE96_MOMO2, GGAPBE96_GNCPP, GGAPBE96_KATO)
      xcname = 'ggapbe'
   case default
      write(IFLOG,*) '### ERROR ### xc-type'
      write(IFLOG,*) '   is_xc ...', is_xc
      ier = 1 ; go to 99
   end select
   write(IFGNCPP,11) xcname
11 format(a7,'  : name ')

   cca1 = cc_a1(zatom)
   cca2 = cc_a2(zatom)
   ccc1 = cc_c1(zatom)
   write(IFGNCPP,12) cca1,cca2,ccc1,1.d0-ccc1
12 format(' ',4f12.6,'  :   alp,cc')

   write(IFGNCPP,13)           nmesh,  xh, rmax
13 format(' ',i6,2f12.6,'  :   nmesh,  xh, rmax')

   write(IFGNCPP,14)
14 format('VALL')

   ispin = 1
   write(IFGNCPP,15) (veff(ir,ispin,lmax_core),ir=1,nmesh)
15 format(3e25.17)

   vscr(:,:) = 0.d0
   select case (is_pp_calc_class)
   case (NC)
      do ips = 1,nps
         ishell = ishell_ps(ips,1)
         ll = l_qnum(ishell)
         do ir = 1,nmesh                      
            vscr(ir,ll+1) = veff_ps(ir,ips,1) 
         end do                               
      end do
   case (US)
      do lt = 1,num_ltx_us
         ips = ips_lt_us(lt)
         ln = ln_lt_us(lt)
         tn = tn_lt_us(lt)
         select case (is_val_type_us(ln))
         case (TM91)
            do ir = 1,nmesh
               vscr(ir,ln+1) = veff_ps(ir,ips,1)
            end do
         case (US90)
            do ir = 1,nmesh
               vscr(ir,ln+1) = 0.d0
            end do
         end select
      end do
   end select
   if(iloc >= 5) then
      write(IFGNCPP,15) (vloc_scr_sol(ir),ir=1,nmesh)
   else
      write(IFGNCPP,15) (vscr(ir,iloc),ir=1,nmesh)
   endif

   do ir = 1,nmesh
      rhvr(ir) = rho_sol(ir) * 4.d0*PI*rpos(ir)**2
   end do                                        
   write(IFGNCPP,15) (rhvr(ir),ir=1,nmesh)

   if(lmax == 3) then
      write(IFGNCPP,16)
   end if
16 format('F-STATE')

   co1 (:,:,:) = 0.d0
   phiv(:,:,:) = 0.d0
   select case (is_pp_calc_class)
   case (NC)
      mopsw = 0
      do lt = 1,num_ltx_us
         ln = ln_lt_us(lt)
         tn = tn_lt_us(lt)
         do ir=1,nmesh
            phiv(ir,ln+1,tn) = rphi_us(ir,lt)
         end do
      end do
   case (US)
      mopsw = ncoeff_phi_us
      do lt = 1,num_ltx_us
         ln = ln_lt_us(lt)
         tn = tn_lt_us(lt)
         ips = ips_lt_us(lt)
         select case (is_val_type_us(ln))
         case (TM91)
            do ir=1,nmesh
               phiv(ir,ln+1,tn) = rphi_us(ir,lt)
            end do            
         case (US90)                                
            do icoeff = 0,mopsw
               co1(icoeff,ln+1,tn) = coeff_phi_us(icoeff,lt)
            end do
            do ir=1,nmesh
               phiv(ir,ln+1,tn) = rphi_us(ir,lt)
            end do
         end select
      end do
   end select
   nrcl (:,:) = 0
   nrcml(:,:) = 0
   select case (is_pp_calc_class)
   case (NC)
   case (US)
      do ln = 0,lmax
         do tn = 1,nref_us(ln)
            lt = lt_n_us(ln,tn)
            nrcl(ln+1,tn) = nrcut_phi_us(lt)
         end do
      end do
      mm = 0
      do ln = 0,lmax
         if (ln == lloc) then
            cycle
         end if
         do tn = 1,nref_us(ln)
            do lm = ln,lmax
               if (lm == lloc) then
                  cycle
               end if
               if ((is_val_type_us(ln) == TM91).and. &
                   (is_val_type_us(lm) == TM91)) then
                  cycle
               end if
               tmin = 1
               if (ln == lm) then
                  tmin = tn
               end if
               do tm = tmin,nref_us(lm)
                  mm = mm+1
                  ltlt = ltlt_nm_us(ln,tn,lm,tm)
                  do l3 = abs(ln-lm),ln+lm,2
                     nrcml(mm,l3+1) = nrcut_qps_us(ltlt,l3)
                     write(IFLOG,*) &
                        'ln,tn,lm,tm,l3,mm,ltlt,nrcml ...', &
                         ln,tn,lm,tm,l3,mm,ltlt,nrcml(mm,l3+1)
                  end do
               end do
            end do
         end do
      end do
   end select
   do ln = 0,lmax
      itau (ln+1) = nref_us(ln)
   end do
   do ln = 0,lmax
      select case (is_val_type_us(ln))
      case (US90)
         ivanl(ln+1) = 1
      case (TM91)
         ivanl(ln+1) = 0
      end select
   end do
   eps(:,:) = 0.d0
   do lt = 1,num_ltx_us
      ln = ln_lt_us(lt)
      tn = tn_lt_us(lt)
      eps(ln+1,tn) = eref_us(lt)
   end do
   do il1 = 1,lmax+1
      write(IFGNCPP,20) il1,itau(il1),ivanl(il1)
      do tau1 = 1,itau(il1)
         if(ivanl(il1) >= 1) then
            write(IFGNCPP,21) il1,tau1,eps(il1,tau1),nrcl(il1,tau1),mopsw
            write(IFGNCPP,15) (co1(icoeff,il1,tau1),icoeff=0,mopsw)
            write(IFGNCPP,15) (phiv(ir,il1,tau1),ir=nrcl(il1,tau1)+1,nmesh)
         else
            write(IFGNCPP,21) il1,tau1,eps(il1,tau1),0,0
            write(IFGNCPP,15) (phiv(ir,il1,tau1),ir=1,nmesh)
            write(IFGNCPP,15) (vscr(ir,il1),ir=1,nmesh)
         end if
      end do
   end do
20 format(' ',3i4,'  :   il1, itau(il1),ivanl(il1) ')
21 format(' ',2i6,f24.16,2i6,' : il,tau,eps,nrcl,mopsw')

   qrsps(:,:,:) = 0.d0
   copsc(:,:,:) = 0.d0
   select case (is_pp_calc_class)
   case (NC)
      mopsc = 0
   case (US)
      mopsc = ncoeff_qps_us
      mm = 0
      do ln = 0,lmax
         if (ln == lloc) then
            cycle
         end if
         do tn = 1,nref_us(ln)
            do lm = ln,lmax
               if (lm == lloc) then
                  cycle
               end if
               if ((is_val_type_us(ln) == TM91).and. &
                   (is_val_type_us(lm) == TM91)) then
                  cycle
               end if
               tmin = 1
               if (ln == lm) then
                  tmin = tn
               end if
               do tm = tmin,nref_us(lm)
                  mm = mm+1
                  ltlt = ltlt_nm_us(ln,tn,lm,tm)
                  do l3 = abs(ln-lm),ln+lm,2
                     do icoeff = 0,mopsc
                        copsc(icoeff,mm,l3+1) = &
                           coeff_qps_us(icoeff,ltlt,l3)
                     end do
                     do ir = nrcut_qps_us(ltlt,l3)+1,nmesh
!                        qrsps(ir,mm,l3+1) = qps_us(ir,ltlt,l3) &   !AAS 2009
!                                          * rpos(ir)**(l3+2)
                        qrsps(ir,mm,l3+1) = qps_us(ir,ltlt,l3) &    !AAS 2009
                                          * rpos(ir)**(2)
                     end do
                     write(IFLOG,*) 'ln,tn,lm,tm,l3,mm,ltlt ...', &
                                     ln,tn,lm,tm,l3,mm,ltlt
                  end do
               end do
            end do
         end do
      end do
   end select
   mm = 0
   do il1 = 1,lmax+1
      if (iloc == il1) cycle
      do tau1 = 1,itau(il1)
      do il2 = il1,lmax+1
         if ((iloc == il2) .or. &
            ((ivanl(il1) == 0).and.(ivanl(il2) == 0))) cycle
            tmin = 1
         if (il1 == il2) tmin = tau1
         do tau2 = tmin,itau(il2)
            mm = mm+1
            do il3 = abs(il1-il2)+1,il1+il2-1,2
               !if (il3-1 > 4) cycle          !!! <---------- M.Okamoto 2003.04.23
               if (il3-1 > 4) cycle           !!! <---------- M.Okamoto 2005.01.31
               write(IFGNCPP,30) il1,tau1,il2,tau2,il3,nrcml(mm,il3),mopsc
               write(IFGNCPP,15) (copsc(icoeff,mm,il3),icoeff=0,mopsc)
               write(IFGNCPP,15) (qrsps(ir,mm,il3),ir=nrcml(mm,il3)+1,nmesh)
            end do
         end do
      end do
      end do
   end do
30 format(' ',5i3,i6,i4,' il1,tau1,il2,tau2,il3,nrcml,mopsc')

   rhpcr(:) = 0.d0
   coc  (:) = 0.d0
   select case (is_pcc)
   case (PCC)
      chgpc = 0.d0
      do ir = 1,nmesh
         if (rho_pcore(ir) * 4.d0*PI*rpos(ir)**2 < 1.d-99) then
            rhpcr(ir) = 0.d0
         else
            rhpcr(ir) = rho_pcore(ir) * 4.d0*PI*rpos(ir)**2
         end if
         chgpc = chgpc + rhpcr(ir) * wr(ir)
      end do
      do icoeff = 0,ncoeff_pcc
         coc(icoeff) = coeff_pcc(icoeff) * 4.d0*PI
      end do
   end select
   if (itpcc == 1) then
      write(IFGNCPP,40) chgpc, nr0_pcc, ncoeff_pcc
      write(IFGNCPP,15) (coc(icoeff),icoeff=0,ncoeff_pcc)
      write(IFGNCPP,15) (rhpcr(ir),ir=nr0_pcc+1,nmesh)
   end if
40 format(' ',f24.16,2i6,' : chgpc, nrc0, mopcc  ')

   close(IFGNCPP)
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   deallocate(nrcl,nrcml,ivanl,itau,vscr,rhvr,co1,phiv,eps,qrsps,&
      copsc,rhpcr,coc)
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
99 continue
   end subroutine write_gncpp

!=====================================================================
   subroutine write_gncpp2(ier)
!=====================================================================
!
!  ### CAUTION ### 2006.08.23 M.O.
!  Temporarily, tt = 1 for veff_ps()
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   
   character(7) :: xcname
   integer :: ival, iloc, itpcc, ir, ips, ishell, ll, lt, itpp, &
              icoeff, ln, tn, lm, tm, l3, tmin, ltlt, ispin, &
              mm, mmmax, mopsw, mopsc, il1, tau1, il2, tau2, il3
   integer :: n1, l1, t1, m1, n2, l2, t2, m2, ltmltm
   real(8) :: cca1, cca2, ccc1, chgpc
   integer,allocatable :: &
      nrcl(:,:), nrcml(:,:), ivanl(:), itau(:)
   real(8),allocatable :: &
      vscr(:,:), rhvr(:), co1(:,:,:), phiv(:,:,:), eps(:,:), &
      qrsps(:,:,:), copsc(:,:,:), rhpcr(:), coc(:), vscr2(:,:), &
      phia(:,:,:)
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   mmmax = max(ncoeff_phi_us,ncoeff_qps_us)
   allocate(nrcl(lmax+1,nref_max_us),nrcml(num_ltltx_us,l3_max_us+1),&
      ivanl(lmax+1),itau(lmax+1),vscr(nmesh,lmax+1),rhvr(nmesh),&
      co1(0:mmmax,lmax+1,l3_max_us+1),phiv(nmesh,lmax+1,nref_max_us),&
      eps(lmax+1,nref_max_us),qrsps(nmesh,num_ltltx_us,l3_max_us+1),&
      copsc(0:mmmax,num_ltltx_us,l3_max_us+1),rhpcr(nmesh),&
      coc(0:ncoeff_pcc),vscr2(nmesh,lmax+1),&
      phia(nmesh,lmax+1,nref_max_us))
      nrcl    = 0 ; nrcml    = 0 ; ivanl    = 0 ; itau     = 0
      vscr = 0.d0 ; rhvr  = 0.d0 ; co1   = 0.d0 ; phiv  = 0.d0
      eps  = 0.d0 ; qrsps = 0.d0 ; copsc = 0.d0 ; rhpcr = 0.d0
      coc  = 0.d0 ; vscr2 = 0.d0 ; phia  = 0.d0
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   
   open(IFGNCPP2,file=trim(gncpp2file),status='unknown')
   rewind(IFGNCPP2)
   
   write(IFLOG,*) '   Writing GNCPP2 -->',IFGNCPP2
   fval = fatom - felec_core
   zval = int(fval + 1.d-6)
   ival   = zval
   iloc   = lloc+1 
   select case (is_pcc)
   case (NONE)
      itpcc = 0
   case (PCC)
      itpcc = 1
   case (FCC)
      itpcc = 2
   end select
   if (is_with_ae /= 0) then
      itpp = -2
   else
      itpp = 2
   end if

   if (abs(fatom-dble(zatom)) < 1.d-6) then
      if (abs(fval-dble(ival)) < 1.d-5) then
         write(IFGNCPP2,60) zatom, ival, iloc, itpcc, itpp  !!!  GNCPP2
      else
         write(IFGNCPP2,61) zatom, fval, iloc, itpcc, itpp  !!!  GNCPP2
      end if
   else
      if (abs(fval-dble(ival)) < 1.d-5) then
         write(IFGNCPP2,62) fatom, ival, iloc, itpcc, itpp  !!!  GNCPP2
      else
         write(IFGNCPP2,63) fatom, fval, iloc, itpcc, itpp  !!!  GNCPP2
      end if
   end if
60 format(' ',5i4,         '  : zatom, ival, iloc, itpcc ')
61 format(' ',i4,f10.5,3i4,'  : zatom, fval, iloc, itpcc ')
62 format(' ',f10.5,4i4,   '  : fatom, ival, iloc, itpcc ')
63 format(' ',2f10.5,3i4,  '  : fatom, fval, iloc, itpcc ')

   select case (is_xc)
   case (LDAPZ81)
      xcname = 'ldapz81'
   case (LDAPW92_MOMO, LDAPW92_MOMO2, LDAPW92_GNCPP)
      xcname = 'ldapw91'
   case (GGAPW91_MOMO, GGAPW91_MOMO2, GGAPW91_F90, GGAPW91_F77)
      xcname = 'ggapw91'
   case (GGAPBE96_MOMO, GGAPBE96_MOMO2, GGAPBE96_GNCPP, GGAPBE96_KATO)
      xcname = 'ggapbe'
   case default
      write(IFLOG,*) '### ERROR ### xc-type'
      write(IFLOG,*) '   is_xc ...', is_xc
      ier = 1 ; go to 99
   end select
   write(IFGNCPP2,11) xcname
11 format(a7,'  : name ')

   cca1 = cc_a1(zatom)
   cca2 = cc_a2(zatom)
   ccc1 = cc_c1(zatom)
   write(IFGNCPP2,12) cca1,cca2,ccc1,1.d0-ccc1
12 format(' ',4f12.6,'  :   alp,cc')

   write(IFGNCPP2,13)           nmesh,  xh, rmax
13 format(' ',i6,2f12.6,'  :   nmesh,  xh, rmax')

   write(IFGNCPP2,14)
14 format('VALL')

   ispin = 1
   write(IFGNCPP2,15) (veff(ir,ispin,lmax_core),ir=1,nmesh)
15 format(3e25.17)

   vscr(:,:) = 0.d0
   vscr2(:,:) = 0.d0
   select case (is_pp_calc_class)
   case (NC)
      do ips = 1,nps
         ishell = ishell_ps(ips,1)
         ll = l_qnum(ishell)
         do ir = 1,nmesh                      
            vscr(ir,ll+1) = veff_ps(ir,ips,1) 
            vscr2(ir,ll+1) = vion_ps(ir,ips,1) 
         end do                               
      end do
   case (US)
      do lt = 1,num_ltx_us
         ips = ips_lt_us(lt)
         ln = ln_lt_us(lt)
         tn = tn_lt_us(lt)
         select case (is_val_type_us(ln))
         case (TM91)
            do ir = 1,nmesh
               vscr(ir,ln+1) = veff_ps(ir,ips,1)
               vscr2(ir,ln+1) = vion_ps(ir,ips,1)
            end do
         case (US90)
            do ir = 1,nmesh
               vscr(ir,ln+1) = 0.d0
               vscr2(ir,ln+1) = 0.d0
            end do
         end select
      end do
   end select
   if(iloc >= 5) then
      write(IFGNCPP2,15) (vloc_scr_sol(ir),ir=1,nmesh)
      write(IFGNCPP2,15) (vloc_ion_sol(ir),ir=1,nmesh)
   else
      write(IFGNCPP2,15) (vscr(ir,iloc),ir=1,nmesh)
      write(IFGNCPP2,15) (vscr2(ir,iloc),ir=1,nmesh)
   endif

   do ir = 1,nmesh
      rhvr(ir) = rho_sol(ir) * 4.d0*PI*rpos(ir)**2
   end do                                        
   write(IFGNCPP2,15) (rhvr(ir),ir=1,nmesh)

   if(lmax == 3) then
      write(IFGNCPP2,16)
   end if
16 format('F-STATE')

   co1 (:,:,:) = 0.d0
   phiv(:,:,:) = 0.d0
   select case (is_pp_calc_class)
   case (NC)
      mopsw = 0
      do lt = 1,num_ltx_us
         ln = ln_lt_us(lt)
         tn = tn_lt_us(lt)
         do ir=1,nmesh
            phia(ir,ln+1,tn) = rpsi_us(ir,lt)
            phiv(ir,ln+1,tn) = rphi_us(ir,lt)
         end do
      end do
   case (US)
      mopsw = ncoeff_phi_us
      do lt = 1,num_ltx_us
         ln = ln_lt_us(lt)
         tn = tn_lt_us(lt)
         ips = ips_lt_us(lt)
         select case (is_val_type_us(ln))
         case (TM91)
            do ir=1,nmesh
               phia(ir,ln+1,tn) = rpsi_us(ir,lt)
               phiv(ir,ln+1,tn) = rphi_us(ir,lt)
            end do            
         case (US90)                                
            do icoeff = 0,mopsw
               co1(icoeff,ln+1,tn) = coeff_phi_us(icoeff,lt)
            end do
            do ir=1,nmesh
               phia(ir,ln+1,tn) = rpsi_us(ir,lt)
               phiv(ir,ln+1,tn) = rphi_us(ir,lt)
            end do
         end select
      end do
   end select
   nrcl (:,:) = 0
   nrcml(:,:) = 0
   select case (is_pp_calc_class)
   case (NC)
   case (US)
      do ln = 0,lmax
         do tn = 1,nref_us(ln)
            lt = lt_n_us(ln,tn)
            nrcl(ln+1,tn) = nrcut_phi_us(lt)
         end do
      end do
      mm = 0
      do ln = 0,lmax
         if (ln == lloc) then
            cycle
         end if
         do tn = 1,nref_us(ln)
            do lm = ln,lmax
               if (lm == lloc) then
                  cycle
               end if
               if ((is_val_type_us(ln) == TM91).and. &
                   (is_val_type_us(lm) == TM91)) then
                  cycle
               end if
               tmin = 1
               if (ln == lm) then
                  tmin = tn
               end if
               do tm = tmin,nref_us(lm)
                  mm = mm+1
                  ltlt = ltlt_nm_us(ln,tn,lm,tm)
                  do l3 = abs(ln-lm),ln+lm,2
                     nrcml(mm,l3+1) = nrcut_qps_us(ltlt,l3)
                     write(IFLOG,*) &
                        'ln,tn,lm,tm,l3,mm,ltlt,nrcml ...', &
                         ln,tn,lm,tm,l3,mm,ltlt,nrcml(mm,l3+1)
                  end do
               end do
            end do
         end do
      end do
   end select
   do ln = 0,lmax
      itau (ln+1) = nref_us(ln)
   end do
   do ln = 0,lmax
      select case (is_val_type_us(ln))
      case (US90)
         ivanl(ln+1) = 1
      case (TM91)
         ivanl(ln+1) = 0
      end select
   end do
   eps(:,:) = 0.d0
   do lt = 1,num_ltx_us
      ln = ln_lt_us(lt)
      tn = tn_lt_us(lt)
      eps(ln+1,tn) = eref_us(lt)
   end do
   do il1 = 1,lmax+1
      write(IFGNCPP2,20) il1,itau(il1),ivanl(il1)
      do tau1 = 1,itau(il1)
         if(ivanl(il1) >= 1) then
            write(IFGNCPP2,21) il1,tau1,eps(il1,tau1),nrcl(il1,tau1),mopsw
            if (is_with_ae /= 0) then
            write(IFGNCPP2,15) (phia(ir,il1,tau1),ir=1,nmesh)
            end if
            write(IFGNCPP2,15) (co1(icoeff,il1,tau1),icoeff=0,mopsw)
            write(IFGNCPP2,15) (phiv(ir,il1,tau1),ir=nrcl(il1,tau1)+1,nmesh)
         else
            write(IFGNCPP2,21) il1,tau1,eps(il1,tau1),0,0
            if (is_with_ae /= 0) then
            write(IFGNCPP2,15) (phia(ir,il1,tau1),ir=1,nmesh)
            end if
            write(IFGNCPP2,15) (phiv(ir,il1,tau1),ir=1,nmesh)
            write(IFGNCPP2,15) (vscr2(ir,il1),ir=1,nmesh)
         end if
      end do
   end do
20 format(' ',3i4,'  :   il1, itau(il1),ivanl(il1) ')
21 format(' ',2i6,f24.16,2i6,' : il,tau,eps,nrcl,mopsw')

   qrsps(:,:,:) = 0.d0
   copsc(:,:,:) = 0.d0
   select case (is_pp_calc_class)
   case (NC)
      mopsc = 0
   case (US)
      mopsc = ncoeff_qps_us
      mm = 0
      do ln = 0,lmax
         if (ln == lloc) then
            cycle
         end if
         do tn = 1,nref_us(ln)
            do lm = ln,lmax
               if (lm == lloc) then
                  cycle
               end if
               if ((is_val_type_us(ln) == TM91).and. &
                   (is_val_type_us(lm) == TM91)) then
                  cycle
               end if
               tmin = 1
               if (ln == lm) then
                  tmin = tn
               end if
               do tm = tmin,nref_us(lm)
                  mm = mm+1
                  ltlt = ltlt_nm_us(ln,tn,lm,tm)
                  do l3 = abs(ln-lm),ln+lm,2
                     do icoeff = 0,mopsc
                        copsc(icoeff,mm,l3+1) = &
                           coeff_qps_us(icoeff,ltlt,l3)
                     end do
                     do ir = nrcut_qps_us(ltlt,l3)+1,nmesh
!                        qrsps(ir,mm,l3+1) = qps_us(ir,ltlt,l3) &   !AAS 2009
!                                          * rpos(ir)**(l3+2)
                        qrsps(ir,mm,l3+1) = qps_us(ir,ltlt,l3) &    !AAS 2009
                                          * rpos(ir)**(2)
                     end do
                     write(IFLOG,*) 'ln,tn,lm,tm,l3,mm,ltlt ...', &
                                     ln,tn,lm,tm,l3,mm,ltlt
                  end do
               end do
            end do
         end do
      end do
   end select
   mm = 0
   do il1 = 1,lmax+1
      if (iloc == il1) cycle
      do tau1 = 1,itau(il1)
      do il2 = il1,lmax+1
         if ((iloc == il2) .or. &
            ((ivanl(il1) == 0).and.(ivanl(il2) == 0))) cycle
            tmin = 1
         if (il1 == il2) tmin = tau1
         do tau2 = tmin,itau(il2)
            mm = mm+1
            do il3 = abs(il1-il2)+1,il1+il2-1,2
               !if (il3-1 > 4) cycle          !!! <---------- M.Okamoto 2003.04.23
               if (il3-1 > 4) cycle           !!! <---------- M.Okamoto 2005.01.31
               write(IFGNCPP2,30) il1,tau1,il2,tau2,il3,nrcml(mm,il3),mopsc
               write(IFGNCPP2,15) (copsc(icoeff,mm,il3),icoeff=0,mopsc)
               write(IFGNCPP2,15) (qrsps(ir,mm,il3),ir=nrcml(mm,il3)+1,nmesh)
            end do
         end do
      end do
      end do
   end do
30 format(' ',5i3,i6,i4,' il1,tau1,il2,tau2,il3,nrcml,mopsc')

   rhpcr(:) = 0.d0
   coc  (:) = 0.d0
   select case (is_pcc)
   case (PCC)
      chgpc = 0.d0
      do ir = 1,nmesh
         if (rho_pcore(ir) * 4.d0*PI*rpos(ir)**2 < 1.d-99) then
            rhpcr(ir) = 0.d0
         else
            rhpcr(ir) = rho_pcore(ir) * 4.d0*PI*rpos(ir)**2
         end if
         chgpc = chgpc + rhpcr(ir) * wr(ir)
      end do
      do icoeff = 0,ncoeff_pcc
         coc(icoeff) = coeff_pcc(icoeff) * 4.d0*PI
      end do
   end select
   if (itpcc == 1) then
      write(IFGNCPP2,40) chgpc, nr0_pcc, ncoeff_pcc
      write(IFGNCPP2,15) (coc(icoeff),icoeff=0,ncoeff_pcc)
      write(IFGNCPP2,15) (rhpcr(ir),ir=nr0_pcc+1,nmesh)
   end if
40 format(' ',f24.16,2i6,' : chgpc, nrc0, mopcc  ')

if(is_with_core /= 0) then
   write(IFGNCPP2,50)
50 format('CORE-CHARGE')
   rhpcr(:) = 0.d0
   chgpc = 0.d0
   do ir = 1,nmesh
      if (rho_core(ir) * 4.d0*PI*rpos(ir)**2 < 1.d-99) then
         rhpcr(ir) = 0.d0
      else
         rhpcr(ir) = rho_core(ir) * 4.d0*PI*rpos(ir)**2
      end if
      chgpc = chgpc + rhpcr(ir) * wr(ir)
   end do
51 format(' ',f24.16,' : chg_core')
   write(IFGNCPP2,51) chgpc
   write(IFGNCPP2,15) (rhpcr(ir),ir=1,nmesh)
end if

if(is_with_dipole /= 0) then
   write(IFGNCPP2,52)
52 format('DIPOLE')
   write(IFGNCPP2,*) num_dipole_lm_us/2
   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(IFGNCPP2,53) n1,l1,t1,m1,n2,l2,t2,m2, &
      dipole_dx_us(ltmltm),dipole_dy_us(ltmltm),dipole_dz_us(ltmltm), &
      phase_ylm(l1,m1),phase_ylm(l2,m2)
   end do
53 format(8i3,3e18.10,2i3)
end if

   close(IFGNCPP2)
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   deallocate(nrcl,nrcml,ivanl,itau,vscr,rhvr,co1,phiv,eps,qrsps,&
      copsc,rhpcr,coc,vscr2,phia)
  !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
99 continue
   end subroutine write_gncpp2

!=====================================================================
   subroutine write_ciaopp(ier)
!=====================================================================
!
!  M. Okamoto
!
!---------------------------------------------------------------------
   use parameters
   implicit none
   integer,intent(out) :: ier
   character(10) :: xc_name
   character(1)  :: ch_ln, ch_tn, ch_lm, ch_tm, ch_l3, &
                    fn_label_orbital, fn_label_orbital_capital
   character(2)  :: val_type_tmp, ch2
   character(3)  :: ch3
   character(5)  :: ch5
   character(6)  :: ch6
   integer :: ir, nn, ll, tt, lt, ln, tn, lm, tm, l3, nrc, icoeff, &
              n1, l1, t1, m1, n2, l2, t2, m2, ltmltm, ltlt, ltt, &
              ips, nsum, ishell, lshell, ie, nref, lps, iss, lss, ig
   real(8) :: rcut, eref, rho_pcore_sum
   real(8),allocatable :: array_tmp(:)
  !++++++++++++++++++++++++++++++++++++++++++++++
   allocate(array_tmp(nmesh)) ; array_tmp = 0.d0
  !++++++++++++++++++++++++++++++++++++++++++++++
   open(IFCIAOPP,file=trim(ciaoppfile),status='unknown')
   rewind(IFCIAOPP)
   write(IFLOG,*) '   Writing CIAOPP -->',IFCIAOPP
   call date_time(day_now)
   call write_title(IFCIAOPP,day_now)
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a16)') '### Atomic label'
   write(IFCIAOPP,'((a12,8x),a2,7x,a20)') &
      'atomic_label', atom_label(zatom), atom_name(zatom)
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a47)') '### Atomic charge : Z, Za, Zc, Zv, (Ne, Nc, Nv)'
   write(IFCIAOPP,'((a13,6x),(i3,4x),3f11.5)') &
      'atomic_charge', zatom, fatom, fcore, fval
   write(IFCIAOPP,'((13x,6x),(3x,4x),3f11.5)') &
      felec, felec_core, felec_val
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a34)') '### Exchange-correlation potential'
   select case (is_xc)
   case (LDAPZ81)
      xc_name = 'ldapz81'
   case (LDAPW92_MOMO, LDAPW92_MOMO2, LDAPW92_GNCPP)
      xc_name = 'ldapw92'
   case (GGAPW91_MOMO, GGAPW91_MOMO2, GGAPW91_F90, GGAPW91_F77)
      xc_name = 'ggapw91'
   case (GGAPBE96_MOMO, GGAPBE96_MOMO2, GGAPBE96_GNCPP, GGAPBE96_KATO)
      xc_name = 'ggapbe'
   case default
      write(IFLOG,*) '### ERROR ### xc_type'
      write(IFLOG,*) '   is_xc ...', is_xc
      ier = 1 ; go to 99
   end select
   write(IFCIAOPP,'((a12,8x),a7,5x,a5)') &
      'xc_potential', xc_name, xc_approx
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a30)') '### r-Mesh : Nmesh, rmin, rmax'
   write(IFCIAOPP,'(a5,5x,a11)') 'rmesh','logarithmic'
   write(IFCIAOPP,'(i10,2(1pe25.15))') nmesh, rmin, rmax
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a30)') '### g-Mesh : Nmesh, gmin, gmax'
   write(IFCIAOPP,'(a5,5x,a6)') 'gmesh','linear'
   write(IFCIAOPP,'(i10,2(1pe25.15))') ng_mesh, gmin, gmax
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a34)') '### All-electron SCF energy levels'
   select case (is_calc)
   case (NONREL)
      write(IFCIAOPP,'(a3,5x,a16)') '#AE','non_relativistic'
   case (SREL)
      write(IFCIAOPP,'(a3,5x,a19)') '#AE','scalar_relativistic'
   end select
   write(IFCIAOPP,21) &
      'symm','Energy (Ha)','Energy (eV)','nocc','focc'
   do ishell = 1,nshell
      lshell = list_shell(ishell)
      if (is_solve(lshell) == NO) then
         cycle
      end if
      nn = n_qnum(lshell) ; ll = l_qnum(lshell)
      write(IFCIAOPP,22) &
         state(lshell)(1:2),engy(lshell),engy(lshell)*HARTREE, &
         nocc(lshell),focc(lshell)
   end do
   write(IFCIAOPP,23) 'Total number of electrons',felec
21 format('#AE',(3x,a4),2(9x,a11),(2x,a4),(6x,a4))
22 format('#AE',(4x,a2,1x),2(f20.10),i6,f10.5)
23 format('#AE',2x,a25,26x,f10.5)
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a29)') '### All-electron total energy'
   write(IFCIAOPP,24) 'Energy (Ha)','Energy (eV)'
   if (is_calc == NONREL) then
   write(IFCIAOPP,25) 'Ekin  ',ekin_sum1,ekin_sum1*HARTREE
   else
   write(IFCIAOPP,25) 'Ekin  ',ekin_sum ,ekin_sum*HARTREE
   end if
   write(IFCIAOPP,25) 'Eion  ',eion_sum ,eion_sum *HARTREE
   write(IFCIAOPP,25) 'Eh    ',eh_sum   ,eh_sum   *HARTREE
   write(IFCIAOPP,25) 'Exc   ',exc_sum  ,exc_sum  *HARTREE
   if (is_calc == NONREL) then
   write(IFCIAOPP,25) 'Etot  ',etot_sum1,etot_sum1*HARTREE
   else
   write(IFCIAOPP,25) 'Etot  ',etot_sum ,etot_sum *HARTREE
   end if
24 format('#AE',2x,6x,2(9x,a11))
25 format('#AE',2x,a6,2(f20.10))
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a32)') '### Cutoff WF : rc[n] & dEref[n]'
   write(IFCIAOPP,'(a9)') 'cutoff_wf'
   write(IFCIAOPP,'(16i5)') nps, (nref_ps(ips),ips=1,nps)
   do ips = 1,nps
      nn = n_val_label_ps(ips) ; ll = l_val_label_ps(ips)
      select case (is_val_type_ps(ips))
      case (TM91)
         val_type_tmp = 'NC'
      case (US90)
         val_type_tmp = 'US'
      end select
      write(ch2,'(i1,a1)') nn, fn_label_orbital(ll)
      write(IFCIAOPP,'(5x,a2,(10x,a2),i12)') ch2,val_type_tmp,nref_ps(ips)
      do tt = 1,nref_ps(ips)
         write(IFCIAOPP,'(5x,2f12.5)') &
            rcut_phi_ps(ips,tt),deref_ps(ips,tt)
      end do
   end do
if (is_pp_calc_class == US) then
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a22)') '### Cutoff energy [US]'
   write(IFCIAOPP,36) 'Gcut (au)', 'Ecut (Ha)', 'Ecut (eV)'
   write(IFCIAOPP,37) 'WaveFn',gmin_phi_us, &
      0.5d0*gmin_phi_us**2,0.5d0*gmin_phi_us**2*HARTREE
   write(IFCIAOPP,37) 'Charge',gmin_qps_us, &
      0.5d0*gmin_qps_us**2,0.5d0*gmin_qps_us**2*HARTREE
36 format('#PP',2x,6x,3(11x,a9))
37 format('#PP',2x,a6,3(f20.10))
end if
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a33)') '### Pseudopotential energy levels'
   write(IFCIAOPP,31) 'symm', &
                   'Energy (Ha)','Energy (eV)','nocc','focc'
   do ips = 1,nps
      lps = list_sol(ips)
      lshell = ishell_ps(lps,1)
      if (is_solve(lshell) == 0) then
         cycle
      end if
      nn = n_qnum(lshell)
      ll = l_qnum(lshell)
      write(IFCIAOPP,32) state(lshell)(1:2), &
         engy_sol(lps),engy_sol(lps)*HARTREE,nocc(lshell),focc_sol(lps)
   end do
   write(IFCIAOPP,33) 'Total number of electrons',felec_sol
31 format('#PP',(3x,a4),2(9x,a11),(2x,a4),(6x,a4))
32 format('#PP',(4x,a2,1x),2(f20.10),i6,f10.5)
33 format('#PP',2x,a25,26x,f10.5)
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a31)') '### Psedopotential total energy'
   write(IFCIAOPP,34) 'Energy (Ha)','Energy (eV)'
   write(IFCIAOPP,35) 'Ekin     ',ekin_sum1_sol   ,ekin_sum1_sol   *HARTREE
   write(IFCIAOPP,35) 'Eion[NL] ',enl_ion_sum_sol ,enl_ion_sum_sol *HARTREE
   write(IFCIAOPP,35) 'Eion[LOC]',eloc_ion_sum_sol,eloc_ion_sum_sol*HARTREE
   write(IFCIAOPP,35) 'Eh       ',eh_sum_sol      ,eh_sum_sol      *HARTREE
   write(IFCIAOPP,35) 'Exc      ',exc_sum_sol     ,exc_sum_sol     *HARTREE
   write(IFCIAOPP,35) 'Epcc     ',excpc_sum_sol   ,excpc_sum_sol   *HARTREE
   write(IFCIAOPP,35) 'Etot     ',etot_sum1_sol   ,etot_sum1_sol   *HARTREE
34 format('#PP',2x,9x,2(9x,a11))
35 format('#PP',2x,a9,2(f20.10))
if (is_solve_pp_spin /= NO) then
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a50)') &
      '### Pseudopotential energy levels [Spin polarized]'
   write(IFCIAOPP,41) 'symm','s', &
                   'Energy (Ha)','Energy (eV)','nocc','focc'
   do iss = 1,nss
      lss = list_ss(iss)
      lshell = ishell_ss(lss)
      if (is_solve_ss(lss) == 0) then
         cycle
      end if
      nn = n_qnum(lshell)
      ll = l_qnum(lshell)
      write(IFCIAOPP,42) state(lshell)(1:2),spin_label_ss(lss)(1:1), &
         engy_ss(lss),engy_ss(lss)*HARTREE,nocc_ss(lss),focc_ss(lss)
   end do
   write(IFCIAOPP,43) 'Number of electrons (+)',felec1_ss
   write(IFCIAOPP,43) '                    (-)',felec2_ss
41 format('#SS',(3x,a4),(4x,a1),2(9x,a11),(2x,a4),(6x,a4))
42 format('#SS',(4x,a2,1x),(4x,a1),2(f20.10),i6,f10.5)
43 format('#SS',2x,a23,33x,f10.5)
end if
if (is_solve_pp_spin /= NO) then
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a48)') '### Psedopotential total energy [Spin polarized]'
   write(IFCIAOPP,44) 'Energy (Ha)','Energy (eV)'
   write(IFCIAOPP,45) 'Ekin     ',ekin_sum1_ss   ,ekin_sum1_ss   *HARTREE
   write(IFCIAOPP,45) 'Eion[NL] ',enl_ion_sum_ss ,enl_ion_sum_ss *HARTREE
   write(IFCIAOPP,45) 'Eion[LOC]',eloc_ion_sum_ss,eloc_ion_sum_ss*HARTREE
   write(IFCIAOPP,45) 'Eh       ',eh_sum_ss      ,eh_sum_ss      *HARTREE
   write(IFCIAOPP,45) 'Exc      ',exc_sum_ss     ,exc_sum_ss     *HARTREE
   write(IFCIAOPP,45) 'Epcc     ',excpc_sum_ss   ,excpc_sum_ss   *HARTREE
   write(IFCIAOPP,45) 'Etot     ',etot_sum1_ss   ,etot_sum1_ss   *HARTREE
44 format('#SS',2x,9x,2(9x,a11))
45 format('#SS',2x,a9,2(f20.10))
end if
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a49)') '### All-electron screened potential : Vae[scr](r)'
   write(IFCIAOPP,'(a16)') 'ae_scr_potential'
   write(IFCIAOPP,10) (veff(ir,1,lmax_core),ir=1,nmesh)
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a41)') '### BHS potential parameters : a1, a2, c1'
   write(IFCIAOPP,'(a63)') '#  Vbhs(r) := -Zv/r * [c1*erf{sqrt(a1*r)} + c2*erf{sqrt(a2*r)}]'
   write(IFCIAOPP,'(a15)') '#  c2 := 1 - c1'
   write(IFCIAOPP,'(a13)') 'bhs_potential'
   write(IFCIAOPP,'(3f20.10)') cc_a1(zatom), cc_a2(zatom), cc_c1(zatom)
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a43)') '### Screened local potential : Vloc[scr](r)'
   write(IFCIAOPP,'(a19)') 'scr_local_potential'
   write(IFCIAOPP,'(i10)') nrcut_max_us
   write(IFCIAOPP,10) (vloc_scr_sol(ir),ir=1,nrcut_max_us)
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a40)') '### Ionic local potential : Vloc[ion](r)'
   select case (lloc)
   case (0)
      write(IFCIAOPP,'(a19,6x,a7,2x,a1)') 'ion_local_potential','orbital','s'
   case (1)
      write(IFCIAOPP,'(a19,6x,a7,2x,a1)') 'ion_local_potential','orbital','p'
   case (2)
      write(IFCIAOPP,'(a19,6x,a7,2x,a1)') 'ion_local_potential','orbital','d'
   case (3)
      write(IFCIAOPP,'(a19,6x,a7,2x,a1)') 'ion_local_potential','orbital','f'
   case (5)
      write(IFCIAOPP,'(a19,6x,a7,2x,a3)') 'ion_local_potential','special','bhs'
   case (6)
      write(IFCIAOPP,'(a19,6x,a7,2x,a10)') 'ion_local_potential','special','polynomial'
   end select
   write(IFCIAOPP,10) (vloc_ion_sol(ir),ir=1,nmesh)
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a30)') '### Valence charge : r*r*nv(r)'
   write(IFCIAOPP,'(a19)') 'valence_charge_rrnv'
   do ir = 1,nmesh
      if (abs(rpos(ir)**2*rho_sol(ir)) < 1.d-99) then
         array_tmp(ir) = 0.d0
      else
         array_tmp(ir) = rpos(ir)**2*rho_sol(ir)
      end if
   end do
   write(IFCIAOPP,10) (array_tmp(ir),ir=1,nmesh)
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a27)') '### Core charge : r*r*nc(r)'
   write(IFCIAOPP,'(a16)') 'core_charge_rrnc'
   do ir = 1,nmesh
      if (abs(rpos(ir)**2*rho_core(ir)) < 1.d-99) then
         array_tmp(ir) = 0.d0
      else
         array_tmp(ir) = rpos(ir)**2*rho_core(ir)
      end if
   end do
   write(IFCIAOPP,10) (array_tmp(ir),ir=1,nmesh)
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a48)') '### All-electron SCF wavefunctions : r*psi[n](r)'
   write(IFCIAOPP,'(a21)') 'ae_wave_function_rpsi'
   write(IFCIAOPP,'(i10)') num_ltx_us
   write(IFCIAOPP,'(1x,3(2x,a1),2(1x,a2),2x,(4x,3x),(10x,a7,3x))') &
      'n','l','t','ln','tn','Eref[n]'
   do lt = 1,num_ltx_us
      nn  = n_lt_us(lt)  ; ll  = l_lt_us(lt)  ; tt   = t_lt_us(lt)
      ln  = ln_lt_us(lt) ; tn  = tn_lt_us(lt) ; eref = eref_us(lt)
      ch_ln = fn_label_orbital(ll)
      write(ch_tn,'(i1)') tn
      ch3(1:3) = '_'//ch_ln(1:1)//ch_tn(1:1)
      write(IFCIAOPP,'(1x,5i3,2x,(a4,a3),f20.10)') &
         nn,ll,tt,ln,tn,'rpsi',ch3,eref
   end do
   do lt = 1,num_ltx_us
      nn  = n_lt_us(lt)  ; ll  = l_lt_us(lt)  ; tt   = t_lt_us(lt)
      ln  = ln_lt_us(lt) ; tn  = tn_lt_us(lt) ; eref = eref_us(lt)
      ch_ln = fn_label_orbital(ll)
      write(ch_tn,'(i1)') tn
      ch3(1:3) = '_'//ch_ln(1:1)//ch_tn(1:1)
      write(IFCIAOPP,'(1x,a34,5i3,2x,a4,a3)') &
         'r*psi[n](r): n = (n,l,t,ln,tn) -->',nn,ll,tt,ln,tn,'rpsi',ch3
      write(IFCIAOPP,20) nn,ll,tt,ln,tn,eref
      do ir = 1,nmesh
         if (abs(rpsi_us(ir,lt)) < 1.d-99) then
            array_tmp(ir) = 0.d0
         else
            array_tmp(ir) = rpsi_us(ir,lt)
         end if
      end do
      write(IFCIAOPP,10) (array_tmp(ir),ir=1,nmesh)
   end do
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a38)') '### Pseudo-wavefunctions : r*phi[n](r)'
   write(IFCIAOPP,'(a41)') '#  For r < rc[n], phi[n](r) is explicitly'
   write(IFCIAOPP,'(a57)') '#    NC ... phi[n](r) = r^ln * exp(c0+c1*r^2+...+cN*r^2N)'
   write(IFCIAOPP,'(a54)') '#    US ... phi[n](r) = r^ln * (c0+c1*r^2+...+cN*r^2N)'
   write(IFCIAOPP,'(a39)') '#  For r > rc[n], phi[n](r) = psi[n](r)'
   write(IFCIAOPP,'(a21)') 'pp_wave_function_rphi'
   write(IFCIAOPP,'(i10)') num_ltx_us
   write(IFCIAOPP,'(1x,3(2x,a1),2(1x,a2),2x,(4x,3x),(2x,2x),(8x,a7,3x),(8x,a2,8x),(7x,a3))') &
      'n','l','t','ln','tn','Eref[n]','rc','nrc'
   do lt = 1,num_ltx_us
      nn  = n_lt_us(lt)  ; ll  = l_lt_us(lt)  ; tt   = t_lt_us(lt)
      ln  = ln_lt_us(lt) ; tn  = tn_lt_us(lt) ; eref = eref_us(lt)
      nrc = nrcut_phi_us(lt)
      rcut = rpos(nrc)
      ips = ips_lt_us(lt)
      ch_ln = fn_label_orbital(ll)
      select case (is_val_type_ps(ips))
      case (TM91)
         val_type_tmp = 'NC'
      case (US90)
         val_type_tmp = 'US'
      end select
      write(ch_tn,'(i1)') tn
      ch3(1:3) = '_'//ch_ln(1:1)//ch_tn(1:1)
      write(IFCIAOPP,'(1x,5i3,2x,(a4,a3),2x,a2,2f18.10,i10)') &
         nn,ll,tt,ln,tn,'rphi',ch3,val_type_tmp,eref,rcut,nrc
   end do
   do lt = 1,num_ltx_us
      nn  = n_lt_us(lt)  ; ll  = l_lt_us(lt)  ; tt   = t_lt_us(lt)
      ln  = ln_lt_us(lt) ; tn  = tn_lt_us(lt) ; eref = eref_us(lt)
      nrc = nrcut_phi_us(lt)
      rcut = rpos(nrc)
      ips = ips_lt_us(lt)
      ch_ln = fn_label_orbital(ll)
      write(ch_tn,'(i1)') tn
      ch3(1:3) = '_'//ch_ln(1:1)//ch_tn(1:1)
      write(IFCIAOPP,'(1x,a34,5i3,2x,a4,a3)') &
         'r*phi[n](r): n = (n,l,t,ln,tn) -->',nn,ll,tt,ln,tn,'rphi',ch3
      select case (is_val_type_ps(ips))
      case (TM91)
         write(IFCIAOPP,19) nn,ll,tt,ln,tn,'NC',nrc,ncoeff_phi_tm
         write(IFCIAOPP,10) (coeff_phi_tm(icoeff,ips,1),icoeff=0,ncoeff_phi_tm)
      case (US90)
         write(IFCIAOPP,19) nn,ll,tt,ln,tn,'US',nrc,ncoeff_phi_us
         write(IFCIAOPP,10) (coeff_phi_us(icoeff,lt),icoeff=0,ncoeff_phi_us)
      end select
   end do
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a42)') '### Separable potential : q[nm] & Dion[nm]'
   write(IFCIAOPP,'(a64)') '#  q[nm]    := <psi[n]|psi[m]> - <phi[n]|phi[m]> = q[l,tn,tm]   '
   write(IFCIAOPP,'(a64)') '#  Dion[nm] := D[nm] - <Vloc|Q[nm]>              = Dion[l,tn,tm]'
   write(IFCIAOPP,'(a64)') '#  D[nm]    := B[nm] + E[m]*q[nm]                = D[l,tn,tm]   '
   write(IFCIAOPP,'(a64)') '#  B[nm]    := <phi[n]|chi[m]>                   = B[l,tn,tm]   '
   write(IFCIAOPP,'(a19)') 'separable_potential'
   write(IFCIAOPP,'(i10)') num_lttx_us
   write(IFCIAOPP,'(1x,(1x,a1,2x,a2,2x,a2),(8x,a5,12x),(8x,a8,9x))') &
      'l','tn','tm','q[nm]','Dion[nm]'
   do ltt = 1,num_lttx_us
      ll = l_ltt_us(ltt) ; tn = tn_ltt_us(ltt) ; tm = tm_ltt_us(ltt)
      write(IFCIAOPP,'(1x,(i2,2x,i2,2x,i2),2(1pe25.15))') &
         ll,tn,tm,q_sum_us(ltt),dion_us(ltt)
   end do
   write(IFCIAOPP,'(1x,(1x,a1,2x,a2,2x,a2),(8x,a5,12x),(8x,a5,12x))') &
      'l','tn','tm','B[nm]','D[nm]'
   do ltt = 1,num_lttx_us
      ll = l_ltt_us(ltt) ; tn = tn_ltt_us(ltt) ; tm = tm_ltt_us(ltt)
      write(IFCIAOPP,'(1x,(i2,2x,i2,2x,i2),2(1pe25.15))') &
         ll,tn,tm,bmat_us(ltt),dmat_us(ltt)
   end do
   write(IFCIAOPP,'(1x,(1x,a1,2x,a2,2x,a2),(8x,a14,3x))') &
      'l','tn','tm','<Vloc|Qps[nm]>'
   do ltt = 1,num_lttx_us
      ll = l_ltt_us(ltt) ; tn = tn_ltt_us(ltt) ; tm = tm_ltt_us(ltt)
      write(IFCIAOPP,'(1x,(i2,2x,i2,2x,i2),2(1pe25.15))') &
         ll,tn,tm,vlocqps_us(ltt)
   end do
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a29)') '### Projectors : r*beta[n](r)'
   write(IFCIAOPP,'(a15)') 'projector_rbeta'
   write(IFCIAOPP,'(i10)') num_ltx_us
   write(IFCIAOPP,'(1x,3(2x,a1),2(1x,a2),2x,(5x,3x),2x,2x,(8x,a7,3x))') &
      'n','l','t','ln','tn','Eref[n]'
   do lt = 1,num_ltx_us
      nn  = n_lt_us(lt)  ; ll  = l_lt_us(lt)  ; tt   = t_lt_us(lt)
      ln  = ln_lt_us(lt) ; tn  = tn_lt_us(lt) ; eref = eref_us(lt)
      nrc = nmesh
      ips = ips_lt_us(lt)
      select case (is_val_type_ps(ips))
      case (TM91)
         val_type_tmp = 'NC'
      case (US90)
         val_type_tmp = 'US'
      end select
      ch_ln = fn_label_orbital(ll)
      write(ch_tn,'(i1)') tn
      ch3(1:3) = '_'//ch_ln(1:1)//ch_tn(1:1)
      write(IFCIAOPP,'(1x,5i3,2x,(a5,a3),2x,a2,f18.10)') &
         nn,ll,tt,ln,tn,'rbeta',ch3,val_type_tmp,eref
   end do
   do lt = 1,num_ltx_us
      nn  = n_lt_us(lt)  ; ll  = l_lt_us(lt)  ; tt   = t_lt_us(lt)
      ln  = ln_lt_us(lt) ; tn  = tn_lt_us(lt) ; eref = eref_us(lt)
      nrc = nmesh
      ips = ips_lt_us(lt)
      select case (is_val_type_ps(ips))
      case (TM91)
         val_type_tmp = 'NC'
      case (US90)
         val_type_tmp = 'US'
      end select
      ch_ln = fn_label_orbital(ll)
      write(ch_tn,'(i1)') tn
      ch3(1:3) = '_'//ch_ln(1:1)//ch_tn(1:1)
      write(IFCIAOPP,'(1x,a35,5i3,2x,a5,a3)') &
         'r*beta[n](r): n = (n,l,t,ln,tn) -->',nn,ll,tt,ln,tn,'rbeta',ch3
      write(IFCIAOPP,19) nn,ll,tt,ln,tn,val_type_tmp,nrc
      write(IFCIAOPP,10) (rbeta_us(ir,lt),ir=1,nrc)
   end do
if (is_pp_calc_class == US) then
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a36)') '### Deficit charge : r*r*Qps[nmL](r)'
   write(IFCIAOPP,'(a53)') '#  Qps[nm](rvec) = sum_{LM} c[LMnm] Y[LM] Qps[nmL](r)'
   write(IFCIAOPP,'(a50)') '#  Q[nm](rvec)   = sum_{LM} c[LMnm] Y[LM] Q[nm](r)'
   write(IFCIAOPP,'(a41)') '#  Y[n] Y[m]     = sum_{LM} c[LMnm] Y[LM]'
   write(IFCIAOPP,'(a28)') '#  Qps[nmL](r) is explicitly'
   write(IFCIAOPP,'(a61)') '#    for r < rin, Qps[nmL](r) = r^L * (c0+c1*r^2+...+cN*r^2N)'
   write(IFCIAOPP,'(a40)') '#    for r > rin, Qps[nmL](r) = Q[nm](r)'
   select case (is_deficit_type)
   case (POLYNOMIAL)
      write(IFCIAOPP,'((a20,5x),(a10))') 'deficit_charge_rrqps','polynomial'
      nsum = 0
      do ltlt = 1,num_ltlt_us
         ln = ln_ltlt_us(ltlt) ; lm = lm_ltlt_us(ltlt)
         do l3 = abs(ln-lm),ln+lm,2
            nsum = nsum + 1
         end do
      end do
      write(IFCIAOPP,'(2i10)') nsum, num_ltlt_us
      write(IFCIAOPP,'(1x,4(1x,a2),(2x,a1),2x,(6x,6x),(10x,a2,8x),(7x,a3))') &
         'ln','tn','lm','tm','L','rc','nrc'
      do ltlt = 1,num_ltlt_us
         ln = ln_ltlt_us(ltlt) ; tn = tn_ltlt_us(ltlt)
         lm = lm_ltlt_us(ltlt) ; tm = tm_ltlt_us(ltlt)
         ch_ln = fn_label_orbital(ln) ; ch_lm = fn_label_orbital(lm)
         write(ch_tn,'(i1)') tn
         write(ch_tm,'(i1)') tm
         ch5(1:5) = '_'//ch_ln(1:1)//ch_tn(1:1) &
                       //ch_lm(1:1)//ch_tm(1:1)
         do l3 = abs(ln-lm),ln+lm,2
            nrc = nrcut_qps_us(ltlt,l3)
            ch_l3 = fn_label_orbital_capital(l3)
            ch6(1:6) = ch5(1:5)//ch_l3(1:1)
            write(IFCIAOPP,'(1x,5i3,2x,(a6,a6),f20.10,i10)') &
               ln,tn,lm,tm,l3,'rr_qps',ch6, &
               rcut_qps_us(ltlt,l3),nrcut_qps_us(ltlt,l3)
         end do
      end do
      do ltlt = 1,num_ltlt_us
         ln = ln_ltlt_us(ltlt) ; tn = tn_ltlt_us(ltlt)
         lm = lm_ltlt_us(ltlt) ; tm = tm_ltlt_us(ltlt)
         ch_ln = fn_label_orbital(ln) ; ch_lm = fn_label_orbital(lm)
         write(ch_tn,'(i1)') tn
         write(ch_tm,'(i1)') tm
         ch5(1:5) = '_'//ch_ln(1:1)//ch_tn(1:1) &
                       //ch_lm(1:1)//ch_tm(1:1)
         do l3 = abs(ln-lm),ln+lm,2
            nrc = nrcut_qps_us(ltlt,l3)
            ch_l3 = fn_label_orbital_capital(l3)
            ch6(1:6) = ch5(1:5)//ch_l3(1:1)
            write(IFCIAOPP,'(1x,a42,5i3,2x,a6,a6)') &
               'r*r*Qps[nmL](r): nmL = (ln,tn,lm,tm,L) -->', &
               ln,tn,lm,tm,l3,'rr_qps',ch6
            write(IFCIAOPP,'(5i3,i6,i4)') &
               ln,tn,lm,tm,l3,nrc,ncoeff_qps_us
            write(IFCIAOPP,10) &
               (coeff_qps_us(icoeff,ltlt,l3),icoeff=0,ncoeff_qps_us)
            write(IFCIAOPP,10) &
               (rpos(ir)**2*qps_us(ir,ltlt,l3),ir=nrc+1,nmesh)
         end do
      end do
   case (SBESSEL)
      write(IFCIAOPP,'((a20,5x),a16)') 'deficit_charge_rrqps','spherical_bessel'
      nsum = 0
      do ltlt = 1,num_ltlt_us
         ln = ln_ltlt_us(ltlt)
         lm = lm_ltlt_us(ltlt)
         do l3 = abs(ln-lm),ln+lm,2
            nsum = nsum + 1
         end do
      end do
      write(IFCIAOPP,'(2i10)') nsum, num_ltlt_us
      write(IFCIAOPP,'(1x,4(1x,a2),(2x,a1),2x,(6x,6x),(10x,a2,8x),(7x,a3))') &
         'ln','tn','lm','tm','L','rc','nrc'
      do ltlt = 1,num_ltlt_us
         ln = ln_ltlt_us(ltlt) ; tn = tn_ltlt_us(ltlt)
         lm = lm_ltlt_us(ltlt) ; tm = tm_ltlt_us(ltlt)
         ch_ln = fn_label_orbital(ln) ; ch_lm = fn_label_orbital(lm)
         write(ch_tn,'(i1)') tn
         write(ch_tm,'(i1)') tm
         ch5(1:5) = '_'//ch_ln(1:1)//ch_tn(1:1) &
                       //ch_lm(1:1)//ch_tm(1:1)
         do l3 = abs(ln-lm),ln+lm,2
            nrc = nrcut_qps_us(ltlt,l3)
            ch_l3 = fn_label_orbital_capital(l3)
            ch6(1:6) = ch5(1:5)//ch_l3(1:1)
            write(IFCIAOPP,'(1x,5i3,2x,(a6,a6),f20.10,i10)') &
               ln,tn,lm,tm,l3,'rr_qps',ch6, &
               rcut_qps_us(ltlt,l3),nrcut_qps_us(ltlt,l3)
         end do
      end do
      do ltlt = 1,num_ltlt_us
         ln = ln_ltlt_us(ltlt) ; tn = tn_ltlt_us(ltlt)
         lm = lm_ltlt_us(ltlt) ; tm = tm_ltlt_us(ltlt)
         ch_ln = fn_label_orbital(ln) ; ch_lm = fn_label_orbital(lm)
         write(ch_tn,'(i1)') tn
         write(ch_tm,'(i1)') tm
         ch5(1:5) = '_'//ch_ln(1:1)//ch_tn(1:1) &
                       //ch_lm(1:1)//ch_tm(1:1)
         do l3 = abs(ln-lm),ln+lm,2
            nrc = nrcut_qps_us(ltlt,l3)
            ch_l3 = fn_label_orbital_capital(l3)
            ch6(1:6) = ch5(1:5)//ch_l3(1:1)
            write(IFCIAOPP,'(1x,a42,5i3,2x,a6,a6)') &
               'r*r*Qps[nmL](r): nmL = (ln,tn,lm,tm,L) -->', &
               ln,tn,lm,tm,l3,'rr_qps',ch6
            write(IFCIAOPP,'(5i3,i6,i4)') ln,tn,lm,tm,l3,nrc
            write(IFCIAOPP,10) &
               (rpos(ir)**2*qps_us(ir,ltlt,l3),ir=1,nmesh)
         end do
      end do
   end select
end if
if (is_pcc == PCC) then
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a36)') '### Partial core charge : r*r*npc(r)'
   write(IFCIAOPP,'(a23)') '#  npc(r) is explicitly'
   write(IFCIAOPP,'(a47)') '#    for r < rc, npc(r) = c0+c1*r^2+...+cN*r^2N'
   write(IFCIAOPP,'(a31)') '#    for r > rc, npc(r) = nc(r)'
   rho_pcore_sum = 0.d0
   do ir = 1,nmesh
      rho_pcore_sum = rho_pcore_sum &
         + 4.d0*PI*rpos(ir)**2*rho_pcore(ir) * wr(ir)
   end do
   select case (is_pcc_method)
   case (POLYNOMIAL)
      write(IFCIAOPP,'((a15,5x),a10)') 'pc_charge_rrnpc','polynomial'
      write(IFCIAOPP,'(f24.16,2i6)') rho_pcore_sum, nr0_pcc, ncoeff_pcc
      write(IFCIAOPP,10) &
         (coeff_pcc(icoeff),icoeff=0,ncoeff_pcc)
   case (SBESSEL)
      write(IFCIAOPP,'((a15,5x),a16)') 'pc_charge_rrnpc','spherical_bessel'
      write(IFCIAOPP,'(f24.16,2i6)') rho_pcore_sum, nr0_pcc
      write(IFCIAOPP,10) a_pcc, b_pcc
   end select
end if
if (is_with_dipole /= NO) then
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a54)') &
      '### Dipole moment : [n|d/dx|m], [n|d/dy|m], [n|d/dz|m]'
   write(IFCIAOPP,'(a73)') &
      '#  [n|d/dx|m] = <psi[n]|d/dx|psi[m]> - <phi[n]|d/dx|phi[m]> = -[m|d/dx|n]'
   write(IFCIAOPP,'(a73)') &
      '#  [n|d/dy|m] = <psi[n]|d/dy|psi[m]> - <phi[n]|d/dy|phi[m]> = -[m|d/dy|n]'
   write(IFCIAOPP,'(a73)') &
      '#  [n|d/dz|m] = <psi[n]|d/dz|psi[m]> - <phi[n]|d/dz|phi[m]> = -[m|d/dz|n]'
   write(IFCIAOPP,'(a42)') &
      '#     n = (n1,l1,t1,m1), m = (n2,l2,t2,m2)'
   write(IFCIAOPP,'(a6)') 'dipole'
   write(IFCIAOPP,'(i10)') num_dipole_lm_us/2
   write(IFCIAOPP,'(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_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(IFCIAOPP,'(8i3,3(1pe18.10),2i3)') &
      n1,l1,t1,m1,n2,l2,t2,m2, &
      dipole_dx_us(ltmltm),dipole_dy_us(ltmltm),dipole_dz_us(ltmltm), &
      phase_ylm(l1,m1),phase_ylm(l2,m2)
   end do
end if
if ((is_write_logderi /= NO).and.(is_logderi /= NO)) then
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a39)') '### Logarithmic derivatives [separable]'
   write(IFCIAOPP,'(a38)') '#  AE --> dlog{psi[l](r,E)}/dr at r=rc'
   write(IFCIAOPP,'(a38)') '#  PP --> dlog{phi[l](r,E)}/dr at r=rc'
   write(IFCIAOPP,'(a7,5x,a6)') 'logderi','linear'
   write(IFCIAOPP,'(i10,2(1pe25.15))') &
      ne_logderi, emin_logderi, emax_logderi
   if (nrcut_logderi == 0) then
      nrc = nrcut_max_us
   else
      nrc = max(nrcut_logderi,nrcut_max_us)
   end if
   nsum = 0
   do ll = 0,lmax
      nref = nref_us(ll)
      if (nref == 0) then
         cycle
      end if
      nsum = nsum + 1
   end do
   write(IFCIAOPP,'(i10)') nsum
   write(IFCIAOPP,'((9x,a1),(10x,a2,8x),(7x,a3))') 'l','rc','nrc'
   do ll = 0,lmax
      ch_ln = fn_label_orbital(ll)
      ch2(1:2) = '_'//ch_ln(1:1)
      nref = nref_us(ll)
      if (nref == 0) then
         cycle
      end if
      write(IFCIAOPP,'(i10,f20.10,i10,5x,a6,a2)') ll,rpos(nrc),nrc,'ldr_ae',ch2
      write(IFCIAOPP,'(i10,f20.10,i10,5x,a6,a2)') ll,rpos(nrc),nrc,'ldr_pp',ch2
   end do
   do ll = 0,lmax
      ch_ln = fn_label_orbital(ll)
      ch2(1:2) = '_'//ch_ln(1:1)
      nref = nref_us(ll)
      if (nref == 0) then
         cycle
      end if
      write(IFCIAOPP,'(1x,a32,i5,f20.10,5x,a6,a2)') &
         'dlog{psi[l](r,E)}/dr: (l,rc) -->',ll,rpos(nrc),'ldr_ae',ch2
      write(IFCIAOPP,11) (logderi_ae(ie,ll),ie=1,ne_logderi)
      write(IFCIAOPP,'(1x,a32,i5,f20.10,5x,a6,a2)') &
         'dlog{phi[l](r,E)}/dr: (l,rc) -->',ll,rpos(nrc),'ldr_pp',ch2
      write(IFCIAOPP,11) (logderi_us(ie,ll),ie=1,ne_logderi)
   end do
end if
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a48)') '### All-electron SCF wavefunctions : g*psi[n](g)'
   write(IFCIAOPP,'(a21)') 'ae_wave_function_gpsi'
   write(IFCIAOPP,'(i10)') num_ltx_us
   write(IFCIAOPP,'(1x,3(2x,a1),2(1x,a2),2x,(4x,3x),(10x,a7,3x))') &
      'n','l','t','ln','tn','Eref[n]'
   do lt = 1,num_ltx_us
      nn  = n_lt_us(lt)  ; ll  = l_lt_us(lt)  ; tt   = t_lt_us(lt)
      ln  = ln_lt_us(lt) ; tn  = tn_lt_us(lt) ; eref = eref_us(lt)
      ch_ln = fn_label_orbital(ll)
      write(ch_tn,'(i1)') tn
      ch3(1:3) = '_'//ch_ln(1:1)//ch_tn(1:1)
      write(IFCIAOPP,'(1x,5i3,2x,(a4,a3),f20.10)') &
         nn,ll,tt,ln,tn,'gpsi',ch3,eref
   end do
   do lt = 1,num_ltx_us
      nn  = n_lt_us(lt)  ; ll  = l_lt_us(lt)  ; tt   = t_lt_us(lt)
      ln  = ln_lt_us(lt) ; tn  = tn_lt_us(lt) ; eref = eref_us(lt)
      ch_ln = fn_label_orbital(ll)
      write(ch_tn,'(i1)') tn
      ch3(1:3) = '_'//ch_ln(1:1)//ch_tn(1:1)
      write(IFCIAOPP,'(1x,a34,5i3,2x,a4,a3)') &
         'g*psi[n](g): n = (n,l,t,ln,tn) -->',nn,ll,tt,ln,tn,'gpsi',ch3
      write(IFCIAOPP,20) nn,ll,tt,ln,tn,eref
      write(IFCIAOPP,11) (gpos(ig)*psi_g_us(ig,lt),ig=1,ng_mesh)
   end do
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a38)') '### Pseudo-wavefunctions : g*phi[n](g)'
   write(IFCIAOPP,'(a21)') 'pp_wave_function_gphi'
   write(IFCIAOPP,'(i10)') num_ltx_us
   write(IFCIAOPP,'(1x,3(2x,a1),2(1x,a2),2x,(5x,3x),2x,2x,(8x,a7,3x))') &
      'n','l','t','ln','tn','Eref[n]'
   do lt = 1,num_ltx_us
      nn  = n_lt_us(lt)  ; ll  = l_lt_us(lt)  ; tt   = t_lt_us(lt)
      ln  = ln_lt_us(lt) ; tn  = tn_lt_us(lt) ; eref = eref_us(lt)
      ips = ips_lt_us(lt)
      select case (is_val_type_ps(ips))
      case (TM91)
         val_type_tmp = 'NC'
      case (US90)
         val_type_tmp = 'US'
      end select
      ch_ln = fn_label_orbital(ll)
      write(ch_tn,'(i1)') tn
      ch3(1:3) = '_'//ch_ln(1:1)//ch_tn(1:1)
      write(IFCIAOPP,'(1x,5i3,2x,(a4,a3),2x,a2,f18.10)') &
         nn,ll,tt,ln,tn,'gphi',ch3,val_type_tmp,eref
   end do
   do lt = 1,num_ltx_us
      nn  = n_lt_us(lt)  ; ll  = l_lt_us(lt)  ; tt   = t_lt_us(lt)
      ln  = ln_lt_us(lt) ; tn  = tn_lt_us(lt) ; eref = eref_us(lt)
      ips = ips_lt_us(lt)
      select case (is_val_type_ps(ips))
      case (TM91)
         val_type_tmp = 'NC'
      case (US90)
         val_type_tmp = 'US'
      end select
      ch_ln = fn_label_orbital(ll)
      write(ch_tn,'(i1)') tn
      ch3(1:3) = '_'//ch_ln(1:1)//ch_tn(1:1)
      write(IFCIAOPP,'(1x,a34,5i3,2x,a4,a3)') &
         'g*phi[n](g): n = (n,l,t,ln,tn) -->',nn,ll,tt,ln,tn,'gphi',ch3
      write(IFCIAOPP,19) nn,ll,tt,ln,tn,val_type_tmp
      write(IFCIAOPP,11) (gpos(ig)*phi_g_us(ig,lt),ig=1,ng_mesh)
   end do
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a29)') '### Projectors : g*beta[n](g)'
   write(IFCIAOPP,'(a15)') 'projector_gbeta'
   write(IFCIAOPP,'(i10)') num_ltx_us
   write(IFCIAOPP,'(1x,3(2x,a1),2(1x,a2),2x,(5x,3x),2x,2x,(8x,a7,3x))') &
      'n','l','t','ln','tn','Eref[n]'
   do lt = 1,num_ltx_us
      nn  = n_lt_us(lt)  ; ll  = l_lt_us(lt)  ; tt   = t_lt_us(lt)
      ln  = ln_lt_us(lt) ; tn  = tn_lt_us(lt) ; eref = eref_us(lt)
      ips = ips_lt_us(lt)
      select case (is_val_type_ps(ips))
      case (TM91)
         val_type_tmp = 'NC'
      case (US90)
         val_type_tmp = 'US'
      end select
      ch_ln = fn_label_orbital(ll)
      write(ch_tn,'(i1)') tn
      ch3(1:3) = '_'//ch_ln(1:1)//ch_tn(1:1)
      write(IFCIAOPP,'(1x,5i3,2x,(a5,a3),2x,a2,f18.10)') &
         nn,ll,tt,ln,tn,'gbeta',ch3,val_type_tmp,eref
   end do
   do lt = 1,num_ltx_us
      nn  = n_lt_us(lt)  ; ll  = l_lt_us(lt)  ; tt   = t_lt_us(lt)
      ln  = ln_lt_us(lt) ; tn  = tn_lt_us(lt) ; eref = eref_us(lt)
      ips = ips_lt_us(lt)
      select case (is_val_type_ps(ips))
      case (TM91)
         val_type_tmp = 'NC'
      case (US90)
         val_type_tmp = 'US'
      end select
      ch_ln = fn_label_orbital(ll)
      write(ch_tn,'(i1)') tn
      ch3(1:3) = '_'//ch_ln(1:1)//ch_tn(1:1)
      write(IFCIAOPP,'(1x,a35,5i3,2x,a5,a3)') &
         'g*beta[n](g): n = (n,l,t,ln,tn) -->',nn,ll,tt,ln,tn,'gbeta',ch3
      write(IFCIAOPP,19) nn,ll,tt,ln,tn,val_type_tmp
      write(IFCIAOPP,11) (gpos(ig)*beta_g_us(ig,lt),ig=1,ng_mesh)
   end do
if (is_pp_calc_class == US) then
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a36)') '### Deficit charge : g*g*Qps[nmL](g)'
   write(IFCIAOPP,'(a18,5x)') 'deficit_charge_ggqps'
   write(IFCIAOPP,'(i10)') num_ltlt_us
   write(IFCIAOPP,'(1x,4(1x,a2),(2x,a1))') &
      'ln','tn','lm','tm','L'
   do ltlt = 1,num_ltlt_us
      ln = ln_ltlt_us(ltlt) ; tn = tn_ltlt_us(ltlt)
      lm = lm_ltlt_us(ltlt) ; tm = tm_ltlt_us(ltlt)
      ch_ln = fn_label_orbital(ln) ; ch_lm = fn_label_orbital(lm)
      write(ch_tn,'(i1)') tn
      write(ch_tm,'(i1)') tm
      ch5(1:5) = '_'//ch_ln(1:1)//ch_tn(1:1) &
                    //ch_lm(1:1)//ch_tm(1:1)
      write(IFCIAOPP,'(1x,4i3,5x,(a6,a5))') &
         ln,tn,lm,tm,'gg_qps',ch5
      do l3 = abs(ln-lm),ln+lm,2
         ch_l3 = fn_label_orbital_capital(l3)
         ch6(1:6) = ch5(1:5)//ch_l3(1:1)
         write(IFCIAOPP,'(1x,5i3,2x,(a6,a6))') &
            ln,tn,lm,tm,l3,'gg_qps',ch6
      end do
   end do
   do ltlt = 1,num_ltlt_us
      ln = ln_ltlt_us(ltlt) ; tn = tn_ltlt_us(ltlt)
      lm = lm_ltlt_us(ltlt) ; tm = tm_ltlt_us(ltlt)
      ch_ln = fn_label_orbital(ln) ; ch_lm = fn_label_orbital(lm)
      write(ch_tn,'(i1)') tn
      write(ch_tm,'(i1)') tm
      ch5(1:5) = '_'//ch_ln(1:1)//ch_tn(1:1) &
                    //ch_lm(1:1)//ch_tm(1:1)
      write(IFCIAOPP,'(1x,a36,4i3,2x,a4,a5)') &
         'g*g*Q[nm](g): nm = (ln,tn,lm,tm) -->', &
         ln,tn,lm,tm,'gg_q',ch5
      write(IFCIAOPP,'(4i3)') ln,tn,lm,tm
      write(IFCIAOPP,11) &
         (gpos(ig)**2*q_g_us(ig,ltlt),ig=1,ng_mesh)
      do l3 = abs(ln-lm),ln+lm,2
         ch_l3 = fn_label_orbital_capital(l3)
         ch6(1:6) = ch5(1:5)//ch_l3(1:1)
         write(IFCIAOPP,'(1x,a42,5i3,2x,a6,a6)') &
            'g*g*Qps[nmL](g): nmL = (ln,tn,lm,tm,L) -->', &
            ln,tn,lm,tm,l3,'gg_qps',ch6
         write(IFCIAOPP,'(5i3)') ln,tn,lm,tm,l3
         write(IFCIAOPP,11) &
            (gpos(ig)**2*qps_g_us(ig,ltlt,l3),ig=1,ng_mesh)
      end do
   end do
end if
   write(IFCIAOPP,*)
   write(IFCIAOPP,'(a17)') '### End of CIAOPP'
   write(IFCIAOPP,'(a3)') 'end'
   close(IFCIAOPP)
10 format(3(1pe25.17))
11 format(6(1pe11.3))
19 format(1x,3(i2,2x),2(i2,2x),2x,a2,2i10)
20 format(1x,3(i2,2x),2(i2,2x),2f20.10,i10)
99 continue
  !++++++++++++++++++++++
   deallocate(array_tmp)
  !++++++++++++++++++++++
   end subroutine write_ciaopp
