      SUBROUTINE vermat(iadrv,isspi,yadri,nemax)
      parameter(maxsym=8,maxorbcas=16,ngru3=2048)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
c
c      common/ver2/iadrver(500)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    | iadrv |                       |
c    |--------isspi----------| |
c                             yadri
c
      common/dim/iadri ; integer(8) iadri
      common /ijd/itab,jtab,ktab
      dimension ITAB(NGRU3),JTAB(NGRU3),kTAB(NGRU3)
      dimension YADRI(iadri)
c      COMMON/VER/IADRV(IADRI)
      dimension iadrv(iadri),isspi(iadri*3)
      common/opt/ihab,calcul
      character*3 calcul
      common /det/ndet,mdet(50),nbdet_cas
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension ntv(maxorbcas+2),npv(maxorbcas+2)
      dimension ica(maxorbcas),icb(maxorbcas),it(2),ip(2)
      character*1 syspin
      common/sysp1/syspin
      common/pr/nprint,mprint(10)
      common/test/itest(100)
      character*80 mono1
      common/files/mono1
      common/ess3/ ndetcas,ynessai3
cdcor
ccor      common/bidvr/ibidv(10000),ibidr(10000,20),icor
cfcor
c      print*,'entree vermat'
c      call flush(6)
      yw=nprint.ge.3
      iistop=0
      nbdet_cas=0
c 777 continue
c     read(60) i,j
c     print*,'test',i,j
c     goto 777
c
c-------------------------------------------------------------
c     VERIF  CORRESPONDANCE ENTRE ADRESSES ET NUMEROS DES DET
c-------------------------------------------------------------
c
      if(yw)print*,'calcul ',calcul
      if(calcul.ne.'MD')
     *open(1,status='UNKNOWN',file='Mattemp',form='UNFORMATTED')
      open(87,status='UNKNOWN',file='IADRV',form='UNFORMATTED')
      open(84,status='UNKNOWN',file='BID84',form='UNFORMATTED')
c--   stockage des mono
c
c--   lecture des determinants et adressage
c
      do k=1,iadri
         yadri(k)=.false.
      enddo
      if(syspin.ne.'0') then
         do k=1,ndet
            isspi(k)=0
         enddo
      endif
      nemax=0
c      if(yw)write(6,*)'VERIF IMAT=1'
      ndet2=0
      ndet1=0
      ndetcas=0
      call rew61
      maxadr=0
 1    continue
      call venondloc(ne,ntv,npv,ierr)
      if(ierr.eq.1) goto 100
      nemax=max0(ne,nemax)
      ndet2=ndet2+1
      ndet1=ndet1+1
      !print*,'ndet1',ndet1,ndet2,ne,(ntv(k),k=1,ne),(npv(k),k=1,ne)
      if(ndet1.gt.ngru3) then
         ndet1=1
         write(84) itab
      endif
c     write(6,*)'ndet,ne',ndet,ne
      call trad(ne,ntv,npv,nca,ica,ncb,icb,nt,it,ispt,np,ip,ispp,ierr)
      if(nt.eq.0.and.np.eq.0) ndetcas=ndetcas+1
      call adrdet
     *(nca,ica,ncb,icb,nt,it,ispt,np,ip,ispp,iadr1,
     *      mhdum,mtdum)
      if(nt.eq.0.and.np.eq.0) nbdet_cas=nbdet_cas+1
      maxadr=max0(iadr1,maxadr)
      itab(ndet1)=iadr1
      nta=(nt+ispt)/2
      npa=(np+ispp)/2
      if(yw.or.mprint(2).eq.1) then
c         if(itest(80).eq.0.or.ndet2.le.itest(80)) then
            write(75,*)'VERMAT ',
     *      ' trou',(iorb(it(k)),k=1,nta),(-iorb(it(k)),k=nta+1,nt),
     *      ' CAS',(ica(k),k=1,nca),(-icb(k),k=1,ncb),
     *      ' part',(iorb(ip(k)),k=1,npa),(-iorb(ip(k)),k=npa+1,np)
     *      ,' ndet',ndet2,' iadr1',iadr1,' $'
            call scril
         endif
         if(ndet2.ne.iadr1.and.itest(71).eq.1)print*,'erreur'
