      subroutine mrs1(iesp)
      use mod_ndimcs0
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
c
c----------------------------------------------------------
c                    PART DEL PROGRAMA MR-SDCI
c     Programa per a construir tots els determinants possibles
c     donats uns determinants de referencia.
c----------------------------------------------------------
c
      PARAMETER (maxsym=8)
      include 'maxorb.prm'
      parameter (maxorbcas=16)
      parameter(nrec1=1024)
      parameter(maxref=15000)
      parameter(nz21=maxorb*2+1)
      common/dim/iadri ; integer(8) iadri
      dimension iesp(iadri)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common/mrmr/nmr,nel
      common/f4/norb,noc,noca,nocb,nca0,ncb0,ydet,ydetcl
      dimension it(2),ip(2),ic(maxorbcas*2)
      dimension iocc(maxorbcas)
      dimension nmf(maxorbcas+4)
      dimension nmou(maxorbcas+4)
      dimension ic1(maxorbcas)
      common/ref2/refmr1,refmr,prefix
      character*80 prefix,refmr
      character*80 refmr1
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      dimension num(maxorbcas),icd(maxorbcas),nmou2(maxorbcas)
      common /adrcs/ ces(0:maxorbcas,0:maxorbcas),idimcs
      integer difref,ces
      common/test/itest(100)
      dimension iocref(maxorbcas,maxref)
      common /prep/ ndum,ndumb,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/pr/nprint,mprint(10)
      common/igen/ igener
      namelist/mr/it,ip,ic,v
      data num /1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/
      yw=nprint.ge.3
c
c     lecture des determinants de reference
c
      open(27,form='formatted',file='OCCMRS',status='old')
      read(27,*) nmr
      call verdim('parametre maxref pas assez grand. besoin/dispo',
     *nmr,maxref)
      do k=1,nmr
         read(27,'(80i1)')(iocref(i,k),i=1,noac)
      enddo
      close (27)
 
c
c     Creacio de tots el possibles determinants dins dels OM del CAS
c     creant un maxim de dos particules i dos forats.
c
c     Primer calcular el numero maxim de capes tancades que podrem tindr
c
      iplus=2
      if(ygmono) iplus=1
      if(ygcas) iplus=0
      if(yw)print*,'mrs1 gener,iplus  ',gener,iplus
      ncfmax=min(noac,(nelac+iplus)/2)
      ncfmin=max(0,nelac-iplus-noac)
c
c     Per a cada capa tancada calculem els determinants
c     que poden eixir tenint en conter el numero de orbitals actius.
c     Despres afegim el electrons capa oberta que hi hajen
c
c     Fem primer un bucle sobre el numero variable de capes tancades
c     que podem generar. Despres un bucle del electrons en capa oberta
c     que podem tindre depenint dels presos per fer les capes tancades i
c     tenint en conter que podem afegir i eliminar-ne dos mes
c
c
      ij=0
!      Dans certains cas, on va generer des det ou le nb de couches
!      ouvertes dans le CAS est trop petit pour etre augmente dans
!      les TP jusqu'a abs(ms2), qui est la valeur min pour le det.
      min_nb_co_in_det=abs(ms2)
      if(igener==1.or.igener==2) then 
         min_nb_co_in_cas=min_nb_co_in_det-2
      else
         min_nb_co_in_cas=min_nb_co_in_det-igener
      endif
! boucles sur le nb de couches ouvertes et fermees
      do k=ncfmin,ncfmax
         do ncouv=max(0,nelac-iplus-k*2),min(noac-k,nelac+iplus-k*2)
            if(yw) then
               print*,'===========nb de CF,ouv======',k,ncouv
               if(ncouv<min_nb_co_in_cas) print*,'nb de CF,ouv',k,ncouv,
     *         ' cycle'
            endif
            if(ncouv<min_nb_co_in_cas) cycle
