      module mod_ena
      integer,save :: imat(2048),jmat(2048),ijmat=0
      real(4),save :: dmat(2048)
      contains
       subroutine ena(aa,longc,idetc1,idetc2,longtp,jtp1,jtp2,isgn)
      use module
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      dimension idetc1(longc),idetc2(longc)
      dimension jtp1(longtp),jtp2(longtp)
      integer,intent(in),optional,dimension(longc) :: isgn
      integer,allocatable,dimension(:) :: jjtp1,jjtp2
      
      if(calcul=='M') then
         if(w)print*,'entree ena'
         if(w)print*,idebc(1),ifinc(1)
         if(w)print*,idebc(2),ifinc(2)
         if(w)print'(10i8)',idetc(idebc(1):ifinc(1))
         if(w)print'(a)','idetc1'
         if(w)print'(10i8)',idetc1
         if(w)print'(a)','idetc2'
         if(w)print'(10i8)',idetc2
         if(w)print'(a)','jtp1'
         if(w)print'(10i8)',jtp1
         if(w)print'(a)','jtp2'
         if(w)print'(10i8)',jtp2
         do i=1,longc
            if(present(isgn)) then
               aa1=aa*isgn(i)
            else
               aa1=aa
            endif
            do j=1,longtp
               iadr1=idetc1(i)+jtp1(j)
               iadr2=idetc2(i)+jtp2(j)
               jjadr1=max(iadr1,iadr2)
               jjadr2=min(iadr1,iadr2)
               if(w1)print 1000,'elt_mat',jjadr1,jjadr2,iadr1,iadr2,aa1
!               if(jjadr1==41254.and.jjadr2==172) then
!                  print 1000,'elt_mat1',jjadr1,jjadr2,iadr1,iadr2,aa1
!                  stop
!               endif
 1000          format(a,4i6,f15.8)
               ! remplissage du fichier mat
               call ecrmat(iadr1,iadr2,aa1)
            enddo
         enddo
      else
         if(itest(13)==3) allocate(jjtp1(longtp),jjtp2(longtp))
         do i=1,longc
            if(present(isgn)) then
               aa1=aa*isgn(i)
            else
               aa1=aa
            endif
            if(itest(7)==1) cycle
            ! Produit
            if(itest(13)==2) then
               call enar(idetc1(i)+jtp1(1:longtp),
     *         idetc2(i)+jtp2(1:longtp),longtp,aa1)
            else if(itest(13)==1) then
               do j=1,longtp
                  iadr1=idetc1(i)+jtp1(j)
                  iadr2=idetc2(i)+jtp2(j)
                  ! Produit
                 ! v2(iadr2,:)=v2(iadr2,:)+aa1*v1(iadr1,:)
                 ! v2(iadr1,:)=v2(iadr1,:)+aa1*v1(iadr2,:)
                  call prodena0(aa1,iadr1,iadr2)
               enddo
            else if(itest(13)==3) then
               do iv=1,maxl0
                  jjtp1=idetc1(i)+jtp1
                  jjtp2=idetc2(i)+jtp2
                  v2(jjtp2,iv)=v2(jjtp2,iv)+aa1*v1(jjtp1,iv)
                  v2(jjtp1,iv)=v2(jjtp1,iv)+aa1*v1(jjtp2,iv)
               enddo
            else
               do iv=1,maxl0
!   Habillage a partir de ITERH
               !print*,'hab,nhab,iv,iter,iterh',hab,nhab,iv,iter,iterh
                  if(iter.ge.iterh.and.hab.ne.0.and.nhab==iv) then
!                      print*,'mod_ena : habillage'
                      do kkk=1,longtp
                        delta(hab)=delta(hab)+vhab(idetc1(i)+jtp1(kkk))
     *                  *vhab(idetc2(i)+jtp2(kkk))*aa1
                        if(mprinth(1)==1)
     *                  print'(a,3i4,2d26.15)','hab,delta(hab)',
     *                  idetc1(i)+jtp1(kkk),idetc2(i)+jtp2(kkk)
     *                  ,hab,vhab(idetc1(i)+jtp1(kkk))
     *                  *vhab(idetc2(i)+jtp2(kkk))*aa1,delta(hab)
                        v2(idetc2(i)+jtp2(kkk),iv)=
     *                  v2(idetc2(i)+jtp2(kkk),iv)
     *                  +aa1*v1(idetc1(i)+jtp1(kkk),iv)
                        v2(idetc1(i)+jtp1(kkk),iv)=
     *                  v2(idetc1(i)+jtp1(kkk),iv)
     *                  +aa1*v1(idetc2(i)+jtp2(kkk),iv)
                     enddo
                 else
                     do kkk=1,longtp
                        v2(idetc2(i)+jtp2(kkk),iv)=
     *                  v2(idetc2(i)+jtp2(kkk),iv)
     *                  +aa1*v1(idetc1(i)+jtp1(kkk),iv)
                        v2(idetc1(i)+jtp1(kkk),iv)=
     *                  v2(idetc1(i)+jtp1(kkk),iv)
     *                  +aa1*v1(idetc2(i)+jtp2(kkk),iv)
                    enddo
                 endif
              enddo
            endif
         enddo
         if(itest(13)==3) deallocate(jjtp1,jjtp2)
      endif
