      subroutine scf1
      use mod_dolo
      use mod_lirorb
      implicit real(8) (a-h,o-x,z),logical*1(y)
      common/sym/ nsym,isym(maxsym),isymt(0:maxsym)
      character(80) orb
      dimension afermi(maxsym),isym_bid(8)
      double precision,dimension(:),allocatable :: w
      allocatable yfix(:)
      double precision,dimension(:,:),allocatable :: ul,u,s,v
      character(100000) namel
      common /pr/ nprint
      allocate(yfix(norb),w(norb))
      yw=.false.
      yverif=.false.
!
!--------------------------------------
! Allocate
!--------------------------------------
!
      allocate(ul(norb,norb))
      allocate(gamma(norb,norb))
      allocate(s(norb,norb))
      allocate(v(norb,norb))
      allocate(u(norb,norb))
      allocate(yvirt(norb))
      allocate(numac(norb))
!
!--------------------------------------
! read fermi0
!--------------------------------------
!
      rewind 93
      namel=' '
      call LECNAM('&ORB ',namel,93,ierr,1)
      call nameli(namel,NUMAC,'NUMAC',4)
      fermi0=0
      call nameli(namel,FERMI0,'FERMI0',4)
 
c------------------------------
c     lecture du fichier scforb
c------------------------------
      call lirorb(scforb,norb_bid,nsym_bid,isym_bid,99,11)
c------------------------------
c     lecture des orbitales SCF
c------------------------------
!      open(11,file=scforb,status='old')
!      read(11,'(a)')
!      do is=1,nsym
!         ndims=isym(is)
!         if(ndims.eq.0) cycle
!         ndims0=isymt(is-1)
!         nd1=1+ndims0
!         nd2=ndims+ndims0
!         do k=1,ndims
!            read(11,'(a)') orb
!            read(11,1000) gamma(1:ndims,k+ndims0)
 1000       format(4d18.12)
!         enddo
!         yvirt(nd1:nd2)=.true.
!      enddo
      do is=1,nsym
         ndims=isym(is)
         if(ndims.eq.0) cycle
         ndims0=isymt(is-1)
         nd1=1+ndims0
         nd2=ndims+ndims0
         read(99) gamma(1:ndims,nd1:nd2)
         yvirt(nd1:nd2)=.true.
      enddo
 
c-----------------------------------------------
c     lecture de l'occupation des orbitales lues
c-----------------------------------------------
!      read(11,'(a)') orb
      kk=0
      afermi=0.d0
      yfermi0=all(fermi0==0)
      do is=1,nsym
         ndims=isym(is)
         if(ndims.eq.0) cycle
         ndims0=isymt(is-1)
         nd1=1+ndims0
         nd2=ndims+ndims0
!            read(11,1000) w(nd1:nd2)
            read(99) w(nd1:nd2)
         if(nprint.ge.1) then
            print*,' '
            print*,'orbitales SCF lues,  symetrie',is
            call scripto(gamma(1:ndims,nd1:nd2),ndims,ndims,ndims,
     &      ndims
     *      ,orbi(nd1:nd2))
         endif
         print*,'occupation of input orbitals, symmetry',is
         print'(10f8.4)',w(nd1:nd2)
         do k=1,ndims
            kk=kk+1
            !if(w(kk).ge.1.d0) fermi0(is)=fermi0(is)+1
            afermi(is)=afermi(is)+w(kk)
         enddo
      enddo
      close(99,status='delete')
!
      print*,'occupation per symmetry :'
      print'(8f10.4)',afermi(1:nsym)
      nel1=int(sum(afermi(1:nsym))+0.1)
      call titre('Electron Occupation#',20)
      print*,'total number of electrons',sum(afermi(1:nsym)),' -->',nel1
      afermi=afermi/2+0.1
      !print'(a,l2)', 'yfermi0',yfermi0
      if(yfermi0) fermi0=afermi
      print*,' '
      print*,'-----------------------------------------------------'
      print'(a)',' fermi0 as found from the orbital occupation'
      print'(a,8i5)','(file '//trim(scforb)//')',int(afermi(1:nsym))
      print'(a,i6,a)','(which corresponds to'
     *,2*sum(int(afermi(1:nsym))),' electrons'
      if(.not.yfermi0) then
         print*,' '
         print'(a,8i5)','         FERMI0 is given in data',
     *   fermi0(1:nsym)
      endif
      !print*,' '
      !print*,'-----------------------------------------------------'
      nel2=sum(fermi0(1:nsym))*2
      !print*,'total number of electrons according to fermi0',nel2
      print*,'-----------------------------------------------------'
      if(nel1/=nel2) then
         if(nel1==nel2-1) then
            !print*,'There is an odd number of electrons !'
         else
            print*,' '
            print*,'The numbers of electron do not fit.',
     *      ' There are probably non filled orbitals'
            print*,'Please give FERMI0 in &orb'
            print*,'---------------------------------------------------'
            stop
         endif
      endif
