      subroutine mulvovodx(a,i,b,j,aa1,aa2)
      use module
      use mod_ena
      use mod_mulatp
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      integer a,b,d,corr1,corr2
      dimension icorspin(16)
      character(31) elmat(81)
      common/com_nntp/ nntp(0:100)
      
      curr_sub='mulvovod'
      ysp1=itest(21)==1
      ysp0=itest(21)==0
      !ysp1=.false.
      !ysp0=.true.
      !
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! Preparation des listes d'adresses du CAS et des TP
      !
      ! i,j,a,b,aa = indices et valeur de l'integrale
      ! itp1,itp2,itp3,itp4 : adresses de la partie T/P
      ! ntp       : nombre d'adresses T/P
      !  det1 : i-(k) --> b+(c)      det2 : j-(k) --> a+(c)
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      !
      !
      ipair1=il(j,a)
      ipair2=il(i,b)
      !=========================================================
      ! on n'ajoute rien
      ! conditions : les 2 paires (j,a) et (i,b) doivent exister
      !=========================================================
      !
      if(w)print*,'entree mulvovodx a,i,b,j',a,i,b,j
      ! signe
      ybon=.false.
      if(w)print*,' det1 : i- --> b+      det2 : j- --> a+'
      if(ipair1.ne.0) then
         if(ipair2.ne.0) ybon=.true.
      endif
      call caldfc(idist,1,1)
      if(ybon) then
         itp1(1)=ipair1
         itp2(1)=ipair2
         !
         isgn0=-1+2*mod(sum(num_oav((/i,j/))),2)
         if(w)print*,'isgn0',isgn0
         aa=aa1*isgn0
         ! inclusion du fock dans le cas particulier nelac=1
         if(nelac==1.and.i==j) aa=aa-corrf2*isgn0
         if(ysp1) aa=aa*2
         ! Partie CAS
         iclc=iclasc(-1,1)
         if(iclc/=0) then
            longc=ifinc(iclc)+1-idebc(iclc)
            !
            jcltp=isdimtp(icltp(0,1,1,0))
            !
            if(sel==2) then
               lc=0
               do k=idebc(iclc),ifinc(iclc)
                  if(icaldist(k,jbin,ibinc,noac)>idist) cycle
                  lc=lc+1
                  mdetc1(lc)=idetc(k)
               enddo
               call ena(aa,lc,mdetc1(1:lc),
     *         mdetc1(1:lc),
     *         1,itp1+jcltp,itp2+jcltp)
            else
               if(longc/=0) itest(24)=1
               call ena(aa,longc,idetc(idebc(iclc):ifinc(iclc)),
     *         idetc(idebc(iclc):ifinc(iclc)),
     *         1,itp1+jcltp,itp2+jcltp)
            endif
         endif
         !
         if(w)print*,' det1 : i+ --> b-      det2 : j+ --> a-'
         ! Partie CAS
         if(ysp0) then
            iclc=iclasc(1,-1)
            if(iclc/=0) then
               longc=ifinc(iclc)+1-idebc(iclc)
               !
               jcltp=isdimtp(icltp(1,0,0,1))
               !
               if(sel==2) then
                  lc=0
                  do k=idebc(iclc),ifinc(iclc)
                     if(icaldist(k,jbin,ibinc,noac)>idist) cycle
                     lc=lc+1
                     mdetc1(lc)=idetc(k)
                  enddo
                  call ena(aa,lc,mdetc1(1:lc),
     *            mdetc1(1:lc),
     *            1,itp1+jcltp,itp2+jcltp)
               else
                  if(longc/=0) itest(24)=1
                  call ena(aa,longc,idetc(idebc(iclc):ifinc(iclc)),
     *            idetc(idebc(iclc):ifinc(iclc)),
     *            1,itp1+jcltp,itp2+jcltp)
               endif
            endif
         endif
         !
         !
         isgn0=1-2*mod(nelac+num_oav(i)+num_oav(j),2)
         if(w)print*,'isgn0',isgn0
         aa=aa2*isgn0
         if(ysp1) aa=aa*2
         if(w)print*,' det1 : i- --> b-      det2 : j+ --> a+'
         ! Partie CAS
         iclc=iclasc(0,0)
         longc=ifinc(iclc)+1-idebc(iclc)
         !
         jcltp1=isdimtp(icltp(0,1,0,1))
         jcltp2=isdimtp(icltp(1,0,1,0))
         !
         if(sel==2) then
            lc=0
            do k=idebc(iclc),ifinc(iclc)
               if(icaldist(k,jbin,ibinc,noac)>idist) cycle
               lc=lc+1
               mdetc1(lc)=idetc(k)
            enddo
            call ena(aa,lc,mdetc1(1:lc),
     *      mdetc1(1:lc),
     *      1,itp1+jcltp1,itp2+jcltp2)
         else
            if(longc/=0) itest(24)=1
            call ena(aa,longc,idetc(idebc(iclc):ifinc(iclc)),
     *      idetc(idebc(iclc):ifinc(iclc)),
     *      1,itp1+jcltp1,itp2+jcltp2)
         endif
         !
         if(i.ne.j.or.a.ne.b) then
            if(ysp0) then
               if(w)print*,' det1 : i+ --> b+      det2 : j- --> a-'
               ! Partie CAS
               longc=ifinc(iclc)+1-idebc(iclc)
               !
               jcltp1=isdimtp(icltp(1,0,1,0))
               jcltp2=isdimtp(icltp(0,1,0,1))
               !
               if(sel==2) then
                  lc=0
                  do k=idebc(iclc),ifinc(iclc)
                     if(icaldist(k,jbin,ibinc,noac)>idist) cycle
                     lc=lc+1
                     mdetc1(lc)=idetc(k)
                  enddo
                  call ena(aa,lc,mdetc1(1:lc),
     *            mdetc1(1:lc),
     *            1,itp1+jcltp1,itp2+jcltp2)
               else
                  if(longc/=0) itest(24)=1
                  call ena(aa,longc,idetc(idebc(iclc):ifinc(iclc)),
     *            idetc(idebc(iclc):ifinc(iclc)),
     *            1,itp1+jcltp1,itp2+jcltp2)
               endif
            endif
            !
            isgn0=-1+2*mod(num_oav(i)+num_oav(j),2)
            if(w)print*,'isgn0',isgn0
            aa=(aa1-aa2)*isgn0
            ! inclusion du fock dans le cas particulier nelac=1
            if(nelac==1.and.i==j) aa=aa-corrf2*isgn0
            if(w)print*,' det1 : i+ --> b+      det2 : j+ --> a+'
            if(w)print*,' det1 : i- --> b-      det2 : j- --> a-'
            ! Partie CAS
            iclc=iclasc(0,0)
            longc=ifinc(iclc)+1-idebc(iclc)
            !
            !
            if(ysp1) aa=aa*2
            if(sel==2) then
               lc=0
               do k=idebc(iclc),ifinc(iclc)
                  if(icaldist(k,jbin,ibinc,noac)>idist) cycle
                  lc=lc+1
                  mdetc1(lc)=idetc(k)
               enddo
               if(longc/=0) itest(24)=1
               jcltp=isdimtp(icltp(1,0,1,0))
               call ena(aa,lc,mdetc1(1:lc),
     *         mdetc1(1:lc),
     *         1,itp1+jcltp,itp2+jcltp)
            !
               jcltp=isdimtp(icltp(0,1,0,1))
            !
               if(ysp0)call ena(aa,lc,mdetc1(1:lc),
     *         mdetc1(1:lc),
     *         1,itp1+jcltp,itp2+jcltp)
            else
               if(longc/=0) itest(24)=1
               jcltp=isdimtp(icltp(1,0,1,0))
               call ena(aa,longc,idetc(idebc(iclc):ifinc(iclc)),
     *         idetc(idebc(iclc):ifinc(iclc)),
     *         1,itp1+jcltp,itp2+jcltp)
            !
               jcltp=isdimtp(icltp(0,1,0,1))
            !
               if(ysp0)call ena(aa,longc,idetc(idebc(iclc):ifinc(iclc)),
     *         idetc(idebc(iclc):ifinc(iclc)),
     *         1,itp1+jcltp,itp2+jcltp)
            endif
         endif
      endif
      !
      ipair1=ilp(j,a)
      ipair2=ilp(i,b)
      !
      !===============================================================
      ! on ajoute un trou
      ! conditions : 2 paires (j ou k,b) et (i ou k,a) doivent exister
      ! le trou non apparie doit etre lie au CAS
      !===============================================================
      !
      if(igener<3) return
      !///////////////////////////////////////////
      if(w)print*,'mulvovodx on ajoute un trou',a,i,b,j
      !///////////////////////////////////////////
      !
      call caldfc(idist,2,1)
      idist2=idist
      n=0
      nntp=0
      if(ipair1.ne.0) then
         do klc=1,nlco
            k=ilc(klc)
            klc1=klc
            klc2=klc
            jpair2=ipair2
            if(jpair2==0) then
               jpair2=ilp(k,b)
               klc2=ilc1(i)
               if(jpair2==0.or.klc2==0) cycle
            endif
            if(ipc(ipair1,klc1)==0) cycle
            if(ipc(jpair2,klc2)==0) cycle
            n=n+1
            itp1(n)=abs(ipc(ipair1,klc1))
            itp2(n)=abs(ipc(jpair2,klc2))
            call mulvovodi(i,j,k,ltp1(n))
            nntp(ltp1(n))=nntp(ltp1(n))+1
            if(w)print'(a,30i3)','A,b,i,j,k',a,b,i,j,k,n,
     *      ltp1(n),nntp(ltp1(n)),
     *      itp1(n),itp2(n)
         enddo
      endif
      if(ilc1(j)/=0) then
         do kpair3=idebliscond(a),ifinliscond(a)
            ipair3=liscond(kpair3)
            k=ilpair(1,ipair3)
            if(ilc1(k).ne.0.and.ilp(j,a)/=0) cycle
            ilc4=ilc1(i)
            ipair4=ilp(k,b)
            if(ilc4==0.or.ipair4==0) then
               ilc4=ilc1(k)
               ipair4=ilp(i,b)
               if(ilc4==0.or.ipair4==0) cycle
            endif
            if(ipc(ipair3,ilc1(j))==0) cycle
            if(ipc(ipair4,ilc4)==0) cycle
            n=n+1
            itp1(n)=abs(ipc(ipair3,ilc1(j)))
            itp2(n)=abs(ipc(ipair4,ilc4))
            call mulvovodi(i,j,k,ltp1(n))
            nntp(ltp1(n))=nntp(ltp1(n))+1
            if(w)print'(a,30i3)','A,b,i,j,k',a,b,i,j,k,n,
     *      ltp1(n),nntp(ltp1(n)),
     *      itp1(n),itp2(n)
         enddo
      endif
      if(w7)call genel(1,1,j,A,1,1,i,b,1,0,nl)
      if(w7)print*,'n,nl',n,nl
      if(n>0) then
         call reoitp(n,9,nntp)
         if(w)print'(a,20i3)','ITP',itp1(1:n)
         if(w)print'(a,20i3)','ITP',itp2(1:n)
         !
         elmat(1:9)=(/'k+ J+ -> A+    | k+ I+ -> B+   ',
     *                'J+ k+ -> A+    | I+ k+ -> B+   ',
     *                'k+ J+ -> A+    | I+ k+ -> B+   ',
     *                'J+ k+ -> A+    | k+ I+ -> B+   ',
     *                'k+ J+ -> A+    | I+=k+ -> B+   ',
     *                'J+ k+ -> A+    | I+=k+ -> B+   ',
     *                'J+=k+ -> A+    | I+ k+ -> B+   ',
     *                'J+=k+ -> A+    | k+ I+ -> B+   ',
     *                'J+=k+ -> A+    | I+=k+ -> B+   '/)
      
         !
         if(i/=j.or.a/=b) then
            aa3=aa1
            if(ysp1) aa3=aa3*2
            jsgn=1-2*mod(num_oav(i)+num_oav(j),2)
         !
            if(w)print*,'icas1'
            call mulatp(aa3,elmat,n,9,-jsgn,'I-','J-')
            if(ysp0)call mulatp(aa3,elmat,n,9,-jsgn,'A-','B-','k-')
         !
            if(w)print*,'icas2'
            call mulatp(aa3,elmat,n,9,-jsgn,'I-','J-','k-')
            if(ysp0)call mulatp(aa3,elmat,n,9,-jsgn,'A-','B-')
         !
         !=================
         !
            aa3=aa1-aa2
            if(ysp1) aa3=aa3*2
            if(w)print*,'icas3',jsgn,aa3,aa1,aa2
            call mulatp(aa3,elmat,n,9,-jsgn)
            if(ysp0)
     *      call mulatp(aa3,elmat,n,9,-jsgn,'I-','J-','A-','B-','k-')
         !
            if(w)print*,'icas4',jsgn,aa3,aa1,aa2
            call mulatp(aa3,elmat,n,9,-jsgn,'k-')
            if(ysp0)call mulatp(aa3,elmat,n,9,-jsgn,'I-','J-','A-','B-')
         endif
         !
         !=================
         !
         aa3=aa2
         if(ysp1) aa3=aa3*2
         jsgn=1-2*mod(nelac+1+num_oav(i)+num_oav(j),2)
         if(w)print*,'icas5'
         call mulatp(aa3,elmat,n,9,jsgn,'I-','B-')
         if(ysp0)call mulatp(aa3,elmat,n,9,jsgn,'A-','J-','k-')
         !
         if(i/=j.or.a/=b) then
            if(w)print*,'icas6',jsgn,nelac,num_oav(i),num_oav(j)
            call mulatp(aa3,elmat,n,9,jsgn,'I-','B-','k-')
            if(ysp0)call mulatp(aa3,elmat,n,9,jsgn,'A-','J-')
         endif
         !
      endif
      !
      !===============================================================
      ! on ajoute une particule
      ! conditions : voir pour les trous + haut
      !===============================================================
      !
      !/////////////////////////////////////////////////
      if(w)print*,'mulvovodx on ajoute une particule',a,i,b,j
      !/////////////////////////////////////////////////
      call caldfc(idist,1,2)
      idist2=idist
      n=0
      nntp=0
      if(w)print*,'ipair',ipair1,ipair2
      if(ipair2/=0) then
         do klc=1+nlco,nlc
         !print*,'klc',klc
            d=ilc(klc)
            klc1=klc
            klc2=klc
            jpair1=ipair1
            if(jpair1==0) jpair1=ilp(j,d)
         !print*,'jpair1',jpair1,j,d,ilp(j,d)
            if(jpair1==0) cycle
            jpair2=ipair2
