LOGICAL FUNCTION VALIDATE(FIELD_NAME,FIELD_VALUE,INITIALIZING)
	IMPLICIT INTEGER*4 (A-Z)
	INCLUDE 'FMS$EXAMPLES:FDVDEF.FOR' ! Get the FMS (VERSION 2) defs


	EXTERNAL VALIDATION_TABLES		! See VALIDTBL.CLD
	EXTERNAL PARSE_ERROR_HANDLER		! Error handler module
!
! Get some of the CLI symbols
!
	EXTERNAL CLI$_PRESENT
	EXTERNAL CLI$_NEGATED
	EXTERNAL CLI$_LOCPRES
	EXTERNAL CLI$_LOCNEG
	EXTERNAL CLI$_DEFAULTED
	EXTERNAL CLI$_ABSENT
!
! These variables are passed at function call time
!
	CHARACTER*31	FIELD_NAME
	CHARACTER*(*)	FIELD_VALUE
	LOGICAL		INITIALIZING		! .TRUE. when loading form

	LOGICAL		LOCAL		! From DCL qualifier of same name
	LOGICAL		RANGE
	LOGICAL		LEGAL
	LOGICAL		VALID
	COMMON /DCL_QUALIFIERS/LOCAL,RANGE,LEGAL,VALID
!
! These are local variables used in this routine
!
	CHARACTER*512	NAMED_DATA		! String from FMS named data
	CHARACTER*80	VALIDATION_STRING	! Retrieved from tables
	CHARACTER*80	ERROR_MESSAGE		! Validation error message
	CHARACTER*12	VALID_RADIX		! Holds radix from form
	REAL		FLOAT			! INTEGER to REAL function
	REAL		STRING_VALUE		! String to REAL function
	REAL		REAL_FIELD_VALUE
	REAL		REAL_LOW_LIMIT
	REAL		REAL_HIGH_LIMIT
	CHARACTER*31	TEST_FIELD_NAME		! Temp field name
	CHARACTER*80	NMDVAL			! Named data value

	CHARACTER*20	FORMAT_STR		! Runtime format
	CHARACTER*7	DECIMAL/'DECIMAL'/	! Valid constant for radix
	CHARACTER*5	OCTAL/'OCTAL'/		! Valid constant for radix
	CHARACTER*11	HEXIDECIMAL/'HEXIDECIMAL'/ ! Valid constant for radix
	CHARACTER*6	BINARY/'BINARY'/	! Valid constant for radix
	LOGICAL		SPACE			! Used in space checking
	BYTE		BYTE_CHAR
!
! This little hack is used to get a copy of FIELD_NAME into a common
! so that the user defined error handler can show the user
! which named data field(s) contained invalid information
!
	CHARACTER*31 HANDLER_FIELD_NAME
	COMMON/HANDLER/HANDLER_FIELD_NAME,NAMED_DATA_LEN,NAMED_DATA
!
!==========================================================================
!
	VALIDATE = .TRUE.			! Assume it's okay
	ERROR_DISPLAYED = .FALSE.		! Assume no error msgs printed
!+
! Try to get a named data string of the same name as our field name. If it
! doesn't exist just return as no validation is required.  If, however,
! it DOES exist we must go thru this validation routine
!-
	IF(FDV$RETDN(FIELD_NAME,NAMED_DATA,NMDIDX).NE.FDV$_SUC)RETURN
	IF(NAMED_DATA .EQ. ' ')RETURN		! Ignore blank strings
!
! Here we got a field name match we better parse the string and see if
! it's valid.

!
! Find the position of the last character of the string
!
	NAMED_DATA_LEN = 0
	DO I=1,80
	  IF(NAMED_DATA(I:I).NE.' ')NAMED_DATA_LEN = I
	ENDDO
