module m_PS_opencore
  use m_Files,  only : nfpot, nfout, m_Files_open_ps_files, m_Files_close_ps_file
  use m_PseudoPotential,  only : nmesh, mmesh, radr_paw, radr, wos
  use m_NonLocal_Potential, only : new_radr_and_wos

  use m_PlaneWaveBasisSet,  only : gr_l
  use m_Parallelization,  only : npes, mype, ista_kngp, iend_kngp, ista_k
  use m_Const_Parameters,  only : DP
  use m_Crystal_Structure,  only : univol
  use m_Ionic_System,  only : ivan, ntyp, iatomn, natm, ityp
  use m_Control_Parameters,  only : noncol
  use m_CD_Mag_Moment,   only :  RhoMag_on_atom

  implicit none
  include 'mpif.h'
!
  integer, allocatable :: has_opencore(:)
  real(kind=DP), allocatable :: mag_opencore_pol(:,:)
  real(kind=DP), allocatable :: rmag_opencore(:,:)
  real(kind=DP), allocatable :: rmag_opencore_l(:,:)

contains

  subroutine m_PS_set_rmag_opencore
    integer :: it, ierr, nfp, i, ir
    integer :: num_core_ae_wfns
    integer, allocatable :: qnum_n_core_ae_wfns(:)
    integer, allocatable :: qnum_l_core_ae_wfns(:)
    real(kind=DP), allocatable :: psir_core_ae_wfns(:,:)
    real(kind=DP), allocatable :: enelevel_core_ae_wfns(:)
    real(kind=DP), allocatable :: focc_core_ae_wfns(:)
    real(kind=DP) :: weight

! == KT_DEBUG === 2015/06/15 == 
!    call m_Files_open_ps_file(ivan,iatomn,ntyp,it,ierr)  
!                                      ! this does not work properly by unknown reason.
    call m_Files_open_ps_files(ivan,iatomn,ntyp,ierr)
! =============== 2015/06/15

    if (ierr/=0) call mpi_stop(nfout)

    allocate( rmag_opencore(mmesh,ntyp) );   rmag_opencore = 0.0d0
    allocate( has_opencore(ntyp) );   has_opencore = 0.0d0

    Do it=1, ntyp
       nfp = nfpot(it)

       if ( mype == 0 ) call read_num_core_ae_wfns( nfp, num_core_ae_wfns, it )
       if ( npes > 1 ) then
          call mpi_bcast(  num_core_ae_wfns, 1, mpi_integer, 0, mpi_comm_world, ierr )
       endif
       
       if ( num_core_ae_wfns == 0 ) cycle
       
       allocate( qnum_n_core_ae_wfns( num_core_ae_wfns ) )
       allocate( qnum_l_core_ae_wfns( num_core_ae_wfns ) )
       allocate( psir_core_ae_wfns( nmesh(it),  num_core_ae_wfns ) )
       allocate( enelevel_core_ae_wfns( num_core_ae_wfns ) )
       allocate( focc_core_ae_wfns( num_core_ae_wfns ) )
       
       if ( mype == 0 ) then
          call read_data_core_ae_wfns( nfp, num_core_ae_wfns, nmesh(it), &
               &                       qnum_n_core_ae_wfns, qnum_l_core_ae_wfns, &
               &                       psir_core_ae_wfns, &
               &                       enelevel_core_ae_wfns, focc_core_ae_wfns )
       endif
       
       if ( npes > 1 ) then
          call mpi_bcast( qnum_n_core_ae_wfns, num_core_ae_wfns, &
               &          mpi_integer, 0, mpi_comm_world, ierr )
          call mpi_bcast( qnum_l_core_ae_wfns, num_core_ae_wfns, &
               &          mpi_integer, 0, mpi_comm_world, ierr )
          call mpi_bcast( enelevel_core_ae_wfns, num_core_ae_wfns, &
               &          mpi_double_precision, 0, mpi_comm_world, ierr )
          call mpi_bcast( focc_core_ae_wfns, num_core_ae_wfns, &
               &          mpi_double_precision, 0, mpi_comm_world, ierr )
          call mpi_bcast( psir_core_ae_wfns, nmesh(it)*num_core_ae_wfns, &
               &          mpi_double_precision, 0, mpi_comm_world, ierr )
       endif
