home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / educ / pstat2.zip / CFIT12.PQS / cfit12.pas
Pascal/Delphi Source File  |  1986-12-17  |  53KB  |  1,496 lines
  1. Program CFit12 ;
  2.  
  3. Const
  4.    Cpyrtnotice = '(C) 1986 Joseph C. Hudson 4198 Warbler Dr. Flint MI 48504' ;
  5.    MaxNumObs = 250 ;
  6.    MaxNumMissing = 10 ;
  7.    NumRegr = 196 ;
  8.    NumForms = 7 ;
  9.    TurboType = 88 ;
  10.  
  11. Type
  12.    Info = Array [ 1..3 ] of Real ;
  13.    Regression = Record
  14.                 YIndex, X1Index, X2Index,
  15.                 ResidualDF, NextR, NextF : Integer ;
  16.                 A, B1, B2, SEE, SST, D, C11, C12, C22,
  17.                 RSq, RBarSq, FRatio : Real ;
  18.                 End ;
  19.    DataVector = Array [ 1 .. MaxNumObs ] of Real ;
  20.  
  21.  
  22. Var
  23.    FormFeed, ResetLineFeed, SetLineFeed, ResetPrinter,
  24.    SetCondensed, SetOneWay : String [ 4 ] ;
  25.    DataFileName : String[ 80 ] ;
  26.    OutFileName : String[ 80 ] ;
  27.    DataFile,HdrOutFile : Text ;
  28.    X, Y, YHat, Residual, StdDevResid : DataVector ;
  29.    NumRow, Base, NumRegRun, NumMissingX, NumMissingY,
  30.    NumMissing, BestF, BestR, WorstF, WorstR, LastReg, J1,
  31.    XCol, YCol, RegToPrint, LinesLeft : Integer ;
  32.    Rank : Array [ 1..NumRegr ] of Info ;
  33.    RegOutFile : File of Regression ;
  34.    RegOut : Array [ 1..NumRegr ] Of Regression ;
  35.    Reg : Regression ;
  36.    Answer : Char ;
  37.    DataNotSaved, NoReg : Boolean ;
  38.    OKToRunY : Array [ 1 .. NumForms ] of Boolean ;
  39.    OKToRunX : Array [ 0 .. NumForms ] of Boolean ;
  40.    MissingX : Array [ 1 .. MaxNumMissing ] of Real ;
  41.    MissingY : Array [ 1 .. MaxNumMissing ] of Real ;
  42.    XBar, YBarr : Array [ 0 .. NumForms ] of Real ;
  43.    Max, Min,
  44.    XInc, YInc,
  45.    XMax, YMax, XMin, YMin,
  46.    YBar, X1Bar, X2Bar : Real ;
  47.  
  48. Function  F ( i : Integer ; Z : Real ) : Real ;
  49. Begin
  50.    Case i Of
  51.       0 : F := 0.0 ;
  52.       1 : F := Z ;
  53.       2 : F := Z * Z ;
  54.       3 : F := 1.0 / Z ;
  55.       4 : F := 1.0 / ( Z * Z ) ;
  56.       5 : F := Ln ( Z ) ;
  57.       6 : F := Z * Ln ( Z ) ;
  58.       7 : F := ( Ln ( Z ) ) / Z ;
  59.    End ;
  60. End ;
  61.  
  62. Procedure SetPrintVars ;
  63.  
  64. { The codes given here work for Star Delta, Epson RX-80, FX-80 etc }
  65.    Begin
  66.    ResetPrinter  := Chr(27) + '@'           ;
  67.    FormFeed      := Chr(12)                 ;
  68.    ResetLineFeed := Chr(27) + 'A' + Chr(12) ;     { Set LF to 12/72 in.   }
  69.    SetLineFeed   := Chr(27) + 'A' + Chr(6)  ;     { Set LF to  6/72 in.   }
  70.    SetCondensed  := Chr(15)                 ;     { Set to 17 chars/in.   }
  71.    SetOneWay     := Chr(27) + 'U' + Chr(1)  ;     { Set unidirectional    }
  72.    End ; { SetPrintVars }
  73.  
  74. Procedure NewPage ;
  75. Begin
  76.    Write(Lst,FormFeed) ; Writeln(Lst) ; Writeln(Lst) ;
  77.    LinesLeft := 60 ;
  78. End ; { NewPage }
  79.  
  80. Procedure CheckConstraints ( I : Integer ) ;
  81. Var J : Integer ;
  82. Begin
  83.    If X[I] = 0.0 Then
  84.       Begin
  85.       OKToRunX[3] := False ;
  86.       OKToRunX[4] := False ;
  87.       End ;
  88.    If X[I] <= 0.0 Then
  89.       Begin
  90.       OKToRunX[5] := False ;
  91.       OKToRunX[6] := False ;
  92.       OKToRunX[7] := False ;
  93.       End ;
  94.    If Y[I] <= 0.0 Then For J := 2 To 5 Do OKToRunY[J] := False ;
  95.    If Y[I] < Exp(-1.0) Then OKToRunY[6] := False ;
  96.    If Y[I] < Exp(1.0) Then OKToRunY[7] := False ;
  97. End ; { CheckConstraints }
  98.  
  99. Procedure GetOutFile ( StartRow : Integer ) ;
  100. Begin
  101.    Repeat
  102.       GoToXY(1,StartRow) ;
  103.       Writeln(Con,'Type a name for the output files, without an extension. ') ;
  104.       Writeln(Con) ;
  105.       Write(Con,'You may include a path and must include a name, e.g.') ;
  106.       Writeln(Con,' A:\DATA\OUTFILE, ') ;
  107.       Writeln(Con,'where DATA is a subdirectory and OUTFILE is a file name.');
  108.       Writeln(Con,'Do not include a "dot" or a 3 letter extension.') ;
  109.       Writeln(Con) ;
  110.       {$I-} Readln(Con,OutFileName) {$I+} ; Writeln(Con) ;
  111.       Until ( ( ( IOResult = 0 ) And ( Pos('.',OutFileName) = 0 ) )
  112.          And ( ( Pos(':',OutFileName) = 2 )
  113.          Or ((Pos(':',OutFileName)=0)And(Length(OutFileName)<80)) ) ) ;
  114.    Assign ( RegOutFile, OutFileName + '.REG' ) ;
  115.    Assign ( HdrOutFile, OutFileName + '.HDR' ) ;
  116. End ; { GetOutFile }
  117.  
  118. Procedure GetStarted ;
  119. Var
  120.    MaxCol, I, J, K, L, Code : Integer ;
  121.    Dummy : Real ;
  122.    Missing : String [ 20 ] ;
  123.    DataLine : String [ 255 ] ;
  124.    XorYMissing , DataOnLine : Boolean ;
  125. Begin
  126.    ClrScr ; GoTOXY(1,2) ;
  127.    Write(Con,'What is the name of the data file? ') ;
  128.    Readln(Con,DataFileName) ; Writeln(Con) ;
  129.    Assign ( DataFile , DataFileName ) ;
  130.    {$I-} Reset ( DataFile ) {$I+} ;
  131.    If IOResult <> 0 Then NoReg := True ;
  132.    If NoReg = False Then
  133.    Begin
  134.       MaxCol := 0 ; NumRow := 0 ;
  135.       Repeat
  136.          {$I-} Read(DataFile,Dummy) {$I+} ;
  137.          MaxCol := MaxCol + 1 ;
  138.          Dummy := IOResult ;
  139.       Until Eoln(DataFile) ;
  140.       NumRow := 1 ;
  141.       Repeat
  142.          DataLine := '' ;
  143.          Readln(DataFile,DataLine) ;
  144.          J := 47 ;
  145.          Repeat
  146.             J := J + 1 ;
  147.          Until ( (Pos(Chr(J),Dataline) > 0 ) Or (J = 58)) ;
  148.          If J < 58 Then NumRow := NumRow + 1 ;
  149.       Until Eof(DataFile) ;
  150.       Reset(DataFile) ;
  151.       GoToXY(1,4) ;
  152.       Write(Con,'There are ',NumRow,' rows and ',MaxCol) ;
  153.       Writeln(Con,' columns of data.') ;
  154.       Repeat
  155.          GoToXY(1,6) ;
  156.          Write(Con,'Which column contains X? ') ;
  157.          {$I-} Readln(Con,XCol) {$I+} ;
  158.       Until ( (IOResult = 0) And ((XCol > 0) And (XCol <= MaxCol))) ;
  159.       Repeat
  160.          GoToXY(1,8) ;
  161.          Write(Con,'Which column contains Y? ') ;
  162.          {$I-} Readln(Con,YCol) {$I+} ;
  163.       Until (((IOResult=0)And(YCol<>XCol))And((Ycol>0)And(YCol<=MaxCol))) ;
  164.       Writeln(Con) ;
  165.       If XCol < YCol Then MaxCol := YCol Else MaxCol := XCol ;
  166.       For I := 1 To NumForms Do OKToRunY[I] := True ;
  167.       For I := 0 To NumForms Do OKToRunX[I] := True ;
  168.       Repeat
  169.          GoToxy(1,10) ;
  170.          Write(Con,'Do you want to omit any X or Y values ? ') ;
  171.          {$I-} Readln(Con,Answer) {$I+} ;
  172.          Answer := UpCase ( Answer ) ;
  173.       Until ( ( IOResult = 0 ) And ( Answer In [ 'Y' , 'N' ] ) ) ;
  174.       NumMissing := 0 ; NumMissingX := 0 ; NumMissingY := 0 ;
  175.       If Answer = 'Y' Then
  176.          Begin
  177.          GoToXY(1,12) ;
  178.          Write(Con,'You may specify up to ',MaxNumMissing,' values to be') ;
  179.          Writeln(Con,' omitted for X and for Y.') ; Writeln(Con) ;
  180.          Write(Con,'If you enter fewer than ',MaxNumMissing,' values') ;
  181.          Writeln(Con,' for X or Y, hit Enter with no value') ;
  182.          Writeln(Con,'to terminate entry.');
  183.          Repeat
  184.             Repeat
  185.                GoToXY(1,18) ;
  186.                Write(Con,'Enter value number ',NumMissingX+1,' for X : ') ;
  187.                Write(Con,' ':20) ; GoToXY(33,18) ;
  188.                {$I-} Readln(Con,Missing) {$I+} ;
  189.                Val ( Missing , MissingX [ NumMissingX + 1 ] , Code ) ;
  190.             Until (( IOResult = 0 ) And ( ( Code = 0 ) Or ( Missing = '') )) ;
  191.             If Missing <> '' Then NumMissingX := NumMissingX + 1 ;
  192.          Until ( (NumMissingX = MaxNumMissing ) Or ( Missing = '') ) ;
  193.          Repeat
  194.             Repeat
  195.                GoToXY(1,20) ;
  196.                Write(Con,'Enter value number ',NumMissingY+1,' for Y : ') ;
  197.                Write(Con,' ':20) ; GoToXY(33,20) ;
  198.                {$I-} Readln(Con,Missing) {$I+} ;
  199.                Val ( Missing , MissingY [ NumMissingY + 1 ] , Code ) ;
  200.             Until (( IOResult = 0 ) And ( ( Code = 0 ) Or ( Missing = '') )) ;
  201.             If Missing <> '' Then NumMissingY := NumMissingY + 1 ;
  202.          Until ( (NumMissingY = MaxNumMissing ) Or ( Missing = '') ) ;
  203.          End ; { If Answer = 'Y' }
  204.       K := 1 ;
  205.       For I := 1 to NumRow Do
  206.          Begin
  207.          For J := 1 to MaxCol Do
  208.             Begin
  209.             If J = XCol Then Read(DataFile,X[K])
  210.                Else If J = YCol Then Read(DataFile,Y[K])
  211.                Else Begin
  212.                   {$I-} Read(DataFile,Dummy) {$I+} ;
  213.                   Dummy := IOResult ;
  214.                   End ; {Else}
  215.             End ; { For J }
  216.          Readln(DataFile) ;
  217.          XorYMissing := False ;
  218.          If NumMissingX > 0 Then
  219.             For L := 1 To NumMissingX Do
  220.                If X[K] = MissingX[L] Then XorYMissing := True ;
  221.          If ( ( NumMissingY > 0 ) And ( Not XorYMissing ) )Then
  222.             For L := 1 To NumMissingY Do
  223.                If Y[K] = MissingY[L] Then XorYMissing := True ;
  224.          If (Answer = 'N') Or ( Not XorYMissing ) Then Begin
  225.             CheckConstraints(K) ;
  226.             K := K + 1 ;
  227.             End
  228.          Else NumMissing := NumMissing + 1 ;
  229.          End ; { For I }
  230.       Close ( DataFile ) ;
  231.       If Answer = 'Y' Then NumRow := NumRow - NumMissing ;
  232.    End { If NoReg = False }
  233.    Else
  234.    Begin
  235.       Writeln(Con) ; Writeln(Con,'This file is not available.') ;
  236.       Writeln(Con) ; Writeln(Con,'Press any key to continue.') ;
  237.       Repeat Until KeyPressed ;
  238.    End ; { Else }
  239.    If NumRow < 4 Then
  240.    Begin
  241.       Writeln(Con) ;
  242.       Writeln(Con,'There are ',NumRow,' rows of data, too few to proceed.') ;
  243.       Writeln(Con) ;
  244.       Writeln(Con,'Press any key to continue.') ;
  245.       NoReg := True ;
  246.       Repeat Until KeyPressed ;
  247.    End ; { If }
  248. End ; { GetStarted }
  249.  
  250. Procedure Regress ;
  251. Var
  252.    I, J, K : Integer ;
  253.    SumY, SumYSq, DTemp,
  254.    SSR, SSE, MSR, MSE, MST : Real ;
  255.    SumX, SumXY : Array [ 0 .. NumForms ] Of Real ;
  256.    SumXX : Array [ 0 .. NumForms , 0 .. NumForms ] Of Real ;
  257. Begin
  258.    For I := 0 To NumForms Do SumX [ I ] := 0.0 ;
  259.    For I := 0 To NumForms Do XBar [ I ] := 0.0 ;
  260.    SumXY := SumX ;
  261.    For I := 0 To NumForms Do SumXX [ 0 , I ] := 0.0 ;
  262.    For I := 1 To NumForms Do SumXX [ I ] := SumXX [ 0 ] ;
  263.    SumXX [ 0 , 0 ] := 1.0 ;
  264.    For I := 1 To NumForms Do
  265.    Begin
  266.       If OKToRunX[I] Then
  267.       Begin
  268.          For J := 1 To NumRow Do
  269.             SumX[I] := SumX[I] + F ( I , X[J] ) ;
  270.          XBar[I] := SumX[I] / NumRow ;
  271.          For J := 1 To I Do
  272.          If OKToRunX[J] Then
  273.          Begin
  274.             For K := 1 to NumRow Do
  275.                SumXX[I,J]:=SumXX[I,J]+(F(I,X[K])-XBar[I])*(F(J,X[K])-XBar[J]);
  276.             If I <> J Then SumXX[J,I] := SumXX[I,J] ;
  277.          End ;
  278.       End ; { If }
  279.    End ; { For }
  280.    NumRegRun := 0 ;
  281.    For I := 1 To NumForms  Do
  282.    Begin
  283.       If OKToRunY[I] Then
  284.       Begin
  285.       SumY := 0.0 ; SumYSq := 0.0 ;
  286.       For J := 1 To NumForms Do SumXY[J] := 0.0 ;
  287.       For J := 1 to NumRow Do SumY := SumY + F(I,Y[J]) ;
  288.       YBar := SumY / NumRow ;
  289.       YBarr[I] := YBar ;
  290.       For J := 1 To NumForms Do
  291.          If OKToRunX[J] Then
  292.             For K := 1 To NumRow Do
  293.                SumXY[J] := SumXY[J] + (F(J,X[K])-XBar[J])*(F(I,Y[K])-YBar) ;
  294.       For K := 1 To NumRow Do SumYSq := SumYSq + Sqr(F(I,Y[K])-YBar) ;
  295.       For J := 1 to NumForms Do
  296.          Begin
  297.          If OKToRunX[J] Then
  298.          Begin
  299.          For K := 0 to J - 1 Do
  300.             Begin
  301.             If OKToRunX[K] Then
  302.             Begin
  303.             DTemp := SumXX[J,J] * SumXX[K,K] - Sqr(SumXX[J,K]) ;
  304.             If Abs(DTemp) > 1E-10 Then
  305.             Begin
  306.             With Reg Do
  307.             Begin
  308.             YIndex := I ; X1Index := J ; X2Index := K ;
  309.             D := Dtemp ; C11 := SumXX[K,K] / D ;
  310.             C12 := - SumXX[J,K] / D ; C22 := SumXX[J,J] / D ;
  311.             If K = 0 Then ResidualDF := NumRow - 2
  312.                      Else ResidualDF := NumRow - 3 ;
  313.             B1 := (SumXX[K,K] * SumXY[J] - SumXX[J,K] * SumXY[K])/D ;
  314.             B2 := (SumXX[J,J] * SumXY[K] - SumXX[J,K] * SumXY[J])/D ;
  315.             A := YBar - XBar[J] * B1 - XBar[K] * B2 ;
  316.             SSR := SumXY[J] * B1 + SumXY[K] * B2 ;
  317.             SST := SumYSq ;
  318.             SSE := SST - SSR ;
  319.             RSq := ( SSR / SST ) * 100.0 ;
  320.             MSR := SSR / ( NumRow - ResidualDF - 1 ) ;
  321.             MSE := SSE / ResidualDF ;
  322.             MST := SST / ( NumRow - 1 ) ;
  323.             RBarSq := ( 1 - ( MSE / MST ) ) * 100.0 ;
  324.             FRatio := MSR / MSE ;
  325.             SEE := Sqrt(MSE) ;
  326.             NextR := -1 ;
  327.             NextF := -1 ;
  328.             NumRegRun := NumRegRun + 1 ;
  329.             RegOut[NumRegRun] := Reg ;
  330.             Rank [ NumRegRun , 1 ] := NumRegRun ;
  331.             Rank [ NumRegRun , 2 ] := Fratio ;
  332.             Rank [ NumRegRun , 3 ] := RBarSq ;
  333.             End ; { With Reg }
  334.             End ; { If Abs(D) }
  335.          End ; { If OKToRunX[K] }
  336.          End ; { For K }
  337.       End ; { If OKToRunX[J] }
  338.       End ; { For J }
  339.    End ; { If OKToRunY[I] }
  340.    End ; { For I }
  341.    End ; { Regress }
  342.  
  343. Procedure GetAverages ;
  344. Begin
  345.    YBar := YBarr[Reg.YIndex] ;
  346.    X1Bar := XBar[Reg.X1Index] ;
  347.    X2Bar := XBar[Reg.X2Index] ;
  348. End ; { GetAverages }
  349.  
  350. Procedure Exchange ( Var I1 , I2 : Info ) ;
  351. Var Temp : Info ;
  352. Begin
  353.    Temp := I1 ;
  354.    I1 := I2 ;
  355.    I2 := Temp ;
  356. End ; { Exchange }
  357.  
  358. Procedure Heap ( I , N : Integer ) ;
  359. Begin
  360.    While( 2 * I + 1 <= N ) And
  361.    ( ( Rank[I,J1] > Rank[2*I,J1] ) Or ( Rank[I,J1] > Rank[2*I+1,J1] ) ) Do
  362.    Begin
  363.       If Rank [ 2 * I , J1 ] < Rank [ 2 * I + 1 , J1 ] Then
  364.       Begin
  365.          Exchange ( Rank[I] , Rank[2*I] ) ;
  366.          I := 2 * I ;
  367.       End
  368.       Else
  369.       Begin
  370.          Exchange ( Rank[I] , Rank[2*I+1] ) ;
  371.          I := 2 * I + 1 ;
  372.       End
  373.    End ; { While }
  374.    If ( ( 2 * I = N ) And ( Rank[I,J1] > Rank[2*I,J1] ) )
  375.       Then Exchange ( Rank[I] , Rank[2*I] ) ;
  376. End ; { Heap }
  377.  
  378. Procedure Sort ;
  379. Var I , M : Integer ;
  380. Begin
  381.    I := Trunc ( ( NumRegRun / 2.0 ) + 0.1 ) ;
  382.    While I >= 1 Do
  383.       Begin
  384.       Heap ( I , NumRegRun ) ;
  385.       I := I - 1 ;
  386.       End ; { While }
  387.    M := NumRegRun ;
  388.    While M > 1 Do
  389.       Begin
  390.       Exchange ( Rank[1] , Rank[M] ) ;
  391.       M := M - 1 ;
  392.       Heap ( 1 , M ) ;
  393.       End ; { While }
  394. End ; { Sort }
  395.  
  396. Procedure AddInfo ;
  397. Var
  398.    I, K1, K2 : Integer ;
  399. Begin
  400.    For I := 1 To NumRegRun - 1 Do
  401.    Begin
  402.       K1 := Trunc( Rank[I,1]+0.1)  ;
  403.       K2 := Trunc( Rank[I+1,1]+0.1) ;
  404.       With RegOut[K1] Do If J1 = 2 Then NextF := K2 Else NextR := K2 ;
  405.    End ; { For }
  406.    If J1 = 2 Then K1 := WorstF Else K1 := WorstR ;
  407.    With RegOut[K1] Do If J1 = 2 Then NextF := - BestF Else NextR := - BestR ;
  408. End ; { AddInfo }
  409.  
  410. Procedure WriteReg(I:Integer) ;
  411.    Begin
  412.    With Reg Do
  413.       Begin
  414.       Write(Lst,' ':10,I:3,'  ',RegToPrint:4,'  ',YIndex,'  ',X1Index) ;
  415.       Write(Lst,'  ',X2Index,'  ',A:13,'  ',B1:13,'  ',B2:13);
  416.       Write(Lst,'  ',ResidualDF:4,'  ',FRatio:8:2) ;
  417.       Writeln(Lst,' ',RSq:8:2,'  ',RBarSq:8:2,'    ',SEE:13) ;
  418.    End ; { With Reg }
  419.    End ; { WriteReg }
  420.  
  421. Procedure DrawLine ;
  422. Var I : Integer ;
  423. Begin
  424.    Write(Lst,' ':10) ;
  425.    For I := 1 To 120 Do Write(Lst,'=') ; Writeln(Lst) ; Writeln(Lst) ;
  426. End ; { DrawLine }
  427.  
  428. Procedure WriteHeading ;
  429. Var I : Integer ;
  430. Begin
  431.    Writeln(Lst) ; If Answer <> 'R' Then DrawLine ;
  432.    Writeln(Lst,' ':15,'Regr',' ':55,'Residual',' ':21,'Adj') ;
  433.    Write(Lst,' ':10,' No.  No.  Y X1 X2','  ','A',' ':14,'B1',' ':13,'B2') ;
  434.    Writeln(Lst,' ':15,'DF',' ':6,'F       RSq       RSq      SEE') ;
  435. End ; { WriteHeading }
  436.  
  437. Procedure WriteHeader(ForR : Char) ;
  438. Var
  439.    Expression : String[40] ;
  440.    L : Integer ;
  441. Begin
  442.    If ForR = 'F' Then Expression := 'F Ratio.'
  443.                  Else Expression := 'Adjusted Coeficient of Determination.' ;
  444.    Writeln(Lst) ;
  445.    Write(Lst,' ':10,'Regression using data in ',DataFileName,'.') ;
  446.    Writeln(Lst,'  X is column ',XCol,' and Y is column ',YCol,'.' ) ;
  447.    Write(Lst,' ':10,'There are ',NumRow,' valid cases. ') ;
  448.    Write(Lst,NumMissing,' cases were omitted. ') ;
  449.    Writeln(Lst,NumRegRun,' regressions were run.') ;
  450.    If NumMissingX > 0 Then
  451.    Begin
  452.       Write(Lst,' ':10,'Omitted X values : ') ;
  453.       For L := 1 To NumMissingX Do Write(Lst,MissingX[L]:10:2,' ') ;
  454.       Writeln(Lst) ;
  455.    End ;
  456.    If NumMissingY > 0 Then
  457.    Begin
  458.       Write(Lst,' ':10,'Omitted Y values : ') ;
  459.       For L := 1 To NumMissingY Do Write(Lst,MissingY[L]:10:2,' ') ;
  460.       Writeln(Lst) ;
  461.    End ;
  462.    Write(Lst,' ':10,'The regressions are sorted by ',Expression) ;
  463.    If Not DataNotSaved Then
  464.       Writeln(Lst,' Output is stored in files ',OutfileName,'.')
  465.       Else Writeln(Lst) ;
  466. End ; { WriteHeader }
  467.  
  468. Procedure Report ;
  469. Var
  470.    I, Ans, LinesToPrint, ExtraLines : Integer ;
  471.    ForR : Char ;
  472. Begin
  473.    ClrScr ;
  474.    Repeat
  475.       Writeln(Con) ;
  476.       Write(Con,'Do you want the list sorted by F or by R? ');
  477.       Readln(Con,ForR) ; ForR := UpCase(ForR) ;
  478.    Until ForR in [ 'F' , 'R' ] ;
  479.    If ForR = 'F' Then RegToPrint := BestF Else RegToPrint := BestR ;
  480.    Repeat
  481.       GoToXY(1,4) ;
  482.       Writeln(Con) ;
  483.       Writeln(Con,NumRegRun,' regressions were run.') ; Writeln(Con) ;
  484.       Write(Con,'How many regressions do you want printed? ') ;
  485.       {$I-} Readln(Con,Ans) {$I+} ;
  486.    Until ( ( Ans In [ 1 .. NumRegRun ] ) And ( IOResult = 0 ) ) ;
  487.    LinesToPrint := 10 + Ans ; ExtraLines := 0 ;
  488.    If NumMissingX > 0 Then ExtraLines := ExtraLines + 1 ;
  489.    If NumMissingY > 0 Then ExtraLines := ExtraLines + 1 ;
  490.    LinesToPrint := LinesToPrint + ExtraLines ;
  491.    If ((LinesToPrint < 60) And (LinesToPrint > LinesLeft))
  492.       Or ((LinesLeft < 14) And (LinesToPrint > LinesLeft)) Then NewPage ;
  493.    DrawLine ; WriteHeader(ForR) ; WriteHeading ;
  494.    LinesLeft := LinesLeft - 9 - ExtraLines ;
  495.    For I := 1 To Ans Do
  496.    Begin
  497.       Reg := RegOut[RegToPrint] ;
  498.       With Reg Do
  499.       Begin
  500.          WriteReg(I) ;
  501.          LinesLeft := LinesLeft - 1 ; If LinesLeft < 1 Then NewPage ;
  502.          If ForR = 'F' Then RegToPrint := NextF Else RegToPrint := NextR ;
  503.       End ; { With Reg }
  504.    End ; { For }
  505.    If ForR = 'F' Then RegToPrint := WorstF Else RegToPrint := WorstR ;
  506.    Reg := RegOut[RegToPrint] ;
  507.    WriteReg(NumRegRun) ;
  508.    LinesLeft := LinesLeft - 1 ; If LinesLeft < 1 Then NewPage ;
  509. End ; { Report }
  510.  
  511. Procedure FindMaxMin( Z : DataVector ) ;
  512. Var I : Integer ;
  513. Begin
  514.    Max := Z[1] ; Min := Z[1] ;
  515.    For I := 2 To NumRow Do
  516.       Begin
  517.       If Max < Z[I] Then Max := Z[I] ;
  518.       If Min > Z[I] Then Min := Z[I] ;
  519.       End ;
  520. End ; { FindMaxMin }
  521.  
  522. Procedure FindYHat ( Var EstY : Real ; X1 : Real ) ;
  523. Var
  524.    RHS, Y1, Y2, Z : Real ;
  525. Begin
  526.    RHS := Reg.A + Reg.B1*F(Reg.X1Index,X1) + Reg.B2*F(Reg.X2Index,X1);
  527.    Case Reg.YIndex Of
  528.       1 : EstY := RHS ;
  529.       2 : If RHS > 0.0 Then EstY := Sqrt(RHS) Else EstY := 0.0 ;
  530.       3 : If RHS > 0.0 Then EstY := 1.0/RHS Else EstY := 0.0 ;
  531.       4 : If RHS > 0.0 Then EstY := 1.0/Sqrt(RHS) Else EstY := 0.0 ;
  532.       5 : EstY := Exp(RHS) ;
  533.       6 : If RHS <= -Exp(-1.0) Then EstY := Exp(-1.0)
  534.             Else Begin
  535.             Y2 := RHS + 2.0 / Exp(1.0) ;
  536.             Repeat
  537.                Y1 := Y2 ;
  538.                Z  := Y1 * Ln(Y1) - RHS ;
  539.                Y2 := Y1 - Z / (1.0 + Ln(Y1) );
  540.             Until Abs ( Y2 - Y1 ) < 1E-10 ;
  541.             EstY := Y2 ;
  542.             End ;
  543.       7 : If RHS >= 1.0/Exp(1.0) Then EstY := Exp(1.0)
  544.             Else Begin
  545.             If RHS <= 0.0 Then EstY := 0.0
  546.                Else Begin
  547.                   Y2 := Exp(3.0/2.0) ;
  548.                   Repeat
  549.                      Y1 := Y2 ;
  550.                      Z  := ( Ln(Y1) / Y1 ) - RHS ;
  551.                      Y2 := Y1 - Z * Sqr(Y1) / ( 1.0 - Ln(Y1) ) ;
  552.                   Until Abs ( Y2 - Y1 ) < 1E-10 ;
  553.                   EstY := Y2 ;
  554.                End ;
  555.             End ;
  556.    End ; { Case }
  557. End ; { FindYHat }
  558.  
  559. Procedure EvaluateYHat ;
  560. Var I : Integer ;
  561. Begin
  562.    For I := 1 To NumRow Do
  563.    Begin
  564.       FindYHat ( YHat[I] , X[I] ) ;
  565.       Residual[I] := Y[I] - YHat[I] ;
  566.    End ; { For }
  567. End ; { EvaluateYHat }
  568.  
  569. Procedure AskWhichReg ;
  570. Begin
  571.    Repeat
  572.       ClrScr ;
  573.       Write(Con,'What is the regression number of the regression ') ;
  574.       Writeln(Con,'you want to use ? ') ;
  575.       {$I-} Readln(Con,RegToPrint) {$I+} ;
  576.    Until ((RegToPrint In [ 1 .. NumRegRun ]) And (IOResult = 0)) ;
  577.    Reg := RegOut[RegToPrint] ;
  578. End ; { AskWhichReg }
  579.  
  580. Procedure FindPlotCoords ( Var XLoc, YLoc : Integer ; X1, Y1 : Real ) ;
  581. Begin
  582.    XLoc := Trunc ( 0.5 + 10.0 * ( X1 - XMin ) / XInc ) ;
  583.    YLoc := 80 - Trunc ( 0.5 + 10.0 * ( Y1 - YMin ) / YInc ) ;
  584.    If ( ( XLoc < 0 ) Or ( XLoc > 100 ) ) Then XLoc := -1 ;
  585.    If ( ( YLoc < 0 ) Or ( YLoc >  80 ) ) Then YLoc := -1 ;
  586. End ; { FindPlotCoords }
  587.  
  588. Procedure AskWhichData ( Var Answer : Char ) ;
  589. Begin
  590.    Repeat
  591.       ClrScr ; GoToXY(1,4) ;
  592.       Writeln(Con, 'Do you want the    ') ;
  593.       Writeln(Con,'          O Original') ;
  594.       Write(Con,'    or    T Transformed data?  ') ;
  595.       Readln(Con,Answer) ;  Answer := UpCase(Answer) ;
  596.    Until Answer In [ 'O' , 'T' ] ;
  597. End ; { AskWhichData }
  598.  
  599. Procedure Plot ;
  600. Var
  601.    Yhi, Ylo, EstY, XtoFit : Real ;
  602.    YPlot : Array [ 0 .. 8 ]  Of Real ;
  603.    XPlot : Array [ 0 .. 10 ] Of Real ;
  604.    I, J, XLoc, YLoc, Value, Result : Integer ;
  605.    Grid : Array [ 0 .. 101 , 0 .. 80 ] Of Char ;
  606.    Number : String[1] ;
  607. Begin
  608.    ClrScr ; Writeln(Con) ;
  609.    If LinesLeft < 55 Then NewPage ;
  610.    AskWhichReg ; WriteHeading ; WriteReg(1) ;
  611.    FindMaxMin(X) ; XMax := Max ; XMin := Min ;
  612.    FindMaxMin(Y) ; YMax := Max ; YMin := Min ;
  613.    EvaluateYHat  ;
  614.    XInc := 0.1 * ( XMax - XMin ) ;
  615.    FindYHat ( Ylo , XMin ) ; FindYHat ( Yhi , XMax ) ;
  616.    If Ylo < YMin Then YMin := Ylo ;
  617.    If Yhi < YMin Then YMin := Yhi ;
  618.    If Ylo > YMax Then YMax := Ylo ;
  619.    If Yhi > YMax Then YMax := Yhi ;
  620.    YInc := 0.125 * ( YMax - YMin ) ;
  621.    Writeln(Lst) ;
  622.    Write(Lst,' ':10,'The increment along the X (horizontal) axis is ') ;
  623.    Write(Lst,XInc/10:14) ;
  624.    Writeln(Lst,' and along the Y (vertical) axis is ',YInc/10:14,' .') ;
  625.    For I := 0 To 10 Do XPlot[I] := XMin + I * XInc ;
  626.    For I := 0 To  8 Do YPlot[I] := YMax - I * YInc ;
  627.    For I := 0 To 100 Do
  628.    Begin
  629.       For J := 0 To 80 Do Grid[I,J] := ' ' ;
  630.    End ; { For I }
  631.    For J := 1 To 79 Do Grid[101,J] := '-' ;
  632.    For J := 0 To 16 Do Grid[101,5*J] := '+' ;
  633.    For I := 0 To 100 Do
  634.    Begin
  635.       XToFit := XMin + I * XInc / 10.0 ;
  636.       FindYHat ( EstY , XToFit ) ;
  637.       FindPlotCoords ( XLoc , YLoc , XToFit , EstY ) ;
  638.       If (( XLoc >= 0 ) And ( YLoc >= 0 )) Then Grid [ XLoc , YLoc ] := '*' ;
  639.    End ; { For I }
  640.    For I := 1 To NumRow Do
  641.    Begin
  642.       FindPlotCoords ( XLoc , YLoc , X[I] , Y[I] ) ;
  643.       If (( XLoc >= 0 ) And ( YLoc >= 0 )) Then
  644.       Begin
  645.          If Grid [ Xloc , Yloc ] In  [' ','*'] Then Grid [ XLoc, YLoc ] := '0'
  646.          Else
  647.          Begin
  648.             Val ( Grid [ Xloc , Yloc ] , Value , Result ) ;
  649.             If ( ( Result =  0 ) And ( Value = 0 ) ) Then
  650.             Grid [ Xloc , Yloc ] := '2'
  651.             Else If ( ( Result = 0 ) And ( Value < 9 ) ) Then
  652.             Begin
  653.                Str( Value + 1, Number ) ;
  654.               Grid [ Xloc , Yloc ]  := Number ;
  655.             End { Else }
  656.             Else Grid [ Xloc , Yloc ] := '+' ;
  657.          End ; { Else }
  658.       End ; { If }
  659.    End ; { For I }
  660.    Writeln(Lst,SetLineFeed) ;  { Set line feed to 6/72 inch }
  661.    Writeln(Lst) ; Writeln(Lst) ;
  662.    Write(Lst,' ':20) ;
  663.    For I := 1 To 10 Do Write(Lst,'+....:....') ;
  664.    Writeln(Lst,'+') ;
  665.    For J := 0 To 80 Do
  666.    Begin
  667.       If J Mod 5 = 0 Then
  668.          If J Mod 10 = 0 Then Write(Lst,' ':10,YPlot[J Div 10]:9:2,'+')
  669.          Else Write(Lst,' ':19,'+')
  670.          Else Write(Lst,' ':19,'-') ;
  671.       For I := 0 To 101 Do Write(Lst,Grid[I,J]) ;
  672.       Writeln(Lst) ;
  673.    End ; { For J }
  674.    Write(Lst,' ':20) ;
  675.    For I := 1 To 10 Do Write(Lst,'+....:....') ;
  676.    Writeln(Lst,'+') ; Writeln(Lst) ;
  677.    Write(Lst,' ':14) ;
  678.    For I := 0 To 10 Do Write(Lst,Xplot[I]:9:2,' ') ;
  679.    Writeln(Lst,ResetLineFeed) ; { Reset line feed to 12/72 inch }
  680.    LinesLeft := 0 ;
  681. End ; { Plot }
  682.  
  683. Procedure ComputeYHat ;
  684. Var
  685.    Answer : String[20] ;
  686.    X1, EstY, G, RHS, SMuHat : Real ;
  687.    Result, Kt : Integer ;
  688. Begin
  689.    If LinesLeft < 10 Then NewPage ;
  690.    AskWhichReg ; WriteHeading ; WriteReg(1) ;
  691.    GetAverages ;
  692.    Writeln(Lst) ; Writeln(Con) ;
  693.    Write(Lst,' ':10,'    I  X',' ':15,'YHat Orig Units ') ;
  694.    Writeln(Lst,'YHat Tnf Units  SMuHat') ;
  695.    LinesLeft := LinesLeft - 7 ;
  696.    Kt := 0 ;
  697.    Repeat
  698.       ClrScr ; Writeln(Con) ;
  699.       Write(Con,'Enter the value of X. enter Q to quit  ') ;
  700.       Readln(con,Answer) ;
  701.       Val ( Answer , X1 , Result ) ;
  702.       If Result = 0 Then
  703.          Begin
  704.          Kt := Kt + 1 ;
  705.          FindYHat ( EstY , X1 ) ;
  706.          With Reg Do
  707.             Begin
  708.             RHS := A + B1 * F(X1Index,X1) + B2 * F(X2Index,X1) ;
  709.             G := 1.0 - (1.0/NumRow) - C11 * Sqr ( F(X1Index,X1) - X1Bar ) ;
  710.             G := G - C22 * Sqr ( F(X2Index,X1) - X2Bar ) ;
  711.             G := G - 2.0 * C12 * (F(X1Index,X1)-X1Bar)*(F(X2Index,X1)-X2Bar) ;
  712.             SMuHat := SEE * Sqrt ( 1.0 - G ) ;
  713.          End ; { With Reg }
  714.          Write(Lst,' ':10,Kt:5,'  ',X1:14,'  ',EstY:14,'  ',RHS:14) ;
  715.          Writeln(Lst,'  ',SMuHat:14) ;
  716.          LinesLeft := LinesLeft - 1 ;
  717.          If LinesLeft < 1 Then NewPage ;
  718.       End ; { If }
  719.    Until Answer[1] In [ 'q' , 'Q' ] ;
  720. End ; { ComputeYHat }
  721.  
  722. Procedure PrintHistogram ;
  723. Var
  724.    Hist : Array [ 1 .. 13 ] Of Integer ;
  725.    Mark : Array [ 1 .. 12 ] Of Real ;
  726.    MidPoint,SMidPt : Array [ 2 .. 12 ] Of Real ;
  727.    SumR, SumRSq, SDResid, G,
  728.    TnfX1, TnfX2, TnfY, RHS : Real ;
  729.    I, K,MaxElt, PointsPerDot : Integer ;
  730.    Answer : Char ;
  731. Begin
  732.    If LinesLeft < 25 Then NewPage ;
  733.    AskWhichReg ; WriteHeading ; WriteReg(1) ;
  734.    AskWhichData(Answer) ;
  735.    Case Answer Of
  736.       'O' : Begin
  737.             EvaluateYHat ;
  738.             Writeln(Lst) ;
  739.             Write(Lst,' ':10,'Histogram of residuals using') ;
  740.             Writeln(Lst,' the original units.') ;
  741.             SumR := 0.0 ; SumRSq := 0.0 ;
  742.             For I := 1 To NumRow Do
  743.                Begin
  744.                SumR := SumR + Residual[I] ;
  745.                SumRSq := SumRSq + Sqr( Residual[I] ) ;
  746.             End ;
  747.             SDResid := Sqrt( (SumRSq  - Sqr(SumR) / NumRow) / (NumRow - 1) ) ;
  748.             For I := 1 To NumRow Do
  749.                Residual[I] := (Residual[I]-(SumR/NumRow))/SDResid ;
  750.             End ;  { O }
  751.       'T' : Begin
  752.             GetAverages ;
  753.             For I := 1 To NumRow Do
  754.                Begin
  755.                TnfX1 := F(Reg.X1Index,X[I]) ;
  756.                TnfX2 := F(Reg.X2Index,X[I]) ;
  757.                TnfY  := F(Reg.YIndex, Y[I]) ;
  758.                RHS := Reg.A + TnfX1 * Reg.B1 + TnfX2 * Reg.B2 ;
  759.                Residual[I] := TnfY - RHS ;
  760.                With Reg Do
  761.                   Begin
  762.                   G := 1.0 - (1.0/Numrow) - C11*Sqr(TnfX1-X1Bar) ;
  763.                   G := G - C22 * Sqr(TnfX2-X2Bar) ;
  764.                   G := G - 2.0 * C12 * (TnfX1-X1Bar) * (TnfX2-X2Bar) ;
  765.                   SDResid := SEE * Sqrt ( G ) ;
  766.                End ; { With }
  767.                Residual[I] := Residual[I] / SDResid ;
  768.             End ; { For }
  769.             Writeln(Lst) ; Write(Lst,' ':10,'Histogram of standardized ') ;
  770.             Writeln(Lst,'residuals using transformed units.') ;
  771.             End ; { T }
  772.    End ; { Case }
  773.    Mark[1] := - 2.75 ;
  774.    For I := 2 to 12 Do Mark[ I ] := Mark[ I - 1 ] + 0.5 ;
  775.    For I := 1 To 13 Do Hist[ I ] := 0 ;
  776.    For I := 1 To NumRow Do
  777.       Begin
  778.       If Residual[I] < Mark[1] Then Hist[1] := Hist[1] + 1
  779.       Else If Residual [I] >= Mark[12] Then Hist[13] := Hist[13] + 1
  780.       Else Begin
  781.          K := 12 ;
  782.          Repeat
  783.             K := K - 1 ;
  784.          Until Residual[I] >= Mark[K] ;
  785.          Hist[K] := Hist[K] + 1 ;
  786.          End ; { If }
  787.       End ; { For }
  788.    MaxElt := Hist[1] ;
  789.    For I := 1 To 13 Do If Hist[I] > MaxElt Then MaxElt := Hist[I] ;
  790.    PointsPerDot := MaxElt Div 50 + 1 ;
  791.    For I := 2 To 12 Do SMidPt[I] := ( Mark[I] + Mark[I-1] ) / 2 ;
  792.    If Answer = 'O' Then For I := 2 To 12 Do
  793.       MidPoint[I] := SDResid * SMidPt[I] + SumR/NumRow ;
  794.    If PointsPerDot = 1 Then
  795.       Writeln(Lst,' ':10,'Each * represents 1 observation.')
  796.       Else Begin
  797.          Write(Lst,' ':10,'Each * represents ',PointsPerDot) ;
  798.          Writeln(Lst,' or a fraction of ',PointsPerDot,' observations') ;
  799.       End ; { If }
  800.    Write(Lst,' ':10,'The standardized cell midpoints ') ;
  801.    If Answer = 'O' Then Write(Lst,'and the cell midpoints ') ;
  802.    Writeln(Lst,'are printed.') ;
  803.    If Answer = 'O' Then Begin
  804.       Write(Lst,' ':10,'The width of each cell is one half the standard') ;
  805.       Write(Lst,' deviation of the observed residuals, which') ;
  806.       Writeln(Lst,' is ',SDResid:12,'.') ; End
  807.       Else Writeln(Lst,' ':10,'The width of each cell is 0.5.') ;
  808.    Writeln(Lst) ; Writeln(Lst) ;
  809.    For I := 1 To 13 Do
  810.       Begin
  811.       Case Answer Of
  812.          'O' : Case I Of
  813.                 1    : Write(Lst,' ':10,'      <   ',' ':10,'|') ;
  814.              2 .. 12 : Write(Lst,' ':10,MidPoint[I]:9,' ',SMidPt[I]:9:2,' |') ;
  815.                13    : Write(Lst,' ':10,'      >   ',' ':10,'|') ;
  816.              End ; { Case I }
  817.          'T' : Case I Of
  818.                 1    : Write(Lst,' ':26,'<   ','|') ;
  819.              2 .. 12 : Write(Lst,' ':20,SMidPt[I]:9:2,' |') ;
  820.                13    : Write(Lst,' ':26,'>   ','|') ;
  821.             End ; { Case I }
  822.       End ; { Case Answer }
  823.       If ( ( Hist[I] <> 0 ) And ( Hist[I] >= PointsPerDot ) ) Then
  824.          For K := 1 To Hist[I] Div PointsPerDot Do Write(Lst,'*') ;
  825.       If Hist[I] Mod PointsPerDot <> 0 Then Writeln(Lst,'*')
  826.          Else Writeln(Lst) ;
  827.       End ; { For I }
  828.    LinesLeft := LinesLeft - 25 ;
  829. End ; { PrintHistogram }
  830.  
  831. Procedure PrintTable ;
  832. Var
  833.    Answer : Char ;
  834.    LinesToPrint, I : Integer ;
  835.    RHS, TnfX1, TnfX2, TnfY, TnfResid,
  836.    G, SResid, StdResid, SMuHat : Real ;
  837. Begin
  838.    AskWhichReg  ;
  839.    If Reg.YIndex <> 1 Then AskWhichData(Answer) Else Answer := 'T' ;
  840.    LinesToPrint := NumRow + 8 ;
  841.    If ((LinesToPrint < 60) And (LinesToPrint > LinesLeft))
  842.       Or ((LinesLeft < 12) And (LinesToPrint > LinesLeft)) Then NewPage ;
  843.    WriteHeading ; WriteReg(1) ; Writeln(Lst) ; Writeln(Lst) ;
  844.    LinesLeft := LinesLeft - 7 ;
  845.    If Reg.YIndex <> 1 Then
  846.    Begin
  847.       Case Answer Of
  848.          'O' : Writeln(Lst,' ':10,'Data in original units.') ;
  849.          'T' : Writeln(Lst,' ':10,'Data in transformed units.') ;
  850.       End ; { Case }
  851.    End { Then }
  852.    Else Writeln(Lst) ;
  853.    Case Answer Of
  854.      'O' : Begin
  855.            EvaluateYHat ;
  856.            Write(Lst,' ':10,' I',' ':3,'X',' ':15,'Y',' ':15,'YHat',' ':12) ;
  857.            Writeln(Lst,'Residual') ;
  858.            LinesLeft := LinesLeft - 1 ; If LinesLeft < 1 Then NewPage ;
  859.            For I := 1 To NumRow Do
  860.            Begin
  861.               Write(Lst,' ':10,I:3,'  ',X[I]:14,'  ',Y[I]:14,'  ') ;
  862.               Write(Lst,YHat[I]:14,'  ') ;
  863.               Writeln(Lst,Residual[I]:14) ;
  864.               LinesLeft := LinesLeft - 1 ; If LinesLeft < 1 Then NewPage ;
  865.            End ; { For I }
  866.            End ; { O }
  867.      'T' : Begin
  868.            GetAverages ;
  869.            Case Reg.X2Index Of
  870.               0 : Begin
  871.                   Write(Lst,' ':10,' I',' ':3,'X1',' ':14,'Y',' ':15) ;
  872.                   Write(Lst,'YHat',' ':12,'SMuHat',' ':10) ;
  873.                   Writeln(Lst,'Residual',' ':8,'Std Residual') ;
  874.                   LinesLeft := LinesLeft - 1 ; If LinesLeft < 1 Then NewPage ;
  875.                   For I := 1 To NumRow Do
  876.                   Begin
  877.                      TnfX1 := F(Reg.X1Index,X[I]) ;
  878.                      TnfY  := F(Reg.YIndex, Y[I]) ;
  879.                      RHS := Reg.A + TnfX1 * Reg.B1 ;
  880.                      TnfResid := TnfY - RHS ;
  881.                      With Reg Do
  882.                         Begin
  883.                         G := 1.0 - (1.0/NumRow) - C11 * Sqr (TnfX1-X1Bar) ;
  884.                         SResid := SEE * Sqrt ( G ) ;
  885.                         StdResid := TnfResid / SResid ;
  886.                         SMuHat := SEE * Sqrt ( 1.0 - G ) ;
  887.                      End ; { With Reg }
  888.                      Write(Lst,' ':10,I:3,'  ',TnfX1:14,'  ') ;
  889.                      Write(Lst,TnfY:14,'  ',RHS:14,'  ',SMuHat:14,'  ') ;
  890.                      Writeln(Lst,TnfResid:14,'  ',StdResid:8:4) ;
  891.                      LinesLeft := LinesLeft-1 ; If LinesLeft < 1 Then NewPage ;
  892.                   End ; { For I }
  893.                   End ; { 0 }
  894.               1 .. NumForms : Begin
  895.                  Write(Lst,' ':10,' I',' ':3,'X1',' ':14,'X2',' ':14) ;
  896.                  Write(Lst,'Y',' ':15) ;
  897.                  Write(Lst,'YHat',' ':12,'SMuHat',' ':10) ;
  898.                  Writeln(Lst,'Residual',' ':8,'Std Residual') ;
  899.                  LinesLeft := LinesLeft - 1 ; If LinesLeft < 1 Then NewPage ;
  900.                  For I := 1 To NumRow Do
  901.                     Begin
  902.                     TnfX1 := F(Reg.X1Index,X[I]) ;
  903.                     TnfX2 := F(Reg.X2Index,X[I]) ;
  904.                     TnfY  := F(Reg.YIndex, Y[I]) ;
  905.                     RHS := Reg.A + TnfX1 * Reg.B1 + TnfX2 * Reg.B2 ;
  906.                     TnfResid := TnfY - RHS ;
  907.                     With Reg Do
  908.                        Begin
  909.                        G := 1.0 - (1.0/NumRow) - C11 * Sqr (TnfX1-X1Bar) ;
  910.                        G := G - C22 * Sqr (TnfX2-X2Bar) ;
  911.                        G := G - 2.0 * C12 * (TnfX1-X1Bar) * (TnfX2-X2Bar) ;
  912.                        SResid := SEE * Sqrt ( G ) ;
  913.                        StdResid := TnfResid / SResid ;
  914.                        SMuHat := SEE * Sqrt ( 1.0 - G ) ;
  915.                     End ; { With Reg }
  916.                     Write(Lst,' ':10,I:3,'  ',TnfX1:14,'  ',TnfX2:14,'  ') ;
  917.                     Write(Lst,TnfY:14,'  ',RHS:14,'  ',SMuHat:14,'  ') ;
  918.                     Writeln(Lst,TnfResid:14,'  ',StdResid:8:4) ;
  919.                     LinesLeft := LinesLeft-1 ; If LinesLeft < 1 Then NewPage ;
  920.                     End ; { For }
  921.                  End ; { 1..6 }
  922.               End ; { Case }
  923.            End ; { T }
  924.       End ; { Case }
  925. End ;  { PrintTable }
  926.  
  927. Procedure PrintDetails ;
  928. Var
  929.    Beta1, Beta2, MSE, MST, SB1, SB2, R12, T1, T2, SSE,
  930.    SSR, MSR, SSX1, SSX2X1, SSX2, SSX1X2 : Real ;
  931.    LinesToPrint, DFReg, DFTotal : Integer ;
  932. Begin
  933.    AskWhichReg ; WriteHeading ; WriteReg(1) ;
  934.    If Reg.X2Index = 0 Then LinesToPrint := 14 Else LinesToPrint := 24 ;
  935.    If LinesLeft < LinesToPrint Then NewPage ;
  936.    Writeln(Lst) ;
  937.    Writeln(Lst,' ':10,'ANOVA Table') ; Writeln(Lst) ;
  938.    Writeln(Lst,' ':10,'Source      D.F.  SS',' ':14,'MS',' ':17,'F') ;
  939.    With Reg Do
  940.       Begin
  941.       SSR := SST * RSq / 100.0 ;
  942.       DFReg := NumRow - ResidualDF - 1 ;
  943.       MSR := SSR / DFReg ;
  944.       SSE := SST - SSR ;
  945.       MSE := SSE / ResidualDF ;
  946.       T1 :=  MSR / MSE ;
  947.       Write(Lst,' ':10,'Regression  ',DFReg:3,' ':3,SSR:14) ;
  948.       Writeln(Lst,'  ',MSR:14,' ',T1:9:3) ;
  949.       If X2Index > 0 Then
  950.          Begin
  951.          SSX2X1 := B2 * B2 / C22 ;
  952.          SSX1 := SSR - SSX2X1 ;
  953.          T1 := SSX1 / MSE ;
  954.          T2 := SSX2X1 / MSE ;
  955.          Writeln(Lst) ;
  956.          Write(Lst,' ':10,'   X1',' ':7,'  1',' ':3,SSX1:14,'  ',SSX1:14) ;
  957.          Writeln(Lst,' ',T1:9:3) ;
  958.          Write(Lst,' ':10,'   X2 | X1  ','  1',' ':3,SSX2X1:14,'  ',SSX2X1:14);
  959.          Writeln(Lst,' ',T2:9:3) ;
  960.          SSX1X2 := B1 * B1 / C11 ;
  961.          SSX2 := SSR - SSX1X2 ;
  962.          T1 := SSX2 / MSE ;
  963.          T2 := SSX1X2 / MSE ;
  964.          Writeln(Lst) ;
  965.          Write(Lst,' ':10,'   X2',' ':7,'  1',' ':3,SSX2:14,'  ',SSX2:14) ;
  966.          Writeln(Lst,' ',T1:9:3) ;
  967.          Write(Lst,' ':10,'   X1 | X2  ','  1',' ':3,SSX1X2:14,'  ',SSX1X2:14);
  968.          Writeln(Lst,' ',T2:9:3) ;
  969.          Writeln(Lst) ;
  970.       End ; { If }
  971.       DFTotal := NumRow - 1 ;
  972.       MST := SST / DFTotal ;
  973.       Writeln(Lst,' ':10,'Error',' ':7,ResidualDF:3,' ':3,SSE:14,'  ',MSE:14) ;
  974.       Writeln(Lst,' ':10,'Total',' ':7,DFTotal:3,' ':3,SST:14,'  ',MST:14) ;
  975.       Writeln(Lst) ; Writeln(Lst) ;
  976.       If X2Index > 0 Then
  977.          Begin
  978.          Write(Lst,' ':10,'Variable Coefficient     Beta',' ':12) ;
  979.          Writeln(Lst,'S.D.ofCoef.',' ':9,'T') ;
  980.          Beta1 := B1 * Sqrt ( D * C22 / SST ) ;
  981.          Beta2 := B2 * Sqrt ( D * C11 / SST ) ;
  982.          SB1 := SEE * Sqrt ( C11 ) ;
  983.          SB2 := SEE * Sqrt ( C22 ) ;
  984.          R12 := SEE * SEE * C12 / ( SB1 * SB2 ) ;
  985.          T1 := B1 / SB1 ;
  986.          T2 := B2 / SB2 ;
  987.          Write(Lst,' ':10,'   X1    ',B1:14,'  ',Beta1:14,'  ',SB1:14) ;
  988.          Writeln(Lst,'  ',T1:9:3);
  989.          Write(Lst,' ':10,'   X2    ',B2:14,'  ',Beta2:14,'  ',SB2:14) ;
  990.          Writeln(Lst,'  ',T2:9:3);
  991.          Writeln(Lst) ;
  992.          Writeln(Lst,' ':10,'The correlation between X1 and X2 is ',R12:9:4) ;
  993.       End ; { If }
  994.       Writeln(Lst) ;
  995.       Write(Lst,' ':10,'C11 = ',C11:14,' ':5,'C22 = ',C22:14,' ':5) ;
  996.       Writeln(Lst,'C12 = ',C12:14) ;
  997.    End ; { With }
  998.    LinesLeft := LinesLeft - LinesToPrint ;
  999. End ; { PrintDetails }
  1000.  
  1001. Procedure FindOrigY ;
  1002. Var
  1003.    Answer : String[20] ;
  1004.    Result, Kt : Integer ;
  1005.    TnfY, OrigY, Y1, Y2, Z : Real ;
  1006. Begin
  1007.    If LinesLeft < 10 Then NewPage ;
  1008.    AskWhichReg ; WriteHeading ; WriteReg(1) ;
  1009.    Writeln(Lst) ; Writeln(Con) ;
  1010.    Writeln(Lst,' ':10,'    I  ','Y in Tnf Units  ','Y in Orig Units') ;
  1011.    LinesLeft := LinesLeft - 7 ;
  1012.    Kt := 0 ;
  1013.    Repeat
  1014.       ClrScr ; Writeln(Con) ;
  1015.       Write(Con,'Enter the Transformed value of Y. enter Q to quit  ') ;
  1016.       Readln(con,Answer) ;
  1017.       Val ( Answer , TnfY , Result ) ;
  1018.       If Result = 0 Then
  1019.          Begin
  1020.          Kt := Kt + 1 ;
  1021.          Case Reg.YIndex Of
  1022.          1 : OrigY := TnfY ;
  1023.          2 : If TnfY > 0.0 Then OrigY := Sqrt(TnfY) Else OrigY := 0.0 ;
  1024.          3 : If TnfY > 0.0 Then OrigY := 1.0/TnfY Else OrigY := 0.0 ;
  1025.          4:  If TnfY > 0.0 Then OrigY := 1.0/Sqrt(TnfY) Else OrigY := 0.0 ;
  1026.          5 : OrigY := Exp(TnfY) ;
  1027.          6 : If TnfY <= -Exp(-1.0) Then OrigY := Exp(-1.0)
  1028.                Else Begin
  1029.                Y2 := TnfY + 2.0 / Exp(1.0) ;
  1030.                Repeat
  1031.                   Y1 := Y2 ;
  1032.                   Z  := Y1 * Ln(Y1) - TnfY ;
  1033.                   Y2 := Y1 - Z / (1.0 + Ln(Y1) );
  1034.                Until Abs ( Y2 - Y1 ) < 1E-10 ;
  1035.                OrigY := Y2 ;
  1036.                End ;
  1037.          7 : If TnfY >= 1.0/Exp(1.0) Then OrigY := Exp(1.0)
  1038.                Else Begin
  1039.                If TnfY <= 0.0 Then OrigY := 0.0
  1040.                   Else Begin
  1041.                      Y2 := Exp(3.0/2.0) ;
  1042.                      Repeat
  1043.                         Y1 := Y2 ;
  1044.                         Z  := ( Ln(Y1) / Y1 ) - TnfY ;
  1045.                         Y2 := Y1 - Z * Sqr(Y1) / ( 1.0 - Ln(Y1) ) ;
  1046.                      Until Abs ( Y2 - Y1 ) < 1E-10 ;
  1047.                      OrigY := Y2 ;
  1048.                   End ;
  1049.                End ;
  1050.             End ; { Case }
  1051.          Writeln(Lst,' ':10,Kt:5,'  ',TnfY:14,'  ',OrigY:14) ;
  1052.          LinesLeft := LinesLeft -1 ;
  1053.          If LinesLeft < 1 Then NewPage ;
  1054.       End ;
  1055.    Until Answer[1] In [ 'q' , 'Q' ] ;
  1056.    End ; { FindOrigY }
  1057.  
  1058. Procedure SaveRegression ;
  1059. Var
  1060.    I : Integer ;
  1061. Begin
  1062.    ClrScr ;
  1063.    GetOutFile(2) ;
  1064.    {$I-} ReWrite ( HdrOutFile ) ; {$I+}
  1065.    If IOResult <> 0 Then
  1066.    Begin
  1067.       Writeln(Con) ;
  1068.       Writeln(Con,'File ',OutFileName,'.HDR cannot be opened.') ;
  1069.    End  { If }
  1070.    Else
  1071.    Begin
  1072.       Writeln ( HdrOutFile , TurboType ) ;
  1073.       Writeln ( HdrOutFile , DataFileName ) ;
  1074.       Writeln ( HdrOutFile , XCol , ' ' , YCol , ' ' , NumRow ) ;
  1075.       Writeln ( HdrOutFile , NumMissing,' ',NumMissingX,' ',NumMissingY ) ;
  1076.       If NumMissingX > 0 Then For I := 1 To NumMissingX Do
  1077.          Writeln ( HdrOutFile , MissingX [ I ] ) ;
  1078.       If NumMissingY > 0 Then For I := 1 To NumMissingY Do
  1079.          Writeln ( HdrOutFile , MissingY [ I ] ) ;
  1080.       Writeln(HdrOutFile,'*') ;
  1081.       For I := 1 To NumForms Do
  1082.          If OKToRunX[I] Then Writeln(HdrOutFile,'X',' ',I,' ',XBar[I]) ;
  1083.       For I := 1 To NumForms Do
  1084.          If OKToRunY[I] Then Writeln(HdrOutFile,'Y',' ',I,' ',YBarr[I]) ;
  1085.       Close ( HdrOutFile ) ;
  1086.       {$I-} ReWrite ( RegOutFile ) ; {$I+}
  1087.       If IOResult <> 0 Then
  1088.       Begin
  1089.          Writeln(Con) ;
  1090.          Writeln(Con,'File ',OutFileName,'.REG cannot be opened.') ;
  1091.       End
  1092.       Else
  1093.       Begin
  1094.          For I := 0 To NumRegRun - 1 Do
  1095.          Begin
  1096.             Seek(RegOutFile,I) ;
  1097.             Write ( RegOutFile , RegOut[I+1] ) ;
  1098.          End ; { For }
  1099.          Close(RegOutFile) ;
  1100.          DataNotSaved := False ;
  1101.       End ; { Else for REG file }
  1102.    End ; { Else for HDR file }
  1103. End ; { SaveRegression }
  1104.  
  1105. Procedure ExitPrompt ;
  1106. Begin
  1107.    If ( DataNotSaved And ( Not NoReg ) ) Then
  1108.    Begin
  1109.       ClrScr ;
  1110.       Writeln(Con) ;
  1111.       Writeln(Con,'The regression output has not been saved to disk.') ;
  1112.       Writeln(Con) ;
  1113.       Write(Con,'Do you want to save the regression output? ') ;
  1114.       Readln(Con,Answer) ; Answer := UpCase(Answer) ;
  1115.       If Answer = 'Y' Then SaveRegression ;
  1116.    End ; { If }
  1117. End ; { ExitPrompt }
  1118.  
  1119. Procedure RunRegression ;
  1120. Begin
  1121.    ExitPrompt ;
  1122.    NoReg := False ;
  1123.    DataNotSaved := True ;
  1124.    GetStarted ;
  1125.    If NoReg = False Then
  1126.    Begin
  1127.       Regress ;
  1128.       J1 := 2 ; Sort ; BestF := Trunc(Rank[1,1] + 0.1) ;
  1129.       WorstF := Trunc(Rank[NumRegRun,1] + 0.1) ; AddInfo ;
  1130.       J1 := 3 ; Sort ; BestR := Trunc(Rank[1,1] + 0.1) ;
  1131.       WorstR := Trunc(Rank[NumRegRun,1] + 0.1) ; AddInfo ;
  1132.    End ; { If }
  1133. End ; { RunRegression }
  1134.  
  1135. Procedure GetRegression ;
  1136. Var
  1137.    I, MaxCol, K, J, L, Typ : Integer ;
  1138.    XOrYMissing : Boolean ;
  1139.    Dummy : Real ;
  1140.    Temp : String[3] ;
  1141.    Drive : String[2] ;
  1142. Begin
  1143.    ExitPrompt ;
  1144.    ClrScr ; Writeln(Con) ; NoReg := False ;
  1145.    Write(Con,'The data file and the output files must be in the same ');
  1146.    Writeln(Con,'directory or subdirectory') ;
  1147.    Writeln(Con) ;
  1148.    GetOutFile (4) ;
  1149.    If Pos(':',OutFileName) = 2 Then Drive := Copy(OutFileName,1,2) ;
  1150.    Assign ( RegOutFile , OutFileName + '.REG' ) ;
  1151.    Assign ( HdrOutFile , OutFileName + '.HDR' ) ;
  1152.    {$I-} Reset(RegOutFile) {$I+} ; I := IOResult ;
  1153.    If I <> 0 Then Begin
  1154.       NoReg := True ; Writeln(Con) ;
  1155.       Writeln(Con,'The reg file ',OutFileName+'.REG', ' is not available.') ;
  1156.       Writeln(Con) ; Writeln(Con,'Press any key to continue.') ;
  1157.       Repeat Until KeyPressed ;
  1158.    End ; { If }
  1159.    If NoReg = False Then
  1160.    Begin
  1161.       {$I-} Reset(HdrOutFile) {$I+} ; I := IOResult ;
  1162.       If I <> 0 Then Begin
  1163.          NoReg := True ; Writeln(Con) ;
  1164.          Writeln(Con,'The hdr file ',OutFileName+'.HDR',' is not available.') ;
  1165.          Writeln(Con) ; Writeln(Con,'Press any key to continue.') ;
  1166.          Repeat Until KeyPressed ;
  1167.       End ; { If I <> 0 }
  1168.    End ; { If NoReg = False }
  1169.    If NoReg = False Then
  1170.    Begin
  1171.       Readln( HdrOutFile , Typ ) ;
  1172.       If Typ <> TurboType Then
  1173.       Begin
  1174.          Close ( RegOutFile ) ; Close ( HdrOutFile ) ;
  1175.          Writeln(Con) ; NoReg := True ;
  1176.          Write(Con,'The output was saved with CFIT') ;
  1177.          If Typ = 87 Then Write(Con,'87') ;
  1178.          Writeln(Con,' and cannot be read by this program.') ;
  1179.          Writeln(Con) ; Writeln(Con,'Press any key to continue.') ;
  1180.          Repeat Until KeyPressed ;
  1181.       End ; { If Typ <> TurboTyp }
  1182.    End ; { If NoReg = False }
  1183.    If NoReg = False Then
  1184.    Begin
  1185.       Readln( HdrOutFile , DataFileName) ;
  1186.       Readln( HdrOutFile , XCol , YCol , NumRow ) ;
  1187.       Readln( HdrOutFile , NumMissing , NumMissingX , NumMissingY ) ;
  1188.       If NumMissingX > 0 Then For I := 1 To NumMissingX Do
  1189.          Readln( HdrOutFile , MissingX [ I ] ) ;
  1190.       If NumMissingY > 0 Then For I := 1 To NumMissingY Do
  1191.          Readln( HdrOutFile , MissingY [ I ] ) ;
  1192.       If Pos(':',DataFileName) = 2 Then
  1193.          DataFileName := Copy(DataFileName,3,Length(DataFileName)-2) ;
  1194.       DataFileName := Drive + DataFileName ;
  1195.       Assign ( DataFile , DataFileName ) ;
  1196.       {$I-} Reset ( DataFile ) {$I+} ; I := IOResult ;
  1197.       If I <> 0 Then Begin
  1198.          NoReg := True ; Writeln(Con) ;
  1199.          Writeln(Con,DataFileName,' is not available. ') ;
  1200.          Writeln(Con) ; Writeln(Con,'Press any key to continue.') ;
  1201.          Repeat Until KeyPressed ;
  1202.       End ; { If I <> 0 }
  1203.    End ; { If NoReg = False } ;
  1204.    If NoReg = False Then
  1205.    Begin
  1206.       If XCol < YCol Then MaxCol := YCol Else MaxCol := XCol ;
  1207.          K := 1 ;
  1208.       For I := 1 to NumRow + NumMissing Do
  1209.       Begin
  1210.          For J := 1 to MaxCol Do
  1211.             Begin
  1212.             If J = XCol Then Read(DataFile,X[K])
  1213.                Else If J = YCol Then Read(DataFile,Y[K])
  1214.                Else Read(DataFile,Dummy) ;
  1215.             End ; { For J }
  1216.          Readln(DataFile) ;
  1217.          XorYMissing := False ;
  1218.          If NumMissingX > 0 Then
  1219.             For L := 1 To NumMissingX Do
  1220.                If X[K] = MissingX[L] Then XorYMissing := True ;
  1221.          If ( ( NumMissingY > 0 ) And ( Not XorYMissing ) )Then
  1222.             For L := 1 To NumMissingY Do
  1223.                If Y[K] = MissingY[L] Then XorYMissing := True ;
  1224.          If (Answer = 'N') Or ( Not XorYMissing ) Then Begin
  1225.             CheckConstraints(K) ;
  1226.          K := K + 1 ;
  1227.          End ; { If }
  1228.       End ; { For I }
  1229.       Close ( DataFile ) ;
  1230.       I := 0 ;
  1231.       While Not EOF(RegOutFile) Do
  1232.       Begin
  1233.          Seek ( RegOutFile , I ) ;
  1234.          Read ( RegOutFile , RegOut[I+1] ) ;
  1235.          I := I + 1 ;
  1236.          If RegOut[I].NextF < 0 Then
  1237.          Begin
  1238.             WorstF := I ;
  1239.             BestF := - RegOut[I].NextF ;
  1240.          End ; { If }
  1241.       End ; { While }
  1242.       NumRegRun := I ;
  1243.       I := 0 ;
  1244.       Repeat I := I + 1 ; Until RegOut[I].NextR < 0 ;
  1245.       WorstR := I ; BestR := - Reg.NextR ;
  1246.       Close ( RegOutFile ) ;
  1247.       DataNotSaved := False ;
  1248.    End ; { If NoReg = False }
  1249. End ; { GetRegression }
  1250.  
  1251. { Procedure Listfiles is adapted from DIRECT.INC on the Public (Software)
  1252.   Library's ASM-Pascal disk. No copyright is claimed for this procedure. }
  1253.  
  1254. Procedure ListFiles ;
  1255. Type
  1256.    Char80arr   = Array [ 1..80 ] of Char ;
  1257.    String80    = String[ 80 ] ;
  1258.    RegisterSet = Record
  1259.                     AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : Integer ;
  1260.                  End ;
  1261.  
  1262. {$I-}
  1263.  
  1264. Var
  1265.    DTA : array [ 1..43 ] of Byte ;
  1266.    DTAseg, DTAofs, SetDTAseg, SetDTAofs, Error, ErrFlag1, ErrFlag2, I, J,
  1267.    Option, Dn, RowNum : Integer ;
  1268.    Regs : RegisterSet ;
  1269.    Buffer, NamR, CurDir : String80 ;
  1270.    Ch, OrigDrive, TempDrive : Char ;
  1271.    Mask : Char80arr ;
  1272.    HorizTab : Byte ;
  1273.  
  1274. Function DefaultDrive : Char ;
  1275. Var
  1276.    Regs : RegisterSet ;
  1277. Begin
  1278.    Regs.AX := $1900 ;
  1279.    Msdos( regs ) ;
  1280.    DefaultDrive := Chr(Ord('A')+lo(Regs.AX)) ;
  1281. End ;
  1282.  
  1283. Procedure ChangeDrive(dr : char);
  1284. Var
  1285.    Regs : RegisterSet;
  1286. Begin
  1287.    Regs.AX := $0E00 ;
  1288.    Regs.DX := Ord(UpCase(dr)) - Ord('A') ;
  1289.    Msdos( Regs ) ;
  1290. End ;
  1291.  
  1292. Procedure SetDTA( Segment, Offset : Integer; var Error : Integer ) ;
  1293. Begin
  1294.    Regs.AX := $1A00 ;
  1295.    Regs.DS := Segment ;
  1296.    Regs.DX := Offset ;
  1297.    MSDos( Regs ) ;
  1298.    Error := Regs.AX and $FF ;
  1299. End ;
  1300.  
  1301. Procedure GetCurrentDTA( Var Segment, Offset, Error : Integer ) ;
  1302. Begin
  1303.    Regs.AX := $2F00 ;
  1304.    MSDos( Regs ) ;
  1305.    Segment := Regs.ES ;
  1306.    Offset := Regs.BX ;
  1307.    Error := Regs.AX and $FF ;
  1308. End ;
  1309.  
  1310. Procedure GetFirst( Mask : Char80arr; Var NamR : String80; Segment,
  1311.                     Offset, Option : Integer; Var Error : Integer ) ;
  1312. Var I : Integer ;
  1313. Begin
  1314.    Error := 0 ;
  1315.    Regs.AX := $4E00 ;
  1316.    Regs.DS := Seg( Mask ) ;
  1317.    Regs.DX := Ofs( Mask ) ;
  1318.    Regs.CX := Option ;
  1319.    MSDos( Regs ) ;
  1320.    Error := Regs.AX and $FF ;
  1321.    I := 1 ;
  1322.    Repeat
  1323.       NamR[ I ] := Chr( Mem[ Segment : Offset + 29 + I ] ) ;
  1324.       I := I + 1 ;
  1325.    Until ( Not ( NamR[ I - 1 ] In [ ' '..'~' ] ))  ;
  1326.    NamR[ 0 ] := Chr( I - 1 ) ;
  1327. End ;
  1328.  
  1329. Procedure GetNextEntry( Var NamR : String80 ; Segment, Offset,
  1330.                         Option : Integer ; Var Error : Integer ) ;
  1331. Var I : Integer ;
  1332. Begin
  1333.    Error := 0 ;
  1334.    Regs.AX := $4F00 ;
  1335.    Regs.CX := Option ;
  1336.    MSDos( Regs ) ;
  1337.    Error := Regs.AX and $FF ;
  1338.    I := 1 ;
  1339.    Repeat
  1340.       NamR[ I ] := Chr( mem[ Segment : Offset + 29 + I ] ) ;
  1341.       I := I + 1 ;
  1342.    Until ( Not ( NamR[ I - 1 ] In [ ' '..'~' ] )) ;
  1343.    NamR[ 0 ] := Chr( I - 1 ) ;
  1344. End ;
  1345.  
  1346. Begin
  1347.    HorizTab := 4 ;
  1348.    RowNum := 3 ;
  1349.    For I := 1 to 21 Do DTA[ I ] := 0 ;
  1350.    For I := 1 to 80 Do
  1351.    Begin
  1352.       Mask[ I ] := Chr( 0 ) ;
  1353.       NamR[ I ] := Chr( 0 ) ;
  1354.    End ;
  1355.    NamR[ 0 ] := Chr( 0 ) ;
  1356.    GetCurrentDTA( DTAseg, DTAofs, ErrFlag1 ) ;
  1357.    If ErrFlag1 = 0 Then
  1358.    Begin
  1359.       SetDTAseg := Seg( DTA ) ;
  1360.       SetDTAofs := Ofs( DTA ) ;
  1361.       SetDTA( SetDTAseg, SetDTAofs, ErrFlag2 ) ;
  1362.    End ;
  1363.    If ((ErrFlag1 = 0) And (Errflag2 = 0)) Then
  1364.    Begin
  1365.       Error := 0 ;
  1366.       Buffer[ 0 ] := Chr( 0 ) ;
  1367.       Option := 16 ;
  1368.       ClrScr ;
  1369.       Write('Path : ' ) ;
  1370.       ReadLn( Buffer );
  1371.       WriteLn;
  1372.       Buffer := Buffer + '\*.*' ;
  1373.       If Pos(':',Buffer) = 2 Then
  1374.       Begin
  1375.          TempDrive := Copy(Buffer,1,1) ;
  1376.          OrigDrive := DefaultDrive ;
  1377.          ChangeDrive(TempDrive) ;
  1378.          Buffer := Copy(Buffer,3,Length(Buffer)-2) ;
  1379.       End ;
  1380.       For I := 1 To Length( Buffer ) Do Mask[ I ] := Buffer[ I ] ;
  1381.       GetFirst( Mask, NamR, SetDTAseg, SetDTAofs, Option, Error ) ;
  1382.       If ( Error = 0 ) Then
  1383.       Begin
  1384.          GoToXY(HorizTab,RowNum) ;
  1385.          Write( NamR ) ;
  1386.          HorizTab := HorizTab + 15 ;
  1387.       End
  1388.       Else Writeln( '   Path ''', Buffer, ''' not found.' ) ;
  1389.       While ( Error = 0 ) Do
  1390.       Begin
  1391.          GetNextEntry( NamR, SetDTAseg, SetDTAofs, Option, Error ) ;
  1392.          If Error = 0 Then
  1393.          Begin
  1394.             GoToXY(HorizTab,RowNum) ;
  1395.             Write( NamR ) ;
  1396.             HorizTab := HorizTab + 15 ;
  1397.             If HorizTab > 70 Then
  1398.             Begin
  1399.                HorizTab := 4 ;
  1400.                RowNum := RowNum + 1 ;
  1401.                Writeln ;
  1402.                If RowNum = 23 Then
  1403.                Begin
  1404.                   GoToXY(1,24) ;
  1405.                   Write(Con,'Press any key to continue.') ;
  1406.                   Repeat Until KeyPressed ;
  1407.                   ClrScr ;
  1408.                   RowNum := 3 ;
  1409.                End ;
  1410.             End ;
  1411.          End ;
  1412.       End; { While }
  1413.       SetDTA( DTAseg, DTAofs, Error );
  1414.       ChangeDrive(OrigDrive) ;
  1415.       GoToXY(1,24) ;
  1416.       Write(Con,'Press any key to continue.') ;
  1417.       Repeat Until KeyPressed ;
  1418.    End { If ErrFlag1 = 0 And ErrFlag2 = 0 }
  1419.    Else
  1420.    Begin
  1421.       GoToXY(3,1) ;
  1422.       Write(Con,'Disk access error. Press any key to continue.') ;
  1423.       Repeat Until KeyPressed ;
  1424.    End ; { Else }
  1425.    {$I+}
  1426. End ; { ListFiles }
  1427.  
  1428. Procedure SetUpPrinter ;
  1429. Var
  1430.    K : Integer ;
  1431. Begin
  1432.    ClrScr ; Writeln(Con) ;
  1433.    Writeln(Con,'Set printer to top of form and turn on.') ;
  1434.    Writeln(Con) ;
  1435.    Writeln(Con,'Press any key when ready.') ;
  1436.    Repeat Until KeyPressed ;
  1437.    SetPrintVars ;
  1438.    Write(Lst , ResetPrinter , SetCondensed , SetOneWay ) ;
  1439.    K := 5 ; Repeat Begin Writeln(lst) ; K := K - 1 ; End ; Until K = 1 ;
  1440.    LinesLeft := 55 ;
  1441. End ; { SetUpPrinter }
  1442.  
  1443. Procedure Menu ;
  1444. Var AnsOK : Boolean ;
  1445. Begin
  1446.    Repeat
  1447.       AnsOK := False ;
  1448.       ClrScr ; Writeln(Con) ;
  1449.       Writeln(Con,' C Compute Y Hat Values') ;
  1450.       Writeln(Con,' D Print Details of a Fit') ;
  1451.       Writeln(Con,' F Find Y in Original Units Given Y in Transformed Units') ;
  1452.       Writeln(Con,' G Get Regression From Disk') ;
  1453.       Writeln(Con,' H Print Histogram Of Residuals') ;
  1454.       Writeln(Con,' L List Files On Disk') ;
  1455.       Writeln(Con,' N Run New Regression') ;
  1456.       Writeln(Con,' P Plot Fitted Curve') ;
  1457.       Writeln(Con,' Q Quit') ;
  1458.       Writeln(Con,' R Report Regression Results') ;
  1459.       Writeln(Con,' S Save Regressions to Disk') ;
  1460.       Writeln(Con,' T Print Table of Residuals') ;
  1461.       Writeln(Con,' U Setup Printer') ;
  1462.       If NoReg Then
  1463.       Begin
  1464.          Writeln(Con) ;
  1465.          Write(Con,'You can only use the G, L, N and Q options now. ') ;
  1466.       End ; { If }
  1467.       Readln(Con,Answer) ; Answer := UpCase(Answer) ;
  1468.       If ( NoReg And ( Answer In [ 'G','L','N','Q' ] ) ) Then AnsOK := True ;
  1469.       If ( ( Not NoReg ) And
  1470.          (Answer In [ 'C','D','F','G','H','L','N','P','Q','R','S','T','U' ]))
  1471.       Then AnsOK := True ;
  1472.    Until AnsOK ;
  1473.    If Answer = 'C' Then ComputeYHat ;
  1474.    If Answer = 'D' Then PrintDetails ;
  1475.    If Answer = 'F' Then FindOrigY ;
  1476.    If Answer = 'G' Then GetRegression ;
  1477.    If Answer = 'H' Then PrintHistogram ;
  1478.    If Answer = 'L' Then ListFiles ;
  1479.    If Answer = 'N' Then RunRegression ;
  1480.    If Answer = 'P' Then Plot ;
  1481.    If Answer = 'R' Then Report ;
  1482.    If Answer = 'S' Then SaveRegression ;
  1483.    If Answer = 'T' Then PrintTable ;
  1484.    If Answer = 'U' Then SetUpPrinter ;
  1485. End ; { Menu }
  1486.  
  1487.  
  1488.  
  1489. Begin  { M A I N  P R O G R A M }
  1490.    NoReg := True ; DataNotSaved := True ;
  1491.    SetUpPrinter ;
  1492.    Repeat Menu Until Answer In [ 'q' , 'Q' ] ;
  1493.    ExitPrompt ;
  1494. End .
  1495.  
  1496.