binaries/src/disembl/Tisean_3.0.1/source_f/readfile.f

   1 c===========================================================================
   2 c
   3 c   This file is part of TISEAN
   4 c
   5 c   Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber
   6 c
   7 c   TISEAN is free software; you can redistribute it and/or modify
   8 c   it under the terms of the GNU General Public License as published by
   9 c   the Free Software Foundation; either version 2 of the License, or
  10 c   (at your option) any later version.
  11 c
  12 c   TISEAN is distributed in the hope that it will be useful,
  13 c   but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 c   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 c   GNU General Public License for more details.
  16 c
  17 c   You should have received a copy of the GNU General Public License
  18 c   along with TISEAN; if not, write to the Free Software
  19 c   Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
  20 c
  21 c===========================================================================
  22 c
  23 c   i/o utilities for TISEAN f-sources
  24 c   author T. Schreiber (1998) based on earlier versions
  25 c===========================================================================
  26       subroutine readfile(nmax,x,nexcl,icol,file,iverb)
  27 c read at most nmax points, return nmax
  28       dimension x(nmax)
  29       character*(*) file
  30
  31       iv=iv_io(iverb)
  32       if(icol.eq.0) icol=igetcol(file)
  33       if(icol.gt.0.and.iv.ne.0)
  34      .   write(istderr(),*) 'reading from column', icol
  35       call infile(file,iunit,iverb)
  36       lc=0
  37       do 10 n=1,nexcl
  38          lc=lc+1
  39  10      read(iunit,*,end=999)
  40       do 20 n=1,nmax
  41  1       lc=lc+1
  42          read(iunit,*,err=2,end=999) (dum,i=1,icol-1), x(n)
  43          goto 20
  44  2       if(iv.ne.0) write(istderr(),*) "data in line ", lc, " ignored"
  45          goto 1
  46  20      continue
  47       if(iv.ne.0) write(istderr(),*) '*** readfile: warning:'//
  48      .   ' maybe not the whole file has been used'
  49  999  nmax=n-1
  50       if(iunit.ne.istdin()) close(iunit)
  51       if(iv.ne.0) call readreport(nmax,file)
  52       if(icol.gt.0.and.file.ne."-") call putcol(file,icol)
  53       end
  54
  55       function igetcol(file)
  56       character*(*) file
  57
  58       igetcol=0
  59       do 10 i=len(file),1,-1
  60  10      if(file(i:i).eq.",") goto 1
  61  1    if(i.eq.0) return
  62       read(file(i+1:len(file)),'(i10)',err=999) igetcol
  63       file(i:len(file))=" "
  64  999  continue
  65       end
  66
  67       subroutine putcol(file,icol)
  68       character*(*) file
  69
  70       if(icol.le.9) then
  71          write(file(index(file," "):index(file," ")+1),'(1h,,i1)') icol
  72       else
  73          write(file(index(file," "):index(file," ")+2),'(1h,,i2)') icol
  74       endif
  75       end
  76
  77       subroutine writecfile(nmax,x,file,iverb,comm)
  78 c write comment and nmax points
  79       dimension x(nmax)
  80       character*(*) file,comm
  81
  82       call outfile(file,iunit,iverb)
  83       if(comm.ne." ") write(iunit,'(a)') comm
  84       do 10 n=1,nmax
  85  10      write(iunit,*) x(n)
  86       if(iunit.eq.istdout()) then
  87          write(iunit,*)
  88          write(iunit,*)
  89       else
  90          close(iunit)
  91       endif
  92       if(iv_io(iverb).eq.1) call writereport(nmax,file)
  93       end
  94
  95       subroutine writefile(nmax,x,file,iverb)
  96 c write nmax points
  97       dimension x(nmax)
  98       character*(*) file
  99
 100       call writecfile(nmax,x,file,iverb," ")
 101       end
 102
 103       subroutine infile(file,iunit,iverb)
 104 c open file for read on iunit=ifile(), or iunit=istdin() if "-"
 105       character*(*) file
 106
 107       if(file.eq."-") then
 108          iunit=istdin()
 109          if(iv_io(iverb).eq.1) write(istderr(),*) "reading from stdin"
 110          return
 111       endif
 112       iunit=ifilein()
 113       open(iunit,file=file,status="old",err=999)
 114       if(iv_io(iverb).eq.1) write(istderr(),'(a,a,a)')
 115      .   "opened ",file(1:index(file," ")-1), " for input"
 116       return
 117  999  write(istderr(),'(a,a)') "Cannot open input file ",
 118      .   file(1:index(file," ")-1)
 119       stop
 120       end
 121
 122       subroutine outfile(file,iunit,iverb)
 123 c open file for write on iunit=ifileout(), or iunit=istdout() if file=" "
 124       character*(*) file
 125
 126       if(file.eq." ") then
 127          iunit=istdout()
 128          if(iv_io(iverb).eq.1) write(istderr(),*) "writing to stdout"
 129          return
 130       endif
 131       iunit=ifileout()
 132       open(iunit,file=file,status='unknown',err=999)
 133       if(iv_io(iverb).eq.1) write(istderr(),'(a,a,a)')
 134      .   "opened ",file(1:index(file," ")-1), " for output"
 135       return
 136  999  write(istderr(),'(a,a)') "Cannot open output file ",
 137      .   file(1:index(file," ")-1)
 138       stop
 139       end
 140
 141       subroutine suffix(base,suff)
 142 c append stuff after last nonblank character in base
 143       character*(*) base, suff
 144
 145       base=base(1:index(base," ")-1)//suff
 146       end
 147
 148       subroutine addsuff(target,base,suff)
 149 c append stuff after last nonblank character in base
 150       character*(*) target,base, suff
 151
 152       target=base(1:index(base," ")-1)//suff
 153       end
 154
 155       subroutine readreport(nmax,file)
 156 c report on numbers read
 157       character*(*) file
 158
 159       if(file.eq."-") then
 160          write(istderr(),'(i10,a)') nmax, ' values read from stdin'
 161       else
 162          write(istderr(),'(i10,a,a)') nmax, ' values read from file: ',
 163      .      file(1:index(file," ")-1)
 164       endif
 165       if(nmax.ne.0) return
 166       if(file.eq."-") then
 167          write(istderr(),'(a)') "No input given - aborting."
 168       else
 169          write(istderr(),'(a,a,a)') "Input file ",
 170      .      file(1:index(file," ")-1), " empty - aborting."
 171       endif
 172       call usage()
 173       end
 174
 175       subroutine writereport(nmax,file)
 176 c report on numbers written
 177       character*(*) file
 178
 179       if(file.eq." ") then
 180          write(istderr(),'(i10,a)') nmax, ' values written to stdout'
 181       else
 182          write(istderr(),'(i10,a,a)') nmax, ' values written to file: ',
 183      .      file(1:index(file," ")-1)
 184       endif
 185       end
 186