	LOGICAL*1 FUNCTION GETDEF(BUFR,QUIET)
C
C	Obtain a UDK definition from the user as an ASCII string
C	and convert it into it's HEX_ASCII equivalent.
C
	INTEGER JSW,SVEJSW,LENGTH,IPEEK,LEN,INDEX,I,J,CKNT,NUMBER
	INTEGER EXTCDE
	LOGICAL*1 QUIET
	BYTE BUFR(1),PID,STRING,CRTRN(2),ECONT,YESNOP,CNTRLZ(2)
	BYTE DFPRM1(255),DFPRM2(255),DFPRM3(255),DFPRM4(243)
	BYTE EMPTY(119),BADNUM(125),TOOLNG(161)
	COMMON /UDK00/ PID(41)
	COMMON /UDK01/ STRING(82)
	COMMON /UDK02/ ECONT(54)
	COMMON /UDK03/ YESNOP(112)
	COMMON /UDK04/ EXTCDE
	DATA JSW /"44/, CRTRN /"15,0/, CNTRLZ /"32,0/
	DATA DFPRM1 /"33,'[','2','J',"33,'[','2',';','2','0','H',"33,
     #	 '[','1','m','E','n','t','e','r',' ','t','h','e',' ','c','h',
     #	 'a','r','a','c','t','e','r',' ','s','t','r','i','n','g',' ',
     #	 't','o',' ','b','e',' ','l','o','a','d','e','d','.',"33,'[',
     #	 '0','m',"33,'[','3',';','1','H',"33,')','0',"16,'s','s','s',
     #	 's','s','s','s','s','s','s','s','s','s','s','s','s','s','s',
     #	 's','s','s','s','s','s','s','s','s','s','s','s','s','s','s',
     #	 's','s','s','s','s','s','s','s','s','s','s','s','s','s','s',
     #	 's','s','s','s','s','s','s','s','s','s','s','s','s','s','s',
     #	 's','s','s','s','s','s','s','s','s','s','s','s','s','s','s',
     #	 's','s',"33,'[','1','0',';','1','H','o','o','o','o','o','o',
     #	 'o','o','o','o','o','o','o','o','o','o','o','o','o','o','o',
     #	 'o','o','o','o','o','o','o','o','o','o','o','o','o','o','o',
     #	 'o','o','o','o','o','o','o','o','o','o','o','o','o','o','o',
     #	 'o','o','o','o','o','o','o','o','o','o','o','o','o','o','o',
     #	 'o','o','o','o','o','o','o','o','o','o','o','o','o','o',"17,
     #	 "33,'[','4',';','9','r',"33,'[','1','1',';','7','H','E','n',
     #	 'd',' ',"200/
	DATA DFPRM2 /'t','h','e',' ','d','e','f','i','n','i','t','i',
     #	 'o','n',' ','w','i','t','h',' ',"33,'[','7','m','C','o','n',
     #	 't','r','o','l','_','Z',"33,'[','0','m',' ',"33,'[','7','m',
     #	 'R','E','T','U','R','N',"33,'[','0','m',' ','o','r',' ','t',
     #	 'h','e',' ','s','t','r','i','n','g',' ',"33,'[','7','m','^',
     #	 'Z',"33,'[','0','m',' ',"33,'[','7','m','R','E','T','U','R',
     #	 'N',"33,'[','0','m','.',"33,'[','1','2',';','1','7','H','T',
     #	 'h','e',' ','l','a','t','t','e','r',' ','f','o','r','m',' ',
     #	 'i','s',' ','r','e','q','u','i','r','e','d',' ','i','n',' ',
     #	 'c','o','m','m','a','n','d',' ','f','i','l','e','s','.',"33,
     #	 '[','1','4',';','1','3','H','I','n','p','u','t',' ','l','i',
     #	 'n','e','s',' ','m','a','y',' ','b','e',' ','e','d','i','t',
     #	 'e','d',' ','w','i','t','h',' ',"33,'[','7','m','D','E','L',
     #	 'E','T','E',"33,'[','0','m',' ','a','n','d',' ',"33,'[','7',
     #	 'm',' ','C','o','n','t','r','o','l','_','U','.',"33,'[','0',
     #	 'm',"33,'[','1','6',';','1','2','H','N','o','t','e',':',' ',
     #	 ' ',"33,'[','7','m','L','I','N','E','_','F','E','E','D',"33,
     #	 '[','0',"200/
	DATA DFPRM3 /'m',' ','c','h','a','r','a','c','t','e','r','s',
     #	 ' ','m','u','s','t',' ','b','e',' ','s','p','e','c','i','f',
     #	 'i','c','a','l','l','y',' ','e','n','t','e','r','e','d','.',
     #	 "33,'[','1','8',';','1','4','H','A',' ','"',"33,'[','7','m',
     #	 '-',"33,'[','0','m','"',' ','(','m','i','n','u','s',' ','s',
     #	 'i','g','n',')',' ','c','h','a','r','a','c','t','e','r',' ',
     #	 'i','m','m','e','d','i','a','t','e','l','y',' ','p','r','e',
     #	 'c','e','d','i','n','g',"33,'[','1','9',';','1','4','H','a',
     #	 ' ',"33,'[','7','m','R','E','T','U','R','N',"33,'[','0','m',
     #	 ' ','c','h','a','r','a','c','t','e','r',' ','w','i','l','l',
     #	 ' ','b','e',' ','i','n','t','e','r','p','r','e','t','e','d',
     #	 ' ','a','s',' ','a',' ','r','e','q','u','e','s','t',"33,'[',
     #	 '2','0',';','1','4','H','f','o','r',' ','s','t','r','i','n',
     #	 'g',' ','c','o','n','t','i','n','u','a','t','i','o','n',' ',
     #	 '(','o','m','i','t',' ','t','h','e',' ','"',"33,'[','7','m',
     #	 '-',"33,'[','0','m','"',' ','a','n','d',' ',"33,'[','7','m',
     #	 'R','E','T','U','R','N',"33,'[','0','m',')','.',"33,'[','2',
     #	 '2',';',"200/
	DATA DFPRM4 /'7','H','N','o','n','-','p','r','i','n','t','i',
     #	 'n','g',' ','A','S','C','I','I',' ','c','h','a','r','a','c',
     #	 't','e','r','s',' ','m','u','s','t',' ','b','e',' ','e','n',
     #	 't','e','r','e','d',' ','a','s',' ','n','u','m','e','r','i',
     #	 'c',' ','v','a','l','u','e','s','.',"33,'[','2','3',';','7',
     #	 'H','T','h','e','s','e',' ','a','r','e',' ','s','p','e','c',
     #	 'i','f','i','e','d',' ','o','n','e',' ','v','a','l','u','e',
     #	 ' ','p','e','r',' ','l','i','n','e',' ','i','n',' ','t','h',
     #	 'e',' ','f','o','l','l','o','w','i','n','g',' ','f','o','r',
     #	 'm','a','t',':',"33,'[','2','4',';','7','H',"33,'[','1','m',
     #	 '\','x','x','x','O',"33,'[','0','m',' ','f','o','r',' ','a',
     #	 'n',' ','O','c','t','a','l',' ','e','n','t','r','y',',',' ',
     #	 "33,'[','1','m','\','x','x','x','D',"33,'[','0','m',' ','f',
     #	 'o','r',' ','D','e','c','i','m','a','l',' ','a','n','d',' ',
     #	 "33,'[','1','m','\','x','x','H',"33,'[','0','m',' ','f','o',
     #	 'r',' ','H','e','x','a','d','e','c','i','m','a','l','.',"33,
     #	 '[','4',';','1','H',"200/
	DATA EMPTY  /"7,"7,"33,'[','2',';','1','H',"33,'[','0','J',"33,
     #	 '[','1','0',';','1','2','H',"33,'[','1','m','T','h','i','s',
     #	 ' ','n','u','l','l',' ','e','n','t','r','y',' ','w','i','l',
     #	 'l',' ','c','l','e','a','r',' ','t','h','e',' ','k','e','y',
     #	 "47,'s',' ','p','r','e','s','e','n','t',' ','d','e','f','i',
     #	 'n','i','t','i','o','n','.',"33,'[','0','m',"33,'[','1','3',
     #	 ';','2','7','H','I','s',' ','t','h','a','t',' ','w','h','a',
     #	 't',' ','y','o','u',' ','i','n','t','e','n','d','e','d','?',
     #	 "200/
	DATA BADNUM /"7,"7,"33,'[','2',';','1','H',"33,'[','0','J',"33,
     #	 '[','1','0',';','1','5','H',"33,'[','1','m','A','n',' ','i',
     #	 'l','l','e','g','a','l',' ','n','u','m','e','r','i','c',' ',
     #	 'i','n','p','u','t',' ','v','a','l','u','e',' ','h','a','s',
     #	 ' ','b','e','e','n',' ','d','e','t','e','c','t','e','d','.',
     #	 "33,'[','0','m',"33,'[','1','3',';','2','0','H','T','h','e',
     #	 ' ','w','h','o','l','e',' ','d','e','f','i','n','i','t','i',
     #	 'o','n',' ','h','a','s',' ','b','e','e','n',' ','r','e','j',
     #	 'e','c','t','e','d','.',"200/
	DATA TOOLNG /"7,"7,"33,'[','2',';','1','H',"33,'[','0','J',"33,
     #	 '[','7',';','2','1','H','V','T','2','0','0',' ','s','e','r',
     #	 'i','e','s',' ','t','e','r','m','i','n','a','l','s',' ','p',
     #	 'r','o','v','i','d','e',' ','a',' ','t','o','t','a','l',"33,
     #	 '[','9',';','2','3','H','U','D','K',' ','s','t','o','r','a',
     #	 'g','e',' ','c','a','p','a','c','i','t','y',' ','o','f',' ',
     #	 '2','5','6',' ','b','y','t','e','s','.',"33,'[','1','3',';',
     #	 '1','7','H',"33,'[','1','m','T','h','i','s',' ','d','e','f',
     #	 'i','n','i','t','i','o','n',' ','h','a','s',' ','b','e','e',
     #	 'n',' ','r','e','j','e','c','t','e','d',' ','a','s',' ','t',
     #	 'o','o',' ','l','o','n','g','.',"33,'[','0','m',"200/
	GETDEF = .FALSE.           !Assume abort will be requested
	IF(QUIET)  GO TO 5
	CALL PRINT(DFPRM1)         !Display the menu
	CALL PRINT(DFPRM2)
	CALL PRINT(DFPRM3)
	CALL PRINT(DFPRM4)
    5	SVEJSW = IPEEK(JSW)
	CALL IPOKE(JSW,SVEJSW .OR. "40000)  !Enable Lowercase input
	CALL RCTRLO
	CKNT = 0                    !Reset number of chars. in definition
C
C	Get a line of characters from the terminal
C
   10	CALL GTLIN(STRING)
	LENGTH = LEN(STRING)
	IF(LENGTH .NE. 0)  GO TO 15
C
C	An empty line implies enter a carriage-return code
C
	CALL SCOPY(CRTRN,STRING)
	LENGTH = 1
	GO TO 45
C
C	React to end_of_string flags:  Control_Z, "^Z", and "^z"
C
   15	IF(ISCOMP(CNTRLZ,STRING).EQ.0)  GO TO 50
	IF(ISCOMP('^Z',STRING).EQ.0 .OR. ISCOMP('^z',STRING).EQ.0)
     #	 GO TO 50
C
C	Detect the numeric input introducer
C
	IF(INDEX(STRING(1),'\') .EQ. 1)  GO TO 25
C
C	Detect the minus sign string continuation request
C
	IF(INDEX(STRING(LENGTH),'-') .NE. 1)  GO TO 20
	STRING(LENGTH) = 0            !Delete the trailing minus sign
	LENGTH = LENGTH - 1
	GO TO 45
C
C	Process normal string input
C
   20	CALL CONCAT(STRING,CRTRN,STRING,81) !Append carriage return code
	LENGTH = LENGTH + 1
	GO TO 45
C
C	Process numeric input codes
C
   25	I = INDEX('ODHodh',STRING(LENGTH))  !Indentify numeric "base"
	IF(I .EQ. 0)  GO TO 80
	IF(I .GT. 3)  I = I - 3             !Handle lower case input
	STRING(LENGTH) = 0                  !Eliminate "base" indicator
	LENGTH = LEN(STRING(2))
	IF(LENGTH .EQ. 0)  GO TO 80
	IF(I .EQ. 3)  GO TO 35
	IF(IVERIF(STRING(2),'0123456789') .NE. 0)  GO TO 80
	IF(I .EQ. 2) GO TO 30
	DECODE(LENGTH,100,STRING(2),ERR=80) NUMBER   !Octal
  100	FORMAT(O)
	GO TO 40
   30	DECODE(LENGTH,200,STRING(2),ERR=80) NUMBER   !Decimal
  200	FORMAT(I)
	GO TO 40
   35	NUMBER = 0                                   !Hexadecimal
	DO 1000 I = 1,LENGTH
	J = INDEX('0123456789ABCDEF',STRING(1+I)) - 1
	IF(J .LT. 0)  GO TO 80
	NUMBER = (NUMBER * 16) + J
 1000	CONTINUE
   40	IF(NUMBER .LT. 0 .OR. NUMBER .GT. 127)  GO TO 80
	CALL SCOPY(NUMBER,STRING)          !High byte will be zero
	LENGTH = 1
C
C	Translate the input string into HEX_ASCII in the output buffer
C
   45	CKNT = CKNT + LENGTH
	IF(CKNT .GT. 256)  GO TO 90                !String too long
	CALL HEXASC(STRING,BUFR(LEN(BUFR)+1))      !Translate into HEX_ASCII
	GO TO 10                                   !Go look for more input
C
C	End of string input detected
C
   50	CALL IPOKE(JSW,SVEJSW)                     !Restore "Upper Case Only"
	CALL RCTRLO
	IF(CKNT .EQ. 0)  GO TO 70                  !Null Definition
   55	GETDEF = .TRUE.
	RETURN
C
C	Error handler
C
   70	CALL PRINT(PID)
	CALL PRINT(EMPTY)
	CALL GTLIN(STRING,YESNOP)
	IF(LEN(STRING).EQ.0 .OR. STRING(1).NE.'Y')  RETURN
	GO TO 55                                   !Null definition wanted
   80	CALL PRINT(PID)
	CALL PRINT(BADNUM)
	GO TO 95
   90	CALL PRINT(PID)
	CALL PRINT(TOOLNG)
   95	CALL GTLIN(STRING,ECONT)
	EXTCDE = 4                                 !Set exit code to ERROR$
	RETURN
	END
	SUBROUTINE HEXASC(ISTRNG,OSTRNG)
C
C	Convert each ASCII value in ISTRNG into two HEX-ASCII
C	characters stored sequentially in OSTRNG.  OSTRNG must be
C	twice as long as ISTRNG and must also have room for a trailing
C	NULL byte which marks the end_of_string (ASCIZ).
C

	INTEGER LEN,ICNT,IP,OP,I
	BYTE ISTRNG(1),OSTRNG(1),HEXTBL(16)
	DATA HEXTBL /'0','1','2','3','4','5','6','7','8','9','A','B',
     #	 'C','D','E','F'/
	OP = 1
	ICNT = LEN(ISTRNG)
	IF(ICNT .EQ. 0)  GO TO 10
	DO 1000 IP = 1,ICNT
	I = ISTRNG(IP)
	OSTRNG(OP)   = HEXTBL(1+(I/16))         !H.O. Nibble
	OSTRNG(OP+1) = HEXTBL(1+(I.AND.15))     !L.O. Nibble
	OP = OP + 2
 1000	CONTINUE
   10	OSTRNG(OP) = 0
	RETURN
	END
�����������������������������������������������������������������������������������������������������������������������������������������������������������