      subroutine calmat
      use module
      use mod_ena
      integer,save :: premier_appel_calmat=1
      integer(8) :: ninta3,ninta4,igarda3,igarda4,iecra,igarda_sli
     *,nintutil
      common/elim/ ninta3,ninta4,igarda3,igarda4,iecra,igarda_sli
     *,nintutil
      logical yw
      yw=.false.
      if(premier_appel_calmat==1) then
         ninta3=0
         ninta4=0
         igarda3=0
         igarda4=0
         igarda_sli=0
         iecra=0
         premier_appel_calmat=0
         itest(23)=0
      endif
      !
      ! idebc pour calcul selectionne
      !
      !
      ! lecture des integrales
      !
!      allocate(itp1(nlpair),itp2(nlpair))
!      allocate(itp3(nlpair),itp4(nlpair))
      allocate(itp5(nlpair),itp6(nlpair))
      open(40,status='old',form='unformatted',file=ijcl41)
      if(yw)print*,'appel calmat4'
      if(w)print*,'calmat',ijcl41
      ycalmat3=.false.
      hab=0
      if(ytana) call cpu_time(t0)
      if(debug(1)) print*,'avant calmat4'
      call calmat4(ijcl41)
      if(ytana) call cpu_time(t1)
      if(ytana) t1=t1-t0
      close(40)
      open(30,file=ijcl31,status='old',form='unformatted')
      if(yhmono) then
         ycalmat3=.false.
      else
         ycalmat3=.true.
      endif
      if(yw)print*,'appel calmat3',trim(ijcl31)
      if(ytana) call cpu_time(t0)
      if(debug(1)) print*,'avant calmat3'
      call calmat3(ijcl31)
      if(ytana) call cpu_time(t2)
      if(ytana) t2=t2-t0
      close(30)
      if(yw)print*,'appel calmat2'
      if(ytana) call cpu_time(t0)
      if(debug(1)) print*,'avant calmat2'
      call calmat2
      if(ytana) call cpu_time(t3)
      if(ytana) t3=t3-t0
      !!!!!!!!!!!!!!!!!!!
      if(ytana) call cpu_time(t0)
      if(debug(1)) print*,'avant calmat0'
      call calmat0
      if(debug(1)) print*,'apres calmat0'
      if(ytana) call cpu_time(t4)
      if(ytana) t4=t4-t0
      if(ytana) print'(a,4f10.1)','calmat cpu',t1,t2,t3,t4
      deallocate(itp5,itp6)
      return
      end
       subroutine calmat4(fil)
      use module
      use mod_lirint
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(80) fil
      dimension aa(3),aa1(3)
      integer(8) :: ninta3,ninta4,igarda3,igarda4,iecra,igarda_sli
     *,nintutil
      common/elim/ ninta3,ninta4,igarda3,igarda4,iecra,igarda_sli
     *,nintutil
      dimension loci(4,8)
      dimension aa2(3,8)
      !
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! lecture des integrales a 4 indices
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      !
      !--------cas particulier gener='CAS'-------
      if(igener==0) then
         if(noac<4) return
         itest(21)=0
         rewind 40
! prise en compte de la symetrie de spin :
         if(syspin=='+'.or.syspin=='-') itest(21)=1
! Preparation a la fabrication d'une liste courte d'integrales
         itest(23)=0
         if(itest(30)==1) then
! preparation de l'ecriture d'une file d'integrales courte,
! pour accelerer les iterations a partir de la 3eme
            nintutil=0
! cas ou la 1ere iteration est complete (itest(22)/=1). 
! On peut fabriquer alors le fichier court des la 1ere iteration
            if(iter==1.and.itest(22)/=1) itest(23)=1
! cas ou la 1ere iteration est rapide (itest(22)==1)
! La premiere iteration ou on utilise toutes les integrales est
! la 2eme. Il faut faire la liste courte au cours de la 2eme iteration
            if(iter==2.and.itest(22)==1) itest(23)=1
            if(itest(23)==1) call ecrin4(0,0,0,0,aa1,0)
         endif
         do
            call lirin4(i,j,k,l,aa,40)
               if(itest(30)==1) then
               i30=i
               j30=j
               k30=k
               l30=l
            endif
            aa1=aa
            if(i==0) exit
            if(itype(i)/=2) cycle
            if(itype(j)/=2) cycle
            if(itype(k)/=2) cycle
            if(itype(l)/=2) cycle
            itest(24)=0
            if(w1)print'(a,4i4,3f22.18)','Int0 lue',i,j,k,l,aa
            call regensym(i,j,k,l,loci,nintsy,nintsy2,aa,aa2)
            if(w1)print*,'nintsy',nintsy,nintsy2
            do iintsy=1,nintsy
               if(intsy=='SYM') then
                  i=loci(1,iintsy)
                  j=loci(2,iintsy)
                  k=loci(3,iintsy)
                  l=loci(4,iintsy)
                  aa=aa2(:,iintsy)
               endif
               if(itest(23)==1) igarda4=igarda4+3
               if(w1)print'(a,4i4,3f22.18)','Int lue',i,j,k,l,aa
               if(.not.ytot.and.abs(aa(1))<10.d0) cycle
               if(w)print*,itype(i),itype(j),itype(k),itype(l)
               if(w)print*,itypi(itype(i),itype(j),itype(k),itype(l))
               call reoriac(i,j,k,l,aa)
               if(w)print'(a,4i3,3f22.18)','int reoriac',i,j,k,l,aa
               call mulcccc(i,j,k,l,aa)
            enddo
            if(itest(30)==1) then
