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