      program CASDET
      implicit real*8(a-h,o-x,z),logical*1 (y)
      parameter(maxorb=1024,nsymz=8)
      parameter(maxorbcas=16)
      character*80 ligne
      common/f4/norb,noc,noca,nocb,nca0,ncb0,ydet,ydetv,ydetcl
     *,ydetsc,yf_act,ywcas,ynosym,ytp0
      common/det/msto,nsto,mstov,nstov,idet(2400),nex(100),
     *long(maxorbcas+2),imono,ndet,msto256,
     *ncfmin,ncfmax
      common/occ/noac,nelac,numac(maxorbcas),is0,ninac,nvirt
     *,numt(maxorb),nump(maxorb),ntac,nutac(maxorbcas),ms2
      character*8 gener
      common/gene/gener,ygcas,ygmono,ygmr
      common/print/nprint
      common/version/ibeta
      character*4 fn
      common/pres/ presel
      character*4 presel
      write(6,*)' '
      write(6,*)' ####     ##     ####           #####   ######   #####'
      write(6,*)'#    #   #  #   #               #    #  #          #'
      write(6,*)'#       #    #   ####           #    #  #####      #'
      write(6,*)'#       ######       #          #    #  #          #'
      write(6,*)'#    #  #    #  #    #          #    #  #          #'
      write(6,*)' ####   #    #   ####  #######  #####   ######     #'
      write(6,*)' '
      write(6,*)'------------------------------------------------------'
      write(6,*)'------------------------------------------------------'
      write(6,*)'             GENERATION DES DETERMINANTS'
      write(6,*)'------------------------------------------------------'
      write(6,*)'------------------------------------------------------'
      call sto5_1(5,94,'CASDET_DATA')
      open(75)
! 9    continue
!      read(5,'(a)',end=8) ligne
!      print*,ligne
!      write(94,'(a)') ligne
!      goto 9
! 8    continue
c      rewind 5
      rewind 94
      call openf
      call prepar
      if(presel.ne.' ') then
         call preselec
         stop
      endif
      if(ygmr.and.ibeta.eq.1) then
         call genmr
      else if(ygmr.and.ibeta.eq.2) then
         call genmr2
      else
         call gen
      endif
      if(ydet)call fine2
      if(ydetv)call fine
      if(gener.eq.'CAS') gener='MRTC'
      if(gener.eq.'CASV') gener='CAS'
      if(gener.eq.'CAS+SD') gener='MRT'
      if(gener.eq.'CAS+S') gener='MRTM'
      if(gener.eq.'CAS+DDCI') gener='MRTD'
      if(gener.eq.'CAS+DDC2') gener='MRT2'
      if(gener.eq.'SEL') gener='MRC'
      if(gener.eq.'SEL+SD') gener='MRS'
      if(gener.eq.'SEL+S') gener='MRM'
      if(gener.eq.'SEL+DDCI') gener='MRDD'
      if(gener.eq.'SEL+DDC2') gener='MRD2'
      write(4,'(1x,a4)')'&CDI'
      write(4,'(1x,a5,i2,1h,)')'noac=',noac
      write(4,'(1x,a6,i4,1h,)')'ninac=',ninac
      write(4,'(1x,a6,20(i3,1h,))')'numac=',(numac(k),k=1,max(noac,1))
      write(4,'(1x,a6,i2,1h,)')'nelac=',nelac
      write(4,'(1x,a4,i3,1h,)')'ms2=',ms2
      write(4,'(1x,a4,i2,1h,)')'is0=',is0
      write(4,'(1x,a5,i9,1h,)')'ndet=',ndet
      write(4,'(1x,a6,a7)')'gener=',''''//gener(1:4)//''''//','
      call finnam(fn)
      write(4,'(1x,a4)') fn
      close(94)
      end
       subroutine finnam(fn)
      character*4 fn
      character*80 fn1
      namelist/end/ dum
      open(unit=95,file='BID95',status='unknown')
      dum=0.
      write(95,end)
      rewind 95
      read(95,'(a80)') fn1
      read(95,'(a80)',end=1) fn1
      read(95,'(a80)',end=1) fn1
 1    continue
      do k=80,1,-1
      if(fn1(k:k).eq.' ') cycle
      if(fn1(k:k).eq.'/') then
         fn='/   '
      else
         fn='&end'
      endif
      close(95,status='DELETE')
      return
      enddo
      if(fn/='/'.and.fn/='&end') fn='/'
      end
 
       subroutine prepar
      implicit real*8(a-h,o-x,z),logical*1 (y)
      parameter(maxorb=1024,nsymz=8)
      parameter(maxorbcas=16)
      common/occsy/numacsy(8),ninacsy(8)
      common/occ/noac,nelac,numac(maxorbcas),is0,ninac,nvirt
     *,numt(maxorb),nump(maxorb),ntac,nutac(maxorbcas),ms2
      common/sym/nsym,its(nsymz,nsymz),itsym(maxorb)
      common/util/jsp(-2:2,-2:2),ksp(-4:4)
      common/f4/norb,noc,noca,nocb,nca0,ncb0,ydet,ydetv,ydetcl
     *,ydetsc,yf_act,ywcas,ynosym,ytp0
      common/det/msto,nsto,mstov,nstov,idet(2400),nex(100),
     *long(maxorbcas+2),imono,ndet,msto256,
     *ncfmin,ncfmax
      common/print/nprint
      common/fr/nfrag
      dimension ifr(maxorbcas),kfinfr(0:maxorbcas),nelfr(maxorbcas)
      dimension iappfr(maxorbcas)
      dimension l(maxorb)
      dimension iorbfr(maxorbcas,maxorbcas),norbfr(maxorbcas)
      dimension lie(maxorbcas,maxorbcas)
      dimension y(maxorb)
      character*8 gener
      common/gene/gener,ygcas,ygmono,ygmr
      common/version/ibeta
      common/selm/iselm
      character*100000 namel,namel1
      common/pres/ presel
      character*4 presel
      namelist /ij/nsym,norb,noc,itsym,its
      namelist/cd/gener,is0,ms2,nelac,nfrag,noac,nprint,numac,
     *ydet,ydetv,ydetcl,ydetsc,yf_act,ywcas

!
!*************************************************************
! Lecture Namelist &cd
!*************************************************************
!
      yf_act=.true.
      ynosym=.false.
      ydet=.true.
      ydetcl=.false.
      ydetsc=.false.
      ydetv=.false.
      yw=.false.
      ywcas=.false.
      gener='CAS+SD'
      nprint=0
      noac=0
      nelac=0
      nfrag=0
      ibeta=2
      ncfmin=0
      ncfmax=maxorbcas
      presel='    '
      ypr=.false.
      do i=1,maxorbcas
         numac(i)=0
      enddo
      do i=1,8
         numacsy(i)=0
      enddo
      ms2=0
      is0=1