!
       Do i=1, num_core_ae_wfns
          if ( qnum_l_core_ae_wfns(i) == 3 ) then
             if ( abs( focc_core_ae_wfns(i) -14.0 ) < 0.1 ) cycle

             has_opencore(it) = 1
             if ( focc_core_ae_wfns(i) <=7  ) then
                weight = focc_core_ae_wfns(i)
             else
                weight =  14.d0 -focc_core_ae_wfns(i)
             endif
             Do ir=1, nmesh(it)
                rmag_opencore(ir,it) = weight *psir_core_ae_wfns(ir,i) **2
             End Do
          endif
       End Do

       deallocate( qnum_n_core_ae_wfns )
       deallocate( qnum_l_core_ae_wfns )
       deallocate( psir_core_ae_wfns )
       deallocate( enelevel_core_ae_wfns )
       deallocate( focc_core_ae_wfns )

       call m_Files_close_ps_file(it)
    End Do
  end subroutine m_PS_set_rmag_opencore

  subroutine m_PS_set_pcc_opencore
    integer :: ierr, i, ir, n, it, ik
    real(kind=DP) :: gabs, fac
    real(kind=DP), allocatable :: wkx(:), wky(:)

    allocate( rmag_opencore_l( ista_kngp:iend_kngp, ntyp ) )
    rmag_opencore_l = 0.0d0

    allocate(wkx(mmesh)); wkx = 0.d0
    allocate(wky(mmesh)); wky = 0.d0
    allocate(wos(mmesh)); wos = 0

#if 1
    allocate( radr(mmesh)); radr = 0.0d0
#endif


    Do it=1, ntyp
#if 0
       call set_weight_exp( ierr, 1, nmesh(it), radr_paw(:,it), wos )
#else
       ik = ista_k
       call new_radr_and_wos(ik,it)
!       write(*,*) "wos", wos(1:5)
#endif

       if ( has_opencore(it) == 0 ) cycle
!       write(*,*) 'FFFF ', it
!       write(*,*) "FF2 ",  rmag_opencore(10,it)

       do i = ista_kngp, iend_kngp  !for mpi
          gabs = gr_l(i)
#if 0
          do n = 1, nmesh(it)
             wkx(n) = gabs * radr_paw(n,it)
          enddo
#else
          do n = 1, nmesh(it)
             wkx(n) = gabs * radr(n)
          enddo
#endif          
          call dsjnv(0,nmesh(it),wkx, wky)
          
          do  n = 1, nmesh(it)
             fac = wos(n) *rmag_opencore(n,it) /univol
             rmag_opencore_l(i,it) = rmag_opencore_l(i,it) + fac *wky(n)
          enddo
       end do
    End Do
    deallocate( wos )
    deallocate( wkx )
    deallocate( wky )
#if 1
    deallocate( radr )
#endif

  end subroutine m_PS_set_pcc_opencore

  subroutine m_PS_init_mag_opencore_pol
    integer :: ia, it

    if ( noncol ) then
       allocate( mag_opencore_pol(natm,3) )
    else
       allocate( mag_opencore_pol(natm,1) )
    endif
    mag_opencore_pol = 0.0d0

    Do ia=1, natm
       it = ityp(ia)
       if ( has_opencore(it) == 0 ) cycle
       if ( noncol ) then
!          mag_opencore_pol(ia,3) = -1.0d0    ! DOWN
          mag_opencore_pol(ia,3) = 1.0d0   
       else
