ml_5.ado

是一个经济学管理应用软件 很难找的 但是经济学学生又必须用到

			noi $S_mlfunc `fmh`i'' `arglist'


			noi adjustS `S' `f' `x0' `fmh`i'' `x`i'' `h`i'' /*
				*/ "`arglist'"
			scalar `h`i'' = float(`h`i''*`S')


			replace `x`i'' = `x0' + `h`i''
			gen double `fph`i'' = .
			noi $S_mlfunc `fph`i'' `arglist'/* fph`i'=f(X+hi) */


			gen double `grad'=$S_mlwgt* /*
				*/ (`fph`i''-`fmh`i'')/(2*`h`i'')
			matrix vecaccum `wrk' = `grad' `vl`i'', nocons
			mat subst `d'[1,`se'] = `wrk'
			drop `grad'

					 		/* Dii calculation */
			gen double `Dii' = $S_mlwgt* /*
				*/ (`fph`i''-2*`ff'+`fmh`i'')/(`h`i''^2)
			summ `Dii' if $S_mlwgt
			scalar `nfac' = _result(3)
/* using wrk */
			matrix accum `wrk'= `vl`i'' [iw=-`Dii'/`nfac'], nocons
			if _result(1)!=0 { 
				mat `wrk' = `wrk' * `nfac'
				mat subst `h'[`se',`se'] = `wrk'
			}
/* wrk now free */

			/*
				update scale to min( sqrt(|f/f''|, |x|/epsf )
				unless f/f'' is missing, then use |x| as 
				scale.
				thus, maximum h next time is x.
				note, that S will be used on the next
				iteration to produce h`i'
			*/

			drop `Dii'


			if `fast'>1 {		/* Dij calculation */
				local nei = `ee' - `se' + 1
				local nei1 = `nei' + 1
				local j 1
				while `j' < `i' { /* wrap */
rename `x`j'' `xj0'
gen double `x`j'' = `xj0' + `h`j''
gen double `fphh' = . 
noi $S_mlfunc `fphh' `arglist'

drop `x`j''
gen double `x`j'' = `xj0' - `h`j''
replace `x`i'' = `x0' - `h`i''
gen double `fmhh' = . 
noi $S_mlfunc `fmhh' `arglist'
replace `x`i'' = `x0' + `h`i''
drop `x`j''

gen double `Dij' = $S_mlwgt * /*
*/ (`fphh'+`fmhh'+2*`ff'-`fph`i''-`fmh`i''-`fph`j''-`fmh`j'' ) /*
*/ / (2*`h`i''*`h`j'')

* gen double `Dij' = $S_mlwgt * (`fphh'-`fph`i''-`fph`j''+`ff')/(`h`i''*`h`j'')
summ `Dij' if $S_mlwgt
scalar `nfac' = _result(3)
								/* use wrk */
mat accum `wrk' = `vl`i'' `vl`j'' [iw=-`Dij'/`nfac'], nocons
if _result(1) != 0 {
	mat `wrk' = `wrk'[1..`nei',`nei1'...]
	mat `wrk' = `wrk' * `nfac'

	local sej : word `j' of $S_mlfsd

	mat subst `h'[`se',`sej'] = `wrk'
	mat `wrk' = `wrk' '
	mat subst `h'[`sej',`se'] = `wrk'
}
								/* wrk free */
drop `Dij' `fphh' `fmhh'
rename `xj0' `x`j''

