      subroutine lircd
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8,maxorb=500,maxorbcas=16)
      parameter (maxal=56)
      LOGICAL BIDIA
c      character*5280 namel,namel1
      character*5280 namel,namel1
      character*4 hab
      common/infdav/ alam(maxal),tau,twvec,twess,sint,sh
     *,hab,Nbtots,nvec,ngao,niter,iprec,lvec(maxal),ipresc,irest
     *,iunit,ihprec,ihvec,ifiess,NESSAI,nf8,BIDIA,maxda2,ywvec,ytana
     *,yhmono,ydens,ywcas
      common/dim/ iadri
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/infodp/ydp
      common/pr/nprint,mprint(10)
      common/test/itest(50)
      common/opt/ihab,calcul
      character*3 calcul
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common/l40/ hmono(maxorb*(maxorb+1)/2),aj(maxorb*(maxorb+1)/2)
     *,ak(maxorb*(maxorb+1)/2),f(maxorb*(maxorb+1)/2),e0
     *,ajk(maxorb*(maxorb+1)/2),escf
      common/sy2/nts(maxsym),ncs(maxsym),nps(maxsym)
     *,norbs(maxsym)
      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
      common/l0/ilimi,nintot,nint,ycl
      common /det/ndet,mdet(50)
      common/stp/stop
      character*8 stop
      common /stoc/ jint,jnb(1024),jnb1,iter,lonstc,maxstc,ystc,ystit1
      namelist /cdi/ noac,numac,nelac,is0,ms2,gener
      namelist /ij/nsym,norb,noc,ydp,enuc,ycl
c    *,itsym,its
c ----------------------------------------------------------------------
c     lecture et stockage des integrales
c ----------------------------------------------------------------------
      yw1=.false.
      noac=0
      nelac=0
      ms2=0
      do i=1,maxorbcas
         numac(i)=0
      enddo
      is0=1
 
      write(6,*)
      write(6,*)'--------------------------------------'
      write(6,*)'          LECTURE DES FILES         '
      write(6,*)'--------------------------------------'
      write(6,*)
 
 
c     read(4,cdi,end=24)
      call LECNAM('&CDI',namel,4,ierr,0)
      if(ierr.eq.1) goto 24
      call nameli(namel,noac,'NOAC',4)
      call nameli(namel,NUMAC(1),'NUMAC',4)
      call nameli(namel,NELAC,'NELAC',4)
      call nameli(namel,IS0,'IS0',4)
      call nameli(namel,MS2,'MS2',4)
      call nameli(namel,NDET,'NDET',4)
      call namela(namel,GENER,'GENER')
c      write(6,cdi)
      write(75,cdi)
      call scrinam('NAMELIST CDI   ')
 
 
      if(gener(1:2).eq.'MR') maxstc=0
      if(maxstc.eq.0) then
         itest(30)=0
      else
         itest(30)=1
      endif
 
 
c      print*,'1ndet,nvec,maxda2',ndet,nvec,maxda2
      maxda2=max0(maxda2,2)
      if(maxda2.gt.ndet) maxda2=ndet
c      print*,'2ndet,nvec,maxda2',ndet,nvec,maxda2
      if(nvec*2.gt.maxda2) then
         if(ndet.eq.maxda2) then
            print*,'On calcule tous les vecteurs propres',ndet
            nvec=ndet
         else
            print*,'nombre max de vecteurs = maxda2/2 =',maxda2/2
c      print*,'3ndet,nvec,maxda2',ndet,nvec,maxda2
            stop
         endif
      endif
c      print*,'ndet,nvec,maxda2',ndet,nvec,maxda2
      if(ihab.ne.0) then
         if(gener.eq.'DDCI'.or.gener.eq.'DDC2') then
            itest(11)=1
            write(6,*)'gener=',gener,'   itest(11) est mis a 1'
         endif
         if(gener.eq.'DDci') stop 'gener=DDci et ihab.ne.0'
      endif
      if(nelac.eq.0) itest(16)=0
      goto 25
 24   continue
      write(6,*)'on n''a pas trouve de fichier cdi'
      itest(50)=1
      return
 25   continue
      close(4)
c      write(6,*)'noac,numac',noac,numac
      if(noac.ne.0) then
         if(ihab.ne.0.and.itest(11).eq.0) then
            write(6,*) 'pas d''habillage s''il y a des actives'
	    write(6,*) 'ihab.ne.0.and.itest(11).eq.0??'
c            stop
         endif
      endif
      if(ms2.gt.0) then
         ms2=-ms2
         write(6,*)'ms2 doit etre negatif  on change son signe'
         write(6,*)'ms2',ms2
      endif
c      write(6,cdi)
 
 
 