!     if (iter.gt.1.and.hab.ne.0) print*,'hab',hab,'delta',delta(hab)
      return
      end subroutine
       subroutine ena_ccccd(aa,longc,idetc1,idetc2,longtp,isgn)
      use module
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      dimension idetc1(longc),idetc2(longc)
      integer,intent(in),optional,dimension(longc) :: isgn
      if(calcul=='M') then
         do i=1,longc
            if(present(isgn)) then
               aa1=aa*isgn(i)
            else
               aa1=aa
            endif
            do j=1,longtp
               iadr1=idetc1(i)+j
               iadr2=idetc2(i)+j
               jjadr1=max(iadr1,iadr2)
               jjadr2=min(iadr1,iadr2)
               if(w1)print 1000,'elt_mat',jjadr1,jjadr2,iadr1,iadr2,aa1
!               if(jjadr1==41254.and.jjadr2==172) then
!                  print 1000,'elt_mat1',jjadr1,jjadr2,iadr1,iadr2,aa1
!                  stop
!               endif
 1000          format(a,4i6,f15.8)
               ! remplissage du fichier mat
               call ecrmat(iadr1,iadr2,aa1)
            enddo
         enddo
      else
         do i=1,longc
            if(present(isgn)) then
               aa1=aa*isgn(i)
            else
               aa1=aa
            endif
            if(itest(7)==1) cycle
            ! Produit
               do iv=1,maxl0
!   Habillage a partir de ITERH
               !print*,'hab,nhab,iv,iter,iterh',hab,nhab,iv,iter,iterh
                  if(iter.ge.iterh.and.hab.ne.0.and.nhab==iv) then
!                      print*,'mod_ena : habillage'
                      do kkk=1,longtp
                        delta(hab)=delta(hab)+vhab(idetc1(i)+kkk)
     *                  *vhab(idetc2(i)+kkk)*aa1
                        if(mprinth(1)==1)
     *                  print'(a,3i4,2d26.15)','hab,delta(hab)',
     *                  idetc1(i)+kkk,idetc2(i)+kkk
     *                  ,hab,vhab(idetc1(i)+kkk)
     *                  *vhab(idetc2(i)+kkk)*aa1,delta(hab)
                        v2(idetc2(i)+kkk,iv)=
     *                  v2(idetc2(i)+kkk,iv)
     *                  +aa1*v1(idetc1(i)+kkk,iv)
                        v2(idetc1(i)+kkk,iv)=
     *                  v2(idetc1(i)+kkk,iv)
     *                  +aa1*v1(idetc2(i)+kkk,iv)
                     enddo
                 else
                     do kkk=1,longtp
                        v2(idetc2(i)+kkk,iv)=
     *                  v2(idetc2(i)+kkk,iv)
     *                  +aa1*v1(idetc1(i)+kkk,iv)
                        v2(idetc1(i)+kkk,iv)=
     *                  v2(idetc1(i)+kkk,iv)
     *                  +aa1*v1(idetc2(i)+kkk,iv)
                    enddo
                 endif
              enddo
         enddo
      endif
!     if (iter.gt.1.and.hab.ne.0) print*,'hab',hab,'delta',delta(hab)
      return
      end subroutine
       subroutine ena_ccccd2(aa,longc,idetc1,idetc2,longtp,ntp,isgn)
      use module
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      dimension idetc1(longc),idetc2(longc)
      integer,intent(in),optional,dimension(longc) :: isgn
      
      if(calcul=='M') then
         if(w)print*,'entree ena'
         if(w)print*,idebc(1),ifinc(1)
         if(w)print*,idebc(2),ifinc(2)
         if(w)print'(10i8)',idetc(idebc(1):ifinc(1))
         if(w)print'(a)','idetc1'
         if(w)print'(10i8)',idetc1
         if(w)print'(a)','idetc2'
         if(w)print'(10i8)',idetc2
         do i=1,longc
            if(present(isgn)) then
               aa1=aa*isgn(i)
            else
               aa1=aa
            endif
            jj=ntp
            do j=1,longtp
               jj=jj+1
               iadr1=idetc1(i)+jj
               iadr2=idetc2(i)+jj
               jjadr1=max(iadr1,iadr2)
               jjadr2=min(iadr1,iadr2)
               if(w1)print 1000,'elt_mat',jjadr1,jjadr2,iadr1,iadr2,aa1
