c  file: sgiof.for	low level i/o routines for sglib
c
c  feb-85	write ag_inio (originally called io_init). [met]
c  may-85	add tinput, iowait (previously in agiod.mar). [met]
c  jun-85	add toutpt from agiod.  [met]
c  oct-85	add rinitt. 	 [met]
c  nov-85	add simultaneous disk/terminal output. [met]
c  nov-86	move file open and close from ag_inio to tsend.
c		modify ag_inio and tsend to support sggds.  [met]
c  jan-87	add vgds support; add agfkeep,agfclos. [met]
c  apr-87	add sg_term common; add disk file /keep switch.
c		delay opening disk file until first output. [met]
c  dec-87	add tclos_term; add workstation (WT) support.
c		add typed character argument to upause. [met]
c
c  mar-88	change disk buffer to 3 blocks.
c		move commons to sgiof.inc.
c		change ag_inio to look for terminal name if comma. [met]
c
c  dec-88	usr_getdvi return klass=5 for null device; error (klass=0)
c		 if nothing from getdvi and no dot.
c		drop leading spaces for both parts of comma separated PLOT.
c		support VGDS upgrade; drop support for GDS.
c		add iag_ljust.
c		agfkeep(0) to toss frame; (-1) to keep frame.
c		add io$m_escape flag to tinput instead of doing second qio
c		 when get an esc (generated by enter from VT).
c		bypass qio if outtrm is null device (5). [met]
c
c sep-89	agtpurg sets flag for tinput to do qio with m_purge instead
c		 of nowait qio.
c		modify tsend_term to buffer broadcast messages during plot;
c		 dont use yet - cant spawn with mbx attached to tty. [met]
c
c jan-90	print symbionts no longer need US as first char of file.
c		add topen_term; only assign terminal (with broadcast mbx)
c		  while on graphics screen; turn on broadcast trapping.
c		add exit handler to close terminal and disk and mbx.
c		dont close terminal in agfclos, only file.
c		set outdsk to -2 in agfoff, reset in agfonn only if -2.
c		fix return code in usr_trnlog, add case_blind option.
c		logical TERMINAL_TRAP controls broadcast trapping.
c		close files in ag_inio if called from agvgds (like rinitt)
c		 so logicals are reevaluated.
c		add agseef to return outflg.
c		dynamically allocate term/disk buffers; size set by logicals.
c		fix bug restricting disk name to 24 characters.
c		add tmark_disk so always keep frame header. [met]
c
c  aug-91	add istat argument to ag_inio.
c		make separate XTC version. [met]
c
c  feb-92	return from rinitt on error if istat arg present.
c		get device type for each item in PLOT definition.
c		allow mbx output (for XTC) or second tty output.
c		translate XTC_GIN... in tinput; allow mbx input in tinput.
c		translate TERMINAL_INPUT before SYS$COMMAND in tinput.
c		use SYS$LOGIN:<user>.PLT if SYS$OUTPUT in batch job.
c		change default disk buffer from 3 blocks to 30 (for DAS).
c		output to auxiliary in no-wait mode.
c		move cursor to corner in UPAUSE if both disk and tty output.
c		move ag_info,iag_trim here from sgvgds; add ag_swit. [met]
c
c  feb-92	translate XTC_GIN_n_user in tinput.
c		always purge first in tinput except between characters
c		in ainst/tinst. [met]
c
c  aug-93	add upauch entry and iag_upcase; revise ag_swit. [met]
c
c  jan-94	rename sg_narg to iargcount. [met]
c
c-----------------------------------------------------------------/toutpt
	subroutine toutpt(ichr)
c
	implicit none
	include 'sgcopr_inc'
	include 'sgiof_inc'	!sg_flag, sg_buff
	integer istat, ii
        integer ichr, jchr
	integer hex7f,hex0
	data hex7f /z'7f'/, hex0/z'00'/
c
	jchr = iand(ichr,hex7f)		!drop parity bit
c
	if(outflg.eq.0) then
	  call ag_inio(' ',istat)	!exit on error
	  if(istat.ne.1) call bad_exit
	endif
c
	if(outdsk.eq.-1) then
#ifdef __f90
	  call topen_disk(0)
#else
	  call topen_disk(1)		!need to open disk file
#endif
	endif
c
	if(outdsk.gt.0) then	!disk output
	  if(kdptr.eq.0) then
	    do ii=1,maxdb
#ifdef __f90
	      dbuff(ii)=char(hex0)