!
! Test to see if the next named data
! field in the form has the same name, if so, append that to our
! named data string. This allows us to handle strings which are longer
! than 80 characters
!
	TEST_FIELD_NAME = FIELD_NAME		! Record the current field name
	DO WHILE(TEST_FIELD_NAME .EQ. FIELD_NAME) ! Loop until no match
	  NMDIDX = NMDIDX + 1			! Index to the next named data
	  CALL FDV$RETDI(NMDIDX,NMDVAL,		! Get the next named data
	1	TEST_FIELD_NAME)
	  IF(TEST_FIELD_NAME.EQ.FIELD_NAME)THEN	! Same name ?
	    NMDLEN = 0				! Yes! Figure out its's length
	    DO I=1,80				! Scan the string
	      IF(NMDVAL(I:I).NE.' ')NMDLEN=I	! Looking for spaces
	    ENDDO
	    NAMED_DATA(NAMED_DATA_LEN+1:) = 	! Append to the end of our str
	1	NMDVAL(1:NMDLEN)
	    NAMED_DATA_LEN = NAMED_DATA_LEN + NMDLEN ! Update the end pointer
	  ENDIF		! if(field_name = test_field_name)
	ENDDO		! field_name = test_field_name

	VALIDATE = .FALSE.			! Assume invalid from here on
!
! This command uses the CLI tables in VALIDTBL.CLD for parsing the
! validation string.
!
	HANDLER_FIELD_NAME = FIELD_NAME		! Store name for error handler
	SAV_HANDLER = LIB$ESTABLISH(PARSE_ERROR_HANDLER)! Error handler module
	ISTAT = CLI$DCL_PARSE
	1  ('VALIDATE'//NAMED_DATA(1:NAMED_DATA_LEN),	! Parse the string
	1	VALIDATION_TABLES)		! Using these tables
	CALL LIB$ESTABLISH(SAV_HANDLER)		! Restore old error handler
	LEN_FIELD = LEN(FIELD_VALUE)		! Get the len of the form field
!
! Then test to see if we're gonna allow imbeded spaces in the field
!
	IF(.NOT.CLI$PRESENT('SPACES'))THEN
	  VALIDATE = .FALSE.			! Assume invalid from here on
	  SPACE=.FALSE.				! Assume no spaces found yet
	  DO I=1,LEN_FIELD			! Scan the field
	    IF(FIELD_VALUE(I:I).EQ.' ')THEN	! Find a space ?
	      SPACE = .TRUE.			! Yep set the flag
	    ELSE				! Otherwise (not a space)
	      IF(SPACE)THEN			! Fail if character after space
		IF(CLI$PRESENT('MESSAGE').EQ.%LOC(CLI$_DEFAULTED))THEN
		  CALL FDV$PUTL('Spaces not permitted') ! Take default err txt
		  CALL FDV$BELL			! Ring the bell
		  ERROR_DISPLAYED = .TRUE.	! Indicated msg displayed
		ENDIF				!
		GOTO 900			! Take failure path
	      END IF	! (found illegal space)
	    ENDIF	! (FIELD_VALUE(I:I)=' ')
	  ENDDO		! scan field
	  VALIDATE = .TRUE.			! Test passed
	ENDIF		! test for spaces

!
! The next thing we will do is test for valid ascii strings
! if we find a valid match we can skip the range checking stuff
!
	IF(CLI$PRESENT('LEGAL'))THEN		! /LEGAL qualifier ?
	  VALIDATE = .FALSE.			! Assume invalid data
	  IF(LEGAL)THEN				! Is legal testing enabled ?
	    ISTAT = .TRUE.			! Force at least one CLI$GET
	      DO WHILE(ISTAT)			! Loop till no more values
	        ISTAT = CLI$GET_VALUE('LEGAL',	! Get a validation string
	1		VALIDATION_STRING)
	        IF(ISTAT)THEN			! Did we really get one ?
	          IF(VALIDATION_STRING(1:LEN_FIELD) ! Yep - test it...
	1		.EQ.FIELD_VALUE)THEN
	    	    VALIDATE = .TRUE.		! Musta been okay set flag
	  	    GOTO 900			! And skip the rest
	  	  ENDIF		! if( strings matched)
	        ENDIF		! if(cli value was returned)
	      ENDDO		! do while there legal values
	  ELSE			! If no legal testing (per orig DCL command)
	    VALIDATE = .TRUE.			! It's always true
	    GOTO 900				! And skip the rest
	  ENDIF	! IF LEGAL
	ENDIF	! IF CLI$PRESENT
