      subroutine genmr2
      implicit real*8(a-h,o-x,z),logical*1 (y)
      parameter(maxorb=1024,nsymz=8)
      parameter(maxorbcas=16,maxdetc=12870)
      parameter (maxref=15000)
      common/occ/noac,nelac,numac(maxorbcas),is0,ninac,nvirt
     *,numt(maxorb),nump(maxorb),ntac,nutac(maxorbcas),ms2
      common/f4/norb,noc,noca,nocb,nca0,ncb0,ydet,ydetv,ydetcl
     *,ydetsc,yf_act,ywcas,ynosym,ytp0
      common/det/msto,nsto,mstov,nstov,idet(2400),nex(100),
     *long(maxorbcas+2),imono,ndet,msto256,
     *ncfmin,ncfmax
      common/util/jsp(-2:2,-2:2),ksp(-4:4)
      common/mr/nmr,nel,yref(-maxorb:maxorb,maxref)
      common/sym/nsym,its(nsymz,nsymz),itsym(maxorb)
      dimension nsa(maxorbcas,maxdetc)
      dimension nsb(maxorbcas,maxdetc)
      dimension ica(maxorbcas),icb(maxorbcas),
     *ita(2),itb(2),ipa(2),ipb(2)
      dimension it(20),ip(20),melc(5)
      dimension jt(20),jp(20)
      dimension iispc(5)
      character*8 gener
      common/gene/gener,ygcas,ygmono,ygmr
      common/print/nprint
      dimension nmf(maxorbcas),nmo(maxorbcas)
      dimension jlibreo(maxorbcas)
      dimension ns1(maxorbcas+4)
      dimension iocca(maxorbcas,1024),iocca0(maxorbcas)
      dimension ys1(maxorbcas+4)
      dimension itp1((maxorb+2)*(maxorb+1)/2)
      dimension itp2((maxorb+2)*(maxorb+1)/2)
      dimension numat(0:2,nsymz,0:2),numat1(0:1+nsymz+1+
     *nsymz*(nsymz+1)/2)
      dimension numap(0:2,nsymz,0:2),numap1(0:1+nsymz+1+
     *nsymz*(nsymz+1)/2)
      data melc /0,1,-1,2,-2/
      yw=.false.
      ndet=0
      ndetc=0
      if(ywcas)open(29,file='ESCASOU0',status='unknown')
c
c           -----------------------------------
c             GENERATION DU CAS
c           ----------------------------------
c
c     ncfmina,ncfmaxa min et max du nombre de CF a ajouter
      open(40,file='CDT_CAS',form='unformatted',status='unknown')
      nnn=0
      ncas=0
      iplus=2
      if(ygcas) iplus=0
      if(ygmono) iplus=1
      imoins=iplus
      if(ninac.eq.0) iplus=0
      if(nvirt.eq.0) imoins=0
      ncfmaxa=min(noac,(nelac+iplus)/2)
      ncfmaxa=min(ncfmax,ncfmaxa)
      ncfmina=max(0,nelac-imoins-noac)
      ncfmina=max(ncfmin,ncfmina)
c
c     boucles sur le nombre de CF et CO rajoutees au CAS
c
      do 10 ncfc=ncfmina,ncfmaxa
      ncomaxa=min(noac-ncfc,nelac+iplus-ncfc*2)
      if(yw)print*,'nelcas,ncfc',nelcas,ncfc
      ncomina=max(0,nelac-imoins-ncfc*2)
      if(yw)print*,'ncfc,ncomina,ncomaxa',ncfc,ncomina,ncomaxa
      do 11 ncouva=ncomina,ncomaxa
      if(yw)print*,'ncfc,ncouva',ncfc,ncouva
c     on repartit les couches fermees
      call combi0(nmf,noac,ncfc,iretf)
      goto 300
 25   call combi2(nmf,noac,ncfc,iretf)
 300  continue
      if(yw)print*,'nmf',(nmf(k),k=1,noac)
      do l=1,noac
         iocca0(l)=0
      enddo
      do l=1,ncfc
         iocca0(nmf(l))=2
      enddo
c     on repartit les couches ouvertes
      mlibreo=0
      do l=1,noac
         if(iocca0(l).ne.2) then
            mlibreo=mlibreo+1
            jlibreo(mlibreo)=l
         endif
      enddo
      call combi0(nmo,mlibreo,ncouva,ireto)
      goto 400
 26   call combi2(nmo,mlibreo,ncouva,ireto)
 400  continue
      nnn=nnn+1
      ncas=ncas+1
      if(nnn.gt.1024) then
         nnn=1
         if(yw)print*,'ecriture 40'
         write(40)((iocca(k,l),k=1,noac),l=1,1024)
      endif
      do l=1,noac
         iocca(l,nnn)=iocca0(l)
      enddo
      do l=1,ncouva
         iocca(jlibreo(nmo(l)),nnn)=1
      enddo
      if(yw) then
         write(75,*)'1iocca',(iocca(k,nnn),k=1,noac),'$'
         call scril
      endif
      if(ireto.eq.0) goto 26
      if(iretf.eq.0) goto 25
 11   continue
 10   continue
      if(yw)print*,'Ecriture 40'
      write(40)((iocca(k,l),k=1,noac),l=1,1024)
