Trailing-Edge
-
PDP-10 Archives
-
BB-AI48A-BM
-
datatrieve/linear.bli
There are no other files named linear.bli in the archive.
%TITLE 'LINEAR - A Callable Datatrieve Example'
MODULE LINEAR (MAIN = MAINPROG) =
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!
! L I N E A R
!
!
! COPYRIGHT (c) 1984 BY
! DIGITAL EQUIPMENT CORPORATION, MAYNARD
! MASSACHUSETTS. ALL RIGHTS RESERVED.
!
! THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY
! BE USED AND COPIED ONLY IN ACCORDANCE WITH THE
! TERMS OF SUCH LICENSE AND WITH THE INCLUSION OF THE
! ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
! COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE
! MADE AVAILABLE TO ANY OTHER PERSON. NO TITLE TO
! AND OWNERSHIP OF THE SOFTWARE IS HEREBY
! TRANSFERRED.
!
! THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO
! CHANGE WITHOUT NOTICE AND SHOULD NOT BE CONSTRUED
! AS A COMMITMENT BY DIGITAL EQUIPMENT CORPORATION.
!
! DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR
! RELIABILITY OF ITS SOFTWARE ON EQUIPMENT THAT IS
! NOT SUPPLIED BY DIGITAL.
!
!
! FUNCTIONAL DESCRIPTION
! The program linear performs a linear regression on data from
! a Datatrieve domain. It prompts the user for input, parses the
! commands, and passes them to Datatrieve.
!
! Linking instructions:
! @LOAD LINEAR,SYS:DTRLIB
!
! VERSION NUMBER
! 1
!
! HISTORY
! This module was adapted from the FORTRAN example in
! the Vax-11 Datatrieve Call Interface Manual.
!
!-----------------------------------------------------------------------
BEGIN
LIBRARY 'DABSYM'; ! Defines the DAB symbols
LIBRARY 'BLI:MONSYM'; ! Monitor symbols
LIBRARY 'DYNLIB'; ! Dynamic library symbols
REQUIRE 'DAB'; ! Declares a block for the DAB
LITERAL
TEXT_BUFFER_SIZE = 256,
FIELD_BUFFER_SIZE = 40,
TRUE = 1,
FALSE = 0,
SUCCESS = 0,
ERROR = 1,
IDUNNO = 2;
! Stopping Macro
MACRO
DIE =
WHILE TRUE DO
BEGIN
BUILTIN JSYS;
JSYS(-1,HALTF_);
END %;
! Macros for TTY IO
MACRO TTY_GET_LINE(BUFFER,LENGTH) =
BEGIN
LOCAL END_PTR;
BEGIN
BUILTIN JSYS;
REGISTER AC1=1,AC2=2,AC3=3,AC4=4;
AC1 = $PRIIN;
AC2 = CH$PTR(BUFFER);
AC3 = LENGTH;
AC4 = %O'12';
JSYS(-1,SIN_,AC1,AC2,AC3,AC4);
END_PTR = .AC2;
END;
(CH$DIFF(.END_PTR,CH$PTR(BUFFER)) - 2)
END % ;
MACRO TTY_GET_CHAR =
BEGIN
BUILTIN JSYS;
REGISTER AC1=1;
JSYS(-1,PBIN_,AC1);
.AC1
END %;
MACRO TTY_PUT_CRLF =
BEGIN
BUILTIN JSYS;
REGISTER AC1=1;
AC1 = %O'15';
JSYS(-1,PBOUT_,AC1);
AC1 = %O'12';
JSYS(-1,PBOUT_,AC1);
END % ;
MACRO TTY_PUT_MSG (BUFFER,LENGTH) =
IF LENGTH NEQ 0 THEN
BEGIN
BUILTIN JSYS;
REGISTER AC1=1,AC2=2,AC3=3;
AC1 = $PRIOU;
AC2 = CH$PTR(BUFFER);
AC3 = - LENGTH;
JSYS(-1,SOUT_,AC1,AC2,AC3);
END % ;
! Local Storage
OWN
! Random fields and lengths for communicating with user
A_FIELD : BLOCK [CH$ALLOCATION(FIELD_BUFFER_SIZE)],
A_LENGTH,
B_FIELD : BLOCK [CH$ALLOCATION(FIELD_BUFFER_SIZE)],
B_LENGTH,
! Another buffer for communicating with user.
TTY_BUFFER : BLOCK [CH$ALLOCATION(TEXT_BUFFER_SIZE)],
TTY_LENGTH,
DATA_LENGTH,
! Random success flag
SUCCEED;
FORWARD ROUTINE
ASCII_TO_BINARY, ! Changes ascii string to binary number
BINARY_TO_ASCII : NOVALUE, ! Changes binary number to ascii string
COMMAND : FORTRAN_FUNC NOVALUE, ! Sends command to Datatrieve
DISPLAY_RESULTS : NOVALUE, ! Prints the results on the TTY
FLOAT_TO_ASCII : NOVALUE, ! Changes floating point number to ascii string
FORM_COLLECTION : NOVALUE, ! Prompts user to form collection
GET_PORT : NOVALUE, ! Gets values which have been stored by DTR
INITIALIZE : NOVALUE, ! Sets up buffers and initializes Datatrieve
MESSAGE : NOVALUE, ! Shows a message from Datatrieve
PRINT_NUM : NOVALUE, ! Prints floating point to primary output
READY_DOMAIN : NOVALUE, ! Prompts the user and readies a domain
STORE_TOTALS : NOVALUE, ! Gets the totals of the independent fields
MAINPROG : NOVALUE; ! Main program loop
ROUTINE ASCII_TO_BINARY(ADDR,LEN) =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
! A S C I I _ T O _ B I N A R Y
!
! FUNCTIONAL DESCRIPTION
! Converts an ASCII string into an integer number
!
! FORMAL PARAMETERS
! Address of string
! Length of string
!
! RETURNED VALUE
! Numeric value of string
!
!------------------------------------------------------
BEGIN
LOCAL
PTR,
NEG,
BINNUM;
PTR = CH$PTR(.ADDR);
BINNUM = 0;
! Watch for negative sign
IF (CH$RCHAR(.PTR) EQL %C'-') THEN
BEGIN
NEG = TRUE;
PTR = CH$PLUS(.PTR,1);
END
ELSE
NEG = FALSE;
! Parse together the digits
INCR I FROM 1 TO .LEN DO
BINNUM = (.BINNUM * 10) + (CH$RCHAR_A(PTR) - %C'0');
IF (.NEG) THEN (- .BINNUM) ELSE (.BINNUM)
END; ! ascii_to_binary
ROUTINE BINARY_TO_ASCII(NUMB,APTR) : NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
! B I N A R Y _ T O _ A S C I I
!
! FUNCTIONAL DESCRIPTION
! Takes an integer number and writes it to the pointer.
! No worry is done about storage allocation here, this is
! the responsibility of the caller. The pointer is modified
! and advanced as characters are read.
!
! FORMAL PARAMETERS
! NUMB - A signed binary number
! APTR - Address of pointer to resultant string
!
! RETURNED VALUE
! None.
!
!------------------------------------------------------
BEGIN
LOCAL
POS, ! Positive or negative
DIGIT_COUNT, ! Number of digits done
DIGIT_VEC : VECTOR[40]; ! Local storage of digits
DIGIT_COUNT = 0;
POS = SIGN(.NUMB);
NUMB = ABS(.NUMB);
! Store away the digits in the vector
WHILE (.NUMB NEQ 0) DO
BEGIN
DIGIT_VEC[.DIGIT_COUNT] = (.NUMB MOD 10);
NUMB = (.NUMB / 10);
DIGIT_COUNT = .DIGIT_COUNT + 1;
END;
IF (.DIGIT_COUNT EQL 0) THEN
BEGIN
DIGIT_VEC[0] = 0;
DIGIT_COUNT = 1;
END;
! Parse them together in backwards order
IF (.POS EQL -1) THEN CH$WCHAR_A(%C'-',.APTR);
DECR I FROM (.DIGIT_COUNT - 1) TO 0 DO
CH$WCHAR_A(%C '0'+ .DIGIT_VEC[.I],.APTR);
END;
ROUTINE COMMAND (DISPLAY_CMD,DISPLAY_MSG,PATTERN,PATTERN_LENGTH)
: FORTRAN_FUNC NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
! C O M M A N D
!
! FUNCTIONAL DESCRIPTION
! If waiting at stall point then, the string is copied into
! value buffer and the command is sent to DATATRIEVE. This
! routine shows the usefulness of pattern strings. Pattern
! strings are imbedded commands in the text string which
! are substituted at run time by extra arguments. For example
! this routine accepts !A as a pattern string for which it
! substitutes a string. Two more arguments are needed, the
! address and length of the string.
!
! FORMAL PARAMETERS
! DISPLAY_CMD - if true then the command is echoed on the
! terminal
! DISPLAY_MSG - if true then any messages which the command
! causes are displayed upon the screen
! PATTERN - The pattern to be output on the screen
! PATTERN_LENGTH - Length in characters of the pattern
!
! IMPLICIT PARAMETERS
! The Datatrieve Access Buffer (DAB)
!
! RETURNED VALUE
! none
!------------------------------------------------------
BEGIN
BUILTIN
ACTUALCOUNT,
ACTUALPARAMETER;
LOCAL
CHAR, ! Character read
PAT_PTR, ! Pointer to pattern
RES_PTR, ! Pointer to resulting string
ARG_NUM; ! Number of arguments
PAT_PTR = CH$PTR(.PATTERN);
RES_PTR = CH$PTR(VALUE_BUFFER);
ARG_NUM = 4;
! First match the command string pattern and fill in any
! fields started with exclamation points.
! When the ! is encountered then arguments from the end of the routine
! are substituted in. The types of comment are:
! !A - Address and length of string
! !F - Floating point number
! !I - Integer number
INCR CHARNUM FROM 1 TO .PATTERN_LENGTH DO BEGIN
CHAR = CH$RCHAR_A(PAT_PTR);
IF (.CHAR NEQ %C'!')
THEN CH$WCHAR_A(.CHAR,RES_PTR)
ELSE BEGIN
CHAR = CH$RCHAR_A(PAT_PTR);
CHARNUM = .CHARNUM + 1;
SELECTONE .CHAR OF SET
[%C'A'] : BEGIN
ARG_NUM = .ARG_NUM + 2;
RES_PTR = CH$MOVE(ACTUALPARAMETER(.ARG_NUM),
CH$PTR(ACTUALPARAMETER(.ARG_NUM - 1)),
.RES_PTR);
END;
[%C'I'] : BEGIN
ARG_NUM = .ARG_NUM + 1;
BINARY_TO_ASCII(ACTUALPARAMETER(.ARG_NUM),RES_PTR);
END;
[%C'F'] : BEGIN
ARG_NUM = .ARG_NUM + 1;
FLOAT_TO_ASCII(ACTUALPARAMETER(.ARG_NUM),RES_PTR);
END;
TES;
IF (.ARG_NUM GTR ACTUALCOUNT()) THEN BEGIN
TTY_PUT_MSG(UPLIT('Too many pattern spaces for arguments'),37);
DIE;
END;
END;
END;
! Now set up the command field and call Datatrieve
DAB[DAB$W_VAL_LEN] = CH$DIFF(.RES_PTR,CH$PTR(VALUE_BUFFER));
IF .DAB[DAB$W_STATE] EQL DTR$K_STL_CMD THEN
BEGIN
IF (.DISPLAY_CMD) THEN
BEGIN
TTY_PUT_MSG(VALUE_BUFFER,.DAB[DAB$W_VAL_LEN]);
TTY_PUT_CRLF;
END;
DTR$COMMAND(DAB);
END;
! Show the results
MESSAGE(.DISPLAY_MSG);
END;
ROUTINE DISPLAY_RESULTS (A_VAL,A_NAME,A_NAME_LEN,
B_VAL,B_NAME,B_NAME_LEN) : NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
! D I S P L A Y _ R E S U L T S
!
! FUNCTIONAL DESCRIPTION
! This routine prints the relationship in the form
! B = AX + C
! using numbers which have been passed. It then pauses
! to ask the user if they would like the relation displayed
!
! FORMAL PARAMETERS
! A_VAL - Value of a field
! A_NAME - Address of name field
! A_NAME_LEN - Length of the name field
! B_VAL - Value of a field
! B_NAME - Address of name field
! B_NAME_LEN - Length of the name field
!
! RETURNED VALUE
! None
!
!---------------------------------------------------
BEGIN
LOCAL
CHAR;
TTY_PUT_MSG(UPLIT('Best estimate for linear relationship is:'),41);
TTY_PUT_CRLF;
TTY_PUT_MSG(.B_NAME,.B_NAME_LEN);
TTY_PUT_MSG(UPLIT(' = '),3);
PRINT_NUM(.A_VAL);
TTY_PUT_MSG(UPLIT(' + '),3);
TTY_PUT_MSG(.A_NAME,.A_NAME_LEN);
TTY_PUT_MSG(UPLIT(' * '),3);
PRINT_NUM(.B_VAL);
TTY_PUT_CRLF;
TTY_PUT_MSG(UPLIT('Enter Y if you wish to see relation: '),38);
DO
CHAR = TTY_GET_CHAR
UNTIL ((.CHAR EQL %C'Y') OR (.CHAR EQL %C'y') OR
(.CHAR EQL %C'N') OR (.CHAR EQL %C'n'));
TTY_PUT_CRLF;
IF ((.CHAR EQL %C'Y') OR (.CHAR EQL %C'y')) THEN
COMMAND(FALSE,TRUE,
UPLIT('FOR CURRENT PRINT !A, !A, !F + !F * !A ("ESTIMATE");'),
52,.A_NAME,.A_NAME_LEN,.B_NAME,.B_NAME_LEN,
.A_VAL,.B_VAL,.A_NAME,.A_NAME_LEN);
END;
ROUTINE FLOAT_TO_ASCII(NUM,APTR) : NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
! F L O A T _ T O _ A S C I I
!
! FUNCTIONAL DESCRIPTION
! Converts the passed floating point number to an ASCIZ
! string and changes the pointer to reflect the change.
! The characters are written to APTR and it is the
! responsibility of the caller to insure storage.
!
! FORMAL PARAMETERS
! NUM - Floating point number
! APTR - Address of pointer
!
! RETURNED VALUE
! None
!
!------------------------------------------------------
BEGIN
BUILTIN JSYS;
REGISTER AC1=1,AC2=2,AC3=3;
AC1 = ..APTR;
AC2 = .NUM;
AC3 = 0;
JSYS(1,FLOUT_,AC1,AC2,AC3);
.APTR = .AC1;
END;
ROUTINE FORM_COLLECTION : NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
! F O R M _ C O L L E C T I O N
!
! FUNCTIONAL DESCRIPTION
! Prompts the user for a Datatrieve command
! which forms a collection, and then passes
! the command to Datatrieve
!
! FORMAL PARAMETERS
! None
!
! RETURNED VALUE
! None
!------------------------------------------------------
BEGIN
LOCAL
FIRST;
! We only wish to print the header the first time
FIRST = TRUE;
DO BEGIN
IF .FIRST THEN
TTY_PUT_MSG(UPLIT('Please enter a command to form a collection'),43);
TTY_PUT_CRLF;
TTY_LENGTH = TTY_GET_LINE(TTY_BUFFER,TEXT_BUFFER_SIZE);
COMMAND(FALSE,FALSE,TTY_BUFFER,.TTY_LENGTH);
FIRST = FALSE;
END UNTIL (.SUCCEED EQL SUCCESS);
END;
ROUTINE GET_PORT(ADDR,DISPLAY_MSG) : NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
! G E T _ P O R T
!
! FUNCTIONAL DESCRIPTION
! If program is stopped at a get port stallpoint then
! the record is fetched and the ADDR and LEN point to
! the record
!
! FORMAL PARAMETERS
! ADDR - The address in which to store the record
! DISPLAY_MSG - If true then any messages pending are
! displayed
!
! RETURNED VALUE
! none
!------------------------------------------------------
BEGIN
IF (.DAB[DAB$W_STATE] EQL DTR$K_STL_PGET) THEN BEGIN
DATA_LENGTH = .DAB[DAB$W_REC_LEN];
DAB[DAB$A_REC_BUF] = .ADDR;
IF NOT DTR$GET_PORT(DAB) THEN
BEGIN
TTY_PUT_MSG(UPLIT('Failed to get record from Datatrieve'),36);
DIE;
END;
END;
MESSAGE(.DISPLAY_MSG);
END;
ROUTINE INITIALIZE : NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
! I N I T I A L I Z E
!
! FUNCTIONAL DESCRIPTION
! Sets up the Datatrieve Access Buffer (DAB) by
! storing the values of the local buffers in the
! DAB
!
! FORMAL PARAMETERS
! None
!
! IMPLICIT PARAMETERS
! The Datatrieve Access Buffer (DAB)
!
! RETURNED VALUE
! None
!------------------------------------------------------
BEGIN
! Don't want output to the TTY
DAB[DAB$V_FAST] = FALSE;
IF NOT(DTR$INIT(DAB)) THEN
BEGIN
TTY_PUT_MSG(UPLIT('Failed to initialize Datatrieve'),31);
DIE;
END;
END; ! Initialize
ROUTINE MESSAGE (DISPLAY_MSG) : NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
! M E S S A G E
!
! FUNCTIONAL DESCRIPTION
! Stops at message stall_point and displays on the screen
! any messages
!
! FORMAL PARAMETERS
! DISPLAY_MSG - If true then messages are displayed on the
! screen, otherwise the stallpoints are just received
!
! IMPLICIT PARAMETERS
! The global word succeed is set to
! SUCCESS if a DTR$_SUCCESS message is received
! ERROR if a DTR$_ERROR message is received
! IDUNNO if neither is received
!
! RETURNED VALUE
! none
!
!------------------------------------------------------
BEGIN
SUCCEED = IDUNNO;
WHILE (.DAB[DAB$W_STATE] EQL DTR$K_STL_LINE) DO
IF .DISPLAY_MSG THEN BEGIN
TTY_PUT_MSG(MESSAGE_BUFFER,.DAB[DAB$W_MSG_LEN]);
TTY_PUT_CRLF;
DTR$CONTINUE(DAB);
END;
WHILE (.DAB[DAB$W_STATE] EQL DTR$K_STL_MSG) DO BEGIN
SELECTONE .DAB[DAB$L_CONDITION] OF SET
[DTR$_SUCCESS] : SUCCEED = SUCCESS;
[DTR$_ERROR] : SUCCEED = ERROR;
[OTHERWISE] :
IF .DISPLAY_MSG THEN BEGIN
TTY_PUT_MSG(MESSAGE_BUFFER,.DAB[DAB$W_MSG_LEN]);
TTY_PUT_CRLF;
END;
TES;
DTR$CONTINUE(DAB);
END;
END;
ROUTINE PRINT_NUM(NUM) : NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
! P R I N T _ N U M
!
! FUNCTIONAL DESCRIPTION
! Prints a floating point number to primary output
!
! FORMAL PARAMETERS
! NUM - Single precision floating point number
!
! RETURNED VALUE
! None
!
!------------------------------------------------------
BEGIN
BUILTIN JSYS;
REGISTER AC1=1,AC2=2,AC3=3;
AC1 = $PRIOU;
AC2 = .NUM;
AC3 = 0;
JSYS(1,FLOUT_,AC1,AC2,AC3);
END;
ROUTINE READY_DOMAIN : NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
! R E A D Y _ D O M A I N
!
! FUNCTIONAL DESCRIPTION
! Gets a domain name from the user, and readies the
! domain. If the domain is not readyable then show
! the domains.
!
! FORMAL PARAMETERS
! None
!
! RETURNED VALUE
!
!------------------------------------------------------
BEGIN
LOCAL
WORKS,
BUFFER_PTR;
DO BEGIN
TTY_PUT_MSG(UPLIT('Please enter the domain name: '),30);
TTY_LENGTH = TTY_GET_LINE(TTY_BUFFER,TEXT_BUFFER_SIZE);
COMMAND(FALSE,FALSE,UPLIT('READY !A'),8,TTY_BUFFER,.TTY_LENGTH);
WORKS = .SUCCEED;
IF (.WORKS NEQ SUCCESS) THEN
COMMAND(FALSE,TRUE,UPLIT('SHOW DOMAINS'),12);
END UNTIL (.WORKS EQL SUCCESS);
END; ! Ready_domain
ROUTINE STORE_TOTALS(WHOLE) : NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
! S T O R E _ T O T A L S
!
! FUNCTIONAL DESCRIPTION
! Gets and stores the name of the independent and dependent
! fields. Then passes a datatrieve command to get the total
! of each of the fields. If an error is found getting the
! fields then it is displayed
!
! FORMAL PARAMETERS
! None
!
! IMPLICIT PARAMETERS
! A_FIELD,A_LENGTH - These buffers are set to reflect the
! independent field.
! B_FIELD,B_LENGTH - These buffers are set to reflect the
! dependent field.
!
! RETURNED VALUE
!
!------------------------------------------------------
BEGIN
LOCAL
WORKS,
BUFFER_PTR;
DO BEGIN
COMMAND(FALSE,FALSE,UPLIT('STORE PT2 USING BEGIN'),21);
! First get the field names
TTY_PUT_MSG(UPLIT('Please enter the name of the independent field: '),48);
A_LENGTH = TTY_GET_LINE(A_FIELD,FIELD_BUFFER_SIZE);
TTY_PUT_MSG(UPLIT('Please enter the name of the dependent field: '),46);
B_LENGTH = TTY_GET_LINE(B_FIELD,FIELD_BUFFER_SIZE);
! Pass the command and get the port values
COMMAND(FALSE,FALSE,UPLIT('PART-A = TOTAL !A; PART-B = TOTAL !A ;END;'),41,
A_FIELD,.A_LENGTH,B_FIELD,.B_LENGTH);
GET_PORT(.WHOLE,FALSE);
WORKS = .SUCCEED;
IF (.WORKS NEQ SUCCESS) THEN
COMMAND(FALSE,TRUE,UPLIT('SHOW FIELDS'),11);
END UNTIL (.WORKS EQL SUCCESS);
END;
GLOBAL ROUTINE MAINPROG : NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
! M A I N P R O G
!
! FUNCTIONAL DESCRIPTION
! Main loop
!
! FORMAL PARAMETERS
! None.
!
! RETURNED VALUE
! NONE.
!
!------------------------------------------------------
BEGIN
LOCAL
A,
B,
BUFFER_PTR,
COUNTER,
WHOLE : VECTOR [2],
AVERAGE : VECTOR [2],
TEMP1,
SUM,
SOS,
CHAR;
BUILTIN ADDF,MULF,SUBF,DIVF,CVTFI,CVTIF;
DY$MIN();
INITIALIZE();
! Set up the ports for communication
COMMAND(FALSE,FALSE,UPLIT('DECLARE PORT PT1 01 NZ PIC 9(5).;'),33);
COMMAND(FALSE,FALSE,UPLIT('DECLARE PORT PT2 01 WHOLE. '),27);
COMMAND(FALSE,FALSE,UPLIT('02 PART-A REAL. 02 PART-B REAL. ;'),33);
DO BEGIN
! Level 1
! At this level of linear regression the user is prompted for a
! domain name. The given domain is readied and control passes to
! the inner loops
READY_DOMAIN();
DO BEGIN
! Level 2
! At this level of linear regression, the user is prompted for
! a command to form a collection. Then control passes to the
! inner loop
FORM_COLLECTION();
DO BEGIN
! Level 3
! At this level of linear regression the user is prompted for
! the field names they wish to use. Then a linear regression
! is done with the given fields
! Store the totals and initialize
COMMAND(FALSE,FALSE,UPLIT('STORE PT1 USING NZ = COUNT;'),27);
GET_PORT(COUNTER,FALSE);
COUNTER = ASCII_TO_BINARY(COUNTER,.DATA_LENGTH);
CVTIF(COUNTER,COUNTER);
STORE_TOTALS(WHOLE);
SUM = %E'0';
SOS = %E'0';
DIVF(COUNTER,WHOLE[0],AVERAGE[0]);
DIVF(COUNTER,WHOLE[1],AVERAGE[1]);
BEGIN
COMMAND(FALSE,FALSE,UPLIT('FOR CURRENT STORE PT2 USING BEGIN'),33);
COMMAND(FALSE,FALSE,UPLIT('PART-A = !A; PART-B = !A; END;'),30,
A_FIELD,.A_LENGTH,B_FIELD,.B_LENGTH);
END;
WHILE (.DAB[DAB$W_STATE] EQL DTR$K_STL_PGET) DO BEGIN
! Loop through and get the values, and calculate
GET_PORT(WHOLE,FALSE);
SUBF(AVERAGE[0],WHOLE[0],TEMP1);
MULF(TEMP1,WHOLE[1],TEMP1);
ADDF(SUM,TEMP1,SUM);
SUBF(AVERAGE[0],WHOLE[0],TEMP1);
MULF(TEMP1,TEMP1,TEMP1);
ADDF(SOS,TEMP1,SOS);
END;
MESSAGE(FALSE);
DIVF(SOS,SUM,B);
MULF(B,AVERAGE[0],TEMP1);
SUBF(TEMP1,AVERAGE[1],A);
DISPLAY_RESULTS(.A,A_FIELD,.A_LENGTH,.B,B_FIELD,.B_LENGTH);
TTY_PUT_MSG(UPLIT('Do you want to try different fields? '),37);
DO
CHAR = TTY_GET_CHAR
UNTIL ((.CHAR EQL %C'Y') OR (.CHAR EQL %C'y') OR
(.CHAR EQL %C'N') OR (.CHAR EQL %C'n'));
TTY_PUT_CRLF;
END UNTIL ((.CHAR EQL %C'N') OR (.CHAR EQL %C'n')); ! Level 3
TTY_PUT_MSG(UPLIT('Do you want to try a different collection? '),43);
DO
CHAR = TTY_GET_CHAR
UNTIL ((.CHAR EQL %C'Y') OR (.CHAR EQL %C'y') OR
(.CHAR EQL %C'N') OR (.CHAR EQL %C'n'));
TTY_PUT_CRLF;
END UNTIL ((.CHAR EQL %C'N') OR (.CHAR EQL %C'n')); ! Level 2
TTY_PUT_MSG(UPLIT('Do you want to start over with a new domain? '),45);
DO
CHAR = TTY_GET_CHAR
UNTIL ((.CHAR EQL %C'Y') OR (.CHAR EQL %C'y') OR
(.CHAR EQL %C'N') OR (.CHAR EQL %C'n'));
TTY_PUT_CRLF;
END UNTIL ((.CHAR EQL %C'N') OR (.CHAR EQL %C'n')); ! Level 1
DTR$FINISH(DAB);
END;
END
ELUDOM