!
! special string
!
!	decodes individual records by special (user input string)
!
	subroutine special(buffer,length_total,record_number,
     1				file_name,ifile_length)
	character*(*) file_name
!
! space for macro expansion 
!
	character*65535	string
	common /special/ string

	character*1 zero
	data zero /0/
	byte buffer(length_total)
	
	include 'flags.inc'

	integer sys$fao,record_number,time_buf(2)
	character*12 codes
	character*90 outstring
	character*3 ctrstr,outbuf1,ctrstr2,ctrstr3,ctrstr4,ctrstr5,ctrstr8
	character*3 ctrstr9,ctrstra,ctrstrb
	character*8 ctrstr1,ctrstr6,ctrstr7,outbuf5
	character*5 outbuf7
	data ctrstr /'!AF'/
	data ctrstr1 /'!3<!OB!>'/
	data ctrstr2 /'!SL'/
	data ctrstr3 /'!SW'/
	data ctrstr4 /'!SB'/
	data ctrstr5 /'!XL'/
	data ctrstr6 /'!8<!SL!>'/
	data ctrstr7 /'!5<!SL!>'/
	data ctrstr8 /'!%D'/
	data ctrstr9 /'!UL'/
	data ctrstra /'!UW'/
	data ctrstrb /'!UB'/
	character*32 bin_string
	character*12 outbuf2,outbuf3,outbuf4
	character*23 outdate
	character*1 outbuf
	character*12 float_string
	data codes /'XAOLWBFDHTZU'/
	dimension isize(12)
	data isize /1,1,1,4,2,1,4,8,4,8,0,0/
	logical attention_flag,display_message,binary,unsigned
	common /control_c/ attention_flag,display_message

	external handler
	call lib$establish(handler)

	length_string=index(string,zero)-1

	istart=1
	outstring=' '
	ilength=1
	ibin_rep=0
	iuns_rep=0
	binary=.false.
	unsigned=.false.
!
! add adaptation of output for full screen
!
	if (full_screen) then
		istat=sys$fao(ctrstr6,len,outbuf2,%val(record_number))
		if (.not. istat) call lib$stop(%val(istat))
		outstring(ilength:ilength+len)=outbuf2(1:len)
		ilength=ilength+23
	 else
		ilength=14
	 endif		

	if (full_screen) then
		line_length=58
	 else
		line_length=64
	 endif

	ientry1=1
	ientry2=ientry1
	iencode=0

	do i=1,length_string
		icode=index(codes,string(i:i))
