
      subroutine ecrmono(file,ifil,prog,isym,nsym,s,hmono,norb,noa)
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      integer isym(nsym)
      double precision hmono(norb,norb),s(noa,noa)
      allocatable r8(:)
      character(80) tete(100),aa
      character(*) prog,file
      yw=.false.
      !print*,'ecrmono ',trim(file)
      call titre(' Ouverture '//trim(file)//'#',40)
      open(ifil,file=file,status='unknown',form='unformatted')

      call ecriS(ifil,s,noa,file,'ijkloc',.true.,1,noa,
     *(/(i,i=1,noa)/))
      call ecriS(-ifil,hmono,norb,file,'ijkloc',.false.,1,norb,
     *(/(i,i=1,norb)/))
      return
      end
!******************************************************************
      subroutine ecrmonov(file,ifil,prog,isym,nsym,s,hmono,norb,noa)
      use mod_script
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      integer isym(nsym)
      double precision hmono(norb,norb),s(noa,noa)
      allocatable r8(:)
      character(80) tete(100),aa
      character(*) prog,file
      yw=.false.
      !print*,'ecrmono ',trim(file)
      call titre(' Ouverture '//trim(file)//'#',40)
      open(ifil,file=file,status='unknown',form='unformatted')
 1000 format(2a)
      write(tete(1),1000)'============================================='
      write(tete(2),1000)'File: ',file(1:len_trim(file))
      write(tete(3),1000)'created by ',prog
      write(tete(4),1000)'date: '
      write(tete(5),1000)'============================================='
      write(ifil) tete(1:5)
      !
      long=0
      longh=norb*(norb+1)/2
      longs=noa*(noa+1)/2
      allocate(r8(longs))
!
! Ecriture de la matrice de recouvrement
!
      ii=0
      do i=1,noa
         do j=1,i
            ii=ii+1
            r8(ii)=s(i,j)
         enddo
      enddo
      if(yw)print*,'ecrmono matrice de recouvrement'
      if(yw)call mscript(s)
      write(aa,'(a)')'==OVERLAP MATRIX (SYM)'
      write(ifil) aa
      write(ifil) longs,nsym,isym(1:nsym)
      write(ifil) r8
      write(aa,'(a)') '==OVERLAP MATRIX (TOTAL)'
      write(ifil) aa
      write(ifil) noa*noa,nsym,isym(1:nsym)
      write(ifil) s
      call script(s,noa,noa,noa,noa)
!
! Ecriture de la matrice hmono
!
      nn=norb*norb
      write(aa,'(a)') '==ONEINT MATRIX (TOTAL)'
      write(ifil) aa
      write(ifil) nn
      write(ifil) hmono
      ii=0
      do i=1,norb
         do j=1,i
            ii=ii+1
            r8(ii)=hmono(i,j)
         enddo
      enddo
      write(aa,'(a)') '==ONEINT MATRIX (SYM)'
      write(ifil) aa
      write(ifil) longh,1,norb
      write(ifil) r8(1:longh)
      close(ifil)
      return
      end