c     read(94,cd)
      open(1,form='formatted',status='UNKNOWN',file='TEMPMR')
      call LECNAM('&CD',namel,94,ierr,1)
      call nameli(namel,numacsy(1),'NUMACSY',4)
      call nameli(namel,NINACSY(1),'NINACSY',4)
      call nameli(namel,numac(1),'NUMAC',4)
      call nameli(namel,noac,'NOAC',4)
      call nameli(namel,nelac,'NELAC',4)
      call namela(namel,gener,'GENER')
      call namela(namel,PRESEL,'PRESEL')
      call nameli(namel,ms2,'MS2',4)
      call nameli(namel,is0,'IS0',4)
      call nameli(namel,nprint,'NPRINT',4)
      call nameli(namel,ncfmax,'NCFMAX',4)
      call nameli(namel,ncfmin,'NCFMIN',4)
      call nameli(namel,IBETA,'IBETA',4)
      call nameli(namel,NFRAG,'NFRAG',4)
      call namell(namel,YDETSC,'YDETSC',1)
      call namell(namel,YDETCL,'YDETCL',1)
      call namell(namel,YDETV,'YDETV',1)
      call namell(namel,YDET,'YDET',1)
      call namell(namel,YF_ACT,'YF_ACT',1)
      call namell(namel,YNOSYM,'YNOSYM',1)
      call namell(namel,YWCAS,'YWCAS',1)
      write(75,cd)
      if(ypr) call scrinam('NAMELIST &CD   ')
      rewind 75
      if(nfrag.ne.0) call frag
c
!
!*************************************************************
! gener.eq.'SEL+CS' : on s'autorise a donner des det de reference
! d'une mauvaise symetrie pour faire un calcul SEL+S. Cest det
! de mauvaise symetrie seront elimines, mais pas leurs "enfants"
! de bonne symetrie.
!*************************************************************
!
      ytp0=.false.
      if(gener.eq.'SEL+CS') then
         gener='SEL+S'
         ynosym=.true.
         ytp0=.true.
         ibeta=1
      endif
c
!
!*************************************************************
! Conformite de la donnee gener
!*************************************************************
!
      if(gener.eq.'PERT') goto 1
      if(gener.eq.'DDCI') goto 1
      if(gener.eq.'DDC2') goto 1
      if(gener.eq.'TOUS') goto 1
      if(gener.eq.'DDci') goto 1
      if(gener.eq.'MONO') goto 1
      if(gener.eq.'CASV') goto 1
c      anciennes donnees :
      if(gener.eq.'MRM') gener='SEL+S'
      if(gener.eq.'MRC') gener='SEL'
      if(gener.eq.'MRDD') gener='SEL+DDCI'
      if(gener.eq.'MRD2') gener='SEL+DDC2'
      if(gener.eq.'MRS') gener='SEL+SD'
      if(gener.eq.'MRTC') gener='CAS'
      if(gener.eq.'MRT') gener='CAS+SD'
      if(gener.eq.'MRTD') gener='CAS+DDCI'
      if(gener.eq.'MRT2') gener='CAS+DDC2'
      if(gener.eq.'MRTM') gener='CAS+S'
c     Donnees pour engendrer un espace perturbatif
      iselm=0
      if(index(gener,'-').ne.0) call genper
c     Jose
      ygmr=.true.
      if(gener.eq.'SEL') goto 1
      if(gener.eq.'SEL+DDCI') goto 1
      if(gener.eq.'SEL+DDC2') goto 1
      if(gener.eq.'SEL+S') goto 1
      if(gener.eq.'SEL+SD') goto 1
      if(gener.eq.'CAS') goto 1
      if(gener.eq.'CAS+SD') goto 1
      if(gener.eq.'CAS+S') goto 1
      if(gener.eq.'CAS+DDCI') goto 1
      if(gener.eq.'CAS+DDC2') goto 1
      write(6,*)'variable gener incorrecte : ',gener
      stop
 1    continue
      ygmono=gener.eq.'MONO'.or.gener.eq.'CAS+S'.or.gener.eq.'SEL+S'
      ygcas=gener.eq.'CASV'.or.gener.eq.'CAS'.or.gener.eq.'SEL'
     *.or.ytp0

!
!*************************************************************
! Coherence de certaines donnees
!*************************************************************
!
      igener=0
      if(index(gener,'DDC2')>0) then
         igener=2
      elseif(index(gener,'DDCI')>0) then
         igener=3
      elseif(index(gener,'SD')>0) then
         igener=4
      elseif(gener=='CAS+S'.or.gener=='SEL+S') then
         igener=1
      endif
      if(mod(ms2,2).ne.mod(nelac,2)) then
         write(6,*)'parites de ms2 et nelac non egales'
         stop
      endif
      if(ms2+(nelac-ms2)/2.gt.noac+igener*2) then
         write(6,*) 'pas de place pour tous les electrons'
         write(6,*) 'au moins',ms2,' celibataires'
         write(6,*) '(nelac-ms2)/2=',(nelac-ms2)/2,' couches fermees'
         stop
      endif
      if(nprint.ge.1) open(46,file='cd_deter',status='UNKNOWN')
      if(is0.gt.nsymz.or.is0.lt.1) then
         write(6,*)'is0 hors limite'
         stop
      endif
      if(ms2.gt.0) then
         ms2=-ms2
         write(6,*)'ms2 doit etre negatif  on change son signe'
         write(6,*)'ms2',ms2
      endif
      do k=1,maxorbcas+2
         long(k)=(k-1)/2+1
      enddo
      nsto=0
      msto=0
      msto256=0
      nstov=0
      mstov=0
      jsp(-1,-2)=-2
      jsp( 0,-2)= 0
      jsp( 1,-2)= 2
      jsp(-1,-1)=-1
      jsp( 1,-1)= 1
      jsp(-1, 0)=-2
      jsp( 0, 0)= 0
      jsp( 1, 0)= 2
      jsp(-1, 1)=-1
      jsp( 1, 1)= 1
      jsp(-1, 2)=-2
      jsp( 0, 2)= 0
      jsp( 1, 2)= 2
      ksp(-2)=-1
      ksp(-1)=-1
      ksp( 0)= 0
      ksp( 1)= 1
      ksp( 2)= 1
 
      jsp(-2, 0)=-4
      jsp( 2, 0)= 4
      jsp(-2, 1)=-3
      jsp( 2, 1)= 3
      jsp(-2,-1)=-3
      jsp( 2,-1)= 3
      ksp(-4)=-2
      ksp(-3)=-2
      ksp( 4)= 2
      ksp( 3)= 2

