1C 2C Copyright (c) 1980 Regents of the University of California. 3C All rights reserved. The Berkeley software License Agreement 4C specifies the terms and conditions for redistribution. 5C 6C @(#)ioinit.f 5.1 (Berkeley) 06/08/85 7C 8C 9C ioinit - initialize the I/O system 10C 11C synopsis: 12C logical function ioinit (cctl, bzro, apnd, prefix, vrbose) 13C logical cctl, bzro, apnd, vrbose 14C character*(*) prefix 15C 16C where: 17C cctl is .true. to turn on fortran-66 carriage control 18C bzro is .true. to cause blank space to be zero on input 19C apnd is .true. to open files at their end 20C prefix is a string defining environment variables to 21C be used to initialize logical units. 22C vrbose is .true. if the caller wants output showing the lu association 23C 24C returns: 25C .true. if all went well 26C 27C David L. Wasley 28C U.C.Bekeley 29C 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 110