      subroutine mr1s
c     Jose
      implicit real*8(a-h,o-x,z),logical*1 (y)
      parameter(maxorb=1024,nsymz=8)
      parameter(maxorbcas=16)
      parameter(maxref=15000)
      parameter(nz21=maxorb*2+1)
      character*8 gener
      common/gene/gener,ygcas,ygmono,ygmr
      common/occ/noac,nelac,numac(maxorbcas),is0,ninac,nvirt
     *,numt(maxorb),nump(maxorb),ntac,nutac(maxorbcas),ms2
      common/mr/nmr,nel,yref(-maxorb:maxorb,maxref)
c     character*1 cref(-maxorb:maxorb,maxref),cy(-maxorb:maxorb)
c      character*(nz21) cref(maxref),cy
c      equivalence (cref(1),yref(-maxorb,1))
c      equivalence (cy,y(-maxorb))
      common/f4/norb,noc,noca,nocb,nca0,ncb0,ydet,ydetv,ydetcl
     *,ydetsc,yf_act,ywcas,ynosym,ytp0
      dimension it(2),ip(2),ic(maxorbcas*2)
c      dimension y(-maxorb:maxorb)
      dimension iref(maxorb)
      dimension iocc(maxorb),iocc0(maxorb)
      common/ocref/ iocref(maxorb,maxref),nref
      dimension icouv(maxorbcas)
      dimension nsa(maxorbcas+4)
      character*80 a
      common/ref2/refmr1,refmr,prefix
      character*80 prefix,refmr
      character*80 refmr1
      common/sym/nsym,its(nsymz,nsymz),itsym(maxorb)
      character*1280 namel
      character*80 file
      common/selm/iselm
      namelist/mr/it,ip,ic,v
      yw=.false.
      file=' '
c
c--   preparatifs
      nbmauvis=0
      nela=ninac+(nelac+ms2)/2
      nelb=ninac+(nelac-ms2)/2
      nel=nela+nelb
c      do i=1,norb
c         y(i)=.false.
c      enddo
c
c---------------------------------------------------------------
c     lecture des determinants de reference
c---------------------------------------------------------------
c
      write(6,*)' '
      if(gener(1:3).ne.'SEL') goto 10
      write(6,*)'-------calcul SEL--------'
c==================================================
c     on duplique le fichier d'entree sur la file 1
c==================================================
c      open(1,form='formatted',status='UNKNOWN',file='TEMPMR')
      print*,'nref',nref
      if(iselm.eq.0) then
         nref=0
 1       continue
         read(94,1000,end=2,err=2) a
 1000    format(a80)
         write(1,1000) a
         if(a(2:4).eq.'&mr'.or.a(2:4).eq.'&MR') then
            write(6,'(a80)')a(1:80)
            nref=nref+1
         endif
         goto 1
      else
         rewind 1
         nref=0
 31      continue
         read(1,1000,end=2,err=2) a
         print*,'a',a
         nref=nref+1
         goto 31
      endif
 2    continue
      print*,'nref',nref
c==================================================
c     on lit les determinants 1 a 1
c==================================================
      rewind 1
      call LECNAM('&MR',namel,1,ierr,0)
      if(ierr.eq.1) then
         print*,'pas de determinant en donnee'
         stop
      endif
c      do k=1,1000
c         read(1,'(a80)') a
c         print*, a
c      enddo
      call namela(namel,file,'FILE')
      if(file.ne.' ') then
         ifil=28
         open(28,file=file,status='old')
         print*,'les determinants de reference sont lus sur :'
         print*, file
         print*,' '
      else
         ifil=1
         rewind 1
      endif
      if(ifil.eq.28) then
         nref=0
 11      continue
         read(28,1000,end=22) a
         if(a(2:4).eq.'&mr'.or.a(2:4).eq.'&MR') then
            if(nref.le.100)write(6,'(a80)')a(1:80)
            if(nref.eq.100)write(6,'(a15)') ' ...........'
            nref=nref+1
         endif
         goto 11
 22      continue
      endif
      print*,' '
      print*,'nombre de references en donnee',nref