!
!*************************************************************
c----------lecture de la file Info  (namelist ij)
!*************************************************************
!
      print*,' '
      print*,'-------------------------------------------------'
      print*,'          Lecture de la file Info'
      rewind 45
      call LECNAM('&COST_AO',namel,45,ierr,0)
      rewind 45
      call LECNAM('&COST_MO',namel1,45,ierr,0)
      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)
      if(ierr.eq.1) then
         print*,'Info absent'
         stop
      endif
      print'(a,i3)', 'nsym           ',nsym
      print'(a,i3)', 'norb           ',norb
      print'(a,i3)', 'noc            ',noc 
      call w_orb_sym(itsym,norb)
      print*,'-------------------------------------------------'
      print*,' '

!
!*************************************************************
! si on a donne numacsy et ninacsy au lieu de numac,
! calcul de Numac a partir de numacsy et ninacsy
!*************************************************************
!
      call fainumac(noac,numac,numacsy)
!
!*************************************************************
! Coherence de des donnees concernant les actives
!*************************************************************
!
      do k=1,noac
         if(numac(k).le.0.or.numac(k).gt.norb) then
            write(75,*)'mauvaise valeur pour numac : numac('
     *      ,k,') =',numac(k),'$'
             call scril
            stop
         endif
      enddo
      nelac1=0
      do k=1,noac
         if(numac(k).le.noc) nelac1=nelac1+2
         if(yw)print*,'k,numac(k),nelac1',k,numac(k),nelac1
      enddo
      nelac1=nelac1-mod(-ms2,2)
      if(nelac.ne.nelac1) then
         write(6,*)'mauvaise valeur de nelac'
         write(6,*)'nelac calcule : ',nelac1,
     *   '    nelac en donnee :',nelac,
     *   '    noac en donnee :',noac
         print*,'noc',noc
         write(6,*)'le niveau de Fermi est-il bien positionne dans',
     *   ' MOTRA ?'
         stop
      endif
!
!*************************************************************
! Calcul de quelques variables
!*************************************************************
!
      noca=noc-(-ms2+1)/2
      nocb=noc-ms2/2
      ninac=noc-(nelac+1)/2
      nca0=noca-ninac
      ncb0=nocb-ninac
c      print*,'ninac,noca,nocb,nca0,ncb0',ninac,noca,nocb,nca0,ncb0
C      do ideb=1,norb,20
C         ifin=min0(ideb+19,norb)
C         write(6,'(20i3)')(i,i=ideb,ifin)
C         write(6,'(20i3)')(itsym(i),i=ideb,ifin)
C         write(6,*) ' '
C      enddo
      print*,' '
      nvirt=norb-ninac-noac
!
!*************************************************************
! Cas "SEL"
!*************************************************************
!
c     Jose
c      print'('' avant mr1s yf_act'',l2)',yf_act
      if(ygmr) call mr1s
c     Jose
      if(yw)write(6,*)'ninac,nvirt',ninac,nvirt
!
!*************************************************************
c--------place des trous et des part
!*************************************************************
!
      do k=1,norb
         y(k)=.true.
      enddo
      do k=1,noac
         y(numac(k))=.false.
      enddo
      ll=0
      ntac=0
      do k=1,noc
         if(y(k)) then
            ll=ll+1
            numt(ll)=k
         else
            ntac=ntac+1
            nutac(ntac)=k
         endif
      enddo
      ll=0
      do k=noc+1,norb
         if(y(k)) then
            ll=ll+1
            nump(ll)=k
         endif
      enddo
      if(nprint.ge.1) then
         write(6,*)'numt',(numt(k),k=1,ninac)
         write(6,*)'nump',(nump(k),k=1,nvirt)
c--------trous actifs
         write(6,*)'nutac',(nutac(k),k=1,ntac)
      endif
      return
      end
       subroutine gen
      implicit real*8(a-h,o-x,z),logical*1 (y)
      parameter(maxorb=1024,nsymz=8)
      parameter(maxorbcas=16,maxdetc=12870)
      parameter (maxref=15000)
      common/occ/noac,nelac,numac(maxorbcas),is0,ninac,nvirt
     *,numt(maxorb),nump(maxorb),ntac,nutac(maxorbcas),ms2
      common/f4/norb,noc,noca,nocb,nca0,ncb0,ydet,ydetv,ydetcl
     *,ydetsc,yf_act,ywcas,ynosym,ytp0
      common/det/msto,nsto,mstov,nstov,idet(2400),nex(100),
     *long(maxorbcas+2),imono,ndet,msto256,
     *ncfmin,ncfmax
      common/sym/nsym,its(nsymz,nsymz),itsym(maxorb)
      common/util/jsp(-2:2,-2:2),ksp(-4:4)
      common/mr/nmr,nel,yref(-maxorb:maxorb,maxref)
      dimension nsa(maxorbcas,maxdetc)
      dimension nsb(maxorbcas,maxdetc)
      dimension ica(maxorbcas),icb(maxorbcas),
     *ita(2),itb(2),ipa(2),ipb(2)
      dimension it(20),ip(20),melc(5)
      dimension iispc(5)
      character*8 gener
      common/gene/gener,ygcas,ygmono,ygmr
      data melc /0,1,-1,2,-2/
      yw=.false.
      ndet=0
      ndetc=0
      
      if(ywcas)open(29,file='ESCASOU0',status='unknown')
!
!*************************************************************
! Boucle sur le nb d'ele en + ou en - dans le CAS
! kelc=1,5 ; nelc=melc(kelc)=0,1,-1,2,-2
!*************************************************************
!
      do 1 kelc=1,5
      if(yw)write(6,*)'kelc',kelc
      if(ygmono.and.kelc.ge.4) goto 1
      if(ygcas.and.kelc.ge.2) goto 1
      nelc=melc(kelc)
!
!*************************************************************
! appel vispc : 
! nispc = nb de valeurs prises par le spin du CAS
! iispc = differences possibles de spin entre un det CAS
!         et un det de reference
!*************************************************************
!
      call vispc(nelc,nispc,iispc)
      nelcas=nelac+nelc
      if(yw)write(6,*)'nelc,nelcas',nelc,nelcas
      if(yw)write(6,*)'nispc',nispc
!
!*************************************************************
! Boucle sur les valeurs possibles du spin du CAS
!*************************************************************
!
      do 3 ii=1,nispc
      ispc1=iispc(ii)
      ispc=jsp(ispc1,nelc)