!          mag_opencore_pol(ia,1) = -1.0d0    ! DOWN
          mag_opencore_pol(ia,1) = 1.0d0    
       endif
    End do
  end subroutine m_PS_init_mag_opencore_pol

  subroutine m_PS_set_mag_opencore_pol
    integer :: ia, it
    real(kind=DP) :: c1, c2

    Do ia=1, natm
       it = ityp(ia)
       if ( has_opencore(it) == 0 ) cycle

       if ( noncol ) then
          c1 = RhoMag_on_atom(ia,2)**2 +RhoMag_on_atom(ia,3)**2 +RhoMag_on_atom(ia,4)**2
          c2 = sqrt(c1)
          if ( c2 >1.0D-11 ) then
             mag_opencore_pol(ia,1) = RhoMag_on_atom(ia,2) /c2
             mag_opencore_pol(ia,2) = RhoMag_on_atom(ia,3) /c2
             mag_opencore_pol(ia,3) = RhoMag_on_atom(ia,4) /c2
          else
             mag_opencore_pol(ia,3) = 1.0d0
          endif
!          write(6000+mype,*) ia, mag_opencore_pol(ia,1:3)
       else
          c1 = RhoMag_on_atom(ia,1) - RhoMag_on_atom(ia,2)
          c2 = abs(c1)
          if ( c2 >1.0D-11 ) then
             mag_opencore_pol(ia,1) = c1 /c2
          else
             mag_opencore_pol(ia,1) = 1.0d0
          endif
       endif
    End Do
  end subroutine m_PS_set_mag_opencore_pol

  subroutine read_num_core_ae_wfns( nfp, nums, it )
    integer, intent(in) :: nfp, it
    integer, intent(out) :: nums

    integer :: length, ierr
    character(30) :: search_key

    nums = 0

    search_key = "CORE STATES";  length = len(search_key)
    call read_size_of_array_from_pp(nfp, nums, length, search_key, ierr)

    if ( ierr /= 0 ) then
       write(nfout,*) '----------------------'
       write(nfout,'(A,I2)') '!!! Keyword CORE STATES is not found in the PP', it
       write(nfout,*) '----------------------'
    endif

  end subroutine read_num_core_ae_wfns

  subroutine read_data_core_ae_wfns( nfp, num_core_ae_wfns, nmesh, &
       &                             qnum_n, qnum_l, psir_core, ene_level, focc )
    implicit none

    integer, intent(in) :: num_core_ae_wfns
    integer, intent(in) :: nmesh, nfp
    integer, intent(out) :: qnum_l(num_core_ae_wfns)
    integer, intent(out) :: qnum_n(num_core_ae_wfns)
    real(kind=8), intent(out) :: psir_core(nmesh, num_core_ae_wfns), &
         &                       ene_level(num_core_ae_wfns), focc(num_core_ae_wfns)

    integer :: i, n1, l1, k
    real(kind=DP) :: ene1, f1

    Do i=1, num_core_ae_wfns
       read(nfp,*) n1, l1, ene1, f1
       read(nfp,*) (psir_core(k,i),k=1,nmesh)
       !
       qnum_n(i) = n1;  qnum_l(i) = l1;  ene_level(i) = ene1;   focc(i) = f1
    End Do
  end subroutine read_data_core_ae_wfns

  subroutine read_size_of_array_from_pp( nfp, size_of_array, length, search_tag, ierr )
    implicit none

    integer, intent(in) :: nfp, length
    integer, intent(out) :: size_of_array, ierr
    character(length), intent(in) :: search_tag

    integer :: ifound
    character(30) :: line1

    size_of_array = 0;  ierr = 0

    Do while (.true.)
       read(nfp,'(a30)',end=10) line1
       ifound = index( line1, search_tag )
       if ( ifound /= 0 ) goto 20
    End do

10  ierr = 1; return

20  read(nfp,*) size_of_array

  end subroutine read_size_of_array_from_pp

end module m_PS_opencore