!
! trap illegal codes for binary or unsigned
!
		if ((binary .or. unsigned) .and. (icode.ne.4 .and.
     1			icode.ne.5.and. icode.ne.6 .and. icode.ne.11
     2			.and. icode.ne.12)) then
			type 755
 755			format(/' Illegal character following U or Z'
     1				' format code (must be L, W, or B)'/)
			goto 3000
		 endif
		if (icode.le.0) goto 1000
		iadd=isize(icode)
 950		if (attention_flag) then
			attention_flag=.true.
			type 777
 777			format(/' Aborted by CNTL C'/)
			goto 3000
		 endif
 		if (icode.eq.1) then				! X skip 1 byte
			iencode=iencode+1
			goto 1000
		 endif
		if (icode.eq.2) then				! A ascii 1 byte
			iencode=iencode+1
			istat=sys$fao(ctrstr,len,outbuf,1,
     1					buffer(istart))
			if (.not. istat) call lib$stop(%val(istat))
			outstring(ilength:ilength+1)=outbuf(1:len)
			ilength=ilength+1
			goto 1000
		 endif
		if (icode.eq.3) then				! O octal 1 byte
			iencode=iencode+1
			istat=sys$fao(ctrstr1,len,outbuf1,
     1					%val(buffer(istart)))
			if (.not. istat) call lib$stop(%val(istat))
			outstring(ilength:ilength+len)=outbuf1(1:len)
			ilength=ilength+len+2
			goto 1000
		 endif
		if (icode.eq.4) then				! L signed long
			iencode=iencode+1
			call integer_get(buffer,istart,4,ivalue)
			if (binary) then
				call binary_convert(ivalue,4,
     1							bin_string,ib)
				outstring(ilength:ilength+ib)=
     1							bin_string(1:ib)
				ilength=ilength+ib+2
				ibin_rep=ibin_rep-1
				goto 1000
			 endif
			if (unsigned) then
				iuns_rep=iuns_rep-1
				istat=sys$fao(ctrstr9,len,outbuf2,
     1						%val(ivalue))
			 else
				istat=sys$fao(ctrstr2,len,outbuf2,
     1						%val(ivalue))
			 endif
			if (.not. istat) call lib$stop(%val(istat))
			outstring(ilength:ilength+len)=outbuf2(1:len)
			ilength=ilength+len+2
			goto 1000
		 endif			
		if (icode.eq.5) then				! W signed word
			iencode=iencode+1
			call integer_get(buffer,istart,2,ivalue)
			if (binary) then
				call binary_convert(ivalue,2,
     1							bin_string,ib)
				outstring(ilength:ilength+ib)=
     1							bin_string(1:ib)
				ilength=ilength+ib+2
				ibin_rep=ibin_rep-1
				goto 1000
			 endif
			if (unsigned) then
				iuns_rep=iuns_rep-1
				istat=sys$fao(ctrstra,len,outbuf3,
     1						%val(ivalue))
			 else
				istat=sys$fao(ctrstr3,len,outbuf3,
     1						%val(ivalue)) 
			 endif
			if (.not. istat) call lib$stop(%val(istat))
			outstring(ilength:ilength+len)=outbuf3(1:len)
			ilength=ilength+len+2
			goto 1000
		 endif
		if (icode.eq.6) then				! B signed byte
			iencode=iencode+1
			call integer_get(buffer,istart,1,ivalue)
			if (binary) then
				call binary_convert(ivalue,1,
     1							bin_string,ib)
				outstring(ilength:ilength+ib)=
     1							bin_string(1:ib)
				ilength=ilength+ib+2
				ibin_rep=ibin_rep-1
				goto 1000
			 endif
			if (unsigned) then
				iuns_rep=iuns_rep-1
				istat=sys$fao(ctrstrb,len,outbuf4,
     1						%val(ivalue))
			 else
				istat=sys$fao(ctrstr4,len,outbuf4,
     1						%val(ivalue))
			 endif
			if (.not. istat) call lib$stop(%val(istat))
			outstring(ilength:ilength+len)=outbuf4(1:len)
			ilength=ilength+len+2
			goto 1000
		 endif
		if (icode.eq.7) then				! F single float
			iencode=iencode+1
			call integer_get(buffer,istart,4,ivalue)
			call convert(ivalue,float_string)
			len=12
			outstring(ilength:ilength+len)=float_string
			ilength=ilength+len+2
			goto 1000
		 endif
		if (icode.eq.8) then				! D double float
			iencode=iencode+1
			call integer_get(buffer,istart,4,ivalue)
			call integer_get(buffer,istart,4,ivalue)
			call dconvert(ivalue,float_string)
			len=12
			outstring(ilength:ilength+len)=float_string
			ilength=ilength+len+2
			goto 1000
		 endif
		if (icode.eq.9) then				! H hex long
			iencode=iencode+1
			call integer_get(buffer,istart,4,ivalue)
			istat=sys$fao(ctrstr5,len,outbuf5,%val(ivalue))
			if (.not. istat) call lib$stop(%val(istat))
			outstring(ilength:ilength+len)=outbuf5(1:len)
			ilength=ilength+len+2
			goto 1000
		 endif
		if (icode.eq.10) then				! T sys time
			iencode=iencode+1
			call integer_get(buffer,istart,4,time_buf)
			call integer_get(buffer,istart+4,4,time_buf(2))
			istat=sys$fao(ctrstr8,len,outdate,time_buf)
			if (.not. istat) call lib$stop(%val(istat))
			outstring(ilength:ilength+len)=outdate(1:len)
			ilength=ilength+len+2
			goto 1000
		 endif
		if (icode.eq.11) then				! Binary 
			ibin_rep=ibin_rep+1
			binary=.true.
			goto 2500
		 endif
		if (icode.eq.12) then				! Unsigned
			iuns_rep=iuns_rep+1
			unsigned=.true.
			goto 2500
		 endif
 1000		continue
		istart=istart+iadd
		if (i.eq.length_string .or. 
     1				ilength.ge.line_length .or.
     2				istart.gt.length_total) then
			if (full_screen) then
				ihere=11
			 else
				ihere=1
			 endif
			ientry2=ientry2+iencode
			iencode=0
			encode(12,1999,outstring(ihere:ihere+11)) 
     1					ientry1,ientry2-1
 1999			format(i5,'-',i5,x)
			if (display_on) type 2000, outstring
 2000			format(x,a<ilength>)
			if (print_on) write(7,2010) outstring
 2010			format(3x,a<ilength>)
			ilength=1
			if (full_screen) then
				ilength=ilength+23
			 else
				ilength=14
	 		 endif
			outstring=' '
			ientry1=ientry2
			ientry2=ientry1
		 endif
		if (istart.gt.length_total) goto 3000
		if (unsigned) then
			if (iuns_rep.eq.0) then
				unsigned=.false.
				goto 2500
			 else
				goto 950
			 endif
		 endif
		if (binary) then
			if (ibin_rep.eq.0) then
				binary=.false.
				goto 2500
			 else
				goto 950
			 endif
		 endif
 2500	 continue
	 enddo
 3000	continue
	call lib$revert(handler)

	return
	end
!
! this routine takes a byte array and from an arbitrary position will create
!	an equivalence of an i*2 or i*4 number
!
	subroutine integer_get(buffer,istart,length,ivalue)
	byte buffer(*)
	dimension itemp(4)

	ivalue=0
	do i=1,length
		k=length-i
		ihorse=buffer(istart+k)
		itemp(i)=jiand(ihorse,'000000ff'x)
	 enddo
	do i=1,length-1
		k=length-i
		itemp(i)=jishft(itemp(i),k*8)
	 enddo
	do i=1,length
		ivalue=ivalue+itemp(i)
	 enddo
	return
	end
!
! convert
! 
!  should convert single floating into some readable presentation.
!
! calling sequence
!
!	call convert(value,string)
!
!	where float_trash is single precision number, string is character*12,
!
	subroutine convert(value,string)
	character*(*) string
	call for$cvt_d_te(value,string,%val(5),%val(0),
     1					%val(2),%val(2))
	return
	end
!
! dconvert
! 
!  should convert double floating into some readable presentation.
!
! calling sequence
!
!	call dconvert(value,string)
!
!	where float_trash is double precision number, string is character*12,
!
	subroutine dconvert(value,string)
	real*8 value
	character*(*) string
	call for$cvt_d_te(value,string,%val(5),%val(0),
     1					%val(2),%val(2))
	return
	end

!
! binary convert
!
!	takes an 1, 2, or 4 byte number and puts in binary text
!
	subroutine binary_convert(ivalue,ibytes,ostring,length)
	character*32 ostring
	character*1 blank
	data blank /' '/
	
	ostring=' '
	call ots$cvt_l_tb(ivalue,ostring(1:8*ibytes),
     1				%val(8*ibytes),%val(ibytes))
	length=8*ibytes

	return
	end