subroutine lir_Orb_Ref
use lewis_module
use mod_script
use mod_lirorb
implicit real*8 (a-h,o-x,z),logical*1(y)
real(4) :: t0,t1
yw=.false.

!
!=============================================================
! Lecture des orbitales de reference
!=============================================================
!
!open(25,file=scforbin,status='old')
call lirorb(scforbin,norb2,nsym2,isym2,26,25)

allocate(orbscf(norb,norb))
allocate(dens(norb,norb))
allocate(occscf(norb))
orbscf=0.d0
ifin=0
do is=1,nsym
   !print*,'************* is=',is
   rewind 26
   ideb=ifin+1
   ifin=ifin+isym(is)
   norbs=isym(is)
   do k=1,is-1
      if(isym(k)>0) read(26)
   !   if(isym(k)>0) print*,'lecture orb',k,isym(k)
   enddo
   if(isym(k)>0) read(26) orbscf(ideb:ifin,ideb:ifin)
   do k=is+1,nsym
      if(isym(k)>0) read(26)
   !   if(isym(k)>0) print*,'lecture orb pour occ',k,isym(k)
   enddo
   do k=1,is-1
      if(isym(k)>0) read(26)
   !   if(isym(k)>0) print*,'lecture occ pour occ',k,isym(k)
   enddo
   if(isym(k)>0) read(26,err=11) occscf(ideb:ifin)
   goto 12
   11 continue
   print*,'error while reading ocupations in scforbin (',trim(scforbin),') for symmetry',is
   print*,'ideb,ifin=',ideb,ifin
   stop
   12 continue
   if(worb) then
      write(ifil_orb,'(/,a,i2,/)') 'Matrice of Reference Orbitals  Sym',is
      call mscript(orbscf(ideb:ifin,ideb:ifin),file=ifil_orb)
   endif
! normalisation des orbitales de reference
         !call mscript(s0(ideb:ifin,ideb:ifin))
   do k=ideb,ifin
      anorm=dot_product(orbscf(ideb:ifin,k), &
      matmul(s0(ideb:ifin,ideb:ifin),orbscf(ideb:ifin,k)))
      anorm=dsqrt(anorm)
      orbscf(ideb:ifin,k)=orbscf(ideb:ifin,k)/anorm
   enddo

enddo
if(mprint(1)>2) then
   print*,'Orb de reference'
   call mscript(orbscf)
   print*,'occupations'
   print'(10f8.4)',occscf
endif
call calc_fermi(fermi0,occscf,isym,nsym,work1,norb,itsym)

!
!==================================================================
! Fabrication de la matrice densite correspondant aux OA en donnee
!==================================================================
!
!
!------------------------------------------------------------
! La matrice diagonale occscf est la matrice densite dans la base des OM
! La matrice orbscf est en fait la matrice de passage des OA aux OM
! --> la matrice densite en base d'OA est P.D.P**(-1)
! ou P=orbscf, D=occscf.
! P**(-1)= transpose(P).S    S=mat de recouvrement des OA
! Demonstration :
! P**(-1) est la matrice des OA dans la base des OM
! Les OA sont non orthogonales, mais les OM le sont
! ==> on a un jeu de vecteurs non orthogonaux (les OA) exprime dans une base
! orthogonale
! donc : transpose(P**(-1)).P**(-1)=S
! ==> P.transpose(P) = S**(-1)
! ==> P.transpose(P).S = I
! ==> P**(-1) = transpose(P).S
!------------------------------------------------------------
!
print*,' '
print*,'calcul de la matrice densite dans la base des OA symetrisees'
! P.D
do i=1,norb
   dens(:,i)=occscf(i)*orbscf(:,i)
enddo
! P.D.P**(-1):  (=P.D.transpose(P).S)
call cpu_time(t0)
work2=transpose(orbscf)
dens=matmul(dens,work2)
call cpu_time(t1)
if(yw)print*,'dens cpu1',t1-t0
call cpu_time(t0)
dens=matmul(dens,s0)
call cpu_time(t1)
if(yw)print*,'dens cpu2',t1-t0
call cpu_time(t0)
call open_chose_number(ifil_dens,'DENS_OA','unknown', &
'unformatted')
write(ifil_dens) dens
close(ifil_dens)
print*,' '
if(yw.or.mprint(1)>2) print*,'matrice densite dans la base des OA '
if(yw.or.mprint(1)>2) call mscript(dens)

if(yw.or.mprint(1)>2) print*,'matrice densite dans la base des OA desymetrisees'
dens=matmul(dens,transpose(pass))
dens=matmul(pass,dens)
if(yw.or.mprint(1)>2) call mscript(dens)
call cpu_time(t1)
print*,'matrice densite : duree du calcul',t1-t0

end
 subroutine calc_fermi(fermi0,occscf,isym,nsym,work1,norb,itsym)
implicit real*8 (a-h,o-x,z),logical*1(y)
integer fermi0(nsym),isym(nsym),itsym(norb)
real(8) work1(norb),occscf(norb),anels(8)
integer :: mloc(1),fermitot,fermiref,loc(1)
logical :: yw=.false.

if(any(fermi0/=0)) then
   print'(/,a,8i4,/)','Fermi0 en donnee',fermi0(1:nsym)
   return
endif

work1=occscf
ifin=0
!do is=1,nsym
!   ideb=ifin+1
!   ifin=ifin+isym(is)
!   do i=ideb,ifin
!      if(work1(i)==2.d0) then
!         work1(i)=0.d0
!         fermi0(is)=fermi0(is)+1
!      endif
!   enddo
!enddo
aneltot=0.d0
do is=1,nsym
   anel=0.d0
   ideb=ifin+1
   ifin=ifin+isym(is)
   do i=ideb,ifin
      anel=anel+work1(i)
   enddo
   anels(is)=anel
   aneltot=aneltot+anel
   fermi0(is)=int(anel/2)
enddo
if(yw) then
   print*,'aneltot',aneltot
   print*,'anels  ',anels(1:nsym)
   print*,'fermi0 ',fermi0
endif
nel_fermi=sum(fermi0*2)
nel=nint(aneltot)
if(yw)print*,'nel_fermi',nel_fermi
if(yw)print*,'nel      ',nel
if(yw)print*,'anels',anels
anels=anels-fermi0*2.d0
do while(nel_fermi<nel)
   if(yw)print*,'anels',anels
   loc=maxloc(anels)
   fermi0(loc(1))=fermi0(loc(1))+1
   anels(loc(1))=anels(loc(1))-2.d0
   if(yw)print*,'loc',loc
   nel_fermi=nel_fermi+2
enddo


!fermitot=sum(fermi0(1:nsym))
!so=sum(occscf)
!neltot=nint(so)
!fermiref=(neltot+1)/2
!do
!   if(fermitot>=fermiref) exit
!   mloc=maxloc(work1)
!   work1(mloc(1))=0.d0
!   is=itsym(mloc(1))
!   fermi0(is)=fermi0(is)+1
!   fermitot=fermitot+1
!enddo
print'(/,a,8i4,/)',' Fermi0 trouve a partir des orb de Ref :' &
,fermi0(1:nsym)
end


