      subroutine categ
c------------------------------------------------------------------
c     Le nb de determinants par categorie ( definie par le CAS,les
c  trous et les particules (imposees=>pas en parametres pr icateg))
c  est stocke ds icateg(nelc,isc,ispc1,nt,ist,ispt1)
c  boucles sur nelc,isc,ispc1,nt,ist et ispt1 => particules imposees
c  nb de determinants = nb deter precedents +mp*mt*maxc(nelc,isc,ispc1)
c  mp = nb de determinants par categorie de particules(np,isp,ispp)
c  mp est calcule a partir de maxp donne par la subroutine maxdetp
c  mt = nb de determinants par categorie de trous(nt,ist,ispt)
c  mt est calcule a partir de maxt donne par la subroutine maxdett
c  maxc = nb de determinants par categorie du CAS(nelc,iscas,ispcas)
c  maxc a ete calcule par les subroutines maxdetcas et sub_mdc
c------------------------------------------------------------------
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      PARAMETER (maxorb=500,maxsym=8,MNEL=5,maxorbcas=16)
      parameter(maxdetc=12870)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/cas_spin/isz0
      common/sym/itsym(2*maxorb),its(maxsym,maxsym),nsym
      common /ctg/icateg(-2:2,maxsym,-2:2,41)
     *,niit(0:2,maxsym,-1:1)
      common/mxdetc/maxc(-2:2,maxsym,-2:2),
     *maxca(-2:2,maxsym,maxsym,-2:2)
      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 /co_max/ maxtt(2,maxsym,0:1),maxpp(0:2,maxsym,0:1)
      common/maxdettrou/maxt(2,maxsym,maxsym,0:1)
      common/maxdetpart/maxp(2,maxsym,maxsym,0:1)
      common/util/jsp(-2:2,-2:2),ksp(-4:4)
c      common/extrai/ iextr(-2:2)
      dimension iispc(5)
      yw1=.false.
      yw=.false.
      if(gener(1:2).eq.'MR') return
      ygcas=gener.eq.'CAS'.or.gener.eq.'MRC'
      ygmono=gener.eq.'MONO'.or.gener.eq.'MRM'.or.gener.eq.'MRTM'
      do k=-2,2
c         iextr(k)=-1
      enddo
c      write(6,*)'categ gener=',gener
      nv=0
      do is=1,nsym
         nv=nv+nps(is)
      enddo
      do isp=0,1
         do is=1,nsym
            maxpp(0,is,isp)=1
         enddo
      enddo
c     compression des donnees relatives aux trous
      do i=-1,1
         do j=1,nsym
            do k=0,2
               niit(k,j,i)=-10
            enddo
         enddo
      enddo
      niit(0,1,0)=1
      ii=2
      do ist=-1,1,2
         do is=1,nsym
            niit(1,is,ist)=ii
            ii=ii+1
         enddo
      enddo
      do ist=-1,1
         do is=1,nsym
            niit(2,is,ist)=ii
            ii=ii+1
         enddo
      enddo
      do 11 isp=0,1
      do 12 n=1,2
      do 13 is=1,nsym
      mt=0
      mp=0
      do is1=1,nsym
         mt=mt+maxt(n,is,is1,isp)
         mp=mp+maxp(n,is,is1,isp)
      enddo
      maxtt(n,is,isp)=mt
      if(yw)write(6,*)'n,is,isp,maxtt',n,is,isp,maxtt(n,is,isp)
      maxpp(n,is,isp)=mp
      if(yw)write(6,*)'n,is,isp,maxpp',n,is,isp,maxpp(n,is,isp)
 13   continue
 12   continue
 11   continue
      if(yw)then
         do k=1,2
            do l=1,nsym
               do m=-1,1
                  print*,'k,l,m,niit(k,l,m)',k,l,m,niit(k,l,m)
               enddo
            enddo
         enddo
      endif
      jfin=0
      do 1 nelc=-2,2
      call vispc(nelc,nispc,iispc,gener)
      do 3 ii=1,nispc
      do 2 isc=1,nsym
      ispc1=iispc(ii)
      mc=maxc(nelc,isc,ispc1)
      if(yw)write(6,*)'nelc,isc,ispc1,mc',nelc,isc,ispc1,mc
      if(mc.eq.0) goto 2
      ispcas=jsp(ispc1,nelc)
      if(yw)write(6,*)'ispc1,ispcas',ispc1,ispcas
      ntfin=min0(2,2+nelc)
      ntdeb=max0(0,nelc)
      if(nelc.eq.-2.and.nelac.eq.2.and.ispcas+nca0-ncb0.ne.0)
     *goto 2
      do 4 nt=ntdeb,ntfin
      np=nt-nelc
      if(np.lt.0) goto 4
      if(gener.eq.'PERT') then
         if(np.eq.2.and.nt.eq.2) then
            if(ispcas.ne.0) then
               goto 2
            endif
            if(isc.ne.is0) then
               goto 2
            endif
         endif
      endif
      if(gener.eq.'DDCI'.or.gener.eq.'DDci') then
         if(np.eq.2.and.nt.eq.2) goto 2
      else if(gener.eq.'DDC2') then
         if(np+nt.gt.2) goto 2
      else if(ygmono) then
         if(np.gt.1.or.nt.gt.1) goto 2
      else if(ygcas) then
         if(np.gt.0.or.nt.gt.0) goto 2
      endif
      do 5 ist=1,nsym
      jpas=1+mod(nt,2)
      do 6 ispt1=-1,1,jpas
      ispt=ispt1*nt
      ispt2=iabs(ispt1)
      if(nt.eq.0)then
         if(ispt1.ne.0) goto 6
         mt=1
      else
         mt=maxtt(nt,ist,ispt2)
      endif
      isp=its(is0,its(ist,isc))
      ispp=ispt-ispcas
      if(ispp.lt.-2.or.ispp.gt.2) goto 6
      if(np.eq.0)then
         if(ispp.ne.0) goto 6
         if(isp.ne.1) goto 6
         mp=1
         ispp1=0
         ispp2=0
      else
         ispp1=ispp/np
         ispp2=iabs(ispp1)
         mp=maxpp(np,isp,ispp2)
      endif
      icateg(nelc,isc,ispc1,niit(nt,ist,ispt1))=jfin