!
!
! Only try to decode the field into a numerical value if
! we're doing some kind of numerical checking
!
	IF(CLI$PRESENT('LOWER') .OR.		! Any range testing ?
	1  CLI$PRESENT('UPPER') .OR.
	1  CLI$PRESENT('RADIX'))THEN		! Or radix testing
	  VALIDATE = .FALSE.			! Assume bad value
!
! Here we've got to test for upper and lower ranges (or valid radix), first get
! the decoding radix from the validation string then try to convert
! the value in the form to a real numerical value which we can
! use for the comparisions
!
	  IF(CLI$PRESENT('RADIX'))THEN		! Was radix explicit ?
	    CALL CLI$GET_VALUE('RADIX',VALID_RADIX) ! Yes,get the valid radix
	    LEN_RADIX=0				! Init radix string length
	    DO I=1,LEN(VALID_RADIX)		! Count the radix str len
	      IF(VALID_RADIX(I:I).NE.' ')LEN_RADIX=I
	    ENDDO
	  ELSE					! 'RADIX' not explicit
	    VALID_RADIX = 'DECIMAL'		! Default to decimal
	    LEN_RADIX = 7			! Length of 'DECIMAL'
	  ENDIF

	  IF( STR$COMPARE(VALID_RADIX(1:LEN_RADIX), ! Test for decimal radix
	1	DECIMAL(1:LEN_RADIX)) .EQ.0)THEN
	    LOCDEC = INDEX(FIELD_VALUE,'.')	! Scan field for decimal point
	    IF(LOCDEC.NE.0)THEN			! Find a decimal point ?
	      WRITE(FORMAT_STR ,		! Yep construct the runtime fmt
	1	'(''(BN,F'',I3,''.'',I3,'')'')')! With this mess
	1	LEN_FIELD,LEN_FIELD-LOCDEC
	      READ(FIELD_VALUE,FORMAT_STR,ERR=900) ! Try to decode the field
	1		REAL_FIELD_VALUE	! and branch to 900 on errors
	    ELSE				! No decimal point in field
	      WRITE(FORMAT_STR,'(''(BN,I'',I3,'')'')') ! Alternate format
	1		LEN_FIELD
	      READ(FIELD_VALUE,FORMAT_STR, 	! Decode this one
	1		ERR=900)INTEGER_FIELD_VALUE
	      REAL_FIELD_VALUE = 		! Convert to floating value
	1	FLOAT(INTEGER_FIELD_VALUE)
	    ENDIF
	    VALIDATE = .TRUE.			! Decmial radix okay
!
! This section executes if we need to decode the field in hex
!

	  ELSE IF(STR$COMPARE(VALID_RADIX(1:LEN_RADIX), ! Test for HEX radix
	1	HEXIDECIMAL(1:LEN_RADIX)) .EQ.0)THEN
	      WRITE(FORMAT_STR,			! Construct the format
	1		'(''(BN,Z'',I3,'')'')')LEN_FIELD
	      READ(FIELD_VALUE,FORMAT_STR,ERR=900) ! Decode the string
	1		INTEGER_FIELD_VALUE	! Branch to 900 on errors
	      REAL_FIELD_VALUE = 		! Convert the results to real
	1	FLOAT(INTEGER_FIELD_VALUE)
	     VALIDATE = .TRUE.			! Hex radix okay
!
! Finally if for some crazy reason we want to read the field based on
! octal - we'll do the following block
!
	  ELSE IF(STR$COMPARE(VALID_RADIX(1:LEN_RADIX), ! Octal radix ?
	1	OCTAL(1:LEN_RADIX)) .EQ.0)THEN
	      WRITE(FORMAT_STR,			! Construct the format
	1	'(''(BN,O'',I3,'')'')')LEN_FIELD
	      READ(FIELD_VALUE,FORMAT_STR,ERR=900) ! Decode the string
	1		INTEGER_FIELD_VALUE	! Branch to 900 on errors
	      REAL_FIELD_VALUE = 		! Convert the results to real
	1	FLOAT(INTEGER_FIELD_VALUE)
	    VALIDATE = .TRUE.			! Octal radix okay

	  ELSE IF(STR$COMPARE(VALID_RADIX(1:LEN_RADIX), ! Binary radix ?
	1	BINARY(1:LEN_RADIX)) .EQ.0)THEN
	    INTEGER_FIELD_VALUE = BIN_STR(FIELD_VALUE,ISTAT)
	    IF(.NOT.ISTAT)GOTO 900		! Branch on conversion errors
	    REAL_FIELD_VALUE =			! Float the value
	1	FLOAT(INTEGER_FIELD_VALUE)
	    VALIDATE = .TRUE.			! Binary radix okay

	  ELSE
	    CALL LIB$ERASE_PAGE(1,1)
	    TYPE *,'An invalid value for the /RADIX qualifier was'
	    TYPE *,'encountered for the field named ',FIELD_NAME
	    TYPE *,'The invalid value was ',VALID_RADIX(1:LEN_RADIX)
	    TYPE *
	    TYPE *,'%MENU-F-BADDATA, invalid named data in form'
	    CALL EXIT
	  ENDIF
