binaries/src/disembl/Tisean_3.0.1/source_f/arguments.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   arguments.f
  23 c   get command line arguments
  24 c   author T. Schreiber (1998)
  25 c===========================================================================
  26
  27       subroutine argdel(i)
  28       parameter(margs=1000)
  29       dimension largs(margs)
  30       common /args/ nargs, largs
  31
  32       if(i.eq.0) then
  33          nargs=min(margs,iargc())
  34          do 10 n=1,nargs
  35  10         largs(n)=1
  36       else
  37          if(i.gt.iargc()) return
  38          if(largs(i).eq.0) return
  39          largs(i)=0
  40          nargs=nargs-1
  41       endif
  42       end
  43
  44       function nstrings()
  45       parameter(margs=1000)
  46       dimension largs(margs)
  47       common /args/ nargs, largs
  48
  49       nstrings=max(nargs,1)
  50       end
  51
  52       subroutine nthstring(n,string)
  53       parameter(margs=1000)
  54       dimension largs(margs)
  55       common /args/ nargs, largs
  56       character*(*) string
  57
  58       iv=0
  59       do 10 i=1,iargc()
  60          if(largs(i).eq.1) iv=iv+1
  61  10      if(iv.eq.n) goto 1
  62       string="-"
  63       return
  64  1    call getarg(i,string)
  65       end
  66
  67       function imust(c)
  68 c get mandatory integer argument, call usage statement if missing
  69       character c
  70
  71       imust=iopt(c,1,ierr)
  72       if(ierr.ne.0) call usage()
  73       end
  74
  75       function fmust(c)
  76 c get mandatory real argument, call usage statement if missing
  77       character c
  78
  79       fmust=fopt(c,1,ierr)
  80       if(ierr.ne.0) call usage()
  81       end
  82
  83       subroutine smust(c,string)
  84 c get mandatory string argument, call usage statement if missing
  85       character c
  86       character*(*) string
  87
  88       call sopt(c,1,string,ierr)
  89       if(ierr.ne.0) call usage()
  90       end
  91
  92       function ican(c,idef)
  93 c get optional integer argument, provide default if missing
  94       character c
  95
  96       ican=iopt(c,1,ierr)
  97       if(ierr.ne.0) ican=idef
  98       end
  99
 100       function fcan(c,fdef)
 101 c get optional real argument, provide default if missing
 102       character c
 103
 104       fcan=fopt(c,1,ierr)
 105       if(ierr.ne.0) fcan=fdef
 106       end
 107
 108       subroutine stcan(c,string,dstring)
 109 c get optional string argument, provide default if missing
 110       character c
 111       character*(*) string, dstring
 112
 113       call sopt(c,1,string,ierr)
 114       if(ierr.ne.0) string=dstring
 115       end
 116
 117       function igetout(fout,iverb)
 118 c gets alternate output file name, default " "
 119 c return 1 if fout must be determined from input file name
 120       character*(*) fout
 121
 122       igetout=0
 123       call stcan("o",fout," ")
 124       if(fout.ne." ".and.nstrings().gt.1.and.iv_io(iverb).ne.0)
 125      .   write(istderr(),*) '*** single output file for multiple'//
 126      .   ' input files - results may be overwritten'
 127       if(fout.ne." ") return
 128       igetout=lopt("o",1)
 129       end
 130
 131       subroutine imcan(c,mmax,mc,ilist)
 132 c get optional integer argument with multiple comma separated values
 133       character c
 134       character*72 string
 135       dimension ilist(*)
 136
 137       call stcan(c,string," ")
 138       string(index(string," "):index(string," "))=","
 139       do 10 m=1,mmax
 140          if(index(string,",").le.1) goto 1
 141          read(string(1:index(string,",")-1),*,err=1,end=1) ilist(m)
 142  10      string=string(index(string,",")+1:72)
 143  1    mc=m-1
 144       end
 145
 146       subroutine fmcan(c,mmax,mc,flist)
 147 c get optional real argument with multiple comma separated values
 148       character c
 149       character*72 string
 150       dimension flist(*)
 151
 152       call stcan(c,string," ")
 153       string(index(string," "):index(string," "))=","
 154       do 10 m=1,mmax
 155          if(index(string,",").le.1) goto 1
 156          read(string(1:index(string,",")-1),*,err=1,end=1) flist(m)
 157  10      string=string(index(string,",")+1:72)
 158  1    mc=m-1
 159       end