c
c      Comenc,a a fer-se els possibles determinants dels electrons capa
c      tancada i oberta.Despres deguem de vore per a cada capa tancada
c      generada quins de capa oberta son possibles
c
            call combi0(nmf,noac,k,iretf)
            goto 300
 25         call combi2(nmf,noac,k,iretf)
 300        continue
            call comple(noac,num,k,nmf,ncd,icd)
c
c      Creem tots el determinants capa oberta ab els electrons solitaris
c      que tenim tenint en conter els electrons capa tancada ya possats
c
            do j=1,idimcs
               y1(j)=.false.
            enddo
c       if(ncouv.eq.0) goto 400
            call combi0(nmou2,noac-k,ncouv,iretou)
            goto 400
 26         call combi2(nmou2,noac-k,ncouv,iretou)
 400        continue
            do i=1,ncouv
               nmou(i)=icd(nmou2(i))
            enddo
            do l=1,noac
               iocc(l)=0
            enddo
            do l=1,k
               iocc(nmf(l))=2
            enddo
            do l=1,ncouv
               iocc(nmou(l))=1
            enddo
c
c        Ya tenim un determinant que te distribuit l'ocupacio de capa ta
c        2 il'ocupacio de capa oberta 1.Ara hem de buscar-li un adressag
c
            if(yw) then
               write(75,*)'===========iocc',(iocc(kk),kk=1,noac)
     *         ,'--','=========$'
               call scril
            endif
            call adrcass(iocc,iadrs,ncf,nc1,ic1)
            if(yw)print*,'Adresse iadrs',iadrs
            if(y1(iadrs)) then
               print*,'adressage cas deja vu', iocc
               stop
            endif
c
c        Una vegada tenim el determinant i l'adressage
c        fem la comparacio ab els determinants de referencia
c
            if(gener(1:3).eq.'MRT') goto 20
            difref=5
            do kk=1,nmr
               ii=0
               do i=1,noac
                  ii=ii+abs(iocc(i)-iocref(i,kk))
                  if(ii.gt.4) goto 10
               enddo
 10            continue
               difref=min(difref,ii)
               if(yw)print*,'iocc   ',(iocc(i),i=1,noac)
               if(yw)print*,'iocref ',(iocref(i,kk),i=1,noac)
               if(yw)print*,'difref',difref
               if(difref.eq.0) goto 20
            enddo
 20         continue
c
c        nombre d'electrons en plus
c
            nn=0
            do i=1,noac
               nn=nn+iocc(i)
            enddo
            nn=nn-nelac
            if(gener(1:3).eq.'MRT') difref=iabs(nn)
            if(yw)print*,'nn,difref',nn,difref
c
c        trous et part max
c
            call tpmms(nn,difref,iadrs,
     *      mint,maxt,minp,maxp,mixtpmrs)
            if(yw)print*,'mint,maxt',mint,maxt
            if(yw)print*,'minp,maxp',minp,maxp
            if(mint.gt.maxt) goto 27
            if(minp.gt.maxp) goto 27
 
c
c        calcul de nim(iadrs) : point de depart des determinants
c        generes par le determinant de CAS courant
c
            call calnim(iadttp,iocc,mint,maxt,minp,isc)
            nim(iadrs)=ij
            if(yw) print*,'iadrs,nim(iadrs),iadttp',iadrs,nim(iadrs),iad
     &      ttp
            ij=ij+iadttp
c
            y1(iadrs)=.true.
            if(yw)print*,'iretou',iretou
 27         continue
            if(iretou.eq.0) goto 26
            if(yw)print*,'iretf',iretf
            if(iretf.eq.0) goto 25
         enddo
      enddo
      return
      end
       subroutine calnim(iadttp,iocc,
     *mint,maxt,minp,isc)
      use mod_ndimcs0
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter (maxorbcas=16)
      PARAMETER (maxsym=8)
      include 'maxorb.prm'
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common /adrcs/ ces(0:maxorbcas,0:maxorbcas),idimcs
      common /combs/ C(0:maxorbcas+4,-1:maxorbcas+4)
      integer c,ces
      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)
      dimension iocc(maxorbcas)
      common/pr/nprint,mprint(10)
      icc(i)=i*(i-1)/2
      yw=nprint.ge.3
      iadttp=0
      isc=1
      nsolc=0
      do k=1,noac
         if(iocc(k).eq.1) then
            nsolc=nsolc+1
