      subroutine ecrimono(ifr,ifw,name,prog,tit,crea,isym,nsym)
      IMPLICIT REAL(8)(A-H,O-X,Z),logical(1)(y)
      character(*) name,prog,crea,tit
      integer isym(nsym)
      character(21) cdate
      character(80) tete(5),aa
      allocatable ov(:),r8(:)
      yw=.false.
      call cost_date(cdate)
 1000 format(2a)
      if(crea=='crea') then
         write(tete(1),1000)'=========================================='
         write(tete(2),1000)'File: ',trim(name)
         write(tete(3),1000)'created by ',prog
         write(tete(4),1000)'date: ',trim(cdate)
         write(tete(5),1000)'=========================================='
         write(ifw) tete(1:5)
      else
         do
            read(ifw,end=1)
         enddo
      endif
 1    continue
      if(yw) then
         print*,'ecrimono'
         print*,'prog',trim(prog)
         print*,'date',trim(cdate)
         print*,'crea',trim(crea)
      endif
c
c     write the overlap matrix (sym)
c
      norb=sum(isym(1:nsym))
      nn= norb*(norb+1)/2
      allocate (r8(nn))
      allocate (ov(nn))
      aa=' '
      write(aa,'(a)') '=='//trim(tit)//' MATRIX (SYM)'
      write(ifw) aa
      long=0
      rewind ifr
      ifin=0
      do k=1,nsym
         if(isym(k)==0) cycle
         l=isym(k)*(isym(k)+1)/2
         long=long+l
         ideb=ifin+1
         ifin=ideb+l-1
         read(ifr) r8(ideb:ifin)
         if(yw) print'(10f8.4)',r8(ideb:ifin)
      enddo
      write(ifw) long,nsym,isym(1:nsym)
      write(ifw) r8(1:long)
      if(yw)call scri1(nsym,r8,isym)
c
c     write the overlap matrix (total)
c
      aa=' '
      write(aa,'(a)') '=='//trim(tit)//' MATRIX (TOTAL)'
      write(ifw) aa
      ifinv=0
      ifinn=0
      do is=1,nsym
         do k=1,isym(is)
            idebn=ifinn+1
            ifinn=idebn+sum(isym(1:is-1))-1
            ov(idebn:ifinn)=0.d0
            idebn=ifinn+1
            ifinn=idebn+k-1
            idebv=ifinv+1
            ifinv=idebv+k-1
            ov(idebn:ifinn)=r8(idebv:ifinv)
         enddo
      enddo
      write(ifw) nn,nsym,isym(1:nsym)
      write(ifw) ov
      if(yw)call scri1(1,ov,norb)
      deallocate(r8,ov)
      return
      end subroutine
      end module mod_ecrimono