!c     read(45,ij,end=22)
!      call LECNAM('&IJ',namel,45,ierr,0)
!      if(ierr.eq.1) goto 22
!c      namelist /ij/nsym,norb,noc,ydp,itsym,its,enuc,ycl
!      call nameli(namel,nsym,'NSYM',4)
!      call nameli(namel,norb,'NORB',4)
!      call nameli(namel,noc,'NOC',4)
!      call namell(namel,ydp,'YDP',1)
!      call nameli(namel,itsym(1),'ITSYM',4)
!      call nameli(namel,its(1,1),'ITS',4)
!      call nameld(namel,enuc,'ENUC',8)
!      call namell(namel,ycl,'YCL',1)
!c     write(6,ij)
!c      print*,'noc',noc
!      write(75,ij)
!      call scrinam('NAMELIST IJ    ')
      
      call LECNAM('&COST_AO',namel,45,ierr,0)
      rewind 45
      call LECNAM('&COST_MO',namel1,45,ierr,0)
      if(ierr.eq.1) goto 22
c      namelist /ij/nsym,norb,noc,ydp,itsym,its,enuc,ycl
      call nameli(namel,nsym,'NSYM',4)
      call nameli(namel1,norb,'NORB',4)
      call nameli(namel1,noc,'NOC',4)
      call nameli(namel1,itsym(1),'ITSYM',4)
      call nameli(namel,its(1,1),'ITS',4)
      call nameld(namel1,enuc,'ENUC',8)
      call namell(namel1,ycl,'YCL',1)
c     write(6,ij)
c      print*,'noc',noc
      write(75,ij)
      if(ypr)call scrinam('NAMELIST IJ    ')
 
 
 
      goto 23
 22   continue
      write(6,*)'on n''a pas trouve de fichier Info'
      return
 23   continue
      noca=noc
      nocb=noca-ms2/2
      if(noac.ne.10)numac(noac+1)=0
      metat=1
      do i=1,norb
         iorb(i)=i
         iorb(i+norb)=i
      enddo
      noca0=noca
      noca=noca-(-ms2+1)/2
      nca0=nelac/2+ms2/2
      ncb0=(nelac+1)/2-ms2/2
 1000 format(a50,10i4)
 1001 format(a40,i8)
 1002 format(a40,d8.2)
      write(6,1000)'norb     ',norb
      write(6,'(''     double precision pour les integrales ydp ''
     *,l8)') ydp
      do 1 i=1,norb
 1    itsym(i+norb)=itsym(i)
      write(6,1000)'nombre de symetries   nsym     ',nsym
      write(6,1000)'nombre d orbitales occupees alpha   noca     ',noca
      write(6,1000)'nombre d orbitales occupees beta    nocb     ',nocb
      write(6,*)' '
      write(6,*)'symetrie des orbitales'
      do ideb=1,norb,20
         ifin=min0(ideb+19,norb)
         write(6,'(20i3)')(i,i=ideb,ifin)
         write(6,'(20i3)')(itsym(i),i=ideb,ifin)
         write(6,*)' '
      enddo
      if(nprint.ge.1)write(6,*)'table de multiplication'
      do 2 i=1,nsym
 2    if(nprint.ge.1)write(6,'(20i4)')(its(i,j),j=1,nsym)
      nter=norb*(norb+1)/2
      write(6,*)
      write(6,*)'--------------------------------------'
      write(6,*)'        FIN DE LECTURE DES FILES         '
      write(6,*)'--------------------------------------'
      write(6,*)
      call calc
      return
      end
       subroutine calc
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8,maxorb=500,maxorbcas=16)
      parameter(ndimcs0=100000)
C=====CALCUL DE C
      common /combs/  c(0:maxorbcas+4,-1:maxorbcas+4)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      integer c
      yw=.false.
C=====CALCUL DE C
      DO I=0,maxorbcas+4
         DO J=-1,maxorbcas+3
            C(I,J)=-50
            if(i.lt.j) c(i,j)=0
         ENDDO
      ENDDO
      DO 1 I=0,noac+4
c   C(I,J)=combinaison de J parmi I
      C(I,-1)=0
      C(I,0)=1
      C(I,1)=I
      C(I,I)=1
      c(0,0)=1
      if(yw)write(6,*)'c(i,j),i,j',c(i,0),i,0
      if(yw)write(6,*)'c(i,j),i,j',c(i,1),i,1
      DO 2 J=2,noac+4
      IF(J.GT.I) GOTO 2
      C(I,J)=(C(I,J-1)*(I-J+1))/(J)
      if(yw)write(6,*)'c(i,j),i,j',c(i,j),i,j
 2    CONTINUE
 1    CONTINUE
c
c     calcul MRS : dimension des CAS
c
      ncfmax=min(noac,(nelac+2)/2)
      ncfmin=max(0,nelac-2-noac)
      ndimcs=0
      do I=ncfmin,ncfmax
         do J=max(0,nelac-2-i*2),min(noac-i,nelac+2-i*2)
            if(yw)print*,i,j,C(noac,I),C(noac-I,J)
            ndimcs=ndimcs+C(noac,I)*C(noac-I,J)
         enddo
      enddo
c      print*,'ndimcs',ndimcs
      call verdim('calcul MRS  ndimcs trop grand :  ndimcs= '
     *,ndimcs,ndimcs0)
      return
      end
c