!               if(jjadr1==41254.and.jjadr2==172) then
!                  print 1000,'elt_mat1',jjadr1,jjadr2,iadr1,iadr2,aa1
!                  stop
!               endif
 1000          format(a,4i6,f15.8)
               ! remplissage du fichier mat
               call ecrmat(iadr1,iadr2,aa1)
            enddo
         enddo
      else
         do i=1,longc
            if(present(isgn)) then
               aa1=aa*isgn(i)
            else
               aa1=aa
            endif
            if(itest(7)==1) cycle
            ! Produit
            do iv=1,maxl0
!   Habillage a partir de ITERH
            !print*,'hab,nhab,iv,iter,iterh',hab,nhab,iv,iter,iterh
               if(iter.ge.iterh.and.hab.ne.0.and.nhab==iv) then
!                   print*,'mod_ena : habillage'
                    jj=ntp
                    do kkk=1,longtp
                     jj=jj+1
                     delta(hab)=delta(hab)+vhab(idetc1(i)+jj)
     *               *vhab(idetc2(i)+jj)*aa1
                     if(mprinth(1)==1)
     *               print'(a,3i4,2d26.15)','hab,delta(hab)',
     *               idetc1(i)+jj,idetc2(i)+jj
     *               ,hab,vhab(idetc1(i)+jj)
     *               *vhab(idetc2(i)+jj)*aa1,delta(hab)
                     v2(idetc2(i)+jj,iv)=
     *               v2(idetc2(i)+jj,iv)
     *               +aa1*v1(idetc1(i)+jj,iv)
                     v2(idetc1(i)+jj,iv)=
     *               v2(idetc1(i)+jj,iv)
     *               +aa1*v1(idetc2(i)+jj,iv)
                  enddo
              else
                  jj=ntp
                  do kkk=1,longtp
                     jj=jj+1
                     v2(idetc2(i)+jj,iv)=
     *               v2(idetc2(i)+jj,iv)
     *               +aa1*v1(idetc1(i)+jj,iv)
                     v2(idetc1(i)+jj,iv)=
     *               v2(idetc1(i)+jj,iv)
     *               +aa1*v1(idetc2(i)+jj,iv)
                 enddo
              endif
           enddo
         enddo
      endif
!     if (iter.gt.1.and.hab.ne.0) print*,'hab',hab,'delta',delta(hab)
      return
      end subroutine
       subroutine prodena0(aa1,iadr1,iadr2)
      use module
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      do k=1,maxl0
         !if(ycvl(k)) cycle
         v2(iadr2,k)=v2(iadr2,k)+aa1*v1(iadr1,k)
         v2(iadr1,k)=v2(iadr1,k)+aa1*v1(iadr2,k)
      enddo
      return
      end subroutine
C       subroutine prodena(iadr1,iadr2,aa,longtp)
C      use module
C      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
C      dimension iadr1(longtp),iadr2(longtp)
C      !if(size(iadr1)/=longtp) stop'(size(iadr1)/=longtp)'
C      do k=1,maxl0
C         v2(iadr2,k)=v2(iadr2,k)+aa1*v1(iadr1,k)
C         v2(iadr1,k)=v2(iadr1,k)+aa1*v1(iadr2,k)
C      enddo
C      return
C      end subroutine
       subroutine ecrmat(iadr1,iadr2,aa)
      use module
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
!      integer,save :: imat(2048),jmat(2048),ijmat=0
!      real(4),save :: dmat(2048)
      ijmat=ijmat+1
      if(ijmat>2048) then
         ijmat=1
         if(itest(1)==0) write(50) imat,jmat,dmat
         imat=0
         jmat=0
         dmat=0.d0
      endif
      imat(ijmat)=iadr1
      jmat(ijmat)=iadr2
      if(iadr1==iadr2) then
         dmat(ijmat)=aa/2
      else
         dmat(ijmat)=aa
      endif
      return
      end subroutine
       subroutine ecrmatf
       
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
!      integer,save :: imat(2048),jmat(2048)
!      real(4),save :: dmat(2048)
      ijmat=ijmat+1
      if(ijmat>2048) then
         ijmat=1
         write(50) imat,jmat,dmat
      endif
      imat(2048)=-1
      jmat(2048)=ijmat-1
      dmat(ijmat)=0.d0
      write(50) imat,jmat,dmat

      return
      end subroutine
      end module

