      subroutine diff1cp
     *(nca,ica,ncb,icb,nt,it,ispt,np,ip,ispp,iadr1,
     *b,ab,coef)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
c    |-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|-*-*-*-*-*-*-*-|
c    |      b        |      ab       |
c
      common/dim/iadri ; integer(8) iadri
      common/opt/ihab,calcul
      character*3 calcul
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/orb2/numina(maxorb),numvir(maxorb),iordo(maxorb*2)
     *,iodro(maxorb*2)
     *,numinb(maxorb),numvib(maxorb)
      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
      dimension ica(maxorbcas),icb(maxorbcas),it(2),ip(2)
      dimension ictemp(maxorb)
      dimension iptemp(maxorb),ipd(maxorb)
      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
      common/test/itest(100)
      character*4 gener
      dimension b(iadri),ab(iadri)
      yw=.false.
c
c-----------------------------------------------------------
c     une difference  deplacement 1 electron CAS  --> 1 part
c-----------------------------------------------------------
c
      if(np.ge.2) return
      nta=(nt+ispt)/2
      npa=(np+ispp)/2
      ntb=nt-nta
      npb=np-npa
      ynon=.false.
      b0=b(iadr1)
      if(gener.eq.'PERT'.or.gener.eq.'MR') then
         if(nt.eq.2.and.np.eq.1) then
            is=1
            do k=1,nca
               is=its(is,itsym(ica(k)))
            enddo
            do k=1,ncb
               is=its(is,itsym(icb(k)))
            enddo
         endif
      endif
      if(gener.eq.'DDCI'.or.gener.eq.'DDci') then
         if(nt.eq.2.and.np.eq.1) return
      else if(gener.eq.'DDC2') then
         if(nt.eq.2) return
         if(nt.eq.1.and.np.eq.1) return
      else if(ygmono) then
         if(nt.gt.1.or.np.gt.0) return
      endif
      if(yw)write(6,*)'nt,np,nca,ncb,nca0,ncb0',nt,np,nca,ncb,nca0,ncb0
      if(gener.eq.'PERT'.or.gener.eq.'DDci'.or.ygmono
     *.or.gener.eq.'MR') then
         if(iabs(nca-1-ncb-nca0+ncb0).gt.2) goto 9
      else if(gener.eq.'DDCI'.or.gener.eq.'DDC2') then
         if(iabs(nca-1-ncb-nca0+ncb0).gt.3) goto 9
      endif
      call comple(nvirt,numvir,npa,ip,npd,ipd)
      do 1 i=1,nca
c--------ica(i) est l'electron supprime
      is1=itsym(ica(i))
      if(gener.eq.'PERT'.or.gener.eq.'MR') then
         if(nt.eq.2.and.np.eq.1) then
            if(nca-1.ne.nca0.or.ncb.ne.ncb0) then
               if(yw)write(6,*)'ejecte ytous'
               goto 1
            endif
            if(its(is,is1).ne.is0) goto 1
         endif
      endif
      if(yw)write(6,*)'diff1cp electron a supprime',ica(i)
c-----------boucle sur la particule creee
      do 2 j=1,npd
      if(is1.ne.itsym(ipd(j))) goto 2
      if(yw)write(6,*)'diff1cp part a creee',ipd(j)
c--------------ipd(j) est la particule creee
      isgn=1
      if(np.eq.1) then
         if(ip(1).gt.ipd(j)) then
            iptemp(1)=ipd(j)
            iptemp(2)=ip(1)
         else
            iptemp(1)=ip(1)
            iptemp(2)=ipd(j)
            if(npa.eq.1)isgn=-1
         endif
      else
         iptemp(1)=ipd(j)
      endif
      do k=1,i-1
         ictemp(k)=ica(k)
      enddo
      do k=i+1,nca
         ictemp(k-1)=ica(k)
      enddo
      if(gener(1:2).eq.'MR')
     *call accept(nca-1,ictemp,ncb,icb,nt,np+1,ynon)
      if(ynon) goto 1
      if(yw)write(6,*)'diff1cp a appel adrdet'
      call adrdet
     *(nca-1,ictemp,ncb,icb,nt,it,
     *ispt,np+1,iptemp,ispp+1,iadr2
     *      ,mhdum,mtdum)
c--------------calcul de l'integrale
      mini=min(ica(i),ipd(j))
      maxi=max0(ica(i),ipd(j))
      a=f(maxi*(maxi-1)/2+mini)
      if(yw)write(6,*)'mini,maxi',mini,maxi,a
c------------------
c------------------signe
c                  on a supprime l'el CAS i et cree la part j
c                  on a donc ramene l'el i a la place j
c                  l'el a donc saute
c                  - par dessus 1 part si il y en avait deja
c                    une et qu'elle etait de rang inferieur
c                    (voir test sur ip(1) et ipd(j) plus haut)
c                  - par dessus nca-i el du CAS
c
c                             CAS                          part
c                              i                                j
c                        x x x   x x   x                 x      x
c                              |________________________________|
c                        <----nca------>
c                                <nca-i>
c------------------
      isgn=isgn*(1-2*mod(nca+i,2))
      if(yw)write(6,*)'diff1cp adresses,int',iadr1,iadr2,a,isgn
      if(calcul.eq.'M') then
         call stover(iadr1,iadr2,a*isgn*coef)
      else
         aa=a*isgn*coef