c      endif
      if(yadri(iadr1)) then
         write(6,*)'determinant deja vu',
     *   ' trou',(iorb(it(k)),k=1,nta),(-iorb(it(k)),k=nta+1,nt),
     *   ' CAS',(ica(k),k=1,nca),(-icb(k),k=1,ncb),
     *   ' part',(iorb(ip(k)),k=1,npa),(-iorb(ip(k)),k=npa+1,np)
     *   ,' ndet',ndet2,' iadr1',iadr1
         stop
      endif
      if(iadr1.gt.ndet) then
         write(6,*)'adresse plus grande que le nombre de determinants',
     *   ' trou',(iorb(it(k)),k=1,nta),(-iorb(it(k)),k=nta+1,nt),
     *   ' CAS',(ica(k),k=1,nca),(-icb(k),k=1,ncb),
     *   ' part',(iorb(ip(k)),k=1,npa),(-iorb(ip(k)),k=npa+1,np)
     *   ,' numero,ndet',ndet2,ndet,' iadr1',iadr1
         if(yw) then
            iistop=1
         else
            stop
         endif
      endif
      yadri(iadr1)=.true.
c--   symetrie de spin
      call syspi01(isspi,nca,ica,ncb,icb,nt,it,ispt,np,ip,ispp,iadr1,
     *nta,npa)
c--   determinant suivant...
      goto 1
 100  continue
      if(iistop.eq.1) then
         do k=1,ndet
            print'(a20,i8,l2)','adresses vides',k,yadri(k)
         enddo
         stop
      endif
      if(yw)print*,'fin de la 1ere lecture des determinants'
      if(yw)call flush(6)
      call rew61
      write(84) itab
c
c--   stockage de la symetrie de spin
      if(syspin.ne.'0') then
c         open(3,file='CD_SYSPIN',form='unformatted',status='unknown')
         call ecribl(isspi,ndet,3)
      endif
      if(yw)print*,'fin du stockage de la symetrie de spin'
      if(yw)call flush(6)
      if(yw) then
         write(6,*)'isspi dans vermat'
         do k=1,ndet
            write(6,'(10i6)')k,isspi(k),isspi(k+iadri),isspi(k+iadri*2)
         enddo
      endif
c
c--   stockage des adresses
      rewind 84
      kk=ngru3
      do k=1,ndet
         kk=kk+1
         if(kk.gt.ngru3) then
            kk=1
            read(84) itab
         endif
         iadrv(itab(kk))=k
      enddo
      if(yw)write(6,'(''iadrv avant ecribl'',10i8)')(iadrv(k),k=1,100)
      rewind 87
      call ecribl(iadrv,ndet,87)
      if(yw) theN
         write(6,*)'maxadr',maxadr
         write(6,*)'iadrv dans vermat'
         do k=1,maxadr
            write(6,'(10i6)')k,iadrv(k)
         enddo
      endif
      if(yw)print*,'fin du stockage des adresses   fin vermat'
      if(yw)call flush(6)
