      subroutine fock(bint)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter(maxsym=8,maxda3=300)
      include 'maxorb.prm'
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |     bint               |
c
      common/adr/iadr0(maxsym),nbint
      common/l40/ hmono(maxorb*(maxorb+1)/2),aj(maxorb*(maxorb+1)/2)
     *,ak(maxorb*(maxorb+1)/2),f(maxorb*(maxorb+1)/2),e0
     *,ajk(maxorb*(maxorb+1)/2),escf
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension  bint(nbint)
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common/orb2/numina(maxorb),numvir(maxorb),iordo(maxorb*2)
     *,iodro(maxorb*2)
     *,numinb(maxorb),numvib(maxorb)
      common/pr/nprint,mprint(10)
      common/infdav/ twcas,alam(maxda3),tau,twvec,twess,sint,sint4,sh
     *,hab,Nbtots,nvec,ngao,niter,iprec,lvec(maxda3),nfrag,ipresc,irest
     *,jrest
     *,iunit,ihprec,ihvec,ifiess,NESSAI,nf8,maxda2,bidia,ywvec,ytana
     *,yhmono,ydens,ywcas
      character*4 hab
      logical*1 bidia
      num(i,j)=i*(i-1)/2+j
      yw=.false.
      if(irest.eq.1.or.irest.eq.2) then
         read(2)(f(k),k=1,norb*(norb+1)/2)
         if(nprint.ge.1) then
            write(6,*)'operateur de fock au niveau de fermi'
            call wrd(f,norb)
         endif
         return
      endif
      rewind 82
      call lir8bl(bint,nbint,82)
      ij=0
      do 3 i=1,norb
      do 2 j=1,i
      ij=ij+1
      ff=hmono(ij)
      if(i.eq.j) then
         if(yw)write(6,*)'fock i,j,hmono(ij)',i,j,ff
         do kk=1,ninac
            k=numina(kk)
            mini=min0(i,k)
            maxi=max0(i,k)
            ff=ff+aj(num(maxi,mini))*2
            if(yw)write(6,*)'fock k,i,j,aj',
     *      k,i,j,aj(num(maxi,mini))*2
            ff=ff-ak(num(maxi,mini))
            if(yw)write(6,*)'fock k,i,j,ak',
     *      k,i,j,-ak(num(maxi,mini))
         enddo
         goto 1
      endif
      if(its(itsym(i),itsym(j)).ne.1) goto 1
      if(yw)write(6,*)'fock i,j,hmono(ij)',i,j,hmono(ij)
      do kk=1,ninac
         k=numina(kk)
         call adri(k,j,i,iadr)
         ff=ff+bint(iadr)+bint(iadr)
         if(yw)write(6,*)'fock k,i,j,iadr,bint(iadr)',
     *   k,i,j,iadr,bint(iadr)
      enddo
 1    continue
      f(ij)=ff
 2    continue
 3    continue
c
c--   int d'echange
      rewind 86
      call lir8bl(bint,nbint,86)
      ij=0
      do 13 i=1,norb
      do 12 j=1,i
      ij=ij+1
      ff=f(ij)
      if(i.eq.j) then
         goto 11
      endif
      if(its(itsym(i),itsym(j)).ne.1) goto 11
      do kk=1,ninac
         k=numina(kk)
         call adri(k,j,i,iadr)
         ff=ff-bint(iadr)
         if(yw)write(6,*)'fock k,i,j,iadr,bint(iadr)',
     *   k,i,j,iadr,bint(iadr)
      enddo
 11   continue
      if(dabs(ff).lt.1.d-7)ff=0.d0
      f(ij)=ff
      if(yw)write(6,*)'fock i,j,f(ij)',i,j,f(ij)
 12   continue
 13   continue
      if(nprint.ge.1) then
         write(6,*)'operateur de fock pour les inactives occupees'
         call wrd(f,norb)
      endif
      write(2)(f(k),k=1,norb*(norb+1)/2)
      return
      end
