      subroutine lircd
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      parameter (maxda3=300)
      logical*1 bidia
      character*100000 namel
      character*10000 namel1
      character*4 hab
      common/infdav/ twcas,alam(maxda3),tau,twvec,twess,sint,sint4,sh
     *,hab,Nbtots,nvec,ngao,niter,iprec,lvec(maxda3),nfrag,ipresc,irest
     *,jrest
     *,iunit,ihprec,ihvec,ifiess,NESSAI,nf8,maxda2,bidia,ywvec,ytana
     *,yhmono,ydens,ywcas
      common/dim/iadri ; integer(8) 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(100)
      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
      integer(8) ilimi,ilimi4,nintot,nintot4,nint
      common/l0/ilimi,ilimi4,nintot,nintot4,nint,ycl
      common /det/ndet,mdet(50),nbdet_cas
      common/stp/stop
      character*8 stop
      common /stoc/ jint,jnb(1024),jnb1,iter,lonstc,maxstc,ystc,ystit1
      character*1 syspin
      common /sysp1/syspin
      common/g2/lg2,ig2,lg2p,ig2p,lg2m,ig2m,ng2,yg2,yga2
      namelist /cdi/ noac,numac,nelac,is0,ms2,gener,ndet
      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
      gener='PERT'
      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')
      call calc_igener(GENER)
      if(index(GENER,'DDC').ne.0) then
         if(ihab.eq.1.and.itest(11).eq.2) then
            print*,'pas d''habillage rapide avec gener=',gener
            print*,'mettre itest(11)=1'
            stop
         endif
      endif
      if(itest(77)==1) then
         write(75,cdi)
         call scrinam('NAMELIST CDI   ')
      endif
      close (75)
      open(75,file='fort.75')
 
 
      if(ms2.ne.0) syspin='0'
      if(gener(1:2).eq.'MR') then
c         if(yg2) then
c            print*,'pas de gamma2 avec un calcul selectionne'
c            if(gener.eq.'MRT')print*,'remplacer gener=''CAS+SD'''
c     *      ,'par gener=''TOUS'' dans casdet'
c            if(gener.eq.'MRTM')print*,'remplacer gener=''CAS+S'''
c     *      ,'par gener=''MONO'' dans casdet'
c            stop
c         endif
      endif
      if(gener(1:2).eq.'MR') maxstc=0
      if(gener(1:2).ne.'MR') itest(44)=0
      if(maxstc.eq.0) then
         itest(30)=0
      else
         itest(30)=1
      endif
      if(gener(1:2).ne.'MR'.or.ihab.ne.0) then
         do k=38,43
            itest(k)=0
         enddo
         itest(60)=0
         itest(61)=0
         itest(66)=0
      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
            if(nessai==2) then
c              dans ce cas, on remet nessai a 0.
c              sinon, on a une erreur dans essai, car on veut
c              lire trop de vecteurs
               nessai=0
            endif
         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'
            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('&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
      if(itest(77)==1) then
         write(75,ij)
         call scrinam('NAMELIST IJ    ')
      endif
 
 
 
      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.maxorbcas)numac(noac+1)=0
      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(a,16i4)
      do 1 i=1,norb
 1    itsym(i+norb)=itsym(i)
      print*,' '
      print*,'********************************************************'
      write(6,1000)'nombre d orbitales                       ',norb
      write(6,1000)'nombre de symetries                      ',nsym
      write(6,1000)'nombre d orbitales occupees alpha        ',noca
      write(6,1000)'nombre d orbitales occupees beta         ',nocb
      write(6,1000)'orbitales actives                        '
     *,(numac(k),k=1,noac)
      write(6,*)' '
      write(6,*)'symetrie des orbitales'
      call w_orb_sym(itsym,norb)
      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)
      print*,'********************************************************'
      print*,' '
      write(6,*)
      write(6,*)'--------------------------------------'
      write(6,*)'        FIN DE LECTURE DES FILES         '
      write(6,*)'--------------------------------------'
      write(6,*)
      call calc
      return
      end
       subroutine calc
      use mod_ndimcs0
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
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      print*,'calc ndimcs0',ndimcs0
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
      ndimcs0=ndimcs
      allocate(nim(ndimcs))
      allocate(y1(ndimcs))
      allocate(tpmrs(ndimcs))
C      call verdim1(5,ndimcs,ndimcs0)
C      call verdim('calcul MRS  ndimcs trop grand :  ndimcs= '
C     *,ndimcs,ndimcs0)
      return
      end
c
       subroutine calc_igener(GENER)
      character(*) gener
      common/igen/ igener
      if(gener=='MRTC'.or.gener=='CAS'.or.gener=='MRC') then
         igener=0
      else if(gener=='MRTM'.or.gener=='MRM') then
         igener=1 
      else if(gener=='MRT2'.or.gener=='MRD2') then
         igener=2
      else if(gener=='MRTD'.or.gener=='MRDD') then
         igener=3
      else
         igener=4
      endif
      return
      end
       subroutine w_orb_sym(itsym,norb)
      integer itsym(norb)
      ifin=0
      ideb=1
      ii=itsym(1)
      do i=1,norb
         if(itsym(i).ne.ii) then
            ifin=i-1
            if(ideb.eq.ifin) then
               write(6,'(a3,i2,a3,i3)')
     *         'sym',ii,' : ',ideb
            else
               write(6,'(a3,i2,a3,i3,a3,i3)')
     *         'sym',ii,' : ',ideb,' - ',ifin
            endif
            ideb=ifin+1
            if(ideb.gt.norb) goto 3
            if(itsym(ideb).le.ii) print*,' '
            ii=itsym(ideb)
         endif
      enddo
      write(6,'(a3,i2,a3,i3,a3,i3)')
     *'sym',ii,' : ',ideb,' - ',norb
 3    continue
      end
