      subroutine bofill(B,iesp,AB,alam,THR,maxdav,maxda2,
     *NVEC,NITER,yesp,ytana)
C*************************
C
C     DIAGONALIZATION BOFILL
C
      ImPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      PARAmETER (ngru3=2048,maxorbcas=16)
      include 'maxorb.prm'
      parameter (maxda3=300)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |      b        |       ab      |
c    |      yesp                     |
c
      dimension yesp(*)
      common/dim/iadri ; integer(8) iadri
      DImENSION B(mAXDAV),AB(mAXDAV),iesp(maxdav*2),
     *diag(ngru3)
      dimension bab1(maxda3,maxda3)
      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/mulr/m0,m2,m3,maxl0,icalc(maxda3),icalc1,ycvl(maxda3)
      common /ijd/itab,jtab,dtab
      dimension itab(NGRU3),JTAB(NGRU3)
      real*4 DTAB(NGRU3)
      dimension sumq(maxda3)
      common /det/ndet,mdet(50),nbdet_cas
      common/test/itest(100)
      common/habil/c2,c0,
     *iterh,maxith,ndeth,ith(maxorbcas+2),iph(maxorbcas+2),neh
     *,ihvec1,iadrh
      common/sui/isuiv
      common/pert/schift,damp,ypertu,ycaspert
      common/pr/nprint,mprint(10)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/tps/ icpu(10)
      common /stoc/ jint,jnb(1024),jnb1
     *,iter,lonstc,maxstc,ystc,ystit1
      character*132 temps
      character*40 temps2
      character*40 form
      common/stp/stop
      character*8 stop
      character*4 hab
      logical*1 bidia
      logical conver(maxda3)
      dimension eig(maxda3),eigim(maxda3)
      dimension ifad(maxda3,maxda3)
      yw=.false.
      call flush(6)
      maxda2=min(maxda2,maxda3-1)
c----------------------------------
c     mises a zero
c----------------------------------
      icpu(1)=itemps(idum)
      lonstc=0
      jnb1=0
      icalc1=0
      m=nvec
      ncv=0
      do kk=1,nvec
         ycvl(kk)=.false.
      enddo
      ITER=0
      m0=0
      m2=nvec
      small=1.d-7
      big=1.d+20
      crit=1.d-4
      nconverv=0
      nconver=0
      CONDIS = CRIT
      CONVEI = CRIT*CRIT*1.0D02
      CONGNR = CRIT*CRIT*1.0D03
      WRITE (6,'('' CONVERGENCE CRITERIA: '')')
      WRITE (6,'('' CON. DIS. '',F9.6,'' CON. V. EIG. ''
     .,F9.6,'' CON. GNR. '',F9.6)') CONDIS,CONVEI,
     .CONGNR
      open(36,file='BOFILL_B',status='unknown',form='unformatted')
      open(37,file='BOFILL_AB',status='unknown',form='unformatted')
c-----------------------------------------
c     premier produit
c-----------------------------------------
      if(mprint(5).eq.1) then
         do kk=m0+1,m
            call scrida('b0 avant mulmc$',b,ndet,21,kk)
         enddo
      endif
      call mulmc2(b,iesp,1,nvec)
      if(mprint(5).eq.1) then
         do kk=m0+1,m
            call scrida('ab0 apres mulmc$',ab,ndet,22,kk)
         enddo
      endif
      do ivec=1,nvec
         ifad(1,ivec)=ivec
      enddo
c-----------------------------------------
c     boucle sur les iterations
c-----------------------------------------
c      rewind 36
c      rewind 37
      do ivec=1,nvec
         call lire(b,ivec,ndet,21)
         call ecr(b,ivec,ndet,23)
c         call ecr8bl(b,ndet,36)
         call lire(ab,ivec,ndet,22)
         call ecr(ab,ivec,ndet,24)
c         call ecr8bl(ab,ndet,37)
         if(yw) then
            do i=1,ndet
               print*,'vec,hvec',i,b(i),ab(i)
            enddo
         endif
         gnorm1=0.d0
         eigim(ivec)=0.d0
         do k=1,ndet
            eigim(ivec)=eigim(ivec)+b(k)*ab(k)
         enddo
         if(yw)print*,'eigim apres son calcul',ivec,eigim(ivec)
         do k=1,ndet
            ab(k)=ab(k)-eigim(ivec)*b(k)
            gnorm1=gnorm1+ab(k)*ab(k)
         enddo
         if(itest(59).eq.0) then
            gnorm1=DSQRT(gnorm1/ndet)
         else
            gnorm1=DSQRT(gnorm1/nbdet_cas)
         endif
         if(gnorm1.le.thr) CONVER(ivec)=.TRUE.
         if(yw)WRITE (6,'('' ITER0. '','' EIG '',
     .   F12.6,'' GNORM '',2F12.6)') EIGIM(ivec),gnorm1
      enddo
      iterm=0
      do 200 iter=1,niter
      if(yw)print*,'iter,iterm,m',iter,iterm,m
      iterm=iterm+1
      mmm=m+nconver
      do ivec=1,nvec
         if(.not.conver(ivec)) then
            ycv=.false.
            mmm=mmm+1
            ifad(iterm+1,ivec)=mmm
            if(yw)print*,'calc ifad',iterm+1,ivec,mmm
         else
            ifad(iterm+1,ivec)=0
            if(yw)print*,'calc ifad',iterm+1,ivec,0
         endif
      enddo
      if(yw)print*,'iter',iter
