2.9BSD - /usr/src/lib/libI77/ioinit.f

   1: C
   2: C ioinit - initialize the I/O system
   3: C		@(#)ioinit.f	1.5
   4: C synopsis:
   5: C	logical function ioinit (cctl, bzro, apnd, prefix, vrbose)
   6: C	logical cctl, bzro, apnd, vrbose
   7: C	character*(*) prefix
   8: C
   9: C where:
  10: C	cctl	is .true. to turn on fortran-66 carriage control
  11: C	bzro	is .true. to cause blank space to be zero on input
  12: C	apnd	is .true. to open files at their end
  13: C	prefix	is a string defining environment variables to
  14: C		be used to initialize logical units.
  15: C	vrbose	is .true. if the caller wants output showing the lu association
  16: C
  17: C returns:
  18: C	.true. if all went well
  19: C
  20: C David L. Wasley
  21: C U.C.Bekeley
  22: C
  23:         logical function ioinit (cctl, bzro, apnd, prefix, vrbose)
  24:         logical         cctl, bzro, apnd, vrbose
  25:         character*(*)   prefix
  26: 
  27:         automatic       iok, fenv, ienv, ename, fname, form, blank
  28:         logical         iok, fenv, ienv
  29:         integer*2       ieof, ictl, izro
  30:         character       form, blank
  31:         character*32    ename
  32:         character*256   fname
  33:         common /ioiflg/ ieof, ictl, izro
  34: 
  35:         if (cctl) then
  36:             ictl = 1
  37:             form = 'p'
  38:         else
  39:             ictl = 0
  40:             form = 'f'
  41:         endif
  42: 
  43:         if (bzro) then
  44:             izro = 1
  45:             blank = 'z'
  46:         else
  47:             izro = 0
  48:             blank = 'n'
  49:         endif
  50: 
  51:         open (unit=5, form=form, blank=blank)
  52:         open (unit=6, form=form, blank=blank)
  53: 
  54:         if (apnd) then
  55:             ieof = 1
  56:         else
  57:             ieof = 0
  58:         endif
  59: 
  60:         iok = .true.
  61:         fenv = .false.
  62:         ienv = .false.
  63:         lp = len (prefix)
  64: 
  65:         if ((lp .gt. 0) .and. (lp .le. 30) .and. (prefix .ne. " ")) then
  66:             ienv = .true.
  67:             nb = index (prefix, " ")
  68:             if (nb .eq. 0) nb = lp + 1
  69:             ename = prefix
  70:             if (vrbose) write (0, 2002) ename(:nb-1)
  71:             do 200 lu = 0, 19
  72:                 write (ename(nb:), "(i2.2)") lu
  73:                 call getenv (ename, fname)
  74:                 if (fname .eq. " ") go to 200
  75: 
  76:                 open (unit=lu, file=fname, form='f', access='s', err=100)
  77:                 if (vrbose) write (0, 2000) lu, fname(:lnblnk(fname))
  78:                 fenv = .true.
  79:                 go to 200
  80: 
  81:   100           write (0, 2003) ename(:nb+1)
  82:                 call perror (fname(:lnblnk(fname)))
  83:                 iok = .false.
  84: 
  85:   200       continue
  86:         endif
  87: 
  88:         if (vrbose) then
  89:             if (ienv .and. (.not. fenv)) write (0, 2001) ename(:nb-1)
  90:             write (0, 2004) cctl, bzro, apnd
  91:             call flush (0)
  92:         endif
  93: 
  94:         ioinit = iok
  95:         return
  96: 
  97:  2000   format ('ioinit: logical unit ', i2,' opened to ', a)
  98:  2001   format ('ioinit: no initialization found for ', a)
  99:  2002   format ('ioinit: initializing from ', a, 'nn')
 100:  2003   format ('ioinit: ', a, ' ', $)
 101:  2004   format ('ioinit: cctl=', l, ', bzro=', l, ', apnd=', l)
 102:         end