LOGICAL*1 FUNCTION GETDEF(BUFR) 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 BYTE BUFR(1),STRING,CRTRN(2),ECONT,YESNOP,CNTRLZ(2) BYTE DFPRM1(255),DFPRM2(255),DFPRM3(255),DFPRM4(243) BYTE EMPTY(119),BADNUM(125),TOOLNG(161) COMMON /UDK01/ STRING(82) COMMON /UDK02/ ECONT(54) COMMON /UDK03/ YESNOP(112) 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 CALL PRINT(DFPRM1) !Display the menu CALL PRINT(DFPRM2) CALL PRINT(DFPRM3) CALL PRINT(DFPRM4) 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(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(BADNUM) GO TO 95 90 CALL PRINT(TOOLNG) 95 CALL GTLIN(STRING,ECONT) 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