      subroutine diago
      use module
      use mod_gen
      use mod_lirint
      use mod_script
      implicit real(8) (a-h,o-x,z),logical(1)(y)
      !
      ! Allocation du vecteur contenant les elements diagonaux
      !
      allocate(ee(ndet))
      print*,'diago ndet',ndet
      if(stop=='NDET') stop
      yw=.false.
      !
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! Genere les determinants dans l'ordre des adresses et calcule la
      ! diagonale de la matrice d'IC
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      print*,' '
      print*,'Calcul de la diagonale de H '
      print*,' '
      if(w2)print*,'diago hmono'
      if(w2)call mscript(hmono)
!
! Introduction de facteurs de correctio ndes integrales d'echange pour PSRCI
! lambda_uci1, lambda_uci0
!
      lambda_uci1=1.0d0
      lambda_uci0=0.0d0
      if(uci) then
         lambda_uci1=0.5d0
         lambda_uci0=0.5d0
      endif
      !
      ! Energie des inactives occupees
      !
      yw=.false.
      diag0=0
      do ii=1,ninac
         i=numin(ii)
         diag0=diag0+f(i*(i+1)/2)*2-ajk(i,i)
         if(w2)print*,'e0',i,hmono(i,i),ajk(i,i)
         do jj=1,ii-1
            j=numin(jj)
            diag0=diag0-(2*ajk(i,j)-ajk(j,i))*2
            if(w2)print*,'e02',i,j,ajk(i,j),ajk(j,i)
         enddo
      enddo
      !print*,'diag0',diag0
      print'(a,i4,a,f20.8)','Energie des inactives occupees ('
     *,ninac,' orbitales)',diag0+enuc
      !
      ! Energie de l'occupation au niveau de fermi
      !
      eref=0
      do i=1,noc
         eref=eref+hmono(i,i)*2+ajk(i,i)