c      rewind 36
c      rewind 37
      m1=m+1
      do ivec=1,nvec
         if(conver(ivec)) goto 10
         call lire(b,ivec,ndet,23)
         call lire(ab,ivec,ndet,24)
         eig(ivec)=0.d0
         do k=1,ndet
            eig(ivec)=eig(ivec)+b(k)*ab(k)
         enddo
 10      continue
      enddo
      if(yw)print*,'eig0',(eig(ivec),ivec=1,nvec)
c-----------------------------------------
C     NOW COMPUTES A IMPROVEMENT OF THE APPROXIMATED
C     EIGENVALUE (EQ. 11 CHEM. PHYS. 183 (1994) 19-26)
c-----------------------------------------
c      rewind 36
c      rewind 37
      do ivec=1,nvec
         if(conver(ivec)) goto 20
         call lire(b,ivec,ndet,23)
c        on lit la diagonale
         rewind 25
         call lir8bl(ab,ndet,25)
         if(yw) then
            do i=1,ndet
               print*,'diag0',i,ab(i)
            enddo
         endif
         do i=1,ndet
            if(yw)print'('' hdia,vec,eig'',3f10.6)',ab(i),b(i),eig(ivec)
            ab(i)=b(i)/(ab(i)-eig(ivec)+small)
         enddo
         if(yw) then
            do i=1,ndet
               print*,'diag1',i,ab(i)
            enddo
         endif
         xthix=0.d0
         do i=1,ndet
            xthix=xthix+b(i)*ab(i)
         enddo
         deig=0.d0
         ifin=0
         kk=0
         do k=1,ndet,ngru3
            kk=kk+1
            ideb=ifin+1
            ifin=min(ideb+ngru3-1,ndet)
c            call lir8(diag,ifin-ideb+1,37)
            numenr=(ivec-1)*((ndet-1)/ngru3+1)+kk
            call lirec(diag,numenr,ifin-ideb+1,24)
            ii=0
            do i=ideb,ifin
               ii=ii+1
               aaa=ab(i)*(diag(ii)-eig(ivec)*b(i))
               deig=deig+ab(i)*(diag(ii)-eig(ivec)*b(i))
            enddo
         enddo
      if(yw)print*,'deig,xthix',deig,xthix
         deig=deig/xthix
         eigim(ivec)=eig(ivec)+deig
         if(yw)print*,'deig,eigim',deig,eigim(ivec)
C     **********
C     NOW COMPUTES A NEW BASES VECTOR
C     (EQ. 12 CHEM. PHYS. 183 (1994) 19-26)
C     **********
         do i=1,ndet
            b(i)=eigim(ivec)*ab(i)
         enddo
         if(yw) then
            do i=1,ndet
               print*,'diag,vec',i,ab(i),b(i)
            enddo
         endif
         rewind 25
c         rewind 37
c         do isaut=1,ivec-1
c            call saut(37,ndet)
c         enddo
         call lir8bl(ab,ndet,25)
         ifin=0
         kk=0
         do k=1,ndet,ngru3
            kk=kk+1
            ideb=ifin+1
            ifin=min(ideb+ngru3-1,ndet)
c            call lir8(diag,ifin-ideb+1,37)
            numenr=(ivec-1)*((ndet-1)/ngru3+1)+kk
            call lirec(diag,numenr,ifin-ideb+1,24)
            ii=0
            do i=ideb,ifin
               ii=ii+1
               if(yw)print'(a20,i4,4f10.6)',
     *         'i,vec,hvec,hdia',i,b(i),diag(ii),ab(i),
     *         b(I) - diag(I) / (ab(I) - EIG(ivec) + SmALL)
               b(i)=b(i)-diag(ii)/(ab(i)-eig(ivec)+small)
            enddo
         enddo
         if(yw) then
            do i=1,ndet
               print*,'vec',i,b(i)
            enddo
         endif
C     **********
C     ORTHONORMALIZES THE NEW BASES VECTOR USING THE
C     GRAM-SCHMIDT PROCEDURE
C     **********
 180     continue
         DO  L1=1,iterm-1
c         DO  L=ivec,m-nvec,nvec
            l=ifad(l1+1,ivec)
            if(yw)print*,'coucou'
            if(yw)print*,'l,m',l1,m
c            call lire(ab,l+nvec,ndet,21)
            call lire(ab,l,ndet,21)
            if(yw)print*,'lect ortho',l1,ivec,l
            SUM=0.d0
            DO I=1,ndet
               SUM=SUm+aB(I)*b(I)
            enddo
            DO I=1,ndet
               b(I)=b(I)-SUm*aB(I)
            enddo
         enddo
         if(yw) then
            do i=1,ndet
               print*,'vec3',i,b(i)
            enddo
         endif
         SUM=0.d0
         DO I=1,ndet
            SUM=SUm+b(I)*b(I)
         enddo
         IF (sum .LE. SMALL*SMALL*1.0D-01) THEN
            WRITE(6,'('' THE DIAGONALIZATION PROCESS IS ENDED DUE''
     .      ,/,'' TO LINEAR DEPENDENCIES.'')')
            print*,'vecteur',ivec
            conver(ivec)=.true.
         ENDIF
         if(yw)print*,'m,sum',m,sum
         SUM=1.d0/DSQRT(SUm)
         DO I=1,ndet
            aB(I)=SUm*b(I)
         enddo