!      if(yfermi0)print*,'fermi0 peut etre donne dans &orb'
c------------------------------------------------------------------
c     lecture des orbitales atomiques orthogonales (OAO)
c------------------------------------------------------------------
      rewind 1
      read(1,'(a)') orb
      do is=1,nsym
         ndims=isym(is)
         ndims0=isymt(is-1)
         nd1=1+ndims0
         nd2=ndims+ndims0
         do k=1,ndims
            read(1,'(a)') orb
            read(1,1000) v(1:ndims,k+ndims0)
         enddo
      enddo
      if(yw) then
         print*,' '
         print*,'orbitales locales orthogonales lues'
         do is=1,nsym
            ndims=isym(is)
            ndims0=isymt(is-1)
            nd1=1+ndims0
            nd2=ndims+ndims0
            call scripto(v(1:ndims,nd1:nd2),ndims,ndims,ndims,n
     &      dims,orbi(nd1:nd2))
         enddo
      endif
c------------------------------------------------------------------
c     lecture de la matrice de recouvrement
c------------------------------------------------------------------
      rewind 8
      do is=1,nsym
         ndims=isym(is)
         ndims0=isymt(is-1)
         nd1=1+ndims0
         nd2=ndims+ndims0
         read(8) nbid
         if(ndims.eq.0) cycle
         read(8) s(1:ndims,1:ndims)
         read(8)
         if(yw)print*,'mats',nbid
         if(yw)call scripto
     *   (s(1:ndims,1:ndims),ndims,ndims,ndims,ndims,orbi(nd1:nd2))
c-----------------------------------------------
c        test d'orthogonalite des orbitales lues
c-----------------------------------------------
         ul(1:ndims,1:ndims)=matmul(transpose(gamma(1:ndims,nd1:nd2)),
     *   matmul(s(1:ndims,1:ndims),gamma(1:ndims,nd1:nd2)))
         ynonor=.false.
         do k=1,ndims
            do l=1,k-1
               if(dabs(ul(k,l)).gt.1.d-6) then
                  ynonor=.true.
                  exit
               endif
            enddo
         enddo
         if(ynonor) then
            print*,
     *      'Attention ! la matrice scf entree n''est pas orthogonale'
            print*,'matrice de recouvrement, symetrie',is
            call scripto(ul(1:ndims,1:ndims),ndims,ndims,ndims,n
     &      dims,orbi)
            call hdiag(ul(1:ndims,nd1:nd2),u(1:ndims,1:ndims)
     *      ,ndims,ndims)
            do i=1,ndims
               ul(i,i)=1.d0/dsqrt(ul(i,i))
            enddo
            ul(1:ndims,1:ndims)=matmul(u(1:ndims,1:ndims),matmul
     *      (ul(1:ndims,1:ndims),transpose(u(1:ndims,1:ndims))))
            print*,'matriz s-1/2'
            call scripto(ul(1:ndims,1:ndims),ndims,ndims,ndims,
     *      ndims,orbi(nd1:nd2))
            gamma(1:ndims,nd1:nd2)=matmul(gamma(1:ndims,nd1:nd2),
     *      ul(1:ndims,1:ndims))
            print*,'orb orthogonalisees ur'
            call scripto(gamma(1:ndims,nd1:nd2),ndims,ndims,ndims,
     *      ndims,orbi(nd1:nd2))
            ul(1:ndims,1:ndims)=matmul(transpose(gamma(1:ndims,nd1:nd2))
     *      ,matmul(s(1:ndims,1:ndims),gamma(1:ndims,nd1:nd2)))
            print*,'solapamiento de ur'
            call scripto(ul(1:ndims,1:ndims),ndims,ndims,ndims,
     *      ndims,orbi(nd1:nd2))
         endif
         if(yw) then