c
c           -----------------------------------
c             GENERATION DU CAS
c           ----------------------------------
c
      ispcas=ms2+ispc
      if(yw)write(6,*)'ms2,ispc,ispcas',ms2,ispc,ispcas
      if(iabs(ispcas).gt.nelcas) goto 3
      nca=(nelcas+ispcas)/2
      ncb=(nelcas-ispcas)/2
      if(yw)write(6,*)'nelc,nelcas,ispcas,nca,ncb',
     *nelc,nelcas,ispcas,nca,ncb
      if(nca.gt.noac.or.ncb.gt.noac) goto 3
      call combin(nsa,noac,nca,na,maxorbcas,maxdetc)
      call combin(nsb,noac,ncb,nb,maxorbcas,maxdetc)
      if(yw)write(6,*)'na,nb',na,nb
      do 10 ia=1,na
      isca=1
      do k=1,nca
         if(yw)
     *   write(6,*)'ia,nsa(k,ia)',ia,(nsa(kk,ia),kk=1,nca)
         ica(k)=numac(nsa(k,ia))
         isca=its(isca,itsym(ica(k)))
      enddo
      do 11 ib=1,nb
      iscb=1
      do k=1,ncb
         if(yw)
     *   write(6,*)'ib,nsb(k,ib)',ib,(nsb(kk,ib),kk=1,ncb)
         icb(k)=numac(nsb(k,ib))
         iscb=its(iscb,itsym(icb(k)))
      enddo
      isc=its(isca,iscb)
      if(yw) then
         write(75,*)'CAS',(ica(k),k=1,nca),'   ',(-icb(k),k=1,ncb),'$'
         call scril
         write(75,*)'isc,ispcas,ispc,ispc1',isc,ispcas,ispc,ispc1,'$'
         call scril
      endif
      mint=0
      minp=0
      maxt=2
      maxp=2
      if(ygmr) call mr2s(nca,ncb,ica,icb,mint,minp,
     *maxt,maxp)
      if(yw)print*,'mint,minp',mint,minp
      if(yw)print*,'maxt,maxp',maxt,maxp
c
c              -----------------------------------
c                GENERATION DES TROUS
c              ----------------------------------
c
      do 4 nt=mint,maxt
      if(ygcas.and.nt.ne.0) goto 4
      if(ygmono.and.nt.eq.2) goto 4
      np=nt-nelc
      if(ygmono.and.np.eq.2) goto 4
      if(yw)write(6,*)'nt,np',nt,np
      if(np.gt.maxp) goto 4
      if(np.lt.minp) goto 4
      if(gener.eq.'DDC2'.or.gener(5:8).eq.'DDC2') then
         if(nt.ge.2.and.np.ge.1) goto 4
         if(nt.ge.1.and.np.ge.2) goto 4
      else if(ygmono) then
         if(nt.gt.1.or.np.gt.1) goto 4
      endif
      if(nt.eq.2.and.np.eq.2) then
         if(gener.eq.'PERT') then
            if(isc.ne.is0) goto 4
            if(ispc.ne.0) goto 4
         else if(gener.eq.'DDCI'.or.gener.eq.'DDci'
     *   .or.gener(5:8).eq.'DDCI') then
            goto 4
         endif
      endif
      ipast=1
      if(nt.eq.1) ipast=2
      do 6 ispt1=-1,1,ipast
      if(yw)write(6,*)'ispt1',ispt1
      ispt=jsp(ispt1,nt)
      if(iabs(ispt).gt.nt) goto 6
      if(yw)write(6,*)'ispt',ispt
      nta=(nt+ispt)/2
      ntb=(nt-ispt)/2
      ispp=ispt-ispc
      if(iabs(ispp).gt.np) goto 6
      npa=(np+ispp)/2
      npb=(np-ispp)/2
      if(yw)write(6,*)'nta,ntb,npa,npb',nta,ntb,npa,npb
      ispp1=ksp(ispp)
      ideb2=1
      if(nt.eq.0) then
         ifin1=1
         ifin2=1
      else
         ifin1=ninac
         ifin2=1
      endif
      if(yw)write(6,*)'ifin1',ifin1
      ist=1
      do 21 jt1=1,ifin1
      it1=numt(jt1)
      if(nta.ne.0) ita(1)=it1
      if(ntb.ne.0.and.nta.eq.0) itb(1)=it1
      if(nt.eq.2) then
         ifin2=ninac
         if(ispt.ne.0) then
            ideb2=jt1+1
         else
            ideb2=1
         endif
      endif
      if(yw)write(6,*)'ideb2,ifin2',ideb2,ifin2
      if(nt.ge.1)ist=itsym(it1)
      do 22 jt2=ideb2,ifin2
      it2=numt(jt2)
      if(nta.eq.2) then
         ita(2)=it2
      endif
      if(ntb.eq.1) then
         if(nta.eq.1) itb(1)=it2
      else if(ntb.eq.2) then
         itb(2)=it2
      endif
      if(nt.ge.2)ist=its(itsym(it1),itsym(it2))
      if(yw)
     *write(6,*)'it1,itsym(it1)',it1,itsym(it1)
      if(yw)
     *write(6,*)'TROU',(ita(k),k=1,nta),'   ',
     *(-itb(k),k=1,ntb)
      if(yw)write(6,*)'ist,ispt',ist,ispt
c
c                          -----------------------------------
c                            GENERATION DES PARTICULES
c                          ----------------------------------
c
      isct=its(isc,ist)
      if(yw)write(6,*)'np,isct,ispp',np,isct,ispp
      if(np.eq.0.and.isct.ne.is0) goto 22
      isp=its(is0,isct)
      ideb1p=1
      if(np.eq.0) then
         ifin1p=ideb1p
      else
         ifin1p=nvirt
      endif
      if(yw)write(6,*)'ideb1p,ifin1p',ideb1p,ifin1p
      do 23 jp1=ideb1p,ifin1p
      ip1=nump(jp1)
      if(npa.ne.0) ipa(1)=ip1
      if(npa.eq.0) ipb(1)=ip1
      ideb2p=1
      ifin2p=ideb2p
      if(np.eq.2) then
         ifin2p=nvirt
         if(ispp.ne.0) ideb2p=jp1+1
      endif
      if(yw)
     *write(6,*)'ideb2p,ifin2p',ideb2p,ifin2p
      do 24 jp2=ideb2p,ifin2p
      ip2=nump(jp2)
      if(npa.eq.2) then
         ipa(2)=ip2
      endif
      if(npb.eq.1) then
         if(npa.eq.1) then
            ipb(1)=ip2
         endif
      else if(npb.eq.2) then
         ipb(2)=ip2
      endif
      isp1=1
      if(np.eq.1) then
         isp1=itsym(ip1)
      else if(np.eq.2) then
         isp1=its(itsym(ip1),itsym(ip2))
      endif
      if(isp1.ne.isp) goto 24