C         eref=eref+f(i*(i+1)/2)*2-ajk(i,i)
         do j=1,i-1
            eref=eref+(2*ajk(i,j)-ajk(j,i))*2
         enddo
      enddo
      print'(a,i4,a,f20.8)','Energie au niveau de Fermi     ('
     *,noc,' orbitales)',eref+enuc
      !
      ! Lecture de l'operateur de Fock
      !
      !rewind 2
      !read(2)((hmono(i,j),i=1,j),j=1,norb)
      ii=0
      do k=1,norb
         do l=1,k
            ii=ii+1
            hmono(k,l)=f(ii)
            hmono(l,k)=f(ii)
         enddo
      enddo
      if(w2)print*,'diago fock'
      if(w2)call mscript(hmono)
      !
      ! Boucle sur les classes de determinants du CAS
      !
      yverif=.false.
      if(itest(9)==1) then
         yverif=.true.
      endif
      iadr=0
      do iclc=1,nclasc
         if(.not.exist_clasc(iclc)) cycle
         !
         ! boucle sur les distances (si selection)
         !
         !
         ! Boucle sur les det du CAS de la classe
         !
         if(yw)print*,'iclc,idebc(iclc),ifinc(iclc)'
     *   ,iclc,idebc(iclc),ifinc(iclc)
         do kc=idebc(iclc),ifinc(iclc)
            !
            ! Lecture du string CAS
            !
            i=ibinc(kc)
            nca=0
            ncb=0
            do k=1,noac
               yc(k)=(i==ibset(i,k-1))
               yc(k+noac)=(i==ibset(i,k+16-1))
               if(yc(k)) then
                  nca=nca+1
                  ica(nca)=k
               endif
               if(yc(k+noac)) then
                  ncb=ncb+1
                  icb(ncb)=k
               endif
            enddo
            !
            ! diagonale : contribution des actives
            !
            e=diag0-eref
            if(w)print*,'e',e
            do i=1,nca
               i1=numac(ica(i))
               e=e+hmono(i1,i1)
               if(w)print*,'acta hmono(i1,i1)',hmono(i1,i1)
               do j=1,i-1
                  i2=numac(ica(j))
                  e=e+ajk(i1,i2)-ajk(i2,i1)*lambda_uci1
                  if(w)print*,'act ajk',ajk(i1,i2)-ajk(i2,i1)
               enddo
               do j=1,ncb
                  i2=numac(icb(j))
                  e=e+ajk(max(i1,i2),min(i1,i2))
     *            -ajk(min(i1,i2),max(i1,i2))*lambda_uci0
                  if(w)print*,'act aj',ajk(max(i1,i2),min(i1,i2))
               enddo
            enddo
            do i=1,ncb
               i1=numac(icb(i))
               e=e+hmono(i1,i1)
               if(w)print*,'actb hmono(i1,i1)',hmono(i1,i1)
               do j=1,i-1
                  i2=numac(icb(j))
                  e=e+ajk(max(i1,i2),min(i1,i2))
     *            -ajk(min(i1,i2),max(i1,i2))*lambda_uci1
                  if(w)print*,'act ajkb',ajk(max(i1,i2),min(i1,i2))
     *            -ajk(min(i1,i2),max(i1,i2))
               enddo
            enddo
            diagc=e
            if(w)print*,'diagc',diagc
            !
            ! Calcul selectionne : distance du string CAS
            !
            if(w2) jdist=0
            if(sel==2) then
               jdist=icaldist(kc,ibin,ibinc,noac)
               if(yw)print*,'jdist',jdist,yc(1:noac+noac)
               if(jdist>2) cycle
            endif
            if(w2)print'(a,i3,i6,a,i4,32l1)'
     *      ,'det CAS : classe, det'
     *      ,iclc,kc,'    ',jdist,yc(1:noac*2)
            !
            ! verif, calcul de l'adresse
            !
            if(yverif) then
               call adrc(yc,iadrc,idum)
               if(w2)write(6,'(" adresses CAS",2i8,2x,16l1)')
     *         kc,iadrc,yc(1:noac*2)
            endif
            !
            ! Boucle sur les classes TP correspondant au CAS
            !
            do jcltp=1,nc_tp(iclc)
               i=ic_tp(jcltp,iclc)
               nta=icltp1(1,i)
               ntb=icltp1(2,i)
               npa=icltp1(3,i)
               npb=icltp1(4,i)
               if(yw)print*,'i,nta,ntb,npa,npb',i,nta,ntb,npa,npb
               !
               ! Examen des differents cas
               !
               nt=nta+ntb
               np=npa+npb
               if(sel==2) then
                  call lim_sel(nt,np,jdist,ibon)
                  if(w2) print*,'accepte nt,np',nt,np
                  if(ibon==0) cycle
               endif
               ntnp=nt+np
               if(ntnp==0) then
                  call gen_0
               else if(ntnp==1) then
                  if(nt==1) then
                     call gen_t
                  else
                     call gen_p
                  endif
               else if(ntnp==2) then
                  if(nt==1) then
                     call gen_tp
                  else if(nt==0) then
                     call gen_pp
                  else if(nt==2) then
                     call gen_tt
                  endif
               else if(ntnp==3) then
                  if(nt==1) then
                     call gen_tpp
                  else
                     call gen_ttp
                  endif
               else if(ntnp==4) then
                  call gen_ttpp
               endif
            enddo
         enddo
      enddo
      open(20,form='unformatted',status='unknown',file='LOC_DIAG')
      call ecr8bl(ee,ndet,20)
      deallocate(ee)
      return
      end
       subroutine diago1
      use module
      use mod_ena
      use mod_gen
      use mod_lirint
      use mod_script
      implicit real(8) (a-h,o-x,z),logical(1)(y)
      !integer,save :: iidiag=0
      !
      ! calcul de la valeur diagonale du determinant
      !
      integer iit(2),iip(2)
      yw=.false.
      yw1=.false.
      iidiag=iidiag+1
      e=diagc
      iit=it
      iip=ip
      if(yw)print*,'It',(it(k),k=1,nt)
      if(yw)print*,'ip',(ip(k),k=1,np)
      if(yw)print*,'e0',diagc
      it=abs(it)
      ip=abs(ip)
      do i=1,nca
         i1=numac(ica(i))
