      program LIDAVEC
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      allocatable alam(:),alpha(:,:),a(:),b(:),yesp(:)
      character*80 det
      dimension bb(2048)
      print*,'------------------------'
      print*,'    LIDAVEC             '
      print*,'------------------------'
      print*,' '
      print*,'voulez-vous'
      print*,' - afficher le vecteur sur l''ecran pour ',
     *'un calcul en cours ? (1)'
      print*,' - recuperer le vecteur d''un calcul qui a echoue ? (2)'
      read(5,*) icas
      if(icas.eq.1) then
         print*,'nom du fichier de determinants ?'
         read(5,'(a)') det
         open(61,file=det,form='unformatted',status='old')
      else
         print*,'le vecteur d''essai sera sur lidavec_ess'
         open(2,file='lidavec_ess',form='unformatted',status='unknown')
      endif
      

      open(1,file='LIDAVEC',form='unformatted',status='old')
      print*,' '
      print*,'----------------'
      print*,'     LIDAVEC   '
      print*,'----------------'
      print*,' '
      read(1) n,nvec
      print*,'n,nvec',n,nvec
      allocate (alam(n))
      allocate (a(n),b(n),yesp(n))
      read(1) (alam(kk),kk=1,nvec),enuc,eref
      write(6,'(''alam'',10f10.6)') alam(1:nvec)
      write(6,'(''enuc'',f14.6)') enuc
      write(6,'(''eref'',f14.6)') eref
      read(1) m,iter,norb
      print*,'dimension de l''hamiltonien effectif',m
      print*,'le vecteur est recupere a l''iteration',iter
      allocate (alpha(m,nvec))
      read(1) alpha
      print*,' '
      print*,'Heff'
      call script(alpha,m,nvec,m,nvec)
!      
      inquire(iolength=long) bb
      open(21,status='UNKNOWN',file='DIRB',access='DIRECT',
     *recl=long,form='UNFORMATTED')
!
      open(85,file='YSGN',form='unformatted',status='old')
      open(87,file='IADRV',form='unformatted',status='old')
      read(85) yesp
!
      if(icas.eq.2) then
         write(2) n,nvec
         write(2) (alam(kk),kk=1,nvec),enuc,eref
      endif
!      do k=1,100
!         call lire(a,k,n,21)
!         print*,'k',k
!      enddo
      do kk=1,nvec
         b=0.d0
         do k=1,m
            print*,'avant lire',k,m
            call lire(a,k,n,21)
            b=a*alpha(k,kk)+b
         enddo
         call sgncip(b,yesp,n)
         call reocip(b,a,n)
         anorm=dsqrt(dot_product(b,b))
c         print*,'anorm',anorm
         b=b/anorm
!         do k=1,n
!            if(dabs(b(k)).gt.0.02) print'(''vec'',i9,f10.6)',k,b(k)
!         enddo
         if(icas.eq.2) write(2) b
         if(icas.eq.1) call wvec(b,n,norb,1,alam(kk),enuc,eref,kk)
      enddo
      end


       subroutine sgncip(b,ysgn,n)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      dimension b(n),ysgn(n)
      do k=1,n
         if(.not.ysgn(k))b(k)=-b(k)
      enddo
      return
      end

      
       subroutine reocip(b,b2,n)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      common/dim/ iadri
      dimension b(n),iadrv(2048),b2(n)
      common/opt/ihab,calcul
      character*3 calcul
      rewind 87
      kk=2048
      do k=1,n
         kk=kk+1
         if(kk.eq.2049) then
            kk=1
            read(87) iadrv
         endif
         b2(iadrv(kk))=b(k)
      enddo
      return
      end
      subroutine lire(b,l,n,ifil)
      parameter (ngru3=2048)
      IMPLICIT REAL*8(A-H,O-Z)
      dimension b(n)
c      write(6,*)'lire l,n,ifil',l,n,ifil
      nn=(n-1)/ngru3
      ll=(l-1)*(nn+1)
      do k=1,n,ngru3
         ll=ll+1
c          read(ifil,rec=l) b
         long=min0(ngru3,n-k+1)
         call lirec(b(k),ll,long,ifil)
      enddo
      return
      end
       subroutine lirec(b,ll,long,ifil)
      IMPLICIT REAL*8(A-H,O-Z)
      dimension b(long)
