      subroutine fock
      use module
      use mod_lirint
      use mod_script
      implicit real(8) (a-h,o-x,z),logical(1)(y)
      yw=.false.

      ! Ouverture du fichier d'integrales a trois indices
      if(yw)print*,'ijcl31',ijcl31
      open(30,file=ijcl31,status='old',form='unformatted')

      ! Allocation de la matrice de Fock
      allocate(f(num1(norb+2)))

! Appels a Fock au niveau de Fermi, puis pour les inactives occupeees
!   Si Fock est en lecture
      if(lifock) then
         open(99,file='FOCK',status='old',form='unformatted')
         read(99)
         read(99) f
         if(nprint.ge.1.and.norb<20) then
            write(6,*)
     *      'operateur de fock relu pour les inactives occupees'
            call wrd(f,norb)
            print*,  ' '
         endif
         write(2)(f(k),k=1,norb*(norb+1)/2)
      else
         call fock1
         write(2)(f(k),k=1,norb*(norb+1)/2)
      endif
      return
      end

       subroutine fock1
      use module
      use mod_lirint
      use mod_script
      implicit real(8) (a-h,o-x,z),logical(1)(y)
      integer(2) iint(4096),jnt(4096),knt(4096)
      dimension aaloc(2,4096)
      dimension loci(3,8)
      dimension aa2(2,8)
      allocatable ftmp(:)
      allocate (ftmp(num1(norb+2)))
      yw=.false.

      ! Operateur de Fock : contribution de hmono
      ij=0 
      do i=1,norb
         do j=1,i
            ij=ij+1
            f(ij)=hmono(i,j)
         enddo
      enddo
      if(yw)print*,'f(1)',f(1)

      ! Operateur de Fock : contribution de Jij et Kij
      ij=0 
      do i=1,norb
         ii=i*(i+1)/2
         do kk=1,ninac
            k=numin(kk)
            mini=min(i,k)
            maxi=max(i,k)
            f(ii)=f(ii)+ajk(maxi,mini)*2-ajk(mini,maxi)
         enddo
         do kk=1,noac
            k=numac(kk)
            mini=min(i,k)
            maxi=max(i,k)
            ftmp(ii)=ftmp(ii)+ajk(maxi,mini)*2-ajk(mini,maxi)
         enddo
      enddo
      if(yw)print*,'f2',f(1)

! Operateur de Fock : contribution des integrales iiij
      do ii=1,ninac
         i=numin(ii)
         ij=i*(i-1)/2
         do j=1,norb
            if(j>i) then
               jj=j*(j-1)/2+i
            else if(j<i) then
               jj=ij+j
            else
               cycle
            endif
            f(jj)=f(jj)+aijjj(j,i)
         enddo
      enddo
      do ii=1,noac
         i=numac(ii)
         ij=i*(i-1)/2
         do j=1,norb
            if(j>i) then
               jj=j*(j-1)/2+i
            else if(j<i) then
               jj=ij+j
            else
               cycle
            endif
            ftmp(jj)=ftmp(jj)+aijjj(j,i)
         enddo
      enddo
      if(yw)print*,'f3',f(1)

! Operateur de Fock : contribution des integrales a 3 indices differents
! Lecture des integrales a 3 indices
      ind=4096
      do
         ind=ind+1
         if(ind>4096) then
            ind=1
            read(30) iint,jnt,knt,aaloc
         endif
         i=iint(ind)
         if(i==0) exit
! i doit faire partie des orbitales occupees :
         ii=num0(i)
         if(ii>ninac+(nelac+1)/2) cycle
         yfermi=ii>ninac

         j=jnt(ind)
         k=knt(ind)
!  traitement de la symetrie
         call regensym3(i,j,k,loci,nintsy,aaloc(:,ind),aa2)
         do iintsy=1,nintsy
            if(intsy=='SYM') then
               i=loci(1,iintsy)
               j=loci(2,iintsy)
               k=loci(3,iintsy)
               aaloc(:,ind)=aa2(:,iintsy)
            endif
!  correction a Fock
            ii=j*(j-1)/2+k
            if(yfermi) then
               ftmp(ii)=ftmp(ii)+aaloc(2,ind)*2-aaloc(1,ind)
            else
               f(ii)=f(ii)+aaloc(2,ind)*2-aaloc(1,ind)
            endif
         enddo
      enddo
      if(yw)print*,'f4',f(1)

