111906SdlwC 211906SdlwC ioinit - initialize the I/O system 3*12009SdlwC @(#)ioinit.f 1.3 411906SdlwC synopsis: 5*12009SdlwC logical function ioinit (cctl, bzro, apnd, prefix, vrbose) 6*12009SdlwC logical cctl, bzro, apnd, vrbose 711906SdlwC character*(*) prefix 811906SdlwC 911906SdlwC where: 10*12009SdlwC cctl is .true. to turn on fortran-66 carriage control 11*12009SdlwC bzro is .true. to cause blank space to be zero on input 12*12009SdlwC apnd is .true. to open files at their end 1311906SdlwC prefix is a string defining environment variables to 1411906SdlwC be used to initialize logical units. 1511906SdlwC vrbose is .true. if the caller wants output showing the lu association 1611906SdlwC 1711906SdlwC returns: 1811906SdlwC .true. if all went well 1911906SdlwC 2011906SdlwC David L. Wasley 2111906SdlwC U.C.Bekeley 2211906SdlwC 23*12009Sdlw logical function ioinit (cctl, bzro, apnd, prefix, vrbose) 24*12009Sdlw logical cctl, bzro, apnd, vrbose 2511906Sdlw character*(*) prefix 2611906Sdlw 27*12009Sdlw automatic iok, fenv, ienv, ename, fname, form, blank 2811921Sdlw logical iok, fenv, ienv 29*12009Sdlw integer*2 ibof, ictl, izro 30*12009Sdlw character form, blank 3111906Sdlw character*32 ename 3211906Sdlw character*256 fname 33*12009Sdlw common /opnbof/ ibof 34*12009Sdlw common /ccntrl/ ictl 35*12009Sdlw common /blzero/ izro 3611906Sdlw 37*12009Sdlw if (cctl) then 38*12009Sdlw ictl = 1 39*12009Sdlw form = 'p' 4011906Sdlw else 41*12009Sdlw ictl = 0 42*12009Sdlw form = 'f' 4311906Sdlw endif 4411906Sdlw 45*12009Sdlw if (bzro) then 46*12009Sdlw izro = 1 47*12009Sdlw blank = 'z' 4811906Sdlw else 49*12009Sdlw izro = 0 50*12009Sdlw blank = 'n' 5111906Sdlw endif 5211906Sdlw 53*12009Sdlw open (unit=5, form=form, blank=blank) 54*12009Sdlw open (unit=6, form=form, blank=blank) 55*12009Sdlw 56*12009Sdlw if (apnd) then 57*12009Sdlw ibof = 0 58*12009Sdlw else 59*12009Sdlw ibof = 1 60*12009Sdlw endif 61*12009Sdlw 6211906Sdlw iok = .true. 6311921Sdlw fenv = .false. 6411921Sdlw ienv = .false. 6511906Sdlw lp = len (prefix) 6611906Sdlw 6711906Sdlw if ((lp .gt. 0) .and. (lp .le. 30) .and. (prefix .ne. " ")) then 6811921Sdlw ienv = .true. 6911906Sdlw nb = index (prefix, " ") 7011906Sdlw if (nb .eq. 0) nb = lp + 1 7111906Sdlw ename = prefix 7211921Sdlw if (vrbose) write (0, 2002) ename(:nb-1) 7311906Sdlw do 200 lu = 0, 19 7411906Sdlw write (ename(nb:), "(i2.2)") lu 7511906Sdlw call getenv (ename, fname) 7611906Sdlw if (fname .eq. " ") go to 200 7711906Sdlw 7811906Sdlw open (unit=lu, file=fname, form='f', access='s', err=100) 7911906Sdlw if (vrbose) write (0, 2000) lu, fname(:lnblnk(fname)) 8011921Sdlw fenv = .true. 8111906Sdlw go to 200 8211906Sdlw 8311921Sdlw 100 write (0, 2003) ename(:nb+1) 8411906Sdlw call perror (fname(:lnblnk(fname))) 8511906Sdlw iok = .false. 8611906Sdlw 8711906Sdlw 200 continue 8811906Sdlw endif 8911906Sdlw 9011906Sdlw if (vrbose) then 9111921Sdlw if (ienv .and. (.not. fenv)) write (0, 2001) ename(:nb-1) 92*12009Sdlw write (0, 2004) cctl, bzro, apnd 9311906Sdlw call flush (0) 9411906Sdlw endif 9511906Sdlw 9611906Sdlw ioinit = iok 9711906Sdlw return 9811906Sdlw 9911906Sdlw 2000 format ('ioinit: logical unit ', i2,' opened to ', a) 10011921Sdlw 2001 format ('ioinit: no initialization found for ', a) 10111921Sdlw 2002 format ('ioinit: initializing from ', a, 'nn') 10211921Sdlw 2003 format ('ioinit: ', a, ' ', $) 103*12009Sdlw 2004 format ('ioinit: cctl=', l, ', bzro=', l, ', apnd=', l) 10411906Sdlw end 105