!         if(jpair2==0) jpair2=ilp(i,d)
!         if(jpair2==0) cycle
            if(ipair1==0) klc1=ilc1(a)+nlco
            if(w)print*,'klc1',klc1,nlco
            if(klc1==nlco) cycle
!         if(ipair2==0) klc2=ilc1(b)+nlco
!         if(klc2==nlco) cycle
            if(ipc(jpair1,klc1)==0) cycle
            if(ipc(jpair2,klc2)==0) cycle
            n=n+1
            itp1(n)=abs(ipc(jpair1,klc1))
            itp2(n)=abs(ipc(jpair2,klc2))
            call mulvovoda(a,b,d,ltp1(n))
            nntp(ltp1(n))=nntp(ltp1(n))+1
            if(w)print'(a,30i3)','a,b,i,j,d',a,b,i,j,d,n,
     *      ltp1(n),nntp(ltp1(n)),
     *      itp1(n),itp2(n)
         enddo
      endif
      ! det1 : i -- a,d , det2 : j -- b,d
      ! 2. (i,d) ; d non lie au CAS, a,b lies au cas, (j,d)
      !print*,'jjj',i,idebliscond(i),ifinliscond(i)
      do kpair3=idebliscond(i),ifinliscond(i)
         ipair3=liscond(kpair3)
         d=ilpair(2,ipair3)
         !print*,'iii',d,ilc1(d),i,b,ilp(i,b)
         if(ilc1(d).ne.0.and.ilp(i,b).ne.0) cycle
         jlcb=ilc1(b)+nlco
         if(jlcb==nlco) cycle
         ipair4=ilp(j,d)
         jlca=ilc1(a)+nlco
         if(ipair4==0.or.jlca==nlco) then
            ipair4=ilp(j,a)
            jlca=ilc1(d)+nlco
         endif
         if(ipair4==0.or.jlca==nlco) cycle
         if(ipc(ipair3,jlcb)==0) cycle
         if(ipc(ipair4,jlca)==0) cycle
         n=n+1
         itp2(n)=abs(ipc(ipair3,jlcb))
         itp1(n)=abs(ipc(ipair4,jlca))
         call mulvovoda(a,b,d,ltp1(n))
         nntp(ltp1(n))=nntp(ltp1(n))+1
         if(w)print'(a,30i3)','A,b,i,j,d',a,b,i,j,d,n,
     *   ltp1(n),nntp(ltp1(n)),
     *   itp1(n),itp2(n)
      enddo
      if(w7)call genel(1,1,j,A,1,1,i,b,0,1,nl)
      if(w7)print*,'n,nl',n,nl
      if(n>0) then
         call reoitp(n,9,nntp)
         if(w)print'(a,20i3)','ITP',itp1(1:n)
         if(w)print'(a,20i3)','ITP',itp2(1:n)
         !
         elmat(1:9)=(/'J+    -> A+ d+ | I+    -> B+ d+',
     *   'J+    -> d+ A+ | I+    -> d+ B+',
     *   'J+    -> d+ A+ | I+    -> B+ d+',
     *   'J+    -> A+ d+ | I+    -> d+ B+',
     *   'J+    -> d+ A+ | I+    -> B+=d+',
     *   'J+    -> A+ d+ | I+    -> B+=d+',
     *   'J+    -> A+=d+ | I+    -> B+ d+',
     *   'J+    -> A+=d+ | I+    -> d+ B+',
     *   'J+    -> A+=d+ | I+    -> B+=d+'/)
      
         if(i/=j.or.a/=b) then
            call debiil1(3)
         else
            call debiil1(4)
         endif
         !
         if(i/=j.or.a/=b) then
            aa3=aa1
            if(ysp1) aa3=aa3*2
            ! inclusion du fock dans le cas particulier nelac=1
            if(nelac==1.and.i==j) aa3=aa3-corrf2
            jsgn=1-2*mod(num_oav(i)+num_oav(j),2)
            !
            if(w)print*,'icas1'
            call mulatp(aa3,elmat,n,9,-jsgn,'I-','J-')
            if(ysp0)call mulatp(aa3,elmat,n,9,-jsgn,'A-','B-','d-')
            !
            if(w)print*,'icas2'
            call mulatp(aa3,elmat,n,9,-jsgn,'I-','J-','d-')
            if(ysp0)call mulatp(aa3,elmat,n,9,-jsgn,'A-','B-')
            !
            !==================
            !
            aa3=aa1-aa2
            if(ysp1) aa3=aa3*2
            ! inclusion du fock dans le cas particulier nelac=1
            if(nelac==1.and.i==j) aa3=aa3-corrf2
            jsgn=1-2*mod(num_oav(i)+num_oav(j),2)
            if(w)print*,'icas3',jsgn
            call mulatp(aa3,elmat,n,9,-jsgn)
            if(ysp0)
     *      call mulatp(aa3,elmat,n,9,-jsgn,'I-','J-','A-','B-','d-')
            !
            if(w)print*,'icas4',jsgn
            call mulatp(aa3,elmat,n,9,-jsgn,'d-')
            if(ysp0)call mulatp(aa3,elmat,n,9,-jsgn,'I-','J-','A-','B-')
         endif
            !
            !==================
            !
         aa3=aa2
         if(ysp1) aa3=aa3*2
         jsgn=1-2*mod(nelac-1+num_oav(i)+num_oav(j),2)
         if(w)print*,'icas5'
         call mulatp(aa3,elmat,n,9,jsgn,'I-','B-')
         if(ysp0)call mulatp(aa3,elmat,n,9,jsgn,'J-','A-','d-')
            !
         if(i/=j.or.a/=b) then
            if(w)print*,'icas6'
            call mulatp(aa3,elmat,n,9,jsgn,'I-','B-','d-')
            if(ysp0)call mulatp(aa3,elmat,n,9,jsgn,'J-','A-')
         endif
         !
         if(i/=j.or.a/=b) then
            call finiil1(3)
         else
            call finiil1(4)
         endif
      endif
      !
      !===============================================================
      ! on ajoute une paire (k,d)
      ! conditions : 2 paires doivent exister de chaque cote
      !  det1 : i-k --> b+d      det2 : j-k --> a+d
      !===============================================================
      !
      if(igener<4) return
      !///////////////////////////////////////////////////
      if(w)print*,'mulvovodx on ajoute une paire',a,i,b,j
      !///////////////////////////////////////////////////
      call caldfc(idist,2,2)
      idist2=idist
      n=0
      nntp=0
      jpair=ilp(j,a)
      ipair=ilp(i,b)
      ! on ajoute une paire cote j-a
      if(jpair/=0) then
         do kpair=1,nlpairp
            k=ilpair(1,kpair)
            d=ilpair(2,kpair)
            call verifib(k,d,i,b,ipair21,ipair22,y)
            if(y) then
               n=n+1
               call aj_tp_tp_tp2
     *         (jpair,kpair,ipair21,ipair22,i,j,k,a,b,d,n)
            endif
         enddo
      endif
      do iipair1=idebliscond(j),ifinliscond(j)
         iipair=liscond(iipair1)
         d=ilpair(2,iipair)
         do jjpair1=idebliscond(a),ifinliscond(a)
            jjpair=liscond(jjpair1)
            k=ilpair(1,jjpair)
            if(jpair/=0.and.ilp(k,d)/=0) cycle
            call verifib(k,d,i,b,ipair21,ipair22,y)
            if(y) then
               n=n+1
               call aj_tp_tp_tp2
     *         (iipair,jjpair,ipair21,ipair22,i,j,k,a,b,d,n)
            endif
         enddo
      enddo
      if(w7)call genel(1,1,j,A,1,1,i,b,1,1,nl)
      if(w7)print*,'+paire,n,nl',n,nl
      if(n>0) then
         call reoitp(n,81,nntp)
         if(w)print'(a,20i3)','ITP',itp1(1:n)
         if(w)print'(a,20i3)','ITP',itp2(1:n)
         !
         elmat(1:9)=(/'k+ J+ -> A+ d+ | k+ I+ -> B+ d+',
     *   'J+ k+ -> A+ d+ | I+ k+ -> B+ d+',
     *   'k+ J+ -> A+ d+ | I+ k+ -> B+ d+',
     *   'J+ k+ -> A+ d+ | k+ I+ -> B+ d+',
     *   'k+ J+ -> A+ d+ | I+=k+ -> B+ d+',
     *   'J+ k+ -> A+ d+ | I+=k+ -> B+ d+',
     *   'J+=k+ -> A+ d+ | I+ k+ -> B+ d+',
     *   'J+=k+ -> A+ d+ | k+ I+ -> B+ d+',
     *   'J+=k+ -> A+ d+ | I+=k+ -> B+ d+'/)
         do k=2,9
            elmat((k-1)*9+1:k*9)=elmat(1:9)
         enddo
         elmat(10:18)(10:14)='d+ A+'
         elmat(19:27)(10:14)='d+ A+'
         elmat(28:36)(10:14)='A+ d+'
         elmat(37:45)(10:14)='d+ A+'
         elmat(46:54)(10:14)='A+ d+'
         elmat(55:63)(10:14)='A+=d+'
         elmat(64:72)(10:14)='A+=d+'
         elmat(73:81)(10:14)='A+=d+'
      
         elmat(10:18)(27:31)='d+ B+'
         elmat(19:27)(27:31)='B+ d+'
         elmat(28:36)(27:31)='d+ B+'
         elmat(37:45)(27:31)='B+=d+'
         elmat(46:54)(27:31)='B+=d+'
         elmat(55:63)(27:31)='B+ d+'
         elmat(64:72)(27:31)='d+ B+'
         elmat(73:81)(27:31)='B+=d+'
         !
         if(i/=j.or.a/=b) then
            call debiil1(1)
         else
            call debiil1(2)
         endif
         !
         if(i/=j.or.a/=b) then
            aa3=aa1
            if(ysp1) aa3=aa3*2
            jsgn=1-2*mod(num_oav(i)+num_oav(j),2)
            !
            w6=.false.
            if(w)print*,'icas1'
            call mulatp(aa3,elmat,n,81,-jsgn,'I-','J-')
            if(ysp0)
     *      call mulatp(aa3,elmat,n,81,-jsgn,'A-','B-','d-','k-')
            !
            if(w)print*,'icas2'
            call mulatp(aa3,elmat,n,81,-jsgn,'I-','J-','k-')
            if(ysp0)call mulatp(aa3,elmat,n,81,-jsgn,'A-','B-','d-')
            !
            if(w)print*,'icas3'
            call mulatp(aa3,elmat,n,81,-jsgn,'I-','J-','d-')
            if(ysp0)call mulatp(aa3,elmat,n,81,-jsgn,'A-','B-','k-')
            !
            if(w)print*,'icas4'
            call mulatp(aa3,elmat,n,81,-jsgn,'I-','J-','d-','k-')
            if(ysp0)call mulatp(aa3,elmat,n,81,-jsgn,'A-','B-')
            !
            !==================
            !
            aa3=aa1-aa2
            if(ysp1) aa3=aa3*2
            jsgn=1-2*mod(num_oav(i)+num_oav(j),2)
            if(w)print*,'icas5'
            call mulatp(aa3,elmat,n,81,-jsgn)
            if(ysp0)call mulatp(aa3,elmat,n,81,-jsgn,
     *      'I-','J-','A-','B-','d-','k-')
            !
            if(w)print*,'icas6'
            call mulatp(aa3,elmat,n,81,-jsgn,'k-')
            if(ysp0)
     *      call mulatp(aa3,elmat,n,81,-jsgn,'I-','J-','A-','B-','d-')
            !
            if(w)print*,'icas7'
            call mulatp(aa3,elmat,n,81,-jsgn,'d-')
            if(ysp0)
     *      call mulatp(aa3,elmat,n,81,-jsgn,'I-','J-','A-','B-','k-')
            !
            if(w)print*,'icas8'
            call mulatp(aa3,elmat,n,81,-jsgn,'k-','d-')
            if(ysp0)
     *      call mulatp(aa3,elmat,n,81,-jsgn,'I-','J-','A-','B-')
         endif
         !
         !==================
         !
         aa3=aa2
         if(ysp1) aa3=aa3*2
         jsgn=1-2*mod(nelac+num_oav(i)+num_oav(j),2)
         if(w)print*,'icas9'
         call mulatp(aa3,elmat,n,81,jsgn,'I-','B-')
         if(ysp0)call mulatp(aa3,elmat,n,81,jsgn,'J-','A-','d-','k-')
         !
         if(w)print*,'icasa'
         call mulatp(aa3,elmat,n,81,jsgn,'I-','B-','k-')
         if(ysp0)call mulatp(aa3,elmat,n,81,jsgn,'J-','A-','d-')
         !
         if(i/=j.or.a/=b) then
            if(w)print*,'icasb'
            call mulatp(aa3,elmat,n,81,jsgn,'I-','B-','d-')
            if(ysp0)call mulatp(aa3,elmat,n,81,jsgn,'J-','A-','k-')
            !
            if(w)print*,'icasc'
            call mulatp(aa3,elmat,n,81,jsgn,'I-','B-','d-','k-')
            if(ysp0)call mulatp(aa3,elmat,n,81,jsgn,'J-','A-')