c         call ecr(ab,m+ivec,ndet,21)
            if(yw)print*,'ecr nouv',iterm+1,ivec,ifad(iterm+1,ivec)
         call ecr(ab,ifad(iterm+1,ivec),ndet,21)
         if(sum.gt.big) goto 180
         if(yw) then
            do i=1,ndet
               print*,'vec2',i,ab(i)
            enddo
         endif
 20      continue
      enddo
C     **********
C     END OF GRAM-SCHMIDT PROCEDURE NOW
C     COMPUTES THE HB(I) VECTOR
C     **********
c-----------------------------------------
c     appel H*Psi0
c-----------------------------------------
      m0=m2
      m2=m0+nvec-nconver
      if(yw)print*,'m0,m2',m0,m2,nvec,nconver
      if(mprint(5).eq.1) then
         do kk=m0+1,m2
         print*,'kk',kk
         call scrida('b avant mulmc$',b,ndet,21,kk)
         enddo
      endif
      if(yw)print*,'avant mulmc2'
 
      call mulmc2(b,iesp,m+nvec,nvec)
      if(yw)print*,'apres mulmc2'
      if(mprint(5).eq.1) then
         do kk=m0+1,m2
         print*,'kk',kk
         call scrida('ab apres mulmc$',ab,ndet,22,kk)
         enddo
      endif
      if(yw)print*,'m0,m',m0,m
c      print*,'apres mulmc2'
c      rewind 37
      mm1=iterm+1
      do ivec=1,nvec
         if(conver(ivec)) goto 30
c-----------------------------------------
c     calcul de l'hamiltonien effectif
c-----------------------------------------
         DO 60 L=1,iterm
c         call lire(b,nvec*l+ivec,ndet,21)
         call lire(b,ifad(l+1,ivec),ndet,21)
         DO 60 LL=1,L
         BABL=0.d0
c         call lire(ab,nvec*ll+ivec,ndet,22)
         call lire(ab,ifad(ll+1,ivec),ndet,22)
            if(yw)print*,'lire22 heff',ll+1,ivec,ifad(ll+1,ivec)
         DO 50 J=1,ndet
         if(yw)print'('' babl'',i4,3f10.6)',j,babl,b(j),ab(j)
   50    BABL=BABL+B(J)*AB(J)
         BAB(LL+1,L+1)=BABL
   60    BAB(L+1,LL+1)=BABL
 
 
 
 
 
 
         do k=2,m+1
            bab(k,k)=bab(k,k)-eig(ivec)
         enddo
c         eig(ivec)=bab(m+1,m+1)
 
 
 
 
 
 
 
         if(yw)print*,'iterm,m,bab(m+1,m+1)',iterm,m,bab(m+1,m+1)
         if(yw)print*,'ivec,eig(ivec)',ivec,eig(ivec)
         if(yw)print*,'ivec,eigim(ivec)',ivec,eigim(ivec)
C     **********
C     NOW PERFORMS THE NEWTON-RAPHSON OPTIMIZATION
C     IN THE SUBSPACE
C     **********
         bab(1,1)=0.d0
c         rewind 36
c         do isaut=1,ivec-1
c            call saut(36,ndet)
c         enddo
c         print*,'avant lec',ivec
c         call lir8bl(b,ndet,36)
          call lire(b,ivec,ndet,23)
c         print*,'apres lec',ivec
         do jiter=1,iterm
c            call lire(ab,nvec*jiter+ivec,ndet,22)
            call lire(ab,ifad(jiter+1,ivec),ndet,22)
            if(yw)print*,'lire22 fin',jiter+1,ivec,ifad(jiter+1,ivec)
            bthx=0.d0
            do i=1,ndet
               bthx=bthx+b(i)*ab(i)
            enddo
            bab(1,jiter+1)=bthx
            bab(jiter+1,1)=bthx
         enddo
         do jiter=1,iterm
c            call lire(b,nvec*jiter+ivec,ndet,21)
            call lire(b,ifad(jiter+1,ivec),ndet,21)
            if(yw)print*,'lire fin',jiter+1,ivec,ifad(jiter+1,ivec)
            bthb=0.d0
            btx=0.d0
            ifin=0
            kk=0
            do k=1,ndet,ngru3
               kk=kk+1
               ideb=ifin+1
               ifin=min(ideb+ngru3-1,ndet)
c               call lir8(diag,ifin-ideb+1,36)
               numenr=(ivec-1)*((ndet-1)/ngru3+1)+kk
               call lirec(diag,numenr,ifin-ideb+1,23)
               ii=0
               do i=ideb,ifin
                  ii=ii+1
