       subroutine scf1(orb,norb,fermi0,nprint,orbitales,ur,v,s,ul,u,occ,
     *yvirt)
      use bas
      implicit real*8 (a-h,o-x,z),logical*1(y)
      parameter (maxsym=8)
      common/sym/ nsym,isym(maxsym),isymt(0:maxsym)
c      common/bas/ orbi,nbas(nfix),nbast(0:nfix),natom,atom,base
c      character*8 orbi(nfix)
c      character*8 base(nfix)
c      character*4 atom(100)
      character(3000) orb,orbitales
      integer fermi0(maxsym)
      dimension afermi(maxsym)
      double precision,dimension(:),allocatable :: w
      allocatable yfix(:)
      dimension ur(norb,norb)
      dimension v(norb,norb)
      dimension s(norb,norb)
      dimension ul(norb,norb)
      dimension u(norb,norb)
      dimension yvirt(norb)
      allocate(yfix(norb),w(norb))
      yw=.false.
      yverif=.false.
c------------------------------
c     lecture des orbitales SCF
c------------------------------
      rewind 11
      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) ur(1:ndims,k+ndims0)
 1000       format(4d18.12)
         enddo
         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)
         if(nprint.ge.1) then
            print*,' '
            print*,'orbitales SCF lues,  symetrie',is
            call scripto(ur(1:ndims,nd1:nd2),ndims,ndims,ndims,
     &      ndims
     *      ,orbi(nd1:nd2))
         endif
         print*,'occupation des orbitales lues, symetrie',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
      print*,'occupation par symetrie :'
      print'(8f10.6)',afermi(1:nsym)
      print*,'nombre total d''electrons',sum(afermi(1:nsym))
      nel1=int(sum(afermi(1:nsym))+0.01)
      afermi=afermi/2+0.1
      if(yfermi0) fermi0=afermi
      print'(a,8i5)',' fermi0 calcule',int(afermi(1:nsym))
      if(.not.yfermi0) 
     *print'(a,8i5)',' valeur retenue de fermi0 (en donnee)',
     *fermi0(1:nsym)
      nel2=sum(fermi0(1:nsym))*2
      print*,'nombre total d''electrons selon fermi0',nel2
      if(nel1/=nel2) then
         print*,'les nombres d''electrons ne concordent pas',
     *   ' il y a sans doute des orbitales non pleines'
         print*,'donner fermi0 dans &orb'
         if(yfermi0) stop
      endif
      if(yfermi0)print*,'fermi0 peut etre donne dans &orb'
!     noc=0
!     do k=1,norb
!        if(w(k).ge.1.d0) noc=noc+1
!     enddo
!     print*,' '
!     print*,'nombre total d''orbitales occupees :',noc
!     print*,' '
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))
         if(orbitales.eq.'SCHMUD') then
c            call faidensch(v(1:ndims,nd1:nd2)
c     *      ,u,s(1:ndims,1:ndims),ndims,orbi(nd1:nd2))
            goto 22
         endif
c-----------------------------------------------
c        test d'orthogonalite des orbitales lues
c-----------------------------------------------
         ul(1:ndims,1:ndims)=matmul(transpose(ur(1:ndims,nd1:nd2)),
     *   matmul(s(1:ndims,1:ndims),ur(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))
            ur(1:ndims,nd1:nd2)=matmul(ur(1:ndims,nd1:nd2),
     *      ul(1:ndims,1:ndims))
            print*,'orb orthogonalisees ur'
            call scripto(ur(1:ndims,nd1:nd2),ndims,ndims,ndims,
     *      ndims,orbi(nd1:nd2))
            ul(1:ndims,1:ndims)=matmul(transpose(ur(1:ndims,nd1:nd2))
     *      ,matmul(s(1:ndims,1:ndims),ur(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
     *      (ur(1:ndims,nd1:nd2)),matmul(s(1:ndims,1:ndims)
     *      ,ur(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(ur(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),ur(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------------------------------------------------------------------
         if(orbitales.eq.'SCHMUD') then
            u=0.d0
            do k=1,ndims
               u(k,k)=occ(k)
            enddo
         else
            do k=1,ndims
               do l=1,ndims
                  u(k,l)=w(ndims0+k)*ul(k,l)
               enddo
            enddo
            u(1:ndims,1:ndims)=matmul(ur(1:ndims,nd1:nd2),
     *      u(1:ndims,1:ndims))
         endif
         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)
         ur(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.2) then
            print*,'matrice densite dans la base des OAO sym',is
            call scripto(ur(1:ndims,nd1:nd2),ndims,ndims,ndims,
     *      ndims,orbi(nd1:nd2))
         endif
         if(orbitales.eq.'SCHMUD') then
            ur=(ur+transpose(ur))/2
            if(nprint.ge.2) then
               print*,'matrice densite sym dans la base des OAO sym',is
               call scripto(ur(1:ndims,nd1:nd2),ndims,ndims,ndims,
     *         ndims,orbi(nd1:nd2))
            endif
         endif
c        verif diagonalisation
         if(yverif) then
            ul(1:ndims,1:ndims)=ur(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
         if(is.eq.1)
     *   open(20,status='scratch',form='unformatted')
         write(20) ur(1:ndims,nd1:nd2)
      enddo
      return
      end
