      subroutine diff1tp
     *(nca,ica,ncb,icb,nt,it,ispt,np,ip,ispp,iadr1,
     *b,ab)
      parameter(maxsym=8,maxorbcas=16)
      include 'maxorb.prm'
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
c
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/sy3/itorbi(maxorb),isbrot(maxorb),itorbc(maxorb)
     *,itorbs(maxorb)
      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 ittemp(maxorb)
      dimension iptemp(maxorb)
      dimension b(iadri),ab(iadri)
      common/test/itest(100)
      yw=.false.
c
c-----------------------------------------------------------
c     une difference  suppression 1 trou 1 part
c-----------------------------------------------------------
c
      nta=(nt+ispt)/2
      npa=(np+ispp)/2
      ntb=nt-nta
      npb=np-npa
      b0=b(iadr1)
      do 1 i=1,nta
c--------it(i) est le trou supprime
      is1=itsym(it(i))
      if(yw)write(6,*)'diff1tp trou a supprime',it(i)
c-----------boucle sur la particule supprimee
      do 2 j=1,npa
      if(is1.ne.itsym(ip(j))) goto 2
      if(yw)write(6,*)'diff1tp part a supprimee',ip(j)
c--------------ip(j) est la part supprimee
      do k=1,i-1
         ittemp(k)=it(k)
      enddo
      do k=1,j-1
         iptemp(k)=ip(k)
      enddo
      do k=i+1,nt
         ittemp(k-1)=it(k)
      enddo
      do k=j+1,np
         iptemp(k-1)=ip(k)
      enddo
      call adrdet
     *(nca,ica,ncb,icb,nt-1,ittemp,ispt-1,
     *np-1,iptemp,ispp-1,iadr2,
     *      mhdum,mtdum)
c--------------calcul de l'integrale
      mini=(it(i))
      maxi=(ip(j))
      a=f(maxi*(maxi-1)/2+mini)
      if(yw)write(6,*)'i,j,f,a',i,j,f(maxi*(maxi+1)/2+mini),a
     *,mini,maxi
c------------------
c------------------signe
c                  on a supprime le trou i et la part j
c                  on a donc ramene l'el j a la place i
c
c                  l'el a donc saute
c                  - par dessus j-1 part
c                  - par dessus nca el du CAS
c                  - par dessus ninac-ita(i)-(nta-i) occupees
c
c                             occ              CAS         part
c                              i                                j
c                        x x x   x x   x      x x x      x      x
c                              |________________________________|
c                        <---ninac----->      <nca>
c                              <------->
c                              ninac-ita(i)
c                      donc    ninac-ita(i)-(nta-i) electrons
c------------------
c           isgn=1-2*mod(ninac-iordo(it(i))-(nta-i)+nca+j-1,2)
      isgn=1-2*mod(ninac+iodro(it(i))+(nta+i)+nca+j+1,2)
      if(yw)write(6,*)'diff1tp adresses,int',iadr1,iadr2,a,isgn
      if(calcul.eq.'M') then
         call stover(iadr1,iadr2,a*isgn)
      else
         aa=a*isgn
CIT17           if(itest(17).eq.iadr2)write(6,'('' diff1tp it17'',i5,2f1
CIT17        *   iadr1,aa,b(iadr1)
CIT17           if(itest(17).eq.iadr1)write(6,'('' diff1tp 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
      do 3 i=nta+1,nt
c--------it(i) est le trou supprime
      is1=itsym(it(i))
      if(yw)write(6,*)'diff1tp trou b supprime',it(i)
c-----------boucle sur la particule supprimee
      do 4 j=npa+1,np
      if(is1.ne.itsym(ip(j))) goto 4
      if(yw)write(6,*)'diff1tp part b supprimee',ip(j)
c--------------ip(j) est la part supprimee
      do k=1,i-1
         ittemp(k)=it(k)
      enddo
      do k=1,j-1
         iptemp(k)=ip(k)
      enddo
      do k=i+1,nt
         ittemp(k-1)=it(k)
      enddo
      do k=j+1,np
         iptemp(k-1)=ip(k)
      enddo
      call adrdet
     *(nca,ica,ncb,icb,nt-1,ittemp,ispt+1,
     *np-1,iptemp,ispp+1,iadr2,
     *      mhdum,mtdum)
c--------------calcul de l'integrale
      mini=iorb(it(i))
      maxi=iorb(ip(j))
      a=f(maxi*(maxi-1)/2+mini)
      if(yw)write(6,*)'i,j,f,a',i,j,f(maxi*(maxi+1)/2+mini),a
     *,mini,maxi
c------------------
c------------------signe (v. commentaires + haut
c              isgn=1-2*mod(ninac-iordo(mini)-(ntb-i+nta)+ncb+j-npa-1,2)
      isgn=
     *1-2*mod(ninac+iodro(mini)+(ntb+i+nta)+ncb+j+npa+1,2)
      if(yw)write(6,*)'diff1tp adresses,int',iadr1,iadr2,a,isgn
      if(calcul.eq.'M') then
         call stover(iadr1,iadr2,a*isgn)
      else
         aa=a*isgn
CYSGN               if(.not.yeqy(ysgn(iadr1),ysgn(iadr2))) aa=-aa
CIT17           if(itest(17).eq.iadr2)write(6,'('' diff1tp it17'',i5,2f1
CIT17        *   iadr1,aa,b(iadr1)
CIT17           if(itest(17).eq.iadr1)write(6,'('' diff1tp 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