! Ecritures
      if(nprint.ge.1.and.norb<20) then
         write(6,*)'operateur de fock pour les inactives occupees'
         call wrd(f,norb)
         write(6,*)'operateur de fock au niveau de Fermi'
         call wrd(f+ftmp,norb)
         print*,  ' '
      endif
      deallocate(ftmp)
      return
      end




      subroutine fockv
      use module
      use mod_lirint
      use mod_script
      implicit real(8) (a-h,o-x,z),logical(1)(y)
      integer(2) iint(4096),jnt(4096),knt(4096)
      dimension aaloc(2,4096)
      dimension loci(3,8)
      dimension aa2(2,8)
      yw=.false.
      ! Ouverture du fichier d'integrales a trois indices
      if(yw)print*,'ijcl31',ijcl31
      ! Allocation de la matrice d'integrales a trois indices
      allocate(f(num1(norb+2)))
      call fock0
      allocate(aiikl(norb,num1(norb+1)))
      allocate(aijil(norb,num1(norb+1)))
      open(30,file=ijcl31,status='old',form='unformatted')

      ! Lecture des integrales a 3 indices
      ind=4096
      aiikl=0.d0
      aijil=0.d0
      do
         ind=ind+1
         if(ind>4096) then
            ind=1
            read(30) iint,jnt,knt,aaloc
         endif
         i=iint(ind)
         if(i==0) exit
         j=jnt(ind)
         k=knt(ind)
         if(yw)print'(a,3i4,2f12.8)','i,j,k,aaloc1'
     *   ,i,j,k,aaloc(:,ind)
         call regensym3(i,j,k,loci,nintsy,aaloc(:,ind),aa2)
         do iintsy=1,nintsy
            if(intsy=='SYM') then
               i=loci(1,iintsy)
               j=loci(2,iintsy)
               k=loci(3,iintsy)
               aaloc(:,ind)=aa2(:,iintsy)
            endif
            if(yw)print'(a,3i4,2f12.8)','i,j,k,aa2'
     *      ,i,j,k,aa2(:,iintsy)
            ii=(j-1)*(j-2)/2+k
            aiikl(i,ii)=aaloc(1,ind)
            aijil(i,ii)=aaloc(2,ind)
            if(yw) then
            if(i==1.and.ii==3)print'(a,4i4,2f12.8)',
     *         'aaloc',i,j,k,nintsy,aaloc(1,ind)
     *         ,aiikl(i,ii)
            endif
         enddo
      enddo
      close(30)
      do i=1,norb
         do j=1,norb
            if(j>i) then
               jj=(j-2)*(j-1)/2+i
            else if(j<i) then
               jj=(i-2)*(i-1)/2+j
            else
               cycle
            endif
            aiikl(i,jj)=aijjj(j,i)
            if(yw) then
               if(i==1.and.ii==3)print'(a,4i4,2f12.8)',
     *         'ijjj',i,j,k,nintsy,aijjj(j,i)
     *         ,aiikl(i,jj)
            endif
            aijil(i,jj)=aijjj(j,i)
            if(yw)print'(a,3i4,f12.8)','i,i,j,aaloc2',i,i,j,aijjj(j,i)
         enddo
      enddo
      if(yw)call mscript(aiikl)
      ! Operateur de Fock
      ij=0 
      ij1=0 
      do i=1,norb
         do j=1,i
            !yw=i==2.and.j==1
            ij=ij+1
            ff=hmono(i,j)
            if(i.eq.j) then
               if(yw)write(6,*)'fock i,j,hmono(ij)',i,j,ff
               do kk=1,ninac
                  k=numin(kk)
                  mini=min0(i,k)
                  maxi=max0(i,k)
                  ff=ff+ajk(maxi,mini)*2
                  if(yw)write(6,*)'fock k,i,j,aj',
     *            k,i,j,ajk(maxi,mini)*2
                  ff=ff-ajk(mini,maxi)
                  if(yw)write(6,*)'fock k,i,j,ak',
     *            k,i,j,-ajk(mini,maxi)
               enddo
               goto 1
            endif
            if(yw)write(6,*)'fock i,j,hmono(ij)',i,j,hmono(i,j)
            ij1=ij1+1
            do kk=1,ninac
               k=numin(kk)
c               call adri(k,j,i,iadr)
c               ff=ff+bint(iadr)+bint(iadr)
               if(yw)print*,'i,j,ij',i,j,ij1
               ff=ff+aijil(k,ij1)+aijil(k,ij1)
               if(yw)write(6,'(a,3i4,f20.12)')'fock k,i,j,aijil(k,ij1)'
     *         ,k,i,j,aijil(k,ij1)
            enddo
 1          continue
            f(ij)=ff
            if(yw)print*,'ff',ff
         enddo
      enddo
c
c--   int d'echange
      ij=0
      ij1=0
      do i=1,norb
         do j=1,i
            ij=ij+1
            if(i==j) cycle
            ij1=ij1+1
            ff=f(ij)
            if(yw)write(6,*)'debut fock i,j,f(ij)',i,j,f(ij)
            if(i.eq.j) then
               goto 11
            endif
            do kk=1,ninac
               k=numin(kk)
               ff=ff-aiikl(k,ij1)
               if(yw)write(6,'(a,3i4,f20.12)')'fockx k,i,j,aiikl(i,ij)'
     *         ,k,i,j,aiikl(k,ij1)
            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)
         enddo
      enddo
!      if(nprint.ge.1.and.norb<20) then
         write(6,*)'operateur de fock pour les inactives occupees'
         call wrd(f,norb)
         print*,  ' '
