      subroutine tijklfr
      !subroutine tijklfr(hhhijil,hhhiikl)
      use module
      use mod_script
      use mod_licost
      use mod_tijkl
      use mod_sto
      implicit real*8 (a-h,o-x,z),logical*1(y)
      allocatable omfr(:,:,:)
      dimension isv(8)
      !dimension hhhijil(idimfr,nfr)
      !dimension hhhiikl(idimfr,nfr)
      double precision,allocatable,dimension(:,:) :: hhhijil,hhhiikl
      dimension numt(8)
      character(80) name
      double precision,allocatable,dimension(:,:) :: hh1,hh
      double precision,allocatable,dimension(:) :: h8
C      double precision,allocatable,dimension(:,:) :: hmonot
      yw1=.false.
      yw=.false.
      yw=yw.or.ywtot
      yw1=yw1.or.ywtot
!
! Allocation!
!
!    One wants to store integrals of the type: (FFrs) and (FqFs)
!    F=frozen orb, r,s or q,s = AO's of the same symmetry
!    the total dimension of the integrals is then
!    (nfr,sum(isymoa*(isymoa+1)/2)
      if(any(frozen/=0)) then
         nfr=sum(frozen)
         idimfr=0
         do is=1,nsym
            idimfr=idimfr+num1(isymoa(is)+1)
         enddo
      endif
      allocate(hhhijil(idimfr,nfr))
      allocate(hhhiikl(idimfr,nfr))
      if(yw)print*,'ENUC en entree tijklfr',enuc
!
! Initialization
!
      hhhijil=0.d0
      hhhiikl=0.d0
      if(yw)print*,'isymoa',isymoa
      if(yw)print*,'isym',isym
      if(yw)print*,'frozen',frozen
!
! Read 1-e integrals
!
      nn=0
      do is=1,nsym
         nn=nn+num1(isym(is)+1)
      enddo
      allocate(h8(nn))
      rewind 26
      ifin=0
      do is=1,nsym
         if(isym(is)==0) cycle
         ideb=ifin+1
         ifin=ifin+num1(isym(is)+1)
         read(26) h8(ideb:ifin)
      enddo
      if(yw)print*,'h8'
      if(yw)print'(6f12.8)',h8
!
! frozen molecular orbitals
!
      numt(1)=0
      do is=2,nsym
         numt(is)=numt(is-1)+num1(isymoa(is-1)+1)
      enddo
      if(yw)print*,'NUMT',numt
      if(yw)print*,'isymoa',isymoa
      if(yw)print*,'isymoa',num1(isymoa+1)
      msym1=maxval(isymoa(1:nsym))
      msym2=maxval(frozen(1:nsym))
!
! matrice de passage
!
      msymoa=maxval(isymoa(1:nsym))
      !deallocate(om)
      allocate(om(msymoa,msymoa,nsym))
      ! read the orbitals
      rewind 33
      rewind 34
      do is=1,nsym
         n=isym(is)
         !if(n==0) cycle
         n1=isymoa(is)
         n2=frozen(is)
         read(33) om(1:n1,n2+1:n2+n,is)
         !if(n1==0.or.n2==0) cycle
         read(34) om(1:n1,1:n2,is)
         if(yw1)print*,'ijkl0 om sym',is
         if(yw1) call mscript(om(1:n1,1:n1,is))
      enddo
!
! initialize integrals reading
!
      open(11,file=pqrs1,status='old',form='unformatted')
      !inquire(11,name=name)
      !print*,'pqrs1',pqrs1
      !print*,'name',name;stop
       inquire(11,name=name)
       if(yw)print*,'TIJKLFR',name
      call lirpqrs(0,ijkl0,a,11,idum1,idum2)
      call lirpqrs(1,ijkl0,a1,11,idum1,idum2)
      do
         if(ijkl0(4)==0) exit
         if(yw)print'(a,4i4,f12.8)','tijklfr',ijkl0,a
         is0=itsymoa(ijkl0(1))
         js0=itsymoa(ijkl0(2))
         ks0=itsymoa(ijkl0(3))
         ls0=itsymoa(ijkl0(4))
         ! reorder indices according to symmetries
         call reors(ijkl0,is0,js0,ks0,ls0)
         nis=frozen(is0)
         njs=frozen(js0)
         nks=frozen(ks0)
         nls=frozen(ls0)
         nisoa=isymoa(is0)
         njsoa=isymoa(js0)
         nksoa=isymoa(ks0)
         nlsoa=isymoa(ls0)
         call cpu_time(t0)
         if(yw1)print*,'IS0,JS0,KS0,LS0',IS0,JS0,KS0,LS0
         if(is0==js0) then
            if(js0==ks0) then
               if(yw1)print*,'ETAPE IIII'
!
!-------------------------------------------
! loop on the <is is is is> integrals
!-------------------------------------------
!
               hii=0.d0
               hij=0.d0
               do
                  ijkls=insoa(ijkl0)
                  ps=ijkls(1)
                  qs=ijkls(2)
                  rs=ijkls(3)
                  ss=ijkls(4)
                  if(ps<rs) then
                     i=ps
                     ps=rs
                     rs=i
                     i=qs
                     qs=ss
                     ss=i
                  endif
                  if(ps==rs.and.qs<ss) then
                     i=qs
                     qs=ss
                     ss=i
                  endif
                  if(yw)print'(a,4i3,2x,4i3,2f8.4)','is is is is ',
     *            ijkl0,ijkls,a1,hhhiikl(11,1)
                  a11=a1
                  a12=a1
                  a13=a1
                  a14=a1
                  if(rs/=ss) a11=a1+a1
                  if(ps/=qs) a12=a1+a1
                  if(qs/=ss) a13=a1+a1
                  if(ps/=rs) a14=a1+a1
!
!                 incrementation de pqII et pIrI, rsII et qIsI
!
                  iad1=numt(is0) ! adr des sym prec.
     *            +num1(ps)+qs
                  iad2=numt(is0) ! adr des sym prec.
     *            +num1(rs)+ss
                  if(yw)print'(a,6i4)','iad',ps,qs,rs,ss,iad1,iad2
                     !do is=1,nsym
                  if=sum(frozen(1:is0-1))
                  do i=1,frozen(is0)
!
! increment hhhiikl=(IIpq)  I frozen
!
                     if=if+1
                     hhhiikl(iad1,if)=hhhiikl(iad1,if)+
     *               a11*om(rs,I,is0)*om(ss,I,is0)
!                     if(yw) then
!                        if(iad1==76.and.if>=1)
!                        print'(a,5f12.8,i5)','hhh1',
!     *                  om(rs,I,is0),om(ss,I,is0),
!     *                  a11,a12,hhhiikl(iad1,if),if
!                     endif
!
! increment hhhiikl=(IIrs)  I frozen
!
                     if(ps/=rs.or.qs/=ss) then
                        hhhiikl(iad2,if)=hhhiikl(iad2,if)+
     *                  a12*om(ps,I,is0)*om(qs,I,is0)
                        if(yw) then
!                           if(iad2==11.and.if>=1)
!!!!                        print'(a,6f12.8,i5)','HHH1'
!     &                     ,om(ps,I,is0),om(qs,I,is0),
!     *                     a12*om(ps,I,is0)*om(qs,I,is0),
!     *                     a11,a12,hhhiikl(iad2,if),if
                        endif
                     endif
!
! increment hhhijil=(pIrI)  I frozen
!
                     iad0=numt(is0) ! adr des sym prec.
                     call tijklfr2(ps,qs,rs,ss,iad0,1,if,hhhijil,i,is0)
                     if(rs/=ss)
     *               call tijklfr2(ps,qs,ss,rs,iad0,2,if,hhhijil,i,is0)
                     if(ps/=qs)
     *               call tijklfr2(qs,ps,rs,ss,iad0,3,if,hhhijil,i,is0)
                     if(ps/=qs.and.rs/=ss)
     *               call tijklfr2(qs,ps,ss,rs,iad0,4,if,hhhijil,i,is0)
                     if(ps/=rs.or.qs/=ss) then
                        call tijklfr2(rs,ss,ps,qs,iad0,5,
     *                  if,hhhijil,i,is0)
                        if(ps/=qs)
     *                  call tijklfr2(rs,ss,qs,ps,iad0,6,
     *                  if,hhhijil,i,is0)
!                        if(rs/=ss)
!     *                  call tijklfr2(ss,rs,ps,qs,iad0,7,
!     *                  if,hhhijil,i,is0)
                        if(ps/=qs.and.rs/=ss)
     *                  call tijklfr2(ss,rs,qs,ps,iad0,8,
     *                  if,hhhijil,i,is0)
                     endif
                  enddo
!
! read the following integral
!
                  call lirpqrs(1,ijkl0,a1,11,idum1,idum2)
                  !print'(a,4i4,f12.8)','Ijkl0 ',ijkl0,a1
                  if(ijkl0(4)==0) exit
                  is=itsymoa(ijkl0(1))
                  js=itsymoa(ijkl0(2))
                  ks=itsymoa(ijkl0(3))
                  ls=itsymoa(ijkl0(4))
                  ! reorder indices according to symmetries
                  call reors(ijkl0,is,js,ks,ls)
                  if(any((/is,js,ks,ls/)/=(/is0,js0,ks0,ls0/))) then
                     if(yw)print'(a,4i4,2x,4i4)',
     *               'nouveau',is,js,ks,ls,is0,js0,ks0,ls0
                     exit
                  endif
               enddo
            else
               if(yw1)print*,'ETAPE IIKK'
!
!-------------------------------------------
! loop on the <is is ks ks> integrals
!-------------------------------------------
!
               do
                  ijkls=insoa(ijkl0)
                  ps=ijkls(1)
                  qs=ijkls(2)
                  rs=ijkls(3)
                  ss=ijkls(4)
                  if(yw)print'(a,4i3,2x,4i3,f8.4)','is is ks ks ',
     *            ijkl0,ijkls,a1
                  a11=a1
                  a12=a1
                  if(rs/=ss) a11=a1+a1
                  if(ps/=qs) a12=a1+a1
!
!                 incrementation de pqII et pIrI, rsII et qsII
!
                  iad1=numt(is0) ! adr des sym prec.
     *            +num1(ps)+qs
                  iad2=numt(ks0) ! adr des sym prec.
     *            +num1(rs)+ss
                  if(yw)print*,'iadiikk',iad1,iad2
                  !do is=1,nsym
                  if=sum(frozen(1:ks0-1))
!
! increment hhhiikl=(pqII)  I frozen
!
                  do i=1,frozen(ks0)
                     if=if+1
                     hhhiikl(iad1,if)=hhhiikl(iad1,if)+
     *               a11*om(rs,I,ks0)*om(ss,I,ks0)
!                     if(iad1==11.and.if>=1)
!     *               print'(a,5f12.8,5i5)','hhh5',
!     *               om(rs,I,ks0),om(ss,I,ks0),
!     *               a11,a12,hhhiikl(iad1,if),if
                  enddo
                  if=sum(frozen(1:is0-1))
!
! increment hhhiikl=(rsII)  I frozen
!
                  do i=1,frozen(is0)
                     if=if+1
                     hhhiikl(iad2,if)=hhhiikl(iad2,if)+
     *               a12*om(ps,I,is0)*om(qs,I,is0)
!                     if(iad2==11.and.if>=1)
!     *               print'(a,6f12.8,5i5)','hhh7',
!     *               om(ps,I,is0),om(qs,I,is0),
!     *               a12*om(ps,I,is0)*om(qs,I,is0),
!     *               a11,a12,hhhiikl(iad2,if),if,numt(ks0),ks0
                  enddo
                  !enddo
!
! read the following integral
!
                  call lirpqrs(1,ijkl0,a1,11,idum1,idum2)
                  !if(yw)print'(a,4i4,f12.8)','ijkl0 ',ijkl0,a1
                  if(ijkl0(4)==0) exit
                  is=itsymoa(ijkl0(1))
                  js=itsymoa(ijkl0(2))
                  ks=itsymoa(ijkl0(3))
                  ls=itsymoa(ijkl0(4))
                  ! reorder indices according to symmetries
                  call reors(ijkl0,is,js,ks,ls)
                  if(any((/is,js,ks,ls/)/=(/is0,js0,ks0,ls0/))) then
                     if(yw)print'(a,4i4,2x,4i4)',
     *               'nouveau',is,js,ks,ls,is0,js0,ks0,ls0
                     exit
                  endif
               enddo
            endif
         else
            if(is0==ks0) then
               if(yw1)print*,'ETAPE IJIJ'
!
!-------------------------------------------
! loop on the <is js is js> integrals
!-------------------------------------------
!
               do
                  ijkls=insoa(ijkl0)
                  ps=ijkls(1)
                  qs=ijkls(2)
                  rs=ijkls(3)
                  ss=ijkls(4)
                  if(ps<rs) then
                     i=ps
                     ps=rs
                     rs=i
                     i=qs
                     qs=ss
                     ss=i
                  endif
                  if(ps==rs.and.qs<ss) then
                     i=qs
                     qs=ss
                     ss=i
                  endif
                  if(yw)print'(a,4i3,2x,4i3,f8.4)','is js is js ',
     *            ijkl0,ijkls,a1
!
!                 incrementation de pqII et pIrI, rsII et qsII
!
                  ma=max(ps,rs)
                  mi=min(ps,rs)
                  iad3=numt(is0) ! adr des sym prec.
     *            +num1(ma)+mi
                  ma=max(qs,ss)
                  mi=min(qs,ss)
                  iad4=numt(js0) ! adr des sym prec.
     *            +num1(ma)+mi
                  if(yw)print*,'iad3,iad4',iad3,iad4,is0,js0
                  !do is=1,nsym
                  if=sum(frozen(1:js0-1))
!
! increment hhhijil=(prII)  I frozen
!
                  do i=1,frozen(js0)
                     ifac=1
                     if(ps==rs.and.qs/=ss) ifac=2
                     if=if+1
                     hhhijil(iad3,if)=hhhijil(iad3,if)+
     *               a1*om(ss,I,js0)*om(qs,I,js0)*ifac
!                     if(iad3==16.and.if>=1)print'(a,4f12.8,6i5)','hhh6',
!     *               om(ss,I,js0),om(qs,I,js0),
!     *               a1,hhhijil(iad3,if),if,iad3,ifac
                  enddo
                  if=sum(frozen(1:is0-1))
!
! increment hhhijil=(qsII)  I frozen
!
                  do i=1,frozen(is0)
                     ifac=1
                     if(qs==ss.and.ps/=rs) ifac=2
                     if=if+1
                     hhhijil(iad4,if)=hhhijil(iad4,if)+
     *               a1*om(ps,I,is0)*om(rs,I,is0)*ifac
                     !if(iad4==5.and.if==4)print'(a,4f12.8,6i5)','hhh8',
!     *               om(ps,I,is0),om(rs,I,is0),
!     *               a1,hhhijil(iad4,if),if,iad4,ifac
                  enddo
                  !enddo
!
! read the following integral
!
                  call lirpqrs(1,ijkl0,a1,11,idum1,idum2)
                  if(yw)print'(a,4i4,f12.8)','ijkl0 ',ijkl0,a1
                  if(ijkl0(4)==0) exit
                  is=itsymoa(ijkl0(1))
                  js=itsymoa(ijkl0(2))
                  ks=itsymoa(ijkl0(3))
                  ls=itsymoa(ijkl0(4))
                  ! reorder indices according to symmetries
                  call reors(ijkl0,is,js,ks,ls)
                  if(any((/is,js,ks,ls/)/=(/is0,js0,ks0,ls0/))) then
                     if(yw)print'(a,4i4,2x,4i4)',
     *               'nouveau',is,js,ks,ls,is0,js0,ks0,ls0
                     exit
                  endif
               enddo
            else
               !if(is0==ks0) then
                  if(yw1)print*,'ETAPE ijkl0'
!
!-------------------------------------------
! loop on the <is js ks rs> integrals
!-------------------------------------------
!
                  do
!
! read the following integral
!
                     call lirpqrs(1,ijkl0,a1,11,idum1,idum2)
                     !if(yw)print'(a,4i4,f12.8)','ijkl0 ',ijkl0,a1
                     if(ijkl0(4)==0) exit
                     is=itsymoa(ijkl0(1))
                     js=itsymoa(ijkl0(2))
                     ks=itsymoa(ijkl0(3))
                     ls=itsymoa(ijkl0(4))
                     ! reorder indices according to symmetries
                     call reors(ijkl0,is,js,ks,ls)
                     if(any((/is,js,ks,ls/)/=(/is0,js0,ks0,ls0/)))
     *               then
                        if(yw)print'(a,4i4,2x,4i4)',
     *                  'nouveau',is,js,ks,ls,is0,js0,ks0,ls0
                        exit
                     endif
                  enddo
               !endif
            endif
         endif
      enddo
!
!--------------------------------------------------------
! Hiikl (pqII) and Hijil (pIrI) have been computed
! for each frozen orbital I
! (p,q) --> iad.  the matrices are Hiikl(iad,I), Hijil(iad,i)
!--------------------------------------------------------
!
       !if(yw)print*,'HHHIIKL(11,1)',HHHIIKL(11,1)
      ii=0
      n=0
      do p=1,noa
         do q=1,p
            if(itsymoa(p).ne.itsymoa(q)) cycle
            ii=ii+1
            do i=1,nfr
               n=n+1
               if(yw)print'(a,5i4,f12.8)',
     *            'hhhiikl',n,i,i,p,q,hhhiikl(ii,i)
            enddo
         enddo
      enddo
      if(yw)print*,' '
      ii=0
      do p=1,noa
         do q=1,p
            if(itsymoa(p).ne.itsymoa(q)) cycle
            ii=ii+1
            do i=1,nfr
               n=n+1
               if(yw)print'(a,5i4,f12.8)',
     *            'hhhijil',n,i,p,i,q,hhhijil(ii,i)
            enddo
         enddo
      enddo
      if(yw)print*,'size(hhhiikl)',size(hhhiikl),nfr,idimfr
      if(yw)print*,'numt',numt
      if(yw)print*,'isymoa',isymoa
!
!---------------------------------------------------------
! Transformation  (p,q)  -->  (i,j)
!---------------------------------------------------------
!
      numt(1)=0
      do is=2,nsym
         numt(is)=numt(is-1)+num1(isym(is-1)+1)
      enddo
      if(yw)print*,'numt',numt
!
! IIJJ
!
      do ifr=1,nfr
         do is=1,nsym
            ndims=isymoa(is)
            allocate(hh1(ndims,ndims))
            allocate(hh(ndims,ndims))
            ii=0
            do p=1,noa
               do q=1,p
                  if(itsymoa(p).ne.itsymoa(q)) cycle
                  ii=ii+1
                  if(itsymoa(p)/=is) cycle
                  ps=insoa(p)
                  qs=insoa(q)
                  hh(ps,qs)=hhhiikl(ii,ifr)
                  hh(qs,ps)=hhhiikl(ii,ifr)
               enddo
            enddo
!
!---------------------------------------------------------
! for frozen orbital ifr, hh(i,j) has been filled
! hh=square matrix storing Hhhiikl
!---------------------------------------------------------
!
            if(yw1)print*,'Hhhiikl   sym',is,',  fr',ifr
            if(yw1)call mscript(hh)
            hh1=0.d0
            DO I1=1,ndims
               DO qs=1,ndims
                  DO ps=1,ndims
                     hh1(qs,I1)=hh1(qs,I1)+om(ps,i1,is)*hh(ps,qs)
                  enddo
               enddo
            enddo
            hh=0.d0
            DO I=1,ndims
               DO J=1,I
                  DO K=1,ndims
                     hh(I,J)=hh(I,J)+hh1(K,I)*om(k,j,is)
                     hh(J,I)=hh(I,J)
                  enddo
               enddo
            enddo
            if(yw1)print*,'HijKK   sym',is,',  fr',ifr
            if(yw1)call mscript(hh)
!
!---------------------------------------------------------
! for frozen orbital ifr, hh(p,q) has been transformed
! to hh(i,j)
!---------------------------------------------------------
!
!---------------------------------------------------------
! modify 1-e integrals and enuc  (Coulomb integrals)
!---------------------------------------------------------
!
            ndims=isym(is)
            do i1=1,ndims
               i2=i1+frozen(is)
               i=isymt(is)+i1
               i=insinv(i)
               do j1=1,i1
                  j2=j1+frozen(is)
                  j=isymt(is)+j1
                  j=insinv(j)
                  !print*,'i1,j1',i1,j1,i2,j2,hh(I2,J2)
                  if(yw)print'(a,4i4,f12.8)','HIIkl  GGkl',
     *            ifr,ifr,i,j,hh(I2,J2)
                  ma=max(i1,j1)
                  mi=min(i1,j1)
                  ii=numt(is)+num1(ma)+mi
                  h8(ii)=h8(ii)+hh(I2,J2)*2
                  if(yw)print'(a,3i3,3f14.8,2i4)','dh8',
     *            i1,j1,ii,hh(I2,J2),h8(ii),h8(ii)-hh(I2,J2)*2
     *            ,is,numt(is)
               enddo
            enddo
            ndims=frozen(is)
            do i1=1,ndims
               i=i1+sum(frozen(1:is-1))
               if(yw)print'(a,4i4,f12.8)','HIIJJ  GGGG',
     *         ifr,ifr,i,i,hh(I1,I1)
               if(i==ifr) then
                  if(yw)print'(a,3f15.8,2i4)',
     *            'ENUC2',enuc,enuc+hh(I1,I1)
     *            ,hh(I1,I1),ifr,i1
                  enuc=enuc+hh(I1,I1)
               else
                  if(yw)print'(a,4f15.8,2i4)',
     *            'ENUC3',enuc,enuc+hh(I1,I1)
     *            ,hh(I1,I1),hh(i1,i1)*2,ifr,i1
                  enuc=enuc+hh(I1,I1)*2
               endif
            enddo
!
! IJIJ
!
            ndims=isymoa(is)
            ii=0
            do p=1,noa
               do q=1,p
                  if(itsymoa(p).ne.itsymoa(q)) cycle
                  ii=ii+1
                  if(itsymoa(p)/=is) cycle
                  ps=insoa(p)
                  qs=insoa(q)
                  hh(ps,qs)=hhhijil(ii,ifr)
                  hh(qs,ps)=hhhijil(ii,ifr)
                  if(yw)print'(''ps,qs,hh'',2i3,f12.8)',ps,qs,hh(ps,qs)
               enddo
            enddo
            do k=1,ndims
               if(yw)print'(a,5f12.8)','hh',hh(k,:)
            enddo
            if(yw1)print*,'hhhijil   sym',is,',  fr',ifr
            if(yw1)call mscript(hh)
            hh1=0.d0
            DO I1=1,ndims
               DO qs=1,ndims
                  DO ps=1,ndims
                     hh1(qs,I1)=hh1(qs,I1)+om(ps,i1,is)*hh(ps,qs)
                  enddo
               enddo
            enddo
            hh=0.d0
            DO I=1,ndims
               DO J=1,I
                  DO K=1,ndims
                     hh(I,J)=hh(I,J)+hh1(K,I)*om(k,j,is)
                     hh(J,I)=hh(I,J)
!                     if(i==1.and.j==1)print*,'test',i,j,k,
!     *               hh1(K,I),om(k,j,is),hh1(K,I)*om(k,j,is),
!     *               hh(I,J)
!                     if(i==2.and.j==2)print*,'tes2',i,j,k,
!     *               hh1(K,I),om(k,j,is),hh1(K,I)*om(k,j,is),
!     *               hh(I,J)
                  enddo
               enddo
            enddo
            if(yw) then
               do k=1,ndims
                  print'(10f10.6)',om(k,1:ndims,is)
               enddo
               print*,'HiKjK   sym',is,',  fr',ifr
               do k=1,ndims
                  print'(10f10.6)',hh(k,1:ndims)
               enddo
               call mscript(hh)
            endif
!
! modify 1-e integrals and enuc  (Exchange integrals)
!
            ndims=isym(is)
            do i1=1,ndims
               i2=i1+frozen(is)
               i=isymt(is)+i1
               i=insinv(i)
               do j1=1,i1
                  j2=j1+frozen(is)
                  j=isymt(is)+j1
                  j=insinv(j)
                  !print*,'i1,j1',i1,j1,i2,j2,hh(I2,J2)
                  if(yw)print'(a,4i4,f12.8)','HIjIl  GjGl',
     *            ifr,i,ifr,j,hh(I2,J2)
                  ma=max(i1,j1)
                  mi=min(i1,j1)
                  ii=numt(is)+num1(ma)+mi
                  h8(ii)=h8(ii)-hh(I2,J2)
                  if(yw)print'(a,3i3,3f14.8)','Dh8',
     *            i1,j1,ii,hh(I2,J2),h8(ii),h8(ii)+hh(I2,J2)
               enddo
            enddo
            ndims=frozen(is)
            do i1=1,ndims
               i=i1+sum(frozen(1:is-1))
               if(yw)print'(a,4i4,f12.8)','HIJIJ  GGGG',
     *         ifr,i,ifr,i,hh(I1,I1)
               if(yw) then
                  if(i/=ifr)print'(a,3f15.8,2i4)',
     *            'ENUC4',enuc,enuc-hh(I1,I1),hh(I1,I1),ifr,i1
               endif
               if(i/=ifr) enuc=enuc-hh(I1,I1)
            enddo
            deallocate(hh,hh1)
         enddo
      enddo
      if(yw)print'('' enuc='',f20.8)',enuc
!
! Write the corrected Hmono matrix to temp file
!
      rewind 26
      ifin=0
      do is=1,nsym
         ideb=ifin+1
         ifin=ifin+num1(isym(is)+1)
         if(isym(is)>0) write(26) h8(ideb:ifin)
      enddo
      if(yw)print*,'h8'
      if(yw)print'(6f12.8)',h8(1:ifin)
      if(yw)print*,'enuc',enuc
      deallocate(h8,om)
      deallocate(hhhijil,hhhiikl)
      
      return
      end
       subroutine tijklfr2(ii,jj,kk,ll,iad0,icas,if,hhhijil,i,is0)
      use module
      use mod_script
      use mod_licost
      use mod_tijkl
      use mod_sto
      implicit real*8 (a-h,o-x,z),logical*1(y)
      dimension hhhijil(idimfr,nfr)
      if(ii<kk) return
      iad=iad0+num1(max(ii,kk))+min(ii,kk)
      hhhijil(iad,if)=hhhijil(iad,if)+
     *a1*om(jj,I,is0)*om(ll,I,is0)
!     print*,'iad,if',iad,if
!      if(iad==23.and.if==1)print'(a,i1,5f12.8,3i3)','TEST',icas,
!     *a1*om(jj,I,is0)*om(ll,I,is0),hhhijil(iad,if),
!     *a1,om(jj,I,is0),om(ll,I,is0),jj,ll
      return
      end
