      subroutine prepad
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
c
c-------------------------------------------------------------
c     on effectue divers calculs preliminaires
c-------------------------------------------------------------
c
      PARAMETER (maxorb=500,maxsym=8,maxorbcas=16,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/pr/nprint,mprint(10)
      common/mxdetc/maxc(-2:2,maxsym,-2:2)
     *,maxca(-2:2,maxsym,maxsym,-2:2)
      common/maxdettrou/maxt(2,maxsym,maxsym,0:1)
      common/maxdetpart/maxp(2,maxsym,maxsym,0:1)
      common/sym/itsym(2*maxorb),its(maxsym,maxsym),nsym
      common/sy2/nts(maxsym),ncs(maxsym),nps(maxsym)
     *,norbs(maxsym)
      character*4 gener
      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
      common /prep2/ icatt(2,maxsym,maxsym,-1:1),
     *icatp(2,maxsym,maxsym,-1:1)
     *,itorb(maxorb*2),icatc(maxsym,maxsym,0:maxorbcas,0:maxorbcas)
      common /adrsym/irangs(maxdetc,0:maxorbcas)
     *,maxs(maxsym,0:maxorbcas)
      common/util/jsp(-2:2,-2:2),ksp(-4:4)
      common/opt/ihab,calcul
      character*3 calcul
      common/cas_spin/isz0
      dimension idetc(maxorbcas,maxdetc)
      dimension jrangs(maxsym)
      dimension icamc(maxorb)
      yw=.false.
      if(yw) then
         write(6,*)' '
         write(6,*)'----preparation-------'
         write(6,*)'prepad nsym,ms2 ',nsym,ms2
      write(6,*)'===========symetrie du probleme(is0)==========',is0
c========nombre d'electrons alpha et beta dans le CAS======
c      write(6,*)'nelac,isz0,nelac/2',nelac,isz0,nelac/2
      write(6,*)'nb d''electrons alpha et beta dans le CAS de depart'
      write(6,*)'nca0',nca0
      write(6,*)'ncb0',ncb0
      write(6,*)'prepad : spin du CAS de depart'
      write(6,*)'isz0',isz0
      endif
      isz0=nca0-ncb0
c========
c========reference=======
      do i=1,noca0
         yoc(i)=.true.
         yoc(i+norb)=.true.
      enddo
      do i=noca0+1,norb
         yoc(i)=.false.
         yoc(i+norb)=.false.
      enddo
      if(yw) then
         write(6,*)'reference : occupation'
         write(6,'('' alpha  '',120l1)')(yoc(k),k=1,norb)
         write(6,'(''  beta  '',120l1)')(yoc(k+norb),k=1,norb)
      endif
c========
c========reference CAS=======
      if(yw)write(6,*)'reference : CAS'
      nelacr=(nelac+1)/2
      do i=1,nelacr
         ic0(i)=numac(i)
      enddo
      if(yw)write(6,'('' ic0'',10i4)')(ic0(k),k=1,(nelac+1)/2)
      do i=1,nelacr
         yrefc(i)=.true.
      enddo
      do i=nelacr+1,noac
         yrefc(i)=.false.
      enddo
c========
c========orbitales actives=========
      do i=1,norb
         yac(i)=.false.
      enddo
      do i=1,noac
         yac(numac(i))=.true.
      enddo
      if(yw)write(6,'('' yac  '',120l1)')(yac(k),k=1,norb)
c========
c========inverse de numac
      do i=1,norb+norb
         icamun(i)=0
      enddo
      do i=1,noac
         icamun(numac(i))=i
         icamun(numac(i)+norb)=i+noac
      enddo
      if(yw)write(6,'(a18,120i4)')
     *' inverse de numac',(icamun(k),k=1,norb+norb)
      write(6,*)'-----------------------------------------------------'
c========= TROUS ===================================
c==== itorb : itorb(O)=numero de l'orbitale O ds sa symetrie
c===== nts : nb de trous par symetrie
c===== numt : numero des orbitales des trous (orb. occ. !=CAS)
      i=1
      j=1
c trous => couches fermees => noca=nocb et nb d'orb. occ=noca+nocb
      do k=1,nsym
         nts(k)=0
         nps(k)=0
         ncs(k)=0
      enddo
      do k=1,noca0
         if(numac(i).eq.k) then
            i=i+1
         else
            numt(j)=k
            j=j+1
            nts(itsym(k))=nts(itsym(k))+1
            itorb(k)=nts(itsym(k))
            itorb(k+norb)=nts(itsym(k))
         endif
      enddo
      nbtrous=j-1
      if(yw) then
         write(6,'(a19,120i4)')' nts : nb trous/sym',(nts(k),k=1,nsym)
         write(6,*)' numt : no des orb. des trous',(numt(k),k=1,nbtrous)
         write(6,*)' -------------------------'
      endif
      do i=1,noac
         ncs(itsym(numac(i)))=ncs(itsym(numac(i)))+1
         itorb(numac(i))=ncs(itsym(numac(i)))
         itorb(numac(i)+norb)=ncs(itsym(numac(i)))
      enddo
      if(yw)write
     *(6,'(a19,20i4)')' ncs : nb orb/sym ds CAS  ',(ncs(k),k=1,nsym)
c========= PARTICULES ===================================
c==== itorb : itorb(O)=numero de l'orbitale O ds sa symetrie
c===== nps : nb de part par symetrie
c===== nump : numero des orbitales des particules (orb. virt. !=CAS)
      j=1
c particules => couches ouvertes => orb. non occ a partir de noca+1
      do 10 k=noca0+1,norb
      do i=1,noac
         if(numac(i).eq.k) goto 10
      enddo
      nump(j)=k
      j=j+1
      nps(itsym(k))=nps(itsym(k))+1
      itorb(k)=nps(itsym(k))
      itorb(k+norb)=nps(itsym(k))
 10   continue
      j=j-1
      nbpart=j
c     write(6,*)'nps : nb part/sym',(nps(k),k=1,maxsym)
      if(yw)write(6,'(a27,10(20i4,/))')
     *' nump  : no des orb. des part',(nump(k),k=1,j)
c     write(6,*)'-------------------------'
c     write(6,*)'sym',(itsym(k),k=1,norb)
      if(nprint.ge.2)
     *write(6,'(a6,10(20i4,/))')' itorb ',(itorb(k),k=1,norb+norb)
c-------------------------------------------------------------------
c     Calcul du nb d'orbitales virtuelles
c-------------------------------------------------------------------
      nv=0
      do is=1,nsym
         nv=nv+nps(is)
      enddo
c-------------------------------------------------------------------
      if(gener(1:2).eq.'MR') then
         if(yw)print*,'avant prepads ninac,ms2',ninac,ms2
         call prepads
         return
      endif
c------------- fonction de Handy
c----cree la matrice z qlq soit le nb d'electrons alpha(ou beta)du CAS
      do ial=1,noac
         call rang0(noac,ial)
      enddo
c-------------------------------------------------------------------
      call maxdetca
      call maxdett
      call maxdetp
c-------------------------------------------------------------------
c===== icatp : pour le calcul des adresses des determinants
c===== icatt : pour le calcul des adresses des determinants
c===== icatt(nt,ist,is1,ispt1)=nb de combinaisons possibles de
c===== is1 dans 1 categorie definie par nt,ist,ispt(1)
c= nb d'elect | spin des trous|indice pr icatt| ind. pr maxt
c=  nt=0      | ispt=0        |  ispt1=0      |  ispt2=0
c=  nt=1      | ispt=1        |  ispt1=1      |  ispt2=1
c=  nt=1      | ispt=-1       |  ispt1=-1     |  ispt2=1
c=  nt=2      | ispt=2        |  ispt1=1      |  ispt2=1
c=  nt=2      | ispt=0        |  ispt1=0      |  ispt2=0
c=  nt=2      | ispt=-2       |  ispt1=-1     |  ispt2=1
c==== is1 = symetrie du 1er trou
      do 1 nt=1,2
      ipas=1+mod(nt,2)
      do 2 ispt1=-1,1,ipas
      ispt=ispt1*nt
      ispt2=iabs(ispt1)
      do 3 ist=1,nsym
c===une categorie est definie par nt,ist,ispt(1) mais pas par is1
      jfint=0
      jfinp=0
      do 4 is1=1,nsym
      icatt(nt,ist,is1,ispt1)=jfint
      jfint=jfint+maxt(nt,ist,is1,ispt2)
      icatp(nt,ist,is1,ispt1)=jfinp
      jfinp=jfinp+maxp(nt,ist,is1,ispt2)
      if(yw)write(6,*)
     *'icatp(nt,ist,is1,ispt1),nt,ist,is1,ispt1',
     *icatp(nt,ist,is1,ispt1),nt,ist,is1,ispt1
      if(yw)write(6,*)
     *'icatt(nt,ist,is1,ispt1),nt,ist,is1,ispt1',
     *icatt(nt,ist,is1,ispt1),nt,ist,is1,ispt1
 4    continue
 3    continue
 2    continue
 1    continue
c===== icatc : pour le calcul des adresses des determinants
c===== icatc(isc,nca,ncb)=nb de determinants par sym suivant le
c===== nb d'electrons alpha et beta du CAS
c= nb d'elect alpha | symetrie     |  nb d'elect beta
c=  nca=nca0-2      |              |  ncb=ncb0-2
c=  nca=nca0-1      | isc=1,nsym   |  ncb=ncb0-1
c=  nca=nca0        |              |  ncb=ncb0
c=  nca=nca0+1      |              |  ncb=ncb0+1
c=  nca=nca0+2      |              |  ncb=ncb0+2
c     jfin=0
      kca=2
      if(gener.eq.'DDCI'.or.gener.eq.'DDC2') kca=3
      if(gener.eq.'TOUS') kca=4
      do 11 isc=1,nsym
      do 22 nelc=-2,2
      do 33 nca=nca0-kca,nca0+kca
      if(yw)write(6,*)'isc,nelc,nca',isc,nelc,nca
      jfin=0
      if(nca.lt.0.or.nca.gt.noac)goto 33
      ncb=nelc-nca+nca0+ncb0
      if(yw)write(6,*)'ncb',ncb
      if(ncb.lt.0.or.ncb.gt.noac)goto 33
      ispcas=nca-ncb-isz0
      if(yw)write(6,*)'ispcas',ispcas,isc,nelc,nca,ncb
      if(iabs(ispcas).gt.kca) goto 33
      ispc1=ksp(ispcas)
c               if(ispcas.eq.0)then
c                 ispc1=0
c               else
c                 ispc1=ispcas/iabs(ispcas)
c               endif
      do isa=1,nsym
         icatc(isc,isa,nca,ncb)=jfin
         jfin=jfin+maxca(nelc,isc,isa,ispc1)
         if(yw)write(6,*)
     *   'icatc,isc,isa,nca,ncb',icatc(isc,isa,nca,ncb)
     *   ,isc,isa,nca,ncb
c                 write(6,*)'jfin',jfin
      enddo
 33   continue
 22   continue
 11   continue
c============ Prepararation de l'adressage du CAS
c   irangs(adresse du det.,nb d'electron alpha (resp beta))
c   maxs(sym. CAS,nb elect alpha)=nb de det. par sym pr chaque categ.
      do isc=1,nsym
         maxs(isc,0)=1
      enddo
      do ial=0,ncb0+2
         if(ial.gt.noac)goto 100
         do isc=1,nsym
            jrangs(isc)=0
         enddo
         call combin(idetc,noac,ial,nc,maxorbcas,maxdetc)
c        write(6,*)'ial,combin ok',ial
c        idetc=tableau des det., nc=nb de det., ial=nb d'elect. alpha
         do k=1,nc
c           write(6,*)'idetc(k)',(idetc(kk,k),kk=1,ial)
            isc=1
            icamc(1)=0
            do l=1,ial
               icamc(l)=numac(idetc(l,k))
c              write(6,*)'idetc',idetc(l,k)
c              write(6,*)'icamc',icamc(l)
               isc=its(isc,itsym(icamc(l)))
c              write(6,*)'isc',isc
            enddo
            call rang2(ial,idetc(1,k),irang)
c            write(6,*)'isc',isc
            jrangs(isc)=jrangs(isc)+1
c            write(6,*)'isc',isc
            irangs(irang,ial)=jrangs(isc)
            if(yw)write(6,*)'isc=',isc,'  irang=',irang,'  ial=',ial,
     *      '  irangs(irang,ial)=',jrangs(isc)
            maxs(isc,ial)=jrangs(isc)
         enddo
c        write(6,*)'nc(nb det alpha),ial',nc,ial
c        write(6,*)'maxs(isc,ial)',(maxs(isc,ial),isc=1,nsym)
      enddo
 100  continue
      call categ
      call f_int
      return
      end
       subroutine cd01p
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
c
c-------------------------------------------------------------
c     on effectue divers calculs preliminaires
c-------------------------------------------------------------
c
      PARAMETER (maxorb=500,maxsym=8,maxorbcas=16)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/cdp/iadrp0(0:maxorb+maxorb,0:maxorb+maxorb)
      common/orb2/numina(maxorb),numvir(maxorb),iordo(maxorb*2)
     *,iodro(maxorb*2)
     *,numinb(maxorb),numvib(maxorb)
      dimension ip(2)
      yw=.false.
c--   0 particule
      call adrp(0,ip,0,iadrp0(0,0))
c--   1 particule
c     write(6,*)'nvirt',nvirt
      do i=1,nvirt
         j=numvir(i)
         call adrp(1,numvir(i),1,iadrp0(j,0))
         iadrp0(0,j)=iadrp0(j,0)
         call adrp(1,numvir(i),-1,iadrp0(j+norb,0))
         iadrp0(0,j+norb)=iadrp0(j+norb,0)
      enddo
c--   2 particules
      do i=1,nvirt
         do j=i,nvirt
            k=numvir(i)
            l=numvir(j)
            ip(1)=numvir(i)
            ip(2)=numvir(j)
            if(i.ne.j) then
c--            alpha-alpha
               call adrp(2,ip,2,iadrp0(k,l))
               iadrp0(l,k)=iadrp0(k,l)
c--            beta-beta
               call adrp(2,ip,-2,iadrp0(k+norb,l+norb))
               iadrp0(l+norb,k+norb)=iadrp0(k+norb,l+norb)
            endif
c--         alpha-beta
            call adrp(2,ip,0,iadrp0(k,l+norb))
            iadrp0(l+norb,k)=iadrp0(k,l+norb)
c--         beta-alpha
            k=numvir(j)
            l=numvir(i)
            ip(1)=numvir(j)
            ip(2)=numvir(i)+norb
            call adrp(2,ip,0,iadrp0(l+norb,k))
            iadrp0(k,l+norb)=iadrp0(l+norb,k)
         enddo
      enddo
      if(yw) then
         write(6,*)'iadrp0'
         call scripi(iadrp0,norb+norb+1,norb+norb+1,
     *   maxorb+maxorb+1,maxorb+maxorb+1)
         do i=0,norb+norb+1
            write(6,*)(iadrp0(i,j),j=0,norb+norb+1)
         enddo
      endif
      return
      end
       subroutine genc
      implicit real*8(a-h,o-x,z),logical*1 (y)
      parameter(maxorb=500,maxsym=8)
      parameter(maxorbcas=16,maxdetc=12870)
      parameter(maxref=1000,idicmr=35000)
      common/mr3/ maxcmr(-2:2,maxsym,-2:2),mixtpmr(idicmr)
     *,ndetc,ndetc0,iadrc_mr(idicmr)
      common/mxdetc/maxc(-2:2,maxsym,-2:2),
     *maxca(-2:2,maxsym,maxsym,-2:2)
      common/sym/itsym(2*maxorb),its(maxsym,maxsym),nsym
      dimension ica(maxorbcas),icb(maxorbcas)
      dimension nsa(maxorbcas,maxdetc)
      dimension nsb(maxorbcas,maxdetc)
      common/util/jsp(-2:2,-2:2),ksp(-4:4)
      dimension melc(5)
      dimension iispc(5)
      common/ref2/refmr1,refmr,prefix
      character*10 prefix,refmr
      character*40 refmr1
      common/mr/nmr,yref(-maxorb:maxorb,maxref)
      character*4 gener
      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
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      data melc /0,1,-1,2,-2/
c--------------------------------------------------------------
c     generation 1 a 1 des determinants du CAS
c     calcul du nb max de T et P correspondants
c--------------------------------------------------------------
      yw=.false.
      yw1=.false.
      ndetc=0
c
c--   lecture des references
      call nomfil(28,refmr,refmr1,prefix,'OLD       ','UNFORMATTED')
      read(28)nmr,((yref(k,l),k=-norb,norb),l=1,nmr)
      close(28)
c
cc--   calcul de maxcmr (=maxc cumules)
      if(gener.eq.'MR') then
         mxcmr=0
         do k=-2,2
            do is=1,nsym
               do l=-2,2
                  maxcmr(l,is,k)=mxcmr
                  mxcmr=mxcmr+maxc(l,is,k)
c               print*,'dans genc maxc(l,is,k),mxcmr', maxc(l,is,k),mxcm
               enddo
            enddo
         enddo
      endif
c
c           -----------------------------------
c             GENERATION DU CAS
c           ----------------------------------
c
c
c--   boucle sur le nombre d'electrons du CAS
c
      do 1 kelc=1,5
      if(yw)write(6,*)'kelc',kelc
      nelc=melc(kelc)
      call vispc(nelc,nispc,iispc,'PERT')
      nelcas=nelac+nelc
      if(yw)write(6,*)'nelc,nelcas',nelc,nelcas
      if(yw)write(6,*)'nispc',nispc
c
c--   boucle sur le spin du CAS
c
      do 3 ii=1,nispc
      ispc1=iispc(ii)
      ispc=jsp(ispc1,nelc)
      ispcas=ms2+ispc
      if(yw)write(6,*)'ms2,ispc,ispcas',ms2,ispc,ispcas
      if(iabs(ispcas).gt.nelcas) goto 3
      nca=(nelcas+ispcas)/2
      ncb=(nelcas-ispcas)/2
      if(yw)write(6,*)'nelc,nelcas,ispcas,nca,ncb',
     *nelc,nelcas,ispcas,nca,ncb
      if(nca.gt.noac.or.ncb.gt.noac) goto 3
c
c--   generation des occupation alpha et beta
c
      call combin(nsa,noac,nca,na,maxorbcas,maxdetc)
      call combin(nsb,noac,ncb,nb,maxorbcas,maxdetc)
      if(yw)write(6,*)'na,nb',na,nb
c
c--   boucle sur les strings alpha
c
      do 10 ia=1,na
      isca=1
      do k=1,nca
         if(yw)
     *   write(6,*)'ia,nsa(k,ia)',ia,(nsa(kk,ia),kk=1,nca)
         ica(k)=numac(nsa(k,ia))
         isca=its(isca,itsym(ica(k)))
      enddo
c
c--   boucle sur les strings beta
c
      do 11 ib=1,nb
      iscb=1
      do k=1,ncb
         if(yw)
     *   write(6,*)'ib,nsb(k,ib)',ib,(nsb(kk,ib),kk=1,ncb)
         icb(k)=numac(nsb(k,ib))
         iscb=its(iscb,itsym(icb(k)))
      enddo
      isc=its(isca,iscb)
c               if(yw)
c     *         write(6,*)'isc,ispcas,ispc,ispc1',isc,ispcas,ispc,ispc1
c
c--   adresse du det (non MR)
c
      call adrc(0,nca,ica,ncb,icb,iadrcas)
c              write(6,*)'MAXCA',nelc,isc,ispc1,ispc,
c     *         maxc(nelc,isc,ispc1)
      iadr=iadrcas+maxcmr(nelc,isc,ispc1)
      if(yw) then
         write(75,*)'dans genc nelc,isc,ispc1,maxcmr,iadrcas,iadr'
     *   ,nelc,isc,ispc1,maxcmr(nelc,isc,ispc1),iadrcas,iadr,'$'
         call scril
      endif
      call verdim('dans genc  augmenter idicmr : iadr idicmr'
     *,iadr,idicmr)
      ndetc=ndetc+1
c
c--   appel mr2 : calcul des trous et part max
c
      call mr2(nca,ncb,ica,icb,mint,minp,maxt,maxp,mdif)
      if(yw1)print*,'mdif',mdif
c      if(mdif.le.4) then
      ndetc0=ndetc0+1
c
c--      iadrc_mr : adresse du determinant de CAS
c
      iadrc_mr(iadr)=ndetc0
      mixtpmr(ndetc0)=mint+minp*3+maxt*9+maxp*27
      if(yw1) then
         write(6,'('' genc deter adresse,det '',i4,3x,20i3)')
     *   ndetc0,(ica(k),k=1,nca),(-icb(k),k=1,ncb)
         write(6,*)'CAS',' iadr  ',iadr,mixtpmr(ndetc0)
         write(6,*)'mint,minp',mint,minp
         write(6,*)'maxt,maxp',maxt,maxp
         write(6,*)'IADRCAS',iadrcas,iadr
         write(6,*)'dans genc iadr,iadrc_mr(iadr)',
     *   iadr,iadrc_mr(iadr)
      endif
c      endif
 11   continue
 10   continue
 3    continue
 1    continue
      if(yw1) then
         do k=1,ndetc
            call callim(mixtpmr(k),maxt,maxp,mint,minp)
            write(6,'('' k, mint,minp,maxt,maxp'',20i3)')
     *      k,mint,minp,maxt,maxp
         enddo
      endif
      write(6,*)'sortie de genci ndetc,ndetc0',ndetc,ndetc0
      return
      end
       subroutine callim(mixtpmr,maxt,maxp,mint,minp)
c
c-----------------------------------------------------------
c     decodage de mixtpmr pour trouver les valeurs limites
c     des T et P
c-----------------------------------------------------------
c
      maxp=mixtpmr/27
      maxt=(mixtpmr-maxp*27)/9
      minp=(mixtpmr-maxp*27-maxt*9)/3
      mint=mod(mixtpmr,3)
      return
      end
       subroutine mr2(nca,ncb,ica,icb,mint,minp,maxt,maxp,mdif)
      implicit real*8(a-h,o-x,z),logical*1 (y)
      parameter(maxorb=500,maxsym=8)
      parameter(maxorbcas=16)
      parameter(maxref=1000)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension ica(maxorbcas),icb(maxorbcas)
      common/mr/nmr,yref(-maxorb:maxorb,maxref)
      dimension y(-maxorb:maxorb)
      common/mxdetc/maxc(-2:2,maxsym,-2:2),
     *maxca(-2:2,maxsym,maxsym,-2:2)
      common/sym/itsym(2*maxorb),its(maxsym,maxsym),nsym
      common/util/jsp(-2:2,-2:2),ksp(-4:4)
      character*4 gener
      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
      yw=.false.
c
c--------------------------------------------------------------------
c     calcul de la distance maximale de ica/icb a tous les det de ref
c--------------------------------------------------------------------
c
      do k=-norb,norb
         y(k)=.false.
      enddo
      do k=1,nca
         y(ica(k))=.true.
      enddo
      do k=1,ncb
         y(-icb(k))=.true.
      enddo
      mdif=6
      do imr=1,nmr
         if(yw)   write(6,*)'yref',(yref(k,imr),k=-norb,norb)
         if(yw)   write(6,*)'y   ',(y(k),k=-norb,norb)
         idif=0
         do k=1,noac
            nmk=numac(k)
            if(yw)write(6,*)'nmk',nmk
            if(yref(nmk,imr).and..not.y(nmk)) idif=idif+1
            if(.not.yref(nmk,imr).and.y(nmk)) idif=idif+1
            if(yw)write(6,*)'idif',idif
            nmk=-numac(k)
            if(yw)write(6,*)'nmk',nmk
            if(yref(nmk,imr).and..not.y(nmk)) idif=idif+1
            if(.not.yref(nmk,imr).and.y(nmk)) idif=idif+1
            if(yw)write(6,*)'idif',idif
         enddo
         mdif=min0(mdif,idif)
      enddo
c
c--   nombre max de trous et part
c     on calcule l'exces d'electrons dans le CAS
c      nn=nca+ncb-nel+ninac+ninac-nelac
      nn=nca+ncb-nelac
      if(yw)
     *print*,'nca,ncb,ninac,nelac,nn',nca,ncb,ninac,nelac,nn
      if(mdif.eq.0) then
         maxt=2
         maxp=2
         mint=0
         minp=0
      else if(mdif.eq.1) then
         if(nn.eq.1) then
            maxt=2
            maxp=1
            mint=1
            minp=0
         else
            maxt=1
            maxp=2
            mint=0
            minp=1
         endif
      else if(mdif.eq.2) then
         if(nn.eq.0) then
            maxt=1
            maxp=1
            if(nca.eq.nca0) then
               mint=0
               minp=0
            else
               mint=1
               minp=1
            endif
         else     if(nn.eq.2) then
            maxt=2
            maxp=0
            mint=2
            minp=0
         else     if(nn.eq.-2) then
            maxt=0
            maxp=2
            mint=0
            minp=2
         endif
      else if(mdif.eq.3) then
         if(nn.eq.1) then
            maxt=1
            maxp=0
            mint=1
            minp=0
         else
            maxt=0
            maxp=1
            mint=0
            minp=1
         endif
      else if(mdif.eq.4) then
         maxt=0
         maxp=0
         mint=0
         minp=0
      else if(mdif.gt.4) then
         maxt=-1
         maxp=-1
      endif
c      maxp=min0(2,(4+nel-mdif-ninac-ninac-nca-ncb)/2)
c      maxt=min0(2,4-mdif-maxp)
      if(yw)write(6,*)'mdif,nn,maxp,maxt',mdif,nn,maxp,maxt
      if(yw)write(6,*)'nca,ncb',nca,ncb
      return
      end
       subroutine mr2v(nca,ncb,ica,icb,maxtmr,maxpmr)
      implicit real*8(a-h,o-x,z),logical*1 (y)
      parameter(maxorb=500,maxsym=8)
      parameter(maxorbcas=16)
      parameter(maxref=1000)
c      common/occ/noac,nelac,numac(maxorbcas),is0,ninac,nvirt
c     *,numt(norbz),nump(norbz),ntac,nutac(maxorbcas),ms2
c     common/mr/nmr,nel,yref(-norbz:norbz,maxref)
c      common/f4/norb,noca,nocb
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      dimension ica(maxorbcas),icb(maxorbcas)
      common/mr/nmr,yref(-maxorb:maxorb,maxref)
      dimension y(-maxorb:maxorb)
      common/mxdetc/maxc(-2:2,maxsym,-2:2),
     *maxca(-2:2,maxsym,maxsym,-2:2)
      common/sym/itsym(2*maxorb),its(maxsym,maxsym),nsym
      common/util/jsp(-2:2,-2:2),ksp(-4:4)
      yw=.false.
c
c--------------------------------------------------------------------
c     calcul de la distance maximale de ica/icb a tous les det de ref
c--------------------------------------------------------------------
c
      nel=ninac
      do k=-norb,norb
         y(k)=.false.
      enddo
      do k=1,nca
         y(ica(k))=.true.
      enddo
      do k=1,ncb
         y(-icb(k))=.true.
      enddo
      mdif=6
      do imr=1,nmr
         if(yw)   write(6,*)'yref',(yref(k,imr),k=-norb,norb)
         if(yw)   write(6,*)'y   ',(y(k),k=-norb,norb)
         idif=0
         do k=1,noac
            nmk=numac(k)
            if(yw)write(6,*)'nmk',nmk
            if(yref(nmk,imr).and..not.y(nmk)) idif=idif+1
            if(.not.yref(nmk,imr).and.y(nmk)) idif=idif+1
            if(yw)write(6,*)'idif',idif
            nmk=-numac(k)
            if(yw)write(6,*)'nmk',nmk
            if(yref(nmk,imr).and..not.y(nmk)) idif=idif+1
            if(.not.yref(nmk,imr).and.y(nmk)) idif=idif+1
            if(yw)write(6,*)'idif',idif
         enddo
         mdif=min0(mdif,idif)
      enddo
c
c--   nombre max de trous et part
      maxpmr=min0(2,(4+nelac-mdif-nca-ncb)/2)
      maxtmr=min0(2,4-mdif-maxpmr)
      if(yw)write(6,*)'mdif',mdif,maxpmr,maxtmr
      return
      end
