      subroutine david(a,b,iesp,iesp2,yesp)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      PARAMETER (ngru3=2048)
      parameter (maxda3=300,maxorbcas=16)
      include 'maxorb.prm'
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |      a        |       b       |
c    |      iesp     |               |
c    |      iesp2    |               |
c    |      yesp     |               |
c
      common/dim/iadri ; integer(8) iadri
      dimension iesp(iadri*4),yesp(*)
      integer*2 iesp2(iadri*8)
      character*4 hab
      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
      logical*1 bidia
      common /det/ndet,mdet(50),nbdet_cas
      common/opt/ihab,calcul
      character*3 calcul
      dimension a(iadri),b(iadri)
      common /ijd/itab,jtab,dtab
      dimension ITAB(NGRU3),JTAB(NGRU3)
      real*4 DTAB(NGRU3)
      common /prep/ nca0,ncb0,ic0(maxorbcas),icamun(maxorb+maxorb)
     *,numt(maxorb),nump(maxorb),nv
     *,gener,yoc(maxorb+maxorb),yrefc(maxorbcas),yac(maxorb)
     *,ygmono,ygddci,ygddc2,ygcas,ygtous
      common/pert/schift,damp,ypertu,ycaspert
      common/test/itest(100)
      character*4 gener,gener3
      common/ess3/ ndetcas,ynessai3
      print*,' '
      call titre('DIAGONALISATION#',50)
C      write(6,*)' '
C      write(6,*)'==========================='
C      write(6,*)'david   diagonalisation    '
C      write(6,*)'==========================='
c     if(calcul.eq.'D')
c    *open(4,status='OLD',file='FIL4',form='UNFORMATTED')
c
c------------------------------------------------------
c    si nbtots = 0  on cherche la dimension de la matrice
c------------------------------------------------------
c
      if(nbtots.eq.0) then
         call chedim(nbtots)
c        write(6,*)'david nbtots',nbtots
      else
         ndet=nbtots
      endif
      maxdav=nbtots
      !maxda2=min(maxda2,250000000/ndet)
 
      ynessai3=.false.
      if(nessai.ge.3) then
c        --------------------------------------------
c        cas nessai=3
c        --------------------------------------------
         print*,'preparation nessai=3'
         ynessai3=.true.
         ygcas3=ygcas
         ygcas=.true.
         nessai=nessai-3
         ywcas3=ywcas
         ywcas=.true.
         ypertu3=ypertu
         ypertu=.false.
         itest(59)=3
 
         call prdav0(a,b,maxdav,iesp,iesp2,yesp)
         ygcas=ygcas3
         nessai=3
         ywcas=ywcas3
         ypertu=ypertu3
         itest(59)=0
 
      endif
 
 
 
 
 
 
 
 
 
      call prdav0(a,b,maxdav,iesp,iesp2,yesp)
      close(8)
      return
      end
       SUBROUTINE prdav0(b,ab,maxdav,iesp,iesp2,yesp)
      parameter (maxda3=300,maxorbcas=16)
      include 'maxorb.prm'
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |      b        |       ab      |
c    |      iesp                     |
c    |      yesp                     |
c
      common/dim/iadri ; integer(8) iadri
      dimension iesp(iadri*4),yesp(*)
      integer*2 iesp2(iadri*8)
      logical*1 bidia
      common/svfil/fil11
      character*40 fil11
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      character*4 hab
      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
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common /det/ndet,mdet(50),nbdet_cas
      common/pr/nprint,mprint(10)
      common/opt/ihab,calcul
      character*3 calcul
      common/habil/c2,c0,
     *iterh,maxith,ndeth,ith(maxorbcas+2),iph(maxorbcas+2),neh
     *,ihvec1,iadrh
      DIMENSION B(iadri),AB(iadri)
      common /info/ numero
      common /ijd/itab,jtab,dtab
      dimension ITAB(2048),JTAB(2048)
      DIMENSION DTAB(2048)
      common/test/itest(100)
      real*4 dtab
c     print*,'1ydens,ms2',ydens,ms2
      iunit=4
      nvec=min(nvec,ndet)
      CALL PREDAV(b,ab,alam,maxdav,maxda2,
     *ndet,nvec,ngao,niter,iprec,
     *BIDIA,nessai,iesp,iesp2,yesp,ytana)
c      print*,'apres predav'
      if(ihab.eq.1.and.nessai.eq.2.and.iterh.eq.0) return
      rewIND 11
      WRITE(11) ndet,NVEC
      WRITE(11) (ALAM(kk),kk=1,NVEC),enuc,eref
c--   stockage des mono
      ystomono=itest(37).ne.0
      nmono=itest(37)
      if(ystomono) call stomono2(ndet,nvec,nmono,alam,yesp,jtab)
c
c     print*,'3ydens,ms2',ydens,ms2
c         WRITE(6,*)'alam', (ALAM(kk),kk=1,NVEC)
      rewind 63
      do kk=1,nvec
         call lire(b,kk,ndet,21)
         if(calcul.eq.'MD') then
            if(ydens)call dens(b)
            if(itest(73).eq.0) call sgncip(b,yesp(iadri*8+1),ndet)
            call reocip(b,ab,itab,ndet,2)
            WRITE(11)(AB(kkk),kkk=1,ndet)
c            print*,'ecriture 11 prdav0'
c           call scrida('ecriture 11  $',ab,ndet,21,1)
         else
            WRITE(11)(B(kkk),kkk=1,ndet)
         endif
      enddo
 
      if(ystomono) then
c        ecriture des vecteurs mono
         do kk=1,nvec
            call lire(b,kk,ndet,21)
            if(itest(73).eq.0) call sgncip(b,yesp(iadri*8+1),ndet)
            call stomono3(ndet,jtab,ab,b,nmono)
            write(30)(ab(i),i=1,nmono)
         enddo
c        ecriture de la diagonale des monos
         rewind 25
         call lir8bl(b,ndet,25)
         call stomono3(ndet,jtab,ab,b,nmono)
         write(30)(ab(i),i=1,nmono)
c        ecriture de la diagonale initiale des monos
         call diagon(b,ab,0)
         call stomono3(ndet,jtab,b,ab,nmono)
         write(30)(b(i),i=1,nmono)
      endif
