Function LGetR4 (Prompt,Var,RtnCod,Deflt,MinVal,MaxVal) C C************************************************************************** C ALEDA subroutine to prompt for and accept an ascii string C representing a REAL*4 value from the terminal, convert the value C to its internal 4 byte representation, and return the integer value in C the variable VAR. C Explanation of parameters: C Prompt : User supplied string to be used as prompt for input. C Var : Variable which will receive R*4 value. C RtnCod : Variable to completion status information. C Deflt : Value returned if carriage return is first character C entered; also displayed as part of prompt for input. C MinVal : Minimum valid value for converted input. C MaxVal : Maximum valid value for converted input. C Parameters 'prompt' and 'var' are required; others are optional. C************************************************************************** C INTEGER RtnCod REAL Var, Deflt, MinVal, MaxVal BYTE Prompt(1) C INTEGER TmpRtn BYTE DefVal(11), DefStr(25), InStr(20), BegDef(12) BYTE MinStr(24),Nun(4),MaxStr(25) LOGICAL ExDef, ExMin, ExMax, Point C DATA DefStr /25*' '/ DATA BegDef /' ','(','D','e','f','a','u','l','t',' ','=',' '/ DATA MinStr /' ','(','M','i','n','i','m','u','m',' ','=',' ', $ 12*0/ DATA MaxStr /',',' ','M','a','x','i','m','u','m',' ','=',' ', $ 13*0/ DATA Nun /'n','o','n','e'/ C C Existence of parameters indicated by logical values to avoid C the need to repeatedly call Lexist. ExDef = Lexist(Deflt) ExMin = Lexist(MinVal) ExMax = Lexist(MaxVal) C C If parm #1: PROMPT not provided - abort. IF (Lexist(Var)) GOTO 99 LGetR4 = -1 GOTO 950 C C If parm #2: VARIABLE not provided - abort. 99 IF (Lexist(Var)) GOTO 100 LGetR4 = -2 GOTO 950 C C Build minimum string. 100 IF (ExMin) GOTO 101 C if not minimum provided DO 10 i = 1, 4 MinStr(12 + i) = Nun(i) 10 CONTINUE MinStr (17) = 0 GOTO 110 C if minimum provided 101 ENCODE(11,155,DefVal) MinVal DO 11 i = 1, 11 MinStr(12 + i) = DefVal(i) 11 CONTINUE MinStr(24) = 0 C C Build maximum string. 110 IF (ExMax) GOTO 111 C if not minimum provided DO 12 i = 1, 4 MaxStr(12 + i) = Nun(i) 12 CONTINUE MaxStr(17) = ')' MaxStr(18) = '\' GOTO 200 C if default provided 111 ENCODE(11,155,DefVal) MaxVal DO 13 i = 1, 11 MaxStr(12 + i) = DefVal(i) 13 CONTINUE MaxStr(24) = ')' MaxStr(25) = '\' C C Depending on whether or not a default value was provided, either 200 IF (ExDef) GOTO 250 C Make the default prompt null, or DefStr(1) = 0 GOTO 400 C Build an appropriate default prompt. 250 ENCODE(11,155,DefVal) Deflt IF (Ierror.LT.0) GOTO 900 DO 30 i = 1, 12 DefStr(i) = BegDef(i) 30 CONTINUE DO 60 i = 1, 11 DefStr(12 + i) = DefVal(i) 60 CONTINUE DefStr(24) = ')' DefStr(25) = 0 C 155 FORMAT(E11.3) C Blank input string buffer. 400 DO 40 i = 1, 20 InStr(i) = ' ' 40 CONTINUE C C Get input string. Ierror = LGetSt (Prompt,InStr,20,TmpRtn,0,DefStr) CALL CrLf IF (Ierror) GOTO 900 C C If not string was returned, IF (.NOT.(TmpRtn.EQ.0)) GOTO 407 C if a default was provided, set the value to the default, IF(.NOT.(ExDef)) GOTO 402 Var = Deflt GOTO 950 C otherwise, indicate an error and go back to reprompt. 402 CALL InErr('No default. ',MinStr,MaxStr) GOTO 400 C C Make sure input contains decimal point. 407 Point = .FALSE. DO 403 i = 1,TmpRtn IF (InStr(i).EQ.'.') Point = .TRUE. 403 CONTINUE IF(Point) GOTO 405 CALL InErr('Input needs decimal point. ', $ MinStr,MaxStr ) GOTO 400 C 405 DECODE (TmpRtn,410,InStr,ERR=450) Var 410 FORMAT (E20.6) C C Check to see that value is in range. If (.NOT.(ExMin)) GOTO 420 IF (Var.GE.MinVal) GOTO 420 CALL InErr('Input less than minimum. ',MinStr,MaxStr) GOTO 400 420 If(.NOT.(ExMax)) GOTO 460 IF (Var.LE.MaxVal) GOTO 460 CALL InErr('Input greater than maximum. ', $ MinStr,MaxStr ) GOTO 400 GOTO 460 C C Catch conversion errors and reprompt. 450 CALL InErr('Real*4 conversion error. ',MinStr,MaxStr) GOTO 400 C 460 Ierror = 0 900 LGetR4 = Ierror 950 IF (Lexist(RtnCod)) RtnCod = LGetR4 C 999 RETURN END