c
c              -----------------------------------
c                GENERATION DES TROUS
c              ----------------------------------
c
      call gtp(nsym,ninac,itsym,numt,itp1,itp2,
     *numat,numat1,its)
      if(yw)print*,'numat',numat(0,1,0)
c
c              -----------------------------------
c                GENERATION DES PARTICULES
c              ----------------------------------
c
      nnnn=(ninac+1)*(ninac+2)/2
      call gtp(nsym,nvirt,itsym,nump,itp1(nnnn+1)
     *,itp2(nnnn+1),numap,numap1,its)
c
c              -----------------------------------
c                GENERATION DES DETERMINANTS
c              ----------------------------------
c
      rewind 40
      if(yw)print*,'ncas',ncas
      ll=1024
      do l=1,ncas
         ll=ll+1
         if(ll.gt.1024) then
            ll=1
            read(40)((iocca(k,kk),k=1,noac),kk=1,1024)
         endif
         mint=0
         minp=0
         maxt=2
         maxp=2
         isolc=0
         do k=1,noac
            if(iocca(k,ll).eq.1) isolc=isolc+1
         enddo
         call mr2sbis(iocca(1,ll),mint,minp,maxt,maxp)
         if(yw)print*,'iocca',(iocca(k,ll),k=1,noac)
         if(yw)print*,'mint,minp',mint,minp
         if(yw)print*,'maxt,maxp',maxt,maxp
         isc=1
         do k=1,noac
            if(iocca(k,ll).eq.1) isc=its(isc,itsym(numac(k)))
         enddo
         if(yw)print*,'isc',isc
         do nt=mint,maxt
            np=nt+minp-mint
            if(yw)print*,'nt,np',nt,np
            call calisol(nt,isolt1,isolt2)
            call calisol(np,isolp1,isolp2)
            if(yw)print*,'isolt1,isolt2',isolt1,isolt2
            if(yw)print*,'isolp1,isolp2',isolp1,isolp2
            do isolt=isolt1,isolt2,2
               call calsym(isolt,ist2,nsym)
               do isolp=isolp1,isolp2,2
                  if(isolt+isolp+isolc.lt.-ms2) goto 14
                  call calsym(isolp,isp2,nsym)
                  if(yw)print*,'ist2,isp2',ist2,isp2
                  do ist=1,ist2
                     isp=its(isc,its(ist,is0))
                     if(yw)print*,
     *               'isolt,isolp,ist,isp',isolt,isolp,ist,isp
                     if(isp.ne.1.and.isolp.eq.0) goto 3
                     idebt=numat(nt,ist,isolt)
                     if(yw)print*,'nt,ist,isolt',nt,ist,isolt
                     if(yw)print*,'np,isp,isolp',np,isp,isolp
                     call flush(6)
                     idebp=numap(np,isp,isolp)
                     idebt1=numat1(idebt-1)
                     idebp1=numap1(idebp-1)
                     ifint1=numat1(idebt)-1
                     ifinp1=numap1(idebp)-1
                     if(yw)print*,
     *               'idebt,idebp,idebt1,idebp1,ifint1,ifinp1',
     *               idebt,idebp,idebt1,idebp1,ifint1,ifinp1
                     do kp=idebp1,ifinp1
                        do kt=idebt1,ifint1
                           if(yw) then
                              write(75,*)'TROU',itp1(kt),itp2(kt),' CAS'
     *                        ,(iocca(k,ll),k=1,noac),
     *                        ' PART',itp1(nnnn+kp),itp2(nnnn+kp),'$'
                              call scril
                           endif
                           call gsp(nt,np,itp1(kt),itp2(kt),
     *                     itp1(nnnn+kp),itp2(nnnn+kp),isolt,isolp,isolc
     *                     ,iocca(1,ll),ndet,ndetc)
                        enddo
                     enddo
 3                   continue
                  enddo
 14               continue
               enddo
            enddo
         enddo
      enddo
      read(40,end=2)((iocca(k,l),k=1,noac),l=1,1024)
 2    continue
      print*,' '
      write(6,*)'****************************************************'
      write(6,*)'***********      fin de casdet2   ******************'
      write(6,*)' nombre de determinants generes             ',ndet
      write(6,*)' parmi ces determinants :                   '
      write(6,*)' nombre de determinants appartenant au CAS  ',ndetc
      if(gener(1:3).eq.'SEL')
     *write(6,*)' nombre de determinants MR                  ',nmr
      write(6,*)'****************************************************'
      return
      end
       subroutine gsp(nt,np,it1,it2,
     *ip1,ip2,ncoo,ncov,ncouva,iocca,ndet,ndetc)
