      subroutine prepad
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
c
c-------------------------------------------------------------
c     on effectue divers calculs preliminaires
c-------------------------------------------------------------
c
      PARAMETER (maxsym=8,maxorbcas=16,maxdetc=12870)
      include 'maxorb.prm'
      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
      endif
      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
      isz0=nca0-ncb0
      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
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 (maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      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,10,
     *   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 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
