Public strAssignVarArray() As String
Public strYSelected As String
Public strXSelected As String
Public objDataDoc As ISpssDataDoc
Public objOutputDoc As ISpssOutputDoc
Sub Main

	Dim objDocuments As ISpssDocuments
	Dim ingNumber As Integer
	Dim objSpssInfo As ISpssInfo
	Dim retcode As Integer
	Dim objOptions As ISpssOptions

	Set objDocuments = objSpssApp.Documents
	Set objDataDoc = objDocuments.GetDataDoc(0)
		
	Set objSpssInfo = objSpssApp.SpssInfo
	ingNumber=objSpssInfo.NumVariables
	If ingNumber < 1 Then
		retcode =MsgBox( "No variables defined", 0 ,"Cluster Assignments")
		End
	End If

	'we'll call a function which returns variables selected
	'by the user in an array of strings we pass it.
	Dim strVarsSelected() As String
	Dim strXList() As String
	Dim i As Integer
	Dim j As Integer
	Dim lngNumber As Long
	Dim strSpssVars() As String
	Dim strTemp As String

	lngNumber = objSpssInfo.NumVariables
	ReDim strSpssVars (lngNumber)
	For i = 0 To lngNumber - 1
		strSpssVars(i) = objSpssInfo.VariableAt(i)
	Next i

	Call DisplayYDialog (strSpssVars)

	Call DisplayXDialog (strSpssVars)

	Call Get_Rho()

