*! version 1.0.0   11/16/94                             STB-24: sg32
program define colldiag
	version 4.0
	if "$S_E_cmd" != "fit" {
		error 301
	}
	local varlist	"opt"
	local options   "noCONs"
	parse "`*'"

	local varlist	"$S_E_vl"
	local if	"$S_E_if"
	local in	"$S_E_in"
	local wgt	"$S_E_wgt"
	local exp	"$S_E_exp"

	local wtexp
	if "`wgt'" != "" & "`exp'" != "" {
		local wtexp = "[`wgt'`exp']"
	}

	parse "`varlist'", parse(" ")
	mac shift
	local varlist = "`*'"


	quietly {
		preserve
		tempvar use
		mark `use' `if' `in'
		markout `use' `varlist'
		if "`wgt'" != "" {
			qui replace `use'=0 if `wgt'==0
		}
		keep `varlist' `use'
		keep if `use'
		local nvif : word count `varlist'
		local np = `nvif'+1
		tempname tt
		gen `tt'=0
		parse "`varlist'", parse(" ")
		local i 1 
		while "``i''" != "" {
			local x`i' = "``i''"
			replace `tt' = `x`i''*`x`i''
			qui summ `tt'
			local c`i' = sqrt(_result(3))*sqrt(_result(1))
			local i = `i'+1
		}
		local c`np'=sqrt(_result(1))
		summ `varlist'
		local nobs = _result(1)
		local np = `nvif'+1
		local nn1 = `nobs'+1

		tempname X u v w phi phik pi vsq wva 
		if "`cons'"!="" {
			local np = `nvif'
		}
		local nr = 1/`c`np''
		capture matrix `X' = J(`nobs',`np',`nr')
		if _rc == 908 {
			capture set matsize `nn1'
			if _rc != 0 {
				noi di in red /*
*/ "This version of stata does not support matrix operations of this size"
				restore
				error _rc
			}
		}

		capture {
			local i 1
			while `i'<=`nobs' {
				local j 1
				while `j'<=`nvif' {
					matrix `X'[`i',`j'] = /* 
					*/ `x`j''[`i']/`c`j''
					local j = `j'+1
				}
				local i = `i'+1
			}

			matrix svd `u' `w' `v' = `X'
			local i 1
			while `i'<=`np' {
				if `w'[1,`i'] == 0.0 {
					matrix `w'[1,`i'] = 1e-12
				}
				local i = `i'+1
			}

			matrix `phi'  = J(`np',`np',0)
			matrix `phik' = J(1,`np',0)
			matrix `pi'   = J(`np',`np',0)

			local i 1
			while `i' <= `np' {
				local j 1
				while `j' <= `np' {
					scalar `vsq' = `v'[`i',`j']
					scalar `wva' = `w'[1,`j']
					matrix `phi'[`i',`j'] = /*
					*/ `vsq'/`wva'*`vsq'/`wva'
					matrix `phik'[1,`i'] = /*
					*/ `phik'[1,`i'] + `phi'[`i',`j']
					local j = `j'+1
				}
				local i = `i'+1
			}
			local i 1
			while `i' <= `np' {
				local j 1
				while `j' <= `np' {
					matrix `pi'[`i',`j'] = /*
					*/ `phi'[`j',`i'] / `phik'[1,`j']
					local j = `j'+1
				}
				local i = `i'+1
			}

		}
		if _rc {
			restore
			error _rc
		}
	}
	restore
	
	local j 0
	while `j' < `np'/7 {
		local vnames = ""
		di
		if `j' == 0 {
			di in green /*
		*/ "Proportion of variance associated with the decomposition"
		}
		di in green _col(3) "Cond   |"
		di in green _col(2) "Number  |" _col(11) _c
		local i = (`j')*7 + 1
		local nnm  0
		while `i' < ((`j'+1)*7) & `i' < `np' {
			local name8 = "`x`i''"
			local len = length("`name8'")
			local skip = 9 - `len'
			di in green _col(`skip') "`name8'" "  " _c
			local i = `i'+1
			local nnm = `nnm'+1
		}
		local name8 = "`x`i''"
		local len = length("`name8'")
		local skip = 9 - `len'
		if "`name8'" != "" {
			di in green _col(`skip') "`name8'"
		}
		else {
			di in green _col(4) "_cons" 
		}
		local i = `i'+1
		local nnm = (`nnm'+1)*10-2
		di in green _col(1) _dup(9) "-" "+" _dup(`nnm') "-"
		local k = 1
		while `k' <= `np' {
			di in ye %8.0g `w'[1,1]/`w'[1,`k'] in gr " |  " _c
			local m = `j'*7 + 1
			while `m' < `i' {
				if `m' < `i'-1 {
					di in ye %6.4f `pi'[`k',`m'] "    " _c
				}
				else {
					di in ye %6.4f `pi'[`k',`m'] 
				}
				local m = `m'+1
			}
			local k = `k'+1
		}
		local j = `j'+1
	}
end
exit
----+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8

         |                        Proportion of variance
  Cond   |                  associated with the decomposition
 Number  | Varname1  Varname2  Varname3  Varname4  Varname5  Varname6  Varname7
---------+---------------------------------------------------------------------
xxxxxxxx |   123456    123456    123456    123456    123456    123456    123456