c               bthb=bthb+b(i)*ab(i)
                  btx=btx+b(i)*diag(ii)
               enddo
            enddo
            bab(1,jiter+1)=bab(1,jiter+1)-eigim(ivec)*btx
            bab(jiter+1,1)=bab(jiter+1,1)-eigim(ivec)*btx
         enddo
 
 
 
         if(mprint(4).eq.1) then
            write(6,*)'Heff'
            call SCRIPT(bab,iterm+1,iterm+1,maxda3,maxda3)
c        write(6,'('' alam avant riera'',4f8.4)')(alam(kk),kk=1,m)
         endif
c     test de convergence
         GNORM = 0.0D0
         DO 270 JITER = 1,iterm
         GNORM = GNORM + bab(1,JITER+1)**2
         if(yw)print*,'gnorm,bab',jiter,gnorm,bab(1,JITER+1)
  270    CONTINUE
         GNORM = DSQRT(GNORM)
c-----------------------------------------------
c     diagonalisation de l'hamiltonien effectif
c-----------------------------------------------
c     diagonalisation
         CALL RIERA(iterm+1,bab,alpha,alam,P,maxda3,ierr)
         if(ierr.eq.1) then
            print*,'diagonalisation JACOBI'
            call hdiag(h,alpha,m+1,maxda3)
            do k=1,iterm
               alam(k)=h(iterm+1-k,iterm+1-k)
            enddo
            do k=1,iterm/2
               do i=1,iterm
                  vv=alpha(i,k)
                  alpha(i,k)=alpha(i,iterm+1-k)
                  alpha(i,iterm+1-k)=vv
               enddo
            enddo
         endif
         if(mprint(4).eq.1) then
            write(6,'('' alam'',10f8.4)')(alam(kk),kk=1,iterm+1)
            write(6,*)(alam(kk),kk=1,iterm+1)
            write(6,*)'Veff'
            call SCRIPT(alpha,iterm+1,iterm+1,maxda3,maxda3)
         endif
   75    continue
C     **********
C     LOOKS FOR THE MINIMUM DISTANCE
C     **********
         DISTM = BIG
         KROOT = 1
         DO 240 JITER = 1,mm1
         SVEC11 = alpha(1,JITER)
         SVEC12 = SVEC11 * SVEC11
         DISTJ = 1.0D0 / (SVEC12 + SmALL*1.0D-03) - 1.0D0
         DISTJ = DSQRT(DABS(DISTJ))
         IF (DISTJ .LT. DISTm) THEN
            KROOT = JITER
            DISTm = DISTJ
         ENDIF
  240    CONTINUE
C     **********
C     COMPUTES THE DISTANCE VECTOR
C     **********
         SVEC11 = alpha(1,KROOT)
         IF (SVEC11 .LT. 0.0D0) THEN
            SVEC11 = -SVEC11
            DO 250 JITER1 = 2,mm1
            JK = JITER1 + mm1 * (KROOT - 1)
            alpha(jiter1,kroot) = -alpha(jiter1,kroot)
  250       CONTINUE
         ENDIF
         VAREIG = alam(KROOT) / 2.0D0
         DO 260 JITER1 = 2,mm1
         JK = JITER1 + mm1 * (KROOT - 1)
         JITER = JITER1 - 1
         alam(JITER) = alpha(jiter1,kroot) / SVEC11
  260    CONTINUE
         if(yw)write(6,'('' dist'',10f8.4)')(alam(kk),kk=1,mm1)
C     **********
C     CONVERGENCE TEST
C     **********
         SVEC12 = SVEC11 * SVEC11
         DIST = 1.0D0 / SVEC12 - 1.0D0
         DIST = DSQRT(DABS(DIST))
c
c     gnorm remplace par h*psi - e*psi
c
c         rewind 36
c         rewind 37
c         do isaut=1,ivec-1
c            call saut(36,ndet)
c            call saut(37,ndet)
c         enddo
c         call lir8bl(b,ndet,36)
c         call lir8bl(ab,ndet,37)
         call lire(b,ivec,ndet,23)
         call lire(ab,ivec,ndet,24)
         gnorm1=0.d0
         do k=1,ndet
            ab(k)=ab(k)-eigim(ivec)*b(k)
            gnorm1=gnorm1+ab(k)*ab(k)
         enddo
         if(itest(59).eq.0) then
            gnorm1=DSQRT(gnorm1/ndet)
         else
            gnorm1=DSQRT(gnorm1/nbdet_cas)
         endif
         if(yw)print*,'gnorm1',gnorm1
c
 
         VAREIG = DABS(VAREIG)
c      IF ((DIST .LE. CONDIS .AND. GNORM .LE. CONGNR .AND.
c     .    VAREIG .LE. CONVEI) .OR. ITER .GE. niter) CONVER
c     .    = .TRUE.
         if(gnorm1.le.thr.OR.ITER.GE.niter) CONVER(ivec)=.TRUE.
         WRITE (6,'('' ITER,M '',2I3,'' DIST '',F12.6,'' EIG '',
     .   F12.6,'' GNORM '',2F12.6)') ITER,M,DIST,EIGIM(ivec),gnorm1