c==========================================
c--   on changera les actives : mise a zero
c==========================================
      rewind ifil
      do k=1,norb
         iref(k)=0
      enddo
      nmr1=0
c==========================================
c     boucle sur la lecture des references
c==========================================
      do 3 nmr=1,nref
      do k=1,noca
         iocc(k)=2
      enddo
      do k=1,noac
         iocc(numac(k))=0
      enddo
      do k=1+noca,norb
         iocc(k)=0
      enddo
      if(yw)print*,'iocc',(iocc(k),k=1,norb)
 
      nt=0
      nc=0
      np=0
      do k=1,2
         it(k)=0
         ip(k)=0
      enddo
      do k=1,noac*2
         ic(k)=0
      enddo
c     read(1,mr,end=4)
c     namelist/mr/it,ip,ic,v
      call LECNAM('&MR',namel,ifil,ierr,0)
      if(ierr.eq.1) goto 4
      call nameli(namel,it,'IT',4)
      call nameli(namel,IP,'IP',4)
      call nameli(namel,IC,'IC',4)
      if(yw)write(6,mr)
c==========================================
c     la reference lue est-elle correcte ?
c==========================================
      if(yf_act.and.(it(1).ne.0.or.ip(1).ne.0)) then
         print*,'yf_act=.true. : on ne peut donner it ou ip'
         stop
      endif
      do k=1,2
         if(it(k).eq.0) goto 5
         if(it(k).lt.0) it(k)=-it(k)
         if(it(k).gt.noc) call errdet(nmr,'MAUVAIS TROU',it(k))
         nt=k
         if(iocc(it(k)).eq.0) stop ' EPV det t'
         iocc(it(k))=iocc(it(k))-1
      enddo
 5    continue
      do k=1,2
         if(ip(k).eq.0) goto 6
         if(ip(k).lt.0) ip(k)=-ip(k)
         if(ip(k).lt.noc.or.ip(k).gt.norb)
     *   call errdet(nmr,'MAUVAISE PART',ip(k))
         np=k
         if(iocc(ip(k)).eq.2) stop ' EPV det p'
         iocc(ip(k))=iocc(ip(k))+1
      enddo
 6    continue
      kk=0
      do k=1,noac*2
         if(ic(k).eq.0) exit
         if(ic(k).lt.0) ic(k)=-ic(k)
         if(ic(k).gt.norb) call errdet(nmr,'MAUVAISE ACTIVE',ic(k))
         if(all(ic(k)/=numac)) call errdet(nmr,'MAUVAISE ACTIVE',ic(k))
         nc=k
         kk=kk+1
         if(iocc(ic(k)).eq.2) stop ' EPV det c'
         iocc(ic(k))=iocc(ic(k))+1
      enddo
      nc=kk
      if(ninac+ninac+np-nt+nc.ne.nel) then
         write(6,*)'mauvais nombre d''electrons pour le determinant',
     &   nmr
         write(6,'(a30,5i5)')'ninac,nel,nt,np,nc',ninac,nel,nt,np,nc
         stop
      endif
      is=1
      do k=1,nt
         is=its(is,itsym(it(k)))
      enddo
      do k=1,np
         is=its(is,itsym(ip(k)))
      enddo
      do k=1,nc
         is=its(is,itsym(iabs(ic(k))))
      enddo
c      print*,'is',is,is0,'it,ip',it,ip,'ic',(ic(k),k=1,nc)
      if(is.ne.is0.and.nbmauvis.le.10) then
         if(nbmauvis.eq.0)
     *   write(6,*)'================================================='
         write(6,*)'Attention : mauvaise symetrie pour le determinant'
     *   ,nmr,is
         nbmauvis=nbmauvis+1
c         stop
      endif
      if(is.ne.is0.and.nbmauvis.eq.11) then
         print*,'autres avertissements suivent'
         write(6,*)'================================================='
         nbmauvis=nbmauvis+1
      endif
      if(yw)write(75,*)nmr,'. ref ',(iocc(k),k=1,norb),'$'
      if(yw) call scril
      if(yw)print*,'noca,nocb',noca,nocb