#else
	      dbuff(ii)=0
#endif
	    enddo
	  endif
	  kdptr=kdptr+1
#ifdef __f90
	    dbuff(kdptr)=char(jchr)
#else
	    dbuff(kdptr)=jchr
#endif
	  if(kdptr.eq.maxdb) then
	    call tsend_disk
	  endif
	endif
c
	if(outtrm.eq.-1) then		!need to open terminal
#ifdef __f90
	  call topen_term(0)
#else
	  call topen_term(1)
#endif
	endif
c
	if(outaux.eq.-1) then		!need to open aux term
#ifdef __f90
	  call topen_auxl(0)
#else
	  call topen_auxl(1)
#endif
	endif
c
	if(outtrm.eq. 1 .or. outaux.eq.1) then	!terminal output
	  ktptr=ktptr+1
c	  !tbufo(ktptr)=jchr
#ifdef __f90
	  tbuff(ktptr)=char(jchr)
#else
	  tbuff(ktptr)=jchr
#endif
	  if(ktptr.eq.maxtb) then
	    call tsend_term
	  endif
	endif
c
	return
	end
c%
c-----------------------------------------------------------------/upause
	subroutine upause(krase)
c
c  beep, wait until user types a character, and clear screen
c    if krase is non-zero or omitted
c
	implicit none

	include 'sgiof_inc'	!sg_flag, sg_buff
	logical lrase
	integer nargs, krase, ich, iin, inch
	integer hexdf
	data    hexdf /z'df'/
	save ich
c
	nargs = 1  !   
	lrase = .true.
	if(nargs.gt.0) lrase = krase.ne.0
c
cx	if(nargs.eq.0) then
cx	  call agsalf
cx	  type *, 'Call to UPAUSE with no arguments, use UPAUSE(1)'
cx	  call agsgrf
cx	endif
	if(outflg.eq.0) then
	  write(*,*) 'call to UPAUSE with no INITT'
	  return
	endif
c
	if(outtrm.eq. 1 .or. outaux.eq.1) then	!terminal only stuff
	  if(outdsk.ne.0) call movabs(0,0)	!move to a corner
	  call agfoff
	  call alfmod		!set alpha mode
	  call toutpt(07)	!bell
	  call tinput(ich)	!get a character
	  iin = iand(ich,hexdf)		!take upper case
	  if(char(iin).eq.'C') call hdcopy
	  call agfonn
	  call agfkeep(iin)
	endif
c
	if(lrase) then
	  call toutpt(27)	!escape
	  call toutpt(12)	!form feed to clear screen
	  call iowait(10)	!wait 1 second
	endif
c
	return
c
	entry upauch(inch)
c
	inch = ich
	end
c%

c-----------------------------------------------------------------/sg_flagblk
	block data sg_flagblk
	include 'sgiof_inc'
	include 'sgvgds_inc'	
	data outflg,inflg /2*0/
	data outdsk,outtrm,outaux,outps /4*0/
	data maxtb /2048/, maxdb /512/
	data myterm,user /'  ', '  '/
	end
c-----------------------------------------------------------------/rinitt
	subroutine rinitt(uname,istat)
c
c  determine output device from logical translation of plot/sys$output
c    initialize output device/chan
c    set model and comchr from logical translation of terminal_type
c
c  entry rinitt permits user to redefine the output device
c
c  entry ag_inio is called by initt
c
	implicit none
	integer istat
	character*(*) uname
	external sg_flagblk
c
	include 'sgtcs_inc'	!model,comchr
	include 'sgiof_inc'     !sg_flag, sg_buff
	include 'sgvgds_inc'    !iovgds,xpndsk,myterm
c
	character*64 dsknam,trmnam,auxnam
	integer      maxnam
	parameter (maxnam=3)
	character*64 outnam(maxnam)
	character*08 nodnam
	character*04 trmtrp
	character*64 tmpnam
	character*12 sysout !   
	data sysout /'stdout'/ !   
	integer outsav
	integer ivgdsk
	logical closup,addon,iopt
	integer ss_normal 
	integer igood

	integer nargs, ltnam, ldnam, mode
	integer iag_trim
	integer i, lcom, iexit, klass, lt, lu, lm, lcc
	integer lnam, la, ld
	integer kext, ksiz, kfac, kscr
	integer iout,ix,iy,iz
	integer sts
	data nodnam	/' '/

	data outsav /0/
	data ivgdsk	/-1/
	data ss_normal /z'0001'/