c
c                          ---------------------------
c                            GENERATION DES SPINS
c                          ---------------------------
c
      parameter(maxorb=1024,nsymz=8)
      parameter(maxorbcas=16,maxdetc=12870)
      implicit real*8(a-h,o-x,z),logical*1 (y)
      common/occ/noac,nelac,numac(maxorbcas),is0,ninac,nvirt
     *,numt(maxorb),nump(maxorb),ntac,nutac(maxorbcas),ms2
      dimension ns1(maxorbcas+4)
      dimension iocca(maxorbcas)
      dimension ys1(maxorbcas+4)
      dimension ica(maxorbcas),icb(maxorbcas),
     *ita(2),itb(2),ipa(2),ipb(2)
      dimension jt(2),jp(2)
      dimension it(20),ip(20)
      common/print/nprint
      yw=.false.
      if(nt.eq.1) then
         jt(1)=it2
      else if (nt.eq.2) then
         jt(1)=it1
         jt(2)=it2
      endif
      if(np.eq.1) then
         jp(1)=ip2
      else if (np.eq.2) then
         jp(1)=ip1
         jp(2)=ip2
      endif
c     nombre total de couches ouvertes
      nco=ncoo+ncouva+ncov
      if(yw)print*,'nco,ncoo,ncov,ncouva',nco,ncoo,ncov,ncouva
      nela=(nco+ms2)/2
      nelb=(nco-ms2)/2
      if(nela.lt.0) stop'nela=0'
      if(nelb.lt.0) stop'nelb=0'
      if(nt.eq.0) then
         nta=0
         ntb=0
      endif
      if(np.eq.0) then
         npa=0
         npb=0
      endif
      if(nt.eq.2.and.it1.eq.it2) then
         nta=1
         ntb=1
         ita(1)=it1
         itb(1)=it2
      endif
      if(np.eq.2.and.ip1.eq.ip2) then
         npa=1
         npb=1
         ipa(1)=ip1
         ipb(1)=ip2
      endif
      do k=1,nco
         ys1(k)=.false.
      enddo
      call combi0(ns1,nco,nela,iretsp)
      goto 500
 66   call combi2(ns1,nco,nela,iretsp)
 500  continue
      if(yw)print*,'ns1',(ns1(k),k=1,nela)
      do k=1,nela
         ys1(ns1(k))=.true.
      enddo
      if(ncoo.ne.0) then
         nta=0
         ntb=0
         do k=1,nt
            if(ys1(k)) then
               ntb=ntb+1
               itb(ntb)=jt(k)
            endif
         enddo
         do k=1,nt
            if(.not.ys1(k)) then
               nta=nta+1
               ita(nta)=jt(k)
            endif
         enddo
      endif
      if(yw)print*,'jp',(jp(k),k=1,np)
      if(ncov.ne.0) then
         npa=0
         npb=0
         do k=1,np
            if(ys1(nco+k-np)) then
               npa=npa+1
               ipa(npa)=jp(k)
            endif
         enddo
         do k=1,np
            if(.not.ys1(nco+k-np)) then
               npb=npb+1
               ipb(npb)=jp(k)
            endif
         enddo
      endif
      if(yw)print*,'nt,np,nta,ntb,npa,npb',nt,np,nta,ntb,npa,npb
      if(yw)print*,'ys1',(ys1(k),k=1,nco)
      nca=0
      ncb=0
      kk=ncoo
      do k=1,noac
         if(iocca(k).eq.1) then
            kk=kk+1
            if(ys1(kk)) then
               nca=nca+1
               ica(nca)=numac(k)
            else
               ncb=ncb+1
               icb(ncb)=numac(k)
            endif
         else if(iocca(k).eq.2) then
            nca=nca+1
            ica(nca)=numac(k)
            ncb=ncb+1
            icb(ncb)=numac(k)
         endif
      enddo
      ndet=ndet+1
      if(yw)print*,'ica',(ica(k),k=1,nca)
      if(yw)print*,'icb',(icb(k),k=1,ncb)
      if(nt.eq.0.and.np.eq.0) ndetc=ndetc+1
c       print*,'coucou0'
      if(yw.or.nprint.ge.3)
     *call wrdet(nca,ncb,ica,icb,nta,ntb,ita,
     *itb,npa,npb,ipa,ipb)
c      print*,'coucou1'
      call wrcas(nca,ncb,ica,icb,nta,ntb,ita,itb,npa,npb,ipa,ipb)