c      if(iextr(k).eq.-1)iextr(k)=jfin
      if(yw1) then
         write(75,*)'nelc,isc,ispc1',
     *   nelc,isc,ispc1,maxc(nelc,isc,ispc1)
     *   ,'nt,ist,ispt1',nt,ist,ispt1
     *   ,' icateg()',jfin,'$'
         call scril
c         write(6,*)'mt,mp,maxc',mt,mp,maxc(nelc,isc,ispc1)
      endif
      jfin=jfin+mp*mt*maxc(nelc,isc,ispc1)
      if(ntfin.eq.0)goto 4
 6    continue
      if(nt.eq.0)goto 4
 5    continue
 4    continue
c     if(nelc.eq.-2.and.nelac.eq.2)goto 1
 2    continue
 3    continue
 1    continue
c     write(6,*)'categ fin ncf2=',ncf2
      return
      end
       subroutine vispc(nelc,nispc,iispc,gener)
       IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
c
c--------------------------------------------------------------
c     nispc : nombre de valeurs que peut prendre le spin du CAS
c--------------------------------------------------------------
c
      character*4 gener
      dimension iispc(5)
      ygcas=gener.eq.'CAS'.or.gener.eq.'MRC'
      ygmono=gener.eq.'MONO'.or.gener.eq.'MRM'.or.gener.eq.'MRTM'
      if(ygcas) then
         nispc=1
         iispc(1)=0
         return
      endif
      if(nelc.eq.0) then
         if(gener.eq.'PERT'.or.gener.eq.'DDci'.or.gener.eq.'DDCI'.or.
     *   gener.eq.'DDC2'.or.gener.eq.'MR'.or.
     *   gener.eq.'MRD2'.or.gener.eq.'MRDD'
     *   .or.gener.eq.'MRT2'.or.gener.eq.'MRTD'
     *   .or.ygmono) then
            nispc=3
            iispc(2)=0
            iispc(1)=-1
            iispc(3)=1
         else if (gener.eq.'TOUS'.or.gener.eq.'MRS'
     *   .or.gener.eq.'MRT') then
            nispc=5
            iispc(3)=0
            iispc(1)=-2
            iispc(2)=-1
            iispc(4)=1
            iispc(5)=2
         endif
      else if(iabs(nelc).eq.1) then
         if(gener.eq.'PERT'.or.gener.eq.'DDci'.or.gener.eq.'MR') then
            nispc=2
            iispc(1)=-1
            iispc(2)=1
         else if (gener.eq.'TOUS'.or.gener.eq.'DDCI'.or.gener.eq.'DDC2'
     *      .or.ygmono.or.gener.eq.'MRS'.or.
     *      gener.eq.'MRD2'.or.gener.eq.'MRDD'
     *      .or.gener.eq.'MRT2'.or.gener.eq.'MRTD'
     *      .or.gener.eq.'MRT') then
            nispc=4
            iispc(1)=-2
            iispc(2)=-1
            iispc(3)=1
            iispc(4)=2
         endif
      else if(iabs(nelc).eq.2) then
         nispc=3
         iispc(1)=-1
         iispc(2)=0
         iispc(3)=1
      endif
      return
      end
