      subroutine essai(b,iadrv,ysgn,ycas,q,guess,ndet,ngao1)
      PARAMETER (ngru3=2048,maxorbcas=16)
      parameter (maxda3=300,maxsym=8)
      include 'maxorb.prm'
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |      b        | iadrv | |     |
c                             ysgn
c                    |      q        |
c
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      common/test/itest(100)
      character*1280 namel
      dimension b(ndet*2),iadrv(ndet),ysgn(ndet),q(ndet),ycas(ndet)
      common/habil/c2,c0,
     *iterh,maxith,ndeth,ith(maxorbcas+2),iph(maxorbcas+2),neh
     *,ihvec1,iadrh
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common /ijd/itab,jtab,dtab
      dimension ITAB(NGRU3),JTAB(NGRU3)
      DIMENSION DTAB(NGRU3)
      real*4 dtab
      DIMENSION PROV(maxda3*2,maxda3*2),VECT(maxda3*2,maxda3*2),
     *VAL(maxda3*2),P(maxda3*2)
      logical*1 bidia
 
      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
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      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
      character*1 syspin
      common/sysp1/syspin
      DIMENSION GUESS(maxda3*2*maxda3/nvec,nvec)
      character*3 calcul
      dimension it(2),ip(2),ic(maxorbcas*2),v(maxda3)
      dimension it1(2),ip1(2)
      dimension ica(maxorbcas),icb(maxorbcas)
      dimension ylvec(maxda3),yessai0(maxda3)
      character*80 file
      common/ess3/ ndetcas,ynessai3
      dimension ntv(maxorbcas+2),npv(maxorbcas+2)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      namelist /ess/ idet,it,ip,ic,v,lvec
      yw=.false.
      write(6,*) ' '
      write(6,*) '==========================='
      write(6,*) '    vecteurs d''essai      '
      write(6,*) '==========================='
      n_fil_ess=93
      ynessai3_1=ynessai3.and.nessai.lt.3
      if(ynessai3_1) then
         WRITE(6,*) ' prediagonalisation du CAS avec NESSAI=',NESSAI
      else
         WRITE(6,*) '      NESSAI',NESSAI
      endif
      rewind 3
      ND1=MAXDA2*2
      ND2=MAXDA2
      NORTH=0
      NGAO=NGAO1
c
c-------------------------------------------------------------------
c           NESSAI=3
C           FABRICATION DE VECTEURS D'ESSAI PAR DIAGONALISATION
C           DU CAS
c-------------------------------------------------------------------
c
      if(nessai.eq.3) then
         nessai=1
      endif
c
c-------------------------------------------------------------------
c           NESSAI=0
C           FABRICATION DE VECTEURS D'ESSAI PAR DIAGONALISATION
C           D'UNE MATRICE (NGAO,NGAO)
c-------------------------------------------------------------------
c
c      print*,'nessai,calcul,ndet',nessai,calcul,ndet
      if(nessai.ne.0) goto 23
      if(syspin.ne.'0') then
c        sym de spin  on lit le codage en utilisant la place de iadrv
         call lirbl(iadrv,ndet,3)
      endif
c
c----------------------------------------------------------------
c--         on lit la diagonale
c----------------------------------------------------------------
c
         rewind 25
         call lir8bl(b,ndet,25)
      if(yw) then
         do k=1,ndet
            print*,'diag',k,b(k),iadrv(k).ge.k,iadrv(k).gt.k
         enddo
      endif
      ncas=0
      if(ynessai3_1) then
c
c----------------------------------------------------------------
c     On est en train de fabriquer des vecteurs d'essai
c     par prediagonalisation du CAS (Nessai=3),
c     on note les determinants du CAS dans ycas
c----------------------------------------------------------------
c
         call rew61
         do k=1,ndet
            ycas(k)=.false.
            call venondloc(ne,ntv,npv,ierr)
            call trad(ne,ntv,npv,nca,ica,ncb,icb,nt,it,ispt,np
     *      ,ip,ispp,ierr)
            if(nt.eq.0.and.np.eq.0) then
               if(syspin.eq.'0') then
                  ycas(k)=.true.
                  ncas=ncas+1
               else
                  if(iadrv(k).ge.k) then
                     ycas(k)=.true.
                     ncas=ncas+1
                  endif
                  if(yw)print*,'det cas',k,b(k)
               endif
            endif
         enddo
         if(ncas.lt.nvec) nvec=ncas
      endif
      if(syspin.eq.'+') then
c
c-------------------------------------------------------------
c On fait un calcul avec symetrie de spin
c pour chaque determinant k, iadrv(k) donne l'adresse de son
c correspondant.
c S'il y en a 2, on definit un principal et un secondaire
c Arbitrairement, on definit comme principal celui ou
c     iadrv(k).ge.k
c On utilise ysgn: Si le det est principal, ysgn(k)=T
c-------------------------------------------------------------
         do k=1,ndet
            ysgn(k)=iadrv(k).ge.k
         enddo
      else if(syspin.eq.'-') then
         do k=1,ndet
            ysgn(k)=iadrv(k).gt.k
         enddo
      else
         do k=1,ndet
            ysgn(k)=.true.
         enddo
      endif
c
c----------------------------------------------------------------
c--         on place les vecteurs d'essai sur les determinants les
c           plus bas en energie
c----------------------------------------------------------------
c
      bmax=b(1)
      do k=2,ndet
         bmax=max(b(k),bmax)
      enddo