c=====================================================================
c     OK, la reference est correcte
c     si c'est la 1ere lue, on la stocke dans iocc0
c     dans la suite, iref represente les orbitales actives
c     une orbitale est active si elle a une occupation 1 dans une ref,
c     ou des occupations differentes dans diverses references
c=====================================================================
      do k=1,norb
         if(k.le.noc.and.iocc(k).ne.2) iref(k)=1
         if(k.gt.noc.and.iocc(k).ne.0) iref(k)=1
      enddo
      do k=1,norb
         if(nmr.gt.1) then
            if(iocc(k).ne.iocc0(k)) iref(k)=1
         else
            iocc0(k)=iocc(k)
         endif
      enddo
      if(yw)print'('' actives'',10i4)', (iref(k),k=1,norb)
c==========================================================
c--   on verifie si le determinant n'a pas ete deja donne
c      nmr1 est l'indice des ref gardees
c==========================================================
      do i=1,nmr1
         do j=1,norb
            if(iocc(j).ne.iocref(j,i)) goto 9
         enddo
         goto 3
 9       continue
      enddo
      nmr1=nmr1+1
      do k=1,norb
         iocref(k,nmr1)=iocc(k)
      enddo
 3    continue
 4    continue
c=======================================
c     fin de la lecture des references
c=======================================
      close(28)
      nref=nmr1
      print*,'nombre de references gardees  ',nref
c     Jose
      if(yw)then
         print*,'references'
         write(6,'(''        '',40i3)')(k,k=1,norb)
         do nmr=1,nref
            write(6,'('' iocref '',40i3)') (iocref(k,nmr),k=1,norb)
         enddo
      endif
c    Jose
c========================
c--   nouvelles actives
c========================
      if(yf_act) goto 10
      noac=0
      nelac1=0
c     write(6,*)'nela,nelb',nela,nelb
      do k=1,norb
         if(iref(k).eq.1) then
            noac=noac+1
            if(k.le.noc) nelac1=nelac1+2
            if(noac.gt.maxorbcas) then
               write(6,*)'trop de nouvelles actives'
               stop
            endif
            numac(noac)=k
         endif
      enddo
      if(mod(nelac,2).eq.1) nelac1=nelac1-1
      nelac=nelac1
      write(6,*)' '
      write(6,*)'nouvelles orbitales actives'
      write(6,'(10i4)')(numac(k),k=1,noac)
 10   write(6,*)' '
c========================
      nelaca=(nelac+ms2)/2
      nelacb=(nelac-ms2)/2
      ninac=nela-nelaca
      nvirt=norb-noac-ninac
      print*,'nombre d''orbitales              ',norb
      print*,'nombre d''orbitales actives      ',noac
      print'(a,16i4)',' orbitales actives                       '
     *,numac(1:noac)
      print*,'nombre d''electrons alpha        ',nela
      print*,'nombre d''electrons beta         ',nelb
      print*,'nombre d''electrons actifs       ',nelac
      print*,'nombre d''inactives              ',ninac
      print*,'nombre de virtuelles            ',nvirt
      print*,'ms2                             ',ms2
      print*,'Dans un Determinant de Reference :'
      print*,' nombre d''electrons actifs alpha',nelaca
      print*,' nombre d''electrons actifs beta ',nelacb
      print*,'gener                           ',gener
      write(6,*)' '
c     Jose
c     Generation des differents determinants par rapport le spin donne
      nmr2=0
      do jref=1,nref
         ncouv=0
c        nombre de couches ouvertes dans la reference jref
         do io=1,norb
            if(iocref(io,jref).eq.1) then
               ncouv=ncouv+1
               icouv(ncouv)=io
            endif
         enddo
c        nombre des spins alfa dans les couches ouvertes
         ia=(ncouv+ms2)/2
         if(ia.lt.0) then
            print*,'********   Reference',jref,'   **************'
            print*,'impossible de satisfaire ms2=',ms2
            print*,'***********************************************'
            stop
         endif
c        appel de combin pour generer les possibilites pour le spin alfa
         na=0
         call combi0(nsa,ncouv,ia,iret)
         goto 100
 20      call combi2(nsa,ncouv,ia,iret)
 100     continue
         if(yw)print*,'nsa',(nsa(k),k=1,ia)
         na=na+1