!         e=e+hmono(i1,i1)
         do j=1,npa
            i2=ip(j)
            e=e+ajk(max(i1,i2),min(i1,i2))
     *      -ajk(min(i1,i2),max(i1,i2))
            if(yw)print*,'ajk',ajk(max(i1,i2),min(i1,i2))
     *      -ajk(min(i1,i2),max(i1,i2))*lambda_uci1
         enddo
         do j=1,npb
            i2=ip(j+npa)
            e=e+ajk(max(i1,i2),min(i1,i2))
     *      -ajk(min(i1,i2),max(i1,i2))*lambda_uci0
            if(yw)print*,'aj',ajk(max(i1,i2),min(i1,i2))
         enddo
         do j=1,nta
            i2=it(j)
            e=e-ajk(max(i1,i2),min(i1,i2))
     *      +ajk(min(i1,i2),max(i1,i2))*lambda_uci1
            if(yw)print*,'-ajk',-ajk(max(i1,i2),min(i1,i2))
     *      +ajk(min(i1,i2),max(i1,i2))*lambda_uci1
         enddo
         do j=1,ntb
            i2=it(j+nta)
            e=e-ajk(max(i1,i2),min(i1,i2))
     *      +ajk(min(i1,i2),max(i1,i2))*lambda_uci0
            if(yw)print*,'-aj',
     *      -ajk(max(i1,i2),min(i1,i2))
     *      +ajk(min(i1,i2),max(i1,i2))*lambda_uci0
         enddo
      enddo
      do i=1,ncb
         i1=numac(icb(i))