c            if(yw)print*,'k,iocc(k)',k,iocc(k)
c            if(yw)print*,'itsym',itsym(numac(k))
            isc=its(isc,itsym(numac(k)))
         endif
      enddo
      do nt=mint,maxt
         isp=its(isc,is0)
         np=minp-mint+nt
         if(yw)write(75,*)'calnim  nt,np,nsolc,isc,isp'
     *   ,nt,np,nsolc,isc,isp,'$'
         if(yw) call scril
         if(nt.eq.0) then
            if(np.eq.0) then
c---nt=0 np=0
               if(isc.eq.is0)iadttp=c(nsolc,(nsolc+ms2)/2)
               if(yw)print*,'calnim nt=0 np=0',iadttp
            else if (np.eq.1) then
c---nt=0 np=1
               iadttp=nps(isp)*c(nsolc+1,(nsolc+1+ms2)/2)
               if(yw)print*,'calnim nt=0 np=1',iadttp
            else
c---nt=0 np=2
c               if(yw)print*,'calnim nt=0 np=2'
               if(isp.eq.1) then
                  iadttp=iadttp+nvirt*c(nsolc,(nsolc+ms2)/2)
                  if(yw)print*,'1 calnim nt=0 np=2',iadttp
                  do is1=1,nsym
                     iadttp=iadttp+icc(nps(is1))
     *               *c(nsolc+2,(nsolc+2+ms2)/2)
                     if(yw)print*,'2 calnim nt=0 np=2',iadttp
                  enddo
               else
                  do is1=1,nsym
                     is2=its(is1,isp)
                     if(is1.gt.is2)iadttp=iadttp+nps(is1)*nps(is2)
     *               *c(nsolc+2,(nsolc+2+ms2)/2)
                     if(yw)print*,'3 calnim nt=0 np=2',iadttp
                     if(yw.and.is1.gt.is2)  then
                        print*,'is1,is2',is1,is2
                        print*,'c',c(nsolc+2,(nsolc+2+ms2)/2)
                        print*,'ms2',ms2
                        print*,'nps(is1),nps(is1)',nps(is1),nps(is2)
                     endif
                  enddo
               endif
            endif
         else if (nt.eq.1) then
c---nt=1 np=0
            if(np.eq.0) then
               ist=its(is0,isc)
               iadttp=nts(ist)
     *         *c(nsolc+1,(nsolc+1+ms2)/2)
               if(yw)print*,'calnim nt=1 np=0',iadttp
            else if (np.eq.1) then
c---nt=1 np=1
               do ist=1,nsym
                  isp=its(is0,its(isc,ist))
c                  if(isp.gt.ist)iadttp=iadttp+nts(ist)*nps(isp)
                  iadttp=iadttp+nts(ist)*nps(isp)
     *            *c(nsolc+2,(nsolc+2+ms2)/2)
                  if(yw)print*,'calnim nt=1 np=1',iadttp
               enddo
            else