c                                if(its(itsym(ip1),itsym(ip2)).ne.isp)
c     *                           goto 24
      ndet=ndet+1
      if(nt.eq.0.and.np.eq.0) ndetc=ndetc+1
      if(yw)call wrdet(nca,ncb,ica,icb,nta,ntb,ita,
     *itb,npa,npb,ipa,ipb)
      call wrcas(nca,ncb,ica,icb,nta,ntb,ita,
     *itb,npa,npb,ipa,ipb)
      call tradnv
     *(nca,ncb,ica,icb,nta,ntb,ita,
     *itb,npa,npb,ipa,ipb,it,ip)
 24   continue
 23   continue
 22   continue
 21   continue
 6    continue
 4    continue
 11   continue
 10   continue
 3    continue
 1    continue
      print*,' '
      write(6,*)'**************************************'
      write(6,*)'*******      fin de casdet    ********'
      write(6,*)' nombre de determinants generes',ndet
      write(6,*)' nombre de determinants du CAS ',ndetc
      if(gener(1:3).eq.'SEL')
     *write(6,*)' nombre de determinants SEL   ',nmr
      write(6,*)'**************************************'
      return
      end
       subroutine vispc(nelc,nispc,iispc)
      implicit real*8(a-h,o-x,z),logical*1 (y)
      character*8 gener
      common/gene/gener,ygcas,ygmono,ygmr
      dimension iispc(5)
!
!*************************************************************
! En entree : nelc      
! En sortie :
! nispc = nb de valeurs possibles du spin (sa deviation par
!         rapport aux det de reference)
! iispc(1:nispc) = valeurs possibles du spin (sa deviation par
!         rapport aux det de reference)
!*************************************************************
!
      if(ygcas) then
         nispc=1
         iispc(1)=0
         return
      endif
      if(nelc.eq.0) then
         if(gener.eq.'PERT'.or.gener.eq.'DDci'.or.gener.eq.'DDCI'
     *   .or.gener.eq.'DDC2'.or.gener.eq.'MONO'
     *   .or.gener(5:7).eq.'DDC'.or.gener.eq.'SEL+S'
     *    .or.gener.eq.'CAS+S'
     *    ) then
            nispc=3
            iispc(1)=-1
            iispc(2)=0
            iispc(3)=1
         else if (gener.eq.'TOUS'.or.gener.eq.'SEL+SD'
     *   .or.gener.eq.'CAS+SD') then
            nispc=5
            iispc(1)=-2
            iispc(2)=-1
            iispc(3)=0
            iispc(4)=1
            iispc(5)=2
         endif
      else if(iabs(nelc).eq.1) then
         if(gener.eq.'PERT'.or.gener.eq.'DDci')
     *   then
            nispc=2
            iispc(1)=-1
            iispc(2)=1
         else if (gener.eq.'TOUS'.or.gener.eq.'DDCI'
     *      .or.ygmr
     *      .or.gener.eq.'DDC2'.or.gener.eq.'MONO'
     *      ) then
            nispc=4
            iispc(1)=-2
            iispc(2)=-1
            iispc(3)=1
            iispc(4)=2
         endif
      else if(iabs(nelc).eq.2) then
         nispc=3
         iispc(1)=-1
         iispc(2)=0
         iispc(3)=1
      endif
      return
      end
       subroutine tradnv(nca,ncb,ica,icb,nta,ntb,ita,itb,npa,npb,ipa,ipb
     *,it,ip)
      parameter(maxorb=1024,nsymz=8)
      parameter(maxorbcas=16,maxdetc=12870)
      implicit real*8(a-h,o-x,z),logical*1 (y)
      common/occ/noac,nelac,numac(maxorbcas),is0,ninac,nvirt
     *,numt(maxorb),nump(maxorb),ntac,nutac(maxorbcas),ms2
      common/f4/norb,noc,noca,nocb,nca0,ncb0,ydet,ydetv,ydetcl
     *,ydetsc,yf_act,ywcas,ynosym,ytp0
      common/det/msto,nsto,mstov,nstov,idet(2400),nex(100),
     *long(maxorbcas+2),imono,ndet,msto256,
     *ncfmin,ncfmax
      common/print/nprint
      dimension ica(nca),icb(ncb),ita(nta),itb(ntb),ipa(npa),ipb(npb)
      dimension it(20),ip(20)
      integer*2 it2(20),ip2(20)
      dimension ya(maxorb),yb(maxorb)
      character*1 sgna(maxorbcas+2),sgnb(maxorbcas+2)
      yw=.false.
      net=0
      nep=0
      if(yw)then
         print*,'nca,ncb',nca,',',ncb
         print*,'ica,icb',ica,',',icb
         print*,'ita,itb',ita,',',itb
         print*,'ipa,ipb',ipa,',',ipb
      endif
      do i=1,nta
         net=net+1
         it(net)=ita(i)
      enddo
      do i=1,ntb
         net=net+1
         it(net)=itb(i)+norb
      enddo
      if(yw)write(6,*)'trad it',(it(k),k=1,net)
      do i=1,npa
         nep=nep+1
         ip(nep)=ipa(i)
      enddo
      do i=1,npb
         nep=nep+1
         ip(nep)=ipb(i)+norb
      enddo
c         print*,'nca,ncb',nca,',',ncb
      if(yw)write(6,*)'trad ip',(ip(k),k=1,nep)
      do k=1,norb
         ya(k)=.false.
         yb(k)=.false.
      enddo
      do i=1,nca
         if(ica(i).gt.noc) then
            nep=nep+1
            ip(nep)=ica(i)
         else
            ya(ica(i))=.true.
         endif
      enddo
      if(yw)write(6,'('' trad ya'',40l1)')(ya(k),k=1,norb)
c         print*,'nca,ncb',nca,',',ncb
      do i=1,ncb
         if(icb(i).gt.noc) then
            nep=nep+1
            ip(nep)=icb(i)+norb
         else
            yb(icb(i))=.true.
         endif
      enddo
      if(yw)write(6,'('' trad yb'',40l1)')(yb(k),k=1,norb)
      if(yw)call flush(6)
      do i=1,ntac
         if(.not.ya(nutac(i))) then
            net=net+1
            it(net)=nutac(i)
         endif
      enddo
      if(yw)write(6,*)'trad it',(it(k),k=1,net)
      if(yw)call flush(6)
      do i=1,ntac
         if(.not.yb(nutac(i))) then
            net=net+1
            it(net)=nutac(i)+norb
         endif
      enddo
      if(yw)write(6,*)'trad it',(it(k),k=1,net)
      call reor(net,it)
      call reor(nep,ip)
      if(mod(nelac,2).eq.1) then
         nep=nep+1
         ip(nep)=norb+norb+1
      endif
      if(yw)
     *write(6,*)'T/P',net,nep,'   ',(it(k),k=1,net),(ip(k),k=1,nep)