! on ajoute l'int a la liste courte si elle a ete utile
! itest(23)==1 : on est a l'iteration ou il faut ecrire l'int
! itest(24)==1 : on l'ecrit, car elle a ete utile
               if(itest(23)==1) then
                  if(itest(24)==1) then
                     call ecrin4(i30,j30,k30,l30,aa1,1)
                     nintutil=nintutil+3
                     !print*,'nintutil',nintutil
                  endif
               endif
            endif
         enddo
         if(itest(30)==1) then
            if(itest(23)==1) then
               anintutil=nintutil
               call ecrin4(0,0,0,0,aa1,2)
!               write(75,'(a,i12,a,i12,a,f8.2,a)')
!     *         '.......... int a 4 indices ',igarda4,' ; utiles '
!     *         ,nintutil,' : soit ',100*anintutil/igarda4,'%$'
!               call scril
               print*,' '
               print*,'On fabrique une petite liste d''integrales'
               print*,' '

               ijcl41='IJCLLOC4'
               close(17)
               !print*,'int a 4 indices, on prend le petit fichier'
               itest(30)=0
            endif
         endif
         return
      endif
      !-------- Fin cas gener='CAS'------------------------
 
 
 
 
!      if(itest(10)==1) then
!      call cpu_time(t0)
!      do kk=1,100
!         i=11
!         j=10
!         k=3
!         l=1
!         ity=itypi(itype(i),itype(j),itype(k),itype(l))
!         call cpu_time(t3)
!         if(ity==19) call mulccoo(i,j,k,l,aa)
!         call cpu_time(t4)
!         print*,'ity',ity,t4-t3
!      enddo
!      call cpu_time(t1)
!      print*,'t',t1-t0
!      stop
!      endif
 
 
 
 
 
      if(syspin=='+'.or.syspin=='-') itest(21)=1
      itest(23)=0
      if(itest(30)==1) then
! preparation de l'ecriture d'une file d'integrales courte,
! pour accelerer les iterations a partir de la 3eme
         nintutil=0
! cas ou la 1ere iteration est complete (itest(22)/=1). 
! On peut fabriquer alors le fichier court des la 1ere iteration
         if(iter==1.and.itest(22)/=1) itest(23)=1
! cas ou la 1ere iteration est rapide (itest(22)==1)
! La premiere iteration ou on utilise toutes les integrales est
! la 2eme. Il faut faire la liste courte au cours de la 2eme iteration
         if(iter==2.and.itest(22)==1) itest(23)=1
!         if(itest(23)==1)
!     *   print*,' preparation de l''ecriture d''une file d''int courte'
         if(itest(23)==1) call ecrin4(0,0,0,0,aa1,0)
      endif
! Boucle sur les integrales du fichier
!
! Il y a plusieurs options, selon qu'on tient compte ou non de 
! la symetrie.
! CAS 1 : pas de symetrie au niveau ijkloc (itest(1)=0 dans ijkloc),
! l'info est passee a casdiloc dans ijcllocinfo par la donnee :
! intsy=.false.   --> pas de prise en compte de la symetrie
! CAS 2 : itest(1)=1 dans ijkloc. Alors ijkloc n'ecrit qu'une des 
! integrales equivalentes par symetrie, plus l'info pour recreer
! celles non ecrites. L'info est transmise par intsy=.true.
! CAS 2.1 : dans casdiloc, is0=0. Les integrales manquantes sont recrees,
! et un calcul sans symetrie est effectue
! CAS 2.2 : dans casdiloc, is0 est donne. Les integrales manquantes
!  ne sont pas recrees, mias leur valeur est multipliee par le nombre
! d'integrales equivalentes (dans regensym)
! Rem : le CAS 2.2 doit etre considere comme le cas standard
      do
         itest(24)=0
         ! on lit 1 int:
         call lirin4(i,j,k,l,aa,40)
         if(itest(30)==1) then
            i30=i
            j30=j
            k30=k
            l30=l
         endif
         aa1=aa
         if(i==0) exit
         if(w1)print'(a,4i3,3f22.16)','0int lue',i,j,k,l,aa
         ! On elimine les integrales non liees
         if(any(sli>=0.d0)) then
            call elim_int_non_liees((/i,j,k,l/),ybon)
            if(itest(23)==1) ninta4=ninta4+3
            if(.not.ybon) cycle
         endif
         ! On genere les nintsy int correspondantes par symetrie
         call regensym(i,j,k,l,loci,nintsy,nintsy2,aa,aa2)
