      subroutine prepads
      use mod_ndimcs0
      parameter (maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      IMPLICIT real*8(A-H,O-x,z),logical*1(y)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      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)
      common/adrmrs/clss(15,18,17,0:maxorbcas)
     *,clssm(15,18,17,0:maxorbcas)
      integer c,ces,clss,clssm
      common /prep2s/ icatts(maxsym,maxsym),icatps(maxsym,maxsym)
      common/sy2/nts(maxsym),ncs(maxsym),nps(maxsym)
     *,norbs(maxsym)
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /nummrs/nummr(maxorb)
      common/dimis/ iadris1,iadristp1,maxsps
      common/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
 
      yw=.false.
c      print *,'entree prepads enuc,eref,norb,noca,nocb,ms2',
c     *enuc,eref,norb,noca,nocb,ms2
c      print *,'entree prepads numac,is0',numac,is0
c      print *,'entree prepads ninac',ninac,noac,nelac
c
c     numerotation des orbitales dans l'ordre TCP
c
c     nombre max de couches ouvertes
      if(nelac-2.gt.noac) then
         maxco=noac-(nelac-2-noac)
      else
         maxco=min(nelac+2,noac)
      endif
c     dimension des conf de spin
      mmm=maxco+min(2,ninac)+min(2,nvirt)
      maxsps=c(mmm,mmm/2)
      if(yw)print*,'dans cdrs maxsps',maxsps
 
      do i=1,norb
         if(itype(i).eq.1) then
            ii=0
         else if (itype(i).eq.2) then
            ii=ninac
         else if (itype(i).eq.3) then
            ii=ninac+noac
         endif
         nummr(i)=itorbc(i)+ii
c         nummr_1(nummr(i))=i
      enddo
 
c
c     En esta subrutina anem a preparar la matriu CEs que contindra
c     les clases de equivalencia que es poden crear tenint en conter
c     les diferents capes tancades i capes obertes.
c
c     icatts et icatps
c
      do is1=1,nsym
         do is2=1,is1
            if(is1.eq.is2) then
               icatts(is2,is1)=0
               icatps(is2,is1)=0
               do is=1,is2-1
                  icatts(is2,is1)=icatts(is2,is1)+nts(is)*(nts(is)-1)/2
                  icatps(is2,is1)=icatps(is2,is1)+nps(is)*(nps(is)-1)/2
               enddo
            else
               do is=1,is2-1
                  js=its(is,its(is1,is2))
                  if(js.gt.is) then
                     icatts(is2,is1)=icatts(is2,is1)+nts(is)*nts(js)
                     icatps(is2,is1)=icatps(is2,is1)+nps(is)*nps(js)
                  endif
               enddo
               icatts(is1,is2)=icatts(is2,is1)
               icatps(is1,is2)=icatps(is2,is1)
            endif
         enddo
      enddo
c
c     Comence a calcular el numero de determinants que es poden generar
c     en cada clase de equivalencia possible
c
      do i=0,noac
         do j=0,noac
            ces(j,i)=0
         enddo
      enddo
      ncfmax=min(noac,(nelac+2)/2)
      ncfmin=max(0,nelac-2-noac)
      do I=ncfmin,ncfmax
        do J=max(0,nelac-2-i*2),min(noac-i,nelac+2-i*2)
        ces(I,J)=C(noac,I)*C((noac-I),J)
           if(yw)print*,'0 i,j,ces(I,J)',i,j,ces(I,J)