c
c----------------------------------------------------------------
c On ne garde de b que les valeurs utiles pour trouver les valeurs
c les plus basses de la diagonale
c----------------------------------------------------------------
c
      n_non_bons=0
      !print*,'count',count(ysgn(1:ndet)),count(.not.ysgn(1:ndet))
      do k=1,ndet
         if(.not.ysgn(k)) then
            b(k)=bmax
            n_non_bons=n_non_bons+1
         else if(ynessai3_1.and..not.ycas(k)) then
            b(k)=bmax
            n_non_bons=n_non_bons+1
            ysgn(k)=.false.
         endif
      enddo
      !print*,'ynessai3_1',ynessai3_1
      !print*,'count',count(ysgn(1:ndet)),count(.not.ysgn(1:ndet))
      !print*,'n_non_bons',n_non_bons
      n_bons=ndet-n_non_bons
      !print*,'n_non_bons',n_non_bons,'           n_bons',n_bons
      if(nvec.gt.n_bons) then
         print*,'On veut fabriquer',nvec,' vecteur(s) d''essai'
         print*,'mais on a un Heff de dim inferieure',n_bons
         nvec=n_bons
      endif
      call minvals(ndet,b,nvec,jtab,2048,ysgn)
      !print*,'jtab',jtab(1:nvec)
      if(calcul.eq.'D') then
         do k=1,ndet
            iadrv(k)=k
         enddo
      else
         rewind 87
         call lirbl(iadrv,ndet,87)
      endif
c           do k=1,ndet
c               write(6,*)'iadrv',k,iadrv(k)
c           enddo
      rewind 75
      !print*,'jtab',jtab(1:nvec)
      write(75,*)'vecteurs d''essai sur',
     *(iadrv(jtab(i)),i=1,nvec),'$'
      call scril
      write(6,'('' energies'',10d12.4)')(b(jtab(k)),k=1,nvec)
c
c     s'il y a des vecteurs a lire sur file remplacer les
c     vecteurs de nessai=0 de plus fort recouvrement par
c     les bons
c
      rewind 93
c      call LECNAM('&ESS',namel,93,ierr,0)
c      if(yw)print*,'ierr',ierr
c      if(ierr.eq.0)call nameli(namel,LVEC(1),'LVEC',4)
      if(nprint.ge.1)print*,'ifiess',ifiess
      if(yw)print*,'lvec',(lvec(k),k=1,nvec)
      do i=1,nvec
         yessai0(i)=.true.
      enddo
      nlec=0
      if(lvec(1).ne.0) then
         read(ifiess)
         read(ifiess)
         if(yw)print*,'jtab',(jtab(k),k=1,nvec)
         lec=0
         do i=1,nvec
            if(lvec(i).ne.0) then
               nlec=nlec+1
               do k=lec,lvec(i)-2
                  read(ifiess)
                  if(yw)print*,'lec nulle ifiess',lec,lvec(i)-2
               enddo
               lec=lvec(i)
 
               read(ifiess) q
               call reocip(q,b,itab,ndet,1)
               if(itest(73)==0)call sgncip(b,ysgn,ndet)
               if(yw) then
                  do kk=1,ndet
                     write(6,'(''b lu'', 2i3,f12.8)')i,kk,b(kk)
                  enddo
               endif
               rec=0.d0
               do l=1,nvec
                  if(yessai0(l)) then
                     rec1=max(rec,dabs(b(jtab(l))))
                     if(rec1.gt.rec) irempl=l
                     rec=rec1
                  endif
               enddo
               if(yw)print*,'rec,irempl',rec,irempl
               yessai0(irempl)=.false.
               call ecr(b,i,ndet,21)
            endif
         enddo
      endif
c     fin de la lecture des vecteurs d'essai sur file
c
c     on met des 1. sur les composantes des determinants les plus bas
c
      ii=nlec
      do i=1,nvec
         if(.not.yessai0(i)) goto 100
         ii=ii+1
         do k=1,ndet
            b(k)=0.d0
         enddo
         b(jtab(i))=1.d0
         if(syspin.ne.'0') then
            call syspi11(b,ndet)
            anor=0.d0
            do k=1,ndet
               anor=anor+b(k)*b(k)
            enddo
            anor=dsqrt(anor)
            do k=1,ndet
               b(k)=b(k)/anor
            enddo
         endif
         call ecr(b,ii,ndet,21)
 100     continue
      enddo
      yw=.false.
      print*,'yw,mprint(5)',yw,mprint(5)
      if(yw.or.mprint(5).eq.1) then
         do i=1,nvec
            call scrida('b vecteur d essai avant ort$',b,ndet,21,i)
         enddo
      endif
c
c     si on a lu des vecteurs sur file, il faut orthogonaliser
c
      if(yw)print*,'yessai0',(yessai0(k),k=1,nvec)
      if(lvec(1).ne.0) then
         call orton(b,q)
         if(yw.or.mprint(5).eq.1) then
            do i=1,nvec
               call scrida('b vecteur d essai apres ort$',b,ndet,21,i)
            enddo
         endif
         do k=1,nvec
            if(.not.yessai0(k)) then
               write(75,*) 'le vecteur d''essai numero',k,
     *         ' est remplace par un vecteur lu sur file','$'
               call scril
            endif
         enddo
      endif
      return
