function FC1(fac,si,sj,Nexci,Nexcj,np0,LEXCL,LEXCF,iwr,A,B,C,D,EN)
c     FC = Franc Condon factor for <si|sj> reduce to sum(k) <0|vk>
c     fac = <0|0*>
c     np0 ... dimension of working buffer
      implicit none
      integer*4 si(*),sj(*),Nexci,Nexcj,np,iex,ii,nu,jj,ip,N,ic,jold,
     1nuj,jc,kk,iwr,LEXCL,LEXCF,np0,iq,jq,jex,iexc,jexc
      real*8 FC,fac,A(N,N),B(*),C(N,N),D(*),E(N,N),pini
      real*8,allocatable::p(:)
      integer*4,allocatable::NNi(:),NNj(:),ie(:,:),it(:),jt(:),je(:,:),
     1sk(:)
c     initialize temporary variables:
      allocate(p(np0),NNi(np0),NNj(np0),ie(np0,LEXCL),je(np0,LEXCF),
     1it(np0),jt(np0))

      if(iwr.gt.1)write(6,604)(sj(iex),iex=1,NExcj),(si(iex),iex=1,NExc)
604   format(/,'<j|i> requested:',/,
     1'    j = ',10i3,' i = ',10i3,' requested:')

c     input <sj|si>:
      np=1
      p(np)=1.0d0
      NNi(np)=NExci
      NNj(np)=NExcj
      do 102 iex=1,NNi(np)
102   ie(np,iex)=si(iex)
      do 103 jex=1,NNj(np)
103   je(np,jex)=sj(jex)

c     expand using reccurent formula into a sum of <0|k>
777   do 101 ii=1,np
c     term ii - reduce excitation one by one:
      pini=p(ii)
      if(iwr.gt.1)write(6,617)ii,p(ii),(ie(ii,iex),iex=1,NNi(ii))
      if(iwr.gt.1)write(6,618)         (je(ii,jex),jex=1,NNj(ii))
617   format(' term ',i2,':',f10.6,10i3)
618   format('      ',2x,' ',10x,  10i3)

      do 101 iex=1,NNi(ii)
      iq=ie(ii,iex)
      if(iq.gt.0)then
c      <0| si_nu> reduce to <i-1|j>, <i-2|j>, <i-1,j-1|j>(j<>i), <i-1|j-1>
       nu=0
       do 1032 jj=1,NNi(ii)
1032   if(ie(ii,jj).eq.iq)nu=nu+1

c      write term <i-1| into  string it:
       call wrim(iq,NNi,ie,ii,it,np0,LEXCL)
       do 1036 jj=1,NNj(ii)
1036   jt(jj)=je(ii,jj) 

       iexc=NNi(ii)-1
       jexc=NNj(ii)
       call digest1(np,ie,je,np0,LEXCL,LEXCF,p,NNi,NNj,it,jt,iexc,jexc,
     1 pini*B(iq)/dsqrt(dble(2*nu)))
       if(iwr.gt.1)write(6,606)(it(jj),jj=1,NNi(ii)-1)
       if(iwr.gt.1)write(6,607)(jt(jj),jj=1,NNj(ii))
606    format('digest ',10i3)
607    format('       ',10i3)

c      write term <v'-2_iex|j> into string it:
       if(nu.gt.1)then
        ic=0
        ip=0
        do 1033 jj=1,NN(ii)
        if(ie(ii,jj).eq.iq.and.ic.lt.2)then
         ic=ic+1
        else
         ip=ip+1
         it(ip)=ie(ii,jj)
        endif
1033    continue
        iexc=NNi(ii)-2
        call digest1(np,ie,je,np0,LEXCL,LEXCF,p,NNi,NNj,it,jt,iexc,jexc,
     1  pini*dsqrt(dble(nu-1)/dble(nu))*A(iq,iq))
        if(iwr.gt.1)write(6,606)(it(jj),jj=1,NNi(ii)-2)
        if(iwr.gt.1)write(6,607)(jt(jj),jj=1,NNj(ii))
       endif