local j=`j'+1
				} /* wrap */
			} /* Dij */

			drop `x`i''
			rename `x0' `x`i''

			local i=`i'+1
		} /* i loop */
	} /* quietly */


	if ("$S_mldbug"=="1") {
		mat list `d', title(derivative)
		mat list `h', title(Hessian)
	}
end

/*
	global assumptions:

		S_mlfeq		number of equations

		S_mlfsd		beginning index in b of equations
		S_mlfed		ending index in b of equations

		S_mlfn		dimension of problem
*/

program define setup /* b    (which is properly named) */
	version 4.0, missing

	local b "`1'"

	local vname : colnames(`b')
	local ename : coleq(`b')

	local i 1
	local eq 1
	local se 1
	local e1 : word 1 of `ename'
	while (`i'<=colsof(matrix(`b'))) {
		local vn : word `i' of `vname'
		local en : word `i' of `ename'
		if ("`en'"!="`e1'") {
			local ee = `i'-1
			local eq = `eq'+1
			local sdim "`sdim' `se'"
			local edim "`edim' `ee'"
			local e1 "`en'"
			local se "`i'"
		}
		local i = `i' + 1
	}
	local bdim = colsof(matrix(`b'))
	local sdim "`sdim' `se'"
	local edim "`edim' `bdim'"

	global S_mlfeq `eq'
	global S_mlfsd "`sdim'"
	global S_mlfed "`edim'"
	global S_mlfn `bdim'
end

program define alldone
	version 4.0, missing
	global S_mlfeq
	global S_mlfsd
	global S_mlfed
	global S_mlfn
	global S_mlfS
end

program define adjustS /* f x0 fmhi xi hi "arglist" */
	version 4.0, missing
	local S		"`1'"	/* scalar name	*/
	local f 	"`2'"	/* scalar name 	*/
	local x0 	"`3'"	/* varname	*/
	local fmhi 	"`4'"	/* varname	*/
	local xi 	"`5'"	/* varname 	*/
	local hi	"`6'"	/* scalar name	*/
	local arglist	"`7'"

	tempvar fatS

	qui gen double `fatS' = sum(`fmhi'*$S_mlwgt)

	local ep0 1e-8
	local ep1 1e-7
	local epmin 1e-10

	local goal0 = (abs(scalar(`f'))+`ep0')*`ep0'
	local goal1 = (abs(scalar(`f'))+`ep1')*`ep1'
	local mgoal = (`goal0'+`goal1')/2
	local mingoal = (abs(scalar(`f'))+`epmin')*`epmin'

	local df = abs(scalar(`f')-`fatS'[_N])

	tempname newS
	local lastS .
	local iter 1

	while (`df'<`goal0' | `df'>`goal1') & `iter' <= 40 {
		if `df'<`mingoal' {
			scalar `newS' = `S'*2
		}
		else {
			if `lastS'>=. {
				scalar `newS'=`S'*cond(`df'<`goal0',2,.5)
			}
			else {
				/* f(0) = 0, f(S)=df, f(lastS)=lastdf */
				local a = (`lastdf'/`lastS'-`df'/`S') / /*
						*/ (`lastS'-`S')
				local b = `df'/`S' - `a'*`S'
				local r1 = ( /*
				*/ -`b' + sqrt(`b'*`b'+4*`a'*`mgoal') /* 
				*/ ) / (2*`a')
				scalar `newS'=`S'*cond(`df'<`goal0',2,.5)
				if `df'>`goal1' & `r1'>0 & `r1'<`S' {
					scalar `newS' = `r1'
				}
				else if `df'<`goal0' & `r1'>`S' & `r1'< . {
					scalar `newS' = `r1'
				}
			}
		}
		local lastS = `S'
		local lastdf= `df'

		scalar `S' = `newS'
		qui replace `xi' = `x0' - float(`hi'*`S')
		qui replace `fmhi' = .
		$S_mlfunc `fmhi' `arglist'
		qui replace `fatS' = sum(`fmhi'*$S_mlwgt)
		local df = abs(scalar(`f')-`fatS'[_N])
		local iter = `iter' + 1
	}
	if `df'<`goal0' | `df'>`goal1' { /* did not meet goal */
		di in red "$S_mlfunc does not compute a continuous " /*
		*/ "nonconstant function" _n /*
		*/ "could not calculate numerical derivatives"
		exit 430
	}
end


*  mx_marq.ado:  version 3.0.2 18apr1995
program define mx_marq
	version 4.0, missing
	local inv `1'
	local hh `2'
	local add `3'
	local multipl `4'
	local bad `5'               /* must be a scalar */
	local ok 0
	tempname md iadd mult2

	local rr = colsof(`hh')

	while (!`ok') {
		if (`bad') {
			scalar `add' = (`add'+1) * 10
			scalar `multipl' = (`multipl'+2)^1.25
		}
		else {
			scalar `add' = (`add') / 10
			scalar `multipl' = `multipl'^0.8
		}
		* di "add = " `add' " multipl = " `multipl'
		if (`add'<.1 & `multipl'<1.1) { scalar `multipl' = 1 }
		if (`multipl'>1) {
			mat `md' = vecdiag(`hh')
			mat `iadd' = J(1,`rr',`add')
			mat `md' = `iadd' + `md'
			scalar `mult2' = `multipl' - 1
			mat `md' = `md' * `mult2'
			mat `md' = diag(`md')
			mat `inv' = `hh' + `md'
			mat `inv' = syminv(`inv')
		}
		else 	mat `inv' = syminv(`hh')

		local j 1
		local ok 1
		while (`j'<=`rr') {
			if (`inv'[`j',`j']==0 & `hh'[`j',`j']!=0) { local ok 0 }
			local j = `j' + 1
		}
		if (!`ok') { scalar `bad' = `bad' + 1 }
	}
end


*  mx_meth:  version 1.0.2  07/17/93
program define mx_meth
	version 3.1, missing
	if "`1'"=="user" & "`2'"!="" & "`3'"=="" {
		global S_mlmeth `2'
		exit
	}
	if ("`1'"=="" | "`2'"!="") {
		error 198
	}
	if ("`1'"=="lf") {global S_mlmeth mx_lf}
	else if ("`1'"=="deriv0") { global S_mlmeth mx_d0 }
	else if ("`1'"=="deriv1") { global S_mlmeth mx_d1 }
	else if ("`1'"=="deriv2") { global S_mlmeth mx_d2 }
	else {
		di in red "unknown method `1'"
		exit 198
	}
end


*  mx_model:  version 1.0.3  11dec1995
program define mx_model
	version 4.0, missing
	parse "`*'", parse(" =")
	local b `1'
	if "`2'" != "=" { error 198 }
	mac shift 2
	_crceprs `*'
	local options "NOCONstant CONstant(string) DEpv(string) FRom(string)"
	local eqnames "$S_1"
	parse "$S_2"
	if "`noconst'"!="" {
		if "`constan'"!="" { error 198 }
		local constan 0
	}
	else if "`constan'"=="" {
		local constan 1
	}
	if "`depv'"=="" { local depv "1" }
	parse "`eqnames'", parse(" ")
	tempname s bb
	global S_mlneq 0
	global S_mlmdf 0
	global S_mldepn
	cap mat drop `b'
	local k 0 
	while "`1'"!="" {
		local k = `k' + 1 
		local depve = substr("`depv'",min(`k',length("`depv'")),1)
		confirm integer number `depve'
		local coneq = substr("`constan'",min(`k',length("`constan'")),1)
		confirm integer number `coneq'
		if `coneq'!=0 & `coneq'!=1 {
			di in red "constant() must contain only 0's or 1's"
			error 198
		}
		eq ? `1'
		if `coneq' { global S_1 "$S_1 _cons" }
		local j : word count $S_1
		global S_mleqn = "$S_mleqn $S_3"
		local eqn "$S_3"
		global S_mlneq = $S_mlneq + 1
		global S_mlmdf = $S_mlmdf + `j' - `coneq'
		matrix `bb' = J(1,`j',0)
		matrix colnames `bb' = $S_1
		if `depve' {
			local i 1
			while `i'<=`depve' {
				local one : word `i' of $S_1
				if "`one'"=="" { 
					di in red /*
				*/ "equation `eqn' contains too few variables"
					exit 102
				}
				global S_mldepn "$S_mldepn `one'"
				matrix `bb' = `bb'[1,2...]
				global S_mlmdf = $S_mlmdf - 1 
				local i = `i' + 1
			}
		}
		matrix coleq `bb' = `1'
		cap matrix `s' = `from'[1,"`1':"]
		if _rc & $S_mlneq==1 {
			local 1 "_"
			cap matrix `s' = `from'[1,"`1':"]
		}
		if _rc==0 {
			local j  1
			local c: colnames(`s')
			while `j'<=colsof(`s') {
				local n : word `j' of `c'
				local cc = colnumb(`bb',"`n'")
				if `cc'< . {
					mat `bb'[1,`cc'] = `s'[1,`j']
				} 
				local j = `j' + 1
			}
		}
		matrix `b' = `b' , `bb'
		mac shift
	}
	if $S_mlneq==1 { matrix colnames `b' = _: }
	global S_mlmb `b'
end



*  mx_mx1:  version 1.0.8  20Apr1995
program define mx_mx1
	version 4.0, missing
	parse "`*'", parse(" ,")
	local b $S_mlmb     /* starting values on entrance */
	global S_mlsf `1'
	local f $S_mlsf     /* scalar name to contain function value */
	global S_mlmv `2'
	local v $S_mlmv     /* matrix name to contain variance matrix */


	mac shift 2
	local options "DACC(real 1e-5) Fcnlabel(string) STYLE(int 0) LTOLera(real 1e-6) TOLeran(real 1e-6) ITERate(int `c(maxiter)') TRace"
	parse "`*'"

	if "`fcnlabe'" == "" {
		local fcnlabe "Log Likelihood"
	}

	local method $S_mlmeth
	if ("`method'"=="mx_d2") { local method $S_mlfunc }
	else if "`method'"=="mx_lf" {
		local dim : coleq(`b')
		local dim : word count `dim'
		global S_mlfS
		local i 1
		while `i'<=`dim' {
			tempvar base		/* base just temporary */
			global S_mlfS "$S_mlfS `base'"
			local i=`i'+1
		}
	}

	global S_mlag `dacc'      /* accuracy goal if double precision */
	global S_mlsag 1
	local FUZZ 2e-10
	tempname taa tab tbb tdd fixlist sltollc dll ratio dllold add multipl cosine
	tempname fbase ftry d0 b0 f0 d1 b1 f1 d2 b2 f2 i2 dnorm step0 step1 step2 h hh
	tempname astep astep1 astep2 bad agoal fnext
	local dim = colsof("`b'")
	matrix `b0' = `b'
	matrix `astep' = `b' * 0
	matrix `fixlist'=J(1,`dim',0)
	scalar `dll' = 0
	if ("`trace'"!="") { mat list `b0', nohead nonames noblank }
	local myfast 2 /* start optimistic */
	`method' `b0' `f0' `d0' `h' , firstit fast(`myfast')
	if `f0' < -9.99e29 {
		di in red "Initial starting values not feasible."
		global S_mlfS
		exit 1400
	}
	scalar `f' = `f0'
	global S_ll0 = `f0'
	di in gr "Iteration 0:  `fcnlabe' = " in ye %10.0g `f0'
	local iter  0
	local base 0
	local try  1
	local next 2
	local conv  0
	local mycn : colnames(`b')
	local mycen : coleq(`b')
	scalar `add' = 0
	scalar `multipl' = 1