! CAS 2.1 : nintsy=nb d'int equivalentes, nintsy2=1
! CAS 2.2 : nintsy=1, nintsy2=nb d'int equivalentes
         ! boucle sur les int qui se correspondent par sym
         do iintsy=nintsy,1,-1
            if(intsy=='SYM') then
               i=loci(1,iintsy)
               j=loci(2,iintsy)
               k=loci(3,iintsy)
               l=loci(4,iintsy)
               aa=aa2(:,iintsy)
            endif
            ! int <ijkl>
            if(w1)print'(a,4i3,3f22.16)','int lue',i,j,k,l,aa
            ! int trop petite ?
            if(itest(23)==1) igarda_sli=igarda_sli+3
            if(all(dabs(aa*nintsy2)<si)) cycle
            if(itest(23)==1) igarda4=igarda4+3
            !print'(2i6,4d15.6)',ninta4,igarda4,si,aa
            !w=i==1.and.j==7.and.k==1.and.l==2
            !w1=w
            ! 1 ligne de mise au point
            if(.not.ytot.and.abs(aa(1))<10.d0) cycle
            if(w)print*,itype(i),itype(j),itype(k),itype(l)
            if(w)print*,itypi(itype(i),itype(j),itype(k),itype(l))
            ! on reordonne les indices
            call reoriac(i,j,k,l,aa)
            if(w)print'(a,4i3,3f22.18)','int reoriac',i,j,k,l,aa
            ! type de l'int (itype=1,2,3 pour occ,CAS,virt.
            ity=itypi(itype(i),itype(j),itype(k),itype(l))
            ! 4 lignes de mise au point
            if(itest(20)/=0) then
               if(ity/=itest(20)) cycle
            endif
            if(ity==0) stop 'ity=0'
 
            if(ity==5) call mulvvoo(i,j,k,l,aa)
            if(ity==25) call mulcccv(i,j,k,l,aa)
            if(ity==24) call mulccco(i,j,k,l,aa)
            if(ity==18) call mulccvv(i,j,k,l,aa)
            if(ity==19) call mulccoo(i,j,k,l,aa)
            if(ity==26) call mulcccc(i,j,k,l,aa)
            if(ity==23) call mulcocv(i,j,k,l,aa)
            if(ity==20) call mulcvvo(i,j,k,l,aa)
            if(ity==21) call mulcoov(i,j,k,l,aa)
 
            ! itest(22)=1: acceleration de la 1ere iteration si le
            ! vecteur d'essai est dans le CAS
            if(iter==1.and.itest(22)==1) cycle
            if(igener>1) then
               if(ity==1) call mulvvvv(i,j,k,l,aa)
               if(ity==2) call muloooo(i,j,k,l,aa)
            endif
            if(ity==9) call mulvvvo(i,j,k,l,aa)
            if(ity==16) call mulooov(i,j,k,l,aa)
 
            if (ity==17) call mulcvvv(i,j,k,l,aa)
            if(ity==22) call mulcooo(i,j,k,l,aa)
         enddo
         if(itest(30)==1) then
! on ajoute l'int a la liste courte si elle a ete utile
! itest(23)==1 : on est a l'iteration ou il faut ecrire l'int
! itest(24)==1 : on l'ecrit, car elle a ete utile
            if(itest(23)==1) then
               !if(itest(24)/=1) print*,'int non gardee'
               if(itest(24)==1) then
                  call ecrin4(i30,j30,k30,l30,aa1,1)
                  nintutil=nintutil+3
!                  print*,'gardee',i30,j30,k30,l30
!               else
!                  print*,'sautee',i30,j30,k30,l30
               endif
!               if(itest(24)==1) print'(a,2i3,i12,10i6)','int gardee',
!     *         nintsy,nintsy2,ninta4,igarda4,nintutil
            endif
         endif
      enddo
      if(itest(30)==1) then
         if(itest(23)==1) then
            anintutil=nintutil
            call ecrin4(0,0,0,0,aa1,2)