!         else
!            iil1=iil1+(81+1)*4
         endif
         w6=.false.
         !
         if(i/=j.or.a/=b) then
            call finiil1(1)
         else
            call finiil1(2)
         endif
         !
      endif
      return
      end
       subroutine mulvovodi(i,j,k,ltp1)
      integer(1) ltp1
      if(k<i) then
         if(k<j) then
            ltp1=1
         else if (k>j) then
            ltp1=4
         else
            ltp1=8
         endif
      else if(k>i) then
         if(k<j) then
            ltp1=3
         else if (k>j) then
            ltp1=2
         else
            ltp1=7
         endif
      else
         if(k<j) then
            ltp1=5
         else if (k>j) then
            ltp1=6
         else
            ltp1=9
         endif
      endif
      return
      end
       subroutine mulvovoda(i,j,k,ltp1)
      integer(1) ltp1
      if(k<i) then
         if(k<j) then
            ltp1=2
         else if (k>j) then
            ltp1=3
         else
            ltp1=5
         endif
      else if(k>i) then
         if(k<j) then
            ltp1=4
         else if (k>j) then
            ltp1=1
         else
            ltp1=6
         endif
      else
         if(k<j) then
            ltp1=8
         else if (k>j) then
            ltp1=7
         else
            ltp1=9
         endif
      endif
      return
      end
       subroutine aj_tp_tp_tp2(kpair1,kpair2,lpair1,lpair2,
     *i,j,k,a,b,d,n)
      use module
      integer a,b,d
      integer(1) l2,l3
      common/com_nntp/ nntp(0:100)
      ii1=min(kpair1,kpair2)
      jj1=max(kpair1,kpair2)
      ii2=min(lpair1,lpair2)
      jj2=max(lpair1,lpair2)
      ipp1=abs(ipp((jj1-1)*jj1/2+ii1))
      ipp2=abs(ipp((jj2-1)*jj2/2+ii2))
      if(ipp1==0.or.ipp2==0) then
         n=n-1
         return
      endif
      itp1(n)=ipp1
      itp2(n)=ipp2
      call mulvovodi(i,j,k,l2)
      call mulvovoda(a,b,d,l3)
      ltp1(n)=l2+(l3-1)*9
      nntp(ltp1(n))=nntp(ltp1(n))+1
      if(w)print'(a,30i3)','a,b,d,i,j,k',a,b,d,i,j,k,n,
     *ltp1(n),nntp(ltp1(n)),
     *itp1(n),itp2(n)
      return
      end
       subroutine verifib(k,d,i,b,ipair21,ipair22,y)
      use module
      integer b,d
      logical(1) y
      ipair21=ilp(k,d)
      ipair22=ilp(i,b)
      if(ipair21==0.or.ipair22==0) then
         ipair21=ilp(i,d)
         ipair22=ilp(k,b)
      endif
      y=ipair21/=0.and.ipair22/=0
      return
      end