!      endif
      if(lifock) then
         open(99,file='FOCK',status='old',form='unformatted')
         read(99)
         read(99) f
         if(nprint.ge.1.and.norb<20) then
            write(6,*)
     *      'operateur de fock relu pour les inactives occupees'
            call wrd(f,norb)
            print*,  ' '
         endif
      endif
      write(2)(f(k),k=1,norb*(norb+1)/2)
      
      deallocate(aiikl)
      deallocate(aijil)
      stop
      return
      end
       subroutine fock0
      use module
      use mod_lirint
      implicit real(8) (a-h,o-x,z),logical(1)(y)
      integer(2) iint(4096),jnt(4096),knt(4096)
      dimension aaloc(2,4096)
      dimension loci(3,8)
      dimension aa2(2,8)
      yw=.false.
      ! Allocation de la matrice d'integrales a trois indices
      allocate(aiikl(norb,num1(norb+1)))
      allocate(aijil(norb,num1(norb+1)))
      open(30,file=ijcl31,status='old',form='unformatted')

      ! Lecture des integrales a 3 indices
      ind=4096
      aiikl=0.d0
      aijil=0.d0
      do
         ind=ind+1
         if(ind>4096) then
            ind=1
            read(30) iint,jnt,knt,aaloc
         endif
         i=iint(ind)
         if(i==0) exit
         j=jnt(ind)
         k=knt(ind)
         if(yw)print'(a,3i4,2f12.8)','i,j,k,aaloc1'
     *   ,i,j,k,aaloc(:,ind)
         call regensym3(i,j,k,loci,nintsy,aaloc(:,ind),aa2)
         do iintsy=1,nintsy
            if(intsy=='SYM') then
               i=loci(1,iintsy)
               j=loci(2,iintsy)
               k=loci(3,iintsy)
               aaloc(:,ind)=aa2(:,iintsy)
            endif
            if(yw)print'(a,3i4,2f12.8)','i,j,k,aa2'
     *      ,i,j,k,aa2(:,iintsy)
            ii=(j-1)*(j-2)/2+k
            aiikl(i,ii)=aaloc(1,ind)
            aijil(i,ii)=aaloc(2,ind)
         enddo
      enddo
      close(30)
      do i=1,norb
         do j=1,norb
            if(j>i) then
               jj=(j-2)*(j-1)/2+i
            else if(j<i) then
               jj=(i-2)*(i-1)/2+j
            else
               cycle
            endif
            aiikl(i,jj)=aijjj(j,i)
            aijil(i,jj)=aijjj(j,i)
            if(yw)print'(a,3i4,f12.8)','i,i,j,aaloc2',i,i,j,aijjj(j,i)
         enddo
      enddo
      ! Operateur de Fock
      ij=0 
      ij1=0 
      do i=1,norb
         do j=1,i
            ij=ij+1
            ff=hmono(i,j)
            if(i.eq.j) then
               if(yw)write(6,*)'fock i,j,hmono(ij)',i,j,ff
               do kk=1,ninac+(nelac+1)/2
                  mini=min0(i,k)
                  maxi=max0(i,k)
                  ff=ff+ajk(maxi,mini)*2
                  if(yw)write(6,*)'fock k,i,j,aj',
     *            k,i,j,ajk(maxi,mini)*2
                  ff=ff-ajk(mini,maxi)
                  if(yw)write(6,*)'fock k,i,j,ak',
     *            k,i,j,-ajk(mini,maxi)
               enddo
               goto 1
            endif
            if(yw)write(6,*)'fock i,j,hmono(ij)',i,j,hmono(i,j)
            ij1=ij1+1
            do kk=1,ninac+(nelac+1)/2
c               call adri(k,j,i,iadr)
c               ff=ff+bint(iadr)+bint(iadr)
               if(yw)print*,'i,j,ij',i,j,ij1
               ff=ff+aijil(k,ij1)+aijil(k,ij1)
               if(yw)write(6,'(a,3i4,f20.12)')'fock k,i,j,aijil(k,ij1)'
     *         ,k,i,j,aijil(k,ij1)
            enddo
 1          continue
            f(ij)=ff
            if(yw)print*,'ff',ff
         enddo
      enddo
c
c--   int d'echange
      ij=0
      ij1=0
      do i=1,norb
         do j=1,i
            ij=ij+1
            if(i==j) cycle
            ij1=ij1+1
            ff=f(ij)
            if(yw)write(6,*)'debut fock i,j,f(ij)',i,j,f(ij)
            if(i.eq.j) then
               goto 11
            endif
            do kk=1,ninac+(nelac+1)/2
               ff=ff-aiikl(k,ij1)
               if(yw)write(6,'(a,3i4,f20.12)')'fockx k,i,j,aiikl(i,ij)'
     *         ,k,i,j,aiikl(k,ij1)
            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)
         enddo
      enddo
!      if(nprint.ge.1.and.norb<20) then
         write(6,*)'operateur de fock au niveau de Fermi'
         call wrd(f,norb)
         print*,  ' '
!      endif
      write(2)(f(k),k=1,norb*(norb+1)/2)
      
      deallocate(aiikl)
      deallocate(aijil)
      return
      end
      
