4.3BSD - /usr/src/usr.lib/libU77/ioinit.f

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