      subroutine di
      use module
      use moddi
      use mod_disin
      use mod_script
      use modlirin
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
!      integer(2),allocatable,dimension(:,:,:) ::
!     *ijkl,iikl,ijil,ijjj,ijij
      double precision,allocatable,dimension(:) :: aa1,aa2
      character(12) gc(4)
      dimension bijji(4),mjkl(4)
      yw=.false.
!
! Preparation de l'adressage
!
 
      ifint=26
      call prepad
!
      allocate(aiikl(norb,num1(norb+1)))
      allocate(aijil(norb,num1(norb+1)))
      allocate(aijjj(norb,norb))
      allocate(aijij(norb,norb))
      aiikl=0.d0
      aijil=0.d0
      aijjj=0.d0
      aijij=0.d0
!
! ouverture du fichier d'integrales casdi en sortie (optionnel, si on
! veut faire un casdi)
!
      if(ycd) then
         if(ycl1) then
            call disin(0,27,trim(prefix)//'IJCLLOC',ycl1,i,j,k,l,a,ndum)
         else
            allocate(aa(4096))
            call disin
     *      (0,27,trim(prefix)//'ijclloc',ycl1,i,j,k,l,a,ndum)
         endif
      endif
!
! ouverture du fichier d'integrales casdiloc en sortie (int i>j>k>l)
!
      if(ycdloc) then
         allocate(aaloc(3,4096))
         !call disinl(31,0,trim(prefix)//'ijclloc4',ibid,i,j,k,l,a)
         call disinl(31,0,ijclloc41,ibid,i,j,k,l,a)
      endif
!
!     allocations des fichiers d'integrales
!
      allocate(aa1(max(madr1,madr3)))
      allocate(aa2(max(madr2,madr4)))
! Lecture des integrales (ecrites en symetrie) sur la DAF
!
!     boucle sur le nombre de classes des integrales
!
      call cpu_time(t0)
      !call filesplit('REWIND',21,0,ichange,irec)
      i0=0
      ! boucle sur les classes d'orbitales (c-a-d sur les groupes
      ! d'orbitales equivalentes par sym)
      do icl=1,ncl
         !print*,'***************icl=',icl,'*****************'
         n=0
         aa1=0.d0
         ! boucle sur les orbitales de la classe
         do ii=1,nequis(icl)
            i0=i0+1
            ! boucle sur les enregistrements de la DAF qui correspondent
            ! a l'indice i0
            if(yw)print*,'indice',i0,'  nb d''enr',nrec_dela_classe(i0)
            if(yw)print*,'bornes',ifin_dela_classe(i0-1)+1
     *      ,ifin_dela_classe(i0)
            do krec=ifin_dela_classe(i0-1)+1,ifin_dela_classe(i0)
               irec=numrec_dela_classe(krec)
               if(yw)print*,'krec,irec',krec,irec
               call filesplit('READ',21,2*3*1024+8*1024,ichange,irec)
               read(21,rec=irec) a_cl(:,i0),ijkl_cl(:,:,i0)
               ifin=1024
               if(krec==ifin_dela_classe(i0)) ifin=nint_par_classe(i0)
               if(yw)print*,'ifin',irec,ifin_dela_classe(i0),ifin
!
!              1. Transformation ijkl Ijkl
!
               ! boucle sur les integrales de l'enregistrement
               do kk=1,ifin
!                  if(yw)print'(a,4i4,f12.8)','lue ijkl',i0,
!     *            ijkl_cl(:,kk,i0),a_cl(kk,i0)
                  j0=ijkl_cl(1,kk,i0)
                  k0=ijkl_cl(2,kk,i0)
                  l0=ijkl_cl(3,kk,i0)
         !print*,'indices',i0,j0,k0,l0
                  a=a_cl(kk,i0)
                  jcl=iclasloc(j0)
                  kcl=iclasloc(k0)
                  lcl=iclasloc(l0)
                  ! on est sur que icl est la plus grande classe
                  ! si icl==kcl, il faut verifier que jcl>=lcl
                  if(icl==kcl.and.jcl<lcl) then
                     jj=jcl
                     jcl=lcl
                     lcl=jj
                     i=k0
                     j=l0
                     k=i0
                     l=j0
                  else
                     i=i0
                     j=j0
                     k=k0
                     l=l0
                  endif
                  if(yw)print'(a,4i4,f12.8,4i4,1x,4i4)','LUE ijkl',i,
     *            j,k,l,a_cl(kk,i0),i0,j0,k0,l0,icl,jcl,kcl,lcl
!               enddo
!            enddo
!         enddo
!      enddo
!      stop
!      do
!         do
!            do
!               do
!                  ! Phase des orbitales
!                  a=a*product(iphas(nloc2sym((/i,j,k,l/))))
                  if(yw)print*,'iphas',iphas(nloc2sym((/i,j,k,l/)))
                  ! nombre d'integrales identiques
                  iden=product(nequis((/icl,jcl,kcl,lcl/)))
                  ! --> facteur de normalisation
                  a=a/dsqrt(1.d0*iden)
                  if(yw)print*,'a',a
                  call di1(i,j,k,l,icl,jcl,kcl,lcl,
     *            a,aa1,madr1)
                  if(icl==jcl.and.i/=j)
     *            call di1(j,i,k,l,icl,jcl,kcl,lcl,
     *            a,aa1,madr1)
                  if(icl==kcl.and.jcl==lcl.and.
     *            (i/=k.or.j/=l)) then
!                  if(icl==kcl.and.(nloc2sym(i)/=k)) then
                     call di1(k,l,i,j,icl,jcl,kcl,lcl,
     *               a,aa1,madr1)
                     if(icl==jcl.and.k/=l)
     *               call di1(l,k,i,j,icl,jcl,kcl,lcl,
     *               a,aa1,madr1)
                  endif
               enddo
            enddo
         enddo
!
!        2. Transformation Ijkl IJkl
!
         if(yw)print*,'Transformation Ijkl IJkl'
         n=0
         aa2=0.d0
         do m=1,nequis(icl)
            ii=iequiloc(icl,m)
            do jj=1,norb
               if(iclasloc(jj)>icl) exit
               j=jj
               jcl=iclasloc(jj)
               do k=1,norb
                  if(iclasloc(k)>icl) exit
                  kcl=iclasloc(k)
                  do ll=1,k
                     l=ll
                     lcl=iclasloc(ll)
                     n=n+1
!                     print*,'coucou'
!                     if(aa1(n)==0.d0) print*,'cycle'
                     if(aa1(n)==0.d0) cycle
                     if(yw)print'(a,5i4,f12.8,4i3)','Ijkl'
     *               ,n,ii,j,k,l,aa1(n),
     *               icl,jcl,kcl,lcl
                     call di2(ii,j,k,l,icl,jcl,kcl,lcl,aa1(n),aa2
     *               ,madr2)
                  enddo
               enddo
            enddo
         enddo
!
!        3. Transformation IJkl IJKl
!
         if(yw)print*,'Transformation IJkl IJKl'
         n=0
         aa1=0.d0
         do m1=1,nequis(icl)
            ii=iequiloc(icl,m1)
            do jj=1,ii
               jcl=iclasloc(jj)
               do k=1,norb
                  kcl=iclasloc(k)
                  if(kcl>icl) exit
                  do ll=1,k
                     lcl=iclasloc(ll)
                     l=ll
                     n=n+1
                     if(yw)print'(a,5i4,f12.8)','IJkl'
     *               ,n,ii,jj,k,l,aa2(n)
                     call di3(ii,jj,k,l,icl,jcl,kcl,lcl,aa2(n),aa1
     *               ,madr3)
                      if(kcl==lcl.and.k/=l)
     *                call di3(ii,jj,l,k,icl,jcl,kcl,lcl,aa2(n),aa1
     *               ,madr3)
                   enddo
               enddo
            enddo
         enddo
!
!        4. Transformation IJKl IJKL
!
         if(yw)print*,'Transformation IJKl IJKL'
         n=0
         aa2=0.d0
         do m1=1,nequis(icl)
            ii=iequiloc(icl,m1)
            do jj=1,ii
               jcl=iclasloc(jj)
               do kk=1,norb
                  kcl=iclasloc(kk)
                  if(kcl>icl) cycle
                  do ll=1,norb
                     lcl=iclasloc(ll)
                     if(lcl>kcl) exit
                     l=ll
                     n=n+1
                     if(yw)print'(a,5i4,f12.8)','IJKl',
     *               n,ii,jj,kk,l,aa1(n)
                     call di4(ii,jj,kk,l,icl,jcl,kcl,lcl,aa1(n),aa2
     *              ,madr4)!,aijil,aiikl,aijjj,aijij)
                  enddo
               enddo
            enddo
         enddo
         !
         ! Ecriture du fichier d'integrales i>j>k>l
         ! pour la classe icl
         !
         ii=0
         iiloc=0
         ! On regenere les indices i,j,k,l
         ! dans l'ordre ou ils sont dans aa2
         do m1=1,nequis(icl)
            m=iequiloc(icl,m1)
            if(itest(1)==1) then
               ! elimination des integrales non principales
               ! dont le 1er indice est secondaire
               ! (test a supprimer, ceci doit etre fait dans di1)
               if(iequiloc(icl,nequis(icl))/=m) cycle
               if(iequiloc(icl,nequis(icl))/=m) print*,'elim4_0',M
            endif
            do j=1,m-1
               do k=1,j-1
                  do l=1,k-1
                     ! eventuellement, fabrication du fichier pour casdi
                     if(ycd) then
                        ii=ii+1
                        if(yw)print 1001,'IJKLOC',m,j,k,l,aa2(ii),ii
                        call disin
     *                  (1,27,' ',ycl1,m,j,k,l,aa2(ii),nb_ijcl)
                        ii=ii+1
                        if(yw)print 1001,'IJKLOC',m,j,l,k,aa2(ii),ii
                        call disin
     *                  (1,27,' ',ycl1,m,j,l,k,aa2(ii),nb_ijcl)
                        ii=ii+1
                        if(yw)print 1001,'IJKLOC',m,k,j,l,aa2(ii),ii
                        call disin
     *                  (1,27,' ',ycl1,m,k,j,l,aa2(ii),nb_ijcl)
                     endif
                     ! fabrication du fichier pour casdiloc
                     if(ycdloc) then
                        if(itest(1)==1) then
                           ! elimination des integrales non principales
                           mjkl=(/m,j,k,l/)
                           call locsymint(mjkl,ibon)
                           !print*,'(/m,j,k,l/),ibon',(/m,j,k,l/),ibon
 
                           !???? appel locsymint deja fait dans di4
                           ! utile ici ????????
 
                           if(ibon/=0) then
                              iiloc=iiloc+3
                              if(yw)print'(a,5i5)','elim',m,j,k,l,iiloc
                              cycle
                           endif
                        endif
                        iiloc=iiloc+1
                        call disinl
     *                  (31,1,' ',1,m,j,k,l,aa2(iiloc))
                        iiloc=iiloc+1
                        call disinl
     *                  (31,1,' ',2,m,j,k,l,aa2(iiloc))
                        iiloc=iiloc+1
                        if(yw)
     *                  print'(a,5i5,3f10.6)','gardee',m,j,k,l,iiloc,
     *                  aa2(iiloc-2:iiloc)
                        call disinl
     *                  (31,1,' ',3,m,j,k,l,aa2(iiloc))
                     endif
                  enddo
               enddo
            enddo
         enddo
         !if(icl==2) stop
      enddo
      ! On a fini la boucle sur les classes
      ! les int a indices differents sont sur fichier
      ! les autres sont en memoire dans aijij aijjj aijil
!
!     fermetures, desallocations
      deallocate(aa1,aa2)
      call cpu_time(t1)
      print'(a,f12.2)','cpu',t1-t0
      if(ycdloc) then
         ! On finit d'ecrire et on ferme le fichier des int a 4 indices
         call disinl(31,2,' ',0,0,0,0,0,0.d0)
         deallocate (aaloc)
         allocate (aaloc(2,4096))
      endif
      close(21,status='delete')
      call filesplit('DELETE',21,0,idum,irec)
      !
      ! ecriture des orbitales aijij
      !
      open(25,file='BID_ECRIORB',status='old',form='unformatted')
      if(yw.or.nprint>0) then
         allocate(occupng(norb))
         read(25)
         read(25) occupng
         print*,'integrales d''echange'
         call scriptol(aijij
     *   ,norb,norb,norb,norb,tipo_l(1:norb)(1:8)
     *   ,(/(k,k=1,norb)/),
     *   tipo_l(1:norb)
     *   ,occup_l(1:norb))
         deallocate(occupng)
      endif
      close(25,status='delete')
      !
      ! Ecriture des liaisons correspondant a un seuil sijji
      !
      sijji=0.01
      print'(a,f8.4)','Integrales d''echange (occ,virt) >',sijji
      do k=1,norb
         if(orbi(k)(1:1).ne.'A'.and.k>noc) cycle
         print*,' '
         print'(a,f8.4)','========'//tipo_l(k)//' :  (iiii)=',aijij(k,k)
         n=0
         do l=1,norb
            if(orbi(l)(1:1).ne.'A'.and.l<=noc) cycle
            if(aijij(min(k,l),max(k,l))>sijji) then
               n=n+1
               gc(n)=tipo_l(l)
               bijji(n)=aijij(min(k,l),max(k,l))
!              print*,'ECH',k,l,aijij(min(k,l),max(k,l)),n
!             print*,bijji(1:n)
               if(n==3) then
                  print'(3(a12,f8.4,''   |   ''))',
     *            (gc(kk),bijji(kk),kk=1,3)
                  n=0
               endif
            endif
         enddo
         if(n/=0) print'(3(a12,f8.4,''   |   ''))',
     *   (gc(kk),bijji(kk),kk=1,n)
      enddo
      if(yw) then
         print*,'AIJJJ'
         call script(aijjj,norb,norb,norb,norb)
      endif
!
!     Ecriture des integrales a 3 indices differents
!
      ! ecriture casdi
      if(ycd) then
         ! iikl
         ii=0
         do k=2,norb
            do l=1,k-1
               ii=ii+1
               do i=1,norb
                  if(i.ne.k.and.i.ne.l) then
                     if(i>k) then
                        if(i>l) then
                           call disin
     *                     (1,27,' ',ycl1,i,i,k,l,aiikl(i,ii),nb_ijcl)
                        else
                           call disin
     *                     (1,27,' ',ycl1,i,l,k,i,aiikl(i,ii),nb_ijcl)
                        endif
                     else
                        if(i>l) then
                           call disin
     *                     (1,27,' ',ycl1,k,i,i,l,aiikl(i,ii),nb_ijcl)
                        else
                           call disin
     *                     (1,27,' ',ycl1,k,l,i,i,aiikl(i,ii),nb_ijcl)
                        endif
                     endif
                  endif
               enddo
            enddo
         enddo
         ! ijil
         ii=0
         do k=2,norb
            do l=1,k-1
               ii=ii+1
               do i=1,norb
                  if(i.ne.k.and.i.ne.l) then
                     if(i>k) then
                        call disin
     *                  (1,27,' ',ycl1,i,k,i,l,aijil(i,ii),nb_ijcl)
                     else
                        call disin
     *                  (1,27,' ',ycl1,k,i,l,i,aijil(i,ii),nb_ijcl)
                     endif
                  endif
               enddo
            enddo
         enddo
      endif
      ! ecriture casdiloc
      if(ycdloc) then
         ! Ouverture du fichier des integrales a 3 indices differents
         call disinl(30,0,ijclloc31,ibid,i,j,k,l,a)
         ! iikl ijil
         ii=0
         ! Ecriture du fichier des integrales a 3 indices differents
         do k=2,norb
            do l=1,k-1
               ii=ii+1
               do i=1,norb
                  if(itest(1)==1) then
                     ! elimination des integrales non principales
                     ! dont le plus grand indice est secondaire
                     ! (test a supprimer, ceci doit etre fait dans di1)
                     maxik=max(i,k)
                     icl=iclasloc(maxik)
                     if(iequiloc(icl,nequis(icl))/=maxik) cycle
!                     if(iequiloc(icl,nequis(icl))/=maxik)
!     *               print'(a,5i5)','Elim3',i,k,l
                  endif
                  if(i.ne.k.and.i.ne.l) then
                     if(itest(1)==1) then
                        ! elimination des integrales non principales
                        mjkl(1:3)=(/i,k,l/)
                        call locsymint3(mjkl(1:3),ibon)
                        if(ibon/=0) then
                           !print'(a,5i5)','elim3',i,k,l
                           cycle
                        endif
                     endif
                     !print'(a,5i5)','gard3',i,k,l
                     call disinl
     *               (30,1,' ',1,i,k,l,ibid,aiikl(i,ii))
                     call disinl
     *               (30,1,' ',2,i,k,l,ibid,aijil(i,ii))
                  endif
               enddo
            enddo
         enddo
         ! Fermeture du fichier des integrales a 3 indices differents
         call disinl(30,2,' ',0,0,0,0,0,0.d0)
         ! Ouverture du fichier des integrales a 2 indices differents
         open(29,file=ijclloc21,form='unformatted',
     *   status='unknown')
         ! Ecriture du fichier des integrales a 2 indices differents
         write(29) aijij
         write(29) aijjj
         close(29)
         deallocate (aaloc)
      endif
      if(ycd) then
         ! ijjj
         do k=1,norb
            do l=1,norb
               if(k.ne.l) then
                  if(k>l) then
                     call disin
     *               (1,27,' ',ycl1,k,l,l,l,aijjj(k,l),nb_ijcl)
                  else
                     call disin
     *               (1,27,' ',ycl1,l,l,l,k,aijjj(k,l),nb_ijcl)
                  endif
               endif
            enddo
         enddo
         ! ijij
         do k=1,norb
            do l=1,k
               call disin(1,27,' ',ycl1,k,l,k,l,aijij(k,l),nb_ijcl)
            enddo
         enddo
         ! ijji
         do k=2,norb
            do l=1,k-1
               call disin(1,27,' ',ycl1,k,k,l,l,aijij(l,k),nb_ijcl)
            enddo
         enddo
         if(ycl1) then
            ! hmono
            do k=1,norb
               do l=1,k
                  call disin(1,27,' ',ycl1,k,0,l,0,hmono(l,k),nb_ijcl)
               enddo
            enddo
         endif
         ! Fin d'ecriture du fichier d'integrales
         call disin(2,27,' ',ycl1,0,0,0,0,enuc,nb_ijcl)
         if(.not.ycl1) deallocate(aa)
      endif
 
 1001 format(a,4i4,f10.6,i6)
 1000                   format(a,4i4,2i6)
 
!     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!     Appel de test : ne sert pas
!     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      if(itest(2)==1) call testsymint
!     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      return
      end
       subroutine di1(i,j,k,l,icl,jcl,kcl,lcl,a,aa1,ndim)
      use module
      use moddi
      use mod_disin
      use modlirin
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      dimension aa1(ndim)
      yw=.false.
 
!      ii=nsym2loc(i)
!      jj=nsym2loc(j)
!      kk=nsym2loc(k)
!      ll=nsym2loc(l)
      ii=i
      jj=j
      kk=k
      ll=l
      if(yw)
     *print'(a,4i4,2x,4i3,f12.8)','entree di1',i,j,k,l,icl,jcl,kcl,lcl,a
      iadrkl=num1(kk+1)+ll
      nkl=num1(iequiloc(icl,nequis(icl))+2)
      iadr0=(jj-1)*nkl+iadrkl
      do i1=1,nequis(icl)
         if(itest(1)==1)then
            if(icl/=jcl) then
               if(icl/=kcl) then
                  if(yw.and.i1/=nequis(icl))
     *            print'(a,4i4,2x,4i4)','di1 elim',
     *            i,j,k,l,icl,jcl,kcl,lcl
                  if(i1/=nequis(icl)) cycle
               endif
            endif
         endif
         loci1=iequiloc(icl,i1)
         !print*,'loci1,i1',loci1,i1
         isgn1=dsym(i1,rang(nloc2sym(i)))
         isgn1=ipass_sgn(i1,(nloc2sym(i)))
         iadr=incr1(loci1)+iadr0
         if(yw)print*,iadr,iadrkl,nkl,loci1,incr1(loci1),iadr0
         aa1(iadr)=aa1(iadr)+a*isgn1
         if(yw)print'(2f12.8,8i4)',aa1(iadr),a,isgn1,
     *   ipass_sgn(i1,(nloc2sym(i))),i1,(nloc2sym(i)),i,icl,loci1
         if(yw)print'(a,i6,f12.8,2i5,f12.8,a,4i3)'
     *   ,'di1',iadr,aa1(iadr),loci1,isgn1,a,' ->',loci1,j,k,l
      enddo
      return
      end
       subroutine di2(i,j,k,l,icl,jcl,kcl,lcl,a,aa2,ndim)
      use module
      use moddi
      use mod_disin
      use modlirin
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      dimension aa2(ndim)
      yw=.false.
      kk=(k)
      ll=(l)
      iadrkl=num1(kk+1)+ll
      do i1=1,nequis(jcl)
         loci2=iequiloc(jcl,i1)
         if(loci2>i) cycle
         ij=num1(i+1)+loci2
         isgn1=dsym(i1,rang(nloc2sym(j)))
         isgn1=ipass_sgn(i1,(nloc2sym(j)))
         iadr=incr2(ij)+iadrkl
         aa2(iadr)=aa2(iadr)+a*isgn1
         if(yw)print'(a,i6,f12.8,2i5,f12.8,a,4i3)'
     *   ,'di2',iadr,aa2(iadr),loci2,isgn1,a,' ->',i,loci2,k,l
      enddo
      return
      end
       subroutine di3(i,j,k,l,icl,jcl,kcl,lcl,a,aa1,ndim)
      use module
      use moddi
      use mod_disin
      use modlirin
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      dimension aa1(ndim)
      yw=.false.
      ll=(l)
      ij=num1(i+1)+j
      do i1=1,nequis(kcl)
         loci3=iequiloc(kcl,i1)
         if(loci3>i.and.jcl==lcl) cycle
         isgn1=dsym(i1,rang(nloc2sym(k)))
         isgn1=ipass_sgn(i1,(nloc2sym(k)))
         iadr=incr3(ij)+incr3k(loci3,ll)
         aa1(iadr)=aa1(iadr)+a*isgn1
         if(yw)print'(a,i6,f12.8,2i5,f12.8,a,4i3)'
     *   ,'di3',iadr,aa1(iadr),loci3,isgn1,a,' ->',i,j,loci3,l
      enddo
      return
      end
       subroutine di4(i,j,k,l,icl,jcl,kcl,lcl,a,aa2,ndim)!,aijil,
      !*aiikl,aijjj,aijij)
      use module
      use moddi
      use mod_disin
      use modlirin
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      dimension aa2(ndim)
      !dimension aiikl(norb,num1(norb+1))
      !dimension aijil(norb,num1(norb+1))
      !dimension aijjj(norb,norb)
      !dimension aijij(norb,norb)
      integer,dimension(4) :: loci
      yw=.false.
      ll=nsym2loc(l)
      do i1=1,nequis(lcl)
         loci(1:3)=(/i,k,j/)
         loci(4)=iequiloc(lcl,i1)
         if(loci(4)>k) cycle
         if(i==k) then
            if(loci(4)>j) cycle
         endif
         isgn=dsym(i1,rang(nloc2sym(l)))
         isgn=ipass_sgn(i1,(nloc2sym(l)))
         ! on reordonne les indices en ordre decroissant
         if(yw) then
            write(75,*)'di4-->(',loci((/1,3,2,4/)),')$'
            call scril
         endif
         if(yw)print'(a,4i3)','loci avant reori',loci
         call reori(loci,it,'  ')
         ! si itest(1)=1 : on elimine les integrales non
         ! principales
         if(itest(1)==1) then
            call locsymint(loci,ibon)
            !print*,'loci,ibon',loci,ibon
            if(ibon/=0) cycle
         endif
         ! Adresse
         call iadri(loci,iadr,icas,i2,j2,it)
         select case (icas)
            case (1)
               aa2(iadr)=aa2(iadr)+a*isgn
               if(yw)print'(a,i6,f12.8,4i5,i7,f12.8,i3)'
     *         ,'di4_ijkl',iadr,aa2(iadr),loci,isgn,a,it
            case (2)
               aijil(i2,iadr)=aijil(i2,iadr)+a*isgn
               if(yw)print'(a,i6,f12.8,4i5,i7,f12.8,i3)'
     *         ,'di4_ijil',iadr,aijil(i2,iadr),loci,isgn,a,it
            case (3)
               aiikl(i2,iadr)=aiikl(i2,iadr)+a*isgn
               if(yw)print'(a,i6,f12.8,4i5,i7,f12.8,i3)'
     *         ,'di4_iikl',iadr,aiikl(i2,iadr),loci,isgn,a,it
            case (5)
               aijjj(i2,j2)=aijjj(i2,j2)+a*isgn
               if(yw)print'(a,2i3,f12.8,4i5,i7,f12.8,i3)'
     *         ,'di4_ijjj',i2,j2,aijjj(i2,j2),loci,isgn,a,it
               if(yw)print 1004,'ijjj',loci,i2,j2,aijjj(i2,j2),
     *         isgn
            case (4)
               aijij(i2,j2)=aijij(i2,j2)+a*isgn
               if(yw)print'(a,2i3,f12.8,4i5,i7,f12.8,i3)'
     *         ,'di4_ijij',i2,j2,aijij(i2,j2),loci,isgn,a,it
               if(yw)print 1004,'ijij',loci,i2,j2,aijij(i2,j2),
     *         isgn
         end select
 1000    format(a,4i4,2i6)
 1001    format(a,8i4,2i6)
 1005    format(a,12i4,2i6)
 1002    format(a,4i4,i6,f12.8)
 1004    format(a,4i4,i6,i4,f12.8,i3)
      enddo
      return
      end