c         print*,'scf mat de recouvrement'
c         call scripto(s,norb,norb,norb,norb,orbi)
         endif
         if(yverif) then
c        verif prod scal des orb
            ul(1:ndims,1:ndims)=matmul(transpose
     *      (gamma(1:ndims,nd1:nd2)),matmul(s(1:ndims,1:ndims)
     *      ,gamma(1:ndims,nd1:nd2)))
            print*,'verif rec entre orb'
            call script(ul(1:ndims,1:ndims),ndims,ndims,ndims,ndims)
         endif
c------------------------------------------------------------------
c        inverse de la matrice des orbitales SCF
c------------------------------------------------------------------
         ul(1:ndims,1:ndims)=matmul(transpose(gamma(1:ndims,nd1:nd2))
     *   ,s(1:ndims,1:ndims))
         open(9,file='INVSCF',form='unformatted',status='unknown')
         write(9) ul(1:ndims,1:ndims)
         if(yw) then
            print*,'inverse de la matrice des orbitales SCF'
            call script(ul(1:ndims,1:ndims),ndims,ndims,ndims,ndims)
         endif
         if(yverif) then
            u(1:ndims,1:ndims)=matmul(ul(1:ndims,1:ndims),gamma(1:n
     &      dims,nd1:nd2))
            print*,'verif rec entre orb'
            call script(u(1:ndims,1:ndims),ndims,ndims,ndims,ndims)
         endif
 22      continue
c------------------------------------------------------------------
c        calcul de la matrice densite dans la base des OA
c------------------------------------------------------------------
            do k=1,ndims
               do l=1,ndims
                  u(k,l)=w(ndims0+k)*ul(k,l)
               enddo
            enddo
!            print*,'U'
!            call scripto(ul(1:ndims,1:ndims),ndims,ndims,ndims,ndims
!     *      ,orbi(nd1:nd2))
!             print*,'W',w(ndims0+1:ndims0+ndims)
!            stop
            u(1:ndims,1:ndims)=matmul(gamma(1:ndims,nd1:nd2),
     *      u(1:ndims,1:ndims))
         if(nprint.ge.2) then
            print*,'matrice densite dans la base des OA ,sym',is
            call scripto(u(1:ndims,1:ndims),ndims,ndims,ndims,ndims
     *      ,orbi(nd1:nd2))
         endif
c------------------------------------------------------------------
c        calcul de la matrice densite dans la base des OAO
c------------------------------------------------------------------
c        matrice v**(-1)
         ul(1:ndims,1:ndims)=matmul(transpose(v(1:ndims,nd1:nd2)),
     *   s(1:ndims,1:ndims))
c         print*,'v**(-1)'
c         call script(ul,norb,norb,norb,norb)
         gamma(1:ndims,nd1:nd2)=matmul(ul(1:ndims,1:ndims),
     *   matmul(u(1:ndims,1:ndims),v(1:ndims,nd1:nd2)))
         if(yw) then
            print*,'ul'
            call scripto(ul(1:ndims,nd1:nd2),ndims,ndims,ndims,
     *      ndims,orbi(nd1:nd2))
            print*,'u'
            call scripto(u(1:ndims,nd1:nd2),ndims,ndims,ndims,
     *      ndims,orbi(nd1:nd2))
            print*,'v'
            call scripto(v(1:ndims,nd1:nd2),ndims,ndims,ndims,
     *      ndims,orbi(nd1:nd2))
         endif
         if(nprint.ge.1) then
            print*,'matrice densite dans la base des OAO sym',is
             print*,'ndims,nd1,nd2',ndims,nd1,nd2
            call scripto(gamma(1:ndims,nd1:nd2),ndims,ndims,ndims,
     *      ndims,orbi(nd1:nd2))
         endif
c        verif diagonalisation
         if(yverif) then
            ul(1:ndims,1:ndims)=gamma(1:ndims,nd1:nd2)
            call hdiag(ul(1:ndims,1:ndims),u(1:ndims,1:ndims),
     *      ndims,ndims)
            print*,'verif diagonalisation'
            print'(8f10.6)',(ul(k,k),k=1,ndims)
            call scripto(u(1:ndims,1:ndims),ndims,ndims,ndims,ndims,
     *      orbi(nd1:nd2))
         endif
c        on sauve la matrice densite dans la base des OAO
      enddo
      return
      end
 
 
