      subroutine preselec
      implicit real*8(a-h,o-x,z),logical*1 (y)
      parameter(maxorb=1024,nsymz=8)
      parameter(maxorbcas=16)
      common/pres/ presel
      character*4 presel
      common/print/nprint
      common/f4/norb,noc,noca,nocb,nca0,ncb0,ydet,ydetv,ydetcl
     *,ydetsc,yf_act,ywcas,ynosym,ytp0
      common/occ/noac,nelac,numac(maxorbcas),is0,ninac,nvirt
     *,numt(maxorb),nump(maxorb),ntac,nutac(maxorbcas),ms2
      dimension icamun(maxorb)
      character*80 ligne
      character*10000 namel
      dimension ioc(maxorbcas),ic(maxorbcas*2),ioc1(maxorbcas)
      dimension it(2),ip(2)
      character*8 gener
      common/gene/gener,ygcas,ygmono,ygmr
      yw=.false.
c
      do k=1,norb
         icamun(k)=0
      enddo
      do k=1,noac
         icamun(numac(k))=k
      enddo
      if(yw) then
      do k=1,norb
         print*,'icamun',k,icamun(k)
      enddo
      endif
c
c     lecture des determinants en donnee
c
      
      rewind 94
      print*,' '
      print*,'============================================ '
      print*,'    DETERMINANTS DONNES PAR PRESELECTION '
      print*,'============================================ '
      print*,' '
      
      open(55,file='PRESEL',status='unknown',form='formatted')
      print*,'-----------------------------------------------'
     *//'-------------------------'
      print*,' variable presel (S ou SD) ',presel
      print*, ' '
      print*,' Determinants generateurs en donnee '
      ndetsel=0
      ndets=0
      ndetsd=0

c     Boucle sur la lecture des det selectiones (lable 11)

 11   continue
      call LECNAM('&MRSEL ',namel,94,ierr,0)
      if(ierr.eq.1) goto 2
      ndetsel=ndetsel+1
      call nameli(namel,IC,'IC',4)
      write(75,*)(ic(k),k=1,nelac),'$'
      call scril

! Test d'erreur de donnee
      do k=1,nelac
         if(icamun(ic(k)).eq.0) then
            print*,' Erreur'
            print*,' Un indice du determinant en donnee ne'//
     *      ' correspond pas a une orbitale active'
            write(75,*)'ic(',k,')=',ic(k),'$'
            call scril
            close(55,status='delete')
            stop
         endif
      enddo
!
      do k=1,nelac
         ic(k)=icamun(ic(k))
      enddo
 1    continue
c
      do k=1,noac
         ioc(k)=0
      enddo
      do k=1,nelac
         ioc(ic(k))=ioc(ic(k))+1
      enddo
c       write(75,*)'ioc',(ioc(k),k=1,noac),'$'
c       call scril
      call ecrmrs(ioc)

c     exitations
      do i=1,noac
         if(ioc(i).ne.0) then
            it(1)=i
            do j=1,noac
               if(i.eq.j) cycle
               if(ioc(j).ne.2) then
                  ip(1)=j
                  do k=1,noac
                     ioc1(k)=ioc(k)
                  enddo
                  ioc1(it(1))=ioc1(it(1))-1
                  ioc1(ip(1))=ioc1(ip(1))+1
                  if(yw)write(75,*)'ioc1',(ioc1(k),k=1,noac),'$'
                  if(yw)call scril
                  call ecrmrs(ioc1)
                  ndets=ndets+1
               endif
            enddo
         endif
      enddo
      if(presel.eq.'SD') then
         do i=1,noac
            it(1)=i
            do j=1,noac
               it(2)=j
               do k=1,noac
                  if(i.eq.k) goto 13
                  ip(1)=k
                  do l=1,noac
                     if(j.eq.l) goto 14
                     ip(2)=l
                     do kk=1,noac
                        ioc1(kk)=ioc(kk)
                     enddo
                     if(ioc1(it(1)).eq.0) goto 14
                     ioc1(it(1))=ioc1(it(1))-1
                     if(ioc1(ip(1)).eq.2) goto 14
                     ioc1(ip(1))=ioc1(ip(1))+1
                     if(ioc1(it(2)).eq.0) goto 14
                     ioc1(it(2))=ioc1(it(2))-1
                     if(ioc1(ip(2)).eq.2) goto 14
                     ioc1(ip(2))=ioc1(ip(2))+1
                     if(yw) then
                        write(75,*)'ioc1',(ioc1(kk),kk=1,noac),'$'
                        call scril
                     endif
                     call ecrmrs(ioc1)
                     ndetsd=ndetsd+1
 14                  continue
                  enddo
 13               continue
               enddo
            enddo
         enddo
      endif
      goto 11
 2    continue
      print*,' Nombre de determinants generateurs :  ',ndetsel
      print*,' Nombre de determinants generes (+S) : ',ndets
      if(presel.eq.'SD')
     *print*,' Nombre de determinants generes (+SD) :',ndetsd
      print*,' Certains peuvent etre en double, ils seront elimines',
     *' par la suite'
      print*,' Les determinants generes sont dans le fichier PRESEL'
      print*,' Pour utiliser ce fichier dans un autre casdet, entrer :'
      print*,' &mrs file=''PRESEL'''
      print*,' '
      print*,'-----------------------------------------------'
     *//'-------------------------'
      print*,' '
      return
      end
       subroutine ecrmrs(ioc1)
      parameter(maxorbcas=16)
      parameter(maxorb=1024,nsymz=8)
      dimension ioc1(maxorbcas)
      character*80 ligne
      common/sym/nsym,its(nsymz,nsymz),itsym(maxorb)
      common/occ/noac,nelac,numac(maxorbcas),is0,ninac,nvirt
     *,numt(maxorb),nump(maxorb),ntac,nutac(maxorbcas),ms2
      ligne(1:9)=' &mrs ic='
      ideb=10
C! le determinant a-t-il la bonne symetrie ?
C      is=1
C      do k=1,noac
C         if(ioc1(k).eq.1) is=its(is,itsym(numac(k)))
C      enddo
C      if(is.ne.is0) return
            
      

      do k=1,noac
         if(ioc1(k).eq.2) then
            ifin=ideb+8-1
            write(ligne(ideb:ifin),'(i3,",",i3",")')numac(k),numac(k)
            ideb=ifin+1
         else if(ioc1(k).eq.1) then
            ifin=ideb+4-1
            write(ligne(ideb:ifin),'(i3,'','')')numac(k)
            ideb=ifin+1
         endif
      enddo
      ligne(ifin+1:ifin+2)=' /'
      ligne(ifin+3:80)=' '
      write(55,'(a80)') ligne
      write(6,'(a80)') ligne
      return
      end