C     **********
C     COMPUTES THE NEW VECTOR AND THE NEW H*VEC
C     **********
c         REWIND 36
c         do isaut=1,ivec-1
c            call saut(36,ndet)
c         enddo
c         call lir8bl(b,ndet,36)
         call lire(b,ivec,ndet,23)
         DO 280 JITER = 1,iterm
c         call lire(ab,nvec*jiter+ivec,ndet,21)
         call lire(ab,ifad(jiter+1,ivec),ndet,21)
            if(yw)print*,'lire fin2',jiter+1,ivec,ifad(jiter+1,ivec)
         DO 290 I = 1,Ndet
         b(I) = b(I) + ab(I) * alam(JITER)
         if(yw)print*,'b,ab,alam',i,b(i),ab(i),alam(jiter)
  290    CONTINUE
  280    CONTINUE
         overla=0.d0
         do i=1,ndet
            overla=overla+b(i)*b(i)
         enddo
         dnorm=1.d0/dsqrt(overla)
         do i=1,ndet
            b(i)=b(i)*dnorm
         enddo
c         rewind 36
c         do isaut=1,ivec-1
c            call saut(36,ndet)
c         enddo
c         call ecr8bl(b,ndet,36)
         call ecr(b,ivec,ndet,23)
         if(yw) then
            do i=1,ndet
               print*,'fin vec',i,b(i)
            enddo
         endif
c         REWIND 37
c         do isaut=1,ivec-1
c            call saut(37,ndet)
c         enddo
c         call lir8bl(b,ndet,37)
         call lire(b,ivec,ndet,24)
         DO 300 JITER = 1,iterm
c         call lire(ab,nvec*jiter+ivec,ndet,22)
         call lire(ab,ifad(jiter+1,ivec),ndet,22)
            if(yw)print*,'lire fin3',jiter+1,ivec,ifad(jiter+1,ivec)
         DO 310 I = 1,Ndet
         if(yw)print'(a20,i4,4f10.6)','hvec(i),hdia(i),alfa(jiter)',
     *   i,b(i),ab(i),alam(jiter),
     *   b(I) + ab(I) * alam(JITER)
         b(I) = b(I) + ab(I) * alam(JITER)
  310    CONTINUE
  300    CONTINUE
         do i=1,ndet
            b(i)=b(i)*dnorm
         enddo
c         rewind 37
c         do isaut=1,ivec-1
c            call saut(37,ndet)
c         enddo
c         call ecr8bl(b,ndet,37)
         call ecr(b,ivec,ndet,24)
         if(yw) then
            do i=1,ndet
               print*,'fin hvec',i,b(i)
            enddo
            call flush(6)
         endif
 30      continue
      enddo
      if(yw)print'('' CONVER'',50l2)',(conver(ivec),ivec=1,nvec)
      nconverv=nconver
      nconver=0
      ycv=.true.
      do ivec=1,nvec
         if(.not.conver(ivec)) then
            ycv=.false.
            m=m+1
         else
            nconver=nconver+1
         endif
      enddo
      if(m.gt.maxda2)then
         if(yw)print*,'m=nvec',iter,m,maxda2
         m=nvec
         m2=nvec
         iterm=0
      endif
      IF (ycv) THEN
         IF (ITER .GE. niter) then
            WRITE(IOUT,'('' L-N-R PROCEDURE '',
     .      ''DID NOT CONVERGE IN '',I3,'' ITERATIONS'')') niter
         else
            print*,'CONVERGENCE'
         endif
         CLOSE (IX,STATUS='DELETE')
         CLOSE (IV,STATUS='DELETE')
         CLOSE (IS,STATUS='DELETE')
         CLOSE (ID,STATUS='DELETE')
         CLOSE (IH,STATUS='DELETE')
c         rewind 36
         do ivec=1,nvec
c         call lir8bl(b,ndet,36)
         call lire(b,ivec,ndet,23)
         call ecr(b,ivec,ndet,21)
         if(yw) then
            do k=1,ndet
               print *,'vec transmis',k,b(k)
            enddo
         endif
         alam(ivec)=eigim(ivec)
         enddo
         RETURN
      ENDIF
 
 
c      m=m+nvec
 
      print*,'---------------------------------------'
 200  continue
      return
      end
 
 
 
 
 
       subroutine bofillv(B,iesp,AB,alam,THR,maxdav,maxda2,
     *NVEC,NITER,yesp,ytana)
C*************************
C
C     DIAGONALIZATION BOFILL
C
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      PARAMETER (ngru3=2048,maxorbcas=16)
      include 'maxorb.prm'
      parameter (maxda3=300)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |      b        |       ab      |