c     write(3,*)'T/P',net,nep,'   ',(it(k),k=1,net),(ip(k),k=1,nep)
      if(ydet) call pie2(net,it,ip)
      if(ydetv) call pie(net,it,ip)
      if(ydetcl) then
         write(61) net
         if(net.ne.0)write(61)(it(k),k=1,net),(ip(k),k=1,nep)
      endif
      if(ydetsc) then
         if(ndet.eq.1) then
            write(63) 0
         endif
         if(net.ne.0) then
            write(63) net
         endif
         do k=1,net
            it2(k)=it(k)
         enddo
         do k=1,nep
            ip2(k)=ip(k)
         enddo
         if(net.ne.0)write(63)(it2(k),k=1,net),(ip2(k),k=1,nep)
      endif
      if(nprint.ge.1) then
         do k=1,net
            if(it(k).gt.norb) then
               sgna(k)='-'
            else
               sgna(k)='+'
            endif
            if(ip(k).gt.norb) then
               sgnb(k)='-'
            else
               sgnb(k)='+'
            endif
         enddo
         do k=1,net
            if(it(k).gt.norb) it(k)=it(k)-norb
            if(ip(k).gt.norb) ip(k)=ip(k)-norb
         enddo
         if(net.eq.0)write(46,10)
         if(net.eq.1)write(46,11)(it(k),sgna(k),k=1,net)
     *   ,(ip(k),sgnb(k),k=1,nep)
         if(net.eq.2)write(46,12)(it(k),sgna(k),k=1,net)
     *   ,(ip(k),sgnb(k),k=1,nep)
         if(net.eq.3)write(46,13)(it(k),sgna(k),k=1,net)
     *   ,(ip(k),sgnb(k),k=1,nep)
         if(net.eq.4)write(46,14)(it(k),sgna(k),k=1,net)
     *   ,(ip(k),sgnb(k),k=1,nep)
         if(net.eq.5)write(46,15)(it(k),sgna(k),k=1,net)
     *   ,(ip(k),sgnb(k),k=1,nep)
         if(net.eq.6)write(46,16)(it(k),sgna(k),k=1,net)
     *   ,(ip(k),sgnb(k),k=1,nep)
         if(net.eq.7)write(46,17)(it(k),sgna(k),k=1,net)
     *   ,(ip(k),sgnb(k),k=1,nep)
         if(net.eq.8)write(46,18)(it(k),sgna(k),k=1,net)
     *   ,(ip(k),sgnb(k),k=1,nep)
         if(net.eq.9)write(46,19)(it(k),sgna(k),k=1,net)
     *   ,(ip(k),sgnb(k),k=1,nep)
         if(net.eq.10)write(46,20)(it(k),sgna(k),k=1,net)
     *   ,(ip(k),sgnb(k),k=1,nep)
         if(net.eq.11)write(46,21)(it(k),sgna(k),k=1,net)
     *   ,(ip(k),sgnb(k),k=1,nep)
         if(net.eq.12)write(46,22)(it(k),sgna(k),k=1,net)
     *   ,(ip(k),sgnb(k),k=1,nep)
 10      format('F')
 11      format('M',16(i3,a1))
 12      format('D',16(i3,a1))
 13      format('T',16(i3,a1))
 14      format('Q',16(i3,a1))
 15      format('P',16(i3,a1))
 16      format('H',16(i3,a1))
 17      format('7',16(i3,a1))
 18      format('O',16(i3,a1))
 19      format('9',18(i3,a1))
 20      format('10',20(i3,a1))
 21      format('11',22(i3,a1))
 22      format('12',24(i3,a1))
      endif
      return
      end
       subroutine reor(n,it)
      IMPLICIT REAL*8(A-H,O-X,Z),LOGICAL*1 (Y)
      dimension it(n)
      do 1 i=1,n-1
      do 2 j=i+1,n
      if(it(j).ge.it(i)) goto 2
      ii=it(i)
      it(i)=it(j)
      it(j)=ii
 2    continue
 1    continue
      return
      end
       subroutine wrdet(nca,ncb,ica,icb,nta,ntb,ita,itb,npa,npb,ipa,ipb)
      implicit real*8(a-h,o-x,z),logical*1 (y)
      dimension ica(nca),icb(ncb),ita(nta),itb(ntb),ipa(npa),ipb(npb)
      write(6,*)'-------------determinant----------------'
      write(75,*)'T',(ita(k),k=1,nta),'  ',(-itb(k),k=1,ntb),
     *'    C',(ica(k),k=1,nca),'  ',(-icb(k),k=1,ncb),
     *'    P',(ipa(k),k=1,npa),'  ',(-ipb(k),k=1,npb),'$'
      call scril
c      write(2,*)'T',(ita(k),k=1,nta),'  ',(-itb(k),k=1,ntb),
c     *'    C',(ica(k),k=1,nca),'  ',(-icb(k),k=1,ncb),
c     *'    P',(ipa(k),k=1,npa),'  ',(-ipb(k),k=1,npb)
      return
      end
       subroutine wrcas(nca,ncb,ica,icb,nta,ntb,ita,itb,npa,npb,ipa,ipb)
      implicit real*8(a-h,o-x,z),logical*1 (y)
      parameter (maxorbcas=16)
      dimension ica(nca),icb(ncb),ita(nta),itb(ntb),ipa(npa),ipb(npb)
      dimension yeq(maxorbcas),jca(maxorbcas),jcb(maxorbcas)
      common/f4/norb,noc,noca,nocb,nca0,ncb0,ydet,ydetv,ydetcl
     *,ydetsc,yf_act,ywcas,ynosym,ytp0
      save nwcas
      character*1000 namel
      data nwcas /1/
      if(nta+ntb+npa+npb.eq.0) then
         do k=1,nca
            jca(k)=ica(k)
         enddo
         do k=1,ncb
            jcb(k)=icb(k)
         enddo
         do k=1,nca
            do l=1,ncb
               if(jca(k).eq.jcb(l)) then
                  jca(k)=0
                  jcb(l)=0
               endif
            enddo
         enddo
         do k=1,nca
            do l=1,ncb
               if(jcb(l).ne.0.and.jca(k).gt.jcb(l)) then
                  return
               endif
            enddo
         enddo
         write(namel,1000)(ica(k),k=1,nca),(icb(k),k=1,ncb)
 1000    format(40(i4,','))
         kk=0
         do k=1,(nca+ncb)*5
            if(namel(k:k).ne.' ') then
               kk=kk+1
               namel(kk:kk)=namel(k:k)
            endif
         enddo
         nwcas=nwcas+1
         if(ywcas) then
            if(kk.gt.70) then
               write(29,'(a9)') ' &mrs ic='
               write(29,'(1x,a,i6)') namel(1:kk),nwcas
            else
               write(29,'(a9,a,''  /'',i6)') ' &mrs ic=',namel(1:kk)
c            write(6,'(a9,a,''  /'',i6)') ' &mrs ic=',namel(1:kk),nwcas
            endif
         endif
      endif
      return
      end
 
 
       subroutine combin(NS1,N,M,NT,MD,ND)