!            write(75,'(a,i12,a,i12,a,f8.2,a)')
!     *      '.......... int a 4 indices ',igarda4,' ; utiles '
!     *      ,nintutil,' : soit ',100*anintutil/igarda4,'%$'
!            call scril
!            print*,' '
            if(nintutil<ninta4) then
               ijcl41='IJCLLOC4'
               close(17)
               !print*,'int a 4 indices, on prend le petit fichier'
            endif
            itest(30)=0
         endif
      endif
      itest(21)=0
      return
      end
       subroutine calmat3(fil)
      use module
      use mod_lirint
      use mod_fock
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(80) fil
      dimension aa(2)
      integer(8) :: ninta3,ninta4,igarda3,igarda4,iecra,igarda_sli
     *,nintutil
      common/elim/ ninta3,ninta4,igarda3,igarda4,iecra,igarda_sli
     *,nintutil
      dimension loci(3,8)
      dimension aa2(2,8)
      !
      ! lecture des integrales a 3 indices
      !
      rewind 30
      if(igener==0) then
         itest(21)=0
         do
            call lirin3(i,j,k,aa,30)
            if(i==0) exit
            if(itype(i)/=2) cycle
            if(itype(j)/=2) cycle
            if(itype(k)/=2) cycle
            if(w1)print'(a,4i4,3f12.8)','calmat3 0int lue',i,j,i,k,aa
            !
            !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
            ! Valeurs de l'integrale a 3 indices :
            ! i,i,j,k : aa(1)=
            ! i,j,i,k : aa(2)
            !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
            !
            call regensym3(i,j,k,loci,nintsy,aa,aa2)
            do iintsy=1,nintsy
               if(intsy=='SYM') then
                  i=loci(1,iintsy)
                  j=loci(2,iintsy)
                  k=loci(3,iintsy)
                  aa=aa2(:,iintsy)
               endif
               if(w1)print'(a,4i4,3f12.8)','calmat3 int lue',i,j,i,k,aa
               if(itype(j)<itype(k)) call ech(j,k)
               if(w)print'(a,4i3,3f12.8)','calmat3 int reor',i,j,i,k,aa
               if(.not.ytot.and.abs(aa(1))<10.d0) cycle
               ity=itypi(2,2,2,2)
               call corrf0(ity,j,k)
               call mulcecc(i,j,k,aa+(/0.d0,corrf/))
            enddo
         enddo
         return
      endif
      if(syspin=='+'.or.syspin=='-') itest(21)=1
      do
         call lirin3(i,j,k,aa,30)
         if(i==0) then
            if(itest(23)==1) then
               print'(a,d12.4)',
     *         '           - elimination des integrales par sli '
               write(75,'(a,i12,a,i12,a,f8.2,a)')
     *         '.......... 4 indices : lues:',ninta4,'   gardees:',
     *         igarda_sli,' : soit ',(100.d0*igarda_sli)/ninta4,'%$'
               call scril
               print*,' '
               print'(a,d12.4)',
     *         '           - elimination des integrales par si  si= ',si
               write(75,'(a,i12,a,i12,a,f8.2,a)')
     *         '.......... 4 indices : lues:',igarda_sli,'   gardees:',
     *         igarda4,' : soit ',(100.d0*igarda4)/igarda_sli,'%$'
               call scril
               write(75,'(a,i12,a,i12,a,f8.2,a)')
     *         '.......... 3 indices : lues:',ninta3,'   gardees:',
     *         igarda3,' : soit ',(100.d0*igarda3)/ninta3,'%$'
               call scril
               print*,' '
               print'(a,d12.4)',
     *         '           - elimination des integrales qui n''ont'//
     *         ' pas ete utilisees dans l''iteration precedente'
               write(75,'(a,i12,a,i12,a,f8.2,a)')
     *         '.......... int a 4 indices ',igarda4,' ; utiles '
     *         ,nintutil,' : soit ',(100.*nintutil)/igarda4,'%$'
               call scril
               print*,' '
            endif
            iecra=1
            exit
         endif
         if(iecra==0) ninta3=ninta3+2
         if(all(dabs(aa)<si)) cycle
         if(iecra==0) igarda3=igarda3+2
         !print*,ninta3,igarda3
         !
         !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         ! Valeurs de l'integrale a 3 indices :
         ! i,i,j,k : aa(1)=
         ! i,j,i,k : aa(2)
         !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
         !
         !w=i==1.and.j==11.and.k==9
         !  w1=w
         !  w2=w
         call regensym3(i,j,k,loci,nintsy,aa,aa2)
         do iintsy=1,nintsy
            if(intsy=='SYM') then
               i=loci(1,iintsy)
               j=loci(2,iintsy)
               k=loci(3,iintsy)
               aa=aa2(:,iintsy)
            endif
            if(w1)print'(a,4i3,3f12.8)','calmat3 int lue',i,j,i,k,aa
            if(itype(j)<itype(k)) call ech(j,k)
            if(w)print'(a,4i3,3f12.8)','calmat3 int reor',i,j,i,k,aa
            if(.not.ytot.and.abs(aa(1))<10.d0) cycle
            !
            ity=itypi(itype(i),itype(j),itype(i),itype(k))
            if(w)print*,itype(i),itype(j),itype(k)
            if(w)print*,itypi(itype(i),itype(j),itype(i),itype(k))
            if(itest(20)/=0) then
               if(ity/=itest(20)) cycle
            endif
            ! Inclusion de l'operateur de Fock
            call corrf0(ity,j,k)
            if(w)print*,'int corr',aa,corrf,aa(2)+corrf
            if(ity==0) stop 'ity=0'
            if(igener>1) then
               if(ity==1) call mulvvv(i,j,k,aa+(/0.d0,corrf/))
               if(ity==2) call mulooo(i,j,k,aa+(/0.d0,corrf/))
            endif
            if(ity==9) call mulvvo(i,j,k,aa+(/0.d0,corrf/))
            if(ity==15) call muloov(i,j,k,aa+(/0.d0,corrf/))
            if(ity==3) call mulvoo(i,j,k,aa+(/0.d0,corrf/))
            if(ity==4) call mulovv(i,j,k,aa+(/0.d0,corrf/))
         
            if(ity==25) call mulcecv(i,j,k,aa+(/0.d0,corrf/))
            if(ity==24) call mulceco(i,j,k,aa+(/0.d0,corrf/))
            if(ity==18) then
               if(itype(i)==2) call mulcevv(i,j,k,aa+(/0.d0,corrf/))
               if(itype(i)==3) call mulccve(i,j,k,aa+(/0.d0,corrf/))
            endif
            if(ity==17) call mulcvvev(i,j,k,aa+(/0.d0,corrf/))
            if (ity==26) call mulcecc(i,j,k,aa+(/0.d0,corrf/))
            if(ity==19) then
               if(itype(i)==2) call mulceoo(i,j,k,aa+(/0.d0,corrf/))
               if(itype(i)==1) call mulccoe(i,j,k,aa+(/0.d0,corrf/))
            endif
            if(ity==23) call mulceov(i,j,k,aa+(/0.d0,corrf/))
            if(ity==20) call mulcveo(i,j,k,aa+(/0.d0,corrf/))
            if(ity==21) call mulcoev(i,j,k,aa+(/0.d0,corrf/))
            if(ity==22) call mulcoeo(i,j,k,aa+(/0.d0,corrf/))
         enddo
      enddo
      itest(21)=0
      return
      end
       subroutine corrf0(ity,j,k)
      use module
      use mod_lirint
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      !
      ! Inclusion de l'operateur de Fock
      !
      yw=.false.
      corrf=0.d0
      jsgn=1
      corrf=f(num1(max(j,k)+1)+min(j,k))*jsgn
      if(yw)print*,'corrf avant signe',corrf,jsgn
      if(yw)print*,'ity',ity
      if(nelac==0) then
         ! ==> corriger : <V O1|V O2> : + <O1|O2>
         !                <O O1|O O2> : + <O1|O2>
         !                <V V1|V V2> : - <V1|V2>
         !                <O V1|O V2> : - <V1|V2>
         !                <O1 V|V1 V> : - <O1|V2>
         !    ne pas corriger : <O O1|O V1>
         if(ity==15) corrf=0.d0
         if(ity==22) corrf=0.d0
         if(any(ity==(/1,9,25,24,17,18,26,23,20,4,21/))) corrf=-corrf
         if(ity==19.and.itype(j)==2) corrf=-corrf
         ! s'il y a des actives, on corrige comme si on avait des virt
      else if(nelac==1) then
      ! corriger les integrales : <O V1|O V2> par - <V1|V2>/2
      ! (ou V represente V ou C)
      ! Ne pas corriger les autres integrales
         corrf2=corrf/2
         if(w)print*,'calmat corrf2',corrf2
         if(any(ity==(/2,3/))) corrf=corrf/(nelac+1)
         if(ity==19.and.itype(j)==1) corrf=corrf/(nelac+1)
         if(any(ity==(/9,15,24,20,22,23/))) corrf=corrf/(nelac)
         if(any(ity==(/4,21/))) corrf=-corrf/2
         if(ity==19.and.itype(j)==2) corrf=-corrf/2
         if(any(ity==(/26,17,25,1,18/))) corrf=0.d0
      else
              if(yw)print*,'corrf avant division',corrf
         if(any(ity==(/26,17,25,1,4,18,21/))) corrf=corrf/(nelac-1)
         if(any(ity==(/2,3/))) corrf=corrf/(nelac+1)
         if(ity==19.and.itype(j)==1) corrf=corrf/(nelac+1)
         if(ity==19.and.itype(j)==2) corrf=corrf/(nelac-1)
         if(any(ity==(/9,15,24,20,22,23/))) corrf=corrf/(nelac)
      endif
      if(yw)print*,'corrf',j,k,corrf,ity
      return
      end
       subroutine calmat2
      use module
      use mod_lirint
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      integer a,b,x,y,z,a0,b0,x0,y0
      yw=.false.
      !
      ! lecture des integrales a 2 indices
      !
      !=======================================
      ! aijjj(i,j) = <ijjj>
      ! ajk(j,i) = <iijj>  j<i
      ! ajk(i,j) = <ijij>  j<i
      !=======================================
      if(yw)print*,'entree calmat2'
      if(itest(20)/=0) return
      itest(21)=0
      ! Integrales xxxy
      !call script(aijjj,36,36,36,36)
      !print*,'AIJJJ',aijjj(79,78),aijjj(78,79)
      !print*,'AIJJJ',aijjj(77,80),aijjj(80,77)
      do y0=1,noac
         y=numac(y0)
         do x0=1,noac
            if(x0==y0) cycle
            x=numac(x0)
            if(.not.ytot.and.abs(aijjj(y,x))<10.d0) cycle
            if(w1)print'(a,4i3,3f12.8)','calmat2 int xxxy lue',
     *      x,x,x,y,aijjj(y,x)
            call corrf0(26,y,x)
            call mulccccd(x,x,x,y,aijjj(y,x)+corrf)
            call mulccccd(x,x,y,x,aijjj(y,x)+corrf)
            !print'(a,4i4,2f12.8)','XXX',x0,y0,x,y,aijjj(y,x),corrf
         enddo
      enddo
      ! Integrales xxyy
      do y0=1,noac
         y=numac(y0)
         do x0=1,y0-1
            x=numac(x0)
            if(.not.ytot.and.abs(ajk(y,x))<10.d0) cycle
            if(w1)print'(a,4i3,3f12.8)','calmat2 int xxyy lue',
     *      x,x,y,y,ajk(y,x)
            call corrf0(26,y,x)
            call mulccccd(x,x,y,y,ajk(x,y))
            call mulccccd(x,y,y,x,ajk(x,y))
         enddo
      enddo
      if(igener==0) return
      ! Integrales xxxa
      do x0=1,noac
         x=numac(x0)
         do a0=1,nvirt
            b=numvir(a0)
            if(.not.ytot.and.abs(aijjj(b,x))<10.d0) cycle
            if(w1)print'(a,4i3,3f12.8)','calmat2 int xxxa lue',
     *      x,x,x,b,aijjj(b,x)
            call corrf0(25,b,x)
            if(w)print*,'calmat2 appel mulcccvd'
            call mulcccvd(x,x,x,b,aijjj(b,x)+corrf,0.d0)
         enddo
      enddo
      ! Integrales xxaa
      do a0=1,nvirt
         a=numvir(a0)
         do x0=1,noac
            x=numac(x0)
            j=min(x,a)
            i=max(x,a)
            if(.not.ytot.and.abs(ajk(j,i))<10.d0) cycle
            if(w1)print'(a,4i3,3f12.8)','calmat2 int xxaa lue',
     *      x,x,a,a,ajk(j,i),ajk(i,j)
            call corrf0(18,a,x)
            if(igener>1)call mulccvvd(x,x,a,a,ajk(j,i),ajk(j,i))
            call mulcvcvd(x,a,x,a,ajk(i,j),ajk(j,i))
         enddo
      enddo
      ! Integrales xxoo
      do i0=1,ninac
         ii=numin(i0)
         do x0=1,noac
            x=numac(x0)
            j=min(x,ii)
            i=max(x,ii)
            !w=x==12.and.ii==6
            !w1=w
            if(.not.ytot.and.abs(ajk(j,i))<10.d0) cycle
            if(w1)print'(a,4i3,3f12.8)','calmat2 int xxoo lue',
     *      x,x,ii,ii,ajk(j,i),ajk(i,j)
            call corrf0(19,ii,x)
            if(igener>1)call mulccood(x,x,ii,ii,ajk(j,i),ajk(i,j))
            call mulcocod(x,ii,x,ii,ajk(i,j),ajk(j,i))
            !w=.false.
            !w1=w
         enddo
      enddo
      ! Integrales xxxo
      do i0=1,ninac
         i=numin(i0)
         do x0=1,noac
            x=numac(x0)
            if(.not.ytot.and.abs(aijjj(i,x))<10.d0) cycle
            if(w1)print'(a,4i3,3f12.8)','calmat2 int xxxo lue',
     *      x,x,x,i,aijjj(i,x)
            call corrf0(24,i,x)
            call mulcccod(x,x,x,i,aijjj(i,x)+corrf,0.d0)
         enddo
      enddo
      ! Integrales iiaa
      do i0=1,ninac
         i=numin(i0)
         do j0=1,nvirt
            a=numvir(j0)
            if(.not.ytot.and.abs(ajk(a,i))<10.d0) cycle
            if(w1)print'(a,4i3,3f12.8)','calmat2 int iiaa lue',
     *      i,i,a,a,ajk(i,a)
            call mulvovodx(a,i,a,i,0.d0,ajk(i,a))
         enddo
      enddo
      if(igener<2) return
      ! Integrales xooo
      do i0=1,ninac
         i=numin(i0)
         do x0=1,noac
            x=numac(x0)
            if(.not.ytot.and.abs(aijjj(x,i))<10.d0) cycle
            if(w1)print'(a,4i3,3f12.8)','calmat2 int xooo lue',
     *      x,i,i,i,aijjj(x,i)
            call corrf0(22,i,x)
            call mulcoood(x,i,i,i,aijjj(x,i)+corrf,0.d0)
         enddo
      enddo
      ! Integrales xaaa
      do a0=1,nvirt
         a=numvir(a0)
         do x0=1,noac
            x=numac(x0)
            if(.not.ytot.and.abs(aijjj(x,a))<10.d0) cycle
            if(w1)print'(a,4i3,3f12.8)','calmat2 int xaaa lue',
     *      x,a,a,a,aijjj(x,a)
            call corrf0(17,a,x)
            call mulcvvvd(x,a,a,a,aijjj(x,a)+corrf,0.d0)
         enddo
      enddo
      ! Integrales abab
      do i0=1,nvirt
         i=numvir(i0)
         do j0=1,i0-1
            j=numvir(j0)
            if(.not.ytot.and.abs(ajk(j,i))<10.d0) cycle
            if(w1)print'(a,4i3,3f12.8)','calmat2 int abab lue',
     *      i,j,i,j,ajk(j,i)
            call mulvvvvdx(i,i,j,j,ajk(j,i),ajk(j,i))
            call mulvvvvdx(i,j,i,j,ajk(i,j),ajk(j,i))
         enddo
      enddo
      ! Integrales abbb
      do i0=1,nvirt
         i=numvir(i0)
         do j0=1,nvirt
            j=numvir(j0)
            if(j==i)cycle
            if(.not.ytot.and.abs(aijjj(i,j))<10.d0) cycle
            if(w1)print'(a,4i3,3f12.8)','calmat2 int abbb lue',
     *      i,j,j,j,aijjj(i,j)
            call corrf0(1,j,i)
            call mulvvvvdx(i,j,j,j,aijjj(i,j)+corrf,aijjj(i,j)+corrf)
         enddo
      enddo
      ! Integrales ijij
      do i0=1,ninac
         i=numin(i0)
         do j0=1,i0-1
            j=numin(j0)
            if(.not.ytot.and.abs(ajk(j,i))<10.d0) cycle
            if(w1)print'(a,4i3,3f12.8)','calmat2 int ijij lue',
     *      i,j,i,j,ajk(j,i)
            call muloooodx(i,i,j,j,ajk(j,i),ajk(j,i))
            call muloooodx(i,j,i,j,ajk(i,j),ajk(j,i))
         enddo
      enddo
      ! Integrales ijjj
      do i0=1,ninac
         i=numin(i0)
         do j0=1,ninac
            j=numin(j0)
            if(j==i)cycle
            if(.not.ytot.and.abs(aijjj(i,j))<10.d0) cycle
            if(w1)print'(a,4i3,3f12.8)','calmat2 int ijjj lue',
     *      i,j,j,j,aijjj(i,j)
            call corrf0(2,j,i)
            call muloooodx(i,j,j,j,aijjj(i,j)+corrf,aijjj(i,j)+corrf)
         enddo
      enddo
      if(igener<3) return
      ! Integrales ajjj
      do a0=1,nvirt
         a=numvir(a0)
         do j0=1,ninac
            j=numin(j0)
            if(.not.ytot.and.abs(aijjj(a,j))<10.d0) cycle
            if(w1)print'(a,4i3,3f12.8)','calmat2 int ajjj lue',
     *      j,j,j,a,aijjj(a,j)
            call corrf0(15,j,a)
            call mulooovdx(a,j,j,j,aijjj(a,j)+corrf,aijjj(a,j)+corrf)
         enddo
      enddo
      ! Integrales aaaj
      do i0=1,nvirt
         a=numvir(i0)
         do j0=1,ninac
            j=numin(j0)
            if(.not.ytot.and.abs(aijjj(j,a))<10.d0) cycle
            if(w1)print'(a,4i3,3f12.8)','calmat2 int aaaj lue',
     *      a,a,a,j,aijjj(j,a)
            call corrf0(9,j,a)
            call mulvvvodx(a,a,a,j,aijjj(j,a)+corrf,0.d0)
         enddo
      enddo
      if(igener/=4) return
      ! Integrales iiaa
      do i0=1,ninac
         i=numin(i0)
         do j0=1,nvirt
            a=numvir(j0)
            if(.not.ytot.and.abs(ajk(a,i))<10.d0) cycle
            if(w1)print'(a,4i3,3f12.8)','calmat2 int iiaa lue',
     *      i,i,a,a,ajk(i,a)
            call mulvvoodx(a,a,i,i,ajk(i,a),dum)
         enddo
      enddo
      return
      end
       subroutine calmat0
      use module
      use mod_lirint
      integer x,x0,y,y0
      !
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! Prise en compte des elements de l'operateur de Fock
      ! mise de l'operateur de fock dans les integrales bielectroniques
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! 1) nelac=0
      ! *  <O1|O2>     O O1  -->   V1 V2
      !                O O2  -->   V1 V2
      ! <O1|O2> + <V1 O1|V1 O2> + <V2 O1|V2 O2> - <O O1|O O2>
      !                O1  -->  V
      !                O2  -->  V
      ! <O1|O2> + <V O1|V O2>
      !
      ! *  <V1|V2>     O1 O2  -->   V V1
      !                O1 O2  -->   V V2
      ! <V1|V2> + <V V1|V V2> - <V1 O1|V2 O1> - <O2 V1|O2 V2>
      ! *              O1  -->  V1
      !                O1  -->  V2
      ! <V1|V2> - <V1 O1|V2 O1>
      !
      ! *  <O1|V1>     O1 O  -->   V V1
      !                O     -->   V
      ! <O1|V1> + <O1 V|V1 V> - <O1 O|V1 O>
      ! *              O1  -->  V1
      !                -->
      ! <O1|V1>
      ! ==> corriger : <V O1|V O2> : + <O1|O2>
      !                <O O1|O O2> : + <O1|O2>
      !                <V V1|V V2> : - <V1|V2>
      !                <O V1|O V2> : - <V1|V2>
      !                <O1 V|V1 V> : - <O1|V2>
      !    (Il manque l'element de matrice <O1  -->  V1 || F >)
      !     rajouter le calcul direct de <O1  -->  V1 || F > et
      !     <O1  -->  C1 || F >, soit mulfov et mulfoc
      !
      ! 2) nelac>1
      !
      ! on remarque que np+nC-nt=nelac
      ! F apparait en + dans np+nC int, en - dans nt int
      ! au total, il apparait nelac fois
      ! MOINS l'int nulle <xxxy>
      ! donc si on a o-->o                 F apparait nelac+1 fois
      ! donc si on a v ou C-->v ou C       F apparait nelac-1 fois
      ! donc si on a o-->v ou C            F apparait nelac fois
      ! ==> on corrige <xyxz> par F/(nelac+i), i=-1,0, ou 1
      !
      ! 3) nelac .eq. 1 :
      ! dans la formule precedente, il y a probleme avec le
      ! denominateur (nelac-1)
      ! ca correspond au cas : (v ou C) --> (v ou C)
      !             O O'  -->   V1 V
      !             O O'  -->   V2 V
      !<V1|V2>+<V V1|V V2>+<C V1|C V2>-<O V1|O V2>-<O' V1|O' V2>
      !             O O'  -->   V1
      !             O O'  -->   V2
      !<V1|V2>+<C V1|C V2>+<C' V1|C' V2>-<O V1|O V2>-<O' V1|O'V2>
      !             O  -->   V1 V
      !             O  -->   V2 V
      ! <V1|V2> + <V V1|V V2> - <O V1|O V2>
      !             O  -->   V1
      !             O  -->   V2
      ! <V1|V2> + <C V1|C V2> - <O V1|O V2>
      !                -->   V1
      !                -->   V2
      ! <V1|V2>
      ! Il faut distinguer les calculs selon le nombre de trous
      ! 0 trou : ajout special d'un element F
      ! 1 trou : corriger les integrales : <O V1|O V2> par - <V1|V2>
      ! 2 trous : corriger les integrales : <O V1|O V2> par - <V1|V2>/2
      ! Ne pas corriger <V V1|V V2> (ou V represente V ou C)
      ! rajouter le calcul par F de <V1|V2> <C1|V2> <C1|C2>
      ! soit mulfvv mulfxv mulfxx
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      !
      ! Lecture de l'operateur de Fock
      !
 
      if(w1)print*,'CALMAT000',NELAC,1+nlco,nlcv
      if(nelac==1) then
         do j0=1+nlco,nlcv+nlco
            j=ilc(j0)
            do i0=1+nlco,j0-1
               i=ilc(i0)
               ii=num1(j+1)+i
               if(.not.ytot.and.abs(f(ii))<10.d0) cycle
               if(w1)print*,'CALMAT00vv',i,j,ii
               call mulfvv(f(ii),i,j)
            enddo
         enddo
         do x0=1,noac
            x=numac(x0)
            do y0=1+x0,noac
               y=numac(y0)
               ii=num1(y+1)+x
               !print*,'x0,y0,x,y',x0,y0,x,y,num_oav(x),num_oav(y)
               if(.not.ytot.and.abs(f(ii))<10.d0) cycle
               if(w1)print*,'CALMAT00xx',x,y,ii
               call mulfxx(f(ii),x0,y0)
            enddo
         enddo
         do j0=1+nlco,nlcv+nlco
            j=ilc(j0)
            do x0=1,noac
               x=numac(x0)
               ii=num1(max(x,j)+1)+min(x,j)
               if(.not.ytot.and.abs(f(ii))<10.d0) cycle
               if(w1)print*,'CALMAT00xv',x,j,ii
               call mulfxv(f(ii),num_oav(x),j)
            enddo
         enddo
      else if(nelac==0) then
         do ipair=1,nlpair
            i=ilpair(2,ipair)
            j=ilpair(1,ipair)
            ii=num1(i+1)+j
            if(.not.ytot.and.abs(f(ii))<10.d0) cycle
            if(w1)print*,'CALMAT00ia',i,j,ii
            call mulfov(f(ii),i,j)
         enddo
         do j0=1,nlco
            j=ilc(j0)
            do x0=1,noac
               x=numac(x0)
               ii=num1(max(x,j)+1)+min(x,j)
               if(.not.ytot.and.abs(f(ii))<10.d0) cycle
               if(w1)print*,'CALMAT00ox',x,j,ii
               call mulfoc(f(ii),num_oav(x),j)
            enddo
         enddo
         do j0=1+nlco,nlcv
            j=ilc(j0)
            do x0=1,noac
               x=numac(x0)
               ii=num1(max(x,j)+1)+min(x,j)
               if(.not.ytot.and.abs(f(ii))<10.d0) cycle
               if(w1)print*,'CALMAT00xv',x,j,ii
               call mulfxv(f(ii),num_oav(x),j)
            enddo
         enddo
      endif
      return
      end
       subroutine reoriac(i,j,k,l,aa)
      use module
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      dimension aa(3),jj(1)
      norb1=norb+1
      if(w)print*,'reoriac   i,j,k,l',i,j,k,l
      i=i+(itype(i)-1)*norb1
      j=j+(itype(j)-1)*norb1
      k=k+(itype(k)-1)*norb1
      l=l+(itype(l)-1)*norb1
      if(w)print*,'reoriac   i,j,k,l',i,j,k,l
      jj=maxloc((/i,j,k,l/))
      if(w)print*,'reoriac jj',jj
      if(jj(1)==2) then
         call ech(i,j)
         call ech(k,l)
      else if(jj(1)==3) then
         call ech(i,k)
         call ech(j,l)
      else if(jj(1)==4) then
         call ech(i,l)
         call ech(j,k)
      endif
      jj=maxloc((/j,k,l/))
      if(w)print*,'reoriac jj',jj
      if(jj(1)==2) then
         call ech(j,k)
         call echa(aa(1),aa(3))
      else if(jj(1)==3) then
         call ech(j,l)
         call echa(aa(2),aa(3))
      endif
      jj=maxloc((/k,l/))
      if(w)print*,'reoriac jj',jj
      if(jj(1)==2) then
         call ech(k,l)
         call echa(aa(1),aa(2))
      endif
      if(w)print*,'reoriac   i,j,k,l',i,j,k,l
      i=mod(i,norb1)
      j=mod(j,norb1)
      k=mod(k,norb1)
      l=mod(l,norb1)
      if(w)print*,'reoriac   i,j,k,l',i,j,k,l
      return
      end
       subroutine ech(i,j)
      ii=i
      i=j
      j=ii
      return
      end
       subroutine echa(i,j)
      double precision i,j,ii
      ii=i
      i=j
      j=ii
      return
      end
       subroutine elim_int_non_liees(ijkl,ybon)
      use module
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      dimension y(4)
      dimension ijkl(4)
      if (liens .ne. 'KIJ'.and.liens.ne.'FILE' ) then 
           ybon=.true.
           return
      endif
      y=(/.true.,.false.,.false.,.false./)
      n=1
      ybon=.false.
      do i=1,4
         do j=1,4
            if(y(j)) then
               do k=1,4
                  if(k==j) cycle
                  if(.not.y(k)) then
                     if(yl(ijkl(k),ijkl(j))) then
                        y(k)=.true.
                        n=n+1
                        if(n==4)ybon=.true.
                     endif
                  endif
               enddo
            endif
         enddo
      enddo
            !print*,ijkl,ybon,'   ',y
      return
      end