c        combin donne tous les det de ia alfa parmi les ncouv
c        orbitales couche ouverte
c        il faut le fair un pour un
c        on traduit les determinants en numero
c        d'occupation pour des determinants avec
c        les spins alfa et beta
         nmr2=nmr2+1
         do k=1,norb
            if(iocref(k,jref).eq.2) then
               yref(k,nmr2)=.true.
               yref(-k,nmr2)=.true.
            else
               if(iocref(k,jref).eq.0) then
                  yref(k,nmr2)=.false.
                  yref(-k,nmr2)=.false.
               else
                  if(iocref(k,jref).eq.1) then
                     do l=1,ncouv
                        yref(icouv(l),nmr2)=.false.
                        yref(-icouv(l),nmr2)=.true.
                     enddo
                     do l=1,ia
                        yref(icouv(nsa(l)),nmr2)=.true.
                        yref(-icouv(nsa(l)),nmr2)=.false.
                     enddo
                  endif
               endif
            endif
         enddo
         if(iret.eq.0) goto 20
      enddo
      nmr=nmr2
      nref=nmr2
      do jref=1,nref
         do k=1,noac
            iocref(numac(k),jref)=0
            if(yref(numac(k),jref)) iocref(numac(k),jref)=
     *      iocref(numac(k),jref)+1
            if(yref(-numac(k),jref)) iocref(numac(k),jref)=
     *      iocref(numac(k),jref)+1
         enddo
      enddo
c     Jose
      if(yw)then
         do j=1,nmr
            print*,'references'
            write(99,'(''     '',40i3)')(k,k=1,norb),(k,k=1,norb)
            write(99,'('' yref '',40l3)') (yref(k,j),k=-1,-norb,-1),
     *      (yref(k,j),k=1,norb)
         enddo
      endif
c     Jose
c
c--   ecriture sur file de OCCMRS
c
      open(27,form='formatted',file='OCCMRS',status='unknown')
      write(27,*) nref
      do k=1,nref
         write(27,'(80i1)')(iocref(numac(i),k),i=1,noac)
      enddo
      close(27)
c
c     on redefinit les occupations des references par rapport au CAS
c     seulement
c
      do imr=1,nmr
         do k=1,noac
            iocref(k,imr)=iocref(numac(k),imr)
         enddo
      enddo
 
      return
      end
       subroutine mr2s(nca,ncb,ica,icb,mint,minp,maxt,maxp)
      implicit real*8(a-h,o-x,z),logical*1 (y)
      parameter(maxorb=1024,nsymz=8)
      parameter(maxorbcas=16)
      parameter(maxref=15000)
      character*8 gener
      common/gene/gener,ygcas,ygmono,ygmr
      common/ocref/ iocref(maxorb,maxref),nref
      common/occ/noac,nelac,numac(maxorbcas),is0,ninac,nvirt
     *,numt(maxorb),nump(maxorb),ntac,nutac(maxorbcas),ms2
      common/mr/nmr,nel,yref(-maxorb:maxorb,maxref)
      common/f4/norb,noc,noca,nocb,nca0,ncb0,ydet,ydetv,ydetcl
     *,ydetsc,yf_act,ywcas,ynosym,ytp0
      dimension ica(maxorbcas),icb(maxorbcas),iocc(maxorb)
      yw=.false.
c
c--------------------------------------------------------------------
c     calcul de la distance maximale de ica/icb a tous les det de ref
c--------------------------------------------------------------------
c
c
c     occupation du CAS
c
c      print*,'ica',(ica(k),k=1,nca)
c      print*,'icb',(icb(k),k=1,ncb)
      do k=1,norb
         iocc(k)=0
      enddo
      do k=1,nca
         iocc(ica(k))=1
      enddo
      do k=1,ncb
         iocc(icb(k))=iocc(icb(k))+1
      enddo
      do k=1,noac
         iocc(k)=iocc(numac(k))
      enddo