c    |      yesp                     |
c
      dimension yesp(*)
      common/dim/iadri ; integer(8) iadri
      DIMENSION B(MAXDAV),AB(MAXDAV),iesp(maxdav*2),
     *diag(ngru3)
      dimension bab1(maxda3,maxda3)
      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/mulr/m0,m2,m3,maxl0,icalc(maxda3),icalc1,ycvl(maxda3)
      common /ijd/itab,jtab,dtab
      dimension itab(NGRU3),JTAB(NGRU3)
      real*4 DTAB(NGRU3)
      dimension sumq(maxda3)
      common /det/ndet,mdet(50),nbdet_cas
      common/test/itest(100)
      common/habil/c2,c0,
     *iterh,maxith,ndeth,ith(maxorbcas+2),iph(maxorbcas+2),neh
     *,ihvec1,iadrh
      common/sui/isuiv
      common/pert/schift,damp,ypertu,ycaspert
      common/pr/nprint,mprint(10)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/tps/ icpu(10)
      common /stoc/ jint,jnb(1024),jnb1
     *,iter,lonstc,maxstc,ystc,ystit1
      character*132 temps
      character*40 temps2
      character*40 form
      common/stp/stop
      character*8 stop
      character*4 hab
      logical*1 bidia
      logical conver
      yw=.true.
      if(nvec.gt.1) then
         print*,' '
         print*,'diagonalisation Bofill : 1 vecteur max'
         stop
      endif
      write(6,*)'ITER  M'
      call flush(6)
c----------------------------------
c     mises a zero
c----------------------------------
      icpu(1)=itemps(idum)
      lonstc=0
      jnb1=0
      icalc1=0
      m=1
      ncv=0
      do kk=1,nvec
         ycvl(kk)=.false.
      enddo
      ITER=0
      m0=0
      m2=nvec
      small=1.d-7
      big=1.d+20
      crit=3.d-4
      CONDIS = CRIT
      CONVEI = CRIT*CRIT*1.0D02
      CONGNR = CRIT*CRIT*1.0D03
      WRITE (IOUT,'('' CONVERGENCE CRITERIA: '')')
      WRITE (IOUT,'('' CON. DIS. '',F9.6,'' CON. V. EIG. ''
     .      ,F9.6,'' CON. GNR. '',F9.6)') CONDIS,CONVEI,
     .      CONGNR
      open(36,file='BOFILL_B',status='unknown',form='unformatted')
      open(37,file='BOFILL_AB',status='unknown',form='unformatted')
c-----------------------------------------
c     premier produit
c-----------------------------------------
      call scrida('b0 avant mulmc$',b,ndet,21,1)
      call mulmc2(b,iesp,1,nvec)
      call scrida('ab0 apres mulmc$',ab,ndet,22,1)
c-----------------------------------------
c     boucle sur les iterations
c-----------------------------------------
      rewind 36
      rewind 37
      call lire(b,1,ndet,21)
      call ecr8bl(b,ndet,36)
      call lire(ab,1,ndet,22)
      call ecr8bl(ab,ndet,37)
      do i=1,ndet
         print*,'vec,hvec',i,b(i),ab(i)
      enddo
      do 200 iter1=1,10
      iter=iter+1
      rewind 36
      rewind 37
      call lir8bl(b,ndet,36)
      call lir8bl(ab,ndet,37)
      m1=m+1
      eig=0.d0
      do k=1,ndet
         eig=eig+b(k)*ab(k)
      enddo
      print*,'eig0',eig
c-----------------------------------------
C     NOW COMPUTES A IMPROVEMENT OF THE APPROXIMATED
C     EIGENVALUE (EQ. 11 CHEM. PHYS. 183 (1994) 19-26)
c-----------------------------------------
c     on lit la diagonale
      rewind 25
      call lir8bl(ab,ndet,25)
      do i=1,ndet
         print*,'diag0',i,ab(i)
      enddo
      do i=1,ndet
       print'('' hdia,vec,eig'',3f10.6)',ab(i),b(i),eig
         ab(i)=b(i)/(ab(i)-eig+small)
      enddo
      do i=1,ndet
         print*,'diag1',i,ab(i)
      enddo
      xthix=0.d0
      do i=1,ndet
         xthix=xthix+b(i)*ab(i)
      enddo
      deig=0.d0
      ifin=0
      rewind 37
      do k=1,ndet,ngru3
         ideb=ifin+1
         ifin=min(ideb+ngru3-1,ndet)
         call lir8(diag,ifin-ideb+1,37)
         ii=0
         do i=ideb,ifin
            ii=ii+1
            aaa=ab(i)*(diag(ii)-eig*b(i))
            deig=deig+ab(i)*(diag(ii)-eig*b(i))
         enddo
      enddo
      if(yw)print*,'deig,xthix',deig,xthix
      deig=deig/xthix
      eigim=eig+deig
      print*,'deig,eigim',deig,eigim
C     **********
C     NOW COMPUTES A NEW BASES VECTOR
C     (EQ. 12 CHEM. PHYS. 183 (1994) 19-26)
C     **********
      do i=1,ndet
         b(i)=eigim*ab(i)
      enddo
      do i=1,ndet
         print*,'diag,vec',i,ab(i),b(i)
      enddo
      rewind 25
      rewind 37
      call lir8bl(ab,ndet,25)
      ifin=0
      do k=1,ndet,ngru3
         ideb=ifin+1
         ifin=min(ideb+ngru3-1,ndet)
         call lir8(diag,ifin-ideb+1,37)
         ii=0
         do i=ideb,ifin
            ii=ii+1
         print'(a20,i4,4f10.6)',
     *'i,vec,hvec,hdia',i,b(i),diag(ii),ab(i),
     *b(I) - diag(I) / (ab(I) - EIG + SMALL)
            b(i)=b(i)-diag(ii)/(ab(i)-eig+small)
         enddo
      enddo
      do i=1,ndet
         print*,'vec',i,b(i)
      enddo