c------------------------------------------------------------------
c     Parametres en sortie :
c     NS1 = vecteur ds lequel sont notes les determinants trouves
c     NT  = nb de determinants
c     Parametres en entree :
c     N   = nb d'orbitales
c     M   = nb d'electrons
c     MD  = nb d'electrons max (=maxelcas)
c     ND  = nb de det. max (=C8 16=12870)
c------------------------------------------------------------------
      INTEGER*4 NS1(MD,ND)
c     write(6,*)'combin,n,m',n,m
      if(M.eq.0)then
         nt=1
         goto 7
      endif
      I=1
      DO 1 J=1,M
1     NS1(j,i)=J
5     CONTINUE
      J1=0
      DO 3 J=1,M
 3    IF(NS1(j,i).EQ.N-M+J) J1=J1+1
      IF(J1.EQ.M) GOTO 4
      I=I+1
      DO 2 J=1,M
2     NS1(j,i)=NS1(j,I-1)
      NS1(m-j1,I)=NS1(m-j1,I-1)+1
      IF(J1.EQ.0) GOTO 5
      MMJ1=M-J1+1
      DO 6 J=MMJ1,M
6     NS1(j,I)=NS1(j-1,I)+1
      GOTO 5
4     CONTINUE
      NT=I
7     continue
 
      RETURN
      END
       subroutine pie(nec,nts,nps)
c
c
c         subroutine che compatta i determinanti e li scrive su tape 60
c
c
      implicit real*8(a-h,o-x,z),logical*1(y)
      parameter(maxorb=1024,nsymz=8,maxorbcas=16)
      character*1 ylog
      common/det/msto,nsto,mstov,nstov,idet(2400),nex(100),
     *long(maxorbcas+2),imono,ndet,msto256,
     *ncfmin,ncfmax
      dimension ylog(maxorbcas*2+4),iv(maxorbcas/2+1),
     *nts(maxorbcas+2),nps(maxorbcas+2)
      equivalence(ylog(1),iv(1))
      data lungo/100/
c     write(6,*)'nec,nts,nps',nec,(nts(ii),ii=1,nec),(nps(ii),ii=1,nec)
      if(nec.eq.0) go to 10
      lon=long(nec)
      do 1 i=1,lon
      iv(i)=0
 1    continue
      do 2 i=1,nec
      i4=nts(i)
      ylog(i)=char(i4)
      i4=nps(i)
      ylog(i+nec)=char(i4)
 2    continue
c      write(6,1023) (ylog(i),i=1,2*nec)
c 1023 format(40a2)
      do 3 k=1,lon
      mstov=mstov+1
      idet(mstov)=iv(k)
 3    continue
 10   continue
      nstov=nstov+1
      nex(nstov)=nec
      if(nstov.lt.lungo) return
      write(62)mstov,nstov,(idet(i),i=1,mstov),
     *(nex(i),i=1,nstov),(1.d0,i=1,nstov)
      mstov=0
      nstov=0
      return
      entry fine
      if(nstov.eq.0) return
      write(62) mstov,nstov,(idet(i),i=1,mstov),
     *(nex(i),i=1,nstov),(1.d0,i=1,nstov)
      mstov=0
      nstov=0
      return
      END
       subroutine pie2(nec,nts,nps)
c
c
c         subroutine che compatta i determinanti e li scrive su tape 60
c         version en caracteres
c
c
      implicit real*8(a-h,o-x,z),logical*1(y)
      parameter(maxorb=1024,lungo=100,maxorbcas=16,maxnec=maxorbcas+2)
      character*1 ctps,cex,c256
      common/det2/ctps((maxnec)*lungo*2),cex(lungo)
     *,c256((maxnec/4+1)*lungo)
      common/det/msto,nsto,mstov,nstov,idet(2400),nex(100),
     *long(maxorbcas+2),imono,ndet,msto256,
     *ncfmin,ncfmax
      common/f4/norb,noc,noca,nocb,nca0,ncb0,ydet,ydetv,ydetcl
     *,ydetsc,yf_act,ywcas,ynosym,ytp0
      dimension nts(maxnec),nps(maxnec)
      dimension nt(maxnec),np(maxnec),np1024(maxnec)
      yw=.false.
      yw1=.false.
      if(yw)write(6,'(a20,40i4)')'pie2 det v',(nts(k),k=1,nec),
     *(nps(k),k=1,nec)
c     ====================================
c     on note ou commencent les spins beta
c     ====================================
      ms=nec+1
      if(ms.gt.maxnec+2)stop 'dans pie2   CAS trop grand'
      do k=1,nec
         if(nts(k).gt.norb) then
            ms=k
            goto 1
         endif
      enddo
 1    continue
c     ====================================
c     on supprime les spins beta
c     ====================================
      do k=1,nec
         if(nts(k).gt.norb) then
            nt(k)=nts(k)-norb
         else
            nt(k)=nts(k)
         endif
         if(nps(k).gt.norb) then
            np(k)=nps(k)-norb
         else
            np(k)=nps(k)
         endif
      enddo
c--
      if(yw1)write(6,'(a20,40i4)')'pie2 det n',(nt(k),k=1,nec),
     *(np(k),k=1,nec)
c     ===========================================
c     on incremente le nombre de determinants
c     ===========================================
      nsto=nsto+1
c     ===========================================
c     codage en caracteres de ne et du nb d'alpha
c     ===========================================
c      necms=ms+nec*maxnec
      necms=nec*(nec+1)/2+ms
      if(yw)print*,'necms,ms,nec,maxnec',necms,ms,nec,maxnec
      cex(nsto)=char(necms)
c     ===========================================
c     codage en caracteres des trous
c     ===========================================
      do k=1,nec
         msto=msto+1
         ctps(msto)=char(nt(k))
      enddo
c     ===========================================
c     codage en caracteres des particules
c     ===========================================
      if(norb.le.256) then
         do k=1,nec
            msto=msto+1
            ctps(msto)=char(np(k))
         enddo
      else
         do k=1,nec
            msto=msto+1
            np256=np(k)
            call corr1024(np256,np1024(k))
            ctps(msto)=char(np256)
         enddo
c        ===========================================
c        codage en caracteres des orbitales > 256
c        ===========================================
         do k=1,nec,4
            msto256=msto256+1
            i256=0
            kkk=0
            do kk=k,min(k+3,nec)
               i256=i256+np1024(kk)*4**kkk
               if(yw)print*,'i256',i256
               kkk=kkk+1
            enddo
            c256(msto256)=char(i256)
         enddo
      endif
      if(nsto.eq.lungo) then
         write(60)msto,nsto,(ctps(i),i=1,msto),(cex(i),i=1,nsto)
     *   ,msto256,(c256(i),i=1,msto256)