!         e=e+hmono(i1,i1)
         do j=1,npa
            i2=ip(j)
            e=e+ajk(max(i1,i2),min(i1,i2))
     *      -ajk(min(i1,i2),max(i1,i2))*lambda_uci0
            if(yw)print*,'aj',
     *      ajk(max(i1,i2),min(i1,i2))
         enddo
         do j=1,npb
            i2=ip(j+npa)
            e=e+ajk(max(i1,i2),min(i1,i2))
     *      -ajk(min(i1,i2),max(i1,i2))*lambda_uci1
            if(yw)print*,'-ajk',ajk(max(i1,i2),min(i1,i2))
     *      -ajk(min(i1,i2),max(i1,i2))
         enddo
         do j=1,nta
            i2=it(j)
            e=e-ajk(max(i1,i2),min(i1,i2))
     *      +ajk(min(i1,i2),max(i1,i2))*lambda_uci0
            if(yw)print*,'-aj',
     *      -ajk(max(i1,i2),min(i1,i2))
     *      +ajk(min(i1,i2),max(i1,i2))*lambda_uci0
         enddo
         do j=1,ntb
            i2=it(j+nta)
            e=e-ajk(max(i1,i2),min(i1,i2))
     *      +ajk(min(i1,i2),max(i1,i2))*lambda_uci1
            if(yw)print*,'ajk',-ajk(max(i1,i2),min(i1,i2))+
     *      ajk(min(i1,i2),max(i1,i2))*lambda_uci1
         enddo
      enddo
      do i=1,npa
         i1=ip(i)
         e=e+hmono(i1,i1)
         if(yw)write(6,*)'diff0  f npa',i1,hmono(i1,i1)
         do j=1,i-1
            i2=ip(j)
            e=e+ajk(max(i1,i2),min(i1,i2))
     *      -ajk(min(i1,i2),max(i1,i2))*lambda_uci1
            if(yw)write(6,*)'diff0 -1',
     *      +ajk(max(i1,i2),min(i1,i2))
     *      -ajk(min(i1,i2),max(i1,i2))*lambda_uci1
         enddo
         do j=1,npb
            i2=ip(j+npa)
            ig=max0(i1,i2)
            ipet=min0(i1,i2)
            e=e+ajk(max(i1,i2),min(i1,i2))
     *      -ajk(min(i1,i2),max(i1,i2))*lambda_uci0
            if(yw)write(6,*)'diff0 npb',
     *      ajk(max(i1,i2),min(i1,i2))
     *      -ajk(min(i1,i2),max(i1,i2))*lambda_uci0
         enddo
         do j=1,nta
            i2=it(j)
            e=e-ajk(max(i1,i2),min(i1,i2))
     *      +ajk(min(i1,i2),max(i1,i2))*lambda_uci1
            if(yw)write(6,*)'diff0 nta',
     *      -ajk(max(i1,i2),min(i1,i2))
     *      +ajk(min(i1,i2),max(i1,i2))*lambda_uci1
         enddo
         do j=1,ntb
            i2=it(j+nta)
            e=e-ajk(max(i1,i2),min(i1,i2))
     *      +ajk(min(i1,i2),max(i1,i2))*lambda_uci0
            if(yw)write(6,*)'diff0 ntb',
     *      -ajk(max(i1,i2),min(i1,i2))
     *      +ajk(min(i1,i2),max(i1,i2))*lambda_uci0
         enddo
      enddo
      do i=1,npb
         i1=ip(i+npa)
         if(yw)print*,'i1',i1
         e=e+hmono(i1,i1)
         if(yw)write(6,*)'diff0 f npb',hmono(i1,i1)
         do j=1,i-1
            i2=ip(j+npa)
            e=e+ajk(max(i1,i2),min(i1,i2))
     *      -ajk(min(i1,i2),max(i1,i2))*lambda_uci1
            if(yw)write(6,*)'diff0 -1',
     *      ajk(max(i1,i2),min(i1,i2))
     *      -ajk(min(i1,i2),max(i1,i2))*lambda_uci1
         enddo
         do j=1,nta
            i2=it(j)
            e=e-ajk(max(i1,i2),min(i1,i2))
     *      +ajk(min(i1,i2),max(i1,i2))*lambda_uci0
            if(yw)write(6,*)'diff0 nta',
     *      -ajk(max(i1,i2),min(i1,i2))
     *      +ajk(min(i1,i2),max(i1,i2))*lambda_uci0
         enddo
         do j=1,ntb
            i2=it(j+nta)
            e=e-ajk(max(i1,i2),min(i1,i2))
     *      +ajk(min(i1,i2),max(i1,i2))*lambda_uci1
            if(yw)write(6,*)'diff0 ntb',
     *      -ajk(max(i1,i2),min(i1,i2))
     *      +ajk(min(i1,i2),max(i1,i2))*lambda_uci1
         enddo
      enddo
      do i=1,nta
         i1=it(i)
         e=e-hmono(i1,i1)
         if(yw)write(6,*)'diff0 f nta',i1,-hmono(i1,i1)
         do j=1,i-1
            i2=it(j)
            e=e+ajk(max(i1,i2),min(i1,i2))
     *      -ajk(min(i1,i2),max(i1,i2))*lambda_uci1
            if(yw)write(6,*)'diff0 -1',
     *      +ajk(max(i1,i2),min(i1,i2))
     *      -ajk(min(i1,i2),max(i1,i2))*lambda_uci1
         enddo
         do j=1,ntb
            i2=it(j+nta)
            e=e+ajk(max(i1,i2),min(i1,i2))
     *      -ajk(min(i1,i2),max(i1,i2))*lambda_uci0
            if(yw)write(6,*)'diff0 ntb',
     *      +ajk(max(i1,i2),min(i1,i2))
     *      -ajk(min(i1,i2),max(i1,i2))*lambda_uci0
         enddo
      enddo
      do i=1,ntb
         i1=it(i+nta)
         e=e-hmono(i1,i1)
         if(yw)write(6,*)'diff0 f ntb',-hmono(i1,i1)
         do j=1,i-1
            i2=it(j+nta)
            e=e+ajk(max(i1,i2),min(i1,i2))
     *      -ajk(min(i1,i2),max(i1,i2))*lambda_uci1
            if(yw)write(6,*)'diff0 -1',
     *      +ajk(max(i1,i2),min(i1,i2))
     *      -ajk(min(i1,i2),max(i1,i2))*lambda_uci1
         enddo
      enddo
      if(yw1)print*,'valeur diagonale',iidiag,e
      if(calcul=='M')call ecrmat(iidiag,iidiag,e)
      if((nessai==3.or.nhab/=0)
     *.and.nta==0.and.ntb==0.and.npa==0.and.npb==0.)
     *call ecrmat(iidiag,iidiag,e)
      ee(iidiag)=e
      it=iit
      ip=iip
      return
      end
 
