      subroutine prede3s(iesp,idebd,idebd3,iadrr,mh,mt,
     *nor3,nordeb,num1
     *,num2,num3,ispi1,ispi2,ispi3,inddet,is)
      implicit real*8(a-h,o-x,z),logical*1 (y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      common/dim/iadri ; integer(8) iadri
      parameter(maxorbcas=16,maxdetc=12870)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |     iadrr     |  mh   |  mt   |
c
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      dimension idebd(norb,norb),ilond(maxsym),idebd3(norb,nsym)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/sy2/nts(maxsym),ncs(maxsym),nps(maxsym)
     *,norbs(maxsym)
      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
      common /det/ndet,mdet(50),nbdet_cas
      dimension iesp(maxorbcas*maxdetc*2),iadrr(iadri*4),num1(*),num2(*)
     *,num3(*)
      common/sy4/ntcpstot(0:maxsym,3)
      dimension mh(iadri),mt(iadri)
      dimension ip(2)
      integer(8) ndet8
cdcor
ccor      common/bidvr/ibidv(10000),ibidr(10000,20),icor
cfcor
      yw=.false.
      yw1=.false.
      if(yw1)print*,'entree prede3s',inddet
      ndet8=ndet
      do k=1,min(ndet8*2,iadri)
         iadrr(k)=0
      enddo
      kdet=0
      if(inddet.le.20) then
         ityp=3
      else
         ityp=1
      endif
 
c
c     boucle sur l'ordre des orbitales
c     0 : io1=io2 ; 1 : io1<io2 ; 2 : io1>io2
c
      if(nordeb.eq.1) then
         iordd=0
         iordf=2
      else
         iordd=1
         iordf=1
      endif
      do iord=iordd,iordf
         if(iord.eq.0) then
            isolp=0
         else
            isolp=2
         endif
         if(yw)print 1000,'§§§§§§iord, isolp',iord, isolp
c
c           boucles sur les symetries des particules
c
         if(isolp.eq.0) then
            ispf=1
         else
            ispf=nsym
         endif
         do isp=1,ispf
            yprem=.true.
            do is1=1,nsym
               is2=its(isp,is1)
               if(iord.eq.1.and.is2.lt.is1) goto 1
               if(iord.eq.2.and.is2.gt.is1) goto 1
               if(yw)print 1000,'§§§§§§isp,is1,is2',isp,is1,is2
c
c              boucles sur les orbitales
c
               do ko1=ntcpstot(is1-1,ityp)+1,ntcpstot(is1,ityp)
                  io1=num1(ko1)
                  if(iord.eq.0) then
                     io2d=ko1
                     io2f=ko1
                  else if (iord.eq.1) then
                     if(isp.eq.1) then
                        io2d=ko1+1
                        io2f=ntcpstot(is2,ityp)
                     else
                        io2d=ntcpstot(is2-1,ityp)+1
                        io2f=ntcpstot(is2,ityp)
                     endif
                  else if (iord.eq.2) then
                     if(isp.eq.1) then
                        io2d=ntcpstot(is2-1,ityp)+1
                        io2f=ko1-1
                     else
                        io2d=ntcpstot(is2-1,ityp)+1
                        io2f=ntcpstot(is2,ityp)
                     endif
                  endif
                  do ko2=io2d,io2f
                     io2=num2(ko2)
                     if(yw)print 1000,'io1,io2',io1,io2
                     idebd(io1,io2)=kdet+1
                     if(yw)print 1000,
     *               'io1,io2,idebd',io1,io2,idebd(io1,io2)
c                    si is=1 on symetrise idebd
                     if(is.eq.1) idebd(io2,io1)=kdet+1
                     if(yw1)write(6,'('' ----prede3s orb,io1,io2'',4i5)'
     &               )
     *               io1,io2
                     if(yw1)call flush(6)
                     if(inddet.eq.15.or.inddet.eq.17
     *               .or.inddet.eq.21.or.inddet.eq.23) then
                        ip(1)=io1
                        ip(2)=io2+norb
                     else if(inddet.eq.19.or.inddet.eq.25) then
                        ip(1)=io1+norb
                        ip(2)=io2+norb
                     else if(inddet.eq.20.or.inddet.eq.26) then
                        ip(1)=io1
                        ip(2)=io2
                     endif
                     if(yw)print 1000,'ip',ip
                     if(ityp.eq.1) then
                        call adrts(2,ip,iadrp)
                     else
                        call adrps(2,ip,iadrp)
                     endif
                     if(yw)print 1000,'ityp,iadrp',ityp,iadrp
                     if(yprem) then
                        iadrp0=iadrp
c
c                       boucle sur le trou
c
                        kdet0=kdet+1
                        do m=1,nor3
                           io3=num3(m)
                           is3=itsym(io3)
                           if(yw)print 1000,'§§§§§§io3',io3
                           idebd3(io3,isp)=kdet+1
     *                     -idebd(io1,io2)
                           kdet3=kdet+1
                           call gende3(iesp,
     *                     iesp(maxorbcas*maxdetc+1),iadrr,io1,io2,io3,
     *                     ispi1,ispi2,ispi3
     *                     ,kdet,inddet,0,2,2,mh,mt)
c                           if(kdet.gt.iadri) then
c                              write(6,*)'kdet,iadri',kdet,iadri
c                              stop 290
c                           endif
                           ilond(its(isp,is3))=kdet-kdet3
                        enddo
                        yprem=.false.
                        kdet1=kdet
                        if(yw)print 1000,'apres gende3 kdet0,kdet1',
     *                  kdet0,kdet1
                        if(yw)then
                           do k=kdet0,kdet1
                              print 1000,
     *                        'k,mh,mt,iadrr',
     *                        k,mh(k),mt(k),iadrr(k)
                           enddo
                        endif
                     else
c
c                       boucles sans appel a gende3
c
                        if(yw)print 1000,'ypremF kdet0,kdet1',
     *                  kdet0,kdet1
                        if(yw)print 1000,'iadrp0,iadrp',iadrp0,iadrp
                        iadrp1=iadrp-iadrp0
                        do i=kdet0,kdet1
                           kdet=kdet+1
c                           if(kdet.gt.iadri) then
c                              write(6,*)'kdet,iadri',kdet,iadri
c                              stop 29
c                           endif
                           if(ityp.eq.3) then
                              if(iadrr(i).gt.0) then
                                 if(kdet.le.iadri)iadrr(kdet)=iadrr(i)
     *                           +iadrp1*mh(i)*mt(i)
                              else if(iadrr(i).eq.0) then
                                 if(kdet.le.iadri)iadrr(kdet)=0
                              else if(iadrr(i).lt.0) then
                                 if(kdet.le.iadri)iadrr(kdet)=iadrr(i)
     *                           -iadrp1*mh(i)*mt(i)
                              endif
 1000                         format(a30,10i5)
                              if(yw)print 1000,
     *                        'kdet,i,iadrrv,mh,mt,iadrr',
     *                        kdet,i,iadrr(i),mh(i),mt(i)
     *                        ,iadrr(kdet)
                           else
                              if(iadrr(i).gt.0) then
                                 if(kdet.le.iadri)iadrr(kdet)=iadrr(i)
     *                           +iadrp1*mh(i)
                              else if(iadrr(i).eq.0) then
                                 if(kdet.le.iadri)iadrr(kdet)=0
                              else if(iadrr(i).lt.0) then
                                 if(kdet.le.iadri)iadrr(kdet)=iadrr(i)
     *                           -iadrp1*mh(i)
                              endif
                              if(yw)print 1000,
     *                        'kdet,i,iadrrv,mh,mt,iadrr',
     *                        kdet,i,iadrr(i),mh(i),mt(i)
     *                        ,iadrr(kdet)
                           endif
                        enddo
                     endif
                  enddo
               enddo
 1             continue
            enddo
         enddo
      enddo
      mdet(inddet)=kdet
      if(yw) then
         do k=1,norb
            write(75,*)'prede3s idebd',(idebd(k,l),l=1,norb),'
     &      $'
            call scril
         enddo
         write(6,*)'prede3s ilond',(ilond(k),k=1,nsym)
         do k=1,kdet
            write(6,*)'prede3s k,iadrr(k)',k,iadrr(k)
         enddo
      endif
      call ecri(idebd,norb*norb,77)
      call ecri(idebd3,norb*nsym,77)
      call ecri(ilond,maxsym,77)
      call ecribl(iadrr,kdet,76)
      return
      end
       subroutine prede4sbid(iesp,iadrr,inddet,
     *ispi1,ispi2,ifil,mh,mt)
      implicit real*8(a-h,o-x,z),logical*1 (y)
      parameter(maxsym=8)
      include 'maxorb.prm'
      common/dim/iadri ; integer(8) iadri
      parameter(maxorbcas=16,maxdetc=12870)
c
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |     iadrr     |  mh   |  mt   |
c
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/sy2/nts(maxsym),ncs(maxsym),nps(maxsym)
     *,norbs(maxsym)
      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
      common /det/ndet,mdet(50),nbdet_cas
      dimension iesp(*),iadrr(iadri),mh(iadri),mt(iadri)
      common/sy4/ntstot(0:maxsym),ncstot(0:maxsym),npstot(0:maxsym)
      character*8 ifil
      common/ijd/inti(1024),intj(1024),intk(1024),intl(1024),aaint(1024)
      common/util/jsp(-2:2,-2:2),ksp(-4:4)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      dimension it(2),ip(2)
      yw=.false.
      yw1=.false.
      if(yw1)print*,'entree prede4s'
      if(yw1)call flush(6)
      kdet=0
c
c--------------------------------------------------
c     generation des determinants non excites
c--------------------------------------------------
c
      call gende0(iesp,
     *iesp(maxorbcas*maxdetc+1),iadrr,kdet,mh,mt)
      mdec=kdet
      print*,'apres gende0 kdet',kdet
      ispc1=0
      ispc=jsp(ispc1,0)
      ispcas=ms2+ispc
      if(yw)write(6,*)'ms2,ispc,ispcas',ms2,ispc,ispcas
      nca=(nelac+ispcas)/2
      if(nca.lt.0) return
      ncb=(nelac-ispcas)/2
c
c     boucle sur l'ordre des trous
c     0 : io1=io2 ; 1 : io1<io2 ; 2 : io1>io2
c
      if(ifil.eq.'CDI_3311') then
         iordtd=0
         iordtf=1
      else
         iordtd=1
         iordtf=1
      endif
      do iordt=iordtd,iordtf
         if(iordt.eq.0) then
            isolt=0
         else
            isolt=2
         endif
         if(yw)print 1000,'§§§§§§iordt, isolt',iordt, isolt
         if(yw1)call flush(6)
c
c     boucle sur l'ordre des particules
c     0 : io3=io4 ; 1 : io3<io4 ; 2 : io3>io4
c
         if(ifil.eq.'CDI_3311') then
            iordpd=0
            iordpf=1
         else
            iordpd=1
            iordpf=1
         endif
         do iordp=iordpd,iordpf
            if(iordp.eq.0) then
               isolp=0
            else
               isolp=2
            endif
            if(yw)print 1000,'§§§§§§iordp, isolp',iordp, isolp
            if(yw1)call flush(6)
c
c           boucles sur les symetries
c
            if(isolp.eq.0.or.isolt.eq.0) then
               isf=1
            else
               isf=nsym
            endif
            do is=1,isf
               yprem1=.true.
               yprem2=.true.
               do 1 ist1=1,nsym
               ist2=its(is,ist1)
               if(iordt.eq.1.and.ist2.lt.ist1) goto 1
               if(iordt.eq.2.and.ist2.gt.ist1) goto 1
               do 2 isp1=1,nsym
               isp2=its(is,isp1)
               if(iordp.eq.1.and.isp2.lt.isp1) goto 2
               if(iordp.eq.2.and.isp2.gt.isp1) goto 2
               if(yw)print 1000,'§§§§§§is,ist1,ist2,isp1,isp2'
     *         ,is,ist1,ist2,isp1,isp2
               if(yw1)call flush(6)
c
c                    boucles sur les orbitales
c
               do ko1=ntstot(ist1-1)+1,ntstot(ist1)
                  io1=numt(ko1)
                  if(iordt.eq.0) then
                     io2d=ko1
                     io2f=ko1
                  else if (iordt.eq.1) then
                     if(is.eq.1) then
                        io2d=ko1+1
                        io2f=ntstot(ist2)
                     else
                        io2d=ntstot(ist2-1)+1
                        io2f=ntstot(ist2)
                     endif
                  else if (iordt.eq.2) then
                     if(is.eq.1) then
                        io2d=ntstot(ist2-1)+1
                        io2f=ko1-1
                     else
                        io2d=ntstot(ist2-1)+1
                        io2f=ntstot(ist2)
                     endif
                  endif
                  do ko3=npstot(isp1-1)+1,npstot(isp1)
                     io3=nump(ko3)
                     if(iordp.eq.0) then
                        io4d=ko3
                        io4f=ko3
                     else if (iordp.eq.1) then
                        if(is.eq.1) then
                           io4d=ko3+1
                           io4f=npstot(isp2)
                        else
                           io4d=npstot(isp2-1)+1
                           io4f=npstot(isp2)
                        endif
                     else if (iordp.eq.2) then
                        if(is.eq.1) then
                           io4d=npstot(isp2-1)+1
                           io4f=ko3-1
                        else
                           io4d=npstot(isp2-1)+1
                           io4f=npstot(isp2)
                        endif
                     endif
                     do ko2=io2d,io2f
                        io2=numt(ko2)
                        do ko4=io4d,io4f
                           io4=nump(ko4)
                           if(ifil.eq.'CDI_3311') then
                              if(mod(nca+ncb,2).eq.1) isgn=-1
                              it(1)=io1
                              it(2)=io2+norb
                              ip(1)=io3
                              ip(2)=io4+norb
                              call adrts(2,it,iadrt1)
                              call adrps(2,ip,iadrp1)
                           if(yw)print 1000, 'it,ip',it,ip
                              it(1)=io2
                              it(2)=io1+norb
                              ip(1)=io4
                              ip(2)=io3+norb
                              call adrts(2,it,iadrt2)
                              call adrps(2,ip,iadrp2)
                           if(yw)print 1000, 'it,ip',it,ip
                           else
                              if(ispi1.eq.1) then
                                 it(1)=io1
                                 it(2)=io2
                                 ip(1)=io3
                                 ip(2)=io4
                                 call adrts(2,it,iadrt2)
                                 call adrps(2,ip,iadrp2)
                           if(yw)print 1000, 'it,ip',it,ip
                              else
                                 it(1)=io1+norb
                                 it(2)=io2+norb
                                 ip(1)=io3+norb
                                 ip(2)=io4+norb
                                 call adrts(2,it,iadrt2)
                                 call adrps(2,ip,iadrp2)
                           if(yw)print 1000, 'it,ip',it,ip
                              endif
                           endif
                           if(yw)print 1000,
     *                     'iadrt1,iadrt2',iadrt1,iadrt2
c
c                          fin boucle orbitales
c                          calcul des adresses
c
                           if(yw1)call flush(6)
                           if(ifil.eq.'CDI_3311') then
                              if(yprem1) then
c
c                                premiere fois : appel gende4
c
                                 print*,'avant gende4 kdet',kdet
                                 kdet0=kdet+1
                                 call gende4(iesp,
     *                           iesp(maxorbcas*maxdetc+1)
     *                           ,iadrr,io1,io2,io3,io4,
     *                           ispi1,ispi2,kdet,mh,mt)
                                 kdet1=kdet
                                 yprem1=.false.
                                 iadrt0=iadrt1
                                 iadrp0=iadrp1
                                 if(yw) then
                                    do k=kdet0,kdet1
                                       print 1000,
     *                                 '1k,mh,mt,iadrr',
     *                                 k,mh(k),mt(k)
     *                                 ,iadrr(k),iadrt1,iadrp1
                                    enddo
                                 endif
                              else
c
c                                autres fois, calcul rapide
c
                  print*,'kdet0,kdet1',kdet0,kdet1
                                 do k=kdet0,kdet1
                                    kdet=kdet+1
                                    if(iadrr(k).gt.0) then
                                       if(kdet.le.iadri)
     *                                 iadrr(kdet)=iadrr(k)+mh(k)*
     *                                 (iadrt1-iadrt0+mt(k)*
     *                                 (iadrp1-iadrp0))
                                    else if(iadrr(k).lt.0) then
                                       if(kdet.le.iadri)
     *                                 iadrr(kdet)=iadrr(k)-mh(k)*
     *                                 (iadrt1-iadrt0+mt(k)*
     *                                 (iadrp1-iadrp0))
                                    else if(iadrr(k).eq.0) then
                                       iadrr(kdet)=0
                                    endif
                                    if(yw)print 1000,
     *                              '1kdet,k,iadrrv,mh,mt,iadrr',
     *                              kdet,k,iadrr(k),mh(k),mt(k)
     *                              ,iadrr(kdet),iadrt1,iadrp1
                                 enddo
                              endif
                           endif
                           if(io1.ne.io2.or.io3.ne.io4) then
                              if(yprem2) then
c
c                                premiere fois : appel gende4
c
                                 kdet2=kdet+1
                                 call gende4(iesp,
     *                           iesp(maxorbcas*maxdetc+1)
     *                           ,iadrr,io2,io1,io4,io3,
     *                           ispi1,ispi2,kdet,mh,mt)
                                 kdet3=kdet
                                 yprem2=.false.
                                 if(yw) then
                                    do k=kdet2,kdet3
                                       print 1000,
     *                                 '2k,mh,mt,iadrr',
     *                                 k,mh(k),mt(k)
     *                                 ,iadrr(k),iadrt1,iadrp1
                                    enddo
                                 endif
                              else
c
c                                autres fois, calcul rapide
c
                                 do k=kdet2,kdet3
                                    kdet=kdet+1
                                    if(iadrr(k).gt.0) then
                                       if(kdet.le.iadri)
     *                                 iadrr(kdet)=iadrr(k)+mh(k)*
     *                                 (iadrt1-iadrt0+mt(k)*
     *                                 (iadrp1-iadrp0))
                                    else if(iadrr(k).lt.0) then
                                       if(kdet.le.iadri)
     *                                 iadrr(kdet)=iadrr(k)-mh(k)*
     *                                 (iadrt1-iadrt0+mt(k)*
     *                                 (iadrp1-iadrp0))
                                    else if(iadrr(k).eq.0) then
                                       if(kdet.le.iadri)
     *                                 iadrr(kdet)=0
                                    endif
                                    if(yw)print 1000,
     *                              '2kdet,k,iadrrv,mh,mt,iadrr',
     *                              kdet,k,iadrr(k),mh(k),mt(k)
     *                              ,iadrr(kdet),iadrt1,iadrp1
                                 enddo
                              endif
                           endif
                        enddo
                     enddo
                  enddo
               enddo
 2             continue
 1             continue
            enddo
         enddo
      enddo
      mdet(inddet)=kdet
      close(42)
      write(77) mdec
      if(yw) then
         do k=1,kdet
            print*,'prede4 iadrr',k,iadrr(k)
         enddo
      endif
      call ecribl(iadrr,kdet,76)
 1000 format(a30,10i5)
      return
      end
 