c
	nargs = 1  !   
	closup = .true.
c
	call usr_trnlog(' ',uname,tmpnam,ltnam,igood)
	if(igood .eq. 0) tmpnam = uname
	iopt = .true.
	go to 200
c
c-----------------------------------------------------------------/ag_inio
	entry ag_inio(uname,istat)
c
	nargs = 2  !   
	closup = uname.eq.'VGDS'	!close everything if VGDS
c				!check if output already open
	if(outflg.ne.0 .and. .not.closup) go to 8000
	tmpnam=' '
	xpndsk=' '
	lxnam=0
c				!set output for vgds
	if(iovgds.ne.0 .and. iovgds.ne.2) then
	  if(lgdsk.gt.0) then
	    if(ivgdsk.lt.0) then	!only translate first time thru
	      call usr_trnlog(' ','VGDS_SCRATCH',tmpnam,ltnam,igood)
	      if(igood .eq. 0) then
	      write(*,*) ' No VGDS_SCRATCH area'
	      call bad_exit
	      endif
	    endif
	    tmpnam = 'VGDS_SCRATCH:'//gdsdsk(1:lgdsk)
	  else
	    tmpnam = 'NL:'
	  endif
	  if(iovgds.eq.3) then		!disk and terminal
	    ldnam = iag_trim(tmpnam)
	    tmpnam(ldnam+1:) = ','
	  endif
	endif
c				!if not vgds, use logical name PLOT
	iopt = .false.
	if(iovgds.eq.0) then
	  call usr_trnlog(' ','PLOT',tmpnam,ltnam,igood)
	  iopt = .true.		!do check for options in tmpnam
	endif
c				!if nothing, use sysout
	if(tmpnam.eq.' ') then
	  tmpnam = sysout !   
	endif
c
c----------code common to ag_inio and rinitt
c
 200	continue
	if(closup) then
	  if(outdsk.gt.0) then	!if disk file open
	    call tsend_disk	!dump buffer
	    call tclos_disk	!close file
	  endif
c
	  if(outtrm.eq.1 .or. outaux.eq.1) then	!if terminal open
	    call tsend_term	!dump buffer
	    call tclos_term
	  endif
	endif
c..get essential info first time through
	if(nodnam.eq.' ') then
	  call ag_info(mode,ipid,myterm,user)
	endif
c..separate comma delimited list
	do i=1,maxnam
	  call iag_ljust(tmpnam)
	  lcom=index(tmpnam,',')
	  if(lcom.eq.0) then
	    outnam(i)=tmpnam
	    tmpnam=' '
	  else				!have a comma
	    outnam(i)=tmpnam(1:lcom-1)
	    if(outnam(i).eq.' ' .and. mode.eq.3)	!if interactive
     >		outnam(i)=sysout	!?myterm
	    tmpnam=tmpnam(lcom+1:)
	    if(tmpnam.eq.' ' .and. mode.eq.3)
     >		tmpnam=sysout		!?myterm
	  endif
	enddo
c..get device class for each name
	dsknam=' '
	trmnam=' '
	auxnam=' '
	outdsk = 0
	outtrm = 0
	outaux = 0
	outps = 0
	iexit = 0
	do i=1,maxnam
	  if(outnam(i).eq.' ') go to 120
	  call usr_trnlog(' ',outnam(i),tmpnam,ltnam,igood)
	  if(igood.eq.0) tmpnam=outnam(i)
	  call usr_getdvi(tmpnam,klass,igood)
	  if(igood.eq. 0) then
	    write(*,*) 'INITT/RINITT: invalid output device '//tmpnam
	    iexit=0
	    go to 120
	  endif
	  if(klass.eq.1) then		!disk
	    lt=iag_trim(tmpnam)
	    if(tmpnam(lt:lt).eq.':') then
	      lu=iag_trim(user)
	      tmpnam='$HOME/'//user(1:lu)//'.PLT' !   
	      write(*,*) 'INITT/RINITT: creating plot file '//tmpnam
	    endif
	    if(dsknam.ne.' ') then
	      write(*,*) 'INITT/RINITT: multiple output disk files'
	      go to 120
	    endif
	    dsknam=tmpnam
	    outdsk = -1
	  elseif(klass.eq.2) then	!terminal
	    lm=iag_trim(myterm)
	    lt=iag_trim(tmpnam)
	    if(lt.eq.0 .or. tmpnam(1:lt).eq.myterm(1:lm)) then !   
	      trmnam=tmpnam
	      outtrm = -1
	    else
	      auxnam=tmpnam
	      outaux = -1
	    endif
	  elseif(klass.eq.5) then	!mailbox(XTC or NL:)/socket
	    auxnam=tmpnam
	    outaux = -1
	  endif
 120	enddo