c       print*,'coucou2',nca,ncb
      call tradnv
     *(nca,ncb,ica,icb,nta,ntb,ita,
     *itb,npa,npb,ipa,ipb,it,ip)
c       print*,'coucou3'
      do k=1,nela
         ys1(ns1(k))=.false.
      enddo
      if(iretsp.eq.0) goto 66
      return
      end
      
      
      
      
      
      
      
       subroutine gtp(nsym,ninac,itsym,numt,itp1,itp2,
     *num,num1,its)
      parameter(maxorb=1024,nsymz=8)
      implicit real*8(a-h,o-x,z),logical*1 (y)
      dimension itsym(maxorb),numt(maxorb),its(nsymz,nsymz)
      dimension itp1((ninac+1)*(ninac+2)/2)
      dimension itp2((ninac+1)*(ninac+2)/2)
      dimension num(0:2,nsymz,0:2),num1(0:1+nsymz+1+
     *nsymz*(nsymz+1)/2)
      dimension ntstot(0:nsymz),npstot(0:nsymz)
      yw=.false.
c      print*,'entree gtp'
      nnn=0
      num1(0)=1
      ll=1
      do k=0,nsym
         ntstot(k)=0
      enddo
      do k=1,ninac
         ntstot(itsym(numt(k)))=ntstot(itsym(numt(k)))+1
      enddo
      do is=1,nsym
         ntstot(is)=ntstot(is)+ntstot(is-1)
      enddo
c     0 trou
      jj=1
      kk=1
      kkdeb=1
      num(0,1,0)=jj
      num1(jj)=kkdeb+1
      itp1(kk)=0
      itp2(kk)=0
c      print'(a,5i4)','itp',kk,itp1(kk),itp2(kk)
c      print'(a,5i4)','jj,num1(jj)',1,num1(1),0,1,0
c      print*,'num',num(0,1,0)
c     1 trou
      do is=1,nsym
         do jt=ntstot(is-1)+1,ntstot(is)
            kk=kk+1
            itp1(kk)=0
            itp2(kk)=numt(jt)
c            print'(a,5i4)','itp',kk,itp1(kk),itp2(kk)
         enddo
         jj=jj+1
         num(1,is,1)=jj
         kkdeb=kk+1
         num1(jj)=kkdeb
c         print'(a,5i4)','jj,num1(jj)',jj,num1(jj),1,is,1
      enddo
c     2 trous  0 CO
      
      do k=1,ninac
         kk=kk+1
         itp1(kk)=numt(k)
         itp2(kk)=numt(k)
c         print'(a,5i4)','itp',kk,itp1(kk),itp2(kk)
      enddo
      jj=jj+1
      num(2,1,0)=jj
      kkdeb=kk+1
      num1(jj)=kkdeb
c      print'(a,5i4)','jj,num1(jj)',jj,num1(jj),2,1,0
c     2 trous  2 CO meme sym
      do is1=1,nsym
         do jt1=ntstot(is1-1)+1,ntstot(is1)
            do jt2=ntstot(is1-1)+1,jt1-1
               kk=kk+1
               itp2(kk)=numt(jt1)
               itp1(kk)=numt(jt2)
c               print'(a,5i4)','itp',kk,itp1(kk),itp2(kk)
            enddo
         enddo
      enddo
      jj=jj+1
      num(2,1,2)=jj
      kkdeb=kk+1
      num1(jj)=kkdeb
c         print'(a,5i4)','jj,num1(jj)',jj,num1(jj),2,1,2
c     2 trous  2 CO sym differentes
c      print*,'num4',num(0,1,0)
      do is=2,nsym
         do is1=1,nsym
            is2=its(is,is1)
            if(is2.lt.is1) goto 1
            do jt2=ntstot(is2-1)+1,ntstot(is2)
               do jt1=ntstot(is1-1)+1,ntstot(is1)
                  kk=kk+1
                  itp1(kk)=numt(jt1)
                  itp2(kk)=numt(jt2)
c                  print'(a,5i4)','itp',kk,itp1(kk),itp2(kk)
c                  print*,'num5',num(0,1,0)
               enddo
            enddo
 1          continue
         enddo
         jj=jj+1
         num(2,is,2)=jj
         kkdeb=kk+1
         num1(jj)=kkdeb
c         print'(a,5i4)','jj,num1(jj)',jj,num1(jj),2,is,2
      enddo
      return
      end
       subroutine calisol(np,isolp1,isolp2)
      if(np.eq.0) then
         isolp1=0
         isolp2=0
      else if (np.eq.1) then
         isolp1=1
         isolp2=1
      else if (np.eq.2) then
         isolp1=0
         isolp2=2
      endif
      return
      end
       subroutine calsym(isol,ist2,nsym)
      if(isol.eq.0) then
         ist2=1
      else
         ist2=nsym
      endif
      return
      end
