      subroutine pie(yc,nt,it,np,ip)
      use module
      implicit real(8) (a-h,o-x,z),logical(1)(y)
      logical(1) yc(32)
      integer nts(maxorbcas+2),nps(maxorbcas+2),it(nt),ip(np)
      yw=.false.
      nts=0
      nps=0
      nts(1:nt)=it(1:nt)
      nps(1:np)=ip(1:np)
      if(yw)print*,'yc',yc(1:noac*2)
      if(yw)print*,'it,ip',it(1:nt),'    ',ip(1:np)
      where(nts<0) nts=-nts+norb
      where(nps<0) nps=-nps+norb
      nt1=nt
      np1=np
      if(yw)print*,'avant nts,nps',nts(1:nt1),'    ',nps(1:np1)
      if(yw)print*,'nocac0,nocbc0',nocac0,nocbc0
      do k=1,noaco
         if(.not.yc(k)) then
            nt1=nt1+1
            nts(nt1)=numac(k)
         endif
      enddo
      do k=1+noaco,noac
         if(yc(k)) then
            np1=np1+1
            nps(np1)=numac(k)
         endif
      enddo
      do k=1,noaco
         if(.not.yc(k+noac)) then
            nt1=nt1+1
            nts(nt1)=numac(k)+norb
         endif
      enddo
      do k=1+noaco,noac
         if(yc(k+noac)) then
            np1=np1+1
            nps(np1)=numac(k)+norb
         endif
      enddo
      call reor(nt1,nts,idum)
      call reor(np1,nps,idum)
      if(yw)print*,'nts,nps',nts(1:nt1),'    ',nps(1:np1)
      if(nt1.ne.np1) nps(nt1)=norb+norb+1
      if(ydetv) call piev(nt1,nts,nps)
      call pie2(nt1,nts,nps)
      !if(nt1/=0) stop
      return
      end
       subroutine pie2(nec,nts,nps)
      use module
      parameter(maxorbcas2=16)
c
c
c         subroutine che compatta i determinanti e li scrive su tape 60
c         version en caracteres
c
c
      implicit real(8) (a-h,o-x,z),logical(1)(y)
      parameter(maxnec=maxorbcas2+2,lungo=100)
      logical(1),save :: ypremier=.true.
      integer,save :: nsto=0,msto=0,msto256=0
      dimension nt(maxnec),np(maxnec),np1024(maxnec)
      dimension nts(nec),nps(nec)
      character(1),save :: ctps((maxnec)*lungo*2),cex(lungo)
     *,c256((maxnec/4+1)*lungo)
      character(4) genercd
      character(100) namel

      yw=.false.
      yw1=.false.
      if(ypremier) then