c      print*,'lirec ll',ll,ifil,long
      read(ifil,rec=ll) b
      return
      end
       SUBROUTINE script (OAP,M,N,MD,ND)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION OAP(MD,ND)
      nnn=10
      NN=N/nnn
      IF(NN.EQ.0) GOTO 85
      DO 83 KK=1,NN
      N1=nnn*(KK-1)+1
      N2=nnn*KK
      IF(N2.LT.N1) RETURN
      WRITE(6,1023)
      WRITE(6,1024) (I,I=N1,N2)
      WRITE(6,1022)
      DO 83 JJ=1,M
83    WRITE(6,1025) JJ,(OAP(JJ,II),II=N1,N2)
      WRITE(6,1022)
85    N1=nnn*NN+1
      N2=N
      IF(N2.LT.N1) RETURN
      WRITE(6,1023)
      WRITE(6,1024) (I,I=N1,N2)
      WRITE(6,1022)
      DO 84 JJ=1,M
84    WRITE(6,1025) JJ,(OAP(JJ,II),II=N1,N2)
      WRITE(6,1022)
1022  FORMAT(/)
1023  FORMAT(/)
1024  FORMAT(/,1X,10(6X,I2))
1025  FORMAT(3X,I2,10F8.4)
      RETURN
      END



       subroutine venond(ne,ntv,npv,ierr,norb1)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter(maxorb=275,maxorbcas=16,lungo=100,maxne=maxorbcas+2)
      character*1 ctps,cex,c256
      common/detsto/mdestod,ndestod,mdestod1,ndestod1,npie2,mpie2,
     *mpie256,mdestod256,mdestod2561,
     *ctps((maxne)*lungo*2),cex(lungo),c256((maxne/4+1)*lungo)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      dimension ntv(maxorbcas+2),npv(maxorbcas+2)
      dimension np1024(4)
      yw=.false.
      norb=norb1
      ierr=0
      ndestod1=ndestod1+1
      if(ndestod1.gt.ndestod) then
         read(61,end=1) mdestod,ndestod,(ctps(i),i=1,mdestod),
     *   (cex(i),i=1,ndestod)
     *   ,mdestod256,(c256(i),i=1,mdestod256)
         if(yw)print*,'venond2 lect ndestod,mdestod',ndestod,mdestod
c        print*,'venond2 ctps', (ichar(ctps(i)),i=1,mdestod)
c         print*,'c256',(ichar(c256(k)),k=1,mdestod256)
         ndestod1=1
         mdestod1=0
         mdestod2561=0
         if(yw)print*,'venond2 ndestod',ndestod
      endif
      if(yw)print*,'venond2 ndestod1',ndestod1
      nems=ichar(cex(ndestod1))
      call venond4(nems,ne,mst)
      if(yw)print*,'nems',nems
      msp=mst-(-ms2+1)/2
      if(yw)print*,'nems,ne,mst,msp',nems,ne,mst,msp
      if(yw)print*,'char',(ichar(ctps(k)),k=1,ne+ne)
      if(ne.eq.0) return
      do k=1,mst-1
         mdestod1=mdestod1+1
         it=ichar(ctps(mdestod1))
         if(yw)print*,'it',it
         if(it.le.0) it=it+256
         ntv(k)=it
      enddo
      do k=mst,ne
         mdestod1=mdestod1+1
         it=ichar(ctps(mdestod1))+norb
         if(yw)print*,'it',it,norb
         if(it.le.norb) it=it+256
         ntv(k)=it
      enddo
      do k=1,msp-1
         mdestod1=mdestod1+1
         it=ichar(ctps(mdestod1))
         if(it.le.0) it=it+256
         if(yw)print*,'pit',it
         npv(k)=it
      enddo
      do k=msp,ne
         mdestod1=mdestod1+1
         it=ichar(ctps(mdestod1))+norb
         if(it.le.norb) it=it+256
         if(yw)print*,'4it',it
         npv(k)=it
      enddo
      if(norb.gt.256) then
         do k=1,ne,4
            mdestod2561=mdestod2561+1
            iii=ichar(c256(mdestod2561))
            np1024(4)=iii/64
            np1024(3)=(iii-np1024(4)*64)/16
            np1024(1)=mod(iii,4)
            np1024(2)=mod((iii-np1024(1))/4,4)