c     print*,'ecriture pie2', nsto,msto
c          print*,'ecriture 60',nsto,msto
         msto=0
         msto256=0
         nsto=0
      endif
      return
      entry fine2
      if(nsto.eq.0) return
      write(60) msto,nsto,(ctps(i),i=1,msto),(cex(i),i=1,nsto)
     *,msto256,(c256(i),i=1,msto256)
c     print*,'fin ecriture pie2', nsto,msto
c        print*,'fine ecriture 60',nsto,msto
      msto=0
      msto256=0
      nsto=0
      return
      end
!       subroutine scril
!      parameter(nligne=100)
!c      character*500 scr500(10)
!      character*80 scr500(nligne)
!      common/sri/ scr500
!c      print *, 'entree scril'
!      rewind 75
!      read(75,'(a80)',err=2,end=2) scr500
!  2   continue
!c     close(75,status='DELETE')
!      rewind 75
!      call scri(scr500)
!      return
!      end
!       subroutine scri(scr)
!      parameter(nligne=100)
!      character*1 scr(80*nligne),scr1(80*nligne)
!      common/sri/scr1
!      ifil=6
!      k=1
!      scr1(1)=scr(1)
!      do i=2,8000
!c        write(6,*)'SCR',i,'    ',scr(i)
!         if(scr(i).eq.'$') goto 1
!         if(scr(i).eq.' ') then
!            if(scr(i-1).eq.' ') goto 2
!c           write(6,*)'scr(i-1)',scr(i-1)
!         endif
!         k=k+1
!c        write(6,*)'k',k
!         scr1(k)=scr(i)
!c        write(6,*)'scr(i),scr1(k)',scr(i)
! 2       continue
!      enddo
!c     pas de '$' trouve
!      write(6,*)'ecriture formattee sans ''$'' a la fin'
!      return
! 1    continue
!c      write(6,*)k
!      write(6,'(80a1)')(scr1(l),l=1,k)
!      return
!      end
       subroutine corr1024(ni,icorr)
      icorr=(ni-1)/256
      if(ni.le.256) return
      ni=mod(ni,256)
      if(ni.eq.0) ni=ni+256
      return
      end
 
       subroutine openf
      character*80 ligne
      character*40 prefix,cdi,detcl,det,refmr,detv,detsc
      character*40 cdi1,detcl1,det1,blan40,Info,Info1,cas,cas1,
     *refmr1,detv1,detsc1
      namelist /cdfil/ prefix,cdi,cas,cas1,
     *cdi1,detcl1,detcl,det,det1,info,info1,refmr,refmr1,detv,detv1
     *,detsc,detsc1
      common/ref2/refmr1,refmr,prefix
      character*1280 namel
c      write(6,*)'entree dans openf'
      blan40='                                        '
      refmr1=blan40
      cdi1=blan40
      cas1=blan40
      detcl1=blan40
      detsc1=blan40
      det1=blan40
      detv1=blan40
      refmr='refmr     '
      cdi='cdi       '
      cas='cas       '
      det='det       '
      detv='detv      '
      info='Info      '
      info1=blan40
      detcl='detcl     '
      detsc='detsc     '
      prefix=blan40
c     read(94,cdfil)
      rewind 94
      call LECNAM('&CDFIL',namel,94,ierr,1)
      if(ierr.eq.1) then
         print*,'namelist cdfil absente'
         stop
      endif
      call namela(namel,prefix,'PREFIX')
      if(prefix(1:1).eq.' ') then
         print*,'prefix doit etre donne'
         stop
      endif
      call namela(namel,cdi1,'CDI1')
      call namela(namel,detcl1,'DETCL1')
      call namela(namel,detsc1,'DETSC1')
      call namela(namel,detv1,'DETV1')
      call namela(namel,det1,'DET1')
      call namela(namel,cas1,'CAS1')
      call namela(namel,info1,'INFO1')
      call namela(namel,refmr1,'REFMR1')
      call namela(namel,cdi,'CDI')
      call namela(namel,detcl,'DETCL')
      call namela(namel,detsc,'DETSC')
      call namela(namel,detv,'DETV')
      call namela(namel,det,'DET')
      call namela(namel,cas,'CAS')
      call namela(namel,INFO,'INFO')
      call namela(namel,refmr,'REFMR')
c     write(6,cdfil)
      open(28,form='formatted',file='CASOUT',status='unknown')
      call nomfil(4,cdi,cdi1,prefix,'UNKNOWN   ','FORMATTED  ')
      call nomfil(45,info,info1,prefix,'OLD       ','FORMATTED  ')
      call nomfil(61,detcl,detcl1,prefix,'UNKNOWN   ','UNFORMATTED')
      call nomfil(63,detsc,detsc1,prefix,'UNKNOWN   ','UNFORMATTED')
      call nomfil(60,det,det1,prefix,'UNKNOWN   ','UNFORMATTED')
      call nomfil(62,detv,detv1,prefix,'UNKNOWN   ','UNFORMATTED')
c      call nomfil(65,cas,cas1,prefix,'UNKNOWN   ','UNFORMATTED')
      return
      end
       subroutine nomfil(iunit,racine,file1,prefix,status,form)
      character*1 prefix(40),racine(40)
      character*10 status
      character*11 form
      character*40 file1,blan40
      character*50 file
      character*1  fil(50)
      equivalence (fil(1),file)
c      namelist /tes/ file1,blan40
      blan40='                                        '
      file='                                                  '
C      OPEN FILES
      call nomf(fil,prefix,racine)
c     write(6,tes)
c     write(6,*)'file1=',file1
c     if(file1.eq.blan40)write(6,*)'Egalite'
      if(file1.eq.blan40) file1=file
c     write(6,*)'file1   ',file1
c     write(6,*)'blan40  ',blan40
c     write(6,tes)
c      if(file1.eq.blan40)write(6,*)'Egalite'
c     write(6,*)'ouverture de la file',iunit
c     write(6,*)fil,iunit,racine,status,file1
      write(75,*)'ouverture de la file',iunit,' ',file1,status,'$'
      call scril
      OPEN (UNIT=iunit,STATUS=status,file=file1,form=form)
c     write(6,*)'fin ouverture des files'
      return
      end
       subroutine nomf(fil,prefix,racine)
      character*1 prefix(40),racine(40),blanc,fil(50)
      blanc= ' '
      do 1 i=1,40
      if(prefix(i).eq.blanc)then
         do 2 j=1,i-1
         fil(j)=prefix(j)
 2       continue
         k=i-1
         goto 3
      endif
 1    continue
 3    continue
      do 4 i=1,40
      if(racine(i).eq.blanc) then
         do 5 j=1,i-1
         fil(k+j)=racine(j)
 5       continue
         k=k+i-1
         goto 6
      endif
 4    continue
 6    continue
c     write(6,*)fil
      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