c..check at least one valid output device
	outflg = abs(outtrm+outdsk+outaux)
	if(outflg.eq.0) then
	  write(*,*) 'INITT/RINITT: no valid output devices'
	  if(nargs.le.1)  call bad_exit
	  istat = iexit
	  return
	endif
	xpntrm = trmnam
	if(xpntrm.eq.' ') xpntrm = auxnam
c					!drop node if same as SYS$NODE
	keepc = 0		!value if disk only or vgds
	addon = .false.
	if(iopt) then
	  call ag_swit(dsknam,addon,keepc,outps)
	endif
c..set keepc=d, for vgds keepc=0
	if((outtrm.ne.0 .or. outaux.ne.0) .and. outdsk.ne.0) then
	  if(keepc.eq.0 .and. iovgds.eq.0) keepc = ichar('D')
	endif
	model = 'NONE'
c..open terminal
	comchr = ' '
	ktptr=0
	if(outtrm.lt.0) then
	  lt=iag_trim(trmnam)
	  call tname_term(trmnam(1:lt))
c
	  call usr_trnlog(' ','TERMINAL_TYPE',tmpnam,ltnam,igood)
	  if(igood .ne. 0) then
	    ltnam = min(ltnam,6)
	    lcc = index(tmpnam,'_')
	    if(lcc.ne.0) then
	      comchr = tmpnam(lcc+1:)
	      ltnam = lcc-1
	    endif
c
	    model = tmpnam(1:ltnam)
	  else
c Make XTERM default
	    model = 'XTERM '
	  endif
c
	  call usr_trnlog(' ','TERMINAL_TRAP',trmtrp,lnam,igood)
	  call agtrap(.not.(trmtrp.eq.'NO'))
	endif
c..open auxiliary terminal
	if(outaux.lt.0) then
	  la=iag_trim(auxnam)
	  call tname_auxl(auxnam(1:la))
	  if(model.eq.'NONE') model = 'XTC'
	endif
c..establish disk file name, but dont open it yet
	if(outdsk.lt.0) then
	  call agseet(k4105,kfac,ksiz,kscr)
	  if(k4105.gt.0) then	!force 4105 file extension to .4105
	    kext = index(dsknam,'.PLT')
	    if(kext.ne.0) then
	      dsknam(kext:) = '.4105'
	      write(*,*) 'File name extension changed to .4105'
	    endif
	  endif
	  ld=iag_trim(dsknam)
	  call tname_disk(dsknam(1:ld))
c
	endif
c
 8000	continue
	if(nargs.gt.1) istat = ss_normal
	return
c
c-----------------------------------------------------------------/agfoff
	entry agfoff
c
	outsav = outdsk
	outdsk = -2
	return
c
c-----------------------------------------------------------------/agfonn
	entry agfonn
c
	if(outdsk.eq.-2) outdsk = outsav
	return
c
c-----------------------------------------------------------------/agseef
	entry agseef(iout,ix,iy,iz)
c
	iout = outflg
c?	ix = error code
	end
c
c-----------------------------------------------------------------/agfclos
	subroutine agfclos(uname)
c
c  close any disk file, return file name to user if arg uname exists
c
	implicit none

	character*(*) uname
	include 'sgiof_inc'	!sg_flag, sg_buff
	include 'sgvgds_inc'	!iovgds,xpndsk
	integer lu, lsnam
c
c  if lenth of string is < 2, assume string is a constant
	lu=len(uname)
	if(lu.gt.2) uname = ' '	!assume error - no file
	if(outdsk.gt.0) then
	  call tsend_disk
	  call tclos_disk	!close the disk file
	  if(lu.gt.2) then	!return the file name to caller
	    lsnam = index(xpndsk,']')+1
	    if(lxnam.gt.0) uname = xpndsk(lsnam:lxnam)
	  endif
	endif
c
	return
	end
c
c-----------------------------------------------------------------/agfkeep
	subroutine agfkeep(iin)
c
c * decide whether to keep this frame in the disk file or back up to its start
c
	implicit none

	integer iin	!char typed by user