c
c-------------------------------------------------------------------
c           NESSAI=1
c           lecture des vecteurs d'essai en namelist
c-------------------------------------------------------------------
c
 23   continue
      if(nessai.ne.1) goto 33
      if(ynessai3) nessai=3
      write(6,*)' vecteurs d''essai en donnee'
      if(nvec>1) then
         call regrou_essai(norb,nvec,b,q)
         n_fil_ess=94
      endif

c
c-------------------------
c--   cas calcul='D'
c-------------------------
c
      if(calcul.eq.'D') then
         do k=1,nvec
            lvec(k)=k
         enddo
c        read(93,ess)
         call LECNAM('&ESS',namel,n_fil_ess,ierr,0)
         call nameli(namel,IDET,'IDET',4)
         call nameli(namel,it(1),'IT',4)
         call nameli(namel,IP(1),'IP',4)
         call nameli(namel,IC(1),'IC',4)
         call nameli(namel,LVEC(1),'LVEC',4)
         call nameld(namel,V,'V',8)
 
         if(idet.eq.0) then
            do k=1,ndet
               ysgn(k)=.false.
               iadrv(k)=0
c              (ysgn e iadrv utilises pour l'espace)
            enddo
            do k=1,ngao
               ysgn(lvec(k))=.true.
               iadrv(lvec(k))=k
            enddo
            do 142 j=1,ngao
            do 142 i=1,ngao
 142        prov(i,j)=0
 14         READ(1)ITAB,JTAB,DTAB
            NM=NGRU3
            IF(ITAB(NGRU3).EQ.-1) NM=JTAB(NGRU3)
            DO 12 K=1,NM
            I=ITAB(K)
            IF(.not.ysgn(i)) GOTO 12
            J=JTAB(K)
            IF(.not.ysgn(j)) GOTO 12
c           write(6,*)i,j,k
            PROV(iadrv(I),iadrv(J))=DTAB(K)
            PROV(iadrv(J),iadrv(I))=DTAB(K)
            if(i.eq.j) prov(iadrv(i),iadrv(i))=dtab(k)*2
 12         CONTINUE
            IF(ITAB(NGRU3).GE.0) GOTO 14
            if(mprint(1).eq.1) then
               write(6,*)'matrice d''essai pour la diagonalisation'
               call SCRIPT(prov,ngao,ngao,maxda3*2,maxda3*2)
            endif
            CALL RIERA(NGAO,PROV,VECT,VAL,P,maxda3*2,ierr)
            if(ierr.eq.1) then
               print*,'diagonalisation JACOBI'
               call hdiag(prov,vect,ngao,maxda3*2)
               do k=1,ngao
                  val(k)=prov(ngao+1-k,ngao+1-k)
               enddo
               do k=1,ngao/2
                  do i=1,ngao
                     vv=vect(i,k)
                     vect(i,k)=vect(i,ngao+1-k)
                     vect(i,ngao+1-k)=vv
                  enddo
               enddo
            endif
            write(6,*)'essai : vecteurs propres'
            call SCRIPT(vect,ngao,ngao,maxda3*2,maxda3*2)
            DO  I=1,NGAO
               DO  J=1,NVEC
                  GUESS(I,J)=VECT(I,J)
               enddo
            enddo
            do l=1,nvec
               do i=1,ndet
                  b(i)=0.d0
               enddo
               DO I=1,NGAO
                  if(mprint(1).eq.1)
     *            write(6,*)'ngao,i,lvec(i)',ngao,i,lvec(i),GUESS(I,L)
                  B(lvec(i))=GUESS(I,L)
               enddo
               if(yw)write(6,*)'essai essai',(b(kk),kk=1,ndet)
c               call syspi1(b,ndet)
               call syspi11(b,ndet)
               if(yw)write(6,*)'essai essai',(b(kk),kk=1,ndet)
               call ecr(b,l,ndet,21)
               if(mprint(1).eq.1)
     *         call scrida('b vecteur d essai$',b,ndet,21,l)
            enddo
         else if(idet.ne.0) then
            do l=1,nvec
               anor=0.d0
               rewind n_fil_ess
               do i=1,ndet
                  b(i)=0.d0
               enddo
 40            continue
               do i=1,nvec
                  v(i)=0.d0
               enddo
c              read(93,ess,end=39)
               call LECNAM('&ESS',namel,n_fil_ess,ierr,0)
               if(ierr.eq.1) goto 39
               call nameli(namel,IDET,'IDET',4)
               call nameli(namel,it(1),'IT',4)
               call nameli(namel,IP(1),'IP',4)
               call nameli(namel,IC(1),'IC',4)
               call nameli(namel,LVEC(1),'LVEC',4)
               call nameld(namel,V,'V',8)
               write(6,*)' lecture idet',idet,'v',(v(k),k=1,2)
               b(idet)=v(l)
               if(nprint.ge.1.and.dabs(v(l)).gt.1.d-12) then
                  write(75,*)' idet',idet,' v(',l,')=',
     *            v(l),'$'
                  call scril
               endif
               anor=anor+v(l)*v(l)
               goto 40
 39            continue
               if(dabs(anor).lt.1.d-12) then
                  write(6,*)'norme nulle pour le vecteur',l
                  stop
               endif
               anor=dsqrt(anor)
               do i=1,ndet
                  b(i)=b(i)/anor
               enddo
               call ecr(b,l,ndet,21)
            enddo
         else
            write(6,*)'lvec et idet sont nuls dans ess'
            stop
         endif
         goto 51
      endif
c
c-------------------------
c--   cas calcul='MD'
c-------------------------
c
      ilec=0
      idet=0
      file=' '
      if(ynessai3) file='ESCASOUT'
c
c--   on note les vecteurs d'essai a lire sur file
c     ylvec(kk)=T si le vecteur kk est a lire sur la file ess
      ifiless=n_fil_ess
      rewind ifiless
      call LECNAM('&ESS',namel,ifiless,ierr,0)
      call namela(namel,FILE,'FILE')
      if(file.ne.' ') then
         ifiless=99
         open(ifiless,file=file,status='old')
         call LECNAM('&ESS',namel,ifiless,ierr,0)
      endif
      call nameli(namel,LVEC(1),'LVEC',4)
      do kk=1,nvec
         ylvec(kk)=.false.
      enddo
      do kk=1,nvec
         if(lvec(kk).ne.0) then
            write(75,*)
     *      'vecteur d''essai',lvec(kk),' lu sur file','$'
            call scril
            ylvec(lvec(kk))=.true.
         else
            goto 27
         endif
      enddo
 27   lvec(1)=0
c
c--   lecture des vecteurs d'essai en donnee (det 1 a 1)
c
c     mise a zero
      rewind ifiless
 26   continue
      do k=1,2
         it(k)=0
         ip(k)=0
      enddo
      do k=1,nvec
         v(k)=0.d0
      enddo
      do k=1,noac*2
         ic(k)=0
      enddo
      lvec1=lvec(1)
c     lecture d'une namelist ess
c     read(93,ess,end=36)
      call LECNAM('&ESS',namel,ifiless,ierr,0)
      if(ierr.eq.1) goto 36
      call nameli(namel,IDET,'IDET',4)
      call nameli(namel,it(1),'IT',4)
      call nameli(namel,IP(1),'IP',4)
      call nameli(namel,IC(1),'IC',4)
      call nameli(namel,LVEC(1),'LVEC',4)
      call nameld(namel,V,'V',8)
c     write(6,ess)
c      write(6,*)'it',it
c      write(6,*)'ip',ip
      if(lvec1.ne.lvec(1)) then
c         write(6,*)'apres lir93 lvec(1)',lvec(1)
c        alors la namelist indique les vecteurs a lire sur file
         goto 26
      endif
      ilec=ilec+1
c      call verdim('Vecteur d essai trop grand : vec  max   '
c     *,ilec,maxda3*2*maxda3/nvec)
c      call verdim('Vecteur d essai trop grand : vec  max   '
c     *,ilec,2048)
      nca=0
      ncb=0
      if(idet.ne.0) then
c        alors le det a ete donne par son numero
         iadrv(ilec)=-idet
         write(6,*)'idet',idet
         write(6,'(10f8.4)')(v(kk),kk=1,nvec)
         goto 38
      endif
c
c     le determinant a ete donne par son occupation
c
c--   on ecrit le determinant pour adrdet
c      write(6,*)'it',it
c      write(6,*)'ip',ip
      do k=1,noac*2
         if(ic(k).eq.0) goto 34
         if(ic(k).gt.0) then
            nca=nca+1
            if(itype(ic(k)).ne.2) then
               write(6,*) ic(k),' non active'
               stop
            endif
            ica(nca)=ic(k)
         else
            ncb=ncb+1
            if(itype(-ic(k)).ne.2) then
               write(6,*) ic(k),' non active'
               stop
            endif
            icb(ncb)=-ic(k)
         endif
      enddo
 34   continue
      nt=0
      ispt=0
      do k=1,2
         if(it(k).eq.0) goto 35
         if(it(k).gt.0) then
            nt=nt+1
            if(itype(it(k)).ne.1) then
               write(6,*) it(k),' non occupee'
               stop
            endif
            it1(nt)=it(k)
            ispt=ispt+1
         else
            nt=nt+1
            if(itype(-it(k)).ne.1) then
               write(6,*) it(k),' non occupee'
               stop
            endif
            it1(nt)=it(k)
            ispt=ispt-1
         endif
      enddo
 35   continue
      np=0
      ispp=0
      do k=1,2
         if(ip(k).eq.0) goto 37
         if(ip(k).gt.0) then
            np=np+1
            if(itype(ip(k)).ne.3) then
               write(6,*) ip(k),' non virtuelle'
               stop
            endif
            ip1(np)=ip(k)
            ispp=ispp+1
         else
            np=np+1
            if(itype(-ip(k)).ne.3) then
               write(6,*) ip(k),' non virtuelle'
               stop
            endif
            ip1(np)=ip(k)
            ispp=ispp-1
         endif
      enddo
 37   continue
c      write(6,*)'np',np
      if(yw) then
         write(6,*)'it1,ip1',it1,ip1,(v(kk),kk=1,nvec),isgn
      endif
      call reor(nt,it1,isgnt)
      call reor(np,ip1,isgnp)
      isgn=isgnt*isgnp
      if(yw) then
         write(6,*)'it1,ip1',it1,ip1,(v(kk),kk=1,nvec),isgn
      endif
      yy=.false.
      if(nessai.ne.3) then
      do kk=1,nvec
         yy=yy.or.(dabs(v(kk)).gt.1.d-1.and..not.ylvec(kk))
      enddo
      if(yy) then
         write(namel,'(8f8.4)')(v(kk),kk=1,min(nvec,8))
         write(75,*)'|',(it1(k),k=1,nt),'|',(ic(k),k=1,nca+ncb),'|',
     *   (ip1(k),k=1,np),'|',namel(1:8*nvec),'$'
         call scril
         ifin=8
         do i=11,nvec,8
            ideb=ifin+1
            ifin=min(nvec,ifin+8)
            print'(8x,8f8.4)',v(ideb:ifin)
         enddo
c         write(6,'(10f8.4)')(v(kk),kk=1,nvec)
      endif
      endif
      do k=1,nt
         it1(k)=iabs(it1(k))
      enddo
      do k=1,np
         ip1(k)=iabs(ip1(k))
      enddo
      if(yw)write(6,*)'ispt,ispp',ispt,ispp
      if(yw) then
         write(6,*)'it1,ip1',it1,ip1,(v(kk),kk=1,nvec),isgn
      endif
      if(ispp.eq.0.and.np.eq.2) then
         if(yw)write(6,*)'reorp'
         ii=ip1(1)
         ip1(1)=ip1(2)
         ip1(2)=ii
      endif
      if(ispt.eq.0.and.nt.eq.2) then
         if(yw)write(6,*)'reort'
         ii=it1(1)
         it1(1)=it1(2)
         it1(2)=ii
      endif
      do k=1,ncb
         icb(k)=iabs(icb(k))
      enddo
      isgnt=1
      isgnp=1
      if(ispt.eq.-2) call reor(nt,it1,isgnt)
      if(ispp.eq.-2) call reor(np,ip1,isgnp)
      call reor(nca,ica,idum)
      call reor(ncb,icb,idum)
      isgn=isgnt*isgnp*isgn
      if(yw)write(6,*)'it1,ip1',it1,ip1,(v(kk),kk=1,nvec),isgn
      if(yw) then
         write(6,*)'ica',(ica(k),k=1,nca)
         write(6,*)'icb',(icb(k),k=1,ncb)
         write(6,*)'it',(it1(k),k=1,nt)
         write(6,*)'ip',(ip1(k),k=1,np)
         write(6,*)'ispt,ispp',ispt,ispp
      endif
c
c--   on verifie la conformite du determinant
c     nombre de spins alpha et beta
      if(nca+(np+ispp)/2-(nt+ispt)/2.ne.nca0) goto 200
      if(ncb+(np-ispp)/2-(nt-ispt)/2.ne.ncb0) goto 200
c     symetrie
      is=1
      do k=1,nca
         is=its(is,itsym(ica(k)))
      enddo
      do k=1,ncb
         is=its(is,itsym(icb(k)))
      enddo
      do k=1,nt
         is=its(is,itsym(it1(k)))
      enddo
      do k=1,np
c         write(6,*)'k,ip1(k)',k,ip1(k)
         is=its(is,itsym(ip1(k)))
      enddo
      if(is.ne.is0) goto 201
      goto 202
 200  continue
      write(6,*)'mauvais nombre d''electrons'
      write(6,*)'nca,ncb,np,ispp,nt,ispt,nca0,ncb0',
     *nca,ncb,np,ispp,nt,ispt,nca0,ncb0
      stop
 201  write(6,*)'mauvaise symetrie'
      stop
 202  continue
c
c--   adresse du determinant
c      print'(20i4)',
c     *nca,ica,nt,np,ispt,ispp,(it1(k),k=1,nt),(ip1(k),k=1,np)
      call adrdet(nca,ica,ncb,icb,nt,it1,ispt,np,ip1,ispp,iadr,
     *      mhdum,mtdum)
      if(yw)write(6,*)'essai adresse',iadr
      iadrv(ilec)=iadr
 38   continue
      do l=1,nvec
         guess(ilec,l)=v(l)
      enddo
      goto 26
 36   continue
      write(6,*)' '
      if(yw) then
         write(6,*)'GUESS'
         CALL SCRIPT(GUESS,ilec,NVEC,maxda3*2*maxda3/nvec,nvec)
      endif
! orthogonalisation des vecteurs d'essai (de guess)
      call ortov(guess(1:ilec,1:nvec),ilec,nvec,'_NONULLNORM_PR_')
      DO L=1,NVEC
c          write(6,*)'l,ylvec',l,ylvec(l)
         if(ylvec(l)) goto 56
         DO  I=1,ndet
            B(I)=0.d0
         enddo
!         anor=0.d0
!         DO I=1,ilec
!            anor=anor+GUESS(I,L)*GUESS(I,L)
!         enddo
!         anor=dsqrt(anor)
!         write(6,*)'norme du vecteur d''essai',anor
!         if(anor.eq.0.d0) then
!            write(6,*)'norme nulle pour le vecteur d''essai ',l
!            stop
!         endif
!         guess(:,l)=guess(:,l)/anor
         DO I=1,ilec
            if(yw)
     *      write(6,*)'essai i,iadrv(i),guess(i,l)'
     *      ,i,iadrv(i),guess(i,l)
            if(guess(i,l).ne.0.D0) then
               if(iadrv(i).gt.0) then
                  if(nprint.ge.1)
     *            write(6,*)'adresse du determinant    ',iadrv(i)
     *            ,GUESS(I,L)!/anor
                  B(iadrv(i))=GUESS(I,L)!/anor
               else
                  if(nprint.ge.1)
     *            write(6,*)'adresse du determinant    ',-iadrv(i)
     *            ,GUESS(I,L)!/anor
                  B(-iadrv(i))=GUESS(I,L)!/anor
               endif
            endif
         enddo
         if(itest(73)==0)call sgncip(b,ysgn,ndet)
         call ecr(b,l,ndet,21)
         if(yw) then
            do kk=1,ndet
               write(6,*)'essai',l,kk,b(kk)
            enddo
         endif
 56      continue
      enddo
c      if(yw) then
c         write(6,*)'vecteurs d''essai pour la diagonalisation'
c      endif
      goto 50
c
c-------------------------------------------------------------------
c        NESSAI=2
c        lecture des vecteurs d'essai a partir d'un calcul precedent
c-------------------------------------------------------------------
c
 33   continue
c      if(calcul.eq.'MD') then
c         rewind 85
c         call liry(ysgn,ndet,85)
c      endif
      rewind ifiess
      read(ifiess)
      read(ifiess)
      do i=1,nvec
         if(calcul.eq.'MD') then
            read(ifiess)(q(k),k=1,ndet)
            call reocip(q,b,itab,ndet,1)
            if(itest(73)==0)call sgncip(b,ysgn,ndet)
         else
            read(ifiess)(b(k),k=1,ndet)
         endif
         write(6,*)' '
         call rew61
         anor=0.d0
         do j=1,ndet
            anor=anor+b(j)*b(j)
c           if(iterh.le.1.and.dabs(b(j)).gt.1.d-1)
            if(dabs(b(j)).gt.1.d-1)
     *      write(6,*)'ess',j,i,b(j)
         enddo
         anor=dsqrt(anor)
         if(iterh.le.0)write(6,*)'norme du vecteur d''essai',anor
         if(anor.eq.0.d0) then
            write(6,*)'norme nulle pour le vecteur d''essai ',i
            stop
         endif
         do j=1,ndet
            b(j)=b(j)/anor
c            write(6,*)'essai',b(j)
         enddo
         call ecr(b,i,ndet,21)
      enddo
50    CONTINUE
c      write(6,*)'apres 50 lvec(1)',lvec(1)
c          rewind ifiess
c          read(ifiess)
c          read(ifiess)
c          do k=1,nvec
c                read(ifiess)(b(kk),kk=1,ndet)
      if(lvec(1).ne.0) then
c         if(calcul.eq.'MD') then
c            rewind 85
c            call liry(ysgn,ndet,85)
c         endif
         rewind ifiess
         read(ifiess)
         read(ifiess)
         l=1
         do k=1,nvec
            if(lvec(l).eq.0) goto 51
            if(lvec(l).eq.k) then
c                 write(6,*)'k,ndet,nvec',k,ndet,nvec
               read(ifiess)(q(kk),kk=1,ndet)
               if(calcul.eq.'MD') then
c                    write(6,*)'essai fin'
c                   do kk=1,nvec
c                       write(6,*)'avant reocip'
                  call reocip(q,b,itab,ndet,1)
c                       write(6,*)'avant sgncip'
                  if(itest(73)==0)call sgncip(b,ysgn,ndet)
c                       write(6,*)'avant ecr'
                  call ecr(b,k,ndet,21)
c                   enddo
               else
                  call ecr(q,k,ndet,21)
               endif
c                do kk=1,ndet
c                   write(6,*)'vec lu',kk,b(kk)
c                enddo
               l=l+1
            else
               read(ifiess)
            endif
         enddo
      endif
 51   continue
c--   symetrie de spin
      if(syspin.ne.'0') call spiess1(b)
c--   orthonormalisation des vecteurs d'essai
c      write(6,*)'avant orton nessai',nessai
      if(nessai.eq.1.or.lvec(1).ne.0) call orton(b,q)
C--------------FIN DE L'OBTENTION DES VECTEURS D'ESSAI
c      do k=1,nvec
c          write(6,*)'vecteur d''essai numero',k
c         call lire(b,k,ndet,21)
c          do kk=1,ndet
c             write(6,'(i5,f12.8)')kk,b(kk)
c          enddo
c       enddo
      write(6,*)'==========================='
      close (99)
      return
      end
       subroutine orton(b1,b2)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      parameter (maxda3=300)
      common/dim/iadri ; integer(8) iadri
      logical*1 bidia
      common /det/ndet,mdet(50),nbdet_cas
      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
      dimension b1(iadri),b2(iadri)
      common/pr/nprint,mprint(10)
      yw=.false.
      if(nvec.eq.1) return
      write(6,*)'---------------------------------------------'
      write(6,*)'       orthogonalisation des vecteurs d''essai'
      write(6,*)'---------------------------------------------'
      do k=2,nvec
         call lire(b1,k,ndet,21)
         if(yw) then
            write(6,*)'b1'
            call script(b1,ndet,1,ndet,1)
         endif
         do l=1,k-1
c             write(6,*)'orton l',l
            call lire(b2,l,ndet,21)
            if(yw) then
               write(6,*)'b2'
               call script(b2,ndet,1,ndet,1)
            endif
c--         produit scalaire
            scal=0.d0
            do i=1,ndet
               scal=scal+b1(i)*b2(i)
            enddo
            if(nprint.ge.0)
     *      write(6,'(a20,2i3,a20,f12.8)')'vecteurs d''essai',k,l,
     *      ' produit scalaire',scal
            do i=1,ndet
               b1(i)=(b1(i)-scal*b2(i))
            enddo
         enddo
         anor=0.d0
         do kkkk=1,ndet
            anor=anor+b1(kkkk)*b1(kkkk)
         enddo
         write(6,*)'anor verif',anor,k
         anor=dsqrt(anor)
         do kkkk=1,ndet
            b1(kkkk)=b1(kkkk)/anor
         enddo
         call ecr(b1,k,ndet,21)
      enddo
      return
      end
       subroutine sto5
      character ligne*75,debut*5
c     write(6,*)'entree sto5'
 2    read(5,'(a5,a75)',end=1) debut,ligne
      write(93,'(a5,a75)') debut,ligne
c      write(6,'('' sto5'',a5,a75)') debut,ligne
      goto 2
 1    continue
c      call flush(93)
      rewind 93
      return
      end
       subroutine less
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      parameter (maxda3=300)
      PARAMETER (maxorbcas=16)
      logical*1 bidia
      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
      dimension it(2),ip(2),ic(maxorbcas*2),v(maxda3)
      character*1280 namel
      namelist /ess/ idet,it,ip,ic,v,lvec
      do k=1,maxda3
         lvec(k)=0
      enddo
      rewind 93
 2    continue
c     read(93,ess,end=1)
      call LECNAM('&ESS',namel,93,ierr,0)
      if(ierr.eq.1) goto 1
      call nameli(namel,IDET,'IDET',4)
      call nameli(namel,it(1),'IT',4)
      call nameli(namel,IP(1),'IP',4)
      call nameli(namel,IC(1),'IC',4)
      call nameli(namel,LVEC(1),'LVEC',4)
      call nameld(namel,V,'V',8)
      goto 2
 1    continue
      return
      end
       subroutine spiess1(b1)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      common/dim/iadri ; integer(8) iadri
      parameter (maxda3=300)
      PARAMETER (ngru3=2048)
      include 'maxorb.prm'
      common /ijd/itab,dtab
      dimension ITAB(NGRU3),DTAB(NGRU3)
      character*1 syspin
      common /sysp1/syspin
      logical*1 bidia
      common /det/ndet,mdet(50),nbdet_cas
      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
      dimension b1(iadri)
      common/pr/nprint,mprint(10)
      yw=.false.
      if(syspin.eq.'0') return
      write(6,*)'--------------------------------------------------'
      write(6,*)'   symetrisation en spin des vecteurs d''essai'
      write(6,*)'--------------------------------------------------'
      if(syspin.eq.'+') then
         isyspi=1
      else
         isyspi=-1
      endif
      do kvec=1,nvec
         call lire(b1,kvec,ndet,21)
         if(yw)then
            write(6,*)'b1 debut spiess'
            do kk=1,ndet
               write(6,*)'kk,b1(kk)',kk,b1(kk)
            enddo
         endif
         rewind 3
         ifin=0
         do k=1,ndet,ngru3
            ideb=ifin+1
            ifin=min(ideb+ngru3-1,ndet)
c           on lit le codage de la symetrie de spin
            call liri(itab,ngru3,3)
c           on corrige les coef
            i=0
            do l=ideb,ifin
               i=i+1
               if(itab(i).ne.0) then
                  icip=itab(i)
                  if(yw)write(6,*)'spiess',b1(icip),b1(l),icip,l
                  if(icip.eq.l) then
                     if(isyspi.eq.-1) b1(l)=0.d0
                  endif
                  bb=(b1(l)+isyspi*b1(icip))/2
                  b1(icip)=isyspi*bb
                  b1(l)=bb
                  if(yw.and.bb.ne.0.d0)
     *            write(6,*)'symetrisation',icip,l,isyspi
               endif
            enddo
         enddo
c--      normalisation
         anor=0.d0
         do k=1,ndet
            anor=anor+b1(k)*b1(k)
         enddo
         anor=dsqrt(anor)
         do k=1,ndet
            b1(k)=b1(k)/anor
         enddo
         if(yw) then
            write(6,*)'b1 fin spiess'
            do kk=1,ndet
               write(6,*)'kk,b1(kk)',kk,b1(kk)
            enddo
         endif
         call ecr(b1,kvec,ndet,21)
      enddo
      return
      end
 
       subroutine minvals(n,b,nmin,lmin,ldmin,ysgn)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
!
!-----------------------------------------------------
!     trouve la place des nmin plus basses valeurs de b
!     les met en sortie dans lmin
!     Attention ! b est detruit
!-----------------------------------------------------
!
      dimension b(n),lmin(nmin),ysgn(n)
      yw=.false.
      if(ldmin.lt.nmin) then
         print*,
     *   'subroutine minvals : la dimension de lmin est trop petite'
         print*,'nmin,ldmin',nmin,ldmin
         stop
      endif
 
      bmax=abs(b(1))
      do k=2,n
         if(ysgn(k)) then
            bmax=max(abs(b(k)),bmax)
         endif
      enddo
      lmin=0
      do i=1,nmin
         cmax=bmax
         do k=1,n
            if(ysgn(k)) then
               if(b(k)<=cmax) then
                  cmax=b(k)
                  lmin(i)=k
               endif
            endif
         enddo
         ysgn(lmin(i))=.false.
         if(yw)print*,'i,lmin',i,lmin(i)
      enddo
      return
      end
       subroutine regrou_essai(norb,nvec,y,v)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      common/dim/iadri
      dimension y(iadri*8)
      dimension v(iadri)
      character(10000) namel
      character(80) :: file=' '
      rewind 93

! Vecteurs d'essai avec les donnees ou sur fichier a part ?
      call LECNAM('&ESS',namel,93,ierr,0)
      call namela(namel,FILE,'FILE')
      ifil=93
      if(file/=' ') then
         open(96,file=file,status='old')
         ifil=96
      endif
      
! on compte les donnees &ess
        print*,'entree regrou_essai'
      ndon=-1
      do
         call LECNAM('&ESS',namel,ifil,ierr,0)
         ndon=ndon+1
         if(ierr==1) exit
      enddo
      rewind ifil
      if(ndon*nvec>iadri) return
      if(ndon*norb>iadri*4) return
      call regrou_essai_1(norb,nvec,v,v(ndon+1),v(ndon*2+1),
     *y,y(nvec*ndon*8+1),ndon,ifil)
      return
      end
       subroutine regrou_essai_1(norb,nvec,it,ip,ic,v,y,ndon,ifil)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      PARAMETER (maxorbcas=16)
      dimension v(nvec,ndon),it(2,ndon),ip(2,ndon),ic(maxorbcas,ndon)
      dimension y(ndon)
      character(1000) aa
      character(10000) namel
      print*,'entree regrou_essai_1'
      rewind ifil
      it=0
      ip=0
      ic=0
      v=0.d0
      do idon=1,ndon
         call LECNAM('&ESS',namel,ifil,ierr,0)
         if(ierr==1) exit
         call nameli(namel,it(1,idon),'IT',4)
         call nameli(namel,IP(1,idon),'IP',4)
         call nameli(namel,IC(1,idon),'IC',4)
         call nameld(namel,V(1,idon),'V',8)
      enddo
      y=.false.
      do i=2,ndon
         do j=1,i-1
            if(y(j)) cycle
            if(all(ic(:,i)==ic(:,j))) then
               if(all(it(:,i)==it(:,j))) then
                  if(all(ip(:,i)==ip(:,j))) then
                     y(i)=.true.
                     v(:,j)=v(:,i)+v(:,j)
                  endif
               endif
            endif
         enddo
      enddo
      n=0
      open(94)
      do i=1,ndon
         if(y(i)) cycle
         nt=0
         if(it(1,i)/=0) nt=1
         if(it(2,i)/=0) nt=2
         np=0
         if(ip(1,i)/=0) np=1
         if(ip(2,i)/=0) np=2
         do k=1,maxorbcas
            if(ic(k,i)==0) then
               nc=k-1
               exit
            endif
         enddo
         aa=' &ess'
         if(nt>0) then
            aa=trim(aa)//' it='
            l=len_trim(aa)
            write(aa(l+1:),'(2(i4,","))') (it(k,i),k=1,nt)
            l=len_trim(aa)
         endif
         if(nc>0) then
            aa=trim(aa)//' ic='
            l=len_trim(aa)
            write(aa(l+1:),'(16(i4,","))') (ic(k,i),k=1,nc)
            l=len_trim(aa)
         endif
         if(np>0) then
            aa=trim(aa)//' ip='
            l=len_trim(aa)
            write(aa(l+1:),'(2(i4,","))') (ip(k,i),k=1,np)
            l=len_trim(aa)
         endif
         aa=trim(aa)//' v='
         call suppb1(aa(7:l))
         write(94,'(a)') trim(aa)
         l=len_trim(aa)
         ifin=0
         do il=1,nvec,5
            ideb=ifin+1
            ifin=ifin+5
            aa=' '
            write(aa,'(5(f10.6,","))') (v(k,i),k=ideb,ifin)
            write(94,'(a)') trim(aa)
         enddo
         write(94,'(a)') ' /'
      enddo
      return
      end
       subroutine suppb1(aa)
      character(*) aa
      l=len_trim(aa)
      do k=1,l
         if(aa(k:k)==' ') aa(k:)=adjustl(aa(k:))
      enddo
      return
      end
       subroutine ortov(v,nl,nc,option)
!
!-------------------------------------------------
!  Orthonormalisation de v(nl,nc)
! v non orthonormal en entree, orthonormal en sortie
! option : options
!-------------------------------------------------
!
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      character(*) option
      dimension v(nl,nc)
! test
      if(index(option,'_NONULLNORM_')>0) then
         do i=1,nc
            p=dot_product(v(:,i),v(:,i))
            if(index(option,'_PR_')>0) 
     *      write(6,*)'norme du vecteur',i,p
            if(p.eq.0.d0) then
               write(6,*)'norme nulle pour le vecteur',i
               stop
            endif
            v(:,i)=v(:,i)/p
         enddo
      endif
! orthogonalisation
      do i=1,nc
         do j=1,i-1
            p=dot_product(v(:,i),v(:,j))
            !print*,'i,j,p',i,j,p
            do k=1,nl
               v(k,i)=v(k,i)-p*v(k,j)
            enddo
         enddo
! normalisation
         p=dot_product(v(:,i),v(:,i))
         v(:,i)=v(:,i)/sqrt(p)
         !print*,'                    j,p',j,p
      enddo
      return
      end
            
      