c
c       guarde la matriu ces(I,J) on esta el numero de determinants poss
c       ab I numero de capes tancades i J de capes obertes. Esta dimensi
c       maxim possibles independentment del problema. Totes les possibil
c
        enddo
      enddo
      ij=0
      ij1=0
      do i=ncfmin,ncfmax
         do j=max(0,nelac-2-i*2),min(noac-i,nelac+2-i*2)
           ij1=ij1+ij
           ij=ces(i,j)
           ces(i,j)=ij1
           if(yw)print*,'i,j,ces(I,J)',i,j,ces(I,J),ij
        enddo
      enddo
      if(ij+ij1.gt.ndimcs0) then
         print*,'ndimcs0 n''est pas assez grand'
         print*,'ndimcs0 doit valoir au moins',ij+ij1
         stop
      endif
      idimcs=ij+ij1
      do nat=0,noac+4
         do ial=0,nat
            call rang0s(nat,ial)
         enddo
      enddo
      call calcmrs
      return
      end
       subroutine calcmrs
      use mod_ndimcs0
      PARAMETER (maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      IMPLICIT real*8(A-H,O-x,z),logical*1(y)
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common/sy2/nts(maxsym),ncs(maxsym),nps(maxsym)
     *,norbs(maxsym)
      common /combs/  C(0:maxorbcas+4,-1:maxorbcas+4)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      integer c,clss,clssm
      common/adrmrs/clss(15,18,17,0:maxorbcas)
     *,clssm(15,18,17,0:maxorbcas)
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/niis/niips(0:2,0:2,maxsym),niits(0:2,maxsym)
      dimension ndett(0:2,0:2,maxsym)
      dimension ndetp(0:2,0:2,maxsym)
      common/pr/nprint,mprint(10)
      icc(i)=(i-1)*i/2
      yw=nprint.ge.3
      if(yw)print *,'entree calcmrs ninac',ninac,noac,nelac
 
c     mise a zero et preparation
      do isol=0,2
         do is=1,nsym
            do m=0,2
               ndett(isol,m,is)=0
               ndetp(isol,m,is)=0
            enddo
         enddo
      enddo
      call niipmrs(niips)
      call niitmrs(niits)
      ndett(0,0,1)=1
c
c     1 trou
c
      do is=1,nsym
         ndett(1,1,is)=nts(is)
      enddo
c
c     2 trous de symetries differentes
c
      do is1=1,nsym
         do is2=1,is1-1
            ndett(2,2,its(is1,is2))=ndett(2,2,its(is1,is2))+
     *      nts(is1)*nts(is2)
         enddo
      enddo
c
c     2 trous de meme symetrie sur 2 orbitales differentes
c
      do is=1,nsym
         ndett(2,2,1)=ndett(2,2,1)+icc(nts(is))
         if(yw) print*,'!!!',nts(is),is
      enddo
c
c     2 trous de meme symetrie sur la meme orbitale
c
      ndett(0,2,1)=ndett(0,2,1)+ninac
c
c     0 part
c
      ndetp(0,0,1)=1
c
c     1 part
c
      do is=1,nsym
         ndetp(1,1,is)=nps(is)
      enddo
c
c     2 parts de symetries differentes
c
      do is1=1,nsym
         do is2=1,is1-1
            ndetp(2,2,its(is1,is2))=ndetp(2,2,its(is1,is2))+
     *      nps(is1)*nps(is2)
         enddo
      enddo
c
c     2 parts de meme symetrie sur 2 orbitales differentes
c
      do is=1,nsym
         ndetp(2,2,1)=ndetp(2,2,1)+icc(nps(is))
      enddo
c
c     2 parts de meme symetrie sur la meme orbitale
c
      ndetp(0,2,1)=ndetp(0,2,1)+nvirt
c
c     determinants du CAS
c
 
 
      ncfmax=min(noac,(nelac+2)/2)
      ncfmin=max(0,nelac-2-noac)
      if(yw)print*,'ncfmin,ncfmax',ncfmin,ncfmax
      do ncf=ncfmin,ncfmax
         do isolc=max(0,nelac-2-ncf*2),min(noac-ncf,nelac+2-ncf*2)
            nelc=ncf+ncf+isolc-nelac
            if(isolc.eq.0) then
               isc2=1
            else
               isc2=nsym
            endif
            do isc=1,isc2
               do mixtpmrs=1,14
                  call sptxm(mint,maxt,minp,mixtpmrs)
                  if(mint-minp.ne.nelc) goto 200
                  maxp=minp+maxt-mint
                  if(yw) write(75,*)'mixtpmrs,mint,maxt,minp,maxp',
     *            mixtpmrs,mint,maxt,minp,maxp,'$'
                  if(yw) call scril
                  ij=0
                  ij1=0
                  do nt=mint,maxt
                     np=nt+minp-mint
                     if(nt.eq.0) then
                        isolt1=nt
                        isolt2=nt
                        ist1=1
                        ist2=1
                     else if(nt.eq.1) then
                        isolt1=nt
                        isolt2=nt
                        ist1=1
                        ist2=nsym
                     else if(nt.eq.2) then
                        isolt1=0
                        isolt2=2
                        ist1=1
                        ist2=nsym
                     endif
                     if(np.eq.0) then
                        isolp1=np
                        isolp2=np
                     else if(np.eq.1) then
                        isolp1=np
                        isolp2=np
                     else if(np.eq.2) then
                        isolp1=0
                        isolp2=2
                     endif
                     do isolt=isolt1,isolt2,2
                        ist3=ist2
                        if(isolt.eq.0) ist3=1
                        do isolp=isolp1,isolp2,2
                           isol=isolc+isolt+isolp
                           do ist=ist1,ist3
                              isp=its(is0,its(isc,ist))
                              if(niips(np,isolp,isp).eq.0) goto 100
                                 ij1=ij1+ij
                                 clssm
     *                           (mixtpmrs,niips(np,isolp,isp)
     *                           ,niits(isolt,ist),isolc)
     *                           =ij1
                                 ij=ndett(isolt,nt,ist)
     *                           *ndetp(isolp,np,isp)
     *                           *c(isol,(isol-ms2)/2)
             if(c(isol,(isol-ms2)/2).lt.0) then
               print*,'isol,ms2,c',isol,ms2,c(isol,(isol-ms2)/2)
               stop
             endif
                                 if(yw) then
                                    write(75,*)'ms2,isol,ndett,ndetp,c',
     *                              ms2,isol,ndett(isolt,nt,ist)
     *                              ,ndetp(isolp,np,isp)
     *                              ,c(isol,(isol-ms2)/2),'$'
                                    call scril
                                    write(75,*)'mint,maxt,minp,maxp',
     *                              mint,maxt,minp,maxp,'$'
                                    call scril
                                    write(75,*)
     *                              'nelc,isc,isolc,',
     *                              'nt,ist,isolt,np,isp,isolp',
     *                              ' clssm',nelc,isc,isolc,' , '
     *                              ,nt,ist,isolt,
     *                              np,isp,isolp
c     *                              ,'$'
     *                              ,clssm
     *                              (mixtpmrs,niips(np,isolp,isp)
     *                              ,niits(isolt,ist),isolc),ij,'$'
                                    call scril
                                    write(75,*)'niips,niits',
     *                              niips(np,isolp,isp),niits(isolt,ist)
     *                              ,'$'
                                    call scril
                                    write(75,*)'KLSSM',mixtpmrs,np,
     *                              isolp,isp,isolt,ist,isolc,
     *                              clssm
     *                              (mixtpmrs,niips(np,isolp,isp)
     *                              ,niits(isolt,ist),isolc),'$'
                                    call scril
                                 endif
                                 clss(mixtpmrs,niips(np,isolp,isp)
     *                           ,niits(isolt,ist),isolc)=ij
 100                             continue
                           enddo
                        enddo
                     enddo
                  enddo
 200              continue
               enddo
            enddo
         enddo
      enddo
c      do mixtpmrs=1,14
c      do np=0,2
c      do isolp=0,2
c      do isp=1,nsym
c      do isolt=0,2
c      do ist=1,nsym
c      do isolc=0,noac
c      if(niits(isolt,ist).eq.0) goto 300
c      if(niips(np,isolp,isp).eq.0) goto 300
c      write(75,*)'CLSSM',mixtpmrs,np,isolp,isp,isolt,ist,isolc,
c     *                              clssm
c     *                              (mixtpmrs,niips(np,isolp,isp)
c     *                              ,niits(isolt,ist),isolc),'$'
c                                    call scril
c 300  continue
c      enddo
c      enddo
c      enddo
c      enddo
c      enddo
c      enddo
c      enddo
      return
      end
       subroutine niipmrs(niips)
      PARAMETER (maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      dimension niips(0:2,0:2,maxsym)
      common/sym/itsym(2*maxorb),its(maxsym,maxsym),nsym
c
c     mise a zero
c
      do is=1,nsym
      do isolp=0,2
      do np=0,2
         niips(np,isolp,is)=0
      enddo
      enddo
      enddo
c
c
      niips(0,0,1)=1
      ij=1
      do is=1,nsym
         ij=ij+1
         niips(1,1,is)=ij
      enddo
      ij=ij+1
      niips(2,0,1)=ij
      do is=1,nsym
         ij=ij+1
         niips(2,2,is)=ij
      enddo
      return
      end
       subroutine niitmrs(niits)
      PARAMETER (maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      dimension niits(0:2,maxsym)
      common/sym/itsym(2*maxorb),its(maxsym,maxsym),nsym
c
c     mise a zero
c
      do is=2,nsym
         niits(0,is)=0
      enddo
c
c
      niits(0,1)=1
      ij=1
      do isolt=1,2
         do is=1,nsym
            ij=ij+1
            niits(isolt,is)=ij
         enddo
      enddo
      return
      end
       subroutine tradmrs(iocc,nca,ica,ncb,icb)
      parameter (maxorbcas=16)
      include 'maxorb.prm'
      common/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      dimension iocc(maxorbcas),ica(maxorbcas),icb(maxorbcas)
      do k=1,noac
         iocc(k)=0
      enddo
         do k=1,nca
            iocc(itorbc(ica(k)))=1
         enddo
         do k=1,ncb
            iocc(itorbc(icb(k)))=iocc(itorbc(icb(k)))+1
         enddo
      return
      end
 
 
 