!
! Generation de donnees pour programmes apres CASDI (ex: prop)
         open(60,file=det1,status='unknown',
     *   form='unformatted')
         if(gener.eq.'CAS') genercd='MRTC'
         if(gener.eq.'CAS+SD') genercd='MRT'
         if(gener.eq.'CAS+S') genercd='MRTM'
         if(gener.eq.'CAS+DDCI') genercd='MRTD'
         if(gener.eq.'CAS+DDC2') genercd='MRT2'
         if(gener.eq.'SEL') genercd='MRC'
         if(gener.eq.'SEL+SD') genercd='MRS'
         if(gener.eq.'SEL+S') genercd='MRM'
         if(gener.eq.'SEL+DDCI') genercd='MRDD'
         if(gener.eq.'SEL+DDC2') genercd='MRD2'
         open(99,file=trim(prefix)//'cdi',status='unknown')
         write(99,'(a)')' &cdi gener='//''''//trim(genercd)//''''
         write(99,'(a,i10)')' ndet=',ndet
         write(99,'(a,i2)')' noac=',noac
         write(99,'(a,i2)')' nelac=',nelac
         write(99,'(a,i2)')' ms2=',ms2
         write(99,'(a)')' is0=1'
         write(99,1000)' numac=',numac(1:noac)
         write(99,'(a)')' /'
 1000    format(a,16(i3,","))
         close(99)
         !print*,'genercd',genercd
         !print*,'noac,nelac,is0,ms2',noac,nelac,is0,ms2
         !print*,'numac',numac
! Ecriture de la file OCCMRS
         if(gener(1:3)=='SEL') then
            rewind 93
            open(99,file='OCCMRS',status='unknown')
            call LECNAM('&SELEC',namel,93,ierr,0)
            n=0
            do
               read(93,'(a80)')namel(1:80)
               namel=adjustl(namel)
               call maj(namel,3)
               if(namel(1:3)=='FIN'.or.namel(1:3)=='END') exit
               n=n+1
            enddo
            rewind 93
            call LECNAM('&SELEC',namel,93,ierr,0)
            namel=' '
            write(99,*) n
            do k=1,n
               read(93,'(a80)')namel(1:80)
               write(99,*) trim(namel)
            enddo
            close(99)
         endif
      endif
      if(yw)write(6,'(a20,40i4)')'pie2 det v',(nts(k),k=1,nec),
     *(nps(k),k=1,nec)
c     ====================================
c     on note ou commencent les spins beta
c     ====================================
      ms=nec+1
      !if(ms.gt.maxnec+2)stop 'dans pie2   CAS trop grand'
      do k=1,nec
         if(nts(k).gt.norb) then
            ms=k
            exit
         endif
      enddo
c     ====================================
c     on supprime les spins beta
c     ====================================
      do k=1,nec
         if(nts(k).gt.norb) then
            nt(k)=nts(k)-norb
         else
            nt(k)=nts(k)
         endif
         if(nps(k).gt.norb) then
            np(k)=nps(k)-norb
         else
            np(k)=nps(k)
         endif
      enddo
c--
      if(yw1)write(6,'(a20,40i4)')'pie2 det n',(nt(k),k=1,nec),
     *(np(k),k=1,nec)
c     ===========================================
c     on incremente le nombre de determinants
c     ===========================================
      nsto=nsto+1
c     ===========================================
c     codage en caracteres de ne et du nb d'alpha
c     ===========================================
c      necms=ms+nec*maxnec
      necms=nec*(nec+1)/2+ms
      if(yw)print*,'necms,ms,nec,maxnec',necms,ms,nec,maxnec
      cex(nsto)=char(necms)
c     ===========================================
c     codage en caracteres des trous
c     ===========================================
      do k=1,nec
         msto=msto+1
         ctps(msto)=char(nt(k))
      enddo
c     ===========================================
c     codage en caracteres des particules
c     ===========================================
      if(norb.le.256) then
         do k=1,nec
            msto=msto+1
            ctps(msto)=char(np(k))
         enddo
      else
         do k=1,nec
            msto=msto+1
            np256=np(k)
            call corr1024(np256,np1024(k))
            ctps(msto)=char(np256)
         enddo
c        ===========================================
c        codage en caracteres des orbitales > 256
c        ===========================================
         do k=1,nec,4
            msto256=msto256+1
            i256=0
            kkk=0
            do kk=k,min(k+3,nec)
               i256=i256+np1024(kk)*4**kkk
               if(yw)print*,'i256',i256
               kkk=kkk+1
            enddo
            c256(msto256)=char(i256)
         enddo
      endif
      if(nsto.eq.lungo) then
         write(60)msto,nsto,(ctps(i),i=1,msto),(cex(i),i=1,nsto)
     *   ,msto256,(c256(i),i=1,msto256)
c     print*,'ecriture pie2', nsto,msto
c          print*,'ecriture 60',nsto,msto
         msto=0
         msto256=0
         nsto=0
      endif
      ypremier=.false.
      return
      entry fine2
      yw=.false.
      if(nsto.eq.0) return
      if(yw)print*,'ecriture dans fine2'
      write(60) msto,nsto,(ctps(i),i=1,msto),(cex(i),i=1,nsto)
     *,msto256,(c256(i),i=1,msto256)
c     print*,'fin ecriture pie2', nsto,msto
c        print*,'fine ecriture 60',nsto,msto
      msto=0
      msto256=0
      nsto=0
      return
      end
       subroutine corr1024(ni,icorr)
      icorr=(ni-1)/256
      if(ni.le.256) return
      ni=mod(ni,256)
      if(ni.eq.0) ni=ni+256
      return
      end
       subroutine piev(nec,nts,nps)
       use module
c
c
c         subroutine che compatta i determinanti e li scrive su tape 60
c
c
      parameter(maxorbcas2=16)
      implicit real(8) (a-h,o-x,z),logical(1)(y)
      parameter(maxnec=maxorbcas2+2,lungo=100)
      logical(1),save :: ypremier=.true.
      integer,save :: nstov=0,mstov=0,idet(2800)
      dimension nt(maxnec),np(maxnec),np1024(maxnec)
      dimension nts(nec),nps(nec)
      character(1),save :: ctps((maxnec)*lungo*2),cex(lungo)
     *,c256((maxnec/4+1)*lungo)
      dimension iv(maxorbcas/2+1),nex(100)
!      implicit real*8(a-h,o-x,z),logical*1(y)
!      parameter(maxorb=1024,nsymz=8,maxorbcas=16)
      character*1 ylog
!      common/det/msto,nsto,mstov,nstov,idet(2400),nex(100),
!     *long(maxorbcas+2),imono,ndet,msto256,
!     *ncfmin,ncfmax
      dimension ylog(maxorbcas*2+4)!,iv(maxorbcas/2+1),
!     *nts(maxorbcas+2),nps(maxorbcas+2)
      equivalence(ylog(1),iv(1))
c     write(6,*)'nec,nts,nps',nec,(nts(ii),ii=1,nec),(nps(ii),ii=1,nec)
      yw=.false.
      yw1=.false.
      if(ypremier)open(62,file='DETV',status='unknown',
     *form='unformatted')
      if(nec.eq.0) go to 10
      lon=(nec-1)/2+1
      do 1 i=1,lon
      iv(i)=0
 1    continue
      do 2 i=1,nec
      i4=nts(i)
      ylog(i)=char(i4)
      i4=nps(i)
      ylog(i+nec)=char(i4)
 2    continue
      do 3 k=1,lon
      mstov=mstov+1
      idet(mstov)=iv(k)
 3    continue
 10   continue
      nstov=nstov+1
      nex(nstov)=nec
      if(nstov.lt.lungo) return
      write(62)mstov,nstov,(idet(i),i=1,mstov),
     *(nex(i),i=1,nstov),(1.d0,i=1,nstov)
      mstov=0
      nstov=0
      return
      entry finev
      if(nstov.eq.0) return
      write(62) mstov,nstov,(idet(i),i=1,mstov),
     *(nex(i),i=1,nstov),(1.d0,i=1,nstov)
      mstov=0
      nstov=0
      ypremier=.false.
      return
      END