!
! If we get this far, the validation is set to .TRUE.
!
!
! At this point the variable REAL_FIELD_VALUE has the numerical
! value of the string to be tested. If we got a conversion error
! the validation was marked as a failure already and we never get this far.
!
	  IF(CLI$PRESENT('LOWER'))THEN		! Lower range testing ?
	    CALL CLI$GET_VALUE('LOWER',		! Get the string value
	1	VALIDATION_STRING)

	    REAL_LOW_LIMIT = STRING_VALUE(VALIDATION_STRING,
	1	FIELD_NAME)
!
! Here's where the low limit test is performed
!
	    LOW_OKAY = REAL_FIELD_VALUE .GE. REAL_LOW_LIMIT
	  ELSE				! No low test asked for
	    LOW_OKAY = .TRUE.		! is the same as okay
	  ENDIF

	  IF(CLI$PRESENT('UPPER'))THEN
	    CALL CLI$GET_VALUE('UPPER',VALIDATION_STRING)
	    REAL_HIGH_LIMIT = STRING_VALUE (VALIDATION_STRING,
	1	FIELD_NAME)
	    HIGH_OKAY = REAL_FIELD_VALUE .LE. REAL_HIGH_LIMIT
	  ELSE			! No upper test asked for
	    HIGH_OKAY = .TRUE.	! is the same as okay
	  ENDIF

	  IF(RANGE)THEN		! Range testing enabled
	      VALIDATE = LOW_OKAY.AND.HIGH_OKAY	! Calculate VALIDATE
	  ELSE			! Range testing not enabled
	    VALIDATE = .TRUE.	! Just set it true
	  ENDIF

	ENDIF	! IF UPPER OR LOWER TEST OR RANGE TEST

!
! This is the common return point - check to see if we got a valid
! field, if so just return else get the error message and display it
!
900	IF(.NOT.VALIDATE.AND..NOT.INITIALIZING)THEN 	! If we get an error
	  IF(.NOT. ERROR_DISPLAYED)THEN			! Did we do the msg ?
	    CALL CLI$GET_VALUE('MESSAGE',ERROR_MESSAGE) ! Get the error text
	    CALL FDV$PUTL(ERROR_MESSAGE)		! Display the error txt
	    CALL FDV$BELL				! Ring the bell
	  ENDIF
	  IF(CLI$PRESENT('CLEAR_ON_ERROR'))THEN		! Clear the field ?
	    FIELD_VALUE = ' '				! Clear the field
	    CALL FDV$PUT(FIELD_VALUE,FIELD_NAME)	! Stuff the form
	  ENDIF
	ENDIF	! (error detected and not initializing)
	RETURN
	END
!==============================================================================
	REAL FUNCTION STRING_VALUE(STRING,FIELD_NAME)

	INTEGER*4	BIN_STR
	REAL		FLOAT
	INTEGER*4	INT_VALUE
	CHARACTER*(*)	STRING
	CHARACTER*(*)	FIELD_NAME
	CHARACTER*20	FORMAT_STR		! Runtime format
