!=======================================================================
!
!  PROGRAM  PHASE/0 2019.02 ($Rev: 570 $)
!
!  SUBROUINE:  width2, wd_fermi_error1, wd_fermi_error2
!
!  AUTHOR(S): N. Hamada, T. Yamasaki   August/20/2003
!  
!  Contact address :  Phase System Consortium
!                     E-mail: phase_system@nims.go.jp URL https://azuma.nims.go.jp
!  
!
!
!=======================================================================
!
!     The original version of this set of the computer programs "PHASE"
!  was developed by the members of the Theory Group of Joint Research
!  Center for Atom Technology (JRCAT), based in Tsukuba, in the period
!  1993-2001.
!
!     Since 2002, this set has been tuned and new functions have been
!  added to it as a part of the national project "Frontier Simulation 
!  Software for Industrial Science (FSIS)",  which is supported by
!  the IT program of the Ministry of Education, Culture, Sports,
!  Science and Technology (MEXT) of Japan. 
!     Since 2006, this program set has been developed as a part of the
!  national project "Revolutionary Simulation Software (RSS21)", which
!  is supported by the next-generation IT program of MEXT of Japan.
!   Since 2013, this program set has been further developed centering on PHASE System
!  Consortium.
!   The activity of development of this program set has been supervised by Takahisa Ohno.
!
subroutine wd_fermi_error1(nfout,emin,emax,tot,totch)
! $Id: b_Fermi.F90 570 2017-04-21 20:34:50Z yamasaki $
  use m_Const_Parameters, only : DP
  implicit none
  integer,       intent(in) :: nfout
  real(kind=DP), intent(in) :: emin, emax, tot, totch
  write(nfout,'(" emin = ",f10.4,"  emax = ",f10.4)') emin, emax
  write(nfout,'("  tot = ",f10.4," totch = ",f10.4)') tot, totch
  stop ' === stop in sub.fermi_parabolic (too few of states) =='
end subroutine wd_fermi_error1

subroutine wd_fermi_error2(nfout,e1,e2,efermi,emin,emax,tot,totch,neg,MAXITR)
  use m_Const_Parameters, only : DP
  implicit none
  integer, intent(in) :: nfout, neg, MAXITR
  real(kind=DP), intent(in) :: e1, e2,efermi, emin,emax, tot, totch
  
  write(nfout,'("     e1  = ", f10.5)') e1
  write(nfout,'("     e2  = ", f10.5)') e2
  write(nfout,'(" efermi  = ", f10.5)') efermi
  write(nfout,'("   emin  = ", f10.5, "  emax  = ",f10.5)') emin,emax
  write(nfout,'("    tot  = ", f10.5, " totch  = ",f10.5)') tot,totch
  write(nfout,'("  occup ( i = 1, ",i5,")")') neg
  write(nfout,'(" jcount exceeds MAXITR (= ",i8," (in FERMI)")') MAXITR
  stop ' stop at <wd_fermi_error2>'
end subroutine wd_fermi_error2

!!$C SUBROUTINE WIDTH2
!!$c                           @(#)width2.f 9.1 97/05/08 14:49:38 
!!$C
!!$C          1983/05/18 :   NORIAKI HAMADA
!!$C
!!$C----*----1----*----2----*----3----*----4----*----5----*----6----*----7
!!$C
subroutine width2( E,EFF,W, DOS,OCC  )
  use m_Const_Parameters, only : DP
  implicit none
  real(kind=DP), intent(in)  :: E, EFF, W
  real(kind=DP), intent(out) :: DOS, OCC
!!$C          EIGENENERGY IS BROADENED
!!$C
!!$C          E :  EIGENENERGY
!!$C          EF:  FERMI ENERGY
!!$C          W :  4*W IS BOTTOM LENGTH
!!$C          DOS    :  DENSITY OF STATES AT EF
!!$C          OCCUP :  OCUPATION FRACTION OF ELECTRON
  real(kind=DP) :: ee, ww

  if(w <= 0.0d0) STOP ' === STOP AT SUB.WIDTHE. (W<=0.0D0) ==='
#ifdef __TIMER_SUB__
!  call timer_sta(705)
#endif
  ee=(eff-e)/w
  ww=4.0d0*w
  if(ee <= -2.0d0) then
     dos    = 0.0d0
     occ  = 0.0d0
  else if(ee < -1.0d0) then
     dos    = (ee+2.0d0)**2/ww
     occ  = ((ee+2.0)**3)/(12.0d0)
  else if(ee < 1.0d0) then
     dos    = (2.0d0-ee**2)/ww
     occ  = (6.0d0+6.0d0*ee-(ee**3))/12.0d0
  else if(ee < 2.0d0) then
     dos    = ((ee-2.0d0)**2)/ww
     occ  = (12.0d0+(ee-2.0d0)**3)/12.0d0
  else
     dos    = 0.0d0
     occ  = 1.0d0
  end if
#ifdef __TIMER_SUB__
!  call timer_end(705)
#endif
end subroutine width2

! ============= KT_add =========================== 13.0E
subroutine width_fermi_dirac( ene, ef, width, dos, occ )
  use m_Const_Parameters, only : DP
  implicit none

  real(kind=DP), intent(in) :: ene, ef, width
  real(kind=DP), intent(out) :: dos, occ

  real(kind=DP) :: ee, c1, c2

  if ( width < 1.0D-10 ) stop "smearing width is too small"

  ee = ( ene -ef )/width
  if(ee.gt.100)then
     occ = 0.d0
     dos = 0.d0
  else if (ee.lt.-100)then
     occ = 1.d0
     dos = 0.d0
  else
  c1 = exp( ee );   c2 = cosh( ee/2.0D0 )
!
  occ = 1.0D0 / ( 1.0D0 +c1 )
  dos = 0.25D0 / c2**2 /width
  endif

end subroutine width_fermi_dirac
! ============================================== 13.0E
