      subroutine tra1
      use module
      use mod_script
      use mod_lirorb
      use mod_licost
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      double precision,allocatable,dimension(:,:) :: om,om_1,hom,hmonot
      double precision,allocatable,dimension(:) :: r8,h8
      integer,allocatable,dimension(:) :: num1,iord_ov2
      character(80) aa
      integer(2) idx(2,4096)
!     
!**************************ATTENTION**************
! idx dans Q5  idx(4096,2)       modifier q52casdi
!*************************************************
      dimension value(4096)
      yw=.false.
      yw1=.false.
      yw=yw.or.ywtot
      yw1=yw1.or.ywtot
      
!     
! Allocations
!     
      allocate(num1(noa+1))
      do k=1,noa+1
         num1(k)=k*(k-1)/2
      enddo
      nn=0
      do is=1,nsym
         nn=nn+num1(isym(is)+1)
      enddo
      allocate(h8(nn))
      allocate(hmonot(norb,norb))
      hmonot=0.d0
!     
! read full Hmono matrix
!     
      nn=num1(noa+1)
      allocate(r8(nn))
      ij=0
      do
         read(1) idx,value
         do k=1,4096
            if(idx(1,k)==0) goto 1
            i=max(idx(1,k),idx(2,k))
            j=min(idx(1,k),idx(2,k))
            ij=num1(i)+j
            r8(ij)=value(k)
            !print'(3i6,f14.6)',i,j,ij,r8(ij)
         enddo
      enddo
 1    continue
!     
! Compute MO Hmono matrix (frozen + non frozen)
! Loop on symmetries
!     
      h8=0.d0
      ndimst=0
      rewind 34
      rewind 33
      kl=0
      ifin=0
      ifint=0
      open(26,file='HMONOTEMP',form='unformatted',status='unknown')
      !deallocate(hmono)
      do is=1,nsym
         ndims=isymoa(is)
         ndimsd=isymoa(is)-delete(is)
         if(ndimsd==0) then
            read(33)
            read(34)
            cycle
         endif
         if(yw)print*,'kl',kl
!     
! read MO's and Hmono of symmetry is
!     
         allocate(om(ndims,ndims))
         read(34) om(:,1:frozen(is))
         read(33) om(:,frozen(is)+1:ndimsd)
         allocate(hmono(ndims,ndims))
         allocate(om_1(ndims,ndimsd))
         allocate(hom(ndims,ndims))
         do k=1,ndims
            kl=kl+sum(isymoa(1:is-1))
            do l=1,k
               kl=kl+1
               hmono(k,l)=r8(kl)
               hmono(l,k)=r8(kl)
            enddo
         enddo
         !print*,'HMONO SYM',is
         !call mscript(hmono(1:ndims,1:ndims))
         if(yw1) then
            print*,'tra1 int mono atomiques   sym',is
            call mscript(hmono)
            print*,'tra1 orb moleculaires     sym',is
            call mscript(om)
         endif
!     
! Transform Hmono
!     
         om_1=0.d0
         DO I=1,ndimsd
            DO J=1,ndims
               DO K=1,ndims
                  om_1(J,I)=om_1(J,I)+om(k,i)*hmono(K,J)
               enddo
            enddo
         enddo
         !if(yw)print*,'tra1 hpi'
         !if(yw)call mscript(om_1)
         hmono=0.d0
         DO I=1,ndimsd
            DO J=1,I
               DO K=1,ndims
                  hmono(I,J)=hmono(I,J)+om_1(K,I)*om(k,j)
                  hmono(J,I)=hmono(I,J)
               enddo
            enddo
         enddo
         ii=frozen(is)
         idebt=ifint+1
         ifint=ifint+isym(is)
         hmonot(idebt:ifint,idebt:ifint)=
     *   hmono(ii+1:ii+isym(is),ii+1:ii+isym(is))
         if(yw1)print*,'1e molecular integrals   sym',is
         if(yw1)call mscript(hmono(1:ndimsd,1:ndimsd))
!     
! treatment of frozen orbitals
! Nuclear Energy
         do k=1,frozen(is)
            if(yw)print*,'ENUC1',enuc,enuc+hmono(k,k)*2,hmono(k,k)
            enuc=enuc+hmono(k,k)*2
         enddo
!     
! fill h8, containing the hmono matrix of all symmetries,
! only non frozen and non deleted orbitals
         ideb=ifin+1
         ifin=ifin+num1(isym(is)+1)
         ii=frozen(is)
         h8(ideb:ifin)=(/((hmono(ii+i,ii+j),j=1,i),i=1,isym(is))/)
         if(isym(is)/=0) write(26) h8(ideb:ifin)
         if(yw)write(6,*)'h8', h8(ideb:ifin)
         !print*,'ideb,ifin',ideb,ifin
         !print*,'isym',isym
         deallocate(om,hom,om_1,hmono)
      enddo
      !deallocate(hmonot)
!     
! end of loop on symmetries
!     
      if(yw)print'(10f8.4)',h8(1:ifin)
      !call mscript(hmonot)
      !call ecris(-21,hmonot,norb,'BID','BID',.false.,nsym,isym)
      return
      end
      
      
      
      
      
      
      