!
! This section converts the ascii string STRING to a numerical
! value which can be used in the comparisons
!
	    IF(STRING(1:2).EQ.'%X')THEN ! Hex flag ?
	      READ(STRING(3:80),	! Yep, decode the string
	1		'(BN,Z78)',ERR=950)INT_VALUE ! Branch on form error
	      STRING_VALUE = FLOAT(INT_VALUE)	! Convert the value to real


	    ELSE IF(STRING(1:2).EQ.'%O')THEN
	      READ(STRING(3:80),'(BN,O78)',
	1		ERR=950)INT_VALUE
	      STRING_VALUE = FLOAT(INT_VALUE)



	    ELSE IF(STRING(1:2).EQ.'%D')THEN
	      LOCDEC = INDEX(STRING(3:80),'.')
	      IF(LOCDEC .EQ. 0)THEN
	        READ(STRING(3:80),'(BN,I78)',
	1		ERR=950)INT_VALUE
	        STRING_VALUE = FLOAT(INT_VALUE)
	      ELSE
	        WRITE(FORMAT_STR,
	1		'(''(BN,F78.'',I3,'')'')')78-LOCDEC
	        READ(STRING(3:80),
	1		FORMAT_STR,ERR=950)STRING_VALUE
	      ENDIF

	    ELSE IF(STRING(1:2).EQ.'%B')THEN
	      INT_VALUE=BIN_STR(STRING(3:80),ISTAT)
	      IF(.NOT.ISTAT)GOTO 950		! Branch on errors
	      STRING_VALUE = FLOAT(INT_VALUE)

	    ELSE
	      LOCDEC = INDEX(STRING(1:80),'.')
	      IF(LOCDEC .EQ. 0)THEN
	        READ(STRING(1:80),
	1		'(BN,I80)',ERR=950)INT_VALUE
	        STRING_VALUE = FLOAT(INT_VALUE)
	      ELSE
	        WRITE(FORMAT_STR,
	1		'(''(BN,F80.'',I3,'')'')')80-LOCDEC
	        READ(STRING(1:80),
	1		FORMAT_STR,ERR=950)STRING_VALUE
	      ENDIF
	    ENDIF
	RETURN	
!
! This is the error routine which is branched to if we find a bad
! value in the named data in the form
!
950	CALL LIB$ERASE_PAGE(1,1)
	LOC=0
	DO I=1,LEN(FIELD_NAME)
	  IF(FIELD_NAME(I:I).NE.' ')LOC=I
	ENDDO
	TYPE *,'The named data field ',FIELD_NAME(1:LOC)
	TYPE *,'in your form contained an invalid character in the string'
	TYPE *,STRING
	TYPE *
	TYPE *,'%MENU-F-BADDATA, invalid named data in form'
	CALL EXIT
	END

	INTEGER*4 FUNCTION BIN_STR(STRING,ISTAT)
	IMPLICIT INTEGER*4 (A-Z)

	CHARACTER*(*) STRING
	LOGICAL ISTAT

	TEMP_VALUE = 0
	ISTAT = .TRUE.
	DO I = 1,LEN(STRING)
	  IF(STRING(I:I).NE.' ')THEN
	    IF(STRING(I:I).EQ.'0'.OR.STRING(I:I).EQ.'1')THEN
	      TEMP_VALUE = ISHFT(TEMP_VALUE,1) + 
	1		ICHAR(STRING(I:I)) - 48
	    ELSE
	      ISTAT = .FALSE.
	    ENDIF
	  ENDIF
	ENDDO
	BIN_STR = TEMP_VALUE
	RETURN
	END

	SUBROUTINE PARSE_ERROR_HANDLER		! Error handler module

	CHARACTER*31 HANDLER_FIELD_NAME
	CHARACTER*512 NAMED_DATA
	INTEGER*4 NAMED_DATA_LEN
	COMMON/HANDLER/HANDLER_FIELD_NAME,NAMED_DATA_LEN,NAMED_DATA
!
! This module is the condition handler for the CLI parsing routine
! so that we can cleanly handle any form errors
!
	CALL LIB$ERASE_PAGE(1,1)		! Clear the screen
	TYPE *,'An error has occured while parsing the named data field:'
	TYPE *,HANDLER_FIELD_NAME
	TYPE *,'The string containing the error was:'
	TYPE *,NAMED_DATA(1:NAMED_DATA_LEN)
	TYPE *
	TYPE *,'%MENU-F-IVKEYW, unrecognized named data keyword'
	CALL EXIT			! And exit
	END