      subroutine gamma2(esp1,ab)
c
c-----------------------------------------------------------------------
c     calucl gamma2
c     principe
c      - en donnee : &dav calcul='G2' ...
c      execution :
c       1) on fait un calcul 'MD', puis on entre dans la subr gamma2
c       2) on stocke le vecteur propre (dans ab)
c       3) on relit les integrales comme pour un calc normal
c          c'est le "call lirint"
c       4) pour chaque integrale lue <ijkl>, on calcule l'element de
c          gamma2 <ijkl> (il y a bijection entre les 2)
c       5) dans chaque boucle interne du programme, tout se passe
c          comme pour un calcul 'M', sauf qu'on calcule l'element
c          gamma2 <ijkl> (appel stoga2)
c       6) pareil pour les <ijij> a partir de diagon
c       7) on finit en stockant <0111>
c-----------------------------------------------------------------------
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |     esp1      |       ab      |
c
 
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter(maxda3=300)
      include 'maxorb.prm'
      common/dim/iadri ; integer(8) iadri
      dimension esp1(iadri),ab(iadri)
      common/opt/ihab,calcul
      character*3 calcul
      common /born/lbor,nmulr,iadri1,iadri2,iadri3,maxl,mmdet,maxrac
      common/svfil/fil11
      common /det/ndet,mdet(50),nbdet_cas
      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
      common/l40/ g2(maxorb,maxorb),g2a(maxorb*(maxorb+1)/2)
     *,g2b(maxorb*(maxorb+1)/2),dum(3*maxorb*(maxorb+1)/2
     *-maxorb*maxorb+2)
      common/g2/lg2,ig2,lg2p,ig2p,lg2m,ig2m,ng2,yg2,yga2
      character*40 fil11
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
 
      common/espa2/ inti(1024,22),intj(1024,22),intk(1024,22),
     *intl(1024,22),aaint(1024,22)
      common/pr/nprint,mprint(10)
      common/test/itest(100)
      yw=nprint.ge.3
c
      print*,' '
      print*,'================================================== '
      print*,'                      GAMMA2 '
      print*,'================================================== '
      print*,' '
      calcul='M'
      iadri1=iadri+1
      lbor=0
      nmulr=iadri
      maxl=iadri
      mmdet=iadri
      nessai=2
      ifiess=11
c
c
c
c      open(11,file=fil11,status='old',form='unformatted')
c      read(11)
c      read(11)
c      call lir8(ab,ndet,11)
      call lire(ab,1,ndet,21)
      open(81,file='B81',form='unformatted',status='new')
      call ecr8bl(ab,ndet,81)
      if(yw) then
         do k=1,ndet
            print*,'gamma2 vecteur',k,ab(k),esp1(iadri+k)
         enddo
      endif
      call lirint(esp1)
c      print*,'fil56',inti(1,1),intj(1,1),intk(1,1),intl(1,1)
c      print*,'fil57',inti(1,2),intj(1,2),intk(1,2),intl(1,2)
c      print*,'fil58',inti(1,3),intj(1,3),intk(1,3),intl(1,3)
c      print*,'appel diagon'
c      goto 1000
      call diagon(esp1,ab,1)
      kl=0
      do k=1,norb
         do l=1,k-1
            kl=kl+1
            call disin1(lg2p,ig2p,57,k,l,k,l,g2a(kl),2)
            call disin1(lg2m,ig2m,58,k,l,k,l,g2b(kl),3)
         enddo
      enddo
      do k=1,norb
         do l=1,norb
            call disin1(lg2,ig2,56,k,l,k,l,g2(k,l),1)
         enddo
      enddo
c 1000 continue
      if(yw)print*,'ecrit lg2,ig2,lg2p,ig2p,lg2m,ig2m'
     *,lg2,ig2,lg2p,ig2p,lg2m,ig2m
      i=0
      j=1
      call disin1(lg2,ig2,56,i,j,j,j,g2(j,j),1)
      call disin1(lg2p,ig2p,57,i,j,j,j,g2(j,j),2)
      call disin1(lg2m,ig2m,58,i,j,j,j,g2(j,j),3)
      if(yw)print*,'fil56',inti(1,1),intj(1,1),intk(1,1),intl(1,1)
      if(yw)print*,'fil57',inti(1,2),intj(1,2),intk(1,2),intl(1,2)
      if(yw)print*,'fil58',inti(1,3),intj(1,3),intk(1,3),intl(1,3)
      if(yw)print*,'gamma2 lg2,ig2',lg2,ig2
      call disin2(1,56)
      call disin2(2,57)
      call disin2(3,58)
      close(56)
      close(57)
      close(58)
      close(81,status='delete')
      if(itest(70).eq.1) then
         print *,'CALCUL GAMMA2 BESTIAL'
         call gamma2db(esp1,ab)
      endif
      return
      end
       subroutine gamma2db(esp1,ab)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |     esp1      |       ab      |
c
 
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter(maxda3=300,maxorbcas=16)
      include 'maxorb.prm'
      common/dim/iadri ; integer(8) iadri
      dimension esp1(iadri),ab(iadri)
      common/opt/ihab,calcul
      character*3 calcul
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension ntv(maxorbcas+2),npv(maxorbcas+2)
c
c-----------------------------------------------------
c     generation des integrales
c-----------------------------------------------------
c
      call rew61
 1    continue
      call venondloc(ne,ntv,npv,ierr)
      write(75,*)'T ',(ntv(k),k=1,ne),'  P ',(npv(k),k=1,ne)
      call scril
      if(ierr.eq.1) goto 100
      do i=1,norb
         do j=1,i
            do k=1,i
               if(i.eq.j) then
                  lfin=k
               else
                  lfin=j
               endif
               do l=1,lfin
               enddo
            enddo
         enddo
      enddo
 100  continue
      return
      end
 