c            print*,'mdestod2561,iii',mdestod2561,iii
c            print*,'np1024',np1024
            kkk=0
            do kk=k,min(k+3,ne)
               kkk=kkk+1
               npv(kk)=npv(kk)+np1024(kkk)*256
            enddo
         enddo
      endif
      if(yw)print*,'venond2 itv,ipv',(ntv(k),k=1,ne),(npv(k),k=1,ne)
      return
 1    ierr=1
      if(yw)print*,'venond2 lect fin fich',ndestod,ndestod1
      return
      end

       subroutine venond4(nems,ne,mst)
      logical yw
      yw=.false.
c--------------------------------------------------
c     on a la formule nems=ne*(ne+1)/2+mst
c     on doit trouver ne et mst a partir de nems
c     on peut demontrer que :
c--------------------------------------------------
      ne=(  int(dsqrt(8.d0*nems))   -1)/2
      if(yw)print*,'ne',ne
c     alors...
      mst=nems-ne*(ne+1)/2
      if(yw)print*,'nems,ne,mst',nems,ne,mst
      return
      end




       subroutine wvec(b,ndet,norb,nvec,alam,enuc,eref,kkk)
      parameter (maxal=56)
      PARAMETER (maxorb=275)
      parameter (maxorbcas=16,ngru3=2048)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
!     |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
!     |      b        | iadrv |
! 
      dimension itv(18),ipv(18)
      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*50 detc
      common/opt/ihab,calcul
      character*3 calcul
      real*4 b4
      DIMENSION B(ndet),alam(nvec)
      allocatable iorb(:)
      allocate (iorb(norb*2))
      iorb(1:norb)=(/(i,i=1,norb)/)
      iorb(norb+1:norb+norb)=(/(i,i=1,norb)/)
      virg=','
      ibla1=0
      print*,'norb',norb
      twvec=0.08
      do k=1,norb
         iwspin(k)='+ '
         iwspin(k+norb)='- '
      enddo
      do kk=1,nvec
         write(6,'(a25,i4,''   E='',f12.8,''    '',f18.8)')
     *   'VECTEUR PROPRE NUMERO',
     *   kkk,alam(kk),alam(kk)+enuc+eref
         call rew61
         do ll=1,ndet
            call venond(ne,itv,ipv,ierr,norb)
!            print*,'ne',ne
!            print*,'itv,ipv',itv(1:ne),ipv(1:ne)
            ne1=ne
            if(ne.ne.0) then
               if(ipv(ne).eq.norb+norb+1)ne1=ne-1
               if(ipv(ne).eq.norb+1)ne1=ne-1
            endif
            ywv=dabs(b(ll)).gt.twvec
            ibla2='=>'
 3          continue
            if(ywv) then
               l=(ne)*10+5
               if(l.gt.50) then
                  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)
                  if(calcul.eq.'MD') then
                     write(6,'(a35,15x,3X,F11.7)')detc(1:35),(b(ll))
                  else
                     write(6,'(a35,15x,3X,F11.7,i8)')detc(1:35),b(ll),ll
                  endif
               else
                  detc(1:50)='                          '//
     *            '                        '
                  write(detc,6666) (IORB(itv(I)),IWSPIN(itv(I)),I=1,ne),
     *            ibla1,ibla2, (IORB(ipv(I)),IWSPIN(ipv(I)),I=1,ne1)
                  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:50),b(ll),ll
                  endif
               endif
            endif
6666        FORMAT(1X, 10(I3,A2))
c
         enddo
      enddo
      return
      end
       subroutine rew61
      implicit real*8(a-h,o-x,z),logical*1(y)
      parameter(lungo=100,maxorbcas=16,maxne=maxorbcas+2)
      character*1 ctps,cex,c256
      common/test/itest(100)
      common/detsto/mdestod,ndestod,mdestod1,ndestod1,npie2,mpie2,
     *mpie256,mdestod256,mdestod2561,
     *ctps((maxne)*lungo*2),cex(lungo),c256((maxne/4+1)*lungo)
      yw=.false.
      mdestod=0
      ndestod=0
      mdestod256=0
      if(yw)print*,'rew61'
      rewind 61
      return
      end