c      write terms <v'-1_iex-1_jp,|j> jp<>iex> into it:
       jold=0
       do 106 jj=1,NNi(ii)
       jq=ie(ii,jj)
       if(jq.ne.iq.and.jq.ne.jold)then
        nuj=0
        do 1034 kk=1,NNi(ii)
1034    if(jq.eq.ie(ii,kk))nuj=nuj+1
        ic=0
        jc=0
        ip=0
        do 1035 kk=1,NNi(ii)
        if(ie(ii,kk).eq.iq.and.ic.lt.1)then
         ic=ic+1
        else
         if(ie(ii,kk).eq.jq.and.jc.lt.1)then
          jc=jc+1
         else
          ip=ip+1
          it(ip)=ie(ii,kk)
         endif
        endif
1035    continue
        iexc=NNi(ii)-2
        call  digest1(np,ie,je,np0,LEXCL,LEXCF,
     1  p,NNi,NNj,it,jt,iexc,jexc,
     1  pini*dsqrt(dble(nuj)/dble(nu))*A(iq,jq))
        if(iwr.gt.1)write(6,606)(it(kk),kk=1,NNi(ii)-2)
        if(iwr.gt.1)write(6,607)(jt(kk),kk=1,NNj(ii))
       endif
106    jold=jq

c      terms <i-1|j -1> :
c      write term <i-1| into it:
       call wrim(iq,NNi,ie,ii,it,np0,LEXCL)

       jold=0
       do 109 jj=1,NNj(ii)
       jq=je(ii,jj)
       if(jq.ne.jold)then
        nuj=0
        do 1039 kk=1,NNj(ii)
1039    if(jq.eq.je(ii,kk))nuj=nuj+1

c       write term |j-1> into jt:
        call wrim(jq,NNj,je,ii,jt,np0,LEXCF)

        iexc=NNi(ii)-1
        jexc=NNj(ii)-1
        call  digest1(np,ie,je,np0,LEXCL,LEXCF,
     1  p,NNi,NNj,it,jt,iexc,jexc,
     1  pini*dsqrt(dble(nuj)/dble(4*nu))*E(jq,iq))
        if(iwr.gt.1)write(6,606)(it(kk),kk=1,iexc)
        if(iwr.gt.1)write(6,607)(jt(kk),kk=1,jexc)
       endif
109    jold=jq

       if(iwr.gt.1)then
        write(6,*)'np now ',np
        do 108 jj=1,np
        write(6,605)jj,NNj(jj),p(jj),(ie(jj,kk),kk=1,NNi(jj))
108     write(6,655)                 (je(jj,kk),kk=1,NNj(jj))
       endif
       
c      eliminate the old term and start over
       do 105 jj=ii,np-1
       p(jj)=p(jj+1)
       NNi(jj)=NNi(jj+1)
       NNj(jj)=NNj(jj+1)
       do 1051 kk=1,NNi(jj)
1051   ie(jj,kk)=ie(jj+1,kk)
       do 105 kk=1,NNj(jj)
105    je(jj,kk)=je(jj+1,kk)
       np=np-1
       if(iwr.gt.1)then
        write(6,*)'np after elimination ',np
        do 107 jj=1,np
        write(6,605)jj,NN(jj),p(jj),(ie(jj,kk),kk=1,NNi(jj))
107     write(6,655)                (je(jj,kk),kk=1,NNj(jj))
605     format(i3,i2,g9.3,10i3)
655     format(14x,       10i3)
       endif

       goto 777
       
      endif
101   continue

      allocate(sk(LEXCF+1))
      su=0.0d0
      do 111 ii=1,np
      do 112 i=1,NNj(ii)
112   sk(i)=je(ii,i)
111   sum=sum+p(ii)*FC(fac,sk,NNj(ii),np0,LEXCF,iwr,C,D,N)
      if(np.ne.1)call report('np <> 1')

      FC1=sum
      return
      end