C     **********
C     ORTHONORMALIZES THE NEW BASES VECTOR USING THE
C     GRAM-SCHMIDT PROCEDURE
C     **********
 180  continue
         DO  L=1,M-1
           print*,'coucou'
            print*,'l,m',l,m
            call lire(ab,l+1,ndet,21)
            SUM=0.d0
            DO I=1,ndet
               SUM=SUM+aB(I)*b(I)
            enddo
            DO I=1,ndet
               b(I)=b(I)-SUM*aB(I)
            enddo
         enddo
      do i=1,ndet
         print*,'vec3',i,b(i)
      enddo
         SUM=0.d0
         DO I=1,ndet
            SUM=SUM+b(I)*b(I)
         enddo
         IF (sum .LE. SMALL*SMALL*1.0D-01) THEN
            WRITE(IOUT,'('' THE DIAGONALIZATION PROCESS IS ENDED DUE''
     .           ,/,'' TO LINEAR DEPENDENCIES.'')')
            conver=.true.
         ENDIF
         if(yw)print*,'m,sum',m,sum
c         M=M+1
         SUM=1.d0/DSQRT(SUM)
         DO I=1,ndet
            aB(I)=SUM*b(I)
         enddo
         call ecr(ab,m1,ndet,21)
      if(sum.gt.big) goto 180
      do i=1,ndet
         print*,'vec2',i,ab(i)
      enddo
C     **********
C     END OF GRAM-SCHMIDT PROCEDURE NOW
C     COMPUTES THE HB(I) VECTOR
C     **********
c-----------------------------------------
c     appel H*Psi0
c-----------------------------------------
c      if(mprint(5).eq.1) then
c         do kk=m0+1,m
            call scrida('b avant mulmc$',b,ndet,21,m1)
c         enddo
c      endif
c      print*,'avant mulmc2'
 
        m0=m
        m2=m+1
      call mulmc2(b,iesp,m+1,nvec)
c      print*,'apres mulmc2'
c      if(mprint(5).eq.1) then
c         do kk=m0+1,m1
            call scrida('ab apres mulmc$',ab,ndet,22,m1)
c         enddo
c      endif
c       print*,'m0,m',m0,m
c      print*,'apres mulmc2'
c-----------------------------------------
c     calcul de l'hamiltonien effectif
c-----------------------------------------
      DO 60 L=1,M
      call lire(b,l+1,ndet,21)
      DO 60 LL=1,L
      BABL=0.d0
      call lire(ab,ll+1,ndet,22)
      DO 50 J=1,ndet
         print'('' babl'',i4,3f10.6)',j,babl,b(j),ab(j)
   50 BABL=BABL+B(J)*AB(J)
      BAB(LL+1,L+1)=BABL
   60 BAB(L+1,LL+1)=BABL
      eig=bab(m+1,m+1)
         print*,'bab(m+1,m+1)',bab(m+1,m+1)
C     **********
C     NOW PERFORMS THE NEWTON-RAPHSON OPTIMIZATION
C     IN THE SUBSPACE
C     **********
      bab(1,1)=0.d0
      rewind 36
      call lir8bl(b,ndet,36)
      do jiter=1,m
         call lire(ab,jiter+1,ndet,22)
         bthx=0.d0
         do i=1,ndet
            bthx=bthx+b(i)*ab(i)
         enddo
         bab(1,jiter+1)=bthx
         bab(jiter+1,1)=bthx
      enddo
      do jiter=1,m
         call lire(b,jiter+1,ndet,21)
         bthb=0.d0
         btx=0.d0
         ifin=0
         rewind 36
         do k=1,ndet,ngru3
            ideb=ifin+1
            ifin=min(ideb+ngru3-1,ndet)
            call lir8(diag,ifin-ideb+1,36)
            ii=0
            do i=ideb,ifin
               ii=ii+1
c               bthb=bthb+b(i)*ab(i)
               btx=btx+b(i)*diag(ii)
            enddo
         enddo
         bab(1,jiter+1)=bab(1,jiter+1)-eigim*btx
         bab(jiter+1,1)=bab(jiter+1,1)-eigim*btx
      enddo
 
 
 
c      if(mprint(4).eq.1) then
         write(6,*)'Heff'
         call SCRIPT(bab,m+1,m+1,maxda3,maxda3)
        write(6,'('' alam avant riera'',4f8.4)')(alam(kk),kk=1,m)
c      endif
c-----------------------------------------------
c     diagonalisation de l'hamiltonien effectif
c-----------------------------------------------
c     diagonalisation
      CALL RIERA(M+1,bab,alpha,alam,P,maxda3,ierr)
      if(ierr.eq.1) then
         print*,'diagonalisation JACOBI'
         call hdiag(h,alpha,m+1,maxda3)
         do k=1,m
            alam(k)=h(m+1-k,m+1-k)
         enddo
         do k=1,m/2
            do i=1,m
               vv=alpha(i,k)
               alpha(i,k)=alpha(i,m+1-k)
               alpha(i,m+1-k)=vv
            enddo
         enddo
      endif