c     print*,'4ydens,ms2',ydens,ms2
      if(ydens.and.ms2.ne.0) then
         rewind 38
         do kk=1,nvec
            read(38)(b(i),i=1,norb*norb)
            write(63)(b(i),i=1,norb*norb)
         enddo
         close(38,status='delete')
      endif
      if(calcul.eq.'MD') then
         if(ywvec.and.ihab.eq.0) call wvec(b,iesp(iadri*2+1),
     *   yesp(iadri*8+1))
      else
         if(ywvec) call wvec(b,iesp(iadri*2+1),yesp(iadri*8+1))
      endif
      close(11)
      open(11,file=fil11,status='old',form='unformatted')
      RETURN
      END
       subroutine stomono2(ndet,nvec,nmono,alam,y,jtab)
      parameter(maxda3=300,maxorbcas=16)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      common/dim/iadri ; integer(8) iadri
      dimension alam(maxda3)
      dimension jtab(2048),y(iadri)
      dimension itv(maxorbcas+2),ipv(maxorbcas+2)
      common/pr/nprint,mprint(10)
      open(28,form='unformatted',status='old',file='BIDMONO')
      open(55,file='STOMONOD',status='unknown',form='unformatted')
      open(30,file='STOMONOV',status='unknown',form='unformatted')
      write(30) nmono,nvec,ndet
      write(30)(ALAM(kk),kk=1,NVEC)
      print*,'entree stomono2 nmono,ndet',nmono,ndet
      do k=1,ndet
         y(k)=.false.
      enddo
      i=0
      read(28) jtab
      do k=1,nmono
         i=i+1
         if(i.gt.2048) then
            i=1
            read(28) jtab
         endif
         y(jtab(i))=.true.
      enddo
      call rew61
      do ll=1,ndet
         call venondloc(ne,itv,ipv,ierr)
         if(y(ll)) then
            write(55)ne,(itv(k),k=1,ne),(ipv(k),k=1,ne)
            if(nprint.ge.1) then
               write(75,*)'stom2',(itv(k),k=1,ne)
     *         ,' --> ',(ipv(k),k=1,ne),'$'
               call scril
            endif
         endif
      enddo
      close(55)
      return
      end
       subroutine stomono3
     *(ndet,jtab,ab,b,nmono)
      parameter(maxda3=300,maxorbcas=16)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      common/dim/iadri ; integer(8) iadri
      dimension ab(nmono),b(ndet),jtab(2048)
      rewind 28
      i=0
      read(28) jtab
      do k=1,nmono
         i=i+1
         if(i.gt.2048) then
            i=1
            read(28) jtab
         endif
         ab(k)=b(jtab(i))
      enddo
      return
      end
 
 
 
 
 
       subroutine predav(b,ab,alam,maxdav,maxda2,
     *ndet,NVEC,NGAO1,NITER,IPREC,
     *BIDIA,nessai,iesp,iesp2,yesp,ytana)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      PARAMETER (maxda3=300,ngru3=2048)
      common/dim/iadri ; integer(8) iadri
      parameter(maxorbcas=16,norbz=120)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |      b        |       ab      |
c    |      iesp                     |
c    |      yesp                     |
c
      dimension iesp(iadri*4),yesp(*)
      integer*2 iesp2(iadri*8)
      logical*1 bidia
      DIMENSION GUESS(maxda3*2,maxda3),ORTH(maxda3*2,maxda3),
     *GSYM(maxda3*2)
      DIMENSION B(MAXDAV),AB(MAXDAV),
     *ALAM(maxda3)
      COMMON/GAO/GUESS,ORTH,GSYM,NGAO,NORTH
      common /ijd/itab,jtab,dtab
      INTEGER*4 ITAB(NGRU3),JTAB(NGRU3)
      DIMENSION DTAB(NGRU3)
      real*4 dtab
      common/test/itest(100)
      common/opt/ihab,calcul
      character*3 calcul
      common/habil/c2,c0,
     *iterh,maxith,ndeth,ith(maxorbcas+2),iph(maxorbcas+2),neh
     *,ihvec1,iadrh
      common/ess3/ ndetcas,ynessai3
      common/polspicom/ypolspi
      yw=.false.
      ND1=MAXDA2*2
      ND2=MAXDA2
      NORTH=0
      NGAO=NGAO1
      if(nessai.eq.3) goto 1
      if(iterh.eq.0) call diagon(b,ab,1)
 1    continue
      call essai(b,iesp(iadri*2+1),yesp(iadri*12+1),yesp(iadri*13+1),
     *ab,guess,maxdav,ngao1)
c      print*,'apres essai'
      if(yw)write(6,*)'predav essai',(b(kk),kk=1,ndet)
      if(ihab.eq.1.and.nessai.eq.2.and.iterh.eq.0) return
C--------------FIN DE L'OBTENTION DES VECTEURS D'ESSAI
      PREC=1./(10.**IPREC)
      if(calcul.eq.'D') then
         WRITE(6,30)
 30      FORMAT(/,/,20X,'  NDET  NVEC  NGAO NITER   PREC')
         WRITE(6,21) ndet,NVEC,NGAO,NITER,PREC
 21      FORMAT(16X,i10,3I6,D8.1)
      else
         WRITE(6,31)
 31      FORMAT(/,/,20X,'  NDET  NVEC NITER   PREC')
         if(ynessai3.and.nessai.ne.3) then
            WRITE(6,22) ndetcas,NVEC,NITER,PREC
         else
            WRITE(6,22) ndet,NVEC,NITER,PREC
         endif
 22      FORMAT(16X,i10,2I6,D8.1)
      endif
      if(itest(12).eq.0) then
         CALL DAVID2(B,iesp,AB,ALAM,PREC,maxdav,maxda2,ndet,NVEC,NITER,
     *   yesp)
         IF(BIDIA)
     *   CALL DAVID2(B,iesp,AB,ALAM,PREC,maxdav,maxda2,ndet,NVEC,NITER,
     *   yesp)
      else
         if(itest(69).eq.1) then
            CALL DAVID4(B,iesp,AB,ALAM,PREC,maxdav,maxda2,NVEC,NITER,
     *      yesp,ytana)
         else if(itest(69).eq.0) then
            CALL DAVID3(B,iesp,AB,ALAM,PREC,maxdav,maxda2,NVEC,NITER,
     *      yesp)
         else if(itest(69).eq.2) then
            CALL bofill(B,iesp,AB,ALAM,PREC,maxdav,maxda2,NVEC,NITER,
     *      yesp,ytana)
         else if(itest(69).eq.3) then
            CALL bofillv(B,iesp,AB,ALAM,PREC,maxdav,maxda2,NVEC,NITER,
     *      yesp,ytana)
         endif
c      print*,'apres david3'
      endif
      rewIND 1
      RETURN
      END
       subroutine david2(B,iesp,AB,ALAM,THR,maxdav,maxda2,
     *ndet,NVEC,NITER,yesp)
C*************************
C
C     DIAGONALIZATION SUBROUTINE FOR LARGE SYMMETRIC MATRICES
C     E. R. DAVIDSON, J. COMP. PHYS 17, 87 (1975)
C
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      PARAMETER (maxda3=300,ngru3=2048,maxorbcas=16)
      include 'maxorb.prm'
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |      b        |       ab      |
c    |      yesp                     |
c
      dimension yesp(*)
      common/dim/iadri ; integer(8) iadri
      common/svfil/fil11
      character*40 fil11
      common/test/itest(100)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      DIMENSION B(MAXDAV),AB(MAXDAV),iesp(maxdav*2),
     *DIAG(ngru3)
      DIMENSION BAB(maxda3,maxda3),H(maxda3,maxda3),
     *ALPHA(maxda3,maxda3),ALAM(maxda3),p(maxda3)
      DIMENSION GUESS(maxda3*2,maxda3),ORTH(maxda3*2,maxda3),
     *GSYM(maxda3*2)
      COMMON /GAO/ GUESS,ORTH,GSYM,NGAO,NORTH
      common /ijd/itab,jtab,dtab
      dimension ITAB(NGRU3),JTAB(NGRU3)
      dimension qc(ngru3)
      equivalence (jtab(1),qc(1))
      DIMENSION DTAB(NGRU3)
      real*4 dtab
      common/opt/ihab,calcul
      common/habil/c2,c0,
     *iterh,maxith,ndeth,ith(maxorbcas+2),iph(maxorbcas+2),neh
     *,ihvec1,iadrh
      character*3 calcul
      common/sui/isuiv
      common/pr/nprint,mprint(10)
      common/mulr/m0,m2,m3,maxl0,icalc(maxda3),icalc1,ycvl(maxda3)