c			!if -1, keep; if 0, toss
c
	include 'sgiof_inc'	!sg_flag, sg_buff
	include 'sgvgds_inc'	!iovgds,xpndsk
c
	logical saveit
c
	if(outflg.eq.0) return
	if(outdsk.le.0) return
c
	typdc = iin
	if(typdc.eq.0) then
	  saveit = .false.	!toss if agfkeep(0)
	elseif(typdc.eq.-1) then
	  saveit = .true.	!keep if agfkeep(-1)
	elseif(keepc.gt.0 .and. keepc.ne.typdc) then
	  saveit = .false.	!toss if doesnt match /keep
	elseif(keepc.le.0 .and. -keepc.eq.typdc) then
	  saveit = .false.	!toss if does match /nokeep
	else
	  saveit = .true.	!keep
	endif
c
	if(saveit) then
	  call tsend_disk
	  call tkeep_disk	!update start of frame address
	else
	  call tback_disk	!back up disk address
	endif

	return
	end
c
c-------------------------------------------------------------/iag_ljust
	subroutine iag_ljust(str)
c
c left justify a character string
c
	implicit none

	character str*(*)
	integer   js

	js=1
	do while(str(js:).ne.' ' .and. str(js:js).eq.' ')
	  js = js+1
	enddo
	if(js.gt.1) str = str(js:)
	end
c
c-------------------------------------------------------------/iag_trim
	integer function iag_trim(str)
c  return length of a character string minus any trailing blanks
c  if string is blank, returned length is 0
	implicit none

	character str*(*)
	integer   jt, jl

	jt=0			!trimmed length
	jl=len(str)		!allocated length
	do while (jl.gt.jt)
	  if(ichar(str(jl:jl)).gt.ichar(' ')) jt=jl
	  jl=jl-1
	enddo
	iag_trim=jt
	end
c%
c-------------------------------------------------------------/ag_swit
	subroutine ag_swit(dsknam,addon,keepc,outps)
	implicit none

	character dsknam*(*)
	logical addon
	integer keepc, outps
	integer is, no, ik, ld

	character optc*1 	!   
	data optc /'-'/	        !   
	character opts*4	!option string

c
	addon=.false.
	keepc=0
c..see if there is an option (-xx for unix)
	is = index(dsknam,optc)	!check for option character
	do while(is.gt.0)
	  no = 1		!assume no no
	  ik = is+1
	  call iag_upcase(opts,dsknam(ik:ik+3))
	  if(opts(1:2).eq.'NO') then
	    no = -1		!have a no
	    ik = ik+2
	    call iag_upcase(opts,dsknam(ik:ik+3))
	  endif
	  if(opts(1:3).eq.'APP') then	    !append to file
	    addon=.true.
	  elseif(opts(1:2).eq.'PS') then    !postscript
	    outps=1
c..if user specifies /keep=x, set keepc=x; if /keep, set keepc=<cr>
	  elseif(opts(1:4).eq.'KEEP') then
	    ik = ik+4
	    if(dsknam(ik:ik).eq.'=') then	!if =, use that char
	      ik = ik+1
	      call iag_upcase(opts,dsknam(ik:ik))
	      keepc = ichar(opts(1:1))*no
	    else		!if not, use cr
	      keepc = 10*no	!+/- cr  on UNIX cr=A
	    endif
	  endif
	  opts = ' ,'//optc		!look for blank,comma,optc
	  ld=len(dsknam)
	  do while(ik.le.ld .and. index(opts,dsknam(ik:ik)).eq.0)
	    ik = ik+1
	  enddo
	  dsknam(is:ik-1) = ' '		!blank out this switch
	  is = index(dsknam,optc)
	enddo
	end
c%
c-------------------------------------------------------------/iag_upcase
	subroutine iag_upcase(upstr,lostr)
	implicit none

	character upstr*(*),lostr*(*)
	integer   i, icode
	integer hex7f, hexdf
	data hex7f /z'7f'/, hexdf /z'df'/ 

	upstr=lostr
	do i=1,len(upstr)
	  icode=iand(ichar(upstr(i:i)),hex7f)	!drop parity
c?	  if(icode.ge.'61'x .and. icode.le.'7b'x) then	!for 'a' to 'z'
	  if(iand(icode,64).ne.0) then	!if alpha x40 = 64
	  upstr(i:i)=char(iand(icode,hexdf))	!mask out '20'x
	  endif
	enddo
	end