c
c     distance aux determinants de reference
c
      idif=5
      if(gener(1:3).ne.'SEL') goto 20
      do kk=1,nref
         ii=0
         if(yw)print*,'iocc   ',(iocc(i),i=1,noac)
         if(yw)print*,'iocref ',(iocref(i,kk),i=1,noac)
         do i=1,noac
            ii=ii+abs(iocc(i)-iocref(i,kk))
            if(ii.gt.4) goto 10
         enddo
         if(yw)print*,'idif',idif
 10      continue
         idif=min(idif,ii)
         if(idif.eq.0) goto 20
      enddo
 20   continue
      if(yw)print*,'idif a la fin ',idif
c
c        nombre d'electrons en plus
c
      nn=0
      do i=1,noac
         nn=nn+iocc(i)
      enddo
      nn=nn-nelac
      if(yw)print*,'nn',nn
      if(gener(1:3).ne.'SEL') then
         idif=iabs(nn)
      endif
c
c        trous et part max
c
      call tpmms(nn,idif,mint,maxt,minp,maxp)
c
      if(yw)write(6,'(a33,6i5)')'mint,minp,maxt,maxp',
     *mint,minp,maxt,maxp
      if(yw)write(6,*)'nca,ncb',nca,ncb
      return
      end
 
       subroutine tpmms(nn,idif,mint,maxt,minp,maxp)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter (maxorbcas=16)
      common/f4/norb,noc,noca,nocb,nca0,ncb0,ydet,ydetv,ydetcl
     *,ydetsc,yf_act,ywcas,ynosym,ytp0
      character*8 gener
      common/gene/gener,ygcas,ygmono,ygmr
      yw=.false.
      mint=2
      maxt=0
      if(nn.eq.0) then
         if(idif.eq.0) then
            mint=0
            maxt=2
         else if(idif.eq.2) then
            mint=0
            maxt=1
         else if(idif.eq.4) then
            mint=0
            maxt=0
         endif
      else if(nn.eq.1) then
         if(idif.eq.1) then
            mint=1
            maxt=2
         else if(idif.eq.3) then
            mint=1
            maxt=1
         endif
      else if(nn.eq.2) then
         if(idif.eq.2) then
            mint=2
            maxt=2
         endif
      else if(nn.eq.-1) then
         if(idif.eq.1) then
            mint=0
            maxt=1
         else if(idif.eq.3) then
            mint=0
            maxt=0
         endif
      else if(nn.eq.-2) then
         if(idif.eq.2) then
            mint=0
            maxt=0
         endif
      endif
      if(ygcas) then
         if(mint.ne.0.or.minp.ne.0.or.nn.ne.0.or.idif.ne.0) then
            mint=2
            maxt=0
         else
            mint=0
            maxt=0
            minp=0
            maxp=0
         endif
      endif
      if(ygmono) then
         mint=2
         maxt=0
         if(nn.eq.0) then
            if(idif.eq.0) then
               mint=0
               maxt=1
            else if(idif.eq.2) then
               mint=0
               maxt=0
            endif
         else if(nn.eq.1) then
            if(idif.eq.1) then
               mint=1
               maxt=1
            endif
         else if(nn.eq.-1) then
            if(idif.eq.1) then
               mint=0
               maxt=0
            endif
         endif
      endif
      minp=mint-nn
      maxp=maxt-nn
      if(gener(5:8).eq.'DDCI') then
         if(maxt+maxp.gt.3) then
            maxt=maxt-1
            maxp=maxp-1
         endif
      endif
      if(gener(5:8).eq.'DDC2') then
         if(maxt+maxp.gt.2) then
            maxt=maxt-1
            maxp=maxp-1
         endif
      endif
      if(yw)then
         write(75,*)'dans tpmms nn,idif,mint,maxt,minp,maxp'
     *   ,nn,idif,mint,maxt,minp,maxp,'$'
         call scril
      endif
      return
      end
       subroutine errdet(nmr,mess,i)
      character*(*) mess
      print*,' '
      print *,'!!!!!!!!!',mess
      print*,'!!!!!!!!!','determinant numero',nmr
      print*,'!!!!!!!!!','mauvaise valeur : ',i
      stop
      end