c---nt=1 np=2
               do ist=1,nsym
                  isp=its(is0,its(isc,ist))
                  if(isp.eq.1) then
                     iadttp=iadttp+nvirt*nts(ist)
     *               *c(nsolc+1,(nsolc+1+ms2)/2)
                     if(yw)print*,'calnim 1 nt=1 np=2',iadttp,isp,isp
                     do is1=1,nsym
                        iadttp=iadttp+icc(nps(is1))*nts(ist)
     *                  *c(nsolc+3,(nsolc+3+ms2)/2)
                        if(yw)print*,'calnim 2 nt=1 np=2',iadttp
                     enddo
                  else
                     do is1=1,nsym
                        is2=its(is1,isp)
                        if(is2.gt.is1)
     *                  iadttp=iadttp+nps(is1)*nps(is2)*nts(ist)
     *                  *c(nsolc+3,(nsolc+3+ms2)/2)
                        if(yw)print*,'calnim 3 nt=1 np=2',iadttp
                     enddo
                  endif
               enddo
            endif
         else
c---nt=2 np=0
            if(np.eq.0) then
               ist=its(is0,isc)
               if(ist.eq.1) then
                  iadttp=iadttp+ninac
     *            *c(nsolc,(nsolc+ms2)/2)
                  if(yw)print*,'calnim nt=2 np=0',iadttp
                  do is1=1,nsym
                     iadttp=iadttp+icc(nts(is1))
     *               *c(nsolc+2,(nsolc+2+ms2)/2)
                     if(yw)print*,'calnim nt=2 np=0',iadttp
                  enddo
               else
                  do is1=1,nsym
                     is2=its(is1,ist)
                     if(is1.gt.is2)iadttp=iadttp+nts(is1)*nts(is2)
     *               *c(nsolc+2,(nsolc+2+ms2)/2)
                     if(yw)print*,'calnim nt=2 np=0',iadttp
                  enddo
               endif
            else if (np.eq.1) then
c---nt=2 np=1
               do isp=1,nsym
                  ist=its(is0,its(isc,isp))
                  if(ist.eq.1) then
                     iadttp=iadttp+ninac*nps(isp)
     *               *c(nsolc+1,(nsolc+1+ms2)/2)
                     if(yw)print*,'calnim nt=2 np=1',iadttp
                     do is1=1,nsym
                        iadttp=iadttp+icc(nts(is1))*nps(isp)
     *                  *c(nsolc+3,(nsolc+3+ms2)/2)
                        if(yw)print*,'calnim nt=2 np=1',iadttp
                     enddo
                  else
                     do is1=1,nsym
                        is2=its(is1,ist)
                        if(is2.gt.is1)
     *                  iadttp=iadttp+nts(is1)*nts(is2)*nps(isp)
     *                  *c(nsolc+3,(nsolc+3+ms2)/2)
                        if(yw)print*,'calnim nt=2 np=1',iadttp
                     enddo
                  endif
               enddo
            else