c      print*,'vermat nbdet_cas',nbdet_cas
      return
      end
       subroutine reorde(ndet,nemax8,iadrv,ivrda,ior)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter(maxorbcas=16,maxda3=300)
      include 'maxorb.prm'
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |                               | iadrv | ior                     |
c
c
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    | iadrv |ivrda  |
c    |       |        ior            |  (ior prend toute la place dispon
c
c----------------------------------------------------------------
c     creation d'un fichier de determinants reclasses suivant
c     leurs adresses
c----------------------------------------------------------------
c
      integer(8) nemax8
      common/dim/iadri ; integer(8) iadri
      dimension iadrv(iadri),ivrda(iadri)
      integer*2 ior(0:nemax8*2,(iadri*6)/(nemax8*2+1))
      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
      logical*1 bidia
      common/stp/stop
      character*8 stop
c--   si ior en integer*4 : remplacer iadri*6 par iadri*3
c     dans la dimension et dans long
ctest:      integer*2 ior(0:nemax8*2,20)
c:
      dimension itp(2*maxorbcas+4)
      yw=.false.
      if(yw)print*,'reorde ouverture ORDET'
      if(yw)call flush(6)
      if(irest.eq.1.or.irest.eq.3) then
         open(61,status='OLD',file='ORDET',form='UNFORMATTED')
         return
      endif
      open(62,status='UNKNOWN',file='ORDET',form='UNFORMATTED')
      long=(iadri*6)/(nemax8*2+1)
ctest:long=20
c:
c--   inverse de iadrv
      rewind 87
      call lirbl(iadrv,ndet,87)
      if(yw)write(6,'(''iadrv avant reord'',10i4)')(iadrv(k),k=1,ndet)
      do k=1,ndet
         ivrda(iadrv(k))=k
      enddo
      do k=1,ndet
         iadrv(k)=ivrda(k)
      enddo
      if(yw)write(6,'(''iadrv apres reord'',10i4)')(iadrv(k),k=1,ndet)
      if(yw)print*,'fin inverse de iadrv'
      if(yw)call flush(6)
c--   boucle sur la zone ou on garde les determinants
      do k=1,ndet,long
         rewind 61
c--      lecture de tous les det ancien ordre
         long2=0
         do l=1,ndet
            read(61) ne
            il=iadrv(l)
            if(yw)write(6,*)'k,il',k,il
            if(il.ge.k.and.il.lt.k+long) then
               long2=long2+1
c--            le det lu appartient a la bonne zone
               il1=il-(k-1)
               if(yw)write(6,*)'il1',il1
c--            dans cette zone, il a le numero il1
               ior(0,il1)=ne
               if(ne.ne.0)read(61)(itp(kk),kk=1,ne+ne)
               if(yw)write(6,*)'lu',(itp(kk),kk=1,ne+ne)
               do kk=1,ne+ne
                  ior(kk,il1)=itp(kk)
               enddo
            else
               if(yw)write(6,*)'saute'
               if(ne.ne.0)read(61)
            endif
         enddo
c--      on a fini de remplir la zone  on l'ecrit sur le fichier
c        des determinants reordonnes
         do il1=1,long2
            ne=ior(0,il1)
            write(62) ne
            do kk=1,ne+ne
               itp(kk)=ior(kk,il1)
            enddo
            if(ne.ne.0)write(62)(itp(kk),kk=1,ne+ne)
            if(yw.and.ne.ne.0)write(6,*)'ecr',(ior(kk,il1),kk=1,ne+ne)
         enddo
      enddo
      close(61)
      close(62)
      if(stop.eq.'ORDET') stop 'stop ORDET'
      open(61,status='OLD',file='ORDET',form='UNFORMATTED')
      return
      end
       subroutine reorde2(cior,cior256,ndet,nemax8,iadrv)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter(maxorbcas=16,maxda3=300,maxne=maxorbcas+2)
      include 'maxorb.prm'
      parameter (lungo=100)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    | iadrv |
c    |       |        cior           |  (cior prend toute la place dispo
c
c----------------------------------------------------------------
c     creation d'un fichier de determinants reclasses suivant
c     leurs adresses
c----------------------------------------------------------------
c
      integer(8) nemax8
      common/dim/iadri ; integer(8) iadri
      dimension iadrv(iadri)
      character*1 cior,cnems,cec,ctps,cex,c256,cior256
c        on devrait remplacer (iadri*6) par (iadri*12)????????????
      dimension cior(0:nemax8*2,(iadri*6)/(nemax8*2+1))
      dimension cior256(0:nemax8*2+(nemax8+3)/4
     *,(iadri*6)/(nemax8*2+1+(nemax8+3)/4))
      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/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/stp/stop
      character*8 stop
      dimension itab(2048)
      dimension cit(maxne),cip(maxne),c256n((maxne+3)/4)
      common/test/itest(100)
      character*1 cit,cip,c256n
      yw=.false.
!      print*,'DIM',iadri*6,nemax8,
!     *(iadri*6)/(nemax8*2+1+(nemax8+3)/4)
      !print*,shape(cior256)
      !print*,shape(cior)
      !print*,size(cior256)
      !print*,size(cior)
      npie2=0
      mpie2=0
      mpie256=0
      if(yw)print*,'reorde2 ouverture ORDET'
      if(yw)call flush(6)
      if(irest.eq.1.or.irest.eq.3) then
         open(61,status='OLD',file='ORDET',form='UNFORMATTED')
         return
      endif
      open(62,status='UNKNOWN',file='ORDET',form='UNFORMATTED')
      if(norb.le.256) then
         long=(iadri*6)/(nemax8*2+1)
      else
         long=(iadri*6)/(nemax8*2+1+(nemax8+3)/4)
      endif
      if(yw)print*,'reorde2 long',long
      if(yw)print*,'reorde2 maxne',maxne
ctest:long=20
c:
c--   inverse de iadrv
      rewind 87
 
      kk=0
      do ideb=1,ndet,2048
         ifin=min(ideb+2048-1,ndet)
         ilon=ifin-ideb+1
         call liri(itab,ilon,87)
         if(yw) then
            do k=1,ilon
               print*,'iadrv87',k,itab(k)
            enddo
         endif
         do k=1,ilon
            kk=kk+1
            iadrv(itab(k))=kk
         enddo
      enddo
      if(yw)write(6,'(''iadrv apres reord'',10i8)')(iadrv(k),k=1,100)
c--   boucle sur la zone ou on garde les determinants
      do k=1,ndet,long
         call rew61
c--      lecture de tous les det ancien ordre
         long2=0
c        print*,'cex avant',ichar(cex(1))/maxne
         do l=1,ndet
            call venondloc3(ne,cnems,cit,cip,c256n,ierr)
            if(yw)print*,'reorde2 l,ne',ne
            il=iadrv(l)
c           if(yw)write(6,*)'k,il',k,il
            if(il.ge.k.and.il.lt.k+long) then
               long2=long2+1
c--            le det lu appartient a la bonne zone
               il1=il-(k-1)
               if(yw)write(6,*)'il1',il1
c--            dans cette zone, il a le numero il1
c-- norb < 256 on utilise cior
               if(norb.le.256) then
                  cior(0,il1)=cnems
                  do kk=1,ne
                     if(yw)write(6,*)'1il1',il1
                     cior(kk,il1)=cit(kk)
                     if(yw)write(6,*)'2il1',il1
                     cior(kk+ne,il1)=cip(kk)
                  enddo
               else
                  cior256(0,il1)=cnems
                  do kk=1,ne
                     if(yw)write(6,*)'1il1',il1
                     cior256(kk,il1)=cit(kk)
                     if(yw)write(6,*)'2il1',il1
                     cior256(kk+ne,il1)=cip(kk)
                  enddo
                  do kk=1,(ne+3)/4
                     cior256(kk+ne+ne,il1)=c256n(kk)
                  enddo
               endif
            else
c              if(yw)write(6,*)'saute'
            endif
         enddo
c        print*,'cex apres',ichar(cex(1))/maxne
c--      on a fini de remplir la zone  on l'ecrit sur le fichier
c        des determinants reordonnes
         if(yw)print*,'reorde2 fin zone'
         if(yw)print*,'iadri,long,long2',iadri,long,long2
         if(yw)call flush(6)
         if(yw) call flush(6)
         do il1=1,long2
            if(norb.le.256) then
               cec=cior(0,il1)
                ne=(  int(dsqrt(8.d0*ichar(cec)))   -1)/2
               do kk=1,ne
                  cit(kk)=cior(kk,il1)
                  cip(kk)=cior(kk+ne,il1)
               enddo
            else
               cec=cior256(0,il1)
                ne=(  int(dsqrt(8.d0*ichar(cec)))   -1)/2
               do kk=1,ne
                  cit(kk)=cior256(kk,il1)
                  cip(kk)=cior256(kk+ne,il1)
               enddo
               do kk=1,(ne+3)/4
                  c256n(kk)=cior256(kk+ne+ne,il1)
               enddo
            endif
            call pie2(ne,cec,cit,cip,c256n)
         enddo
         call fine2
      enddo
      if(itest(28).eq.1) then
         close(61,status='delete')
      else
         close(61)
      endif
      close(62)
      if(yw)print*,'fin remplissage ORDET'
      if(yw)call flush(6)
      if(stop.eq.'ORDET') stop 'stop ORDET'
      open(61,status='OLD',file='ORDET',form='UNFORMATTED')
      return
      end
       subroutine syspi01(isspi,nca,ica,ncb,icb,nt,it,ispt,np,ip,ispp,
     *iadr1,nta,npa)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
c
c      common/ver2/iadrver(500)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |--------isspi----------|
c
c----------------------------------------------------------------
c     symetrie de spin
c----------------------------------------------------------------
c
      common/dim/iadri ; integer(8) iadri
      dimension isspi(iadri)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/opt/ihab,calcul
      character*3 calcul
      dimension ica(maxorbcas),icb(maxorbcas),it(2),ip(2),it2(2),ip2(2)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      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
      yw=.false.
      if(syspin.eq.'0'.or.isspi(iadr1).ne.0) return
      if(yw)print*,'SYMETRIE DE SPIN 2'
c--   on calcule l'adresse de l'inverse de spin
      ispt2=-ispt
      nt2=0
      do k=nta+1,nt
         nt2=nt2+1
         it2(nt2)=iorb(it(k))
      enddo
      do k=1,nta
         nt2=nt2+1
         it2(nt2)=it(k)
      enddo
      ispp2=-ispp
      np2=0
      do k=npa+1,np
         np2=np2+1
         ip2(np2)=iorb(ip(k))
      enddo
      do k=1,npa
         np2=np2+1
         ip2(np2)=ip(k)
      enddo
      call adrdet
     *(ncb,icb,nca,ica,nt,it2,ispt2,np,ip2,ispp2,iadr2,
     * mhdum,mtdum)
      isspi(iadr1)=iadr2
      isspi(iadr2)=iadr1
      if(yw)write(6,*)'iadr1,isspi(iadr1)',iadr1,iadr2
      return
      end
       subroutine venondloc(ne,ntv,npv,ierr)
      implicit real*8(a-h,o-x,z),logical*1(y)
      parameter(maxorbcas=16)
      common/test/itest(100)
      dimension ntv(maxorbcas+2),npv(maxorbcas+2)
      if(itest(25).eq.1) then
         call venondloc2(ne,ntv,npv,ierr)
         return
      endif
      ierr=0
      read(61,end=1) ne
      if(ne.ne.0) read(61)(ntv(k),k=1,ne),(npv(k),k=1,ne)
      return
 1    ierr=1
      return
      end
       subroutine venondloc2(ne,ntv,npv,ierr)
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter(maxorbcas=16,lungo=100,maxne=maxorbcas+2)
      include 'maxorb.prm'
      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)
      common/debug/ywgen
      yw=.false.
      yw=yw.or.ywgen
      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*,'venondloc2 lect ndestod,mdestod,mdestod256',
     *   ndestod,mdestod,mdestod256
c        print*,'venondloc2 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*,'venondloc2 ndestod',ndestod
      endif
      if(yw)print*,'venondloc2 ndestod1',ndestod1
      nems=ichar(cex(ndestod1))
      call venondloc4(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)
            if(yw)print'(2a,i5)','c256',c256(mdestod2561),mdestod2561
            if(yw)print'(a,10i5)','iii,np1024',iii,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*,'venondloc2 itv,ipv',(ntv(k),k=1,ne),(npv(k),k=1,ne)
      return
 1    ierr=1
      if(yw)print*,'venondloc2 lect fin fich',ndestod,ndestod1
      return
      end
       subroutine venondloc4(nems,ne,mst)
      logical*1 yw,ywgen
      common/debug/ywgen
      yw=.false.
      yw=yw.or.ywgen
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 venondloc3(ne,cnems,ctv,cpv,c256n,ierr)
      implicit real*8(a-h,o-x,z),logical*1(y)
      parameter(maxorbcas=16,lungo=100,maxne=maxorbcas+2)
      character*1 ctps,cex,ctv(maxorbcas+2),cpv(maxorbcas+2),cnems
      character*1 ctpsl,cexl,c256,c256n(maxne/4+1)
      common/detsto/mdestod,ndestod,mdestod1,ndestod1,npie2,mpie2,
     *mpie256,mdestod256,mdestod2561,
     *ctps((maxne)*lungo*2),cex(lungo),c256((maxne/4+1)*lungo)
      dimension cexl(lungo),ctpsl((maxne)*lungo*2)
      common/debug/ywgen
      save cexl,ctpsl
c================================================================
c     subroutine de lecture des determinants codes en caracteres
c================================================================
      yw=.false.
      yw=yw.or.ywgen
      ierr=0
      ndestod1=ndestod1+1
      if(ndestod1.gt.ndestod) then
         read(61,end=1) mdestod,ndestod,(ctpsl(i),i=1,mdestod),
     *   (cexl(i),i=1,ndestod)
     *   ,mdestod256,(c256(i),i=1,mdestod256)
         if(yw)print*,'venondloc3 lect   mdestod,ndestod',mdestod,ndestod
c         print*,'c256',(ichar(c256(k)),k=1,mdestod256)
         ndestod1=1
         mdestod1=0
         mdestod2561=0
      endif
c-----------------------------------------------------
c     decodage du caractere contenant ne et ms
c     cnems (en char.)  ---->  nems (en entiers)
c     au codage, on avait nems=ne*(ne+1)/2+ms
c     on veut connaitre ne et ms
c     on demontre que : (verifie si tu ne me crois pas)
c     ne=(  int(dsqrt(8.d0*nems))   -1)/2
c     si! si!
c     on en deduit ms
c-----------------------------------------------------
      cnems=cexl(ndestod1)
      nems=ichar(cnems)
      ne=(  int(dsqrt(8.d0*nems))   -1)/2
      if(yw)print*,'ne',ne
      do k=1,ne
         mdestod1=mdestod1+1
         ctv(k)=ctpsl(mdestod1)
      enddo
      do k=1,ne
         mdestod1=mdestod1+1
         cpv(k)=ctpsl(mdestod1)
      enddo
      do k=1,(ne+3)/4
         mdestod2561=mdestod2561+1
         c256n(k)=c256(mdestod2561)
      enddo
      if(yw)print*,'ctv',(ichar(ctv(k)),k=1,ne)
      if(yw)print*,'cpv',(ichar(cpv(k)),k=1,ne)
      return
 1    ierr=1
      return
      end
       subroutine pie2(nec,cec,cts,cps,c256n)
c
c
c         subroutine che compatta i determinanti e li scrive su tape 62
c         version en caracteres
c
c
      implicit real*8(a-h,o-x,z),logical*1(y)
      parameter(lungo=100,maxorbcas=16,maxne=maxorbcas+2)
      include 'maxorb.prm'
      character*1 ctps,cex,cts,cps,cec,c256n(maxne/4+1),c256
c      common/detpie/m,n,idet(1200),nex(100),long(maxne),imono,ndet
      common/detsto/mdestod,ndestod,mdestod1,ndestod1,npie2,mpie2,
     *mpie256,mdestod256,mdestod2561,
     *ctps((maxne)*lungo*2),cex(lungo),c256((maxne/4+1)*lungo)
      dimension cts(maxne),cps(maxne)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      yw=.false.
c--
      npie2=npie2+1
      if(yw)print*,'entree pie2 npie2,mpie2',npie2,mpie2
      cex(npie2)=cec
c      if(il1.ge.246201.and.il1.le.246301)
c    *print*,'ne',
c    *ichar(cec)/maxne,npie2,ichar(cex(1))/maxne
c     if(il1.le.100)
c    *print*,'ne',
c    *ichar(cec)/maxne,npie2,ichar(cex(1))/maxne
c     if(il1.ge.246201.and.il1.le.246301)yw=.true.
c     if(il1.le.100)yw=.true.
      do k=1,nec
         mpie2=mpie2+1
         if(mpie2.gt.(maxne)*lungo*2) stop 'mpie2'
         ctps(mpie2)=cts(k)
      enddo
      do k=1,nec
         mpie2=mpie2+1
         if(mpie2.gt.(maxne)*lungo*2) stop 'mpie2'
         ctps(mpie2)=cps(k)
      enddo
      if(norb.gt.256) then
         do k=1,(nec+3)/4
            mpie256=mpie256+1
            c256(mpie256)=c256n(k)
         enddo
      endif
c     print*,'pie2 nt,np',(nt(k),k=1,nec),(np(k),k=1,nec)
      if(npie2.eq.lungo) then
         if(yw)print*,'pie2 ecriture',mpie2,npie2
         if(yw)print*,'pie2 cex',(ichar(cex(i))/maxne,i=1,npie2)
c     print*,'pie2 ctps', (ichar(ctps(i)),i=1,mpie2)
         write(62)mpie2,npie2,(ctps(i),i=1,mpie2)
     *   ,(cex(i),i=1,npie2),mpie256,(c256(i),i=1,mpie256)
c          print*,'ecriture 62',npie2,mpie2,mpie256
         mpie2=0
         npie2=0
         mpie256=0
      endif
      return
      entry fine2
      yw=.false.
      if(npie2.eq.0) return
      if(yw)print*,'fin pie2 ecriture',mpie2,npie2
c     print*,'pie2 ctps', (ichar(ctps(i)),i=1,mpie2)
      write(62) mpie2,npie2,(ctps(i),i=1,mpie2),
     *(cex(i),i=1,npie2),mpie256,(c256(i),i=1,mpie256)
      if(yw)print*,'fine ecriture 62',npie2,mpie2,mpie256
      mpie2=0
      npie2=0
      mpie256=0
      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
       subroutine stomono
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter(maxsym=8,maxorbcas=16,ngru3=2048)
      include 'maxorb.prm'
      dimension jtab(2048)
      dimension ntv(maxorbcas+2),npv(maxorbcas+2)
      dimension ica(maxorbcas),icb(maxorbcas),it(2),ip(2)
      common/test/itest(100)
      call rew61
      imono=0
      nmono=0
      open(28,form='unformatted',file='BIDMONO',status='unknown')
      idet=0
 1    continue
      idet=idet+1
      call venondloc(ne,ntv,npv,ierr)
      if(ierr.eq.1) goto 100
      call trad(ne,ntv,npv,nca,ica,ncb,icb,nt,it,ispt,np,ip,ispp,ibid)
      if(nt.gt.1.or.np.gt.1) goto 1
      imono=imono+1
      nmono=nmono+1
      if(imono.gt.2048) then
         imono=1
         write(28) jtab
      endif
      jtab(imono)=idet
      goto 1
 100  continue
      write(28) jtab
      itest(37)=nmono
      close(28)
      return
      end
 