c      dimension  iadrvbid(1000),abbid(1000)
      common /stoc/ jint,jnb(1024),jnb1
     *,iter,lonstc,maxstc,ystc,ystit1
      DATA ZERO,ONE/0.D0,1.D0/
      DATA EPS/1.D-25/
    5 FORMAT (//10X,'EIGENVALUE NUMBER',I3)
   10 FORMAT (3X,'ITER=',I3,', M=',I2,', EIGENVALUE=',F17.12,
     *', CONVERGENCE =',D10.2)
   20 FORMAT (///5X,'THE DAVIDSON PROCEDURE DOES NOT CONVERGE AFTER',
     *I4,' ITERATIONS'///)
      yw=.false.
      icalc1=0
      if(yw)write(6,*)'1b',(b(kk),kk=1,ndet)
      if(yw)write(6,*)'2b',(b(kk),kk=1,ndet)
      K=1
      WRITE (6,5) K
      call flush(6)
      M=NVEC
      ITER=1
C
C     CONSTRUCTION OF THE BAB MATRIX IN THE SUBSPACE
C     OF THE TRIAL VECTORS  B(1) ... B(M)
C
      if(yw)write(6,*)'3b',(b(kk),kk=1,ndet)
      if(mprint(1).eq.1) then
         do kk=1,m
            call scrida('b avant mulmc$',b,ndet,21,kk)
         enddo
      endif
      if(calcul.eq.'D') then
         call mulm(b,ab,ndet,m)
      else
         call mulmc(b,iesp,ndet,m)
      endif
      if(mprint(1).eq.1) then
         do kk=1,m
            call scrida('ab apres mulmc$',ab,ndet,22,kk)
         enddo
c         if(calcul.eq.'MD') then
c            rewind 87
c            read(87) iadrvbid
c            do kk=1,ndet
c               abbid(iadrvbid(kk))=b(kk)
c            enddo
c            do kk=1,ndet
c               print*,'kk,bbid',kk,abbid(kk)
c            enddo
c            do kk=1,ndet
c               abbid(iadrvbid(kk))=ab(kk)
c            enddo
c            do kk=1,ndet
c               print*,'kk,abbid',kk,abbid(kk)
c            enddo
c         else
c            do kk=1,ndet
c               print*,'kk,ab',kk,ab(kk)
c            enddo
c         endif
      endif
      if(yw)write(6,*)'4b',(b(kk),kk=1,ndet)
      if(yw)write(6,*)'ab',(ab(kk),kk=1,ndet)
      DO 60 L=1,M
      call lire(b,l,ndet,21)
      DO 60 LL=1,L
      BABL=ZERO
      call lire(ab,ll,ndet,22)
      DO 50 J=1,ndet
   50 BABL=BABL+B(J)*AB(J)
   60 BAB(L,LL)=BABL
C
C     DIAGONALIZATION OF BAB ... EIGENVALUES ALAM, EIGENVECTORS ALPHA
C
   70 DO 72 L=1,M
      DO 72 LL=1,L
      H(L,LL)=BAB(L,LL)
   72 H(LL,L)=BAB(L,LL)
      if(nprint.ge.3.or.mprint(4).eq.1) then
         write(6,*)'Heff'
         call SCRIPT(h,m,m,maxda3,maxda3)
c        write(6,'('' alam avant riera'',4f8.4)')(alam(kk),kk=1,m)
      endif
c      CALL RIERA(M,H,ALPHA,ALAM,P,maxda3,ierr)
c      if(ierr.eq.1) then
c         print*,'diagonalisation JACOBI'
         call hdiag(h,alpha,m,maxda3)
         do kk=1,m
            alam(kk)=h(m+1-kk,m+1-kk)
         enddo
         do kk=1,m/2
            do i=1,m
               vv=alpha(i,kk)
               alpha(i,kk)=alpha(i,m+1-kk)
               alpha(i,m+1-kk)=vv
            enddo
         enddo
c      endif
      if(nprint.ge.3.or.mprint(4).eq.1) then
         write(6,'('' alam'',10f8.4)')(alam(kk),kk=1,m)
         write(6,*)'Veff'
         call SCRIPT(alpha,m,m,maxda3,maxda3)
         write(6,*)'k',k
         if(k.gt.1)write(6,*)'k,alpha(k,k),alpha(kk,k-1)',
     *   k,alpha(k,k),(alpha(kk,k-1),kk=1,k-2)
      endif
c       if(k.ne.1.and.dabs(alpha(k,k)).lt.thr*10) then
      if(isuiv.ne.0.and.k.ne.1.and.dabs(alpha(k,k)).lt.0.1) then
c          do kk=1,k-2
c             if(dabs(alpha(kk,k-1)).gt.0.99) goto 54
c          enddo
         if(nprint.ge.3)write(6,*)'alpha(k-1,k-1)',alpha(k-1,k-1)
c          if(dabs(alpha(k-1,k-1)).gt.thr*10) goto 54
         if(dabs(alpha(k-1,k-1)).gt.0.1) goto 54
         write(6,*)'doublement de vecteurs propres'
         do kk=k-1,2,-1
            anor=0.d0
            do k1=1,k-1
               if(nprint.ge.3)write(6,*)'alpha(kk-1,kk)',alpha(kk-1,kk)
c               if(dabs(alpha(k1,kk)).gt.0.99) goto 55
               anor=anor+alpha(k1,kk)*alpha(k1,kk)
               if(anor.gt.0.99) goto 55
            enddo
            aa=alam(k)
            alam(k)=alam(kk)
            alam(kk)=aa
            do kkk=1,m
               aa=alpha(kkk,k)
               alpha(kkk,k)=alpha(kkk,kk)
               alpha(kkk,kk)=aa
            enddo
            goto 54
 55         continue
         enddo
         if(nprint.ge.5)call script(alpha,m,m,maxda3,maxda3)
      endif
 54   continue
C
C     SETS UP THE CORRECTION VECTOR QC
C     AND PERFORMS THE CONVERGENCE TEST
C
   75 continue
      SUMQ=ZERO
      open(81,form='unformatted',file='Q81',status='unknown')
      open(82,form='unformatted',file='Q82',status='unknown')
      do kk=1,ndet
         b(kk)=zero
      enddo
c     rewind 81
      call ecr8bl(b,ndet,81)
      if81=82
      if82=81
      rewind 81
      DO 90 L=1,M
      call lire(b,l,ndet,21)
      call lire(ab,l,ndet,22)
      iiff=if81
      if81=if82
      if82=iiff
      rewind if81
      rewind if82
      long=min(2048,ndet)
      call lir8(QC,long,if81)
c     print*,'zero',if81,(QC(kk),kk=1,long)
      ii=0
      DO 900 I=1,ndet
      ii=ii+1
      if(ii.eq.2049) then
         ii=1
         call ecr8(QC,2048,if82)
         long=2048
         if(i+2048.gt.ndet) long=mod(ndet,2048)
         call lir8(QC,long,if81)
c        print*,'apres'
      endif
c     print*,'qav',QC(ii)
      QC(Ii)=QC(Ii)+ALPHA(L,K)*(AB(I)-ALAM(K)*B(I))
c        print*,'QC',ii,QC(ii),ab(i),b(i)
 900  continue
      long=mod(ndet,2048)
      call ecr8(QC,long,if82)
   90 continue
      rewind if82
      ii=2048
      do i=1,ndet
         ii=ii+1
         if(ii.eq.2049) then
            ii=1
            long=2048
            if(i+2048.gt.ndet) long=mod(ndet,2048)
            call lir8(QC,long,if82)
         endif
         SUMQ=SUMQ+QC(Ii)*QC(Ii)
c        print*,'QC',ii,QC(ii)
      enddo
      SUMQ=DSQRT(SUMQ/ndet)
      WRITE (6,10) ITER,M,ALAM(K),SUMQ
      call flush(6)
      IF (SUMQ.LT.THR) GO TO 200
      IF (ITER.GE.NITER) GO TO 200
      ITER=ITER+1
C
C     IF M OVERFLOWS, THE B SUBSPACE IS THOROUGHLY REDEFINED
C
      IF (M.GE.MAXDA2) GO TO 200
C
C     COMPUTES THE VECTOR B(M+1)  TO ENLARGE THE B SUBSPACE
C
      iq=0
      rewind 25
      rewind if82
      rewind if81
      do 99 ii=1,ndet,ngru3
      if(iq+ngru3.gt.ndet) then
         ilong=ndet-iq
      else
         ilong=ngru3
      endif
      call lir8(diag,ilong,25)
      call lir8(QC,ilong,if82)
      if(yw) then
c         do kkk=1,ndet
c            write(6,'('' david diag '',f12.8,i8)')diag(kkk),kkk
c         enddo
c         do kk=1,ndet
c            abbid(iadrvbid(kk))=diag(kk)
c         enddo
c         do kk=1,ndet
c            print*,'kk,diag',kk,abbid(kk)
c         enddo
      endif
      DO 100 I=1,ilong
      iq=iq+1
      IF (DABS(QC(I))-EPS) 95,95,97
   95 QC(I)=ZERO
      GO TO 100
 97   continue
      if(dabs(ALAM(K)-DIAG(I)).lt.1.d-15) then
         write(6,*)'QUASI DEGENERESCENCE',alam(k),diag(i)
         QC(I)=QC(I)/(ALAM(K)-DIAG(I)-0.01)
      else
         QC(I)=QC(I)/(ALAM(K)-DIAG(I))
      endif
  100 CONTINUE
      call ecr8(QC,ilong,if81)
  99  continue
c
c
c      rewind if81
c     call lir8bl(QC,ndet,if81)
c
C
C     B(M+1)  WILL BE ORTHOGONAL TO A GIVEN SUBSPACE ORTH(1) ...
C     ... ORTH(NORTH) ,   TO PRESERVE SYMMETRY
C
      IF (NORTH.EQ.0) GO TO 108
      DO 106 IORTH=1,NORTH
      SUM=ZERO
      DO 104 I=1,NGAO
  104 SUM=SUM+ORTH(I,IORTH)*QC(I)
      DO 105 I=1,NGAO
  105 QC(I)=QC(I)-SUM*ORTH(I,IORTH)
  106 CONTINUE
  108 CONTINUE
c--   symetrie de spin : cas du singulet
c     b(m+1) est projete sur l'espace singulet
      rewind if81
      call lir8bl(ab,ndet,if81)
c      call syspi1(q,ndet)
c--   orthogonalisation de b(m+1) aux b(1)...b(m)
      DO 130 L=1,M
      call lire(b,l,ndet,21)
      SUM=ZERO
      DO 110 I=1,ndet
  110 SUM=SUM+B(I)*ab(I)
      DO 120 I=1,ndet
  120 ab(I)=ab(I)-SUM*B(I)
  130 CONTINUE
c--   normalisation
      SUM=ZERO
      DO 140 I=1,ndet
  140 SUM=SUM+ab(I)*ab(I)
      M=M+1
      SUM=ONE/DSQRT(SUM)
      DO 150 I=1,ndet
  150 B(I)=SUM*ab(I)
      call ecr(b,m,ndet,21)
      if(yw)write(6,*)'b',(b(kk),kk=1,ndet)
      close(81,status='delete')
      close(82,status='delete')
C
C     ADDS ONE ROW AND ONE COLUMN TO THE BAB MATRIX
C
      if(mprint(1).eq.1) then
         call scrida('b avant mul1c$',b,ndet,21,m)
      endif
      if(calcul.eq.'D') then
         call mul1(b,ab,m,ndet)
      else
         call mul1c(b,m)
      endif
      if(mprint(1).eq.1) then
         call scrida('ab apres mul1c$',ab,ndet,22,m)
      endif
      call lire(ab,m,ndet,22)
      if(yw)write(6,*)'2ab',(ab(kk),kk=1,ndet)
      DO 190 L=1,M
      SUM=ZERO
      call lire(b,l,ndet,21)
      DO 180 J=1,ndet
  180 SUM=SUM+B(J)*AB(J)
  190 BAB(M,L)=SUM
c--   fabrication du vecteur d'essai et ecriture
c     print*,'fabrication vecteur d''essai'
      rewIND 11
      WRITE(11) ndet,NVEC
      WRITE(11) (ALAM(kk),kk=1,NVEC),enuc,eref
      DO 1209 KK=1,NVEC
      do i=1,ndet
         b(i)=ZERO
      enddo
      DO LL=1,nvec
         alp=alpha(ll,kk)
         call lire(ab,ll,ndet,21)
         do i=1,ndet
            b(i)=b(i)+AB(I)*ALP
c     print*,'i,b(i)',i,b(i)
         enddo
         if(calcul.eq.'MD') then
            if(itest(73).eq.0) call sgncip(b,yesp(8*iadri+1),ndet)
            call reocip(b,ab,itab,ndet,2)
            WRITE(11)(AB(kkk),kkk=1,ndet)
c            print*,'ecriture 11 iter',iter
         else
            WRITE(11)(B(kkk),kkk=1,ndet)
         endif
      enddo
 1209 continue
c         WRITE(6,*)'alam', (ALAM(kk),kk=1,NVEC)
      close(11)
      open(11,file=fil11,status='old',form='unformatted')
C
C     BACK TO THE DIAGONALIZATION OF BAB
C
      GO TO 70
C
C     THE EIGENVECTORS OF BAB ARE BACK-TRANSFORMED
C     IN THE ORIGINAL BASIS
C
  200 CONTINUE
      DO 209 KK=1,NVEC
      do i=1,ndet
         ab(i)=ZERO
      enddo
      DO LL=1,M
         alp=alpha(ll,kk)
         call lire(b,ll,ndet,21)
         do i=1,ndet
            ab(i)=ab(i)+B(I)*ALP
         enddo
      enddo
      call ecr(ab,kk,ndet,23)
      do i=1,ndet
         b(i)=ZERO
      enddo
      DO LL=1,M
         alp=alpha(ll,kk)
         call lire(ab,ll,ndet,22)
         do i=1,ndet
            b(i)=b(i)+AB(I)*ALP
         enddo
      enddo
      call ecr(b,kk,ndet,24)
 209  continue
      DO 220 KK=1,NVEC
      call lire(b,kk,ndet,23)
      call ecr(b,kk,ndet,21)
      call lire(b,kk,ndet,24)
      call ecr(b,kk,ndet,22)
  220 continue
      IF (ITER.GE.NITER.and.sumq.gt.thr) GO TO 250
      IF (SUMQ.LT.THR.AND.K.GE.NVEC) then
         RETURN
      endif
      IF (SUMQ.LT.THR.AND.K.LT.NVEC) then
         ITER=1
         k=k+1
      endif
      IF (SUMQ.LT.THR) WRITE (6,5) K
      M=NVEC
      DO 240 L=1,NVEC
      DO 230 LL=1,NVEC
      BAB(L,LL)=ZERO
  230 ALPHA(L,LL)=ZERO
      BAB(L,L)=ALAM(L)
  240 ALPHA(L,L)=ONE
      GO TO 75
 250  CONTINUE
      WRITE (6,20) ITER
c      STOP
      return
      END
       subroutine reocip(b,b2,iadrv,ndet,icas)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      common/dim/iadri ; integer(8) iadri
      dimension b(ndet),iadrv(2048),b2(ndet)
      common/opt/ihab,calcul
      character*3 calcul
      if(calcul.ne.'MD') return
      rewind 87
c      call lirbl(iadrv,ndet,87)
      kk=2048
      if(icas.eq.1) then
         do k=1,ndet
            kk=kk+1
            if(kk.eq.2049) then
               kk=1
               call liri(iadrv,2048,87)
            endif
            b2(k)=b(iadrv(kk))
         enddo
      else
         do k=1,ndet
            kk=kk+1
            if(kk.eq.2049) then
               kk=1
               call liri(iadrv,2048,87)
            endif
            b2(iadrv(kk))=b(k)
         enddo
      endif
      return
      end
       subroutine sgncip(b,ysgn,ndet)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      common/dim/iadri ; integer(8) iadri
      dimension b(iadri),ysgn(iadri)
      common/opt/ihab,calcul
      character*3 calcul
      if(calcul.ne.'MD') return
      rewind 85
      call liry(ysgn,ndet,85)
      do k=1,ndet
c          write(6,*)'sgncip ysgn',k,ysgn(k)
         if(.not.ysgn(k))b(k)=-b(k)
      enddo
      return
      end
       subroutine lirdav
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      PARAMETER (ngru3=2048)
      parameter (maxda3=300,maxorbcas=16)
      include 'maxorb.prm'
car he metido la definicion de SPI como caracter porque da error la compilacion
      character*2 SPI
      logical*1 bidia
      character*1280 namel
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      character*4 hab
      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
      common/pr/nprint,mprint(10)
      common/opt/ihab,calcul
      character*3 calcul
      common /ijd/itab,jtab,dtab
      common/habil/c2,c0,
     *iterh,maxith,ndeth,ith(maxorbcas+2),iph(maxorbcas+2),neh
     *,ihvec1,iadrh
      common/sui/isuiv
      dimension ITAB(NGRU3),JTAB(NGRU3)
      real*4 DTAB(NGRU3)
      common/test/itest(100)
      common/memoire/mem
      common/stp/stop
      common /det/ndet,mdet(50),nbdet_cas
      common /fpspi/yfpspi
      character*8 stop,restart
      character*1 syspin
      common /sysp1/syspin
      common /stoc/ jint,jnb(1024),jnb1
     *,iter,lonstc,maxstc,ystc,ystit1
      common/scmr/yscmrs
      common/pert/schift,damp,ypertu,ycaspert
c      COMMON/GAO/GUESS,ORTH,GSYM,NGAO,NORTH
      common/g2/lg2,ig2,lg2p,ig2p,lg2m,ig2m,ng2,yg2,yga2
      character*1 espace
      common /prep/ nca0,ncb0,ic0(maxorbcas),icamun(maxorb+maxorb)
     *,numt(maxorb),nump(maxorb),nv
     *,gener,yoc(maxorb+maxorb),yrefc(maxorbcas),yac(maxorb)
     *,ygmono,ygddci,ygddc2,ygcas,ygtous
      character*4 gener
      namelist/dav/bidia,calcul,damp,espace,hab
     *,idelint,ideldet
     *,if_diag,if_hoi,if_iadrv,if_ysgn,ihab,ihprec
     *,ihvec,iprec,ipresc,irest,isuiv,iternat
     *,lvec,maxda2,maxith,maxstc,mem
     *,nbtots,ndeth,nessai,nfrag,ngao,ng2,niter,nprint,nvec
     *,restart,schift,sh,sint,sint4,stop,syspin,tau,twcas,twvec,twess
     *,ycaspert,ydens,yfpspi,yhmono,ypertu,ytana,ywcas,ywvec
      common/pbconv/ coef0
      common/only/ ymatonly
      common /orbspi/ norbspi,iorbspi(10),spi
     *,y1h,y1p,y1h1p,y22h,y2p,y1h2p,y2h1p,yio
c     *,mprint,itest
      ng2=1
      ypertu=.false.
      ystomono=.false.
      yscmrs=.false.
      if_diag=0
      if_hoi=0
      if_iadrv=0
      if_ysgn=0
      iternat=0
      hab='SC2'
      ydens=.true.
      yw=.false.
      irest=0
      syspin='0'
      yhmono=.false.
      yfpspi=.false.
      stop='FIN'
      restart='        '
      isuiv=0
      do k=1,10
         mprint(k)=0
      enddo
      do k=1,100
         itest(k)=0
      enddo
      itest(11)=2
      itest(16)=1
      itest(20)=0
      do k=38,43
         itest(k)=1
      enddo
      itest(44)=2
      itest(64)=maxorbcas
      itest(60)=1
      itest(61)=1
      itest(66)=1
      itest(69)=1
      itest(72)=1
      itest(73)=1 ! ne met pas les signes cipsi
      itest(76)=1 ! provisoire : desactive le calcul 
                  ! de la fn propre de S2
      ytana=.false.
      sint=0.d0
      sint4=0.d0
      ndeth=1
      ihprec=3
      ihvec=1
      sh=0.5
      ifiess=15
      maxith=10
      ihab=0
      ywvec=.true.
      ywcas=.false.
      twcas=0.03
      twvec=0.03
      twess=0.1
      calcul='MD'
      nbtots=0
      nvec=1
      ngao=-1
      niter=50
      iprec=6
      nessai=0
      bidia=.false.
      tau=2.d-1
      nprint=0
      maxda2=0
      ipresc=6
      itest(12)=-1
      itest(25)=1
      itest(26)=1
      idelint=-1
      ideldet=-1
      maxstc=-1
      espace='M'
      damp=1.d0
      schift=0.d0
      nfrag=0
      coef0=1.d-13
      ycaspert=.true.
      nhabcl=0
      mhabcl=0
      ypolspi=.false.
      y1h=.false.
      y1p=.false.
      y1h1p=.false.
      y22h=.false.
      y2p=.false.
      y1h2p=.false.
      y2h1p=.false.
      yio=.false.
      norbspi=0
      iorbspi=0
      icl_jterh=2
      if(nprint.ge.1)write(6,*)' '
      if(nprint.ge.1)write(6,*)'==========================='
      if(nprint.ge.1)write(6,*)'david   lecture des donnees'
      if(nprint.ge.1)write(6,*)'==========================='
      rewind 93
      call LECNAM('&DAV',namel,93,ierr,1)
      call namell(namel,YSTOMONO,'YSTOMONO',1)
      call namell(namel,ypertu,'YPERTU',1)
      call namell(namel,ywvec,'YWVEC',1)
      call namell(namel,ywcas,'YWCAS',1)
      call nameld(namel,twcas,'TWCAS',8)
      call nameld(namel,coef0,'COEF0',8)
      call namell(namel,ytana,'YTANA',1)
      call nameli(namel,isuiv,'ISUIV',4)
      call namell(namel,yfpspi,'YFPSPI',1)
      call namell(namel,yhmono,'YHMONO',1)
      call namell(namel,ydens,'YDENS',1)
      call namell(namel,ypolspi,'YPOLSPI',1)
      call namell(namel,y1h,'Y1H',1)
      call namell(namel,y1p,'Y1P',1)
      call namell(namel,y1h1p,'Y1H1P',1)
      call namell(namel,y22h,'Y22H',1)
      call namell(namel,y2p,'Y2P',1)
      call namell(namel,y1h2p,'Y1H2P',1)
      call namell(namel,y2h1p,'Y2H1P',1)
      call namell(namel,yio,'YIO',1)
      call nameli(namel,norbspi,'NORBSPI',4)
      call nameli(namel,iorbspi,'IORBSPI',4)

      call namell(namel,ycaspert,'YCASPERT',1)
      call nameli(namel,nbtots,'NBTOTS',4)
      call nameli(namel,NFRAG,'NFRAG',4)
      call nameli(namel,nvec,'NVEC',4)
      do k=1,nvec
         lvec(k)=0
      enddo
      call nameli(namel,lvec(1),'LVEC',4)
      call nameli(namel,ngao,'NGAO',4)
      call nameli(namel,niter,'NITER',4)
      call nameli(namel,iprec,'IPREC',4)
      call nameli(namel,nessai,'NESSAI',4)
      call nameli(namel,nprint,'NPRINT',4)
      call nameli(namel,maxda2,'MAXDA2',4)
      if(maxda2==0) maxda2=min(nvec*4,maxda3)
      call nameli(namel,ihab,'IHAB',4)
      call nameli(namel,NHABCL,'NHABCL',4)
      call nameli(namel,MHABCL,'MHABCL',4)
      call nameli(namel,ICL_JTERH,'ICL_JTERH',4)
      call nameli(namel,ITERH,'ITERH',4)
      call nameli(namel,maxith,'MAXITH',4)
      call nameli(namel,ihprec,'IHPREC',4)
      call nameli(namel,ipresc,'IPRESC',4)
      call nameli(namel,mprint(1),'MPRINT',4)
      call nameli(namel,itest(1),'ITEST',4)
      call nameli(namel,ihvec,'IHVEC',4)
      call nameli(namel,ndeth,'NDETH',4)
      call nameli(namel,NG2,'NG2',4)
      call nameli(namel,maxstc,'MAXSTC',4)
      call nameli(namel,irest,'IREST',4)
      call nameli(namel,iternat,'ITERNAT',4)
      call namell(namel,bidia,'BIDIA',1)
      call nameld(namel,tau,'TAU',8)
      call nameld(namel,twvec,'TWVEC',8)
      call nameld(namel,twess,'TWESS',8)
      call nameld(namel,sint4,'SINT4',8)
      call nameld(namel,sint,'SINT',8)
      call nameld(namel,sh,'SH',8)
      call namela(namel,calcul,'CALCUL')
      call namela(namel,stop,'STOP')
      call namela(namel,restart,'RESTART')
      call namela(namel,syspin,'SYSPIN')
      call namela(namel,hab,'HAB')
      call namela(namel,espace,'ESPACE')
      call nameli(namel,idelint,'IDELINT',4)
      call nameli(namel,ideldet,'IDELDET',4)
      call nameli(namel,MEM,'MEM',4)
      call nameli(namel,IF_DIAG,'IF_DIAG',4)
      call nameli(namel,IF_HOI,'IF_HOI',4)
      call nameli(namel,IF_IADRV,'IF_IADRV',4)
      call nameli(namel,IF_YSGN,'IF_YSGN',4)
      call nameld(namel,DAMP,'DAMP',8)
      call nameld(namel,SCHIFT,'SCHIFT',8)
      rewind 75
c      write(6,dav)
c     write(6,'('' itest'')')
c     write(6,'(20i4)') itest
c     write(6,'('' mprint'')')
c     write(6,'(20i4)') mprint
      if(ystomono) itest(37)=1
c
c--   coherence des donnees
c
      if(mhabcl==0) nhabcl=0
      if(mhabcl/=0.and.nhabcl==0) nhabcl=1
      if(mhabcl/=0.and.icl_jterh==0) icl_jterh=2
      if(mhabcl==0) icl_jterh=niter+1
      if(itest(66).eq.0) then
         itest(60)=0
         itest(61)=0
      endif
      call maj(stop,8)
      call maj(restart,8)
      call maj(calcul,3)
      if(ymatonly) calcul='D'
      call maj(hab,4)
      if(calcul.eq.'M') maxstc=0
      if(calcul.eq.'M'.or.calcul.eq.'D'.or.calcul.eq.'G2') then
          syspin='0'
          print*,'syspin est mis a zero car calcul=',calcul
      endif
      if(calcul.ne.'MDD') itest(21)=0
      itest(31)=iternat
      itest(32)=if_diag
      itest(33)=if_hoi
      itest(34)=if_iadrv
      itest(35)=if_ysgn
      if(stop.eq.'DEL') itest(35)=1
      if(iternat.ne.0) then
         if(irest.ne.0.or.restart.ne.'        ') print*,
     *   'les donnees de irest et de restart sont ignorees '
     *   ,'si iternat est en donnee'
         if(stop.ne.'FIN') print*,
     *   'la donnee de stop est ignoree '
     *   ,'stop=''ITERNAT'' si iternat est en donnee'
         stop='ITERNAT'
         if(iternat.eq.2) then
            restart='INT'
         else if (iternat.eq.3) then
            restart='DET'
         else if (iternat.eq.4) then
            restart='INTDET'
         endif
      endif
      if(iternat.gt.4.or.iternat.lt.0) then
         print*,'mauvaise valeur pour iternat',iternat
         stop
      endif
      if(restart.eq.'INT') then
         irest=2
      else if (restart.eq.'DET') then
         irest=3
      else if (restart.eq.'INTDET') then
         irest=1
      endif
      if(irest/=0.or.restart.ne.' ') print*,'david irest',irest,restart
      itest(1)=irest
      if(espace.eq.'P') then
         if(idelint.eq.-1) idelint=1
         if(ideldet.eq.-1) ideldet=1
         if(maxstc.eq.-1)maxstc=0
      else  if(espace.eq.'M') then
         if(idelint.eq.-1) idelint=0
         if(ideldet.eq.-1) ideldet=0
         if(maxstc.eq.-1)maxstc=100
      else
         if(idelint.eq.-1) idelint=0
         if(ideldet.eq.-1) ideldet=0
         if(maxstc.eq.-1)maxstc=500
      endif
      itest(27)=idelint
      itest(28)=ideldet
c     ystit1=itest(30).eq.1
      if(calcul.eq.'D') ydens=.false.
      if(itest(77)==1) then
         write(75,dav)
         write(75,'('' mprint='')')
         write(75,'(10i4)') mprint
         write(75,'('' itest='')')
         write(75,'(5(10i4,/))') itest
         call scrinam('NAMELIST DAV   ')
C         write(75,'('' itest='')')
C         write(75,'(5(10i4,/))') itest
      endif
      if(calcul.eq.'G2DB') then
         calcul='G2'
         itest(70)=1
      endif
      if(mhabcl/=0) then
         namel(i+60:i+60)='#'
         i=i+j
         namel(i+1:i+11)="Habillage :"
         namel(i+60:i+60)='#'
         i=i+j
         write(namel(i+1:i+60),'(a,i1)')'mhabcl=',mhabcl
         if(mhabcl==1)write(namel(i+9:i+60),'(a)')'(MR-CEPA_0)'
         if(mhabcl==2)write(namel(i+9:i+60),'(a)')'(MR-CEPA_0 raffine)'
         namel(i+60:i+60)='#'
         i=i+j
         write(namel(i+1:i+60),'(a,i1)')'vecteur ref (nhabcl)=',nhabcl
         namel(i+60:i+60)='#'
         i=i+j
         write(namel(i+1:i+60),'(a,i3)')
     *   'habillage a partir de l''iteration (icl_jterh) ',icl_jterh
         namel(i+60:i+60)='#'
         i=i+j
         call titre(namel(1:i),70)
      endif
      yg2=calcul.eq.'G2'
      if(itest(45).eq.1.or.yg2) then
         calcul='MD'
         ivvvv1=0
         ioooo2=0
         ivovo3=0
         ivvoo4=0
         iovvo5=0
         ivooo6=0
         ivoov7=0
         ivvvc8=0
         iccvv9=0
         icvcv10=0
         ioocc11=0
         iococ12=0
         icovv13=0
         icvov14=0
         icvoo15=0
         icovo16=0
         icooo17=0
         iccov18=0
         icocv19=0
         iccco20=0
         icccv21=0
         icccc22=0
      endif
      yga2=.false.
      print*,
     *'=========================='//
     *'=================================='
      print*,' '
      if(calcul.eq.'MDD') then
         calcul='MD'
         itest(21)=1
      endif
      if(hab.eq.'ACPF'.or.hab.eq.'AQCC') then
         itest(11)=2
      endif
      if(ihab.ne.0) then
         if(hab.ne.'SC2'.and.hab.ne.'ACPF'.and.hab.ne.'AQCC') then
            print*,'donne non prevue pour hab : hab=',hab
            stop
         endif
      endif
      if(calcul.eq.'M') then
         itest(30)=0
         print*,'itest(30) mis a 0 car calcul.eq.M'
      endif
      if(yhmono) then
         itest(16)=1
         print*,'itest(16) mis a 1 car yhmono=t'
      endif
c      write(6,*)'mprint',mprint
      if(syspin.ne.'0'.and.syspin.ne.'+'.and.syspin.ne.'-') then
         print*,'syspin peut prendre les valeurs 0,+,- et non',
     *   syspin
         stop
      endif
      if(yw)print*,'dans lirdav nbtots,nvec,maxda2',nbtots,nvec,maxda2
c      if(itest(12).eq.-1.and.nvec.eq.1) itest(12)=0
c      if(itest(12).eq.-1.and.nvec.gt.1) itest(12)=1
      if(itest(12).eq.-1) itest(12)=1
      if(calcul.ne.'MD') itest(12)=0
      if(itest(2).eq.1)open(99,file='mattest',status='unknown')
      write(6,*)''
      if(ihab.eq.1) iprec=iprec-ihprec
      maxda2=min(maxda2,maxda3)
      if(ngao.eq.-1)ngao=min(nvec,maxda3)
      if(ihab.eq.1) ngao=1
c      call sto5
      return
      end
       subroutine wvec(b,iadrv,ysgn)
      parameter (maxda3=300)
      include 'maxorb.prm'
      parameter (maxorbcas=16,ngru3=2048)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |      b        | iadrv |
c
      common/dim/iadri ; integer(8) iadri
      common/test/itest(100)
      common/opt/ihab,calcul
      character*3 calcul
      dimension iadrv(ndet),ysgn(ndet)
      common /ijd/ vec(ngru3/2*3)
      common /det/ndet,mdet(50),nbdet_cas
      character*4 hab
      character*80 det1
      common/detfile/ det1
      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
      common/pr/nprint,mprint(10)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension itv(10),ipv(10)
      dimension ica(maxorbcas),icb(maxorbcas),it(2),ip(2)
      character*2 iwspin(maxorb*2)
      character*2 ibla2
      character virg*1,fn*4,itc*4,ipc*4,icc*4
      character*60 detc
      real*4 b4
      logical*1 bidia
      DIMENSION B(iadri)
      virg=','
      ibla1=0
      call finnam(fn)
c      if(calcul.eq.'MD') then
c         rewind 87
c         call lirbl(iadrv,ndet,87)
c      endif
      do k=1,norb
         iwspin(k)='+ '
         iwspin(k+norb)='- '
      enddo
      if(itest(50).ne.1)open(52,status='UNKNOWN',file='ESSOUT')
      if(ywcas)open(53,status='UNKNOWN',file='ESCASOUT')
      do kk=1,nvec
         write(6,'(/,a27,i4,''  Ecorr='',f12.8,'' '',f22.12)')
     *   '|  VECTEUR PROPRE NUMERO',
     *   kk,alam(kk),alam(kk)+enuc+eref
         call lire(b,kk,ndet,21)
         if(calcul.eq.'MD') then
            if(itest(73).eq.0)call sgncip(b,ysgn,ndet)
            rewind 87
            call lirbl(iadrv,ndet,87)
         endif
         call rew61
         c_cas=0.d0
         do ll=1,ndet
            call venondloc(ne,itv,ipv,ierr)
            if(ierr.eq.1) goto 1
            ne1=ne
            if(ne.ne.0) then
               if(ipv(ne).eq.norb+norb+1)ne1=ne-1
            endif
            ywv=dabs(b(ll)).gt.twvec
            ywv1=dabs(b(ll)).gt.0.1d0
            ibla2='=>'
            ycas=.true.
            do k=1,ne
               if(itype(iorb(itv(k))).eq.1) ycas=.false.
            enddo
            do k=1,ne1
               if(itype(iorb(ipv(k))).eq.3) ycas=.false.
            enddo
            if(ycas)c_cas=c_cas+b(ll)*b(ll)
            if(ywcas.and.ycas) then
               ywv=dabs(b(ll)).gt.twcas
               ibla2='C>'
            endif
 3          continue
            if(ywv) then
               l=(ne)*10+5
               if(l.gt.50) then
                  if(ywv1) then
                     write(6,6667)(IORB(itv(I)),IWSPIN(itv(I)),I=1,ne),
     *               ibla1,ibla2
                     detc(1:35)='                                   '
                     write(detc,6667)
     *               (IORB(ipv(I)),IWSPIN(ipv(I)),I=1,ne1)
                  else
                     write(6,6666)(IORB(itv(I)),IWSPIN(itv(I)),I=1,ne),
     *               ibla1,ibla2
                     detc(1:35)='                                   '
                     write(detc,6666)
     *               (IORB(ipv(I)),IWSPIN(ipv(I)),I=1,ne1)
                  endif
                  if(calcul.eq.'MD') then
                     write(6,'(a35,15x,3X,F11.7,i8)')detc(1:35)
     *               ,(b(ll))
                  else
                     write(6,'(a60,F11.7,i8)')detc(1:60)
     *               ,b(ll)
c                     write(6,'(a60,15x,3X,F11.7,i8)')detc(1:60)
c     *               ,b(ll)
                  endif
               else
                  detc(1:50)='                          '//
     *            '                        '
                  if(ywv1) then
                     write(detc,6667)
     *               (IORB(itv(I)),IWSPIN(itv(I)),I=1,ne),
     *               ibla1,ibla2, (IORB(ipv(I)),IWSPIN(ipv(I)),I=1,ne1)
                  else
                     write(detc,6666)
     *               (IORB(itv(I)),IWSPIN(itv(I)),I=1,ne),
     *               ibla1,ibla2, (IORB(ipv(I)),IWSPIN(ipv(I)),I=1,ne1)
                  endif
                  if(calcul.eq.'MD') then
                     write(6,'(a50,3X,F11.7,i8)')
     *               detc(1:50),b(ll)
                  else
                     write(6,'(a50,3X,F11.7,i8)')
     *               detc(1:60),b(ll)
                  endif
               endif
            endif
6666        FORMAT(1X, 12(I3,A2))
6667        FORMAT('|', 12(I3,A2))
c
c--         ecriture de vecteurs d'essai
            if(itest(50).eq.1) goto 100
            if(dabs(b(ll)).gt.twess) then
               call trad(ne,itv,ipv,nca,ica,ncb,icb,nt,it,ispt,
     *         np,ip,ispp,ierr)
               if(ierr.eq.1) goto 100
               if(nt.eq.0) then
                  itc='    '
               else
                  itc='it= '
               endif
               if(nca+ncb.eq.0) then
                  icc='    '
               else
                  icc='ic= '
               endif
               if(np.eq.0) then
                  ipc='    '
               else
                  ipc='ip= '
               endif
               b4=b(ll)
               rewind 75
               write(75,*)' &ess~',itc
     *         ,(it(i),virg,i=1,(nt+ispt)/2)
     *         ,(-iorb(it(i)),virg,i=(nt+ispt)/2+1,nt)
     *         ,icc,(ica(i),virg,i=1,nca),(-icb(i),virg,i=1,ncb)
     *         ,ipc
     *         ,(ip(i),virg,i=1,(np+ispp)/2)
     *         ,(-iorb(ip(i)),virg,i=(np+ispp)/2+1,np)
     *         ,'v(',kk,')=',b4,'~',fn,'#'
               call scril2(52)
            endif
c           ecriture des determinants du CAS sur fichier
            if(ywcas) then
               call trad(ne,itv,ipv,nca,ica,ncb,icb,nt,it,ispt,
     *         np,ip,ispp,ierr)
               if(nt.eq.0.and.np.eq.0) then
                  if(nca+ncb.eq.0) then
                     icc='    '
                  else
                     icc='ic= '
                  endif
                  b4=b(ll)
                  rewind 75
                  write(75,*)' &ess~'
     *            ,icc,(ica(i),virg,i=1,nca),(-icb(i),virg,i=1,ncb)
     *            ,'v(',kk,')=',b4,'~',fn,'#'
                  call scril2(53)
               endif
            endif
            goto 100
 1          continue
            if(dabs(b(ll)).gt.twvec)write(6,'(i8,f15.8)')ll,b(ll)
 100        continue
         enddo
         print'('' Somme des carres des coefficients du CAS'',f10.6)'
     *   ,c_cas

! Multiplicite de spin :
         if(itest(76)==0) then
            !print*,noac,norb,ndet,ms2,kk,det1,noca
            call s2casdi_sub(noac,norb,ndet,ms2
     *,     kk,1.d-2,det1,b,(noca+nocb+1)/2,0,amult)
            print'(a,f10.4)',' Multiplicite de spin',amult
            print*,' '
         endif
      enddo
c6666  FORMAT(1X, 8(I3,A2,' '),/,(1X,8(I3,A1,' ')))
      close(52)
      close(53)
      return
      end
       subroutine finnam(fn)
      character*4 fn
      character*80 fn1
      namelist/end/ dum
      open(95,file='BID95')
      dum=0.
      write(95,end)
      rewind 95
      read(95,'(a80)') fn1
      read(95,'(a80)',end=1) fn1
      read(95,'(a80)',end=1) fn1
 1    continue
      do 2 k=80,1,-1
      if(fn1(k:k).eq.' ') goto 2
      if(fn1(k:k).eq.'/') then
         fn='/   '
      else
         fn='&end'
      endif
      close(95,status='DELETE')
      return
 2    continue
      end
       subroutine scrinam(c)
      character b*80,a*2000,c*15
      rewind 75
      i=0
 1    i=i+1
      a(i:i)=' '
      read(75,'(a80)',end=1000) b
c     print*, b
      do k=1,80
         if(b(k:k).ne.' ') then
            i=i+1
            a(i:i)=b(k:k)
         endif
      enddo
      goto 1
 1000 continue
c      do k=1,i,60
c         print'(50(1x,a60))', a(k:k+59)
c      enddo
      print*,' '
      print*,'===================== ',c,
     *' ======================'
      k=0
      kk=0
 3    k=k+1
      kk=kk+1
c     print*,'k,kk,a(k:k)',k,kk,a(k:k)
      b(kk:kk)=a(k:k)
      if(k.ge.i) then
         print'(1x,a)', b(1:kk-1)
         goto 2
      endif
      kks=kk
      if(kks.gt.50) then
         do kkk=kks+1,i
c        print*,'kkk',kkk
            k=k+1
c           print*,'kkk,a',a(k:k)
            if(a(k:k).eq.' '.or.a(k:k).eq.','.or.kkk.gt.72) then
               b(kkk:kkk)=a(k:k)
               print'(1x,a)', b(1:kkk-1)
               kk=0
               goto 3
            else
               b(kkk:kkk)=a(k:k)
            endif
         enddo
      endif
      goto 3
c      do k=1,i,60
c         print'(50(1x,a60))', a(k:k+59)
c      enddo
 2    print*,
     *'=========================='//
     *'=================================='
      print*,' '
      rewind 75
c      print*,'sortie scrinam'
 
      return
      end
 