c---nt=2 np=2
               do ist=1,nsym
                  isp=its(is0,its(isc,ist))
                  if(ist.eq.1) then
                     if(isp.eq.1) then
                        iadttp=iadttp+ninac*nvirt
     *                  *c(nsolc,(nsolc+ms2)/2)
                        if(yw)print*,'1 calnim nt=2 np=2',iadttp
                        do is1=1,nsym
                           iadttp=iadttp+ninac*icc(nps(is1))
     *                     *c(nsolc+2,(nsolc+2+ms2)/2)
                           if(yw)print*,'2 calnim nt=2 np=2',iadttp
                        enddo
                        do is1=1,nsym
                           iadttp=iadttp+nvirt*icc(nts(is1))
     *                     *c(nsolc+2,(nsolc+2+ms2)/2)
                           if(yw)print*,'3 calnim nt=2 np=2',iadttp
                        enddo
                        do ist1=1,nsym
                           do isp1=1,nsym
                              iadttp=iadttp+
     *                        icc(nps(isp1))*icc(nts(ist1))
     *                        *c(nsolc+4,(nsolc+4+ms2)/2)
                              if(yw)print*,'4 calnim nt=2 np=2',iadttp
                           enddo
                        enddo
                     else
                        do is1=1,nsym
                           is2=its(is1,isp)
                           if(is1.gt.is2)
     *                     iadttp=iadttp+nps(is1)*nps(is2)*ninac
     *                     *c(nsolc+2,(nsolc+2+ms2)/2)
                           if(yw)print*,'5 calnim nt=2 np=2',iadttp
                        enddo
                        do is1=1,nsym
                           is2=its(is1,isp)
                           do is3=1,nsym
                              if(is1.gt.is2)
     *                        iadttp=iadttp+nps(is1)*nps(is2)
     *                        *icc(nts(is3))
     *                        *c(nsolc+4,(nsolc+4+ms2)/2)
                              if(yw)print*,'6 calnim nt=2 np=2',iadttp
                           enddo
                        enddo
                     endif
                  else
                     if(isp.eq.1) then
                        do is1=1,nsym
                           is2=its(is1,ist)
                           if(is1.gt.is2) iadttp=iadttp+nts(is1)
     *                     *nts(is2)*nvirt
     *                     *c(nsolc+2,(nsolc+2+ms2)/2)
                           if(yw)print*,'7 calnim nt=2 np=2',iadttp
                        enddo
                        do is1=1,nsym
                           is2=its(is1,ist)
                           do is3=1,nsym
                              if(is1.gt.is2)
     *                        iadttp=iadttp+nts(is1)*nts(is2)
     *                        *icc(nps(is3))
     *                        *c(nsolc+4,(nsolc+4+ms2)/2)
                              if(yw)print*,'8 calnim nt=2 np=2',iadttp
                           enddo
                        enddo
                     else
                        do is1=1,nsym
                           is2=its(is1,ist)
                           do is3=1,nsym
                              is4=its(is3,isp)
                              if(is1.gt.is2.and.is3.gt.is4)
     *                        iadttp=iadttp+nps(is3)*nps(is4)
     *                        *nts(is1)*nts(is2)
     *                        *c(nsolc+4,(nsolc+4+ms2)/2)
                              if(yw)print*,'9 calnim nt=2 np=2',iadttp
                           enddo
                        enddo
                     endif
                  endif
               enddo
            endif
         endif
 1       continue
      enddo
      if(yw) then
         write(75,*)'calnim iocc',(iocc(k),k=1,noac),
     *   ' . iadttp',iadttp,' nsolc',nsolc,'$'
         call scril
      endif
      return
      end
 
 
 
 
       subroutine tpmms(nn,difref,iadrs,
     *mint,maxt,minp,maxp,mixtpmrs)
      use mod_ndimcs0
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter (maxorbcas=16)
      include 'maxorb.prm'
      integer difref,ces
      common /adrcs/ ces(0:maxorbcas,0:maxorbcas),idimcs
      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
      yw=.false.
      mint=2
      maxt=0
      if(yw)print*,'gener,nn,difref',gener,nn,difref
      if(.not.ygmono) then
      if(nn.eq.0) then
         if(difref.eq.0) then
            mint=0
            maxt=2
         else if(difref.eq.2) then
            mint=0
            maxt=1
         else if(difref.eq.4) then
            mint=0
            maxt=0
         endif
      else if(nn.eq.1) then
         if(difref.eq.1) then
            mint=1
            maxt=2
         else if(difref.eq.3) then
            mint=1
            maxt=1
         endif
      else if(nn.eq.2) then
         if(difref.eq.2) then
            mint=2
            maxt=2
         endif
      else if(nn.eq.-1) then
         if(difref.eq.1) then
            mint=0
            maxt=1
         else if(difref.eq.3) then
            mint=0
            maxt=0
         endif
      else if(nn.eq.-2) then
         if(difref.eq.2) then
            mint=0
            maxt=0
         endif
      endif
      endif
      if(ygcas) then
         if(yw)print*,'tpmms MRC mint,minp,nn,difref',
     *     mint,minp,nn,difref
         if(mint.ne.0.or.nn.ne.0.or.difref.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(difref.eq.0) then
               mint=0
               maxt=1
            else if(difref.eq.2) then
               mint=0
               maxt=0
            endif
         else if(nn.eq.1) then
            if(difref.eq.1) then
               mint=1
               maxt=1
            endif
         else if(nn.eq.-1) then
            if(difref.eq.1) then
               mint=0
               maxt=0
            endif
         endif
      endif
      minp=mint-nn
      maxp=maxt-nn
      if(gener.eq.'MRDD'.or.gener.eq.'MRTD') then
         if(maxt+maxp.gt.3) then
            maxt=maxt-1
            maxp=maxp-1
         endif
      endif
      if(gener.eq.'MRD2'.or.gener.eq.'MRT2') then
         if(maxt+maxp.gt.2) then
            maxt=maxt-1
            maxp=maxp-1
         endif
      endif
      mixtpmrs=mxtps(mint,maxt,minp)
      tpmrs(iadrs)=char(mixtpmrs)
      if(yw) then
         write(75,*)'mint,maxt,minp,maxp,mixtpmrs,iadrs',
     *   mint,maxt,minp,maxp,mixtpmrs,iadrs,'$'
         call scril
      endif
      return
      end
       function mxtps(mint,maxt,minp)
      dimension mmm(0:5)
      data mmm /0,3,5,8,9,11/
      if(mint.gt.maxt) then
         mxtps=15
      else
         mxtps=mmm(mint+maxt*(maxt+1)/2)+1+minp
      endif
      return
      end
       subroutine sptxm(mint,maxt,minp,mixtpmrs)
      dimension minit(15),maxit(15),minip(15)
      data minit / 0,0,0,0,0,1,1,1,0,1,1,2,2,2,2/
      data maxit / 0,0,0,1,1,1,1,1,2,2,2,2,2,2,0/
      data minip / 0,1,2,0,1,0,1,2,0,0,1,0,1,2,2/
c      print*,'sptxm mixtpmrs',mixtpmrs
      mint=minit(mixtpmrs)
      maxt=maxit(mixtpmrs)
      minp=minip(mixtpmrs)
c      print*,'dans sptxm mint,maxt',mint,maxt
      return
      end
 
 
 
 
       subroutine adrcass(iocc,iadrs,ncf,nc1,ic1)
      use mod_ndimcs0
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
c
      PARAMETER (maxsym=8)
      include 'maxorb.prm'
      parameter (maxorbcas=16)
      common /adrcs/ ces(0:maxorbcas,0:maxorbcas),idimcs
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common /combs/  C(0:maxorbcas+4,-1:maxorbcas+4)
      integer c,ces
      dimension iocc(maxorbcas)
      dimension icf(maxorbcas),ic1(maxorbcas)
      yw=.false.
      ncf=0
      nc1=0
      do k=1,noac
         if(iocc(k).eq.2) then
            ncf=ncf+1
            icf(ncf)=k
         else if (iocc(k).eq.1)  then
            nc1=nc1+1
            ic1(nc1)=k-ncf
         endif
      enddo
      call rang2s(noac,ncf,icf,irangf)
      if(yw)print*,'adrcass nc1,ic1',nc1,(ic1(k),k=1,nc1)
      call rang2s(noac-ncf,nc1,ic1,irang1)
      if(yw)print*,'adrcass irangf irang1',irangf,irang1
      iadrs=irangf+(irang1-1)*c(noac,ncf)+ces(ncf,nc1)
      if(yw)print*,'adrcass ncf,nc1,ces',ncf,nc1,ces(ncf,nc1)
      if(yw)print*,'adrcass icf',(icf(k),k=1,ncf)
      if(yw)print*,'adrcass ic1',(ic1(k),k=1,nc1)
      return
      end
       subroutine dawrs(ifile,irec,ind)
      parameter(nrec1=1024)
      IMPLICIT REAL*8(A-H,O-x,z),logical*1(y)
      dimension ind(nrec1)
      write(ifile,rec=irec)ind
      return
      end
