      subroutine diagon(a,b,iecr)
c
c-------------------------------------------------------------------
c     subroutine de calcul de la diagonale de la matrice
c-------------------------------------------------------------------
c
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      PARAMETER (ngru3=2048,maxda3=300)
      parameter(maxorbcas=16)
      include 'maxorb.prm'
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |       a       |      b        |
c
      common/test/itest(100)
      common/dim/iadri ; integer(8) iadri
      common /ijd/itab,jtab,dtab
      common /det/ndet,mdet(50),nbdet_cas
      common/opt/ihab,calcul
      character*3 calcul
      dimension ITAB(NGRU3),JTAB(NGRU3)
      real*4 DTAB(NGRU3)
      dimension a(ndet),b(ndet)
      dimension ntv(maxorbcas+2),npv(maxorbcas+2)
      dimension ica(maxorbcas),icb(maxorbcas),it(2),ip(2)
      common/g2/lg2,ig2,lg2p,ig2p,lg2m,ig2m,ng2,yg2,yga2
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      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/pr/nprint,mprint(10)
      common/debug/ywgen
 
      character*1 cccc
      yw=nprint.ge.3
      yw1=nprint.ge.1
      if(yw1)write(6,*)'diagon ndet',ndet
      do k=1,ndet
         b(k)=0.d0
      enddo
      if(calcul.eq.'D') then
         rewind 1
 341     continue
         read(1) itab,jtab,dtab
         NM=NGRU3
         IF(ITAB(NGRU3).EQ.-1) NM=JTAB(NGRU3)
         DO 342 KK=1,NM
         I=ITAB(KK)
         J=JTAB(KK)
c         write(6,*)'i,j,kk',i,j,kk,dtab(kk)
         IF(I.EQ.J) b(i)=DTAB(KK)*2+b(i)
 342     continue
         if(itab(ngru3).ge.0) goto 341
         ifin=0
         if(yw)write(6,*)'diagon b',(b(k),k=1,ndet)
      else
         rewind 61
         read(61)cccc
         call rew61
         if(yga2) call mazg(norb)
         do 1 i=1,ndet
         call venondloc(ne,ntv,npv,ierr)
c         read(61) ne
c         if(ne.ne.0)read(61)(ntv(k),k=1,ne),(npv(k),k=1,ne)
c         print'(a,i8,20i4)','DIAGON',i,(ntv(k),k=1,ne),(npv(k),k=1,ne)
c         call flush(6)
         if(yw)write(6,*)'diagon vieux',(ntv(k),k=1,ne),(npv(k),k=1,ne)
         call trad(ne,ntv,npv,nca,ica,ncb,icb,nt,it,ispt,np,ip,ispp
     *   ,ierr)
         if(yw)write(6,*)'diagon nouv nt',nt,(it(k),k=1,nt)
     *   ,'np',np,(ip(k),k=1,np)
         call adrdet
     *   (nca,ica,ncb,icb,nt,it,ispt,np,ip,ispp,iadr1,
     *      mhdum,mtdum)
         if(yw)write(6,*)'diagon iadr1',iadr1
         if(yga2) then
c              print*,'avant diff0g',nt,np
            call diff0g(nca,ica,ncb,icb,nt,it,ispt,
     *        np,ip,ispp,iadr1,b(i))
         else
c              print*,'avant diff0',nt,np
            call diff0(nca,ica,ncb,icb,nt,it,ispt,
     *      np,ip,ispp,iadr1,b(i))
         endif
 1       continue
         if(yw) then
         do k=1,ndet
            write(6,'(a20,i7,f12.8)')'diagon b',k,b(k)
         enddo
         endif
      endif
      if(yga2) return
      if(yw1)write(6,*)'ecriture sur 25  ndet=',ndet
      if(itest(32).eq.1) then
         print*,'appel stohii'
         call stohii(a,b)
         itest(32)=0
      endif
      if(iecr.eq.1) call ecr8bl(b,ndet,25)
      return
      end
       subroutine stohii(a,b)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |      a        |       b       |
c
c
c-----------------------------------------------
c     stockage de hii
c-----------------------------------------------
c
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      common/dim/iadri ; integer(8) iadri
      dimension a(iadri),b(iadri)
      common/ver3/ ei(2048),itab(2048)
      common /det/ndet,mdet(50),nbdet_cas
c--   ecriture de la diagonale
      call reocip(b,a,itab,ndet,2)
      close (25)
      open(25,file='HII',status='unknown',form='unformatted')
      call ecr8bl(a,ndet,25)
      close (25)
      open(25,file='DIAGON',status='unknown',form='unformatted')
      return
      end
       subroutine mazg(norb)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      include 'maxorb.prm'
      common/l40/ g2(maxorb,maxorb),g2a(maxorb*(maxorb+1)/2)
     *,g2b(maxorb*(maxorb+1)/2),dum(3*maxorb*(maxorb+1)/2
     *-maxorb*maxorb+2)
      do k=1,norb*(norb+1)/2
         g2a(k)=1.d0
         g2b(k)=1.d0
      enddo
      do k=1,norb
         do l=1,norb
            g2(l,k)=1.d0
         enddo
      enddo
      return
      end