End Sub
Sub Get_Rho()

	Dim i As Integer
	Dim j As Integer
	Dim k As Integer

	' Get the number of cases in the file:
	Dim strNCases As String
	strNCases = CStr(objDataDoc.GetNumberOfCases)
	Dim lngNCases As Long
	lngNCases = CLng(strNCases)

	'Get the data
	Dim strDat() As String
	ReDim strDat(lngNCases, 2)
	Dim ValidCase()
	ReDim ValidCase(lngNCases)
	Dim dX() As Double
	Dim strTextDat As Variant
	Dim dY() As Double
	Dim nValidCases As Long
	Dim nCases As Long
	Dim YHat As Double
	Dim Residual() As Double


	'Get the dependent variable

	strTextDat = objDataDoc.GetTextData(strYSelected,strYSelected,1,lngNCases)

	For i = 0 To lngNCases-1
		strDat(i,0) = strTextDat(0,i)
	Next i

	'Now get the independent variable

	'Get string data and remove cases with missing values

	strTextDat = objDataDoc.GetTextData(strXSelected,strXSelected,1,lngNCases)
	For j = 0 To lngNCases-1
		strDat(j,1) = strTextDat(0,j)
	Next j

	For i = 0 To lngNCases-1
		ValidCase(i) = 1
		For j = 0 To 1
			If IsNumeric(strDat(i,j)) = False Then
				ValidCase(i) = 0
			End If
		Next j
	Next i

	nValidCases = 0
	For i = 0 To lngNCases-1
		nValidCases = nValidCases + ValidCase(i)
	Next i

	ReDim dY(nValidCases)
	ReDim dX(nValidCases)
	ReDim Residual(nValidCases)

	nCases = lngNCases
	lngNCases = nValidCases

	k = 0
	For i = 0 To nCases-1
		If ValidCase(i) = 1 Then
			dY(k) = CDbl(strDat(i,0))
			dX(k) = CDbl(strDat(i,1))
			k = k + 1
		End If
	Next i

	Dim n As Double
	n = CDbl(nValidCases)

	Dim Rho As Double
	Dim NewRho As Double
	Dim b0 As Double
	Dim b1 As Double
	Dim YStar() As Double
	ReDim YStar(lngNCases)
	Dim XStar() As Double
	ReDim XStar(lngNCases)
	Dim SXY As Double
	Dim SX As Double
	Dim SY As Double
	Dim SXX As Double

	'Get Ready to start iterations

	'Compute the initial set of residuals to get the starting rho

	Call Simple_Regression(dX, dY, 0, lngNCases, b0, b1)
	Call MakeResidual(dX, dY, b0, b1, lngNCases, Residual)
	NewRho = RhoHat(Residual, lngNCases)

	Dim EPS As Double
	EPS = .01
	Dim MAXITS As Integer
	MAXITS = 1
	Dim ItNo As Integer
	ItNo = 0.0
	Rho = 0

	While Abs(NewRho - Rho) > EPS And ItNo < MAXITS

		Rho = NewRho
		Call MakeStar(dX, Rho, lngNCases, XStar)
		Call MakeStar(dY, Rho, lngNCases, YStar)
		Call Simple_Regression(XStar, YStar, Rho, lngNCases, b0, b1)
		Call MakeResidual(dX, dY, b0, b1, lngNCases, Residual)
		NewRho = RhoHat(Residual, lngNCases)

		ItNo = ItNo + 1

	Wend

	'Compute Final Regression

	Call MakeStar(dX, Rho, lngNCases, XStar)
	Call MakeStar(dY, Rho, lngNCases, YStar)
	Call Simple_Regression(XStar, YStar, Rho, lngNCases, b0, b1)
	Call MakeResidual(dX, dY, b0, b1, lngNCases, Residual)

	'Compute R-square and the Durbin-Watson statistic

	Dim RSquare As Double
	Dim SYY As Double
	Dim ESS As Double
	Dim TSS As Double
	Dim EHatSS As Double
	Dim DW As Double
	Dim EHat() As Double
	ReDim EHat(lngNCases)
	Call MakeResidual(XStar, YStar, b0*(1-Rho), b1, lngNCases, EHat)

	SYY = 0.0
	ESS = 0.0
	EHatSS = 0.0
	DW = 0.0

	For i = 0 To lngNCases-1
		SYY = SYY + dY(i)*dY(i)
		ESS = ESS + Residual(i)*Residual(i)
		EHatSS = EHatSS + EHat(i)*EHat(i)
	Next i
	For i = 1 To lngNCases-1
		DW = DW + (EHat(i)-EHat(i-1))*(EHat(i)-EHat(i-1))
	Next i

	TSS = SYY - n*YBar*YBar
	RSquare = 1.0 - ESS/TSS
	DW = DW/EHatSS

	'Now output the results
	Dim Count As Integer
	Set objDocuments = objSpssApp.Documents
	Count = objDocuments.OutputDocCount

	If Count > 0 Then
		Set objOutputDoc = objDocuments.GetOutputDoc(0)
		objOutputDoc.Visible = True
	Else
		' Open a new output document:
		Set objOutputDoc = objSpssApp.NewOutputDoc
		' Make the document visible:
		objOutputDoc.Visible = True
	End If

	Set objItems = objOutputDoc.Items
	Set objItem = objItems.GetItem(objItems.Count-1)
	objItem.Current = True

	index = objOutputDoc.InsertTable (cNEWTABLE, 5, 2, 1)

	Set objItems = objOutputDoc.Items
	Set objItem = objItems.GetItem(objItems.Count-1)
	Set objPivotTable = objItem.Activate
	objPivotTable.UpdateScreen = False

	Set objLayerLabels = objPivotTable.LayerLabelArray
	Set objPivMgr = objPivotTable.PivotManager
	Set objLayerDim = objPivMgr.LayerDimension(0)
	intLay = objLayerDim.NumCategories

	objLayerLabels.ValueAt(0,2) = "Cochrane-Orcutt Procedure"

	' Insert values in the pivot table
	Dim strFormat As Variant
	strFormat = "#.#"
	objLayerDim.CurrentCategory = 0
	Set objDataCells = objPivotTable.DataCellArray

	objDataCells.SelectCellAt (0, 0)
	objDataCells.ValueAt (0, 0) = "b0"
	objPivotTable.ClearSelection
	objDataCells.SelectCellAt (1, 0)
	objDataCells.ValueAt (1, 0) = "b1"
	objPivotTable.ClearSelection
	objDataCells.SelectCellAt (2, 0)
	objDataCells.ValueAt (2, 0) = "Rho"
	objPivotTable.ClearSelection
	objDataCells.SelectCellAt (3, 0)
	objDataCells.ValueAt (3, 0) = "R-Square"
	objPivotTable.ClearSelection
	objDataCells.SelectCellAt (4, 0)
	objDataCells.ValueAt (4, 0) = "Durbin-Watson"
	objPivotTable.ClearSelection

	objDataCells.SelectCellAt (0, 1)
	objPivotTable.NumericFormat (strFormat, 4)
	objDataCells.ValueAt(0, 1) = CStr(b0)
	objPivotTable.ClearSelection
	objDataCells.SelectCellAt (1, 1)
	objPivotTable.NumericFormat (strFormat, 4)
	objDataCells.ValueAt(1, 1) = CStr(b1)
	objPivotTable.ClearSelection
	objDataCells.SelectCellAt (2, 1)
	objPivotTable.NumericFormat (strFormat, 4)
	objDataCells.ValueAt(2, 1) = CStr(NewRho)
	objPivotTable.ClearSelection
	objDataCells.SelectCellAt (3, 1)
	objPivotTable.NumericFormat (strFormat, 4)
	objDataCells.ValueAt(3, 1) = CStr(RSquare)
	objPivotTable.ClearSelection
	objDataCells.SelectCellAt (4, 1)
	objPivotTable.NumericFormat (strFormat, 4)
	objDataCells.ValueAt(4, 1) = CStr(DW)
	objPivotTable.ClearSelection

	Dim intWidth As Integer
	intWidth = 144

	' Reset the width for the columns:
	objDataCells.ReSizeColumn (0, intWidth)
	objDataCells.ReSizeColumn (1, intWidth)

	objItem.Deactivate