c      if(mprint(4).eq.1) then
         write(6,'('' alam'',10f8.4)')(alam(kk),kk=1,m+1)
         write(6,*)'Veff'
         call SCRIPT(alpha,m+1,m+1,maxda3,maxda3)
c      endif
   75 continue
C     **********
C     LOOKS FOR THE MINIMUM DISTANCE
C     **********
      DISTM = BIG
      KROOT = 1
      DO 240 JITER = 1,m1
         SVEC11 = alpha(1,JITER)
         SVEC12 = SVEC11 * SVEC11
         DISTJ = 1.0D0 / (SVEC12 + SMALL*1.0D-03) - 1.0D0
         DISTJ = DSQRT(DABS(DISTJ))
         IF (DISTJ .LT. DISTM) THEN
            KROOT = JITER
            DISTM = DISTJ
         ENDIF
  240 CONTINUE
C     **********
C     COMPUTES THE DISTANCE VECTOR
C     **********
      SVEC11 = alpha(1,KROOT)
      IF (SVEC11 .LT. 0.0D0) THEN
         SVEC11 = -SVEC11
         DO 250 JITER1 = 2,m1
            JK = JITER1 + m1 * (KROOT - 1)
            alpha(jiter1,kroot) = -alpha(jiter1,kroot)
  250    CONTINUE
      ENDIF
      VAREIG = alam(KROOT) / 2.0D0
      DO 260 JITER1 = 2,m1
         JK = JITER1 + m1 * (KROOT - 1)
         JITER = JITER1 - 1
         alam(JITER) = alpha(jiter1,kroot) / SVEC11
  260 CONTINUE
         write(6,'('' dist'',10f8.4)')(alam(kk),kk=1,m+1)
C     **********
C     CONVERGENCE TEST
C     **********
      SVEC12 = SVEC11 * SVEC11
      DIST = 1.0D0 / SVEC12 - 1.0D0
      GNORM = 0.0D0
      DO 270 JITER = 1,m
         GNORM = GNORM + bab(1,JITER+1)**2
  270 CONTINUE
      DIST = DSQRT(DABS(DIST))
      GNORM = DSQRT(GNORM)
      VAREIG = DABS(VAREIG)
      IF ((DIST .LE. CONDIS .AND. GNORM .LE. CONGNR .AND.
     *    VAREIG .LE. CONVEI) .OR. ITER .GE. niter) CONVER
     *    = .TRUE.
      WRITE (6,'('' ITER. '',I3,'' DIST '',F12.6,'' EIG '',
     *      F12.6,'' GNORM '',F12.6,l2)') IITER,DIST,EIGIM,GNORM,conver
C     **********
C     COMPUTES THE NEW VECTOR AND THE NEW H*VEC
C     **********
      REWIND 36
      call lir8bl(b,ndet,36)
      DO 280 JITER = 1,m
         call lire(ab,jiter+1,ndet,21)
         DO 290 I = 1,Ndet
            b(I) = b(I) + ab(I) * alam(JITER)
        print*,'b,ab,alam',i,b(i),ab(i),alam(jiter)
  290    CONTINUE
  280 CONTINUE
      overla=0.d0
      do i=1,ndet
         overla=overla+b(i)*b(i)
      enddo
      dnorm=1.d0/dsqrt(overla)
      do i=1,ndet
         b(i)=b(i)*dnorm
      enddo
      rewind 36
      call ecr8bl(b,ndet,36)
      do i=1,ndet
         print*,'fin vec',i,b(i)
      enddo
      REWIND 37
      call lir8bl(b,ndet,37)
      DO 300 JITER = 1,m
         call lire(ab,jiter+1,ndet,22)
         DO 310 I = 1,Ndet
         print'(a20,i4,4f10.6)','hvec(i),hdia(i),alfa(jiter)',
     *i,b(i),ab(i),alam(jiter),
     *b(I) + ab(I) * alam(JITER)
            b(I) = b(I) + ab(I) * alam(JITER)
  310    CONTINUE
  300 CONTINUE
      do i=1,ndet
         b(i)=b(i)*dnorm
      enddo
      rewind 37
      call ecr8bl(b,ndet,37)
      do i=1,ndet
         print*,'fin hvec',i,b(i)
      enddo
      IF (CONVER) THEN
         IF (ITER .GE. niter) then
            WRITE(IOUT,'('' L-N-R PROCEDURE '',
     .      ''DID NOT CONVERGE IN '',I3,'' ITERATIONS'')') niter
         else
            print*,'CONVERGENCE'
         endif
         CLOSE (IX,STATUS='DELETE')
         CLOSE (IV,STATUS='DELETE')
         CLOSE (IS,STATUS='DELETE')
         CLOSE (ID,STATUS='DELETE')
         CLOSE (IH,STATUS='DELETE')
         rewind 36
         call lir8bl(b,ndet,36)
         call ecr(b,1,ndet,21)
         alam(1)=eigim
         RETURN
      ENDIF
 
 
 
 
 
 
 
 
      m=m+1
 
 200  continue
      return
      end
 