CYSGN               if(.not.yeqy(ysgn(iadr1),ysgn(iadr2))) aa=-aa
CIT17           if(itest(17).eq.iadr2)write(6,'('' diff1cp it17'',i5,2f1
CIT17        *   iadr1,aa,b(iadr1)
CIT17           if(itest(17).eq.iadr1)write(6,'('' diff1cp it17'',i5,2f1
CIT17        *   iadr2,aa,b(iadr2)
         ab(iadr2)=ab(iadr2)+aa*b0
         ab(iadr1)=ab(iadr1)+aa*b(iadr2)
      endif
 2    continue
 1    continue
 9    continue
      if(gener.eq.'PERT'.or.gener.eq.'DDci'.or.ygmono
     *.or.gener.eq.'MR') then
         if(iabs(nca-ncb+1-nca0+ncb0).gt.2) return
      else if(gener.eq.'DDCI'.or.gener.eq.'DDC2') then
         if(iabs(nca-ncb+1-nca0+ncb0).gt.3) return
      endif
      call comple(nvirt,numvib,npb,ip(npa+1),npd,ipd)
      do 3 i=1,ncb
c--------icb(i) est l'electron supprime
      is1=itsym(icb(i))
      if(gener.eq.'PERT'.or.gener.eq.'MR') then
         if(nt.eq.2.and.np.eq.1) then
            if(nca.ne.nca0.or.ncb-1.ne.ncb0) then
               if(yw)write(6,*)'ejecte ytous'
               goto 3
            endif
            if(its(is,is1).ne.is0) goto 3
         endif
      endif
      if(yw)write(6,*)'diff1cp electron b supprime',icb(i)
c-----------boucle sur la particule creee
      do 4 j=1,npd
      if(is1.ne.itsym(ipd(j))) goto 4
      if(yw)write(6,*)'diff1cp part b creee',ipd(j)
c--------------ipd(j) est la part creee
      if(yw)write(6,*)'np,ip(1)',np,ip(1)
      isgn=1
      if(np.eq.1) then
         if(ip(1).gt.ipd(j)) then
            iptemp(1)=ipd(j)
            iptemp(2)=ip(1)
         else
            iptemp(1)=ip(1)
            iptemp(2)=ipd(j)
            if(npb.eq.1)isgn=-1
         endif
      else
         iptemp(1)=ipd(j)
      endif
      do k=1,i-1
         ictemp(k)=icb(k)
      enddo
      do k=i+1,ncb
         ictemp(k-1)=icb(k)
      enddo
      if(yw)write(6,*)'diff1cp b iptemp',(iptemp(k),k=1,np+1)
      if(yw)write(6,*)'diff1cp b ictemp',(ictemp(k),k=1,ncb-1)
      if(yw)write(6,*)'ispp',ispp
      if(gener(1:2).eq.'MR')
     *call accept(nca,ica,ncb-1,ictemp,nt,np+1,ynon)
      if(ynon) goto 4
      if(yw)write(6,*)'diff1cp b appel adrdet'
      call adrdet
     *(nca,ica,ncb-1,ictemp,nt,it,
     *ispt,np+1,iptemp,ispp-1,iadr2
     *      ,mhdum,mtdum)
c--------------calcul de l'integrale
      mini=min(icb(i),iorb(ipd(j)))
      maxi=max0(icb(i),iorb(ipd(j)))
      a=f(maxi*(maxi-1)/2+mini)
      if(yw)write(6,*)'mini,maxi',mini,maxi,a
c------------------
c------------------signe
c                  on a supprime l'el CAS i et cree la part j
c                  on a donc ramene l'el i a la place j
c                  l'el a donc saute
c                  - par dessus 1 part si il y en avait deja
c                    une et qu'elle etait de rang inferieur
c                    (voir test sur ip(1) et ipd(j) plus haut)
c                  - par dessus ncb-i el du CAS
c
c                             CAS                          part
c                              i                                j
c                        x x x   x x   x                 x      x
c                              |________________________________|
c                        <----ncb------>
c                                <ncb-i>
c------------------
      if(yw)write(6,*)'isgn,i,npa',isgn,i,npa
      isgn=isgn*(1-2*mod(ncb+i,2))
      if(yw)write(6,*)'diff1cp adresses,int',iadr1,iadr2,a,isgn
      if(calcul.eq.'M') then
         call stover(iadr1,iadr2,a*isgn*coef)
      else
         aa=a*isgn*coef
CYSGN               if(.not.yeqy(ysgn(iadr1),ysgn(iadr2))) aa=-aa
CIT17           if(itest(17).eq.iadr2)write(6,'('' diff1cp it17'',i5,2f1
CIT17        *   iadr1,aa,b(iadr1)
CIT17           if(itest(17).eq.iadr1)write(6,'('' diff1cp it17'',i5,2f1
CIT17        *   iadr2,aa,b(iadr2)
         ab(iadr2)=ab(iadr2)+aa*b0
         ab(iadr1)=ab(iadr1)+aa*b(iadr2)
      endif
 4    continue
 3    continue
      return
      end