End Sub
Sub DisplayYDialog(strSpssVars() As String)

	Begin Dialog UserDialog 400,203,"Select Dependent Variable", .DlgFreq ' %GRID:10,7,1,1
		ListBox 80,21,90,133,strSpssVars(),.ListBox1
		OKButton 280,42,90,21, .cmdOK
		CancelButton 290,98,70,21, .cmdCancel
	End Dialog
	Dim dlg As UserDialog
	Dialog dlg

End Sub
Function DlgFreq%(DlgItem$, Action%, SuppValue%)

	Select Case Action%
	Case 1 ' Dialog box initialization

	Case 2 ' Value changing or button pressed

		Select Case DlgItem$
		Case "cmdOK"
			strYSelected = DlgText("ListBox1")
			Exit Function
		Case "cmdCancel"
			Exit Function
		End Select

	Case 3 ' TextBox or ComboBox text changed

	Case 4 ' Focus changed

	Case 5 ' Idle

	End Select

End Function
Sub DisplayXDialog(strSpssVars() As String)

	Begin Dialog UserDialog 400,203,"Select Independent Variable", .DlgXFreq ' %GRID:10,7,1,1
		ListBox 80,21,90,133,strSpssVars(),.ListBox1
		OKButton 280,42,90,21, .cmdOK
		CancelButton 290,98,70,21, .cmdCancel
	End Dialog
	Dim dlg As UserDialog
	Dialog dlg

End Sub
Function DlgXFreq%(DlgItem$, Action%, SuppValue%)

	Select Case Action%
	Case 1 ' Dialog box initialization

	Case 2 ' Value changing or button pressed

		Select Case DlgItem$
		Case "cmdOK"
			strXSelected = DlgText("ListBox1")
			Exit Function
		Case "cmdCancel"
			Exit Function
		End Select

	Case 3 ' TextBox or ComboBox text changed

	Case 4 ' Focus changed

	Case 5 ' Idle

	End Select

End Function
Sub MakeStar(x() As Double, Rho As Double, n As Long, ByRef XStar() As Double)

	Dim i As Integer

	XStar(0) = x(0)*Sqr(1-Rho*Rho)
	For i = 1 To n-1
		XStar(i) = x(i) - Rho*x(i-1)
	Next i

End Sub
Sub MakeResidual(x() As Double, y() As Double, b0 As Double, b1 As Double, n As Long, ByRef e() As Double)

	Dim i As Integer

	For i = 0 To n-1
		e(i) = y(i) - b0 - b1*x(i)
	Next i

End Sub
Sub Simple_Regression(x() As Double, y() As Double, Rho As Double, n As Long, ByRef b0 As Double, ByRef b1 As Double)

	Dim i As Integer

	Dim SXY As Double
	Dim SX As Double
	Dim SY As Double
	Dim SXX As Double

	SXY = 0.0
	SX = 0.0
	SY = 0.0
	SXX = 0.0
	For i = 0 To n-1
		SXY = SXY + x(i)*y(i)
		SX = SX + x(i)
		SY = SY + y(i)
		SXX = SXX + x(i)*x(i)
	Next i
	b1 = ((n-start)*SXY - SX*SY)/((n-start)*SXX - SX*SX)
	b0 = (SY/(n-start) - b1*SX/(n-start))/(1-Rho)

End Sub
Function RhoHat(ehat() As Double, n As Long)

	Dim i As Integer
	Dim SXY As Double
	Dim SXX As Double

	SXY = 0.0
	SXX = 0.0
	For i = 1 To n-1
		SXY = SXY + ehat(i)*ehat(i-1)
	Next i
	For i = 0 To n-2
		SXX = SXX + ehat(i)*ehat(i)
	Next i
	RhoHat = SXY/SXX

End Function