b34sexec options debugsubs(wait); b34srun; /$ # 1 runs without key strokes /$ # 2 /$ # 3 /$ # 4 /$ # 5 /$ # 6 runs without key strokes takes less time %b34slet bug =0; %b34slet bug2 =0; %b34slet test1=1; %b34slet test2=0; %b34slet test3=0; %b34slet test4=0; %b34slet test5=0; %b34slet test6=1; %b34sif(&test1.eq.1)%then; /; /;ACF ACF(series,n) Autocorrelation Function /; b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; acf1=acf(gasout,24,se1,pacf1); call graph(acf1,pacf1 :nokey :heading 'ACF & PACF of Gasout'); call graph(acf(dif(gasout),24) :Heading 'ACF of Gasout(1-B)'); call graph(acf(dif(gasout,2,1),24) :heading 'ACF of Gasout(1-B)**2'); acf2=acf(gasin,24,se2,pacf2); call graph(acf2,pacf2 :nokey :heading 'ACF & PACF of Gasin'); call graph(acf1,SE1 :nokey :heading 'ACF and SE of ACF of Gasout'); i=integers(24); call tabulate(i,acf1,acf2,se1,se2,pacf1,pacf2); call print('ACF, SE, PACF, Modified Q Prob Q for gasin':); acf2=acf(gasin,24, se2,pacf2,mq2,pmq2); call tabulate(acf2,se2,pacf2,mq2,pmq2); call graph(acf2,pmq2); call graph(acf2 se2 :overlay acfplot /$ Un comment next line to get a hard copy /$ :file 'testacf.wmf' :heading 'Overlay plot of ACF of gasin'); call graph(pacf2 se2 :overlay acfplot3d :heading '3D Overlay plot of PACF of gasin'); call graph(acf2 :overlay acfplot :heading 'Just plot of ACF of gasin'); call graph(gasin gasout :heading 'Scaled Plot of gasin gasout' :nokey :scale :plottype obsplot); n=400; rr=rn(array(n:)); acf1=acf(rr,24,se1); acf2=acf(dif(rr) ,24,se2); acf3=acf(dif(rr,2,1),24,se3); call graph(acf1,se1 :overlay acfplot :heading 'ACF of Random series'); call graph(acf2,se2 :overlay acfplot :heading 'ACF of rn(1-B)'); call graph(acf3,se3 :overlay acfplot :heading 'ACF of rn(1-B)**2'); b34srun$ /$ Tests using bjiden command b34sexec bjiden nac =36 npac=36; var =gasin ; rauto gasin ; b34srun; /; /;ACF_PLOT Illustrate ACF_Plot Subroutine /; b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; call load(acf_plot); call acf_plot(gasout,24,namelist(gasout)); b34srun; /; /;ADDCOL call addcol(matx,n,i) Adds i Cols to matx before n /; b34sexec matrix; n=3; x=matrix(n,n:integers(1,n*n)); call print(x); test=x; call addcol(test); call print('We add at the right',test); test=x; call addrow(test,2,4); call print('We add 4 cols after 1 and before old 2',test); b34srun; /; /;ADDROW Illustrates Addrow Capability /; b34sexec matrix; n=3; x=matrix(n,n:integers(1,n*n)); call print(x); test=x; call addrow(test); call print('We add at the end',test); test=x; call addrow(test,2,4); call print('We add 4 rows after 2 and before old 3',test); b34srun; /; /;AFAM Illustrates AFAM Command /; b34sexec matrix$ x=matrix(3,3:); call print(x); x1=matrix(3,3:1 2 3 4 5 6 7 8 9); call print(x1); v=vector(4:1 2 3 4); xx=matrix(2,2:v); call print(xx); ax=afam(x); call print(ax); av=afam(v); call print(v); b34srun; /; /;AGGDATA Aggregate Data /; b34sexec matrix; id=10.; x=20.1; call aggdata(id,x,newx,newid); call print(id,x,newx,newid,%nelm,%nnzero,%varx); id=array(6:10. 10. 11. 11. 11. 12.); x= array(6:1 2 3 4 5 6); call tabulate(id,x); call aggdata(id,x,newx,newid); call tabulate(newx,newid,%nelm,%nnzero,%varx); b34srun; /; /;ALIGN Align Series that have missing Data /; b34sexec matrix; n=10; x=rn(array(n:)); y=rn(x); call tabulate(x,y); i=integers(1,n,2); x(i)=missing(); call tabulate(x,y); call align(x,y); call tabulate(x,y); b34srun; /; /;ARMA Tests ARMA Command on Gasin Series /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; /$ Model Discussed in Box-Jenkins and in Stokes (1997) /$ For raw gasin the setup :nar 3 => problems /$ ACF of raw series indicates have or nearly have a unit root!! /$ :nar 2 is OK call loaddata; * :nar 3 :nma 1 will fail as too complex ; call arma(gasin :nar 2 :nma 1 :forecast 296 24 :print); call graph(%res); call graph(%y,%yhat); acf1=acf(%res); call graph(acf1); call print(acf1); call arma(dif(gasin) :nar 3 :forecast 295 24 :print); call graph(%res); call graph(%y,%yhat); acf1 = acf(%res); acf2 = acf(dif(gasin)); acfraw = acf(gasin); call graph(acf1,acf2); call tabulate(acf1,acf2,acfraw); call df(gasin,df); call pp(gasin,pp); call print(df,pp); b34srun; /; /;ARMA_1 Shows more Options of ARIMA /; b34sexec options ginclude('gas.b34'); b34srun; /$b34sexec reg residualp; /$model gasout = gasout{1}; b34srun; b34sexec matrix; * Model Discussed in Box-Jenkins and in Stokes (1997); call loaddata; call arma(gasout :maxit 2000 :relerr 0.0 :nar 8 :nma 0 :forecast 296 24 :print); call names(info); call print(%arparms,%maparms); call print(%rss,%const); /$ Tests AR1 model /$test=array(norows(gasout)+1:); /$test(1)=-9999.; /$call echooff; /$do i=2,norows(gasout)+1; /$test(i)=%const + (%arparms(1)*gasout(i-1)); /$enddo; /$ call tabulate(gasout,test); call tabulate(%resobs,%y,%res,%yhat); call print(%yvar,%arorder,%arparms); call graph(%res); call graph(%y,%yhat); call graph(acf(%res)); call tabulate(%foreobs,%fcast,%fconf,%fpsi); b34srun; /; /;ARMA_2 Tests ARMA Command on Real Money /; /$ Problem discussed in Stokes (1979) and Stokes-Neuburger (1979) b34sexec options ginclude('b34sdata.mac') member(res79); b34srun; b34sexec matrix; call loaddata; /$ Depending on if we log or not get Het Model !! /$ Usual ACF does not detect this !!!! diff2rm=dif(dlog(fmscom),2,1); /$ diff2rm=dif(fmscom,2,1); call graph(diff2rm); call arma(diff2rm :nar 3 :maxit 8000 :itprint :print); call graph(%res); call graph(%y,%yhat); acfres=acf(%res,30); acfy =acf(%y,30); call graph(acfy,acfres :nokey); call tabulate(acfres,acfy); * restricted model ; call arma(diff2rm :nar 1 :maxit 8000 :maorder idint(array(:3,4,7)) :itprint :print); call graph(%res); call graph(%y,%yhat); call graph(acf(%res)); call graph(%res); call graph(%y,%yhat); acfres=acf(%res,30); acfy =acf(%y,30); call graph(acfy,acfres :nokey); call tabulate(acfres,acfy); b34srun; /; /;ARMA_3 ARMA (using MM) of generated model /; b34sexec matrix; * We generate a series and use Method of Moments to get Coef; n=10000; nacf=30; call free(ma); ar= array(:-.9 ); nn=100; start=array(:.1); test1=genarma(ar,ma,1.0,start,.1,n,nn); call graph(test1); call arma(test1 :nar 1 maxit 8000 :itprint :print); call graph(%res); call graph(%y,%yhat); acfres = acf(%res,nacf); acfy = acf(%y, nacf); call graph(acfy,acfres :nokey); call tabulate(acfres,acfy); b34srun; /; /;ARMA_4 ARMA of generated model shows refine /; b34sexec matrix; * We generate a series and use Method of Moments to get Coef; n=10000; nacf=30; call free(ma); ar= array(:-.9 ); nn=100; start=array(:.1); test1=genarma(ar,ma,1.0,start,.1,n,nn); call graph(test1); call arma(test1 :nar 4 maxit 8000 :itprint :refine 2. :print); call graph(%res); call graph(%y,%yhat); acfres = acf(%res,nacf); acfy = acf(%y, nacf); call graph(acfy,acfres :nokey); call tabulate(acfres,acfy); b34srun; /; /;ARMA_5 Various ARMA Tests using Subroutines /; b34sexec matrix; * We generate series and use Method of Moments to get Coef; * MM Gets a good starting values for unrestricted models ; program testit; nn=100; test1=genarma(ar,ma,1.0,start,.1,n,nn); call graph(test1); call arma(test1 :nar nar :maxit 8000 :nma nma :refine 2. :print); call graph(%res); call graph(%y,%yhat); acfres = acf(%res,nacf); acfy = acf(%y, nacf); call graph(acfy,acfres :nokey); call tabulate(acfres,acfy); return; end; n=10000; nacf=30; * Model is way too big !!!! ; * Refine removes excess paramaters ; nar=9; nma=0; call free(ma); call free(ar); if(nar.gt.0)ar= array(: .70, -.43 ); if(nma.gt.0)ma= array(:-.6 ); start=array(:.1 .1); call testit; * Correct Model ; nar=2; nma=1; call free(ma); call free(ar); if(nar.gt.0)ar= array(: .70, -.43 ); if(nma.gt.0)ma= array(: .2 ); start=array(:.1 .1); call testit; * Restricted Model ; call arma(test1 :arorder idint(array(:1 2 4)) :maxit 8000 :maorder idint(array(:2) ) :refine 2. :print); call tabulate(%cname,%corder,%coef,%se,%t); call graph(%res); call graph(%y,%yhat); acfres = acf(%res,nacf); acfy = acf(%y, nacf); call graph(acfy,acfres :nokey); call tabulate(acfres,acfy); b34srun; /; /;ARMA_6 Shows Excessive Model that is revised later /; /$ /$ User attempts AR model with 70 terms /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; /$ /$ Subroutine is inside routine in comment form /$ /$ subroutine garch2p(data,nar,nma,coef1,se1,t1,gnar,gnma,coef2,se2,t2, /$ res1,res2,refine); /$ Estimate ARMA / GARCH model following Enders (1995, page 150) /$ two pass method /$ /$ Data => Data /$ nar => # of ar terms for first moment /$ nma => # of ma terms for first moment /$ coef1 => first moment coefficients /$ se1 => first moment se /$ t1 => first moment t /$ gnar => second moment # of ar terms /$ gnma => second moment # of ma terms /$ coef2 => second moment coef /$ se2 => second moment se /$ t2 => second moment t /$ res1 => first moment residual /$ res2 => second moment residual /$ refine => if NE 0 refine models /$ /$ /$ call print('First Moment Model ***************'); /$ call arma(data :nar nar :nma nma :print :refine refine); /$ call print('Second Moment Model ***************'); /$ res1=afam(%res); coef1=%coef; se1=%se; t1=%t; /$ data2=res1*res1; /$ call arma(data2 :nar gnar :nma gnma :print :refine refine); /$ res2=afam(%res); coef2=%coef; se2=%se; t2=%t; /$ return; /$ end; call loaddata; call load(garch2p); * This setting is way too big but tests software ; nar=70; nma=0; gnar=1; gnma=0; call garch2p(gasout,nar,nma,coef1,se1,t1,gnar,gnma,coef2,se2,t2, res1,res2,2.0); call graph(res1); call graph(res2); acf1=acf(res1); call graph(acf1); acf2=acf(res2); call graph(acf2); call tabulate(acf1,acf2); b34srun; /; /;ARMA_7 Allows Extensive tests of ARMA (MM) and OLS /; b34sexec matrix ; * Tests ARMA Command for various arma(1,j) Models ; call echooff; * For Large Numbers of cases turn off gpaph ; * ncase=3000; ncase = 1 ; n=10000 ; nacf=50; coef=array(7:-.75,-.50,-.25,0.0,.25,.50,.75); call free(ma); * sets number of lags for OLSQ filter ; k=1; * sets what ma parameter to use - If zero turns off ; materm=7; * max ar for mm filter; maxar=9; do j=1,7; do i=1,ncase; iter = dfloat(i) ; ar=coef(j); if(materm.ne.0)then; ma=coef(materm); endif; const=1.0; start=.1; wnv=1.0; nout=2000; ar1=genarma(ar,ma,const,start,wnv,n,nout); call arma(ar1 :nar maxar :maxbc 400 :nonlls ); test2=acf(%res,nacf); call olsq(ar1 ar1{1 to k}); test1=acf(ar1,nacf); test3=acf(%res,nacf); call graph(test1,test2 test3 :heading 'Raw & 2 White Series'); * call print(i,j,%coef); enddo; enddo; b34srun ; /; /;ARMA_8 Variance of AR(1) Coefficient /; b34sexec matrix; * We generate a series and following Hinich show that; * Coef SE is invariant to changes in input variance ; n=10000; call free(ma); ar= array(:.7 ); nn=10000; start=array(:.1); varnoise=1.; test1=genarma(ar,ma,0.0,start,varnoise,n,nn); call print('Variance of the series going in ',variance(test1)); call arma(test1 :nar 1 maxit 8000 :itprint :print); varnoise=10.; test1=genarma(ar,ma,0.0,start,varnoise,n,nn); call print('Variance of the series going in ',variance(test1)); call arma(test1 :nar 1 maxit 8000 :itprint :print); b34srun; /; /;ARMA_9 Shows R**2 and ACF Relationshiop /; b34sexec matrix; * Uses Nelson (1976) Formula get R**2 as a f of ACF ; * Needs large samples; n=10000; call free(ma); ar= array(:-.8,.1 ); nn=1000; start=array(:.1,.1); ar2=genarma(ar,ma,0.0,start,.1,n,nn); aacfar2=acf(ar2); call graph(ar2); call arma(ar2 :nar 2 maxit 8000 :itprint :print); gamma=matrix(2,2:1.0,aacfar2(1),aacfar2(1),1.0); pp=vector(2:aacfar2(1),aacfar2(2)); call print(pp,gamma,%coef); rsq1=pp*inv(gamma)*pp; testrsq=1.0-(variance(%res)/variance(%y)); call print(rsq1,testrsq); /$ call tabulate(%res,%y); /$ call names(all); b34srun; /; /;ARRAY Illustrates ARRAY Command /; b34sexec matrix$ x=array(3,3:); x=rn(x); call print(x); xfromi_4=array(2,2:1 2 3 4); xfromr_8=array(2,2:1. 2. 3. 4.); xd1=array(3:); xd1=rn(xd1); call print(xd1,xfromi_4,xfromr_8); /$ Character options call character(cc,'abcdefghi'); cx =array(3,3:cc); * place character*1 in character*1 with different dimensions; cx1 =c1array(3,3:cc); * place character*1 in character*8 ; call character(cc,'1234567812345678abcdefghABCDEFGH'); cx8 =c8array(2,2:cc); call print(cx,cx1,cx8); * recode cx8 into one row and character*1 ; * Two ways to do the same thing ; newcx8 = array(4:cx8); newcx8_1=c8array(4:cx8); * place character*8 into character*1 ; newcx8_2=c1array(32:cx8); * recode a character*1 array; newch1=c1array(norows(cc),1:cc); call print(newcx8,newcx8_1,newcx8_2,newch1); call names(all); b34srun; /; /;AUTOBJ AUTOBJ Command tested on Gas Data /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(rtest); /$ /$ This roottol setting forces no differencing /$ /$ call autobj(gasout :print :nac 24 :npac 24 /$ :roottol .99 :autobuild ); /$ This turns off differencing call autobj(gasout :print :nac 24 :npac 24 :nodif :autobuild ); call rtest(%res,gasout,48); /$ Default let program decide call autobj(gasout :print :nac 24 :npac 24 /$ :printsteps :spiketol 2.0 :autobuild ); call rtest(%res,gasout,48); b34srun; /; /;AUTOBJ_2 Illustrates Reading and writing saved Model /; /; /$ Illustrates saving a model and rereading back into B34S b34sexec options ginclude('gas.b34'); b34srun; B34SEXEC BJEST ; MODEL GASout$ MODELN P=(1,2,3) $ FORECAST NF=24 NT=(296) $ b34srun$ b34sexec matrix; call loaddata; call autobj(gasout :smodeln 'test.mod' :ar index(1 2 3 ) :print :nac 200 :npac 24 :forecast index(24 296) ); /$ call tabulate(%fcast,%foreobs,%fse %fpsi); b34srun; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call autobj(gasout :smodeln 'test.mod' :noest :print :forecast index(24 296) ); b34srun; /; /;AUTOBJ_3 Estimation under user Control /; /$ Estimation under user Control /$ b34srun; b34sexec options ginclude('gas.b34'); b34srun; B34SEXEC BJEST ; MODEL GASout$ MODELN P=(1,2,3) $ FORECAST NF=24 NT=(296) $ b34srun$ b34sexec matrix; call loaddata; call load(rtest); call autobj(gasout :smodeln 'test.mod' :ar index(1 2 3 ) :print :nac 24 :npac 12 :forecast index(24 296) ); call tabulate(%fcast,%foreobs,%fse %fpsi); call rtest(%res,gasout,48); b34srun; /; /;AUTOBJ_4 Test of Rensel series /; /; /; Test problems from Box-Jenkins-Rensel (1994) page 255 /; b34sexec options ginclude('b34sdata.mac') member(bj_a); b34srun; b34sexec bjest; model y; modeln p=(1) q=(1) avepa=.5; /; difference models b34sexec bjest; model y; modeln dif=(1,1) q=(1) ; b34srun; b34sexec matrix; call loaddata; call load(rtest); call autobj(y :autobuild :print); b34srun; /; b34sexec options ginclude('b34sdata.mac') member(bj_b1); b34srun; /; difference models b34sexec bjest; model ibm; modeln dif=(1,1) q=(1) ; b34srun; b34sexec matrix; call loaddata; call load(rtest); call autobj(ibm :autobuild :print); b34srun; /; b34sexec options ginclude('b34sdata.mac') member(bj_c ); b34srun; b34sexec bjest; model chem; modeln dif=(1,1) p=(1); b34srun; b34sexec matrix; call loaddata; call load(rtest); call autobj(chem :autobuild :print); b34srun; b34sexec options ginclude('b34sdata.mac') member(bj_d ); b34srun; b34sexec bjest; model chemv; modeln p=(1) avepa=.5; b34srun; /; difference models b34sexec bjest; model chemv; modeln dif=(1,1) q=(1) ; b34srun; b34sexec matrix; call loaddata; call load(rtest); call autobj(chemv :autobuild :print); b34srun; b34sexec options ginclude('b34sdata.mac') member(bj_e ); b34srun; b34sexec bjest; model wolfer; modeln p=(1,2) avepa=.5; b34srun; /; model 2 b34sexec bjest; model wolfer; modeln p=(1,2,3) avepa=.5; b34srun; b34sexec matrix; call loaddata; call load(rtest); call autobj(wolfer :autobuild :print); b34srun; /; /;AUTOBJ_6 Moving Forecast of US Retail Data /; b34sexec options ginclude('b34sdata.mac') member(retail); b34srun; b34sexec matrix; call loaddata; call load(movebj); call print(movebj); call echooff; nout=1; iseas=12; ibegin=200; iprint=0; call movebj(applance,iseas,ibegin,actual,fore,obs,nout,iprint); call tabulate(obs,actual,fore); call graph(obs fore,actual :plottype xyplot :nolabel :heading '1 step ahead moving forecast'); nout=3; call movebj(applance,iseas,ibegin,actual,fore,obs,nout,iprint); call tabulate(obs,actual,fore); call graph(obs fore,actual :plottype xyplot :nolabel :heading '3 step ahead moving forecast'); b34srun; /; /;AUTOCOV Tests AUTOCOV /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call echooff; call loaddata; call load(autocov); call autocov(gasout,aa,norows(gasout)/2); aatest=acf(gasout,norows(gasout)/2); call tabulate(aa,aatest); call graph(aatest :heading 'ACF'); call graph(aa :heading 'Autocovariance'); b34srun; /; /;BACKSPACE Backspace a unit /; b34sexec matrix; /$ /$ Notes: After the call copyf unit 6 has hit an end of file. /$ The call backspace(6); makes this file able to be /$ written. The call to echooff; is needed since /$ the call to rewind will be echoed in the output /$ file before the backspace is given and cause /$ problems!! /$ x=rn(matrix(4,4:)); xi=inv(x); call print(x,xi); call open(77,'b34sout.out'); call rewind(77); call echooff; call copyf(6,77); call backspace(6); call echoon; b34srun; /; /;BDS Tests BDS Statistic using LeBarron Data /; b34sexec options ginclude('b34sdata.mac') member(blake); b34srun; b34sexec matrix; call loaddata; call print('Results should be:' ' 2 3 4 5 ' ' -.086613 -1.6219 -1.8737 -1.2281'); call bds(blake,.5,5,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); b34srun; /; /;BDS2 BDS Tests using Patterson Data & Gas Data /; b34sexec options ginclude('b34sdata.mac') member(apdata); b34srun; b34sexec matrix; call loaddata; call bds(gnp,.5,10,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); b34srun; /$ /$ Gas Data Tests /$ b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call bds(gasout,.5,10,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); b34srun; /; /;BDS3 Sensitivity BDS tests /; b34sexec options ginclude('b34sdata.mac') member(apdata); b34srun; b34sexec matrix; call loaddata; call bds(gnp,.5,10,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); call bds(gnp,1.,10,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); call bds(gnp,2.,10,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); e=.8; do i=1,30; call print('Runs with ',e); call bds(gnp,e,10,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); e=e+.01; enddo; b34srun; /$ /$ Gas Data Tests /$ b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call bds(gasout,.5,10,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); call bds(gasout,1.,10,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); call bds(gasout,2.,10,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); b34srun; b34sexec options ginclude('b34sdata.mac') member(blake); b34srun; b34sexec matrix; call loaddata; call bds(blake,.5,5,mm,bdsu,bdsv,pbdsu,pbdsv); call tabulate(mm,bdsu,bdsv,pbdsu,pbdsv); eps=.45; delta=.01; m=10; for i=1,50; eps=eps+delta; call bds(blake,eps,m:); next i; b34srun; /; /;BETAPROB Probability of beta distribution /; /; b34sexec matrix; * problem from IMSL page 914 ; pin=12.0; qin=12.0; x=.6; p=betaprob(x,pin,qin); call print('Probability x is less than 6.',p); call print('Answer should have been .8364'); tt=p-betaprob(.5,pin,qin); call print('Probability x is between .5 and .6',tt); call print('Answer should have been .3364'); b34srun; /; /;BLUS BLUS Residual Analysis /; /; b34sexec data heading('Theil(1971) Table 5.1'); * For detail see pages 214-216; * Matrix Command shows BLUS Calculation; * Code discussed in Stokes ( ) 3rd Edition ; build x1,x2, y; gen x1=kount(); gen x2=dsin(x1/2.0); gen y =x1+ 10.0*dsin(x1/2.)+act_e; input act_e; datacards; 1.046 -.508 -1.630 -.146 -.105 -.357 -1.384 .360 -.992 -.116 -1.698 -1.339 1.827 -.959 .424 .969 -1.141 -1.041 1.041 .535 b34sreturn; b34srun; /$ b34sexec list; b34srun; b34sexec regression residualp blus=both noint; comment('Illustrates BLUS analysis with Theil Data'); model y=x1 x2; ra resid=allblus vars(x1); b34srun; b34sexec matrix; call loaddata; call load(blus); program fulltest; iprint=1; call olsq(y x1 x2 :noint :print :savex); do itype=0,3; call blus(itype,%x,%res,ibase,bluse,bluse2,eigb,sumeig,sumsqb, %coef,blusbeta,ibad,x1,teststat,iprint); enddo; return; end; /$ call echoon; call echooff; call fulltest; b34srun; /; /;BOOTI Genarate a bootstrap index vector /; b34sexec matrix; n=26; * do not used index since command of same name !! ; index1=booti(n); call print(index1); test=grid(1.0,20.,1.0); index2=booti(norows(test)); newx=test(index2); call tabulate(test,index2,newx); call print('Nonstandard calls':); index2p2=booti(norows(test),norows(test)+2); index2m3=booti(norows(test),norows(test)-3); call tabulate(index2,index2P2,index2m3); b34srun; /; /;BOOTOLS Illustrates Bootstrap of OLS Model /; b34sexec matrix; * Illustrate bootstrap of OLS Model; * User sets nobs for sample size ; * k for size of problem ; * beta for coefficients ; * mult for amount of Noise ; * number for # of bootstraps ; nobs=5000; k=3; * try 3.0 15. 30. here !! ; mult=15.0; beta=vector(k:1.0 2.0 3.0); number=1000; y=vector(nobs:); x=rn(matrix(nobs,k:)); y=1.0 + x*beta + mult*rn(y); call olsq(y,x:print); call echooff; holdcoef=matrix(number,k+1:); holdt =matrix(number,k+1:); do i=1,number; j=booti(nobs); newy=y(j); newx=x(j,); call olsq(newy newx); holdcoef(i,)=%coef; holdt(i,) =%t; call outstring(2,3,'Estimation:'); call outinteger(40,3,i); enddo; call echoon; x1=holdcoef(,1); x2=holdcoef(,2); x3=holdcoef(,3); call graph(x1,x2,x3:heading 'Should be 1.0 2.0 3.0'); call print(mean(x1),mean(x2),mean(x3)); t1=holdt(,1); t2=holdt(,2); t3=holdt(,3); call graph(t1,t2,t3:heading 't scores of model'); b34srun; /; /;BOOTV1 Genarate a bootstrap from a vector /; b34sexec matrix; test=grid(1.0,20.0,1.); btest=bootv(test); call tabulate(test,btest); x=rn(matrix(4,4:)); newx=bootv(x); call print(x,newx); call print('Nonstandard call'); btestp5=bootv(test,norows(test)+5); btestm5=bootv(test,norows(test)-5); call tabulate(test,btestp5,btestm5); b34srun; /; /;BOOTV2 Bootstrap a matrix /; b34sexec matrix; * Illustrate bootstrap of X matrix; nn=20; x=rn(matrix(nn,3:)); call print(x); j=booti(nn); call print(j); newx=x(j,); call print(newx); b34srun; /; /;BOXCOX Box-Cox Transformation /; b34sexec matrix; x=grid(0.0001 100. .1); ll=.1; log10x=dlog10(x); lnx =dlog(x); bc =boxcox(x,ll); bc2=boxcox(x,x) ; call print('bc =(x**.1 -1)/.1' 'bc2=(x**x -1)/x '); /$ call tabulate(x,log10x,lnx,bc,bc2); call graph(log10x,lnx,bc :Heading 'log10, lb and BC of .0001 - 100'); b34srun; /; /;BOXCOX_1 Box-Cox Regression on Greene(2000) p 451 /; /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix /$ Very Hard problem. Greene solved by a search b34sexec options ginclude('greene.mac') member(a10_1); b34srun; b34sexec matrix; call loaddata; * Problem from Greene page 451 ; call olsq(m r y :print); call olsq(lm lr ly :print); call olsq(lm r y :print); program bc; call echooff; /$ needed for nl2sol lamda2=dmin1(lamda,10.); yhat=a+(beta*boxcox(r,lamda2))+(gamma*boxcox(y,lamda2)); res=lm-yhat; call outstring(3,3,'Coefficients'); call outstring(3,4,'a beta gamma lamda'); call outdouble(26,4,a); call outdouble(56,4,beta); call outdouble(26,5,gamma); call outdouble(56,5,lamda); return; end; call print(bc); * Results in Greene (2000) page 451 ; call nllsq(lm,yhat :name bc :parms a beta gamma lamda :maxit 5000 :flam 1. :flu 10. :eps2 .0000004 /$ :eps2 .00004 :ivalue array(:%coef(3),%coef(1),%coef(2),0.0001) :print result residuals); * Now try nl2sol !!; res1=%res; res =%res; call nl2sol(res :name bc :parms a beta gamma lamda :ivalue array(:%coef(3),%coef(1),%coef(2),0.0001) :print :maxit 5000 :maxfun 5000 ); call graph(res1, %res :heading 'res1 => nllsq %res => nl2sol'); call print(sumsq(%res)); b34srun; /; /;BOXCOX_2 MAXF2 used to minimise sumsq residuals /; /$ Illustrates ML estimation of Box-Cox Model /$ /$ First we do a search /$ Next we set at Greene (2000) values for lamda /$ b34sexec options ginclude('greene.mac') member(a10_1); b34srun; b34sexec matrix; call loaddata; * Problem from Greene page 452 ; call olsq(m r y :print); call olsq(lm lr ly :print); call olsq(lm r y :print); lamda =1.; program bc; call echooff; func=sumsq(afam(boxcox(m,lamda))-(a+(beta*afam(boxcox(r,lamda)) )+ (gamma*afam(boxcox(y,lamda))) )); call outstring(3,3,'Coefficients'); call outstring(3,4,'a beta gamma lamda'); call outdouble(26,4,a); call outdouble(56,4,beta); call outdouble(26,5,gamma); call outdouble(56,5,lamda); func=-1.*func; call outdouble(26,6,func); return; end; call print(bc); rvec=array(:%coef(3),%coef(1),%coef(2),lamda); /$ rvec=array(:-11.,-.001,4.,-.035); call echooff; call maxf2(func :name bc :parms a beta gamma lamda :ivalue rvec :print); b34srun; b34sexec matrix; call loaddata; * Problem from Greene (2000) page 452 ; * By setting lamda at Greene value of -.35 get ; * Greene coefficients ; call olsq(m r y :print); call olsq(lm lr ly :print); call olsq(lm r y :print); lamda =-.35; program bc; call echooff; func=sumsq(afam(boxcox(m,lamda))-(a+(beta*afam(boxcox(r,lamda)) )+ (gamma*afam(boxcox(y,lamda))) )); call outstring(3,3,'Coefficients'); call outstring(3,4,'a beta gamma lamda'); call outdouble(26,4,a); call outdouble(56,4,beta); call outdouble(26,5,gamma); call outdouble(56,5,lamda); func=-1.*func; call outdouble(26,6,func); return; end; call print(bc); rvec=array(:%coef(3),%coef(1),%coef(2) ); call echooff; call maxf2(func :name bc :parms a beta gamma :ivalue rvec :print); b34srun; /; /;BOXCOX_3 Box-Cox Model that Maximized Likelihood Function /; /$ /$ Illustrates ML estimation of Box-Cox Model /$ /$ ML Estimation of Greene (2000) page 452 /$ b34sexec options ginclude('greene.mac') member(a10_1); b34srun; b34sexec matrix; call loaddata; * Problem from Greene page 452 ; * ML function from page 447 ; * Problem very very hard ; * ; * Constants placed in variables to in call olsq(m r y :print) ; call olsq(lm lr ly :print) ; call olsq(lm r y :print) ; lamda =1.; func1=0.0; one=1.0; ndiv2=dfloat(norows(m))/2. ; n =dfloat(norows(m)) ; cc =ndiv2*(dlog(2.*pi())+1.0) ; count=0; program bc; call echooff; func1=sumsq(afam(boxcox(m,lamda))-(a+(beta*afam(boxcox(r,lamda)) )+ (gamma*afam(boxcox(y,lamda))) )); count=count+1; call outstring(3,3,'Coefficients') ; call outstring(3,4,'a beta gamma lamda epe '); call outdouble(26,4,a); call outdouble(56,4,beta); call outdouble(26,5,gamma); call outdouble(56,5,lamda); call outdouble(26,6,func1); call outinteger(56,6,count); func=(lamda-one)*mlsum(m) -cc - (ndiv2*dlog(func1/n)); return; end; call print(bc); rvec=array(:%coef(3),%coef(1),%coef(2),lamda); call echooff; call maxf2(func :name bc :parms a beta gamma lamda :maxit 8000 :maxfun 2000 :maxg 2000 :ivalue rvec :print); b34srun; /; /;BPFILTER Baxter King Filter /; /; /$ /$ Baxter-King MA Filter is used to extract trend and deviations from /$ trend /$ /$ Illustrates passing gasout through Baxter-King MA filter /$ goodrow and catcol used to line up data for plots and /$ redefine the series !! /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; highfreq=6.; lowfreq=32.; nterms=20; call bpfilter(gasout,tr,dev,highfreq,lowfreq,nterms:); call tabulate(gasout,tr,dev,); x=goodrow(catcol(gasout,tr,dev)); gasout=x(,1); tr =x(,2); dev =x(,3); call tabulate(gasout,tr,dev); call graph(gasout,tr,dev); b34srun; /; /;BPFILTER_2 Compares BP and HP Filters /; /$ /$ Illustrates Baxter king and Hodrick - Prescott Filters /$ /$ Note use of goodrow and catcol to control missing /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; highfreq=6.; lowfreq=32.; nterms=20; s=1600.; call hpfilter(gasout,hptrend,hpdev,s); call bpfilter(gasout,bptrend,bpdev,highfreq,lowfreq,nterms:); x=goodrow(catcol(gasout,hptrend,hpdev,bptrend,bpdev)); gasout =x(,1); hptrend =x(,2); hpdev =x(,3); bptrend =x(,4); bpdev =x(,5); call tabulate(gasout,hptrend,hpdev,bptrend,bpdev); call graph(gasout,hptrend,hpdev,bptrend,bpdev); b34srun; /; /;BSDER Compute 1-D spline values/derivatives given knots /; /; b34sexec matrix; * Test Example from IMSL(10) ; call echooff; ndata=5; i=integers(ndata); xdata=dfloat(i)/dfloat(ndata); f=dsqrt(xdata); xknot = bsnak(xdata,3); bscoef= bsint(xdata,f,xknot); ndata=101; j=integers(2,ndata); x=dfloat(j-1)/dfloat(ndata-1); actf=dsqrt(x); actder=(.5/dsqrt(x)); xhat=bsder(0,x,xknot,bscoef); xder=bsder(1,x,xknot,bscoef); error1=actf - xhat; error2=xder - actder; call print('Evaluation of Data and Derivative':); call tabulate(x,actf,xhat,actder,xder,error1,error2); b34srun; /; /;BSDER2 Compute 2-D spline values/derivatives given knots /; b34sexec matrix; * Test Example from IMSL(10) ; call echooff; nxdata=21; nydata=6; kx=5; ky=3; i=integers(nxdata); j=integers(nydata); xdata=dfloat(i-11)/10.; ydata=dfloat(j-1)/5.; f=array(nxdata,nydata:); do ii=1,nxdata; do jj=1,nydata; f(ii,jj)=(xdata(ii)**4.) + ((xdata(ii)**3.)*(ydata(jj)**2.)); enddo; enddo; xknot=bsnak(xdata,kx); yknot=bsnak(ydata,ky); bscoef2=bsint2(xdata,ydata,f,xknot,yknot); nxvec=4; nyvec=4; i=integers(nxvec); j=integers(nyvec); xvec=dfloat(i-1)/3.; yvec=dfloat(j-1)/3.; xx=array(nxvec,nyvec:); yy=xx; ff=xx; ffder=ff; error=xx; f21=xx; do i=1,nxvec; do j=1,nyvec; xx(i,j) =xvec(i); yy(i,j) =yvec(j); ff(i,j) =(xvec(i)**4.) + (xvec(i)*yvec(j)); ffder(i,j)=bsder2(2,1,xvec(i),yvec(j),xknot,yknot,bscoef2); f21(i,j) =12.*xvec(i)*yvec(j); error(i,j)=f21(i,j)-ffder(i,j); enddo; enddo; xx =array(:xx); yy =array(:yy); ffder=array(:ffder); f21=array(:f21); error=array(:error); call tabulate(xx,yy,ffder,f21,error); b34srun; /; /;BSDER3 Compute 3-D spline values/derivatives given knots /; b34sexec matrix; * Test Example from IMSL(10) ; call echooff; kx=5; ky=2; kz=3; nxdata=21; nydata=6; nzdata=8; nxvec=4; nyvec=4; nzvec=2; i=integers(nxdata); j=integers(nydata); k=integers(nzdata); xdata=dfloat(i-11)/10. ; ydata=dfloat(j-1) /dfloat(nydata-1); zdata=dfloat(k-1) /dfloat(nzdata-1); xknot=bsnak(xdata,kx); yknot=bsnak(ydata,ky); zknot=bsnak(zdata,kz); maxii=index(nxdata,nydata,nzdata:); f=array(maxii:); do ii=1,nxdata; do jj=1,nydata; do kk=1,nzdata; ii2=index(nxdata,nydata,nzdata:ii,jj,kk); f(ii2)=(xdata(ii)**4.) + ((xdata(ii)**3.)*ydata(jj)*(zdata(kk)**3.)); enddo; enddo; enddo; bscoef3=bsint3(xdata,ydata,zdata,f,xknot,yknot,zknot); i=integers(nxvec); j=integers(nyvec); k=integers(nzvec); xvec=2.*(dfloat(i-1)/3.)-1. ; yvec=dfloat(j-1)/3.0; zvec=dfloat(k-1); maxjj=index(nxvec,nyvec,nzvec:); fit =array(maxjj:); error =array(maxjj:); actual=array(maxjj:); xx =array(maxjj:); yy =xx; zz =xx; do ii=1,nxvec; do jj=1,nyvec; do kk=1,nzvec; ii2=index(nxvec,nyvec,nzvec:ii,jj,kk); fit(ii2)=bsder3(2,0,1,xvec(ii),yvec(jj),zvec(kk), xknot, yknot, zknot,bscoef3); actual(ii2)=18.*xvec(ii)*yvec(jj)*zvec(kk); xx(ii2)=xvec(ii); yy(ii2)=yvec(jj); zz(ii2)=zvec(kk); error(ii2)=actual(ii2)-fit(ii2); enddo; enddo; enddo; call print('Shows 2,0,1 derivative, actual and error':); call tabulate(xx,yy,zz,fit,actual,error); b34srun; /; /;BSINT Compute 1-D spline interpolant given knots /; b34sexec matrix; * Test Example from IMSL(10) ; call echooff; ndata=50; i=integers(ndata); xdata=dfloat(i-1)/dfloat(ndata-1); f=dsqrt(xdata); xknot = bsnak(xdata,8); bscoef= bsint(xdata,f,xknot); ndata=101; j=integers(2,ndata); x=dfloat(j-1)/dfloat(ndata-1); actf=dsqrt(x); actder=(.5/dsqrt(x)); xhat=bsder(0,x,xknot,bscoef); xder=bsder(1,x,xknot,bscoef); error1=actf - xhat; error2=xder - actder; call print('Evaluation of Data and Derivative':); call tabulate(x,actf,xhat,actder,xder,error1,error2); b34srun; /; /;BSINT2 Compute 2-D spline interpolant given knots /; b34sexec matrix; * Test Example from IMSL(10) ; call echooff; nxdata=21; nydata=6; kx=5; ky=2; i=integers(nxdata); j=integers(nydata); xdata=dfloat(i-11)/10.; ydata=dfloat(j-1)/5.; f=array(nxdata,nydata:); do ii=1,nxdata; do jj=1,nydata; f(ii,jj)=(xdata(ii)*xdata(ii)*xdata(ii)) + (xdata(ii)*ydata(jj)); enddo; enddo; xknot=bsnak(xdata,kx); yknot=bsnak(ydata,ky); bscoef2=bsint2(xdata,ydata,f,xknot,yknot); nxvec=4; nyvec=4; i=integers(nxvec); j=integers(nyvec); xvec=dfloat(i-1)/3.; yvec=dfloat(j-1)/3.; xx=array(nxvec,nyvec:); yy=xx; ff=xx; ffhat=ff; error=xx; do i=1,nxvec; do j=1,nyvec; xx(i,j)=xvec(i); yy(i,j)=yvec(j); ff(i,j)=(xvec(i)*xvec(i)*xvec(i)) + (xvec(i)*yvec(j)); ffhat(i,j)=bsder2(0,0,xvec(i),yvec(j),xknot,yknot,bscoef2); error(i,j)=ff(i,j)-ffhat(i,j); enddo; enddo; xx=array(:xx); yy=array(:yy); ff=array(:ff); ffhat=array(:ffhat); error=array(:error); call tabulate(xx,yy,ff,ffhat,error); b34srun; /; /;BSINT3 Compute 3-D spline interpolant given knots /; b34sexec matrix; * Test Example from IMSL(10) ; call echooff; kx=5; ky=2; kz=3; nxdata=21; nydata=6; nzdata=8; nxvec=4; nyvec=4; nzvec=2; i=integers(nxdata); j=integers(nydata); k=integers(nzdata); xdata=dfloat(i-11)/10. ; ydata=dfloat(j-1) /dfloat(nydata-1); zdata=dfloat(k-1) /dfloat(nzdata-1); xknot=bsnak(xdata,kx); yknot=bsnak(ydata,ky); zknot=bsnak(zdata,kz); maxii=index(nxdata,nydata,nzdata:); f=array(maxii:); do ii=1,nxdata; do jj=1,nydata; do kk=1,nzdata; ii2=index(nxdata,nydata,nzdata:ii,jj,kk); f(ii2)=(xdata(ii)**3.) + (xdata(ii)*ydata(jj)*zdata(kk)); enddo; enddo; enddo; bscoef3=bsint3(xdata,ydata,zdata,f,xknot,yknot,zknot); i=integers(nxvec); j=integers(nyvec); k=integers(nzvec); xvec=2.*(dfloat(i-1)/3.)-1. ; yvec=dfloat(j-1)/3.0; zvec=dfloat(k-1); maxjj=index(nxvec,nyvec,nzvec:); fit =array(maxjj:); error =array(maxjj:); actual=array(maxjj:); xx =array(maxjj:); yy =xx; zz =xx; do ii=1,nxvec; do jj=1,nyvec; do kk=1,nzvec; ii2=index(nxvec,nyvec,nzvec:ii,jj,kk); fit(ii2)=bsder3(0,0,0,xvec(ii),yvec(jj),zvec(kk), xknot, yknot, zknot,bscoef3); actual(ii2)=(xvec(ii)**3.)+(xvec(ii)*yvec(jj)*zvec(kk)); xx(ii2)=xvec(ii); yy(ii2)=yvec(jj); zz(ii2)=zvec(kk); error(ii2)=actual(ii2)-fit(ii2); enddo; enddo; enddo; call tabulate(xx,yy,zz,fit,actual,error); b34srun; /; /;BSITG Compute 1-D spline integral given knots /; b34sexec matrix; * Test Example from IMSL(10) ; ndata=21; korder=5; i =integers(ndata); xdata =dfloat(i-11)/10.; f =xdata**3.; xknot =bsnak(xdata,korder); bscoef=bsint(xdata,f,xknot); a =0.0; b =1.0; val =bsitg(a,b,xknot,bscoef); * fi(x)= x**4./4.; exact =(b**4./4.)-(a**4./4.); error=exact-val; call print('Test of bsitg ***********************':); call print('Lower = ',a:); call print('Upper = ',b:); call print('Integral = ',val:); call print('Exact = ',exact:); call print('Error = ',error:); b34srun; /; /;BSITG2 Compute 2-D spline integral given knots /; b34sexec matrix; * Test Example from IMSL(10) ; call echooff; nxdata=21; nydata=6; kx=5; ky=2; i=integers(nxdata); j=integers(nydata); xdata=dfloat(i-11)/10.; ydata=dfloat(j-1)/5.; f=array(nxdata,nydata:); do ii=1,nxdata; do jj=1,nydata; f(ii,jj)=(xdata(ii)**3.) + (xdata(ii)*ydata(jj)); enddo; enddo; xknot=bsnak(xdata,kx); yknot=bsnak(ydata,ky); bscoef2=bsint2(xdata,ydata,f,xknot,yknot); a=0.0; b=1.0; c=.5; d=1.0; val=bsitg2(a,b,c,d,xknot,yknot,bscoef2); exact=.25*((b**.4-a**.4)*(d-c)+(b*b-a*a)*(d*d-c*c)); error=val-exact; call print('Test of bsitg2 ***********************':); call print('Lower 1 = ',a:); call print('Upper 1 = ',b:); call print('Lower 2 = ',c:); call print('Upper 2 = ',d:); call print('Integral = ',val:); call print('Exact = ',exact:); call print('Error = ',error:); b34srun; /; /;BSITG2_2 Matlab Test case /; b34sexec matrix; * Test Example from Mastering Matlab 5 page 251; call echooff; x=grid(0.0, pi()); y=grid(-1.*pi(),pi()); x1=x; y1=y; call meld(x,y); z=dsin(x) * dcos(y)+1.; call graph(x,y,z :plottype contour3 :d3axis :d3border); kx=5; ky=5; xknot=bsnak(x1 ,kx); yknot=bsnak(y1 ,ky); n1=norows(x1); n2=norows(y1); z1=array(n1*n2:); do ii=1,n1; do jj=1,n2; ii2 =index(n1,n2:ii,jj); z1(ii2)=(dsin(x1(ii)) * dcos(y1(jj))) + 1.; enddo; enddo; bscoef2=bsint2(x1 ,y1 ,z1 ,xknot,yknot); a=0.0; b=pi(); c=-1.*pi(); d=pi(); val=bsitg2(a,b,c,d,xknot,yknot,bscoef2); matlab=19.73921476256606; call print('Integrating sin(x)*cos(y)+1.':); call print('Lower 1 = ',a:); call print('Upper 1 = ',b:); call print('Lower 2 = ',c:); call print('Upper 2 = ',d:); call print('Integral = ',val:); call print('Matlab = ',matlab:); b34srun; /; /;BSITG3 Compute 3-D spline integral given knots /; b34sexec matrix; * Test Example from IMSL(10) ; call echooff; nxdata=21; nydata=6; nzdata=8; kx=5; ky=2; kz=3; i=integers(nxdata); j=integers(nydata); k=integers(nzdata); xdata=dfloat(i-11)/10.; ydata=dfloat(j-1)/5.; zdata=dfloat(k-1)/dfloat(nzdata-1); iimax=index(nxdata,nydata,nzdata:); f=array(iimax:); do ii=1,nxdata; do jj=1,nydata; do kk=1,nzdata; ii3=index(nxdata,nydata,nzdata:ii,jj,kk); f(ii3)=(xdata(ii)**3.) + (xdata(ii)*ydata(jj)*zdata(kk)); enddo; enddo; enddo; xknot=bsnak(xdata,kx); yknot=bsnak(ydata,ky); zknot=bsnak(zdata,kz); bscoef3=bsint3(xdata,ydata,zdata,f,xknot,yknot,zknot); a=0.0; b=1.0; c=.5; d=1.0; e=0.0; ff=.5; val=bsitg3(a,b,c,d,e,ff,xknot,yknot,zknot,bscoef3); g =.5*(b**4.-a**4.); h =(b-a)*(b+a); ri=g*(d-c); rj=.5*h*(d-c)*(d+c); exact=.5*(ri*(ff-e)+.5*rj*(ff-e)*(ff+e)); error=val-exact; call print('Test of bsitg3 ***********************':); call print('Lower 1 = ',a:); call print('Upper 1 = ',b:); call print('Lower 2 = ',c:); call print('Upper 2 = ',d:); call print('Lower 3 = ',e:); call print('Upper 3 = ',ff:); call print('Integral = ',val:); call print('Exact = ',exact:); call print('Error = ',error:); b34srun; /; /;BSNAK Compute Not a Knot Sequence /; b34sexec matrix; * Test Example from IMSL(10) ; call echooff; n=20; i=integers(n); xx1=dfloat(i-1)/dfloat(n-1); x=1.0-(xx1*xx1); f=dsin(10.0*x*x*x); call free(xx); * study which knots do best; do korder=3,8; xknot1 =bsnak(x,korder); xknot2 =bsopk(x,korder); bscoef1=bsint(x,f,xknot1); bscoef2=bsint(x,f,xknot2); * Test using new data; ii=integers(100); xx=dfloat(ii-1)/99.; st1=bsder(0,xx,xknot1,bscoef1); st2=bsder(0,xx,xknot2,bscoef2); ff=dsin(10.*xx*xx*xx); dif1=dabs(ff-st1); dif2=dabs(ff-st2); ddmax1=dmax(dif1); ddmax2=dmax(dif2); call print('For korder ',korder:); call print('bsnak max error ',ddmax1:); call print('bsopk max error ',ddmax2:); enddo; b34srun; /; /;BSOPK Compute optimal spline knot sequence /; b34sexec matrix; * Test Example from IMSL(10) ; call echooff; n=20; i=integers(n); xx1=dfloat(i-1)/dfloat(n-1); x=1.0-(xx1*xx1); f=dsin(10.0*x*x*x); call free(xx); * study which knots do best; do korder=3,8; xknot1 =bsnak(x,korder); xknot2 =bsopk(x,korder); bscoef1=bsint(x,f,xknot1); bscoef2=bsint(x,f,xknot2); * Test using new data; ii=integers(100); xx=dfloat(ii-1)/99.; st1=bsder(0,xx,xknot1,bscoef1); st2=bsder(0,xx,xknot2,bscoef2); ff=dsin(10.*xx*xx*xx); dif1=dabs(ff-st1); dif2=dabs(ff-st2); ddmax1=dmax(dif1); ddmax2=dmax(dif2); call print('For korder ',korder:); call print('bsnak max error ',ddmax1:); call print('bsopk max error ',ddmax2:); enddo; b34srun; /; /;BUILDLAG Builds NEWY and NEWX for VAR Modeling /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call load(buildlag); x=catcol(gasin,gasout); nlag=2; ibegin=1; iend=10; call print(x); call buildlag(x,nlag,ibegin,iend,newx,newy); call print(newx,newy); b34srun; /; /;C1ARRAY Create a Character*1 Array /; b34sexec matrix; /$ /$ Job shows creating char*8 and char*1 variables /$ and moving data between the variable types /$ c8=c8array(3,3:); c1=c1array(3,8:); call names; c8(1,1)='John'; c8(1,2)='Carol'; c8(1,3)='Sue'; call character(cc1,'12345678'); call character(cc2,'abcdefgh'); c1(1,)=cc1; c1(2,)=cc2; call print(c1,c8); /$ /$ Move from Character*8 to Character*1 /$ Note the user of kind = -1 to force LCOPY /$ /$ want to place 'John' on line three of c1 call names; call pcopy(4,pointer(c8),1, pointer(c1)+2, norows(c1),-1); call print(c1); /$ move Sue next to John with a space call pcopy(3,pointer(c8)+(16*norows(c8)),1, pointer(c1)+2+5*norows(c1), norows(c1),-1); call print(c1); * ; call char1(c1,'This is a damm long string what do you think'); call char1(c2,'This is '); call print(c1,c2); call char1(x ,'This is a damm long string what do you think' 'so it this ' 'But this is not'); call names(all); call print(c1,c2,x); b34srun; b34sexec matrix; /$ /$ Job shows creating char*8 and char*1 variables /$ and moving data between the variable types /$ call character(cc8, '012'); call character(cc, '012':3); call character(cc0, '0' :1); call character(cc1, '1' :1); call names(all); call print(cc(2),cc0); if(cc(2).eq.cc0)call print('yes-error'); call print(cc(1),cc0); if(cc(1).eq.cc0)call print('yes-right1'); call print(cc(2),cc0); if(cc(2).ne.cc0)call print('yes-right2'); call print(cc(1),cc1); if(cc(1).ne.cc1)call print('yes-right3'); cc=array(:0.,1.,2.); call print(cc); if(cc(2).eq.0.)call print('yes-error'); if(cc(1).eq.0.)call print('yes-right1'); if(cc(2).ne.0.)call print('yes-right2'); if(cc(1).ne.1.)call print('yes-right3'); b34srun; /; /;C8ARRAY Create a Character*8 Array /; b34sexec matrix; /$ /$ Job shows creating char*8 and char*1 variables /$ and moving data between the variable types /$ c8=c8array(3,3:); c1=c1array(3,8:); call names; c8(1,1)='John'; c8(1,2)='Carol'; c8(1,3)='Sue'; call character(cc1,'12345678'); call character(cc2,'abcdefgh'); c1(1,)=cc1; c1(2,)=cc2; call print(c1,c8); /$ /$ Move from Character*8 to Character*1 /$ Note the user of kind = -1 to force LCOPY /$ /$ want to place 'John' on line three of c1 call names; call pcopy(4,pointer(c8),1, pointer(c1)+2, norows(c1),-1); call print(c1); /$ move Sue next to John with a space call pcopy(3,pointer(c8)+(16*norows(c8)),1, pointer(c1)+2+5*norows(c1), norows(c1),-1); call print(c1); b34srun; /; /;C16TOC32 Complex*16 to Complex*32 /; /$ Illustrates Real*16 and Complex*32 Processing b34sexec matrix; n=4; ncase=1; x=rn(matrix(n,n:)); y=rn(x); xty=x*y; call print(x,y,xty); r16x=r8tor16(x); r16y=r8tor16(y); r16xty=r16x*r16y; call print(r16x,r16y,r16xty); diff=xty-r16tor8(r16xty); call print('Difference',diff); call print('Transpose test',transpose(x),transpose(r16x)); v8=rn(vector(9:)); c16=complex(v8,2.*v8); call print('Are these the same?',c16,c16toc32(c16)); v16=r8tor16(v8); call print(v16); call print(r8tor16(2.)*v16); c32=qcomplex(v16,r8tor16(2.)*v16); c16m=complex(x,y); c32m=qcomplex(r16x,r16y); call print('are these the same?',c16m,c32m); call tabulate(v8,v16,c16,c32); do i=1,ncase; x=rn(x); r16x=r8tor16(x); c16x= complex(x); c32x=qcomplex(r16x); call print('In real*16 real*8 complex*32 complex*16',r16x,x,c32x,c16x); ix=inv(x); ir16x=inv(r16x); ic16x=inv(c16x); ic32x=inv(c32x); call print('Inverse real*16 real*8 complex*32 complex*16', ir16x,ix,ic32x,ic16x); call print('errors of inverse' x*ix,r16x*ir16x,c16x*ic16x,c32x*ic32x); /$ Test inline inverse test1=kindas(r16x,1.0)/r16x; call print(test1,ir16x); test2=kindas(c16x,complex(1.0))/c16x; call print(test2,ic16x); enddo; b34srun; /; /;C32TOC16 Complex*32 to Complex*16 /; /$ Illustrates Real*16 and Complex*32 Processing b34sexec matrix; n=4; ncase=1; x=rn(matrix(n,n:)); y=rn(x); xty=x*y; call print(x,y,xty); r16x=r8tor16(x); r16y=r8tor16(y); r16xty=r16x*r16y; call print(r16x,r16y,r16xty); diff=xty-r16tor8(r16xty); call print('Difference',diff); call print('Transpose test',transpose(x),transpose(r16x)); v8=rn(vector(9:)); c16=complex(v8,2.*v8); call print('Are these the same?',c16,c16toc32(c16)); v16=r8tor16(v8); call print(v16); call print(r8tor16(2.)*v16); c32=qcomplex(v16,r8tor16(2.)*v16); c16m=complex(x,y); c32m=qcomplex(r16x,r16y); call print('are these the same?',c16m,c32m); call tabulate(v8,v16,c16,c32); do i=1,ncase; x=rn(x); r16x=r8tor16(x); c16x= complex(x); c32x=qcomplex(r16x); call print('In real*16 real*8 complex*32 complex*16',r16x,x,c32x,c16x); ix=inv(x); ir16x=inv(r16x); ic16x=inv(c16x); ic32x=inv(c32x); call print('Inverse real*16 real*8 complex*32 complex*16', ir16x,ix,ic32x,ic16x); call print('errors of inverse' x*ix,r16x*ir16x,c16x*ic16x,c32x*ic32x); /$ Test inline inverse test1=kindas(r16x,1.0)/r16x; call print(test1,ir16x); test2=kindas(c16x,complex(1.0))/c16x; call print(test2,ic16x); enddo; b34srun; /; /;C32TOC16_2 Simplified test case /; /; /;CATCOL Test catcol command /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; newdata=catcol(gasin gasout lag(gasin,1),lag(gasin,2)); call print(newdata); gcol=goodcol(newdata); grow=goodrow(newdata); call print(gcol,grow); crow3=catrow(gasin gasout lag(gasin,1),lag(gasin,2)); call print(crow3); x1=rec(matrix(3,3:)); x2=rec(matrix(3,3:)); call print(x1,x2,catrow(x1,x2),catcol(x1,x2)); /$ Character tests call character(cc1,'Line 1 here'); call character(cc2,'Line 2 here'); catrow1=catrow(cc1,cc2); catcol1=catcol(cc1,cc2); call names(all); call print(catrow1,catcol1); b34srun; /; /;CATROW Test catrow command /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; newdata=catcol(gasin gasout lag(gasin,1),lag(gasin,2)); call print(newdata); gcol=goodcol(newdata); grow=goodrow(newdata); call print(gcol,grow); crow3=catrow(gasin gasout lag(gasin,1),lag(gasin,2)); call print(crow3); x1=rec(matrix(3,3:)); x2=rec(matrix(3,3:)); call print(x1,x2,catrow(x1,x2),catcol(x1,x2)); /$ Character tests call character(cc1,'Line 1 here'); call character(cc2,'Line 2 here'); catrow1=catrow(cc1,cc2); catcol1=catcol(cc1,cc2); call names(all); call print(catrow1,catcol1); b34srun; /; /;CCF Tests CCF Command /; b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec data set corr; b34srun; b34sexec matrix; /$ Illustrates and tests ccf function call loaddata; ccf1=ccf(gasin gasout,24); call graph(ccf1:heading 'CCF of Gasin-Gasout'); call print(ccf1); call names; ccf1=ccf(gasin,gasout,24,lags); * Same series passed to test of ACF and CCF give same answer; ccf2=ccf(gasin,gasin ,24,lags); acf1=acf(gasin,24); call tabulate(ccf1,ccf2,acf1,lags); call print('Correlation between gasin & gasout ',ccf(gasin,gasout):); call print('Correlation Matrix ',ccf(catcol(gasin,gasout))); call print('Correlation Matrix ',ccf(catcol(time,gasin,gasout))); b34srun$ /; /;CCF2 Tests Stokes (1979) ACF of CCF Test /; b34sexec matrix; * We generate two series. One with autocorrelation; * There is no relationship between the series ; * Stokes (1997) CCF Diagnostic test is illustrated; n=10000; nccf=200; nacf=30; call free(ma); ar=array(:-.9 ); nn=100; start=array(:.1); test1=genarma(ar,ma,1.0,start,.1,n,nn); test2=rn(array(norows(test1):)); ccf1=ccf(test1,test2,nccf,lags); i=integers(nccf+2,2*nccf+1); testccf=ccf1(i); acfccf=acf(testccf,nacf); acf2 =acf(test1, nacf); acf3 =acf(test2, nacf); call tabulate(acfccf,acf2,acf3); call tabulate(lags,ccf1); call graph(acfccf,acf2 acf3 :Heading 'Red => NWN. Blue => CCF. Green => WN'); b34srun; /; /;CCF3 Further CCF Tests /; b34sexec matrix; * We generate two series. One with autocorrelation; * There is no relationship between the series ; * Stokes (1997) CCF Diagnostic test is illustrated; * More Complex model is shown; n=1000; nccf=200; nacf=30; call free(ma); ar=array(:.7,.5 ); nn=100; start=array(:1.0 .1 ); test1=genarma(ar,ma,0.0,start,1.,n,nn); test2=rn(array(norows(test1):)); ccf1=ccf(test1,test2,nccf,lags); i=integers(nccf+2,2*nccf+1); testccf=ccf1(i); acfccf=acf(testccf,nacf); acf2 =acf(test1, nacf); acf3 =acf(test2, nacf); call tabulate(acfccf,acf2,acf3); call tabulate(lags,ccf1); call graph(acfccf,acf2 acf3 :Heading 'Red => NWN. Blue => CCF. Green => WN'); b34srun; /; /;CCF4 Tests CCF of two White Noise Series /; b34sexec matrix; * We generate two series, both white noise. ; * There is no relationship between the series ; * Stokes (1997) CCF Diagnostic test is illustrated ; n=10000; nccf=200; nacf=30; call free(ma); ar=array(:-.9 ); nn=100; start=array(:.1); test1=genarma(ar,ma,1.0,start,.1,n,nn); test2=rn(array(norows(test1):)); /$ Note: test1 is replaced here with NW series !!!! test1=rn(array(norows(test2):)); ccf1=ccf(test1,test2,nccf,lags); i=integers(nccf+2,2*nccf+1); testccf=ccf1(i); acfccf=acf(testccf,nacf); acf2 =acf(test1, nacf); acf3 =acf(test2, nacf); call tabulate(acfccf,acf2,acf3); call tabulate(lags,ccf1); call graph(acfccf,acf2 acf3 :Heading 'Red => NWN. Blue => CCF. Green => WN'); b34srun; /; /;CCFTEST Plot CCF /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(ccftest); nn=norows(gasout)/4; call character(title,'Gasin - Gasout Raw Correlations'); call ccftest(gasin,gasout,nn,lags,title); b34srun; /; /;CCFTEST1 Shows effect of autocorrelation on ccf /; /; b34sexec matrix; * Hard wired code for example; call load(ccftest); n=100; nccf=30; nacf=30; nlag=3; noise=1.; call free(ma); ar=array(: .9); nn=100; start=array(:.1); x=genarma(ar,ma,1.0,start,.1,n,nn); i=integers(nlag+1,norows(x)); y=array(norows(x):)+missing(); rr=noise*rn(x); y(i)= x(i-nlag)+rr(i); do ii=1,nlag; x(ii)=missing(); y(ii)=missing(); enddo; x=goodrow(x); y=goodrow(y); call names(all); call character(title,'Effect of Autocorrelation on cross correlations'); /$ call tabulate(x,y); call ccftest(x,y,nccf,lags,title); b34srun; /; /;CFREQ Cumulative Frequency of a Series /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(cfreq); call cfreq(gasout,sgasout,cc); call tabulate(gasout,sgasout,cc); b34srun; /; /;CHARDATE Illustrates Date processing /; b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; /; /;CHARDATEMY Illustrates Date processing /; b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); time = rtoch(array(n:)); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); time(i) =chartime(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday,time); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; /; /;CHARTIME Obtains Character Time processing /; b34sexec matrix; call echooff; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); time = rtoch(array(n:)); do i=1,n; base=base+.11; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); time(i) =chartime(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday,time); b34srun; /; /;CHAR_1 Illustrates Character Data /; b34sexec matrix; * call screenouton; * Current limit of character command is 132 cols; * if we c=pass in a string ; call character(cc,'This is a character*1 array'); call print(cc); call character(cclong,'This is a much longer string that goes for more t han one line.'); call print(cclong); call character(cshort,'shortc'); call print(cshort); call names; call names(all); * shows character*8 to character*1. Here there is no 132 limit ; c=rtoch(array(3:)); c(1)='mary'; c(2)='sue'; c(3)='joan'; call character(cc,c); call print(c,cc); call names(all); b34srun; /; /;CHAR_2 Illustrates Character Data with Arrays /; b34sexec matrix; * call screenouton; call character(cc,'This is a character*1 array'); junk=cc; call print(cc,junk); call character(cclong,'This is a much longer string that goes for more than one line.'); call print(cclong); call names; call names(all); call character(c,'x12x12x12'); call print(c); call names(all); cca=array(:c); call print(cca); call character(jj,'B234567890abcdefghijklmnopqrstuvwxyz'); cca2=array(:jj); call print(cca2); newca2=array(6,6:cca2); call print(newca2); * Two ways to load data ; newca3=array(6,12:cca2,cca2); newca4=array(:cca2,cca2); call names(all); call print(newca3,newca4); call print('Note how each letter is doubled',cca2,cca2); cc=array(3,3:c); call names; call names(all); call print(cc); b34srun; /; /;CHAR_3 Character Data with Subscripts /; b34sexec matrix; call character(cc,'1234567890qwertyuiop'); i=integers(7); ccc=cc(i); i=i+3; cccp3=cc(i); call print(cc,ccc,cccp3); * get a large character work array; call character(clarge,rtoch(array(1000:))); call names(all); b34srun; /; /;CHAR_4 Character*8 Data /; b34sexec matrix; cc=array(3:'Mary', 'Sue','Judy'); call print(cc); * Put in character data with analytical statements ; * cc is character*8 ; cc(1)='one'; cc(2)='two'; cc(3)='Three'; call print(cc); b34srun; /; /;CHAR_5 Character*1 Processing /; b34sexec matrix; call echooff; x=rn(matrix(30,30:)); call character(ii,'Element (1, '); call character(ii2,' ':6); jj=integers(12,17); call names(all); do i=1,30; call inttostr(i,ii2,'(i6)'); ii(jj)=ii2(jj-11); call character(rp,')'); /$ ********************************************************** /$ Warning the statement /$ ii(18)=')'; /$ does not work since it will be redefined to be character*8 /$ and will be outside the 132 range /$ ********************************************************** ii(18)=rp; call print(ii,x(1,i) :line); next i; call names(all); b34srun; /; /;CHAR_6 Character data in subroutines /; b34sexec matrix; x=12.; call print('Is this on two lines ',x); call print('Is this 12 on a line ',x:); call character(two,'two'); call print('Is this one ',two ); call print('Is this one ',two:); call print('Is this one':); call print('Is this one '); call print(two:); call print(two); subroutine test(a); call print('In routine test a= ',a:); return; end; * Passing as a string does not work ; call test('This passed to test'); * Pass as a character ; call character(jj,'some junk is here'); call print(jj:); * Passing as a character variable ; call test(jj); b34srun; /$ /$ Case when Character Data is changed when a variable is passed. /$ b34sexec matrix; subroutine test(a); call names(all); call print('In routine test a= ',a:); call character(a,'This is a very long string that is added'); return; end; call test('junk'); call character(jj,'some funny thinmgs are here'); call print(jj:); call test(jj); call print(jj:); b34srun; /; /;CHAR_7 Creating Multi-Dimensional Character*1 Arrays /; b34sexec matrix; call char1(c1,'This is a long string, can you see it'); call char1(c2,'This is not big '); call print(c1,c2); call char1(x ,'This is a long string, can you see it' 'so is this ' 'But this is not'); call names(all); call print(c1,c2,x); b34srun; /; /;CHAR_8 Creating and Testing Character*1 Data /; b34sexec matrix; /$ /$ Job shows creating char*1 and char*1 variables /$ and moving data between the variable types /$ cc8a='012'; call character(cc8, '012':8); call character(cc4, '012':4); call character(cc0, '0' :1); call character(cc1, '1' :1); call names(all); call print(cc4(2),cc0); if(cc4(2).eq.cc0)call print('yes-error'); call print(cc4(1),cc0); if(cc4(1).eq.cc0)call print('yes-right1'); call print(cc4(2),cc0); if(cc4(2).ne.cc0)call print('yes-right2'); call print(cc4(1),cc1); if(cc4(1).ne.cc1)call print('yes-right3'); cc=array(:0.,1.,2.); call print(cc); if(cc(2).eq.0.)call print('yes-error'); if(cc(1).eq.0.)call print('yes-right1'); if(cc(2).ne.0.)call print('yes-right2'); if(cc(1).ne.1.)call print('yes-right3'); b34srun; /; /;CHAR_9 Advanced Character Processing /; b34sexec matrix; * Job illustrates character processing; * ; /$ place ; inside a character array call igetchari(59,semic); * Strings placed inside character*8 variables ; cc1='*'; cc2='**'; cc3='***'; * Build character*1 size 1, 2 and 3 ; * Note that the sizes of variables reflect # characters ; call character(c1,'*'); call character(c2,'**'); call character(c3,'***'); * Here we add more blanks ; call character(c1_2,'*':2); call character(c2_5,'**':5); call character(c3_8,'***':8); call names(all); s=sfam(c1(1)); call print(semic,cc1,cc2,cc3,s,sfam(c1),c2,c3,c1_2,c2_5,c3_8); c1(1)=s; call print(c1); call names(all); * Build a longer string and offset ; call character(astring,'ABCDEFG222222'); call names(all); call print(astring); call igetichar(astring,ichar); ichar2=ichar+1; call igetchari(ichar2,newstr); call print(ichar,ichar2,astring,newstr); call character(astring,'ABCDEFG'); call names(all); call print(astring); call igetichar(astring,ichar); ichar2=ichar+1; call igetchari(ichar2,newstr); call print(astring,ichar,ichar2,newstr); * Look at possible chartacters ; i=integers(0,255); call igetchari(i,newstr); call names(all); call tabulate(i,newstr); b34srun; /; /;CHISPROB Chi-Squared distribution /; b34sexec matrix; * Sample problem from IMSL page 919; df = 2.0; chisq = .15; p=chisqprob(chisq,df); call print('The probability that chi-squared with DF ',df, 'is less than ',chisq,' is ', p, 'The answer should be .0723'); chisq = 3.0; p=1.0 - chisqprob(chisq,df); call print('The probability that chi-squared with df',df, ' is greater than', chisq,' is ',p,' Answer should be .2231'); b34srun; /; /;CHTOR Converts Character*8 to Real*8 /; b34sexec matrix; x=array(5:1 2 3 4 5); call print(x); cx=rtoch(x); call names; newx=chtor(cx); call tabulate(x,newx); b34srun; /; /;CHTOHEX Character to Hex conversionm /; b34sexec matrix; cc=c1array(128:); i=integers(0,127); call igetchari(i,cc); call igetichar(cc,iitest); call chtohex(cc,hexcc); call hextoch(hexcc,cctest); call tabulate(i,cc,iitest,hexcc,cctest); b34srun; /; /;CHTOHEX2 Extended Charater to Hex Conversion /; b34sexec matrix; /$ Illustrates Character Handeling and Hex Conversion; /$ Looking at Printable Characters ; i=integers(33,127); call igetchari(i,cc); call names(all); call tabulate(i,cc); call igetichar(cc,iitest); call chtohex(cc,hexcc); /$ Repack this character*2 array saved as character*1; /$ Next two statments work the same /$ hexcc2= array(norows(hexcc)/2,2:hexcc); hexcc2=c1array(norows(hexcc)/2,2:hexcc); hex1=hexcc2(,1); hex2=hexcc2(,2); call hextoch(hexcc,cctest); xx=transpose(hexcc2); call print(xx,hexcc2); call hextoch(xx,cctest2); call names(all); /$ get hexcc2 in a printable variable; blank=c1array(norows(hex1):); call names(all); c8var=catcol(hex1, hex2,blank,blank, blank, blank,blank,blank); call names(all); /$ call print(c8var); c8var=c8array(norows(c8var):transpose(c8var)); call tabulate(i,cc,iitest,hex1,hex2,cctest,cctest2,c8var); b34srun; /; /;CMAXF1_2 Constrained Minimum testing CMAXF1 & CMACF2 /; b34sexec matrix; * Constrained Minimum tests both commands CMAXF1 and CMAXF2 ; * func = 3.*x2**2. + 4*x1**2 - x2 + 2.*x1 ; * where -1. LE x1 LE 0. and 0. LE x2 LE 1 ; * where answers should be -.2500, .1667 and func = -.3333 ; * To test further set :nstart 100 ; program test; func=(-1.0)*(((3.)*(x2**2.)) + (4.*(x1**2.)) - x2 + (2.*x1)); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; call print(test); rvec=array(2:-1.2 1.0); ll=array(2:-1.,0.0); uu=array(2:.0 ,1.0 ); call echooff; call cmaxf1(func :name test :parms x1 x2 :lower ll :upper UU :nstart 12 :nsig 3 :print); rvec=array(2:-1.2 1.0); ll=array(2:-1.,0.0); uu=array(2:.0 ,1.0 ); call echooff; call cmaxf2(func :name test :parms x1 x2 :lower ll :upper UU :print); b34srun; /; /;CMAXF1_A Constrained Minimum testing CMAXF1 /; b34sexec matrix; * Constrained Minimum tests command CMAXF1 ; * func = 3.*x2**2. + 4*x1**2 - x2 + 2.*x1 ; * where -1. LE x1 LE 0. and 0. LE x2 LE 1 ; * where answers should be -.2500, .1667 and func = -.3333 ; program test; func=(-1.0)*(((3.)*(x2**2.)) + (4.*(x1**2.)) - x2 + (2.*x1)); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; call print(test); rvec=array(2:-1.2 1.0); ll=array(2:-1.,0.0); uu=array(2:.0 ,1.0 ); call echooff; call cmaxf1(func :name test :parms x1 x2 :lower ll :upper UU :nstart 12 :nsig 3 :print); b34srun; /; /;CMAXF1_B Constrained Minimum testing CMAXF1 /; b34sexec matrix; * Minimum of FUNC = 100.*(x2-x1*x1)**2. + (1.-x1)**2. ; * where -2.0 le x1 le .5 ; * -1.0 le x2 le 2.0 ; * with answers .500 .250 and func = .250 ; * can be found with the commands: ; program test; func=(-1.0)*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; call print(test); rvec=array(2:-1.2, 1.0); ll= array(2:-2. ,-1.0); uu= array(2:.5 , 2.0); call echooff; call cmaxf1(func :name test :parms x1 x2 :ivalue rvec :lower ll :upper uu :print); b34srun; /; /;CMAXF2_1 Constrained Minimum /; b34sexec matrix; * Minimum of FUNC = 100.*(x2-x1*x1)**2. + (1.-x1)**2. ; * where -2.0 le x1 le .5 ; * -1.0 le x2 le 2.0 ; * with answers .500 .250 and func = .250 ; * can be found with the commands: ; program test; func=(-1.0)*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; rvec=array(2:-1.2, 1.0); ll= array(2:-2. ,-1.0); uu= array(2:.5 , 2.0); call echooff; call cmaxf2(func :name test :parms x1 x2 :ivalue rvec :lower ll :upper uu :print); b34srun; /; /;CMAXF2_2 Constrained Minimum Gradiant Supplied /; b34sexec matrix; * Minimum of FUNC = 100.*(x2-x1*x1)**2. + (1.-x1)**2. ; * where -2.0 le x1 le .5 ; * -1.0 le x2 le 2.0 ; * with answers .500 .250 and func = .250 ; * can be found with the commands: ; program test; func=(-1.0)*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; program der; g(1)= (400.0*(x2-x1*x1)*x1) + (2.0*(1.0-x1)); g(2)= -200.0*(x2-x1*x1); return; end; call print(test,der); rvec=array(2:-1.2, 1.0); ll= array(2:-2. ,-1.0); uu= array(2:.5 , 2.0); call echooff; call cmaxf2(func g :name test der :parms x1 x2 :ivalue rvec :lower ll :upper uu :print); b34srun; /; /;CMAXF2_3 Constrained Minimum using CMAXF2 /; b34sexec matrix; * Minimum of FUNC = 100.*(x1*x1-x2)**2. + (1.-x1)**2. ; * where -2.0 le x1 le 2.0 ; * -1.0 le x2 le 2.0 ; * with answers 1. 1. and func = 0.0 ; * can be found with the commands: ; program test; func=(-1.0)*(100.*((x1*x1-x2))**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; rvec=array(2:-1.2, 1.0); ll= array(2:-2. ,-1.0); uu= array(2: 2. , 2.0); call echooff; call cmaxf2(func :name test :parms x1 x2 :ivalue rvec :lower ll :upper uu :print); b34srun; /; /;CMAXF3_1 Constrained Minimum using CMAXF3 /; b34sexec matrix; * Minimum of FUNC = 100.*(x1*x1-x2)**2. + (1.-x1)**2. ; * where -2.0 le x1 le 2.0 ; * -1.0 le x2 le 2.0 ; * with answers 1.0 1.0 and func = 0.0 ; * can be found with the commands: ; program test; func=(-1.0)*(100.*(x1*x1-x2)**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; rvec=array(2:-1.2, 1.0); ll= array(2:-2. ,-1.0); uu= array(2: 2. , 2.0); call echooff; call cmaxf3(func :name test :parms x1 x2 :ivalue rvec :maxit 300 :lower ll :upper uu :print); b34srun; /; /;CMAXF3_2 Constrained Minimum /; b34sexec matrix; * Constrained Minimum tests CMAXF3 ; * func = 3.*x2**2. + 4*x1**2 - x2 + 2.*x1 ; * where -1. LE x1 LE 0. and 0. LE x2 LE 1 ; * where answers should be -.2500, .1667 and func = -.3333 ; program test; func=(-1.0)*(((3.)*(x2**2.)) + (4.*(x1**2.)) - x2 + (2.*x1)); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; call print(test); rvec=array(2:-1.2 1.0); ll=array(2:-1.,0.0); uu=array(2:.0 ,1.0 ); call echooff; call cmaxf3(func :name test :parms x1 x2 :lower ll :upper UU :maxit 300 :print); b34srun; /; /;CMAXF3_3 Constrained Minimum using CMAXF3 /; b34sexec matrix; * Minimum of FUNC = 100.*(x1*x1-x2)**2. + (1.-x1)**2. ; * where -2.0 le x1 le .5 ; * -1.0 le x2 le 2.0 ; * with answers .5 .25 and func = .250 ; * can be found with the commands: ; program test; func=(-1.0)*(100.*(x1*x1-x2)**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; rvec=array(2:-1.2, 1.0); ll= array(2:-2. ,-1.0); uu= array(2:.5 , 2.0); call echooff; call cmaxf3(func :name test :parms x1 x2 :ivalue rvec :maxit 300 :lower ll :upper uu :print); b34srun; /; /;COINT2 Tests Cointegration of two series /; b34sexec options ginclude('b34sdata.mac') macro(coint6); b34srun; b34sexec matrix; call loaddata; call load(coint2); call print(coint2); call character(xname,'Enders y Series'); call character(yname,'Enders z Series'); call echooff; lagx=1; lagy=1; dflag=4; call coint2(y,z,xname,yname,dfx,dfy, adfx,adfy,lagx,lagy,speedx,speedy,tspeedx,tspeedy, dfx2,dfy2,adfx2,adfy2,dflag,resid0,resid1,resid2,1); call print(speedx,speedy,tspeedx,tspeedy); b34srun; %b34sendif; %b34sif(&test2.eq.1)%then; /; /;COINT2LM Tests Cointegration of two series with L1 & MM /; b34sexec options ginclude('b34sdata.mac') macro(coint6); b34srun; b34sexec matrix cbuffer=100000; call loaddata; call load(coint2LM); call print(coint2LM); call character(xname,'Enders y Series'); call character(yname,'Enders z Series'); call echooff; lagx=1; lagy=1; dflag=4; call coint2LM(y,z,xname,yname,dfx,dfy, adfx,adfy,lagx,lagy,speedx,speedy,tspeedx,tspeedy, l1speedx,l1speedy,mmspeedx,mmspeedy, dfx2,dfy2,adfx2,adfy2,dflag,resid0,resid1,resid2,1); call print(speedx,speedy, tspeedx, tspeedy, l1speedx,l1speedy,mmspeedx,mmspeedy); b34srun; /; /;COINT2M Tests Moving Cointegration of Two Series /; b34sexec options ginclude('b34sdata.mac') macro(coint6); b34srun; b34sexec matrix; call loaddata; call load(coint2); call load(coint2m); call print(coint2,coint2m); call character(xname,'Enders y Series'); call character(yname,'Enders z Series'); call echooff; number=60; lagx=1; lagy=1; call coint2m(y,z,xname,yname,number,lagx,lagy, speedx,speedy,tspeedx,tspeedy); call graph(speedx,tspeedx :heading 'Enders Y Series Moving Error Correction'); call graph(speedy,tspeedy :heading 'Enders Z Series Moving Error Correction'); call tabulate(speedx,speedy,tspeedx,tspeedy); b34srun; /; /;COINT2M2 Tests Moving Coint. of Two Series with L1 & MM - Exte /; b34sexec options ginclude('b34sdata.mac') macro(coint6); b34srun; b34sexec matrix cbuffer=100000; call loaddata; call load(coint2lm); call load(coint2m2); call print(coint2lm,coint2m2); call character(xname,'Enders y Series'); call character(yname,'Enders z Series'); call echooff; number=60; lagx=1; lagy=1; dflag=4; /$ Shows simple call /$ call coint2m(y,z,xname,yname,number,lagx,lagy,speedx,speedy, /$ tspeedx,tspeedy); /$ call coint2m2(y,z,xname,yname,number,lagx,lagy,speedx,speedy, tspeedx,tspeedy,l1speedx,l1speedy,mmspeedx,mmspeedy, dfx,dfy,adfx,adfy,dfres1, dfres2,adfres1,adfres2,dflag); call graph(speedx,tspeedx :nokey :heading 'Enders Y Series Moving Error Correction'); call graph(speedy,tspeedy :nokey :heading 'Enders Z Series Moving Error Correction'); call graph(speedx,l1speedx,mmspeedx :nokey :heading 'Enders Z Series Moving Error Correction'); call graph(speedy,l1speedy,mmspeedy :nokey :heading 'Enders Z Series Moving Error Correction'); call graph(dfx,dfy,speedx,speedy :nokey); call graph( speedx,speedy,tspeedx,tspeedy :nokey); call tabulate(speedx,speedy,tspeedx,tspeedy,dfx,dfy,dfres1,dfres2); call tabulate(speedx,speedy,tspeedx,tspeedy,adfx,adfy,adfres1,adfres2); call tabulate(speedx,l1speedx,mmspeedx,speedy,l1speedy,mmspeedy); b34srun; /; /;COINT2ME Tests Moving Cointegration of Two Series - Extended /; b34sexec options ginclude('b34sdata.mac') macro(coint6); b34srun; b34sexec matrix; call loaddata; call load(coint2); call load(coint2me); call print(coint2,coint2me); call character(xname,'Enders y Series'); call character(yname,'Enders z Series'); call echooff; number=60; lagx=1; lagy=1; dflag=4; /$ Shows simple call /$ call coint2m(y,z,xname,yname,number,lagx,lagy,speedx,speedy, /$ tspeedx,tspeedy); /$ call coint2me(y,z,xname,yname,number,lagx,lagy,speedx,speedy, tspeedx,tspeedy,dfx,dfy,adfx,adfy,dfres1, dfres2,adfres1,adfres2,dflag); call graph(speedx,tspeedx :heading 'Enders Y Series Moving Error Correction'); call graph(speedy,tspeedy :heading 'Enders Z Series Moving Error Correction'); call graph(dfx,dfy,speedx,speedy); call graph( speedx,speedy,tspeedx,tspeedy); call tabulate(speedx,speedy,tspeedx,tspeedy,dfx,dfy,dfres1,dfres2); call tabulate(speedx,speedy,tspeedx,tspeedy,adfx,adfy,adfres1,adfres2); b34srun; /; /;COINT3 Tests Cointegration of Three Series /; b34sexec options ginclude('b34sdata.mac') macro(coint6); b34srun; b34sexec matrix; call loaddata; call load(coint3); call print(coint3); call character(xname,'Enders w Series'); call character(yname,'Enders y Series'); call character(zname,'Enders z Series'); call echooff; lagx=1; lagy=1; lagz=1; dflag=4; call coint3(w,y,z,xname,yname,zname,dfx,dfy,dfz, adfx,adfy,adfz,lagx,lagy,lagz,speedx,speedy,speedz, tspeedx,tspeedy,tspeedz,dfx2,dfy2,dfz2,adfx2,adfy2, adfz2,dflag,resid0,resid1,resid2,resid3,1); call print(speedx,speedy,speedz); call print(tspeedx,tspeedy,tspeedz); b34srun; /; /;COINT3ME Tests Moving Cointegration of Three Series - Extended /; b34sexec options ginclude('b34sdata.mac') macro(coint6); b34srun; b34sexec matrix; call loaddata; call load(coint3); call load(coint3me); call print(coint3,coint3me); call character(xname,'Enders y Series'); call character(yname,'Enders z Series'); call character(zname,'Enders w Series'); call echooff; number=60; lagx=1; lagy=1; lagz=1; dflag=4; call coint3me(y,z,w,xname,yname,zname,number,lagx,lagy,lagz, speedx,speedy,speedz,tspeedx,tspeedy,tspeedz, dfx,dfy,dfz,adfx,adfy,adfz,dfres1,dfres2,dfres3, adfres1,adfres2,adfres3,dflag); call graph(speedx,tspeedx :heading 'Enders Y Series Moving Error Correction'); call graph(speedy,tspeedy :heading 'Enders Z Series Moving Error Correction'); call graph(speedz,tspeedz :heading 'Enders w series Moving Error Correction'); call tabulate(speedx,speedy,speedz,tspeedx,tspeedy,tspeedz); b34srun; /; /;COMB Combination of N objects taken M at a time /; b34sexec matrix; n=6; call echooff; do m=1,4; jj=comb(n,m); call print('N ',n,'M ',m,'# ',jj); test=idint(matrix(jj,m:)); do kk=1,jj; test(kk,)=comb(n,m,kk); enddo; call print(test); enddo; b34srun; /; /;COMB_2 Illustrates BOUNDS Analysis using comb /; b34sexec matrix; /$ Bounds analysis - Code template. Data is in xold(n,upperi) /$ Want to keep first loweri-1 including constant in col 1 in model /$ Want to see how other variables change "focus" coefficients. /$ upperi outer limit on xold index /$ loweri lower limit on xold => we always use col 1-(loweri-1) /$ ********************************************** /$ build test data ** User call data routine here /$ User sets n, upperi loweri /$ If n=300 will not get significance due to low single / noise /$ ratio. If n = 30000 we can get significance!! This shows /$ effect of sample size on the estimation. The range of the /$ coef will tighten up! n=300; upperi=10; loweri=4; xold=rn(matrix(n,upperi:)); xold(,1)=1.0; b=vector(upperi:)+2.; b(1)=1.0; y=vector(n:); y=xold*b + 100.* rn(y); /$ ********************************************** /$ start analysis oldcoef=vector(loweri-1:); maxcoef=vector(loweri-1:); mincoef=vector(loweri-1:); call olsq(y xold :noint :print); i=integers(loweri-1); oldcoef(i)=%coef(i); maxcoef(i)=%coef(i); mincoef(i)=%coef(i); call echooff; nn=upperi-loweri+1; do num_in=1,(upperi-loweri+1); kk=loweri-1+num_in; newx=matrix(n,kk:); /$ load the data that does not change newx(,i)=xold(,i); /$ num_in = number in each eq /$ numpass = number of combinations given num_in numpass=comb((upperi-loweri+1),num_in); /$ estimation block jjin=integers(loweri,kk); do ii=1,numpass; iv=comb(nn,num_in,ii) + loweri-1; /$ This can be turned on /$ call print(iv); /$ Code is slower than a vectorized setup but more clear do jjcopy=1,norows(iv); j1=jjin(jjcopy); j2=iv(jjcopy); newx(,j1)=xold(,j2); enddo; /$ If want to test t, l1, minimax then in place of %coef /$ use another vector /$ Can turn on here if want to see the output at every step /$ call olsq(y newx :noint :print); call olsq(y newx :noint); do kk=1,norows(maxcoef); if(%coef(kk).gt.maxcoef(kk))maxcoef(kk)=%coef(kk); if(%coef(kk).lt.mincoef(kk))mincoef(kk)=%coef(kk); enddo; enddo; /$ End estimation block *************************** call print(' '); call print('Coef Distribution given # in was ',num_in:); call tabulate(mincoef,oldcoef,maxcoef); enddo; b34srun; /; /;COMB_3 Bounds analysis on real Data /; B34SEXEC OPTIONS GINCLUDE('berndt.mac') MACRO = cigad $ B34Seend$ b34sexec matrix; call loaddata; /$ Bounds analysis - Code template. Data is in xold(n,upperi) /$ Want to keep first loweri-1 including constant in col 1 in model /$ Want to see how other variables change "focus" coefficients. /$ upperi outer limit on xold index /$ loweri lower limit on xold => we always use col 1-(loweri-1) /$ ********************************************** /$ build test data ** User call data routine here /$ User sets n, upperi loweri , includes intercept /$ We save the data in a b34s file /$ ****************** All OLS Turned on ************************* n=49; upperi=9; loweri=4; xold(,1)=1.0; xold(,2)=vfam(rprice); xold(,3)=vfam(realad); xold(,4)=vfam(time); xold(,5)=vfam(f); xold(,6)=vfam(l); xold(,7)=vfam(astock); xold(,8)=vfam(df); xold(,9)=vfam(incpc); y=vfam(salespc); /$ This saves coef in another form nn=upperi-loweri+1; Lcoef1=vector(nn:); Lcoef2=vector(nn:); Lcoef3=vector(nn:); Ucoef1=vector(nn:); Ucoef2=vector(nn:); Ucoef3=vector(nn:); /$ ********************************************** /$ start analysis oldcoef=vector(loweri-1:); maxcoef=vector(loweri-1:); mincoef=vector(loweri-1:); call olsq(y xold :noint :print); i=integers(loweri-1); oldcoef(i)=%coef(i); maxcoef(i)=%coef(i); mincoef(i)=%coef(i); call echooff; nn=upperi-loweri+1; do num_in=1,(upperi-loweri+1); kk=loweri-1+num_in; newx=matrix(n,kk:); /$ load the data that does not change newx(,i)=xold(,i); /$ num_in = number in each eq /$ numpass = number of combinations given num_in numpass=comb((upperi-loweri+1),num_in); /$ estimation block jjin=integers(loweri,kk); do ii=1,numpass; iv=comb(nn,num_in,ii) + loweri-1; /$ This can be turned on /$ call print(iv); /$ Code is slower than a vectorized setup but more clear do jjcopy=1,norows(iv); j1=jjin(jjcopy); j2=iv(jjcopy); newx(,j1)=xold(,j2); enddo; /$ If want to test t, l1, minimax then in place of %coef /$ use another vector /$ Can turn on here if want to see the output at every step /$ All Models turned on call olsq(y newx :noint :print); /$ call olsq(y newx :noint); do kk=1,norows(maxcoef); if(%coef(kk).gt.maxcoef(kk))maxcoef(kk)=%coef(kk); if(%coef(kk).lt.mincoef(kk))mincoef(kk)=%coef(kk); enddo; enddo; /$ End estimation block *************************** call print(' '); call print('Coef Distribution given # in was ',num_in:); call tabulate(mincoef,oldcoef,maxcoef); /$ ********************** coef save *************************** lcoef1(num_in)=mincoef(1); lcoef2(num_in)=mincoef(2); lcoef3(num_in)=mincoef(3); ucoef1(num_in)=maxcoef(1); ucoef2(num_in)=maxcoef(2); ucoef3(num_in)=maxcoef(3); /$ ************************************************************* enddo; call tabulate(lcoef1,ucoef1,lcoef2,ucoef2,lcoef3,ucoef3); call makedata(lcoef1,ucoef1,lcoef2,ucoef2,lcoef3,ucoef3 :file 'bounds.b34'); b34srun; b34sexec options include('bounds.b34'); b34srun; b34sexec list; b34srun; /; /;COMPLEX Make a Complex Number from Real*8 /; b34sexec matrix; r=.3; ii=.4; cc=complex(r,ii); x=rec(matrix(4,4:)); cx =complex(x); cx2=complex(x,dsqrt(dabs(x))); call names(all); call print(r,ii,cc,x,cx,cx2); b34srun; /; /;COMPRESS Illustrates COMPRESS /; b34sexec matrix; * Math with matrix and vectors ; * For bigger problems, change n; * Note how CALL COMPRESS saves space; * Further problems done to test system; * If the matrix procedure should lock unexpectedly as arrays get bigger and bigger, use compress to compact. Compress is not automatic since it takes time; n=3; right=integers(1,((n*n)-1))+10; call print('Right ',right); x=matrix(n,n:right,-7); x2=x*2.; v=vector(n:integers(1,n)); call print('X, 2*x v' ,x,x2,v) ; call print('Inverse of x (INV)' ,(1./x)) ; call print('X*inv' ,x*(1./x)); call print('Vector times matrix (v*x)' ,v*x) ; call print('Matrix times vector (x*v)' ,x*v) ; call print('Matrix times matrix (x*x2)' ,x*x2) ; call print('Matrix times scaler (x*2.)' ,x*2.) ; call print('Scaler times Matrix (3.*x)' ,3.*x) ; call names(all); call compress; call names(all); call print('Vector plus matrix (v+x)' ,v+x) ; call print('Matrix plus vector (x+v)' ,x+v) ; call print('Matrix plus matrix (x+x2)' ,x+x2) ; call print('Matrix plus scaler (x+2.)' ,x+2.) ; call print('Scaler plus matrix (3.+x)' ,3.+x) ; call print('Vector minus matrix (v-x)' ,v-x) ; call print('Matrix minus vector (x-v)' ,x-v) ; call print('Matrix minus matrix (x-x2)' ,x-x2) ; call print('Matrix minus scaler (x-2.)' ,x-2.) ; call print('Scaler minus matrix (3.-x)' ,3.-x) ; call print('Array Math Here '); x=afam(x); v=afam(v); x2=x*2.; call print('X, 2*x v' ,x,x2,v) ; call print('Inverse of x (INV)' ,(1./x)) ; call print('X*inv' ,x*(1./x)); call print('Array(1) times Array(2) (v*x)' ,v*x) ; call print('Array(2) times Array(1) (x*v)' ,x*v) ; call print('Array(2) times Array(2) (x*x2)' ,x*x2) ; call print('Array(2) times Scaler (x*2.)' ,x*2.) ; call print('Scaler times Array(2) (3.*x)' ,3.*x) ; call print('Array(1) plus Array(2) (v+x)' ,v+x) ; call print('Array(2) plus Array(1) (x+v)' ,x+v) ; call print('Array(2) plus Array(2) (x+x2)' ,x+x2) ; call print('Array(2) plus Scaler (x+2.)' ,x+2.) ; call print('Scaler plus Array(2) (3.+x)' ,3.+x) ; call print('Array(1) minus Array(2) (v-x)' ,v-x) ; call print('Array(2) minus Array(1) (x-v)' ,x-v) ; call print('Array(2) minus Array(2) (x-x2)' ,x-x2) ; call print('Array(2) minus scaler (x-2.)' ,x-2.) ; call print('Scaler minus Array(2) (3.-x)' ,3.-x) ; b34srun; /; /;COMPRESS_2 Compress called inside go to loop /; /$ Illustrates call compress inside a LOOP /$ /$ Job # 1 runs saving space /$ /$ Note difference in space use /$ b34sexec matrix; call echooff; subroutine doit(n); x=rn(matrix(n,n:)); c=inv(x); return; end; count=1.; top continue; call compress; call doit(100); count=count+1.0; if(count.le.100.)go to top; b34srun; /$ /$ Job # 2 has call compress turned off /$ b34sexec matrix; call echooff; subroutine doit(n); x=rn(matrix(n,n:)); c=inv(x); return; end; count=1.; top continue; /$ call compress; call doit(100); count=count+1.0; if(count.le.100.)go to top; b34srun; /; /;COMPRESS_3 Compress inside a dowhile loop /; b34sexec matrix; sum=0.0; add=1.; count=1.; tol=.1e-8; nn=1; call echooff; subroutine testit(sum,add,count,tol,nn); dowhile (add.gt.tol); x=rn(matrix(200,20:)); y=rn(vector(200:)); cc=vector(20:)+1.0; y=x*cc+y; call olsq(y x); oldsum=sum; sum=oldsum+((1./count)**3.); count=count+1.; add=sum-oldsum; call compress(nn); call outstring(3,4,'count inside'); call outdouble(3,5, count); enddowhile; return; end; /$ Stand alone code ********************** dowhile (add.gt.tol); x=rn(matrix(200,20:)); y=rn(vector(200:)); cc=vector(20:)+1.0; y=x*cc+y; call olsq(y x); oldsum=sum; sum=oldsum+((1./count)**3.); count=count+1.; add=sum-oldsum; call compress(nn); call outstring(3,8,'count outside'); call outdouble(3,9, count); enddowhile; call print('Results outside subroutine':); call print('Sum was ',sum:); call print('Count was ',count); sum=0.0; add=1.; count=1.; tol=.1e-8; nn=1; call testit(sum,add,count,tol,nn); call print('Results inside subroutine':); call print('Sum was ',sum:); call print('Count was ',count); b34srun; /; /;CONSTRAIN Illustrates CONSTRAIN with MELD /; b34sexec matrix; i=array(:1. 2. 3.); j=array(:4.,5.,6.); k=array(:7.,8.,9.); call tabulate(i,j,k); call meld(i,j,k); f=i**2.+j**2.+k**2.; call tabulate(i,j,k,f); call constrain(i,j,k,f:var i :lower 2.); call tabulate(i,j,k,f); call constrain(i,j,k,f:var k :upper 8.); call tabulate(i,j,k,f); b34srun; /; /;CONTRACT Remove a substring from an array /; b34sexec matrix; call character(cc,'This is a test'); call print(cc); call ilocatestr(cc,istart,iend); i=integers(istart,iend); subs=cc(i); call print(subs); call contract(cc,istart,iend); oldnewcc=cc; call print(cc); call character(new,'aaaissaa'); call expand(cc,new,1,8); call print(oldnewcc,cc); * we want aabb at 5-8 in cc; * We do not want to expand; call character(cc,'This is a test'); call character(new,'aabb'); call contract(cc,5,8); call expand(cc,new,5,8); call print(cc); b34srun; /; /;COPYF Copy from a file to a file /; /$ Running Matlab script under B34S Matrix b34sexec options; pgmcards; x=rand(6) xi=inv(x); x*xi yy=[1 2 3 2 1] plot(yy) pause quit b34sreturn; b34srun; b34sexec matrix; call open(77,'test.m'); call rewind(77); call rewind(4); call copyf(4,77); call close(77); call copyout('test.m'); b34srun; /; /;COPYLOG Illustrates COPYLOG /; b34sexec matrix; * Tests I/O package ; * Real*8, Integer, Character*1 & Character*8 are written and read back ; * Note: Before reading, structure of object must be known!!!! ; n=5; test=rn(array(n:)); call open(70,'testdata'); call write(test,70); tmean=mean(test); call print(tmean); i=integers(1,20); call write(i,70); call character(cc,'This is a test I hope it works'); call write(cc,70); a=array(3:'joan','Margo','Nancy'); call write(a,70); call names(all); call free(test); call rewind(70); call close(70); call copylog('testdata'); call copyout('testdata'); b34srun; /; /;COPYOUT Illustrates COPYOUT Command /; b34sexec matrix; * Tests I/O package ; * Real*8, Integer, Character*1 & Character*8 are written and read back ; * Note: Before reading, structure of object must be known!!!! ; n=5; test=rn(array(n:)); call open(70,'testdata'); call write(test,70); tmean=mean(test); call print(tmean); i=integers(1,20); call write(i,70); call character(cc,'This is a test I hope it works'); call write(cc,70); a=array(3:'joan','Margo','Nancy'); call write(a,70); call names(all); call free(test); call rewind(70); call close(70); call copylog('testdata'); call copyout('testdata'); b34srun; /; /;COPYOUT2 Calls RATS under MATRIX Command /; /$ /$ Illustrates calling rats under b34s MATRIX /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; newgasi=gasin; newgaso=gasout; newgaso(3)=missing(); call makerats(gasin,newgasi,gasout,newgaso :file 'full.por'); call print(mean(gasin)); call open(70,'rats.in'); call character(cc,'all 3000'); call write(cc,70); call character(cc,"open data 'full.por'"); call write(cc,70); call character(cc,'data(format=portable)'); call write(cc,70); call character(cc,'table'); call write(cc,70); call character(cc,'print'); call write(cc,70); call rewind(70); call close(70); /$ Note : since command writes output !!! call copyout('full.por'); b34srun; /; /;CSPECTRAL Call CSPECTRAL Command => Cross Spectral Analysis /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; * For sample output See Stokes (1997) page 424; call cspectral(gasin,gasout,sinx,siny,cosx,cosy,px,py,sx,sy, rp,ip,cs,qs,a,k,ph,freq:1 2 3 4 3 2 1); freq2=freq/(2.0*pi()); period=vfam(1.0/afam(freq2)); call tabulate(freq2,period,sinx,siny,cosx,cosy,px,py,sx,sy); call tabulate(freq2,period,rp,ip,cs,qs,a,k,ph); call graph(freq2,a :heading 'Amplitude':plottype xyplot); call graph(freq2,k :heading 'Coherence':plottype xyplot); call graph(freq2,ph:heading 'Phase':plottype xyplot); b34srun; /; /;CSPLINE Calculate a cubic spline for 1 D data /; b34sexec matrix; n=11; ntest=(n*2)-1; * problem from IMSL for csint and csakm; x=grid(0.0, 1.0,(1.0/dfloat(n-1) )); f=dsin(15.*x); x2=grid(0.0,1.0,(1.0/dfloat(ntest-1))); ftest =dsin(15.*x2); testder=2.*x2*dcos(x2*x2); maxerr1=array(15:); maxerr2=array(15:); spline1 =cspline(x,f :type csint); spline2 =cspline(x,f :type csakm); fit1 =csplineval(spline1,x2); fit2 =csplineval(spline2,x2); err1=fit1-ftest; err2=fit2-ftest; call tabulate(x2,ftest,fit1,err1,fit2,err2); * Problem for cscon ; * Results tested for csint; x=array(9: 0.0 .1 .2 .3 .4 .5 .6 .8 1.); f=array(9: 0.0 .9 .95 .9 .1 .05 .05 .2 1.); spline1=cspline(x,f :type cscon); spline2=cspline(x,f :type csint); call print('Note: Break points in Col. 1':); call print('cscon results ',spline1); call print('csint results ',spline2); fit1=csplineval(spline1,x2); fit2=csplineval(spline2,x2); call tabulate(fit1,fit2); call graph(fit1,fit2); * Problem for csscv; n=300; x=grid(0.0, 3.0,(1.0/dfloat(n-1) )); f=1.0/(.1+(3.0*(x-1.0))**4.) ; call i_rnset(1234579); f = f+ (2.*rec(x :imsl10)) -1.; spline=cspline(x,f :type csscv :equal); testx=array(10:); do i=1,10; testx(i)=90.*dfloat(i-1)/dfloat(n-1); enddo; sval = csplineval(spline,testx) ; actual= 1.0/(.1+(3.0*(testx-1.0))**4.) ; error = sval-actual; call tabulate(testx,actual,sval,error); b34srun; /; /;CSPLINEDER Calculate spline derivative given spline value /; b34sexec matrix; n=11; ntest=(n*2); * problem from IMSL for csint; x=array(n:); x2=array(ntest:); do i=1,n; x(i)=dfloat(i-1)/10.; enddo; do i=1,ntest; x2(i)=dfloat(i-1)/20.; enddo; /$x=grid(0.0, 1.0,(1.0/dfloat(n-1) )); /$ x2=grid(0.0,1.0,(1.0/dfloat(ntest-1))); f = dsin(15.*x); f2 = dsin(15.*x2); df =15.0 *dcos(15.*x2); ddf=-225.*dsin(15.*x2); spline =cspline(x,f :type csint); cf =csplineder(spline,x2,0); ff =csplineval(spline,x2); cdf1 =csplineder(spline,x2,1); cddf1 =csplineder(spline,x2,2); err=cf-f2; /$ tests two ways to get same thing err0=ff-cf; /$ err1= df-cdf1; err2=ddf-cddf1; call tabulate(x2,cf,f2,err,df,cdf1,err1,ddf,cddf1,err2); b34srun; /; /;CSPLINEFIT Fit a 1 D Cubic Spline using alternative models /; b34sexec matrix; n=21; ntest=(n*2)-1; * problem from IMSL; x=3.0*grid(0.0, 1.0,(1.0/dfloat(n-1) )); f=dsin(x*x); x2=3.0*grid(0.0,1.0,(1.0/dfloat(ntest-1))); ftest =dsin(x2*x2); testder=2.*x2*dcos(x2*x2); maxerr1=array(15:); maxerr2=array(15:); do i=1,15; fit =csplinefit(x,f,x2,0 :type i); fitder=csplinefit(x,f,x2,1 :type i); maxerr1(i)=dmax(dabs(ftest-fit)) ; maxerr2(i)=dmax(dabs(testder-fitder)); enddo; type=integers(15); call print('maxerr1 is fit error. maxerr2 = derivative error'); call tabulate(type,maxerr1,maxerr2); b34srun; /; /;CSPLINEITG Calculate integral of a cubic spline /; b34sexec matrix; * problem from IMSL ; n=10; ntest=(n*2)-1; * problem from IMSL for csint and csakm; x =grid(0.0, 1.0,(1.0/dfloat(n-1) )); x2=grid(0.0,1.0,(1.0/dfloat(ntest-1))); f = x*x; fi = x*x*x/3.; spline =cspline(x,f :type csint); lower=0.0; upper=.5; cfi=csplineitg(lower,upper,spline); exact=upper*upper*upper/3.; err=cfi-exact; call Print('Problem # 1 ':); call print('Lower range ',lower:); call print('Upper range ',upper:); call print('Integral ',cfi:); call print('Exact ',exact:); call print('Error ',err); upper=.2; cfi=csplineitg(lower,upper,spline); exact=upper*upper*upper/3.; err=cfi-exact; call print('Problem # 2 ':) call print('Lower range ',lower:); call print('Upper range ',upper:); call print('Integral ',cfi:); call print('Exact ',exact:); call print('Error ',err); b34srun; /; /;CSPLINEVAL Calculate spline value given spline /; b34sexec matrix; n=11; ntest=(n*2)-1; * problem from IMSL for csint and csakm; x=grid(0.0, 1.0,(1.0/dfloat(n-1) )); f=dsin(15.*x); x2=grid(0.0,1.0,(1.0/dfloat(ntest-1))); ftest =dsin(15.*x2); testder=2.*x2*dcos(x2*x2); maxerr1=array(15:); maxerr2=array(15:); spline1 =cspline(x,f :type csint); spline2 =cspline(x,f :type csakm); fit1 =csplineval(spline1,x2); fit2 =csplineval(spline2,x2); err1=fit1-ftest; err2=fit2-ftest; call tabulate(x2,ftest,fit1,err1,fit2,err2); b34srun; /; /;CUSUM Cumulative Sum Function /; b34sexec matrix; n=10; a=dfloat(integers(n)); ccusum=cusum(a); ccusumsq=cusumsq(a); call tabulate(a,ccusum,ccusumsq); call print(sum(a),sumsq(a)); b34srun; /; /;CUSUMSQ Cumulative Sum of Squares function /; b34sexec matrix; n=10; a=dfloat(integers(n)); ccusum=cusum(a); ccusumsq=cusumsq(a); call tabulate(a,ccusum,ccusumsq); call print(sum(a),sumsq(a)); b34srun; /; /;CWEEK Character form of Week Day /; /$ Tests Y2K capability of B34S /$ /$ day month year read in and converted to julian /$ /$ julian = # of days since 1 Jan 1960 /$ /$ b34s data step looks at day ahead and behind /$ /$ dates in 1400's, 1800's 1900's 2000's and 2100's tested /$ /$ ******************************************************* /$ b34sexec options sasdateon; b34srun; b34sexec data heading('Y2K test') idvar=cdate1; input day month year ; build dayinyr dbehind1 dbehind2 dahead1 cweekd iweekd dahead2 qt cdate1 cdate2 julian julianp1 julianm1; character cdate1 cdate2 dbehind1 dbehind2 dahead1 dahead2 cweekd; gen julian = juldaydmy(day,month,year); gen dayinyr = julian - juldaydmy(1,1,getyear(julian))+1.; gen cdate1 = chardate(julian); gen cdate2 = chardatemy(julian); gen julianp1=julian+1.; gen julianm1=julian-1.; gen dbehind1= chardate(julianm1); gen dbehind2= chardatemy(julianm1); gen dahead1 = chardate(julianp1); gen dahead2 = chardatemy(julianp1); gen qt = getqt(julian); gen iweekd = iweek(julian); gen cweekd = cweek(julian); datacards; 9 9 1999 31 12 1999 1 1 2000 2 1 2000 3 1 2000 28 2 2000 29 2 2000 1 3 2000 31 12 2000 1 1 1850 31 12 1899 1 1 2001 5 1 2100 1 5 1492 1 1 1999 2 1 1999 1 2 1999 1 1 1960 b34sreturn; b34seend; b34sexec list ; b34srun; b34sexec list; var julian julianp1 julianm1; b34srun; /$ /$ Data passed to Matrix to see it it prints OK /$ b34sexec matrix; call loaddata; call names; call tabulate(day month year julian dayinyr dbehind1 dbehind2 dahead1 dahead2 qt); call tabulate(day month year julian julianm1 julianp1 cdate1 cdate2); tj =chardate(julian); tjm1 =chardate(julianm1); tjp1 =chardate(julianp1); iiweekd =iweek(julian); ccweekd =cweek(julian); julian =idint(julian); julianm1=idint(julianm1); julianp1=idint(julianp1); call print('This tests calculations within MATRIX of julian data'); call tabulate(day month year julian julianm1 julianp1 tj tjm1 tjp1); call tabulate(day,month,year,julian,iiweekd,ccweekd,iweekd,cweekd); b34srun; /; /;DABS Illustrate DABS Command /; b34sexec matrix; ints=integers(20); ints=ints-10; reals=dfloat(ints); aints=dabs(ints); areals=dabs(reals); areals2=dabs(r8tor16(reals)); call tabulate(ints,aints,reals,areals,areals2); b34srun; /; /;DARCOS Arc cosine of real*8 variable /; b34sexec matrix; x=array(:-1., -.5, 0.0, .5, 1.0); asin=darsin(x); acos=darcos(x); atan=datan(x); call tabulate(x,asin,acos,atan); b34srun; /; /;DARSIN Arc sin of real*8 variable /; b34sexec matrix; x=array(:-1., -.5, 0.0, .5, 1.0); asin=darsin(x); acos=darcos(x); atan=datan(x); call tabulate(x,asin,acos,atan); b34srun; /; /;DATAN Arc tan of real*8 variable /; b34sexec matrix; x=array(:-1., -.5, 0.0, .5, 1.0); asin=darsin(x); acos=darcos(x); atan=datan(x); call tabulate(x,asin,acos,atan); b34srun; /; /;DATAN2 Arc tan of two real*8 variable /; b34sexec matrix; x=array(:-1., -.5, 0.0, .5, 1.0); y=array(norows(x):)+2.; asin=darsin(x); acos=darcos(x); atan=datan(x); atan2=datan2(x,y); call tabulate(x,y,asin,acos,atan,atan2); b34srun; /; /;DATENOW Date now in form dd:mm:yy /; b34sexec matrix; call print('Date now is ',datenow():); call print('Time now is ',timenow():); b34srun; /; /;DBLE Real*4 to Real*8 /; b34sexec matrix; x=dfloat(integers(20)); xreal4=sngl(x); xreal8=dble(xreal4); call names(all); call tabulate(x,xreal4,xreal8); b34srun; /; /;DCONJ Conjugate of a complex number /; b34sexec matrix; cc=complex(dfloat(integers(10)),dsqrt(dfloat(integers(10)))); call tabulate(cc,dconj(cc)); b34srun; /; /;DCOS Illustrates Cosine /; b34sexec matrix; n=10.; test=grid(0.0,pi()*n,.1); cc=dcos(test); ss=dsin(test); call tabulate(test,cc,ss); call graph(test,cc,ss:heading 'Cosine & Sine' :plottype xyplot); b34srun; /; /;DCOSH Hyperbolic Cosine of real*8 value /; b34sexec matrix; x=dfloat(integers(-10,10)); dcosh2=dcosh(x); dsinh2=dsinh(x); dtanh2=dtanh(x); call tabulate(x,dcosh2,dsinh2,dtanh2); b34srun; /; /;DDOT Inner product and related commands /; b34sexec matrix; n=10; x=rn(vector(n:)); y=rn(x); call print(x,y); call print(x*y,ddot(x,y),afam(x)*afam(y),ddot(x,y:), sum(afam(x)*afam(y))); * Complex case ; cx=complex(x,y); cy=complex(y,x); call print(cx,cy); call print(cx*cy,dconj(cx)*cy,zdotu(cx,cy),zdotc(cx,cy), afam(cx)*afam(cy),dconj(afam(cx))*afam(cy), zdotu(cx,cy:),zdotc(cx,cy:), sum( afam(cx) *afam(cy)), sum(dconj(afam(cx))*afam(cy)) ); b34srun; /; /;DELETECOL Illustrates deletecolw Capability /; b34sexec matrix; n=6; x=matrix(n,n:integers(1,n*n)); call print(x); test=x; call deletecol(test); call print('We delete at the right',test); test=x; call deletecol(test,2,4); call print('We delete 4 cols after 1 and before old 2',test); b34srun; /; /;DELETEROW Illustrates deleterow Capability /; b34sexec matrix; n=6; x=matrix(n,n:integers(1,n*n)); call print(x); test=x; call deleterow(test); call print('We delete at the end',test); test=x; call deleterow(test,2,4); call print('We add 4 rows after 1 and before old 2',test); b34srun; /; /;DERF Error Function /; b34sexec matrix; x=grid(.1, 5., .2); derf1 =derf(x); derf1c =derfc(x); test =derf1 + derf1c; derf1_16 =derf(r8tor16(x)); derf1c16 =derfc(r8tor16(x)); test16 =derf1_16+derf1c16; call tabulate(x,derf1,derf1c,test,derf1_16 derf1c16,test16); b34srun; /; /;DERFC Inverse Error Function /; b34sexec matrix; x=grid(.1, 5., .2); derf1 =derf(x); derf1c =derfc(x); test =derf1 + derf1c; derf1_16 =derf(r8tor16(x)); derf1c16 =derfc(r8tor16(x)); test16 =derf1_16+derf1c16; call tabulate(x,derf1,derf1c,test,derf1_16 derf1c16,test16); b34srun; /; /;DERIVATIVE Derivative of a vector using Quadratic method. /; b34sexec matrix; * model is f(x) = 10. -.5*x + .01*x**2 ; x=afam(grid(.01,10.,.01)); fx=10. -.5*x + .01*x**2.; dd=derivative(fx,x); call graph(fx,dd :Heading 'Linear case'); test=-.5+.02*x; call tabulate(x,fx,dd,test); * model is f(x) = 10. -.5*x + .01*x**3 ; x=afam(grid(.01,10.,.01)); fx=10. -.5*x + .01*x**3.; dd=derivative(fx,x); call graph(fx,dd :Heading 'Non-linear case'); test=-.5+.03*x; call tabulate(x,fx,dd,test); b34srun; /; /;DESCRIBE Calculate Moment 1-4 and 6 of a series /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; x=rn(array(1000:)); call describe(x :print); * Show variables created in named storage ; call names(all); call describe(gasin :print); call describe(gasout :print); b34srun; /; /;DES Code / Decode Example /; b34sexec matrix; /$ 12345678901234567890123456789012 call character(line1,'This is a test of the system '); call character(line2,'This is line # 2 of code test'); call chtohex(line1,hexline1); call chtohex(line2,hexline2); call print(hexline1,hexline2); hexline1=c1array(4,16:hexline1); hexline2=c1array(4,16:hexline2); call print(hexline1,hexline2); in=catrow(hexline1,hexline2); call print(in); call character(key,'0101010101010101'); out=c1array(norows(in)*2,nocols(in):); in=transpose(in); do i=1,nocols(in); call des(in(,i),work ,key,0); out(,i)=work; enddo; call print(out); test=c1array(nocols(in),norows(in):); do i=1,nocols(in); call des(out(,i),work,key,1); call hextoch(work,work2); call print(work2); test(i,)=work2; enddo; call names(all); call print(test); newtest=submatrix(test,1,norows(test),1,nocols(test)/2); call print(c1array(norows(newtest)*nocols(newtest):transpose(newtest))); b34srun; /; /;DESTEST Numerical Recipes Test Cases /; b34sexec matrix; /$ Problems from Numerical Recipes Example Book (Fortran) /$ Cambridge University Press 1985 page 78-84 /$ /$ Tests B34S Character Handxeling Capability /$ datacards; /$ DES Validation, as per NBS publication 500-20 *** Initial Permutation and Expansion test: *** start 64 encode 0101010101010101 95F8A5E5DD31D900 8000000000000000 0101010101010101 DD7F121CA5015619 4000000000000000 0101010101010101 2E8653104F3834EA 2000000000000000 0101010101010101 4BD388FF6CD81D4F 1000000000000000 0101010101010101 20B9E767B2FB1456 0800000000000000 0101010101010101 55579380D77138EF 0400000000000000 0101010101010101 6CC5DEFAAF04512F 0200000000000000 0101010101010101 0D9F279BA5D87260 0100000000000000 0101010101010101 D9031B0271BD5A0A 0080000000000000 0101010101010101 424250B37C3DD951 0040000000000000 0101010101010101 B8061B7ECD9A21E5 0020000000000000 0101010101010101 F15D0F286B65BD28 0010000000000000 0101010101010101 ADD0CC8D6E5DEBA1 0008000000000000 0101010101010101 E6D5F82752AD63D1 0004000000000000 0101010101010101 ECBFE3BD3F591A5E 0002000000000000 0101010101010101 F356834379D165CD 0001000000000000 0101010101010101 2B9F982F20037FA9 0000800000000000 0101010101010101 889DE068A16F0BE6 0000400000000000 0101010101010101 E19E275D846A1298 0000200000000000 0101010101010101 329A8ED523D71AEC 0000100000000000 0101010101010101 E7FCE22557D23C97 0000080000000000 0101010101010101 12A9F5817FF2D65D 0000040000000000 0101010101010101 A484C3AD38DC9C19 0000020000000000 0101010101010101 FBE00A8A1EF8AD72 0000010000000000 0101010101010101 750D079407521363 0000008000000000 0101010101010101 64FEED9C724C2FAF 0000004000000000 0101010101010101 F02B263B328E2B60 0000002000000000 0101010101010101 9D64555A9A10B852 0000001000000000 0101010101010101 D106FF0BED5255D7 0000000800000000 0101010101010101 E1652C6B138C64A5 0000000400000000 0101010101010101 E428581186EC8F46 0000000200000000 0101010101010101 AEB5F5EDE22D1A36 0000000100000000 0101010101010101 E943D7568AEC0C5C 0000000080000000 0101010101010101 DF98C8276F54B04B 0000000040000000 0101010101010101 B160E4680F6C696F 0000000020000000 0101010101010101 FA0752B07D9C4AB8 0000000010000000 0101010101010101 CA3A2B036DBC8502 0000000008000000 0101010101010101 5E0905517BB59BCF 0000000004000000 0101010101010101 814EEB3B91D90726 0000000002000000 0101010101010101 4D49DB1532919C9F 0000000001000000 0101010101010101 25EB5FC3F8CF0621 0000000000800000 0101010101010101 AB6A20C0620D1C6F 0000000000400000 0101010101010101 79E90DBC98F92CCA 0000000000200000 0101010101010101 866ECEDD8072BB0E 0000000000100000 0101010101010101 8B54536F2F3E64A8 0000000000080000 0101010101010101 EA51D3975595B86B 0000000000040000 0101010101010101 CAFFC6AC4542DE31 0000000000020000 0101010101010101 8DD45A2DDF90796C 0000000000010000 0101010101010101 1029D55E880EC2D0 0000000000008000 0101010101010101 5D86CB23639DBEA9 0000000000004000 0101010101010101 1D1CA853AE7C0C5F 0000000000002000 0101010101010101 CE332329248F3228 0000000000001000 0101010101010101 8405D1ABE24FB942 0000000000000800 0101010101010101 E643D78090CA4207 0000000000000400 0101010101010101 48221B9937748A23 0000000000000200 0101010101010101 DD7C0BBD61FAFD54 0000000000000100 0101010101010101 2FBC291A570DB5C4 0000000000000080 0101010101010101 E07C30D7E4E26E12 0000000000000040 0101010101010101 0953E2258E8E90A1 0000000000000020 0101010101010101 5B711BC4CEEBF2EE 0000000000000010 0101010101010101 CC083F1E6D9E85F6 0000000000000008 0101010101010101 D2FD8867D50D2DFE 0000000000000004 0101010101010101 06E7EA22CE92708F 0000000000000002 0101010101010101 166B40B44ABA4BD6 0000000000000001 *** Inverse Permutation and Expansion test *** continue 64 encode 0101010101010101 8000000000000000 95F8A5E5DD31D900 0101010101010101 4000000000000000 DD7F121CA5015619 0101010101010101 2000000000000000 2E8653104F3834EA 0101010101010101 1000000000000000 4BD388FF6CD81D4F 0101010101010101 0800000000000000 20B9E767B2FB1456 0101010101010101 0400000000000000 55579380D77138EF 0101010101010101 0200000000000000 6CC5DEFAAF04512F 0101010101010101 0100000000000000 0D9F279BA5D87260 0101010101010101 0080000000000000 D9031B0271BD5A0A 0101010101010101 0040000000000000 424250B37C3DD951 0101010101010101 0020000000000000 B8061B7ECD9A21E5 0101010101010101 0010000000000000 F15D0F286B65BD28 0101010101010101 0008000000000000 ADD0CC8D6E5DEBA1 0101010101010101 0004000000000000 E6D5F82752AD63D1 0101010101010101 0002000000000000 ECBFE3BD3F591A5E 0101010101010101 0001000000000000 F356834379D165CD 0101010101010101 0000800000000000 2B9F982F20037FA9 0101010101010101 0000400000000000 889DE068A16F0BE6 0101010101010101 0000200000000000 E19E275D846A1298 0101010101010101 0000100000000000 329A8ED523D71AEC 0101010101010101 0000080000000000 E7FCE22557D23C97 0101010101010101 0000040000000000 12A9F5817FF2D65D 0101010101010101 0000020000000000 A484C3AD38DC9C19 0101010101010101 0000010000000000 FBE00A8A1EF8AD72 0101010101010101 0000008000000000 750D079407521363 0101010101010101 0000004000000000 64FEED9C724C2FAF 0101010101010101 0000002000000000 F02B263B328E2B60 0101010101010101 0000001000000000 9D64555A9A10B852 0101010101010101 0000000800000000 D106FF0BED5255D7 0101010101010101 0000000400000000 E1652C6B138C64A5 0101010101010101 0000000200000000 E428581186EC8F46 0101010101010101 0000000100000000 AEB5F5EDE22D1A36 0101010101010101 0000000080000000 E943D7568AEC0C5C 0101010101010101 0000000040000000 DF98C8276F54B04B 0101010101010101 0000000020000000 B160E4680F6C696F 0101010101010101 0000000010000000 FA0752B07D9C4AB8 0101010101010101 0000000008000000 CA3A2B036DBC8502 0101010101010101 0000000004000000 5E0905517BB59BCF 0101010101010101 0000000002000000 814EEB3B91D90726 0101010101010101 0000000001000000 4D49DB1532919C9F 0101010101010101 0000000000800000 25EB5FC3F8CF0621 0101010101010101 0000000000400000 AB6A20C0620D1C6F 0101010101010101 0000000000200000 79E90DBC98F92CCA 0101010101010101 0000000000100000 866ECEDD8072BB0E 0101010101010101 0000000000080000 8B54536F2F3E64A8 0101010101010101 0000000000040000 EA51D3975595B86B 0101010101010101 0000000000020000 CAFFC6AC4542DE31 0101010101010101 0000000000010000 8DD45A2DDF90796C 0101010101010101 0000000000008000 1029D55E880EC2D0 0101010101010101 0000000000004000 5D86CB23639DBEA9 0101010101010101 0000000000002000 1D1CA853AE7C0C5F 0101010101010101 0000000000001000 CE332329248F3228 0101010101010101 0000000000000800 8405D1ABE24FB942 0101010101010101 0000000000000400 E643D78090CA4207 0101010101010101 0000000000000200 48221B9937748A23 0101010101010101 0000000000000100 DD7C0BBD61FAFD54 0101010101010101 0000000000000080 2FBC291A570DB5C4 0101010101010101 0000000000000040 E07C30D7E4E26E12 0101010101010101 0000000000000020 0953E2258E8E90A1 0101010101010101 0000000000000010 5B711BC4CEEBF2EE 0101010101010101 0000000000000008 CC083F1E6D9E85F6 0101010101010101 0000000000000004 D2FD8867D50D2DFE 0101010101010101 0000000000000002 06E7EA22CE92708F 0101010101010101 0000000000000001 166B40B44ABA4BD6 *** Key Permutation tests: *** continue 56 encode 8001010101010101 0000000000000000 95A8D72813DAA94D 4001010101010101 0000000000000000 0EEC1487DD8C26D5 2001010101010101 0000000000000000 7AD16FFB79C45926 1001010101010101 0000000000000000 D3746294CA6A6CF3 0801010101010101 0000000000000000 809F5F873C1FD761 0401010101010101 0000000000000000 C02FAFFEC989D1FC 0201010101010101 0000000000000000 4615AA1D33E72F10 0180010101010101 0000000000000000 2055123350C00858 0140010101010101 0000000000000000 DF3B99D6577397C8 0120010101010101 0000000000000000 31FE17369B5288C9 0110010101010101 0000000000000000 DFDD3CC64DAE1642 0108010101010101 0000000000000000 178C83CE2B399D94 0104010101010101 0000000000000000 50F636324A9B7F80 0102010101010101 0000000000000000 A8468EE3BC18F06D 0101800101010101 0000000000000000 A2DC9E92FD3CDE92 0101400101010101 0000000000000000 CAC09F797D031287 0101200101010101 0000000000000000 90BA680B22AEB525 0101100101010101 0000000000000000 CE7A24F350E280B6 0101080101010101 0000000000000000 882BFF0AA01A0B87 0101040101010101 0000000000000000 25610288924511C2 0101020101010101 0000000000000000 C71516C29C75D170 0101018001010101 0000000000000000 5199C29A52C9F059 0101014001010101 0000000000000000 C22F0A294A71F29F 0101012001010101 0000000000000000 EE371483714C02EA 0101011001010101 0000000000000000 A81FBD448F9E522F 0101010801010101 0000000000000000 4F644C92E192DFED 0101010401010101 0000000000000000 1AFA9A66A6DF92AE 0101010201010101 0000000000000000 B3C1CC715CB879D8 0101010180010101 0000000000000000 19D032E64AB0BD8B 0101010140010101 0000000000000000 3CFAA7A7DC8720DC 0101010120010101 0000000000000000 B7265F7F447AC6F3 0101010110010101 0000000000000000 9DB73B3C0D163F54 0101010108010101 0000000000000000 8181B65BABF4A975 0101010104010101 0000000000000000 93C9B64042EAA240 0101010102010101 0000000000000000 5570530829705592 0101010101800101 0000000000000000 8638809E878787A0 0101010101400101 0000000000000000 41B9A79AF79AC208 0101010101200101 0000000000000000 7A9BE42F2009A892 0101010101100101 0000000000000000 29038D56BA6D2745 0101010101080101 0000000000000000 5495C6ABF1E5DF51 0101010101040101 0000000000000000 AE13DBD561488933 0101010101020101 0000000000000000 024D1FFA8904E389 0101010101018001 0000000000000000 D1399712F99BF02E 0101010101014001 0000000000000000 14C1D7C1CFFEC79E 0101010101012001 0000000000000000 1DE5279DAE3BED6F 0101010101011001 0000000000000000 E941A33F85501303 0101010101010801 0000000000000000 DA99DBBC9A03F379 0101010101010401 0000000000000000 B7FC92F91D8E92E9 0101010101010201 0000000000000000 AE8E5CAA3CA04E85 0101010101010180 0000000000000000 9CC62DF43B6EED74 0101010101010140 0000000000000000 D863DBB5C59A91A0 0101010101010120 0000000000000000 A1AB2190545B91D7 0101010101010110 0000000000000000 0875041E64C570F7 0101010101010108 0000000000000000 5A594528BEBEF1CC 0101010101010104 0000000000000000 FCDB3291DE21F0C0 0101010101010102 0000000000000000 869EFD7F9F265A09 *** Test of right-shifts in Decryption *** continue 56 decode 8001010101010101 95A8D72813DAA94D 0000000000000000 4001010101010101 0EEC1487DD8C26D5 0000000000000000 2001010101010101 7AD16FFB79C45926 0000000000000000 1001010101010101 D3746294CA6A6CF3 0000000000000000 0801010101010101 809F5F873C1FD761 0000000000000000 0401010101010101 C02FAFFEC989D1FC 0000000000000000 0201010101010101 4615AA1D33E72F10 0000000000000000 0180010101010101 2055123350C00858 0000000000000000 0140010101010101 DF3B99D6577397C8 0000000000000000 0120010101010101 31FE17369B5288C9 0000000000000000 0110010101010101 DFDD3CC64DAE1642 0000000000000000 0108010101010101 178C83CE2B399D94 0000000000000000 0104010101010101 50F636324A9B7F80 0000000000000000 0102010101010101 A8468EE3BC18F06D 0000000000000000 0101800101010101 A2DC9E92FD3CDE92 0000000000000000 0101400101010101 CAC09F797D031287 0000000000000000 0101200101010101 90BA680B22AEB525 0000000000000000 0101100101010101 CE7A24F350E280B6 0000000000000000 0101080101010101 882BFF0AA01A0B87 0000000000000000 0101040101010101 25610288924511C2 0000000000000000 0101020101010101 C71516C29C75D170 0000000000000000 0101018001010101 5199C29A52C9F059 0000000000000000 0101014001010101 C22F0A294A71F29F 0000000000000000 0101012001010101 EE371483714C02EA 0000000000000000 0101011001010101 A81FBD448F9E522F 0000000000000000 0101010801010101 4F644C92E192DFED 0000000000000000 0101010401010101 1AFA9A66A6DF92AE 0000000000000000 0101010201010101 B3C1CC715CB879D8 0000000000000000 0101010180010101 19D032E64AB0BD8B 0000000000000000 0101010140010101 3CFAA7A7DC8720DC 0000000000000000 0101010120010101 B7265F7F447AC6F3 0000000000000000 0101010110010101 9DB73B3C0D163F54 0000000000000000 0101010108010101 8181B65BABF4A975 0000000000000000 0101010104010101 93C9B64042EAA240 0000000000000000 0101010102010101 5570530829705592 0000000000000000 0101010101800101 8638809E878787A0 0000000000000000 0101010101400101 41B9A79AF79AC208 0000000000000000 0101010101200101 7A9BE42F2009A892 0000000000000000 0101010101100101 29038D56BA6D2745 0000000000000000 0101010101080101 5495C6ABF1E5DF51 0000000000000000 0101010101040101 AE13DBD561488933 0000000000000000 0101010101020101 024D1FFA8904E389 0000000000000000 0101010101018001 D1399712F99BF02E 0000000000000000 0101010101014001 14C1D7C1CFFEC79E 0000000000000000 0101010101012001 1DE5279DAE3BED6F 0000000000000000 0101010101011001 E941A33F85501303 0000000000000000 0101010101010801 DA99DBBC9A03F379 0000000000000000 0101010101010401 B7FC92F91D8E92E9 0000000000000000 0101010101010201 AE8E5CAA3CA04E85 0000000000000000 0101010101010180 9CC62DF43B6EED74 0000000000000000 0101010101010140 D863DBB5C59A91A0 0000000000000000 0101010101010120 A1AB2190545B91D7 0000000000000000 0101010101010110 0875041E64C570F7 0000000000000000 0101010101010108 5A594528BEBEF1CC 0000000000000000 0101010101010104 FCDB3291DE21F0C0 0000000000000000 0101010101010102 869EFD7F9F265A09 0000000000000000 *** Data permutation test: *** continue 32 encode 1046913489980131 0000000000000000 88D55E54F54C97B4 1007103489988020 0000000000000000 0C0CC00C83EA48FD 10071034C8980120 0000000000000000 83BC8EF3A6570183 1046103489988020 0000000000000000 DF725DCAD94EA2E9 1086911519190101 0000000000000000 E652B53B550BE8B0 1086911519580101 0000000000000000 AF527120C485CBB0 5107B01519580101 0000000000000000 0F04CE393DB926D5 1007B01519190101 0000000000000000 C9F00FFC74079067 3107915498080101 0000000000000000 7CFD82A593252B4E 3107919498080101 0000000000000000 CB49A2F9E91363E3 10079115B9080140 0000000000000000 00B588BE70D23F56 3107911598080140 0000000000000000 406A9A6AB43399AE 1007D01589980101 0000000000000000 6CB773611DCA9ADA 9107911589980101 0000000000000000 67FD21C17DBB5D70 9107D01589190101 0000000000000000 9592CB4110430787 1007D01598980120 0000000000000000 A6B7FF68A318DDD3 1007940498190101 0000000000000000 4D102196C914CA16 0107910491190401 0000000000000000 2DFA9F4573594965 0107910491190101 0000000000000000 B46604816C0E0774 0107940491190401 0000000000000000 6E7E6221A4F34E87 19079210981A0101 0000000000000000 AA85E74643233199 1007911998190801 0000000000000000 2E5A19DB4D1962D6 10079119981A0801 0000000000000000 23A866A809D30894 1007921098190101 0000000000000000 D812D961F017D320 100791159819010B 0000000000000000 055605816E58608F 1004801598190101 0000000000000000 ABD88E8B1B7716F1 1004801598190102 0000000000000000 537AC95BE69DA1E1 1004801598190108 0000000000000000 AED0F6AE3C25CDD8 1002911498100104 0000000000000000 B3E35A5EE53E7B8D 1002911598190104 0000000000000000 61C79C71921A2EF8 1002911598100201 0000000000000000 E2F5728F0995013C 1002911698100101 0000000000000000 1AEAC39A61F0A464 *** S-Box test: *** continue 19 encode 7CA110454A1A6E57 01A1D6D039776742 690F5B0D9A26939B 0131D9619DC1376E 5CD54CA83DEF57DA 7A389D10354BD271 07A1133E4A0B2686 0248D43806F67172 868EBB51CAB4599A 3849674C2602319E 51454B582DDF440A 7178876E01F19B2A 04B915BA43FEB5B6 42FD443059577FA2 AF37FB421F8C4095 0113B970FD34F2CE 059B5E0851CF143A 86A560F10EC6D85B 0170F175468FB5E6 0756D8E0774761D2 0CD3DA020021DC09 43297FAD38E373FE 762514B829BF486A EA676B2CB7DB2B7A 07A7137045DA2A16 3BDD119049372802 DFD64A815CAF1A0F 04689104C2FD3B2F 26955F6835AF609A 5C513C9C4886C088 37D06BB516CB7546 164D5E404F275232 0A2AEEAE3FF4AB77 1F08260D1AC2465E 6B056E18759F5CCA EF1BF03E5DFA575A 584023641ABA6176 004BD6EF09176062 88BF0DB6D70DEE56 025816164629B007 480D39006EE762F2 A1F9915541020B56 49793EBC79B3258F 437540C8698F3CFA 6FBF1CAFCFFD0556 4FB05E1515AB73A7 072D43A077075292 2F22E49BAB7CA1AC 49E95D6D4CA229BF 02FE55778117F12A 5A6B612CC26CCE4A 018310DC409B26D6 1D9D5C5018F728C2 5F4C038ED12B2E41 1C587F1C13924FEF 305532286D6F295A 63FAC0D034D9F793 All done ****************************************** end b34sreturn; * Tests Character data options in B34S; call echooff; top continue; help=c1array(72:); call print(' ':); call read(help,4); call print(help:); code=' '; call read(code,4); if(code.eq.'end ')go to done; ncase=0; call read(ncase,4); code=' '; call read(code,4); decode=1; if(code.eq.'encode')decode=0; call print('Encode (=0) Decode (=1)',decode:); call print('# of cases processed ',ncase :); call char1(key, rtoch(array(2:))); call char1(in, rtoch(array(2:))); call char1(out, rtoch(array(2:))); call char1(string,rtoch(array(7:))); i1=integers(2,17); i2=i1+17; i3=i2+17; hold=c1array(ncase,75:); do i=1,ncase; call read(string,4); call character(key,string(i1)); call character(in, string(i2)); call character(out,string(i3)); call des(in,get,key,decode); isgood=' O. K.'; blank=c1array(1:); t1 =c8array(2:out); tt1=c8array(2:get); if(t1(1).ne.tt1(1).or.t1(2).ne.tt1(2))isgood=' Error'; isgood=c1array(8:isgood); hold(i,)=c1array(75:key,blank,in,blank,out,blank,get,isgood); enddo; /$ 12345678901234567890123456789012345678901234567890 /$ 16 32 48 call print(' key in Answer Get ':); call print(hold); go to top; done continue; b34srun; /; /;DET Calculates determinate /; b34sexec matrix; x=matrix(3,3:0.1 1. 2. 9. 8. 7. 5. 4. 0.2); call print(x,inv(x),det(x),det(r8tor16(x))); cx=complex(x,dsqrt(x)); call print(cx,inv(cx),det(cx),det(c16toc32(cx))); b34srun; /; /;DEXP Natural Log /; b34sexec matrix; x=grid(0.0001 100. .1); log10x=dlog10(x); lnx =dlog(x); testx1=10.**log10x; testx2=dexp(lnx); call tabulate(x,log10x,lnx,testx1,testx2); b34srun; /; /;DF Dickey Fuller Test /; b34sexec options ginclude('gas.b34'); b34srun; /$ Dickey Fuller tests are done from BJ and from Matrix /$ Note carefully that DF NE adf(0) b34sexec bjiden; var= gasout; rauto gasout; bispec df adf(1,2,3); b34srun; b34sexec matrix; call loaddata; call echooff; call print('Dickey Fuller Tests on Gasout'); call df(gasout,d :print); n=30; adf=array(n+1:); adft=array(n+1:); lag=array(n+1:); padf=array(n+1:); padft=array(n+1:); do i=0,n; j=i+1; call df(gasout,a1:adf i); adf(j)=a1; padf(j)=%dfprob; call df(gasout,a2:adft i); adft(j)=a2; padft(j)=%dfprob; lag(j)=dfloat(i); enddo; call print('Dickey-Fuller tests':); call tabulate(lag,adf,padf,adft,padft); b34srun; /; /;DF1 Tests DF Test Table /; /$ Can set ncase as 1000 or more if desired /$ try 10000 with n=250 /$ /$ /$ Job establishes critical values for DF test /$ /$ Unit root and noise generated /$ b34sexec matrix; call echooff; ncase=1000; n=250; unit=array(n:); test =array(ncase:); test1=array(ncase:); test2=array(ncase:); test3=array(ncase:); do i=1,ncase; call outstring(2,3,'Case'); call outinteger(20,3,i); noise=rn(unit); unit=cusum(noise); call df(unit, d); call df(unit, d1 :adf 4); call df(unit, d2 :adft 4); call df(noise,d3); test(i)=d; test1(i)=d1; test2(i)=d2; test3(i)=d3; enddo; q=array(8:.01 .025 .05 .10 .90,.95,.975,.99); call quantile(test, q,value); call quantile(test1,q,value1); call quantile(test2,q,value2); call quantile(test3,q,value3); call print('# cases ',ncase:); call print('# observations ',n:); Call Print('DF Test at .01 .025 .05 .10 .90 .95 .975 .99'); call tabulate(q,value,value1,value2,value3); call graph(test(ranker(test)) :heading 'Unit root Distribution - Case 1'); call graph(test1(ranker(test1)) :heading 'Unit root adf Distribution - Case 2'); call graph(test2(ranker(test2)) :heading 'Unit root adf Distribution - Case 4'); call graph(test3(ranker(test3)) :heading 'Random Variable Distribution'); /$ For a discussion of why we cannot use these methods /$ for Case # 4 in some cases see Hamilton page 497 ; b34srun; /; /;DF2 Negative unit root /; /$ /$ /$ Job establishes critical values for DF test /$ "unit root with negative" <= /$ /$ DF test does not detect ########### /$ /$ Unit root and noise generated /$ b34sexec matrix dseed=12332.; call echooff; ncase=1000; n=500; unit=array(n:); hold=array(n:); test =array(ncase:); test1=array(ncase:); test2=array(ncase:); test3=array(ncase:); jj=integers(1,n); hold(jj)=(-1.)**dfloat(jj); do i=1,ncase; call outstring(2,3,'Case'); call outinteger(20,3,i); noise=rn(unit); unit=cusum(noise); unit=afam(unit)*afam(hold); call df(unit, d); call df(unit, d1 :adf 4); call df(unit, d2 :adft 4); call df(noise,d3); test(i)=d; test1(i)=d1; test2(i)=d2; test3(i)=d3; enddo; q=array(8:.01 .025 .05 .10 .90,.95,.975,.99); call quantile(test, q,value); call quantile(test1,q,value1); call quantile(test2,q,value2); call quantile(test3,q,value3); call print('# cases ',ncase,' # observations ',n); Call Print('DF Test at .01 .025 .05 .10 .90 .95 .975 .99'); call tabulate(q,value,value1,value2,value3); call graph(test(ranker(test)) :heading 'Unit root Distribution - Case 1'); call graph(test1(ranker(test1)) :heading 'Unit root adf Distribution - Case 2'); call graph(test2(ranker(test2)) :heading 'Unit root adf Distribution - Case 4'); call graph(test3(ranker(test3)) :heading 'Random Variable Distribution'); * For a discussion of why we cannot use these methods for Case # 4 in some cases see Hamilton page 497 ; b34srun; /; /;DF3 Tests DF test performance /; /$ /$ Unit root and noise generated /$ b34sexec matrix dseed=12331.; call echooff; ncase=100; n=100000; unit=array(n:); call print('Sample Size = ',n); call print(' ':); call print('Data for Unit root Series':); do i=1,ncase; noise=rn(unit); unit=cusum(noise); call df(unit, d :print); call df(unit, d1 :adf 4 :print); call df(unit, d2 :adft 4 :print); enddo; call print('Data for Random Series':); do i=1,ncase; noise=rn(unit); call df(noise,d :print); call df(noise,d1 :adf 4 :print); call df(noise,d2 :adft 4 :print); enddo; b34srun; /; /;DF4 Investigates DF Test Tables /; b34sexec matrix; * Test DF table ; iprint=0; x=grid(-5.0,5.0,.01); call df(x,prob25 :table 25); call df(x,prob50 :table 50); call df(x,prob100 :table 100); call df(x,prob250 :table 250); call df(x,prob300 :table 300); call df(x,prob500 :table 500); call df(x,prob600 :table 600); call print('Regular DW':); if(iprint.eq.1) call tabulate(x,prob25,prob50,prob100,prob250,prob300,prob500,prob600); call names(all); call graph(x,prob25 prob50 prob100 prob250 prob300 prob500 prob600 :plottype xyplot :heading 'DF Test'); call df(x,prob25 :table2 25); call df(x,prob50 :table2 50); call df(x,prob100 :table2 100); call df(x,prob250 :table2 250); call df(x,prob300 :table2 300); call df(x,prob500 :table2 500); call df(x,prob600 :table2 600); call print('Augmented DF':); if(iprint.eq.1) call tabulate(x,prob25,prob50,prob100,prob250,prob300,prob500,prob600); call graph(x,prob25 prob50 prob100 prob250 prob300 prob500 prob600 :plottype xyplot :heading 'Augmented DF Test'); call df(x,prob25 :table4 25); call df(x,prob50 :table4 50); call df(x,prob100 :table4 100); call df(x,prob250 :table4 250); call df(x,prob300 :table4 300); call df(x,prob500 :table4 500); call df(x,prob600 :table4 600); call print('Augmented DW with Trend':); if(iprint.eq.1) call tabulate(x,prob25,prob50,prob100,prob250,prob300,prob500,prob600); call graph(x,prob25 prob50 prob100 prob250 prob300 prob500 prob600 :plottype xyplot :heading 'Augmented DF Test with Trend'); * Test DF table ; x=grid(-30.0,30.0,.1); call df(x,prob25 :table 25 :zform); call df(x,prob50 :table 50 :zform); call df(x,prob100 :table 100 :zform); call df(x,prob250 :table 250 :zform); call df(x,prob300 :table 300 :zform); call df(x,prob500 :table 500 :zform); call df(x,prob600 :table 600 :zform); call print('Regular DW':); if(iprint.eq.1) call tabulate(x,prob25,prob50,prob100,prob250,prob300,prob500,prob600); call graph(x,prob25 prob50 prob100 prob250 prob300 prob500 prob600 :plottype xyplot :heading 'DF Test zform'); call df(x,prob25 :table2 25 :zform); call df(x,prob50 :table2 50 :zform); call df(x,prob100 :table2 100 :zform); call df(x,prob250 :table2 250 :zform); call df(x,prob300 :table2 300 :zform); call df(x,prob500 :table2 500 :zform); call df(x,prob600 :table2 600 :zform); call print('Augmented DF':); if(iprint.eq.1) call tabulate(x,prob25,prob50,prob100,prob250,prob300,prob500,prob600); call graph(x,prob25 prob50 prob100 prob250 prob300 prob500 prob600 :plottype xyplot :heading 'Augmented DF Test Z form'); call df(x,prob25 :table4 25 :zform); call df(x,prob50 :table4 50 :zform); call df(x,prob100 :table4 100 :zform); call df(x,prob250 :table4 250 :zform); call df(x,prob300 :table4 300 :zform); call df(x,prob500 :table4 500 :zform); call df(x,prob600 :table4 600 :zform); call print('Augmented DW with Trend':); if(iprint.eq.1) call tabulate(x,prob25,prob50,prob100,prob250,prob300,prob500,prob600); call graph(x,prob25 prob50 prob100 prob250 prob300 prob500 prob600 :plottype xyplot :heading 'Augmented DF Test with Trend Z form'); b34srun; /; /;DF_GLS Elliott-Rothenberg-Stock DF_GLS Test /; b34sexec matrix; call load(df_gls); call print(df_gls); /$ /$ Subroutine DF_GLS(x,lag1,notrend,trend,notrendx,trendx,iprint); /$ /$ Implements Elliott-Rothenberg-Stock (1996) Unit root test /$ documented in "Efficient Tests for an Autoregressive Root' /$ Econometrica 64(4): 813-836. See also Introduction to /$ Econometrics," By James Stock and Mark Watson, Addison /$ Wesley New York 2003 page 549-550 /$ /$ ********************************************************** /$ /$ x = series to test /$ lag1 = Lag for DF part of test. Must be GE 1 /$ notrend = > no trend test statistic /$ trend = > trend test statistic /$ notrendx = x smoothed without a trend /$ trendx = x smoothed with a trend /$ iprint = 2 to print steps and test, = 1 print test only /$ iprint=1; n=1000; x=rn(array(n:)); root=cusum(x); call graph(x); call graph(root); call echooff; do i=1,4; call print(' ':); call print('For lag ',i:); call print('Non unit root case':); call DF_GLS(x,i,notrend,trend,notrendx,trendx,iprint); call print(' ':); call print('----------------':); call print(' ':); call print('Unit root case':); call DF_GLS(root,i,notrend,trend,notrendx,trendx,iprint); enddo; b34srun; /; /;DFLOAT Integer to real*8 /; b34sexec matrix; r8g=grid(.1,6.,.3) ; i=integers(norows(r8g)); r4i= float(i) ; r8i=dfloat(i) ; i4idint=idint(r8g) ; i4idnint=idnint(r8g) ; i4fromr4=int(r4i) ; r8dint=dint(r8g) ; call names(all) ; call tabulate(i,r4i,r8i,r8g,i4idint,i4idnint,i4fromr4 r8dint); b34srun; /; /;DGAMMA Gamma Function /; b34sexec matrix; * Note that we avoid integer values ; x=grid(1.01,170.01,.5); g =dgamma(x); x2=(-1.0)*x; g2=dgamma(x2); call tabulate(x,g,x2,g2); b34srun; /; /;DGDAGI_2 Studies with Normal Distribution /; b34sexec matrix; * Calculate cumulative Normal ; program test; f=(1./dsqrt(2.*pi()))*dexp((-.5)*x*x); return; end; call print(test); call echooff; a=-1.; b=1. ; do i=1,6; call dqdag(f x :name test :lower a :upper b :errabs 0.0 :errrel .001 :rule i :maxsub 500 :print); enddo; call dqdagi(f x :name test :upper 1. :errabs 0.0 :errrel .001 :maxsub 500 :print); b34srun; /; /;DIAG Obtain Diagonal Elements /; b34sexec matrix; n=5; x=rn(matrix(n,n:)); call print(X,'Diagonal ',diag(x)); cx=complex(x,x*2.); call print(cx,'Diagonal ',diag(cx)); b34srun; /; /;DIAGMAT Illustrates DIAGMAT Command /; b34sexec matrix$ x=vector(6:1 2 3 4 5 6); dm=diagmat(x); call print(x); cx=complex(vector(6:1 2 3 4 5 6),2.*vector(6:1 2 3 4 5 6)); dm=diagmat(cx); call print(cx); b34srun; /; /;DIF Tests Difference Command /; b34sexec matrix; n=8; c=array(n:integers(1,n)); dc=dif(c); cc=rn(array(n:)); dcc=dif(cc); d2d1cc=dif(cc,2,1); call tabulate(c,dc,cc,dcc,d2d1cc); n=2000; nn2=200000; xx=rn(array(n:)); xx2=rn(array(nn2:)); call print('Dif. of White Noise has acf(1)=-.5':); call tabulate(acf(xx,20),acf(dif(xx),20), acf(dif(xx2),20)); call print('Seasonal Differencing effects':); call tabulate(acf(xx,20),acf(dif(xx,1,12),20), acf(dif(xx2,1,12),20)); call print('Seasonal and First Difference Effects':); call tabulate(acf(dif(dif(xx ,1,12)),20) , acf(dif(dif(xx2,1,12)),20)); b34srun; /; /;DIF1 Advanced tests using difference /; b34sexec matrix; * Goal is to illustrate effect of differending on ACF and spectrum; n=4000; c=rn(array(n:)); c1=dif(c,1,1); c12=dif(c,1,12); acf1=acf(c, dmax1(1,n/50),se1,pacf1); acf2=acf(c1, dmax1(1,n/50),se2,pacf2); acf3=acf(c12,dmax1(1,n/50),se3,pacf3); call graph(acf1 :heading 'ACF of rn series'); call graph(acf1,pacf1 :heading 'ACF & PACF of rn series'); call graph(acf2 :heading 'ACF of rn(1-b) series'); call graph(acf2,pacf2 :heading 'ACF & PACF of rn(1-b) series'); call graph(acf3 :heading 'ACF of rn(1-b**12) series'); call graph(acf3,pacf3 :heading 'ACF & PACF of rn(1-b**12) series'); call spectral(c, sinx,cosx,px,sc, freq :1 2 3 2 1); call spectral(c1, sinx,cosx,px,sc1, freq1 :1 2 3 2 1); call spectral(c12,sinx,cosx,px,sc12,freq12:1 2 3 2 1); call graph(freq, sc :heading 'Spectrum of rn series' :plottype xyplot); call graph(freq1, sc1 :heading 'Spectrum of rn(1-b) series' :plottype xyplot); call graph(freq12,sc12 :heading 'Spectrum of rn(1-b**12) series' :plottype xyplot); b34srun; /; /;DIF2 Illustrates Differencing a col of an array /; b34sexec matrix; x=rn(array(10,4:)); call print(x); x1=dif(x(,1)); newx=x; newx(1,)=array(4:)+missing(); newx=goodrow(newx); newx(,1)=x1; call print(x,newx); b34srun; /; /;DINT Integer part pf real*8 in a real*8 /; b34sexec matrix; r8g=grid(.1,6.,.3) ; i=integers(norows(r8g)); r4i= float(i) ; r8i=dfloat(i) ; i4idint=idint(r8g) ; i4idnint=idnint(r8g) ; i4fromr4=int(r4i) ; r8dint=dint(r8g) ; call names(all) ; call tabulate(i,r4i,r8i,r8g,i4idint,i4idnint,i4fromr4 r8dint); b34srun; /; /;DNINT Integer part of real*8 in a real*8 /; b34sexec matrix; r8g=grid(.1,6.,.3) ; i4idint=idint(r8g) ; i4idnint=idnint(r8g) ; r8dint=dint(r8g) ; r8dnint=dnint(r8g) ; call names(all) ; call tabulate(r8g,i4idint,i4idnint,r8dint,r8dnint); b34srun; /; /;DISPLAYB Displays a buffer /; b34sexec matrix; call character(cc,'This is a test'); call displayb(cc); call character(cc2,'This is a test with numbers 1 2 3 # $ % 7 && 8 &'); call displayb(cc2); * Put in reals we know what they are; x(1)=0.0; x(2)=1.0; * Hide an integer in a real; i1=1; i2=2; call ilcopy(4,i1,1,1,x,1,1); call ilcopy(4,i2,1,1,x,1,3); call displayb(x); b34srun; /; /;DIST_TAB Distribution Table /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(dist_tab); call echooff; call describe(gasin :print); call dist_tab(gasin,20,q,qvalue,number,1); b34srun; b34sexec data; input x; datacards; 0.77, 1.74, 0.81, 1.20, 1.95, 1.20, 0.47, 1.43, 3.37, 2.20, 3.00, 3.09, 1.51, 2.10, 0.52, 1.62, 1.31, 0.32, 0.59, 0.81, 2.81, 1.87, 1.18, 1.35, 4.75, 2.48, 0.96, 1.89, 0.90, 2.05 b34sreturn; b34srun; b34sexec matrix; call loaddata; call load(dist_tab); * IMSL test data answers Smaller Empirical Larger Quantile Datum Quantile Datum 0.01 0.32 0.32 0.32 0.05 0.32 0.40 0.47 0.10 0.52 0.53 0.59 0.15 0.59 0.71 0.77 0.20 0.81 0.81 0.81 0.25 0.81 0.88 0.90 0.30 0.96 1.03 1.18 0.35 1.18 1.20 1.20 0.40 1.20 1.24 1.31 0.45 1.31 1.35 1.35 0.50 1.43 1.47 1.51 0.55 1.62 1.63 1.74 0.60 1.74 1.82 1.87 0.65 1.89 1.90 1.95 0.70 1.95 2.02 2.05 0.75 2.10 2.12 2.20 0.80 2.20 2.42 2.48 0.85 2.81 2.88 3.00 0.90 3.00 3.08 3.09 0.95 3.37 3.99 4.75 0.99 4.75 4.75 4.75 ; call echooff; call describe(x :print); call dist_tab(x,20,q,qvalue,number,1); b34srun; /; /;DIVIDE Divide with an error return /; b34sexec matrix; top=array(6:)+1.0; bot=array(6:1. 0. 2. 0. 3. 0.); call print('divide',divide(top,bot) ); call print('divide',divide(top,bot,0.0)); call print('divide',divide(10.,bot) ); call print('divide',divide(10.,bot,0.0)); call print('divide',divide(top,10.) ); call print('divide',divide(top,10.,0.0)); top=r8tor16(top); bot=r8tor16(bot); call print('divide',divide(top,bot) ); call print('divide',divide(top,bot,r8tor16(0.0) )); call print('divide',divide(r8tor16(10.),bot)); call print('divide',divide(r8tor16(10.),bot,r8tor16(0.0))); call print('divide',divide(top,r8tor16(10.) )); call print('divide',divide(top,r8tor16(10.),r8tor16(0.0))); b34srun; /; /;DLGAMMA Log Gamma Function /; b34sexec matrix; x=array(:1.,10.,100.,1000.,10000.,100000.,1000000.); g=dlgamma(x); call tabulate(x,g); b34srun; /; /;DLOG Natural Log /; b34sexec matrix; x=grid(0.0001 100. .1); log10x=dlog10(x); lnx =dlog(x); testx1=10.**log10x; testx2=dexp(lnx); call tabulate(x,log10x,lnx,testx1,testx2); * Complex case; cx=complex(x,dsqrt(x)); lncx =dlog(cx); testcx =exp(lncx); call tabulate(cx,lncx,testcx); b34srun; /; /;DLOG10 Log 10 /; b34sexec matrix; x=grid(0.0001 100. .1); log10x=dlog10(x); lnx =dlog(x); testx1=10.**log10x; testx2=dexp(lnx); call tabulate(x,log10x,lnx,testx1,testx2); b34srun; /; /;DMAX Illustrate DMAX Command /; b34sexec matrix; * Command finds max element ; n=20; reals=rec(array(n:))*100.; ints=idint(reals); maxint=dmax(ints); maxreal=dmax(reals); call print(ints,maxint,reals,maxreal); reals(2)=missing(); call print(dmax( reals), dmax( reals:)); call print('Real*16 case':); call print(dmax(r8tor16(reals)),dmax(r8tor16(reals):)); b34srun; /; /;DMAX1 Illustrate DMAX1 Command /; b34sexec matrix; * Command finds max of two vectors; n=20; reals1=rec(array(n:))*100.; ints1=idint(reals1); reals2=rec(array(n:))*100.; ints2=idint(reals2); maxint=dmax1(ints1,ints2) ; maxreal=dmax1(reals1,reals2); maxreal2=dmax1(r8tor16(reals1),r8tor16(reals2)); call tabulate(ints1,ints2,maxint,reals1,reals2,maxreal,maxreal2); b34srun; /; /;DMIN Illustrate DMIN Command /; b34sexec matrix; * Command finds min element ; n=20; reals=rec(array(n:))*100.; ints=idint(reals); minint=dmin(ints); minreal=dmin(reals); call print(ints,minint,reals,minreal); reals(2)=missing(); call print(dmin(reals),dmin(reals:)); call print('Real*16 Case'); call print(dmin(r8tor16(reals)),dmin(r8tor16(reals):)); b34srun; /; /;DMIN1 Illustrate DMIN1 Command /; b34sexec matrix; * Command finds min of two vectors; n=20; reals1=rec(array(n:))*100.; ints1=idint(reals1); reals2=rec(array(n:))*100.; ints2=idint(reals2); minint=dmin1(ints1,ints2) ; minreal=dmin1(reals1,reals2); minreal2=dmin1(r8tor16(reals1),r8tor16(reals2)); call tabulate(ints1,ints2,minint,reals1,reals2,minreal,minreal2); b34srun; /; /;DMOD Illustrate DMOD Command in simple cases /; b34sexec matrix; ints=integers(20); reals=dfloat(ints); imods=dmod(ints,3); rmod =dmod(reals,3.0); call tabulate(ints,imods,reals,rmod); call print('Real*16 cases':); rmod =dmod(r8tor16(reals),r8tor16(3.0)); call tabulate(ints,imods,reals,rmod); b34srun; /; /;DMOD_2 Remander of real*8, real*16 and integer*4 variables /; b34sexec matrix; call print('Tests with real data'); real=grid(1.0,30.,1.); remand2=dmod(real,2.0); remand3=dmod(real,3.); two=array(30:) + 2.0; three=array(30:)+3.0; remand22=dmod(real,two); remand33=dmod(real,three); tt=dmod(5.0,real); call tabulate(real,remand2,remand3,remand22,remand33,tt); call print('Tests with integer data'); int=integers(30); remand2=dmod(int,2); remand3=dmod(int,3); two=idint(array(30:))+2; three=idint(array(30:))+3; remand22=dmod(int,two); remand33=dmod(int,three); tt=dmod(5,int); call tabulate(int,remand2,remand3,remand22,remand33,tt); call print('Tests with real*16 data'); real=r8tor16(grid(1.0,30.,1.)); remand2=dmod(real,r8tor16(2.0)); remand3=dmod(real,r8tor16(3.)); two=array(30:) + 2.0; three=array(30:)+3.0; two=r8tor16(two); three=r8tor16(three); remand22=dmod(real,two); remand33=dmod(real,three); tt=dmod(r8tor16(5.0),real); call tabulate(real,remand2,remand3,remand22,remand33,tt); b34srun; /; /;DOWHILE Simple dowhile loop /; b34sexec matrix; sum=0.0; add=1.; count=1.; tol=.1e-6; call echooff; dowhile (add.gt.tol); oldsum=sum; sum=oldsum+((1./count)**3.); count=count+1.; add=sum-oldsum; enddowhile; call print('Sum was ',sum:); call print('Count was ',count); b34srun; /; /;DOWHILE_2 Multiple Dowhile loop /; b34sexec matrix; sum=0.0; add=1.; ccount=1.; count=1.; tol=.1e-8; /$ outer dowhile does things 2 times call outstring(2,2,'We sum until we can add nothing!!'); call outstring(2,4,'Tol set as '); call outdouble(20,4,tol); call echooff; dowhile(ccount.ge.1..and.ccount.le.3.); sum=0.0; add=1.; count=1.; dowhile(add.gt.tol); oldsum=sum; sum=oldsum+((1./count)**3.); count=count+1.; call outdouble(2,6,add); add=sum-oldsum; /$ This section cleans temps if(dmod(count,10.).eq.0.)call compress; enddowhile; ccount=ccount+1.; call print('Outer loop count was ',ccount:); call print('Sum was ',sum:); call print('Count was ',count:); enddowhile; b34srun; /; /;DOWHILE_3 Subroutine Implementation /; b34sexec matrix; call echooff; subroutine test(tol); sum=0.0; add=1.; count=1.; call outstring(2,2,'We sum until we can add nothing!!'); call outstring(2,4,'Tol set as '); call outdouble(20,4,tol); dowhile (add.gt.tol); oldsum=sum; sum=oldsum+((1./count)**3.); count=count+1.; add=sum-oldsum; call outdouble(20,6,add); call compress(300); enddowhile; call print('tol was ',tol:); call print('Sum was ',sum:); call print('Count was ',count:); return; end; call test(.1e-6); call test(.1e-8); b34srun; /; /;DO_TEST1 Tests DO loop in MATRIX Language /; b34sexec matrix; call print('Simple do loop'); call echooff; do i=1,10; call print('This is in the simple loop',i); enddo; subroutine testit(i); j=i*2; call print('In testit we run a loop',i,j); do kk=1,i; call print('This is in the simple loop in the subroutine. kk=',kk); enddo; return; end; do kk=1,5; call print('This is in the main program'); call testit(kk); enddo; call print('All Done'); b34srun; /; /;DO_TEST2 Further Do loop tests / illustrations /; b34sexec matrix; call echooff; call print('This is the usual do loop'); do i=1,10; call print('This is i ',i); enddo; call print('This jumps 2'); do i=1,10,2; call print('This is i ',i); enddo; call print('This illustrates computed Arguments'); jj=1; kk=10; do kk1=jj,kk; call print('This is kk1',kk1); enddo; call print('This illustrates arguments that are computed'); do kk2=jj*2,kk/2; call print('This is kk2',kk2); enddo; b34srun; /; /;DO_TEST3 Further DO Loop Tests /; b34sexec matrix; * This program illustrates various DO LOOP setups; * This is NOT the fastest way to program !! ; * Simple do loop; call echooff; do i=1,10; call print('This is line 1!!!!!!!!'); call print('This is in the simple loop',i); if(i.ge.2.and.i.lt.6)then; call print('I is ge 2 and lt 6',' i= ',i); endif; if(i.eq.9)call print('I was 9 in this pass'); enddo; call print('Two nested do loops in base program'); do i=1,10; do j=i,10; call print('i and j',i,j); enddo; enddo; subroutine test(i); call print('In subroutine test. I was ',i); do k=1,5; do j=1,5; call print('in test k, j',k,j); enddo; enddo; call print('leaving test'); return; end; call print('We call a subroutine in a do loop and do a loop'); do i=1,10; call print('Calling test. i was ',i); call test(i); enddo; call print('All Done'); b34srun; /; /;DO_TEST4 DO Loops and GO to Statements and IFs /; b34sexec matrix; call echooff; do i=1,300; if(i.ge.7)go to n; call print('I should be less than 7',i); n continue; if(i.gt.98.and.i.lt.101)call print('I gt 98 & lt 101',i); enddo; b34srun; /; /;DO_TEST5 Illustrates Minitoring a Do loop as it runs /; b34sexec matrix; * Simple do loop with full screen monitoring; * Program can be terminated with break key ; program junk; call echooff; call cls; do i=1,10; call outstring(1,4,'This is i'); call outinteger(40,4,i); do j=i,20; call outstring(1,5,'This is j'); call outinteger(40,5,j); call print('i and j',i,j); x=i*j; enddo; j=0; call break('End of loop # 1'); enddo; return; end; call junk; b34srun; /; /;DO_TEST6 Slows speed of DO SOLVE and Copy - Simple Case /; b34sexec matrix; /$ If N is too big this will blow up /$ Tests speed of calculations. Set n for tests n=2000; ar1=array(N:); test=array(10:); test(1)=.1; test(2)=.99; b=1.1; call timer(base1); /$ solve(ar1=2.*test(t) :range 1, norows(test)); /$ solve(ar1=2.*test(t) :range norows(test)-9, norows(test)); /$ solve(ar1=2.*test(t-1) :range 2, 10); solve(ar1=2.*b :range 2, n); call timer(base2); call echooff; do i=1,n; ar1(i)=2.*b; enddo; call timer(base3); call setcol(ar1,1,2.*b); call timer(base4); call print('Speed differences between SOLVE, Do Loop and Setcol', 'solve ',base2-base1,'do loop ',base3-base2,' Eq ', base4-base3); call names; b34srun; /; /;DO_TEST7 Speed Differences SOLVE DO GENARMA /; b34sexec matrix; /$ If b is too big this will blow up /$ Shows speed differences between DO and solve /$ genarma is the correct way to proceed with this problem /$ n=1000; ar1=array(N:); ar2=ar1; ar1(1)=1.1; ar2(1)=ar1(1); b=.8; call echooff; call timer(base1); /$ next Line tests array problems /$ solve(ar1=b*ar1(t-10)+ rn(b) :range 1, norows(ar1)); solve(ar1=b*ar1(t-1) + rn(b) :range 2, n); call timer(base2); do i=2,n; ar2(i)=b*ar2(i-1)+rn(b) ; enddo; call timer(base3); ar=array(:b); ma=array(:-.5,-.25); start=array(:1.1); ar3=genarma(ar,ma,1.0,start,1.,n); call timer(base4); call print(' For n =',n,'Solve time',base2-base1, 'Do time',base3-base2, 'Genarma time',base4-base3); call graph(ar1,ar2,ar3); /$ call print(ar1); b34srun; /; /;DQAND Multiple integration of a function /; b34sexec matrix; * This is a big problem. Note maxsub 100000 ; program test; f=dexp(-1.*(x(1)*x(1)+x(2)*x(2)+x(3)*x(3) )); return; end; /$ We solve 6 problems. As constant => inf and => pi()**1.5 lowerv=array(3:); upperv=array(3:); x =array(3:); call print(test); call echooff; j=integers(3); do i=1,6; cc=dfloat(i)/2.0; lowerv(j)=(-1.)*cc; upperv(j)= cc; call dqand(f x :name test :lower lowerv :upper upperv :errabs .0001 :errrel .001 :maxsub 100000 :print); enddo; call print('Limit answer ',pi()**1.5 :); b34srun; /; /;DQDAG Integrate a function using Gauss-Kronrod rules /; b34sexec matrix; program test; f=x*dexp(x); return; end; call print(test); call echooff; do i=1,6; call dqdag(f x :name test :lower 0.0 :upper 2.0 :errabs 0.0 :errrel .001 :rule i :maxsub 500 :print); enddo; b34srun; /; /;DQDAGI Integrate a function over infinite/semi-infinite interval. /; b34sexec matrix; program test; f=dlog(x)/(1.+(10.*x)**2.); return; end; call print(test); call echooff; call dqdagi(f x :name test :lower 0.0 :errabs 0.0 :errrel .001 :maxsub 500 :print); exact = -1.*pi()*dlog(10.)/20. ; error=%result-exact; call print('Exact ',exact:); call print('Error ',error:); call tabulate(%alist %blist %rlist %elist); b34srun; /; /;DQDAGP Integrete a function with singularity points given /; b34sexec matrix; program test; f=x**3.*dlog(dabs((x*x-1.0)*(x*x-2.0))); return; end; call print(test); call echooff; call dqdagp(f x :name test :breakp array(:1. dsqrt(2.)) :lower 0.0 :upper 3.0 :errabs 0.0 :errrel .001 :maxsub 500 :print); exact = 61.0*dlog(2.0)+77./4.*dlog(7.0) - 27.; error=dabs(%result-exact); call print('Exact ',exact:); call print('Error ',error:); call tabulate(%alist %blist %rlist %elist); b34srun; /; /;DQDAGS Integrate a function with end point singularities /; b34sexec matrix; program test; f=dlog(x)/dsqrt(x); return; end; call print(test); call echooff; call dqdags(f x :name test :lower 0.0 :upper 1.0 :errabs 0.0 :errrel .001 :maxsub 500 :print); exact = -4.0; error=dabs(%result-exact); call print('Exact ',exact:); call print('Error ',error:); call tabulate(%alist %blist %rlist %elist); b34srun; /; /;DQDNG Integrate a smooth function using a nonadaptive rule. /; b34sexec matrix; program test; f=x*dexp(x); return; end; call print(test); call echooff; call dqdng(f x :name test :lower 0.0 :upper 2.0 :errabs 0.0 :errrel .001 :print); exact=1.0+dexp(2.0); error=%result-exact; call print('Exact error ',error); b34srun; /; /;DROPFIRST Illustrates KEEPFIRST, KEEPLAST, DROPFIRST, DROPLAST /; b34sexec matrix; n=10; maxlag=2; x=array(n:integers(n)); lag1x=lag(x,1:nomiss); lag2x=lag(x,2:); last2=keeplast(x,2); first2=keepfirst(x,2); dropl2=droplast(x,2); dropf2=dropfirst(x,2); call tabulate(x,lag1x,lag2x,last2,first2,dropl2,dropf2); b34srun; /; /;DROPLAST Illustrates KEEPFIRST, KEEPLAST, DROPFIRST, DROPLAST /; b34sexec matrix; n=10; maxlag=2; x=array(n:integers(n)); lag1x=lag(x,1:nomiss); lag2x=lag(x,2:); last2=keeplast(x,2); first2=keepfirst(x,2); dropl2=droplast(x,2); dropf2=dropfirst(x,2); call tabulate(x,lag1x,lag2x,last2,first2,dropl2,dropf2); b34srun; /; /;DSIN Illustrates Cosine / sin functions /; b34sexec matrix; n=10.; test=grid(0.0,pi()*n,.1); cc=dcos(test); ss=dsin(test); call tabulate(test,cc,ss); call graph(test,cc,ss:heading 'Cosine & Sine' :plottype xyplot); b34srun; /; /;DSINH Hyperbolic sine of real*8 value /; b34sexec matrix; x=dfloat(integers(-10,10)); dcosh2=dcosh(x); dsinh2=dsinh(x); dtanh2=dtanh(x); call tabulate(x,dcosh2,dsinh2,dtanh2); b34srun; /; /;DSQRT dsqrt function => Square Root of real and Complex dat /; b34sexec matrix; call screenouton; a=array(4:1,-2,3,-6); ac=complex(a,a*2.); ar=grid(1.,10.,1.); sqrtar=dsqrt(ar); test1=sqrtar*sqrtar; call tabulate(ar,sqrtar,test1); sqrtac=dsqrt(ac); test2=sqrtac*sqrtac; call print(ac,sqrtac); call tabulate(ac,sqrtac,test2); b34srun; /; /;DTAN Illustrates tan function /; b34sexec matrix; n=10.; test=grid(0.0,pi()*n,.1); cc=dcos(test); ss=dsin(test); tt=dtan(test); call tabulate(test,cc,ss,tt); b34srun; /; /;DTANH Hyperbolic tangent of real*8 value /; b34sexec matrix; x=dfloat(integers(-10,10)); dcosh2=dcosh(x); dsinh2=dsinh(x); dtanh2=dtanh(x); call tabulate(x,dcosh2,dsinh2,dtanh2); b34srun; /; /;DTWODQ Two Dimensional Interated Integral /; /$ Fixed inner bounds test case first b34sexec matrix; program test1; f=y*dcos(x+y*y); return; end; program test2; g=1.0; * g=(-2.)*x; return; end; program test3; h=3.0; * h=5.*x; return; end; call print(test1,test2,test3); call echooff; call dtwodq(f x y g h :name test1 test2 test3 :lower 0.0 :upper 1.0 :errabs .000 :errrel .001 :rule 6 :print); call print(' ':); call print('***************************':); call print('IMSL thinks result is -.514':); call print('results ',%result:); call print('error ',%error:); call tabulate(%alist,%blist,%rlist,%elist); b34srun; b34sexec matrix; program test1; f=y*dcos(x+y*y); return; end; program test2; * g=1.0; g=(-2.)*x; return; end; program test3; * h=3.0; h=5.*x; return; end; call print(test1,test2,test3); call echooff; call dtwodq(f x y g h :name test1 test2 test3 :lower 0.0 :upper 1.0 :errabs .001 :errrel .00 :rule 6 :print); call print(' ':); call print('***************************':); call print('IMSL thinks result is -.083':); call print('results ',%result:); call print('error ',%error:); call tabulate(%alist,%blist,%rlist,%elist); b34srun; /; /;EIG Eig (eigenval) => Eigenvalue Analysis /; b34sexec matrix; * Test case for Real Matrix from IMSL Math (10) pp 295-297; * eig => matlab notation; * eigenval => speakeasy notation; a=matrix(3,3:8.,-1.,-5.,-4., 4.,-2.,18.,-5.,-7.); call print('A Matrix',a); call print('eig(a)',eig(a)); e=eig(a,evec); call print('Eigenvalues of a', e, 'Sum of the eigenvalues of General Martix A',sum(e), 'Trace of General Matrix A',trace(a), 'Product of the eigenvalues of Martix A',prod(e), 'Determinant of Matrix A',det(a) 'Test Factorization evec*diagmat(e)*inv(evec)' evec*diagmat(e)*inv(evec)); * real*16 case; r16a=r8tor16(a); call print('eig(r16a)',eig(r16a)); r16e=eig(r16a,r16evec); call print(r16e,r16a,r16evec); call print('Eigenvalues of r16a', r16e, 'Sum of the eigenvalues of General Martix A',sum(r16e), 'Trace of General Matrix A',trace(r16a), 'Product of the eigenvalues of Martix A',prod(r16e), 'Determinant of Matrix A',det(r16a) 'Test Factorization evec*diagmat(e)*inv(evec)' r16evec*diagmat(r16e)*inv(r16evec)); * Complex Case See IMSL Math (10) pp 302-304 ; r=matrix(4,4:5., 5.,-6.,-7., 3., 6.,-5.,-6., 2., 3.,-1.,-5., 1., 2.,-3.,0.0); i=matrix(4,4:9., 5.,-6.,-7., 3.,10.,-5.,-6., 2., 3., 3.,-5., 1., 2.,-3., 4.); ca=complex(r,i); call print('CA Complex Matrix',ca); call print('eig(ca)',eig(ca)); ce=eig(ca,cevec); call print('Eigenvectors of CA',cevec); call print('Eigenvalues of ca', ce, 'Sum of the eigenvalues of General Martix CA',sum(ce), 'Trace of General Matrix CA',trace(ca), 'Product of the eigenvalues of Martix CA',prod(ce), 'Determinant of Matrix CA',det(ca) 'Test Factorization evec*diagmat(ee)*inv(evec)' cevec*diagmat(ce)*inv(cevec) ); * Complex*32 case; c32ca=c16toc32(ca); call print('CA Complex Matrix',c32ca); call print('eig(c32ca)',eig(c32ca)); c32ce=eig(c32ca,c32cevec); call print('Eigenvectors of c32CA',c32cevec); call print('Eigenvalues of c32ca', c32ce, 'Sum of the eigenvalues of General Martix CA',sum(c32ce), 'Trace of General Matrix CA',trace(c32ca), 'Product of the eigenvalues of Martix CA',prod(c32ce), 'Determinant of Matrix CA',det(c32ca) 'Test Factorization evec*diagmat(ee)*inv(evec)' c32cevec*diagmat(c32ce)*inv(c32cevec) ); * Example from Limdep 7.0 Manual page 376 ; * Eigenalysis of Klein Model 1 ; r=matrix(3,3:.172,-.051,-.008,1.511,.848,.743,-.287,-.161,.818); call print(r,eigenval(r)); * Matlab Page 11-35 ; * V = Lamda*inv(v); a=matrix(3,3:0.0, -6., -1., 6., 2., -16., -5., 20., -10.); lamda=eigenval(a,v); dd=diagmat(lamda); call print('A',a, 'Lamda',lamda, 'V', v, 'V*lamda*inv(v)',v*diagmat(lamda)*inv(v)); call print('Now Get MATLAB result'); lamda2=eig(a,v2:lapack); call print(lamda2,v2); b34srun; /; /;EIG_10 Tests of Accuracy /; b34sexec matrix; * Eigen value tests; * Note Eigen values of; * ( 1 1 1 1 e 0 0 0 0 e 0 0 0 0 e 0 0 0 0 e); * are 4+ e**2, and e^2, e^2, e^2 ; * Matrix is rank 0ne, not invertable; * See Handbook of Econometrics Volume 1 Chapter 12; * Paper by Quandt ; subroutine getx(x,order,e); /$ /$ Tests eigenvalue code on a known problem /$ /$ Eigen value tests; /$ Note Eigen values of; /$ ( 1 1 1 1 /$ e 0 0 0 /$ 0 e 0 0 /$ 0 0 e 0 /$ 0 0 0 e); /$ are 4+ e**2, and e^2, e^2, e^2 ; /$ Matrix is rank 0ne, not invertable; /$ See Handbook of Econometrics Volume 1 Chapter 12; /$ Paper by Quandt ; /$ x=matrix(order+1,order:); x(1,)=1.0; call print(pointer(x)); call pcopy(order,pointer(e),0,pointer(x,2),order+2,8); a=transpose(x)*x; call print(x,a); call print('e**2',e**2.); call print('Eigenvalues',eig(a)); call print('Eigenvalues',eig(a:lapack)); call print('Eigenvalues',seig(a)); return; end; e=.1e-3; do j=1,6; e=e/10.; do i=2,6; call getx(x,i,e); enddo; enddo; b34srun; /; /;EIG_2 EISPACK vs LAPACK vs LAPACK /; b34sexec matrix; * Test case for Real Matrix from IMSL Math (10) pp 295-297; * eig => matlab notation; * eigenval => speakeasy notation; a=matrix(3,3:8.,-1.,-5.,-4., 4.,-2.,18.,-5.,-7.); call print('A Matrix real case',a); call print('eigen from Eispack ',eig(a) ); call print('eigen from Lapack ',eig(a:) ); e=eig(a,evec); call print('Test of eispack',a,e, 'Eispack eigenvectors ' evec 'Test of Factorization' evec*diagmat(e)*inv(evec)); e2=eig(a,evec2,evec22 :lapack); call print('Test of lapack ',a,e2, 'Lapack eigenvectors' 'Normalized to have euclian norm = 1. Largest real',evec2 'test factorization for right hand side' evec2*diagmat(e2)*inv(evec2) 'Using right eigenvectors we test if a*evec2 = evec * lamda' complex(a,0.0)*evec2,evec2*diagmat(e2) 'Using the left eigenvectors. We test if' 'evec22**h * a = lamda * evec22**h' transpose(dconj(evec22))*complex(a,0.0), diagmat(e2)*transpose(dconj(evec22)) 'test factorization for left hand side' inv(transpose(dconj(evec22)))*diagmat(e2)*transpose(dconj(evec22))); e3=eig(a,evec3,evec33 :lapack2); call print('Test of lapack2 ',a,e3, 'Lapack eigenvectors' 'Normalized to have euclian norm = 1. Largest real',evec3 'test factorization for right hand side' evec3*diagmat(e3)*inv(evec3) 'Using right eigenvectors we test if a*evec2 = evec * lamda' complex(a,0.0)*evec3,evec3*diagmat(e3) 'Using the left eigenvectors. We test if' 'evec33**h * a = lamda * evec33**h' 'Using the left eigenvectors. We test if' 'evec33**h * a = lamda * evec33**h' transpose(dconj(evec33))*complex(a,0.0), diagmat(e3)*transpose(dconj(evec33)) 'test factorization for left hand side' inv(transpose(dconj(evec33)))*diagmat(e3)*transpose(dconj(evec33))); * Complex Case See IMSL Math (10) pp 302-304 ; r=matrix(4,4:5., 5.,-6.,-7., 3., 6.,-5.,-6., 2., 3.,-1.,-5., 1., 2.,-3.,0.0); i=matrix(4,4:9., 5.,-6.,-7., 3.,10.,-5.,-6., 2., 3., 3.,-5., 1., 2.,-3., 4.); ca=complex(r,i); call print('CA Complex Matrix',ca); ce =eig(ca,cevec ); ce2=eig(ca,cevec2:lapack ); ce3=eig(ca,cevec3:lapack2); call print('ce => EISPACK' 'ce2 => zgeev / zgeev' 'ce3 => zgeevx/ zgeevx' 'Eigenvalues of ca', ca,ce2,ce3 'Sum of the eigenvalues of ce General Martix A',sum(ce), 'Sum of the eigenvalues of ce2 General Martix A',sum(ce2), 'Sum of the eigenvalues of ce3 General Martix A',sum(ce3), 'Trace of General Matrix A',trace(ca), 'Product of the eigenvalues ce of Martix A',prod(ce), 'Product of the eigenvalues ce2 of Martix A',prod(ce2), 'Product of the eigenvalues ce3 of Martix A',prod(ce3), 'Determinant of Matrix A',det(ca) 'Test Factorization evec*diagmat(e)*inv(evec)' 'LAPACK vs EISPACK' cevec *diagmat(ce) *inv(cevec) cevec2*diagmat(ce2)*inv(cevec2) cevec3*diagmat(ce3)*inv(cevec3)); call print('We print the three right hand eigenvalues of ca' cevec,cevec2,cevec3); ce2=eig(ca,cevec2,left2 :lapack); ce3=eig(ca,cevec3,left3 :lapack2); call print('Look at right and left eigenvectors' cevec2,left2 cevec3,left3); b34srun; /; /;EIG_3 Symmetric Eigenvalue Analysis /; b34sexec matrix; * Test case for Real symmetric Matrix from IMSL Math (10) pp 309-311; a=matrix(3,3:7.,-8.,-8.,-8.,-16.,-18.,-8.,-18.,13.); call print('A Matrix',a); e=seig(a); call print('Eigenvalues of a', e, 'Sum of the eigenvalues of Symmetric Martix A',sum(e), 'Trace of Symmetric Matrix A',trace(a), 'Product of the eigenvalues of Symmetric Martix A',prod(e), 'Determinant of Symmetrix Matrix A',det(a)); ee=seig(a,evec); call print(ee,evec); call print('Test transpose(evec)*evec ', transpose(evec)*evec , ' ' 'Note: a*evec = evec*diagmat(ee)' a*evec,evec*diagmat(ee), 'Test evec*transpose(evec) ', evec*transpose(evec)) ; call print('Using EISPACK and LAPACK Test results':); e =eig(a,evec); e2=eig(a,evec2:lapack); call print('Eispack',evec, 'Test of eigenvalues note that diagonal matrix but not 1 on diag' transpose(evec)*evec 'Do we get a' evec*diagmat(e)*inv(evec) ' ' 'Test of LAPACK',evec2 'Do we get a' evec2*diagmat(e)*inv(evec2) evec2*transpose(evec2) transpose(evec2)*evec2); b34srun; /; /;EIG_4 Shows Speed tests /; /$ As setup will solve 75 by 75 system /$ Illustrates speed gains ffrom seigenval /$ Also illustrates how costly Eigenvectors are /$ To calculate. All General matrix eigenvectors /$ use complex matrix path!!!! If only /$ Eigenvalues are needed, EISPACK RG is used /$ /$ All eigenvalues are tested against trace() and det() /$ b34sexec matrix; n=75; nn=namelist(sym,gen,gena,gen2,complex1,complex2); s=rn(matrix(n,n:)); s=transpose(s)*s; call timer(base1); e=seigenval(s); call timer(base2); call print('Eigenvalues of Symmetric Matrix using SEIGENVAL took', (base2-base1)); time(1)=base2-base1; call print('Eigenvalues of s using SEIGENVAL', e, 'Sum of the eigenvalues of Symetric Martix S',sum(e), 'Trace of General Matrix S',trace(s), 'Product of the eigenvalues of Martix S',prod(e), 'Determinant of Matrix S',det(s)); call timer(base1); e=eigenval(s); call timer(base2); call print('Eigenvalues of Symmetric using EIGENVAL took', (base2-base1)); time(2)=base2-base1; call print('Eigenvalues of s using EIGENVAL', e, 'Sum of the eigenvalues of Symetric Martix S',sum(e), 'Trace of General Matrix S',trace(s), 'Product of the eigenvalues of Martix S',prod(e), 'Determinant of Matrix S',det(s)); a=rn(matrix(n,n:)); call timer(base1); e=eigenval(a); call timer(base2); call print('Eigenvalues of Real*8 Gen Matrix using EIGENVAL took', (base2-base1)); time(3)=base2-base1; call timer(base1); e=eigenval(a,vec); call timer(base2); time(4)=base2-base1; call print('Eigenvalues and Vectors of Real*8 Gen Matrix using EIGENVAL took',(base2-base1)); call print('Eigenvalues of a', e, 'Sum of the eigenvalues of General Martix A',sum(e), 'Trace of General Matrix A',trace(a), 'Product of the eigenvalues of Martix A',prod(e), 'Determinant of Matrix A',det(a)); ca=complex(a,2.0*a); call timer(base1); ce=eigenval(ca); call timer(base2); time(5)=base2-base1; call timer(base1); ce=eigenval(ca,cevec); call timer(base2); time(6)=base2-base1; call print('Eigenvalues of Real*8 Gen Matrix using EIGENVAL took', (base2-base1)); call print('Eigenvalues of ca', ce, 'Sum of the eigenvalues of General Martix CA',sum(ce), 'Trace of General Matrix CA',trace(ca), 'Product of the eigenvalues of Martix CA',prod(ce), 'Determinant of Matrix CA',det(ca),' '); call print('Sym => Symmetrix Matrix using SEIGENVAL', 'Gen => Symmetric Matrix using EIGENVAL', 'Gena => Real*8 General Matrix ', 'Gen2 => Real*8 General Matrix Eigenvalues and Vectors', 'Complex1 => Complex*16 Matrix Eigenvalues only', 'Complex2 => Complex*16 Matrix both Eigenvalues & Vectors' ' '); call tabulate(nn,time); b34srun; /; /;EIG_5 Rosser Test Case /; b34sexec matrix; * Rosser test matrix from matlab ; test1=matrix(8,8: 611., 196.,-192., 407., -8., -52.,-49., 29., 196., 899., 113.,-192., -71., -43., -8., -44., -192., 113., 899., 196., 61., 49., 8., 52., 407.,-192., 196., 611., 8., 44., 59., -23., -8., -71., 61., 8., 411.,-599., 208.,208., -52., -43., 49., 44.,-599., 411., 208.,208., -49., -8., 8., 59., 208., 208., 99.,-911., 29., -44., 52., -23., 208., 208.,-911., 99.); call print(test1,eig(test1), eig(test1:lapack) eig(test1:lapack2) seigenval(test1)); b34srun; /; /;EIG_6 Bad Eigenvalue Problem /; b34sexec matrix; * Example from Matlab 4-36 - General Matrix; * Matrix is Defective => Cannot diagonalize ; * Schur decomposition works ; a=matrix(3,3: 6., 12., 19., -9., -20., -33., 4., 9., 15.); e =eigenval(a,vec1); call print(a,e,vec1); e2=eig(a,vec2:lapack); call print(a,e2,vec2); call schur(a,s,u); call print(a,s,u); is_ident=u*transpose(u); is_a =u*s*transpose(u); call print(is_ident,is_a); b34srun; /; /;EIG_7 Speed Tests /; b34sexec matrix; * ispeed1 on pd matrix ; * ispeed2 on general matrix; * ispeed3 on complex general matrix; * up 400 has been run ; igraph=0; ispeed1=1; ispeed2=1; ispeed3=1; upper=250; mesh=25; /$ PD Results if(ispeed1.ne.0)then; call echooff; icount=0; n=0; top continue; icount=icount+1; n=n+mesh; if(n .eq. upper)go to done; x=rec(matrix(n,n:)); x=transpose(x)*x; * x=complex(x,dsqrt(dabs(x))); call compress; call timer(base10); e=seig(x); call timer(base20); call compress; call timer(base110); e=seig(x,evec); call timer(base220); call compress; call timer(base11); e=eig(x); call timer(base22); call compress; call timer(base111); e=eig(x:lapack2); call timer(base222); call compress; call timer(base1); e=eig(x,evec); call timer(base2); call compress; call timer(base3); e=eig(x,evec,evec2 :lapack2); call timer(base4); call compress; call timer(base5); e=eig(x,evec:lapack2); call timer(base6); size(icount) = dfloat(n); sm1(icount) =base20-base10; sm2(icount) =base220-base110; eispack1(icount) =(base22-base11); lapack1(icount) =(base222-base111); eispack2(icount) =(base2-base1); lapack2a(icount) =(base4-base3); lapack2b(icount) =(base6-base5); call free(x,xinv1,ii); go to top; done continue; call print('EISPACK vs LAPACK on PD Matrix ':); call print('lapack2a gets both right and left eigenvectors':); call tabulate(size,sm1 sm2,eispack1,lapack1,eispack2,lapack2a,lapack2b); if(igraph.eq.1) call graph(size sm1,sm2,eispack1,lapack1,eispack2,lapack2a,lapack2b :plottype xyplot :nokey :heading 'Real*8 PD Matrix Results'); endif; if(ispeed2.ne.0)then; call echooff; icount=0; n=0; top2 continue; icount=icount+1; n=n+mesh; if(n .eq. upper)go to done2; x=rec(matrix(n,n:)); * x=transpose(x)*x; * x=complex(x,dsqrt(dabs(x))); call compress; call timer(base11); e=eig(x); call timer(base22); call compress; call timer(base111); e=eig(x:lapack2); call timer(base222); call compress; call timer(base1); e=eig(x,evec); call timer(base2); call compress; call timer(base3); e=eig(x,evec,evec2 :lapack2); call timer(base4); call compress; call timer(base5); e=eig(x,evec:lapack2); call timer(base6); size(icount) = dfloat(n); eispack1(icount) =(base22-base11); lapack1(icount) =(base222-base111); eispack2(icount) =(base2-base1); lapack2a(icount) =(base4-base3); lapack2b(icount) =(base6-base5); call free(x,xinv1,ii); go to top2; done2 continue; call print('EISPACK vs LAPACK on General Matrix ':); call print('lapack2a gets both right and left eigenvectors':); call tabulate(size,eispack1,lapack1,eispack2,lapack2a,lapack2b); if(igraph.eq.1) call graph(size ,eispack1,lapack1,eispack2,lapack2a,lapack2b :plottype xyplot :nokey :heading 'Real*8 General Matrix Results'); endif; if(ispeed3.ne.0)then; call echooff; icount=0; n=0; top3 continue; icount=icount+1; n=n+mesh; if(n .eq. upper)go to done3; x=rec(matrix(n,n:)); x=complex(x,dsqrt(dabs(x))); call compress; call timer(base11); e=eig(x); call timer(base22); call compress; call timer(base111); e=eig(x:lapack2); call timer(base222); call compress; call timer(base1); e=eig(x,evec); call timer(base2); call compress; call timer(base3); e=eig(x,evec,evec2 :lapack2); call timer(base4); call compress; call timer(base5); e=eig(x,evec:lapack2); call timer(base6); size(icount) = dfloat(n); eispack1(icount) =(base22-base11); lapack1(icount) =(base222-base111); eispack2(icount) =(base2-base1); lapack2a(icount) =(base4-base3); lapack2b(icount) =(base6-base5); call free(x,xinv1,ii); go to top3; done3 continue; call print('EISPACK vs LAPACK on a Complex General Matrix ':); call print('lapack2a gets both right and left eigenvectors':); call tabulate(size,eispack1,lapack1,eispack2,lapack2a,lapack2b); if(igraph.eq.1) call graph(size ,eispack1,lapack1,eispack2,lapack2a,lapack2b :plottype xyplot :nokey :heading 'Complex*16 Results'); endif; b34srun; /; /;EIG_8 Simple Tests Eispack vs LAPACK /; b34sexec matrix; * Exercises Eigenvalue calculations ; * IMSL test case ; A = matrix(3,3: 8.0, -1.0,-5.0, -4.0, 4.0,-2.0, 18.0, -5.0,-7.0); e =eig(a,evec); call print('Test Eispack',a,evec*diagmat(e)*inv(evec)); e2 =eig(a,evecr,evecl :lapack); call print('test eispack vs lapack':); call print(a,e,evec,e2,evecr,evecl); call print('test right' evecr*diagmat(e2)*inv(evecr) 'test left' inv(transpose(dconj(evecl)))*diagmat(e2)*transpose(dconj(evecl))); ca=complex(a,a*a); e =eig(ca,evec); call print('Test Eispack',ca,evec*diagmat(e)*inv(evec)); e2 =eig(ca,evecr,evecl :lapack); call print('test eispack vs lapack':); call print(ca,e,evec,e2,evecr,evecl); call print('test right' evecr*diagmat(e2)*inv(evecr) 'test left' inv(transpose(dconj(evecl)))*diagmat(e2)*transpose(dconj(evecl))); b34srun; /; /;EIG_9 Eigen Analysis with links to Matlab /; b34sexec matrix; * IMSL test case ; A = matrix(3,3: 8.0, -1.0,-5.0, -4.0, 4.0,-2.0, 18.0, -5.0,-7.0); e =eig(a,evec); e2 =eig(a,evec2 :lapack); call print('test eispack vs lapack':); call print(a,e,evec,e2,evec2); b34srun; /; /;ENDDO Ending a do or for loop /; b34sexec matrix; sum=0.0; call echooff; do i=1,10; sum=sum+dfloat(i); enddo; call print('Sum was ',sum); b34srun; /; /;ENDDOWHILE End of a dowhile statement /; b34sexec matrix; sum=0.0; add=1.; count=1.; tol=.1e-6; call echooff; dowhile (add.gt.tol); oldsum=sum; sum=oldsum+((1./count)**3.); count=count+1.; add=sum-oldsum; enddowhile; call print('Sum was ',sum:); call print('Count was ',count); b34srun; /; /;EPPRINT Print to Error and Output File /; b34sexec matrix; call epprint('Note: This message will be in the log and output file'); b34srun; /; /;EPRINT Print to error file /; b34sexec matrix; call eprint('Note: This message will be in the log'); b34srun; /; /;EPSILON Positive value such that 1.+x NE 1. /; b34sexec matrix; i=1; x=1.; y=sngl(x); call print('Largest integer ',huge(i):); call print('Largest real*4 ',huge(y):); call print('Largest real*8 ',huge(x):); call print('Smallest real*4 ',tiny(y):); call print('Smallest real*8 ',tiny(x):); call print('Epsilon real*4 ',epsilon(y):); call print('Epsilon real*8 ',epsilon(x):); x=.1d+00; y=sngl(x); j=1; call echooff; do i=1,1000,100; x=x*dfloat(i); y=float(i)*y ; spx(j)=spacing(x); spy(j)=spacing(y); nearpr8(j)=nearest(x, 1.); nearmr8(j)=nearest(x,-1.); nearpr4(j)=nearest(y, 1.); nearmr4(j)=nearest(y,-1.); testnum(j)=x; j=j+1; enddo; call print('Spacing for Real*8 and Real*4'); call tabulate(testnum,spx,spy,nearpr8,nearmr8,nearpr4,nearmr4); call names(all); call graph(testnum,spx :plottype xyplot :heading 'Spacing'); b34srun; /; /;EVAL Evaluate a variable pointer /; b34sexec matrix; test1=10.; pp='TEST1'; call print(eval(pp)); b34srun; /; /;EXP Natural Log /; b34sexec matrix; x=grid(0.0001 100. .1); log10x=dlog10(x); lnx =dlog(x); testx1=10.**log10x; testx2=exp(lnx); call tabulate(x,log10x,lnx,testx1,testx2); * Complex case; cx=complex(x,dsqrt(x)); lncx =dlog(cx); testcx =exp(lncx); call tabulate(cx,lncx,testcx); b34srun; /; /;EXPAND Expand a character Array /; b34sexec matrix; call character(cc,'This is a test'); call print(cc); call ilocatestr(cc,istart,iend); i=integers(istart,iend); subs=cc(i); call print(subs); call contract(cc,istart,iend); oldnewcc=cc; call print(cc); call character(new,'aaaissaa'); call expand(cc,new,1,8); call print(oldnewcc,cc); * we want aabb at 5-8 in cc; * We do not want to expand; call character(cc,'This is a test'); call character(new,'aabb'); call contract(cc,5,8); call expand(cc,new,5,8); call print(cc); b34srun; /; /;EXTRACT Tests Extract /; b34sexec matrix; call character(cc2,'abcdefghijklmnop'); do i=1,10; j=10; newc=extract(cc2,i,j); call print(cc2,i,j,newc); enddo; cc8=namelist(mary sue judy Diana); cc82=extract(cc8,2,3); call print('col 2-3'); call tabulate(cc8,cc82); do i=1,8; newc=place(cc2,1,i); call print(cc2,newc,i); enddo; b34srun; /; /;FACT Factorial /; b34sexec matrix; x=integers(20); call tabulate(x,fact(x)); b34srun; /; /;FDAYHMS Illustrates Date processing /; b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; /; /;FFT fft function = FFT of Real / Complex data /; b34sexec matrix; call screenouton; * Example from IMSL (10) Math Page 707-709; n=7.; ifft=grid(1.,n,1.); xfft=dcos((ifft-1.)*2.*pi()/n); rfft=fft(xfft); bfft=fft(rfft:back); call tabulate(xfft,rfft,bfft); * Complex Case See IMSL(10) Math Page 715-717; cfft=complex(0.0,1.); hfft=(complex(2.*pi())*cfft/complex(n))*complex(3.0); xfft=dexp(complex(ifft-1.)*hfft); cfft=fft(xfft); bfft=fft(cfft:back); call tabulate(xfft,cfft,bfft); * Simple Real Problem IMSL (10) Math 710-12; ffxin=array(7:); ffxin=ffxin+1.0; ffxout=fft(ffxin); bffxout=fft(ffxout:back); bffxout2=bffxout/dfloat(norows(bffxout)); call tabulate(ffxin,ffxout,bffxout,bffxout2); * Simple Problem IMSL (10) Math 718-720 ; fft2=fft(ifft); bfft2=fft(fft2:back); bfft2_2=bfft2/dfloat(norows(fft2)); call tabulate(ifft,fft2,bfft2,bfft2_2); fft2=fft(complex(ifft)); bfft2=fft(fft2:back); bfft2_2=bfft2/complex(dfloat(norows(fft2))); call tabulate(ifft,fft2,bfft2,bfft2_2); b34srun; /; /;FFT_1 Example from Matlab Page 6-32 6-33 /; b34sexec matrix; /$ Test Problem of FFT from MATLAB page 6-32 x=array(8:4., 3., 7., -9., 1., 0., 0., 0.); call print(x,fft(x)); b34srun; /; /;FFT_2 High and Low Pass /; b34sexec matrix; * Uses FFT to High and Low Pass Random Series; /$ /$ Illustrate with random numbers /$ n=296; test=rn(array(n:)); spec=spectrum(test,freq); call graph(freq,spec :plottype xyplot :heading 'Spectrum of Random series'); cfft=fft(complex(test,0.0)); * low pass ; nlow1 =1; nlow2 =64; nhigh1=51; nhigh2=150; fftlow =cfft*complex(0.0,0.0); ffthigh =cfft*complex(0.0,0.0); i=integers(nlow1,nhigh1); fftlow(i) = cfft(i); i=integers(nlow2,nhigh2); ffthigh(i) = cfft(i); call tabulate(cfft,fftlow,ffthigh); low =afam(real(fft(fftlow :back)))*(1./dfloat(norows(test))); high=afam(real(fft(ffthigh :back)))*(1./dfloat(norows(test))); call tabulate(low,high,fft(ffthigh:back)); spec=spectrum(low,freq); call graph(freq,spec :plottype xyplot :heading 'Spectrum of Random after Low Pass'); spec=spectrum(high,freq); call graph(freq,spec :plottype xyplot :heading 'Spectrum of Random after High Pass'); b34srun; /; /;FFT_3 Simple Band Pass Filter /; b34sexec matrix; * Uses FFT to Band Pass Random Series; /$ /$ Illustrate with random numbers /$ /$ Middle Frequencies are passed. Spectrum is inspected /$ before and after filter is applied. /$ n=400; nlow=64; nupper=192; x=rn(array(n:)); spec=spectrum(x,freq); call graph(freq,spec :plottype xyplot :heading 'Spectrum of Random series'); cfft =fft(complex(x,0.0)); fftnew =cfft*complex(0.0,0.0); i=integers(nlow,nupper); fftnew(i) = cfft(i); nseries=afam(real(fft(fftnew :back)))*(1./dfloat(norows(x))); call tabulate(x,nseries); call graph(freq,spectrum(nseries,freq) :plottype xyplot :heading 'Spectrun of filtered Random Series'); b34srun; /; /;FILTER Tests Filter Subroutine /; b34sexec matrix; /$ Uses FFT to High and Low Pass Random Series /$ /$ Illustrate with random numbers /$ call load(filter); n=500; test=rn(array(n:)); spec=spectrum(test,freq); call graph(freq,spec :plottype xyplot :heading 'Spectrum of Random series'); call filter(test,newtest,1,200); spec=spectrum(newtest,freq); call graph(freq,spec :plottype xyplot :heading 'Spectrum of Random after Low Pass'); call filter(test,high,201,500); spec=spectrum(high,freq); call graph(freq,spec :plottype xyplot :heading 'Spectrum of Random after High Pass'); b34srun; /; /;FILTERC Tests Filterc Subroutine /; b34sexec matrix; /$ Uses FFT to High and Low Pass Random Series /$ /$ Illustrate with random numbers /$ call load(filterc); n=500; test=rn(array(n:)); spec=spectrum(test,freq); call graph(freq,spec :plottype xyplot :heading 'Spectrum of Random series'); call filterc(test,newtest,1,200); spec=spectrum(newtest,freq); call graph(freq,spec :plottype xyplot :heading 'Spectrum of Random after Low Pass'); call filterc(test,high,201,500); spec=spectrum(high,freq); call graph(freq,spec :plottype xyplot :heading 'Spectrum of Random after High Pass'); b34srun; /; /;FIND Finds location of a character /; b34sexec matrix; cc=namelist(mary sue joan); wherea=find(cc,'a'); wherea2=find(cc,'A'); call tabulate(wherea,cc,wherea2); call character(cc2,'abcdefghijklmnop'); call print('Where is a?',cc2,find(cc2,'a')); call print('Where is b?',cc2,find(cc2,'b')); b34srun; /; /;FLOAT Integer to real*4 /; b34sexec matrix; r8g=grid(.1,6.,.3) ; i=integers(norows(r8g)); r4i= float(i) ; r8i=dfloat(i) ; i4idint=idint(r8g) ; i4idnint=idnint(r8g) ; i4fromr4=int(r4i) ; r8dint=dint(r8g) ; call names(all) ; call tabulate(i,r4i,r8i,r8g,i4idint,i4idnint,i4fromr4 r8dint); b34srun; /; /;FORMS Illustrate the FORMS Command Capability /; b34sexec matrix; /$ /$ Use this job as a template /$ call echooff; subroutine testform(ii,int4,r4,check,menu,string,menu2,r8,string2); nfields=18; ioff=3; /$ /$ type codes string 1 integer 2 real 3 cycling 4 /$ push 5 double 6 vert 7 long string 8 /$ check 9 check discript 10 /$ idfield=integers(nfields); icol =index( 2 40 2 40 2 40 2 40 2 40 2 40 2 40 2 40 10 50); irow =index( 1 1 2 2 3 3 6 6 10 10 13 13 14 14 15 15 18 18)+ioff; iwidth=index(20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 10 10); itype =index( 1001 2 1001 3 10 9 1001 7 1001 1 1001 4 1001 6 1001 8 5 5); /$ /$ Defines Exit box /$ idbox =index(1); icolbox=index( 3); irowbox=index(17+ioff); iwbox =index(68); ihbox =index(3); /$ /$ Allocte a 3 by 40 character*1 array to hold character info /$ cc =c1array(3,40:); call character(hold,'Do ARIMA Model'); cc(1,)=hold; call character(hold,'Do Regression Model'); cc(2,)=hold; call character(hold,'Do Nonlinear Model'); cc(3,)=hold; call character(fmt,'(g16.8)'); call forms(:start :formdefine S idfield icol irow iwidth itype :formhelp index(2 21+ioff 68) :formdefinebox idbox icolbox irowbox iwbox ihbox :commandn 'Test Form # 1 - Shows all Options' ); call forms(:cont :formputstring 1 'This is int*4' :formputstring 3 'This is a real*4' :formputstring 5 'Check Box' :formputstring 7 'Vertical Menu Box' :formputstring 9 'String' :formputstring 10 ' ' :formputstring 11 'Cycling Menu' :formputstring 13 'Real*8 number' :formputstring 15 'Long String' :formputstring 16 ' ' 60 :formputinteger 2 index(-9) :formputcheckbox index(6 0 5) :formputhelp 2 'Enter an integer*4 here' :formrangeinteger 2 index(-99999 99999) :formputhelp 4 'Enter an real*4 here' :formputreal 4 .1 fmt :formrangereal 4 array(:-999.,999.) :formputhelp 8 'This is a vertical menu - we show 2' :formputmenu 8 cc 1 :formverticalmenu 8 2 999 :formputmenu 12 cc 1 :formputhelp 10 'Enter a short string here' :formputhelp 12 'Click to cycle' :formputdouble 14 99.9 fmt :formrangedouble 14 array(:-999.,999.) :formputhelp 14 'This is a real*8 input menu' :formputhelp 16 'This is a long string menu' /$ /$ Exit group type 5 push /$ :formputbutton 17 'Run' 21 :formputhelp 17 'Run the Menu' :formattribute 17 'N' 'byellow' ' ' :formputhelp 18 'Escape without running' :formputbutton 18 'Escape' 23 :formattribute 18 'N' 'bred' ' ' /$ :formshowedit ii /$ :forminfolist /$ /$ pull out data into b34s matrix command names /$ :formgetinteger 2 int4 :formgetreal 4 r4 :formgetcheckbox 6 check :formgetmenu 8 menu :formgetstring 10 string :formgetmenu 12 menu2 :formgetdouble 14 r8 :formgetstring 16 string2 ); call forms(:final); return; end; call testform(ii,int4,r4,check,menu,string,menu2,r8,string2); /$ forminfolist data /$ call print('nfield_1 ',nfield_1:); /$ call print('nbox_1 ',nbox1 :); /$ call tabulate(ntab_1 ifx_1 ify_1 ifwid_1 iftype_1 ifiden_1); if(ii.eq.21)then; call print('ii =',ii:); call print('int =',int4:); call print('r4 =',r4:); call print('check =',check:); call print('menu =',menu:); call print('string =',string ); call print('menu2 =',menu2:); call print('r8 =',r8:); call print('string2=',string2); endif; if(ii.eq.23)call print('Menu terminated at user request'); b34srun; /; /;FORMS_1 Shows Tabbed Menu /; b34sexec matrix; call echooff; subroutine testform(ii,int4,r4,check,menu,string,menu2,r8,string2); nfields=18; /$ type codes string 1 integer 2 real 3 cycling 4 /$ push 5 double 6 vert 7 long string 8 /$ check 9 check discript 10 idfield=integers(nfields); icol =index( 2 40 2 40 2 40 2 40 2 40 2 40 2 40 2 40 10 50); irow =index( 1 1 2 2 3 3 6 6 1 1 3 3 5 5 6 6 16 16); iwidth=index(20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 10 10); itype =index( 1001 2 1001 3 10 9 1001 7 1001 1 1001 4 1001 6 1001 8 5 5); idbox =index(1 2); icolbox=index(3 3); irowbox=index(15 15); iwbox =index(68 68); ihbox =index( 3 3); cc =c1array(3,40:); call character(hold,'Do ARIMA Model'); cc(1,)=hold; call character(hold,'Do Regression Model'); cc(2,)=hold; call character(hold,'Do Nonlinear Model'); cc(3,)=hold; call character(fmt,'(g16.8)'); call forms(:start :formdefine t idfield icol irow iwidth itype :formhelp index(2 20 68) :formdefinebox idbox icolbox irowbox iwbox ihbox :formdefinetabs t array(2:'first','second') index(8,16) index(1,2) :commandn 'Test Form # 1 - Shows Tabbed form with global' ); call forms(:cont :formputstring 1 'This is int*4' :formputstring 3 'This is a real*4' :formputstring 5 'Check Box' :formputstring 7 'Vertical Menu Box' :formputstring 9 'String' :formputstring 10 ' ' :formputstring 11 'Cycling Menu' :formputstring 13 'Real*8 number' :formputreal 4 .1 fmt :formputdouble 14 99.9 fmt :formrangedouble 14 array(:-999.,999.) :formrangereal 4 array(:-999.,999.) :formrangeinteger 2 index(-99999 99999) :formputstring 15 'Long String' :formputstring 16 ' ' 60 :formputbutton 17 'Run' 21 :formputbutton 18 'Escape' 23 :formattribute 17 'N' 'byellow' ' ' :formattribute 18 'N' 'bred' ' ' :formputinteger 2 index(-9) :formputcheckbox index(6 0 5) :formputhelp 2 'Enter an integer*4 here' :formputhelp 4 'Enter an real*4 here' :formputhelp 8 'This is a vertical menu - we show 2' :formputmenu 8 cc 1 :formverticalmenu 8 2 999 :formputmenu 12 cc 1 :formputhelp 10 'Enter a short string here' :formputhelp 12 'Click to cycle' :formputhelp 14 'This is a real*8 input menu' :formputhelp 16 'This is a long string menu' :formputhelp 17 'Run the Menu' :formputhelp 18 'Escape without running' :formshowedit ii /$ :forminfolist :formgetinteger 2 int4 :formgetreal 4 r4 :formgetcheckbox 6 check :formgetmenu 8 menu :formgetstring 10 string :formgetmenu 12 menu2 :formgetdouble 14 r8 :formgetstring 16 string2 ); call forms(:final); return; end; call testform(ii,int4,r4,check,menu,string,menu2,r8,string2); /$ forminfolist data /$ call print('nfield_1 ',nfield_1:); /$ call print('nbox_1 ',nbox1 :); /$ call tabulate(ntab_1 ifx_1 ify_1 ifwid_1 iftype_1 ifiden_1); if(ii.eq.21)then; call print('ii =',ii:); call print('int =',int4:); call print('r4 =',r4:); call print('check =',check:); call print('menu =',menu:); call print('string =',string ); call print('menu2 =',menu2:); call print('r8 =',r8:); call print('string2=',string2); endif; if(ii.eq.23)call print('Menu terminated at user request'); b34srun; /; /;FORMS_2 Tests Loading a Production File /; b34sexec matrix; call forms(:start :formload 'iighco6.ifd' S); call forms(:cont :forminfolist); call names(all); call print('# of Fields ',nfield_1:); call print('# of Boxes ',nbox_1 :); call print('# of Tabs ',ntab_1 :); call tabulate(ifx_1,ify_1,ifwid_1,iftype_1,ifiden_1); b34srun; /; /;FORMS_3 Shows Forms and Menu Application /; b34sexec matrix; /$ /$ This test file based on CCF_stody in matmenu.mac /$ call echooff; call load(ccftest); call load(acf_plot); nccf=30; nlag=3; nccf=30; n=100; r8=.1; noise=1.; subroutine getdat(n,nccf,nlag,r8,noise,igo); nfields=12; ioff=3; /$ type codes string 1 integer 2 real 3 cycling 4 /$ push 5 double 6 vert 7 long string 8 /$ check 9 check discript 10 idfield=integers(nfields); icol =index( 20 20 4 60 4 60 4 60 4 60 6 60 ); irow =index( 1 2 4 4 6 6 8 8 10 10 18 18) + ioff; iwidth=index( 40 40 40 8 40 3 40 16 40 16 10 10); itype =index( 1001 1001 1001 2 1001 2 1001 6 1001 6 5 5); idbox =index(1); icolbox=index( 3); irowbox=index(17+ioff); iwbox =index(68); ihbox =index(3); call character(fmt,'(g16.8)'); call forms(:start :formdefine S idfield icol irow iwidth itype :formhelp index(2 21+ioff 68) :formdefinebox idbox icolbox irowbox iwbox ihbox :commandn 'CCF and ACF Relationships' ); call forms(:cont :formputstring 1 'Study Effect of ACF On CCF' :formputstring 2 'Illustrate Transfer Function ID' :formputstring 3 'Input # of observations' :formputstring 5 'Input # of terms in CCF' :formputstring 7 'Input ar(1) in range -.999 - .999' :formputstring 9 'Input noise multiplier' :formputinteger 4 n :formrangeinteger 4 index( 60 999999999) :formputinteger 6 nccf :formrangeinteger 6 index(2 999) :formputdouble 8 r8 fmt :formrangedouble 8 array(:-1., 1.) :formputdouble 10 noise fmt :formrangedouble 10 array(:0.0 100.) :formputbutton 11 'Run' 21 :formputbutton 12 'Escape' 23 :formattribute 11 'N' 'byellow' ' ' :formattribute 12 'N' 'bred' ' ' :formputhelp 4 'Enter an integer*4 here' :formputhelp 6 'Enter an integer*4 here' :formputhelp 8 'Enter an real*8 here' :formputhelp 10 'Enter an real*8 here' :formputhelp 11 'Run the Menu' :formputhelp 12 'Escape without running' :formshowedit ii /$ :forminfolist :formgetinteger 4 n :formgetinteger 6 nccf :formgetdouble 8 r8 :formgetdouble 10 noise ); call forms(:final); igo=0; if(ii.eq.21)igo=1; if(ii.eq.23)igo=0; return; end; again continue; call free(ma); call menu(jgo :menutype menutwo :heading 'Continue selection' :text 'Menu' :text 'Forms' :prompt 'Type of I/O ' ); if(jgo.eq.2)then; call getdat(n,nccf,nlag,r8,noise,igo); if(igo.eq.0)go to done; endif; if(jgo.eq.1)then; /$ /$ This is the older and easier menu approach call menu(n :menutype inputint :prompt '# of cases of for CCF example' ); call menu(nccf :menutype inputint :prompt '# of ccf to calculate' ); call menu(nlag :menutype inputint :prompt 'Enter lag as a positive number' ); call menu(r8 :menutype inputreal8 :prompt 'Enter ar(1) parameters in range -.999 - .999' ); call menu(noise :menutype inputreal8 :prompt 'Noise. Usual setting 1.0' ); /$ endif; ar=array(: r8); nn=100; start=array(:.1); x=genarma(ar,ma,1.0,start,.1,n,nn); i=integers(nlag+1,norows(x)); y=array(norows(x):)+missing(); rr=noise*rn(x); y(i)= x(i-nlag)+rr(i); do ii=1,nlag; x(ii)=missing(); y(ii)=missing(); enddo; x=goodrow(x); y=goodrow(y); call names(all); call character(title,'Effect of Autocorrelation on cross correlations'); /$ call tabulate(x,y); call acf_plot(x,nccf,'X Series'); call acf_plot(y,nccf,'Y Series'); call ccftest(x,y,nccf,lags,title); j=2; call menu(j :menutype menutwo :heading 'Continue selection' :text 'stop' :text 'go' :prompt 'Continue? ' ); if(j.eq.2)go to again; done continue; b34srun; /; /;FORMULA Illustrates use of Formula + Solve /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix ; * Shows use of formulas in simple case; * Here the analytic statement works same way as formula; * Formula allows resursive solutions ; * Formula solved one row at a time ; call loaddata; test1=gasout*2.; call print(mean(test1)); formula double = gasout(t)*2.; call names; call print(double); solve(test2=double(t) :range 1, norows(gasout) :block double); call print(mean(test2)); b34srun; /; /;FORPLOT Forcast Plot using GRAPHP /; b34sexec matrix; call load(forplot); y=rn(array(20:)); yhat=rn(array(4:)); error=dfloat(integers(4))/2.; se =error+yhat; se2 =yhat - error; call character(title,'Test Forecast Plot'); call load(forplot); /$ Graph using graph call graph(y :pgborder :heading 'graph command' :htitle 2. 2. :nocontact :pgxscaletop 'I' :pgyscaleleft 'NT' :pgyscaleright 'I' :colors black bred ); /$ Foreplot using graphp call forplot(y,yhat,se,se2,title,' '); /$ Foreplot using graphp call character(title,'Test Forecast Plot with Missing Data'); y(3)=missing(); call character(fileout,'plottest.wmf'); call forplot(y,yhat,se,se2,title,fileout); b34srun; /; /;FORTRAN Illustrates Fortran Call /; b34sexec matrix; call open(70,'_test.f'); call rewind(70); /$ 1234567890 call character(test," write(6,*)'This is a test # 2'" " n=1000 " " write(6,*)n " " do i=1,n " " write(6,*) sin(float(i)) " " enddo " " stop " " end "); call write(test,70); call close(70); /$ lf95 is Lahey Compiler /$ g77 is Linux Compiler /$ fortcl is script to run Lahey LF95 on Unix to link libs call dodos('lf95 _test.f'); * call dounix('g77 _test.f -o_test'); call dounix('lf95 _test.f -o_test'); * call dounix('fortcl _test.f -o_test'); call dodos('_test > testout':); call dounix('./_test > testout':); call open(71,'testout'); call character(test2,' '); call read(test2,71); call print(test2); testd=0.0; n=0; call read(n,71); testd=array(n:); call read(testd,71); call print(testd); call close(71); call dodos('erase testout'); call dodos('erase _test.f'); call dounix('rm testout'); call dounix('rm _test.f'); b34srun; /; /;FORTRAN_2 Illustrates hard coded GARCH In Fortran /; /$ Tests RATS vs GARCHEST vs FORTRAN /$ In the FORTRAN SETUP see line arch(1)=0.0 /$ If line is commented out => GARCHEST = FORTRAN /$ If line is not commented out FORTRAN = RATS /$ This illustrates the effect of starting values!!!!!! /$ Also illustrates Fortran as a viable alternative when there /$ are very special models to be run that are recursive in /$ nature b34sexec options ginclude('b34sdata.mac') member(lee4); b34srun; b34sexec matrix ; call loaddata ; * The data has been generated by GAUSS by following settings $ * a1 = GMA = 0.09 $ * b1_n = GAR = 0.5 ( When Negative) $ * b1 = GAR = 0.01 $ call echooff ; maxlag=0 ; y=doo1 ; y=y-mean(y) ; v=variance(y) ; arch=array(norows(y):) + dsqrt(v); * GARCH on a TGARCH Model ; call garchest(res,arch,y,func,maxlag,n :ngar 1 :garparms array(:.1) :ngma 1 :gmaparms array(:.1) :maxit 2000 :maxfun 2000 :maxg 2000 /$ :steptol .1d-14 :cparms array(2:.1,.1) :print ); b34srun; /; /;FPRINT Formatted Print Command /; b34sexec matrix; r =dsqrt(110.); ii=202; name='Diana'; call fprint(:clear :col 10 :string 'At 10' :col 20 :display r '(g16.8)' :col 40 :string 'At col 40' :print :col 60 :string 'Added string at 60' :print :clear :string 'String at 1' :print :col 40 :string 'Added at 40' :col 60 :display ii '(i3)' :col 70 :string name :print :cr 2); b34srun; /; /;FPRINT_2 Real*8 & Real*16 Examples /; b34sexec matrix; r =rn(array(8:))+100.; r16=r8tor16(r); r=dsqrt(r); r=r8tor16(r); r16=dsqrt(r16); call echooff; do i=1,norows(r); call fprint(:clear :col 1 :string 'This is Real*8' :col 20 :display r(i) '(g40.32)' :col 60 :string 'This is Real*16' :col 80 :display r16(i) '(g40.32)' :print); enddo; b34srun; /; /;FPROB F Distribution /; b34sexec matrix; * IMSL page 925 ; f=648.0; dfn=1.0; dfd=1.0; p=1.0-fprob(f,dfn,dfd); call print('Probability that F(1,1) variable is GE ',f,' is ',p, 'Answer should be .0250'); b34srun; /; /;FRACDIF Fractional Differencing /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; d=1./3.; fdgas=fracdif(gasout,d,20); call tabulate(%fdacoef,%fdmcoef); call tabulate(fdgas,gasout); acf1=acf(gasout,12); acf2=acf(fdgas ,12); call tabulate(acf1,acf2); call graph(acf1,acf2 :Heading 'ACF of GASOUT and FD GASOUT'); * Testing with random numbers; n=10000; d=1./3.; x=rn(array(n:)); fx1=fracdif(x,d,100); call tabulate(%fdacoef,%fdmcoef); acffx1=acf(fx1,50); d=(-1.0)*d; fx2=fracdif(x,d,100); call tabulate(%fdacoef,%fdmcoef); acffx2=acf(fx2,50); call print('Table 2.3 in Cambell-Lo-MacKinlay', 'acffx1 has d=1/3. acffx2 has d=-1/3'); call tabulate(acffx1,acffx2); b34srun; b34sexec matrix; * See Cambell-Lo-MacKinley page 60-61 ; call load(fdifinfo); call print(fdifinfo); d1=1./3.; nterms=20; /$ Note that dgamma limits us in terms of number of terms call fdifinfo(d1,nterms,ar1,ma1,p1); call print('Results for d = 1/3 - See Page 61'); call tabulate(ar1,ma1,p1); d1=(-1.)/3.; call fdifinfo(d1,nterms,ar2,ma2,p2); call print('Results for d = -1/3 - See Page 61'); call tabulate(ar2,ma2,p2); b34srun; /; /;FRACDIF_2 Tests Tsay Chung Paper JE (2000) /; b34sexec matrix; * Tests Tsay Chung paper that indicates if d1+d2 > .5 => spurious regression Note that as we generate series have to use -d1, -d2 The Spurious Regression of Fractionally Integreated Processes Journal of Econometrics 96 (2000) pp 155-182 ; * If n is increased the effect goes away assuming nterms remains at 100. The implications of this are not certain. Problems seen for n=10000 and nterms=150. nterms cannot get too large without dlgamma getting outside its range! ; n=1000; a=rn(array(n:)); b=rn(array(n:)); subroutine tfrac(a,b,d1,d2); nterms=100; x=fracdif(a,d1,nterms); y=fracdif(b,d2,nterms); s=dabs(d1)+dabs(d2); call print(' ' :); call print('Sum dabs(d1) + dabs(d2) ',s:); call olsq(y x :print); call graph(x,y); call print( '------------------------------------------------------------------':); return; end; call print(tfrac); call echooff; d1=-.1; d2=-.1; call tfrac(a,b,d1,d2); d1=-.15; d2=-.15; call tfrac(a,b,d1,d2); d1=-.2; d2=-.2; call tfrac(a,b,d1,d2); d1=-.25; d2=-.25; call tfrac(a,b,d1,d2); d1=-.3; d2=-.3; call tfrac(a,b,d1,d2); d1=-.35; d2=-.35; call tfrac(a,b,d1,d2); d1=-.4; d2=-.4; call tfrac(a,b,d1,d2); d1=-.45; d2=-.45; call tfrac(a,b,d1,d2); b34srun; /; /;FRACDIF_3 Various Expermients with Fractional Differencing /; b34sexec matrix; call echooff; /$ Illustrates various Fractional Differencing Calculations /$ /$ binomial illustrates getting AR and MR coefficients /$ fdifacf illustrates the theoretical ACF /$ arfilter filters a series subroutine binomial(d,k,v,fd); /$ /$ solves v =(d(d-1.)(d-2.)..(d-dfloat(k)+1))/dfloat(k)! /$ fd=((-1.)**k)*v /$ /$ (1-L)**d = (1-dL+((d(d-1)L**2)/2! - d(d-1)(d-2)/3! /$ /$ v=array(k+1:); order=integers(0,k); fd=v; v(1)=1.0; fd(1)=v(1); do i=2,k+1; v(i)=(v(i-1)*(d-dfloat(i)+2.0))/dfloat(i-1); fd(i)=((-1.)**dfloat(i-1))*v(i); enddo; return; end; subroutine fdifacf(d,n,tacf); /$ /$ d = fractional difference /$ n = # of ACF /$ tacf = ACF in theory /$ /$ Baillie (1996) argues /$ p(1) = d/(1.-d) /$ p(2) = p(1)*(1.+d)/(2-d) /$ ........................ /$ p(k) = p(k-1.)*(k-1.+d)/(k-d) /$ if(kind(d).ne.8.or.kind(n).ne.-4)then; call epprint('ERROR: Inputs 1 or 2 not correct':); go to finish; endif; if(dabs(d).ge.1.)then; call epprint('ERROR: dabs(d) GE 1.0':); go to finish; endif; tacf=array(n:); tacf(1)=d/(1.-d); do i=2,n; tacf(i)=tacf(i-1)*((dfloat(i-1)+d)/(dfloat(i)-d)); enddo; finish continue; return; end; subroutine arfilter(coef,series,nseries); /$ /$ Using AR coefficients in coef, filter series /$ /$ coef = coefficient array starting with zero order term /$ series = series to be filtered /$ nseries = filtered series /$ n=norows(series); n2=norows(coef); nseries=array(norows(series):); nseries=nseries+missing(); jj=integers(n2,1); do i=n2,n; nseries(i)=vfam(coef)*vfam(series(jj)); jj=jj+1; enddo; return; end; n=1000; d=1./3.; call binomial(d,20,v,fd); call print('FD from Binomial Subroutine'); call tabulate(fd); testdata=rn(array(n:)); call arfilter(fd,testdata,new); call print('ACF of data filtered with Binomial coef':); call tabulate(acf(goodrow(new),20)); /$ Use built in routine n=20; call fdifacf(d,n,tacf); call print('Using fdifacf subroutine':); call print('TACF is Theoretical ACF for d= ',d:); d=(-1.0)*d; call print('TACF2 is Theoretical ACF for d = ',d:); call fdifacf(d,n,tacf2); call tabulate(tacf,tacf2); n=3000; testdata=rn(array(n:)); d=(-1.0)*d; test=fracdif(testdata,d,170); call print(' '); call print('Random series filtered with fracdif':); call print('Number of data points is ',n:); call print('ACF1 is actual ACF for d= ',d:); acf1=acf(test,20); d=(-1.0)*d; test=fracdif(testdata,d,170); acf2=acf(test,20); call print('ACF2 is actual ACF for d = ',d:); call tabulate(acf1,acf2); tt=fracdif(testdata,d,10); call print('From fracdif':); call tabulate(%fdacoef, %fdmcoef); call print('From Binomial':); call binomial(d ,10,v,fd); call tabulate(v,fd); call print('From Binomial d=.7':); call binomial(.7,10,v,fd); call tabulate(v,fd); call print('From Binomial d=1.':); call binomial(1.,10,v,fd); call tabulate(v,fd); b34srun; /; /;FREE Call FREE => erase objects /; b34sexec matrix; n=4; x=rn(matrix(n,n:)); pdx=transpose(x)*x; call names; call free(n:); call names(info); call makeglobal(pdx); call names(info); r=pdfac(pdx); call print(pdx,r); call makelocal(pdx); call names(info); r=pdfac(pdx); call print(pdx,r); pdx(1,1)=.9999; call names; call print(pdx,'We now free at the local level'); call free(pdx); call names(info); call print('We now free at the global level'); call free(pdx:); call names(info:); b34srun; /; /;FREQ Illustrates Frequency /; b34sexec options ginclude('b34sdata.mac') member(theil); b34srun; b34sexec matrix; call loaddata; call print(timebase(ct),timestart(ct),freq(ct)); b34srun; /; /;FUNCTEST Illustrates a Function Call /; b34sexec options ginclude('gas.b34'); b34srun; /$ Shows function call and data changed /$ Also shows a subroutine call from a function b34sexec matrix; call loaddata; call echooff; function meanf(x); xmean=mean(x); return(xmean); end; subroutine modit(yy); yy(1)=1500.; return; end; call print(meanf,modit); call print('Meanf back from function for gasout was', meanf(gasout) ); call print('Meanf back from function for gasin was', meanf(gasin) ); call print('Mean from root for mod of gasout was', mean(gasout) ); call print('Mean from root for mod of gasin was', mean(gasin) ); call names(all); b34srun; /; /;FUNCTEST2 Illustrates Functions as arguments /; b34sexec matrix; function test(i); x=dfloat(i*i); return(x); end; function rtest(x); xx=x*x; return(xx); end; t=test(4); call print('t displayed (should be 16) ',t); call print('should show 16 here also ',rtest(test(2))); call print('test(4)/test(2) is 16/4 ',test(4)/test(2)); b34srun; /; /;FUNCTEST3 Illustrates Function used as subroutine arguments /; b34sexec matrix; subroutine test(ii,jj); call print('ii was ',ii); call print('jj was ',jj); return; end; function dd(i); jj=i*i; return(jj); end; call test(dd(2),dd(3)); b34srun; /; /;FYEAR Illustrates Date processing /; b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; /; /;GARCH2P_1 Test ARMA / GARCH Example /; b34sexec options ginclude('gas.b34'); b34srun; /$ User is controlling model b34sexec matrix; /$ /$ Subroutine is inside routine in comment form /$ /$ subroutine garch2p(data,nar,nma,coef1,se1,t1,gnar,gnma,coef2,se2,t2, /$ res1,res2,refine); /$ Estimate ARMA / GARCH model following Enders (1995, page 150) /$ two pass method /$ /$ Data => Data /$ nar => # of ar terms for first moment /$ nma => # of ma terms for first moment /$ coef1 => first moment coefficients /$ se1 => first moment se /$ t1 => first moment t /$ gnar => second moment # of ar terms /$ gnma => second moment # of ma terms /$ coef2 => second moment coef /$ se2 => second moment se /$ t2 => second moment t /$ res1 => first moment residual /$ res2 => second moment residual /$ refine => if NE 0 refine models /$ /$ /$ call print('First Moment Model ***************'); /$ call arma(data :nar nar :nma nma :print :refine refine); /$ call print('Second Moment Model ***************'); /$ res1=afam(%res); coef1=%coef; se1=%se; t1=%t; /$ data2=res1*res1; /$ call arma(data2 :nar gnar :nma gnma :print :refine refine); /$ res2=afam(%res); coef2=%coef; se2=%se; t2=%t; /$ return; /$ end; call loaddata; call load(garch2p); nar=6; nma=0; gnar=1; gnma=0; call garch2p(gasout,nar,nma,coef1,se1,t1,gnar,gnma,coef2,se2,t2, res1,res2,2.0); call graph(res1); call graph(res2); acf1=acf(res1); call graph(acf1); acf2=acf(res2); call graph(acf2); call tabulate(acf1,acf2); b34srun; /; /;GARCH2P_2 Shows Model that is revised later /; /$ /$ User attempts AR model with 10 terms /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(garch2p); * This setting is too big but tests software ; * For a more excessive example see ARMA_6 ; nar=10; nma=0; gnar=1; gnma=0; call garch2p(gasout,nar,nma,coef1,se1,t1,gnar,gnma,coef2,se2,t2, res1,res2,2.0); call graph(res1); call graph(res2); acf1=acf(res1); call graph(acf1); acf2=acf(res2); call graph(acf2); call tabulate(acf1,acf2); b34srun; /; /;GARCH2P_A Two Pass GARCH Estimation - Automatic /; /$ Template for basic Two pass GARCH Estimation /$ Menu facility will allow a more complex setup b34sexec options ginclude('b34sdata.mac') member(wpi); b34srun; b34sexec matrix; call loaddata; call echooff; call autobj(pi :autobuild :print :nac 24 :npac 24 /$ :seasonal 12 :rdif /$ :sdif /$ :smodeln 'moment1.mod' /$ :forecast 25 200 ); %res1 =%res; %ressq=%res*%res; call autobj(%ressq :autobuild :print :nac 24 :npac 24 /$ :smodeln 'moment2.mod' /$ :seasonal 12 /$ :forecast 25 200 ); %res2 =%res; acf1=acf(%res1,24); acf2=acf(%res2,24); call tabulate(acf1,acf2); b34srun; /; /;GENARMA ACF and Spectrum of AR(.9) & AR(-.09) /; b34sexec matrix; ar=array(:.9); n=1000; start=array(:.1); testar1a=genarma(ar,ma,1.0,start,.1,n); ar=array(:-.9); testar1b=genarma(ar,ma,1.0,start,.1,n); acf1a=acf(testar1a,20,se,pacf1a); acf1b=acf(testar1b,20,se,pacf1b); call spectral(testar1a,sinx,cosx,px,sx1a,freq:1 2 3 2 1); call spectral(testar1b,sinx,cosx,px,sx1b,freq:1 2 3 2 1); call graph(freq,sx1a:heading 'Spectrum of ar(.9)' :plottype xyplot); call graph(freq,sx1b:heading 'Spectrum of ar(-.9)' :plottype xyplot); call tabulate(acf1a,acf1b,pacf1a,pacf1b); b34srun; /; /;GENARMA_1 Simple test of arma(3,2) model /; b34sexec matrix; * imsl test case; ar=array(:.7,-.5,.2 ); ma=array(:-.5,-.25); n=10; start=array(:.1,.05,.0375); test=genarma(ar,ma,1.0,start,.1,n); call print(test); n=1000; test=genarma(ar,ma,1.0,start,.1,n); acf1=acf(test,dmax1(norows(test)/50,2),se,pacf1); call graph(acf1,pacf1 :heading 'ACF & PACF of ARMA(3,2)'); call spectral(test,sinx,cosx,px,sx1,freq:1 2 3 2 1); call graph(freq,sx1:heading 'Spectrum of ARMA(3,2)' :plottype xyplot); b34srun; /; /;GENARMA_2 Illustrates various AR Models /; b34sexec matrix; * Enders test cases on page 14; * Use to study ar values of .9, .5, -.5, 1. 1.01 -1.01 ; * By adjusting var can show effect of noise ; n=200; ndrop=0; ar=-1.01; var=.1; con=0.0; start=array(1:1.); case_1=genarma(ar,ma,con,start,var,n,ndrop); call graph(case_1 :heading 'Plot Case_1' ); b34srun; /; /;GENARMA_3 Generates AR(2) Test Case /; b34sexec matrix; * Theory suggests acf is .77273, .55682 ; ar=array(:.85,-.1); n=100000; start=array(:.1,.1); testar2=genarma(ar,ma,1.0,start,.1,n,3000); acfar2=acf(testar2,20,se,pacfar2); call spectral(testar2,sinx,cosx,px,sxar2,freq:1 2 3 2 1); call graph(freq,sxar2:heading 'Spectrum of ar2(.85, -.1)' :plottype xyplot); call tabulate(acfar2,pacfar2); b34srun; /; /;GENARMA_4 Generates ARMA models (AR(1) MA(1) ARMA) /; b34sexec matrix; n=4000; /$ Model fit was ar1(t)= .9 * ar1(t-1) + e(t) ar=.9; call free(ma); const=1.0; start=.1; wnv=1.0; nout=200; ar1=genarma(ar,ma,const,start,wnv,n,nout); acf1=acf(ar1,dmax1(norows(ar1)/50,2),se1,pacf1); call graph(acf1,pacf1 :heading 'ACF & PACF of ar1'); call spectral(ar1,sinx,cosx,px,sx1,freq:1 2 3 2 1); call graph(freq,sx1:heading 'Spectrum of ar1' :plottype xyplot); /$ Model fit was ma1(t)= e(t)-.1 * e(t-1) ma=.1; call free(ar); cons=1.0; start=.1; wnv=1.0; nout=200; ma1=genarma(ar,ma,const,start,wnv,n,nout); acf2=acf(ma1,dmax1(norows(ma1)/50,2),se2,pacf2); call graph(acf2,pacf2 :heading 'ACF & PACF of ma1'); call spectral(ma1,sinx,cosx,px,sx2,freq:1 2 3 2 1); call graph(freq,sx2:heading 'Spectrum of ma1' :plottype xyplot); /$ Model fix was (1-.9*B)*arma = (1-.1*B)*e(t) ar=.9; ma=.1; cons=1.0; start=.1; wnv=1.0; nout=200; arma=genarma(ar,ma,const,start,wnv,n,nout); acf3=acf(arma,dmax1(norows(arma)/50,2),se3,pacf3); call graph(acf3,pacf3 :heading 'ACF & PACF of arma(1,1)'); call spectral(arma,sinx,cosx,px,sx3,freq:1 2 3 2 1); call graph(freq,sx3:heading 'Spectrum of arma' :plottype xyplot); call makedata(arma,ar1,ma1); b34srun; /; /;GENARMA_T Generates Actual and Theoretical ACF /; b34sexec matrix; * study the theoretical ACF of the ARMA(1,1) model; * |psi| must be > 0.0; call echooff; theta=-.9; psi=.9; n=200; nacf=30; sigmausq=1.0; i=integers(n); cc=psi-theta; cpsi=psi**(dfloat(i-1)) *cc; * call tabulate(i,cpsi); gamma0=sigmausq*(sumsq(cpsi)+1.); gamma=array((n-nacf):); jj=integers(n-nacf); do ii=1,nacf; gamma(ii)=sigmausq* (sum(cpsi(jj)*cpsi(jj+ii))+ cpsi(ii)); enddo; tacf1=gamma/gamma0; tacf=tacf1(integers(nacf)); * Now generate some data and see what happens ; nobs=100000; ndrop=1000; start=array(:1.); testarma=genarma(psi,theta,1.0,start,sigmausq,nobs,ndrop); acf1a=acf(testarma,nacf,se,pacf1a); call spectral(testarma,sinx,cosx,px,sx1a,freq:1 2 3 2 1); call graph(freq,sx1a:heading 'Spectrum of arma(1,1)' :plottype xyplot); call graph(acf1a:heading 'ACF of ARMA(1,1)'); materms=cpsi(integers(norows(tacf))); tgamma=gamma(integers(norows(tacf))); call print('Psi ',psi :); call print('Theta ',theta :); call print('GAMMA(0) ',gamma0:); call tabulate(tacf acf1a,pacf1a,tgamma,materms); call graph(tacf,acf1a :Heading 'Theoretical ACF and Model ACF'); b34srun; /; /;GET Get One or More Series /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call get(gasout,gasin); call names; call graph(gasout); b34srun; /; /;GET_2 Shows removing Missing Data /; b34sexec options ginclude('b34sdata.mac') member(karras4); b34srun; b34sexec matrix; call get(can_ex,jap_m, julian_ :dropmiss); date=chardate(julian_); call tabulate(date,can_ex,jap_m,julian_); call cleardat; call print('*********** Full Dataset **************':); call get(can_ex,jap_m, julian_ ); date=chardate(julian_); call tabulate(date,can_ex,jap_m,julian_); b34srun; /; /;GETDAY Illustrates Date processing /; b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; /; /;GETHOUR Illustrates Date processing /; b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; /; /;GETMATLAB Gets Matlab Data saved with MAKEB34S command /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; /$ When using the MATLAB GETB34S file use full path /$ xx=getb34s('c:\junk\junk.ttt'); call loaddata; call names; xx=rn(matrix(5,5:)); call makematlab(gasout,gasin:file 'junk.ttt'); call makematlab(xx :file 'junk2.ttt'); call getmatlab(x, :file 'junk.ttt'); call getmatlab(xx2 :file 'junk2.ttt'); call print(x,xx,xx2); call names; cx=complex(xx,xx*2.); call makematlab(cx :file 'junk3.ttt'); call getmatlab(cx2, :file 'junk3.ttt'); call print(cx,cx2); b34srun; /; /;GETMINUTE Illustrates Date processing /; b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; /; /;GETMONTH Illustrates Date processing /; b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; /; /;GETNDIMV Gets value from N Dimensional Object /; b34sexec matrix; x=rn(array(index(4,4,4:):)); call print(x,getndimv(index(4,4,4),index(1,2,1),x)); do k=1,4; do i=1,4; do j=1,4; test=getndimv(index(4,4,4),index(i,j,k),x); call print(i,j,k,test); enddo; enddo; enddo; b34srun; /; /;GETQT Illustrates Date processing /; b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; /; /;GETRATS Get Rats Portable File /; /$ /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; newgasi=gasin; newgaso=gasout; call makerats(gasin,newgasi,gasout,newgaso :file 'full.por'); call print(mean(gasin) mean(newgasi) mean(newgaso) mean(gasout) ); call cleardat; call getrats('full.por'); call print(mean(gasin) mean(newgasi) mean(newgaso) mean(gasout) ); call names; call tabulate(obsnum,gasin,newgasi,gasout,newgaso); b34srun; /; /;GETSCA Illustrate GETSCA Command reading fsv /; /$$ Tests GETSCA in Matrix command. b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; B34SEXEC OPTIONS OPEN('MY.FSV') DISP=UNKNOWN UNIT(44)$ B34SRUN$ B34SEXEC OPTIONS CLEAN(44)$ B34SRUN$ B34SEXEC SCAINPUT$ MAKESCA DATASET=MYFILE /$ VAR=( ) SCAUNIT=44$ B34SRUN$ B34SEXEC OPTIONS CLOSE(44)$ B34SRUN$ b34sexec matrix; call getsca('MY.fsv'); call names; call graph(gasout); b34srun; /; /;GETSCA_2 Illustrate GETSCA Command reading mad /; /$$ Tests GETSCA in Matrix command. /$$ Test file first built b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call makemad(gasin,gasout :file 'full.mad' :member test); b34srun; b34sexec matrix; call getsca('full.mad' :mad); call names; call graph(gasout); b34srun; /; /;GETSECOND Illustrates Date processing /; b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; /; /;GETSECOND Get second and other time commands /; b34sexec matrix; call echooff; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.11; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); b34srun; /; /;GETYEAR Illustrates Date processing /; b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; /; /;GMFAC LU Factorization /; b34sexec matrix; * Problem from MATLAB; x=matrix(3,3:8. 1. 6. 3. 5. 7. 4. 9. 2.); call gmfac(x,l,u,info); call print(x,l,u,info,l*u); cx=complex(x,dsqrt(dabs(x))); call gmfac(cx,cl,cu,info); call print(cx,cl,cu,info,cl*cu); b34srun; /; /;GMINV Inverse using LAPACK /; b34sexec matrix; call echooff; n=5; x=rn(matrix(n,n:)); call gminv(x,xinv1,info); xinv2=inv(x); dtest=matrix(n,n:)+1.0; test1=x*xinv1; test2=x*xinv2; if(n.le.5)call print(x ,xinv1 ,xinv2 ,test1,test2); call print('Real Matrix is of order ',n:); call print('Max Error for LAPACK ', dmax(dabs(dtest-test1)):); call print('Max Error for LINPACK ', dmax(dabs(dtest-test2)):); call print('Sum Error for LAPACK ', sum(dabs(dtest-test1)):); call print('Sum Error for LINPACK ', sum(dabs(dtest-test2)):); call print('Sumsq Error for LAPACK ',sumsq(dtest-test1):); call print('Sumsq Error for LINPACK ',sumsq(dtest-test2):); cx=complex(x,dsqrt(dabs(x))); call gminv(cx,cxinv1,info); cxinv2=inv(cx); dc=complex(dtest,0.0); test1=cx*cxinv1; test2=cx*cxinv2; if(n.le.5)call print(cx,cxinv1,cxinv2,test1,test2); call print('Complex Matrix is of order ',n:); call print('Max Error for LAPACK real ', dmax(dabs(real(dc-test1))):); call print('Max Error for LINPACK real ', dmax(dabs(real(dc-test2))):); call print('Max Error for LAPACK imag ', dmax(dabs(imag(dc-test1))):); call print('Max Error for LINPACK imag ', dmax(dabs(imag(dc-test2))):); call print('Sum Error for LAPACK real ',sum(dabs(real(dc-test1))):); call print('Sum Error for LINPACK real ',sum(dabs(real(dc-test2))):); call print('Sum Error for LAPACK imag ',sum(dabs(imag(dc-test1))):); call print('Sum Error for LINPACK imag ',sum(dabs(imag(dc-test2))):); call print('Sumsq Error for LAPACK real ',sumsq(real(dc-test1)):); call print('Sumsq Error for LINPACK real ',sumsq(real(dc-test2)):); call print('Sumsq Error for LAPACK imag ',sumsq(imag(dc-test1)):); call print('Sumsq Error for LINPACK imag ',sumsq(imag(dc-test2)):); b34srun; /; /;GMINV_2 Speed tests of LAPACK vs LINPACK /; b34sexec matrix; * Tests speed of Linpack vs LAPACK; call echooff; icount=0; n=0; upper=250; mesh=50; top continue; icount=icount+1; n=n+mesh; if(n .eq. upper)go to done; x=rn(matrix(n,n:)); ii=matrix(n,n:)+1.; call timer(base1); call gminv(x,xinv1,info); call timer(base2); error1(icount)=sum(dabs(ii-(xinv1*x))); call timer(base3); xinv1=inv(x); call timer(base4); error2(icount)=sum(dabs(ii-(xinv1*x))); size(icount) =dfloat(n); lapack(icount) =(base2-base1); linpack(icount)=(base4-base3); call free(x,xinv1,ii) call compress; go to top; done continue; call tabulate(size,lapack,linpack,error1,error2); call graph(size lapack,linpack :plottype xyplot); b34srun; /; /;GMINV_3 Speed tests for LAPACK vs LINPACK /; b34sexec matrix; * At 150 LINPACK is faster ; * At 300 and 600 LAPACK wins ; * For this reason the inv( ) command uses LINPACK; n=150; call print('size ',n); x=rn(matrix(n,n:)); call timer(t1); xx=inv(x); call timer(t2); call print('GM time',t2-t1); call compress; call timer(t1); call gminv(x,xx); call timer(t2); call print('LAPACK',t2-t1); call compress; n=300; call print('size ',n); x=rn(matrix(n,n:)); call timer(t1); xx=inv(x); call timer(t2); call print('GM time',t2-t1); call compress; call timer(t1); call gminv(x,xx); call timer(t2); call print('LAPACK',t2-t1); call compress; n=600; call print('size ',n); x=rn(matrix(n,n:)); call timer(t1); xx=inv(x); call timer(t2); call compress; call print('GM time',t2-t1); call timer(t1); call gminv(x,xx); call timer(t2); call print('LAPACK',t2-t1); b34srun; /; /;GMINV_4 Tests of invert done different ways /; b34sexec matrix; call echooff; n=100; * test1 and test3 use LAPACK ; x=rn(matrix(n,n:)); * to show effect of balancing uncomment next statement; * x(1,)=x(1,)*100000.; call gminv(x,xinv1,info); xinv2=inv(x); xinv3=inv(x:gmat); j=inv(x,rcond:gmat); j=inv(x,rcond2); xinv4=inv(x,rcond3 :refine); xinv5=inv(x,rcond4 :refinee); dtest=matrix(n,n:)+1.0; test1=x*xinv1; test2=x*xinv2; test3=x*xinv3; test4=x*xinv4; test5=x*xinv5; if(n.le.5)call print(x ,xinv1 ,xinv2,xinv3 ,test1,test2,test3); call print('Matrix is of order ',n:); call print('LAPACK 3 => refine':); call print('LAPACK 4 => refinee':); call print('Max Error for LAPACK 1', dmax(dabs(dtest-test1)):); call print('Max Error for LAPACK 2', dmax(dabs(dtest-test3)):); call print('Max Error for LAPACK 3', dmax(dabs(dtest-test4)):); call print('Max Error for LAPACK 4', dmax(dabs(dtest-test5)):); call print('Max Error for LINPACK ', dmax(dabs(dtest-test2)):); call print('Sum Error for LAPACK 1', sum(dabs(dtest-test1)):); call print('Sum Error for LAPACK 2', sum(dabs(dtest-test3)):); call print('Sum Error for LAPACK 3', sum(dabs(dtest-test4)):); call print('Sum Error for LAPACK 4', sum(dabs(dtest-test5)):); call print('Sum Error for LINPACK ', sum(dabs(dtest-test2)):); call print('Sumsq Error for LAPACK 1',sumsq(dtest-test1):); call print('Sumsq Error for LAPACK 2',sumsq(dtest-test3):); call print('Sumsq Error for LAPACK 3',sumsq(dtest-test4):); call print('Sumsq Error for LAPACK 4',sumsq(dtest-test5):); call print('Sumsq Error for LINPACK ',sumsq(dtest-test2):); call print('rcond rcond2 rcond3,rcond4',rcond,rcond2,rcond3,rcond4); cx=complex(x,dsqrt(dabs(x))); call gminv(cx,cxinv1,info); cxinv2=inv(cx); cxinv3=inv(cx:gmat); cxinv4=inv(cx,rcond3 :refine); cxinv5=inv(cx,rcond4 :refinee); dc=complex(dtest,0.0); test1=cx*cxinv1; test2=cx*cxinv2; test3=cx*cxinv3; test4=cx*cxinv4; test5=cx*cxinv5; j=inv(x,rcond:gmat); j=inv(x,rcond2); if(n.le.5)call print(cx,cxinv1,cxinv2,cxinv3,test1,test2,test3); call print('Matrix is of order ',n:); call print('Max Error for LAPACK 1 real', dmax(dabs(real(dc-test1))):); call print('Max Error for LAPACK 2 real', dmax(dabs(real(dc-test3))):); call print('Max Error for LAPACK 3 real', dmax(dabs(real(dc-test4))):); call print('Max Error for LAPACK 4 real', dmax(dabs(real(dc-test5))):); call print('Max Error for LINPACK real', dmax(dabs(real(dc-test2))):); call print('Max Error for LAPACK 1 imag', dmax(dabs(imag(dc-test1))):); call print('Max Error for LAPACK 2 imag', dmax(dabs(imag(dc-test3))):); call print('Max Error for LAPACK 3 imag', dmax(dabs(imag(dc-test4))):); call print('Max Error for LAPACK 4 imag', dmax(dabs(imag(dc-test5))):); call print('Max Error for LINPACK imag', dmax(dabs(imag(dc-test2))):); call print('Sum Error for LAPACK 1 real',sum(dabs(real(dc-test1))):); call print('Sum Error for LAPACK 2 real',sum(dabs(real(dc-test3))):); call print('Sum Error for LAPACK 3 real',sum(dabs(real(dc-test4))):); call print('Sum Error for LAPACK 4 real',sum(dabs(real(dc-test5))):); call print('Sum Error for LINPACK real',sum(dabs(real(dc-test2))):); call print('Sum Error for LAPACK 1 imag',sum(dabs(imag(dc-test1))):); call print('Sum Error for LAPACK 2 imag',sum(dabs(imag(dc-test3))):); call print('Sum Error for LAPACK 3 imag',sum(dabs(imag(dc-test4))):); call print('Sum Error for LAPACK 4 imag',sum(dabs(imag(dc-test5))):); call print('Sum Error for LINPACK imag',sum(dabs(imag(dc-test2))):); call print('Sumsq Error for LAPACK 1 real',sumsq(real(dc-test1)):); call print('Sumsq Error for LAPACK 2 real',sumsq(real(dc-test3)):); call print('Sumsq Error for LAPACK 3 real',sumsq(real(dc-test4)):); call print('Sumsq Error for LAPACK 4 real',sumsq(real(dc-test5)):); call print('Sumsq Error for LINPACK real',sumsq(real(dc-test2)):); call print('Sumsq Error for LAPACK 1 imag',sumsq(imag(dc-test1)):); call print('Sumsq Error for LAPACK 2 imag',sumsq(imag(dc-test3)):); call print('Sumsq Error for LAPACK 3 imag',sumsq(imag(dc-test4)):); call print('Sumsq Error for LAPACK 4 imag',sumsq(imag(dc-test5)):); call print('Sumsq Error for LINPACK imag',sumsq(imag(dc-test2)):); call print('rcond rcond2 rcond3,rcond4',rcond,rcond2,rcond3,rcond4); b34srun; /; /;GMSOLV Solution of equations system /; b34sexec matrix; n=6; x=rec(matrix(n,n:)); b=rec(x); call gmsolv(x,b,aa,info); call print(x,b,aa,inv(x)*b); call gmsolv(x,b,aa,info:refine); call print(x,b,aa,inv(x)*b); call print(%rcond,%ferror,%berror); call gmsolv(x,b,aa,info:refinee); call print(x,b,aa,inv(x)*b); call print(%rcond,%ferror,%berror); b34srun; /; /;GMSOLV_2 Tests Various GMSOLV Options /; b34sexec matrix; /$ /$ Not clear that Refinement makes much difference /$ subroutine test(n); x=rn(matrix(n,n:)); x(1,)=100000.*x(1,); b=rn(x); call print('Matrix Order ',n:) call print('a => refine. ':); call print('b => refinee ':); call print(' ':); call gmsolv(x,b,test1,info); call gmsolv(x,b,test1a,info:refine); call print('refine case', %rcond,%ferror,%berror); call gmsolv(x,b,test1b,info:refinee); call print('refinee case',%rcond,%ferror,%berror); test2=inv(x)*b; diff =dabs(test1-test2); diffa=dabs(test1-test1a); diffb=dabs(test1-test1b); if(n.le.5)call print(x ,b ,test1,test2,diff,test1a,test1b,diffa,diffb); call print('Real Matrix Case ':); call print('max diff ',dmax(diff) :); call print('max diffa ',dmax(diffa):); call print('max diffb ',dmax(diffa):); call print('sumsq diff ',sumsq(diff) :); call print('sumsq diffa ',sumsq(diffa):); call print('sumsq diffb ',sumsq(diffa):); cx=complex(x,dsqrt(dabs(x))); cb=complex(b,dsqrt(dabs(b))); call gmsolv(cx,cb,test1,info); call gmsolv(cx,cb,test1a,info:refine); call print('refine case ',%rcond,%ferror,%berror); call gmsolv(cx,cb,test1b,info:refinee); call print('refinee case',%rcond,%ferror,%berror); test2=inv(cx)*cb; diff =dabs(test1-test2); diffa=dabs(test1-test1a); diffb=dabs(test1-test1b); if(n.le.5)call print(cx,test1,test2,diff,test1a,test1b,diffa,diffb); call print('Complex Case':); call print('max diff on real ', dmax(real(diff)) :); call print('max diff on imag ', dmax(imag(diff)) :); call print('max diffa on real ', dmax(real(diffa)):); call print('max diffa on imag ', dmax(imag(diffa)):); call print('max diffb on real ', dmax(real(diffb)):); call print('max diffb on imag ', dmax(imag(diffb)):); call print('sumsq diff on real ',sumsq(real(diff)): ); call print('sumsq diff on imag ',sumsq(imag(diff)): ); call print('sumsq diffa on real ',sumsq(real(diffa)):); call print('sumsq diffa on imag ',sumsq(imag(diffa)):); call print('sumsq diffb on real ',sumsq(real(diffb)):); call print('sumsq diffb on imag ',sumsq(imag(diffb)):); return; end; * above 5 only tests max difference and sumsq ; n=5; call test(n); call echooff; do i=50,250,50; call test(i); enddo; b34srun; /; /;GOODCOL Test goodcol command /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; newdata=catcol(gasin gasout lag(gasin,1),lag(gasin,2)); call print(newdata); gcol=goodcol(newdata); grow=goodrow(newdata); call print(gcol,grow); crow3=catrow(gasin gasout lag(gasin,1),lag(gasin,2)); call print(crow3); b34srun; /; /;GOODROW Test goodrow command /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; newdata=catcol(gasin gasout lag(gasin,1),lag(gasin,2)); call print(newdata); gcol=goodcol(newdata); grow=goodrow(newdata); call print(gcol,grow); crow3=catrow(gasin gasout lag(gasin,1),lag(gasin,2)); call print(crow3); b34srun; /; /;GOTO Tests GOTO statement /; b34sexec matrix; /$ See also DOTEST4 for a bigger example do i=1,10; if(i.gt.7)go to n10; call print('I should be less than 7',i); n10 continue; enddo; b34srun; /; /;GRAPH Call Graph => High Resolution Graphics /; b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; i=integers(60); gasout=gasout(i); gasin=gasin(i); ccf1=ccf(gasin gasout,24); call graph(gasout,gasin); call graph(gasout,gasin:nokey :heading 'Nokey option'); call graph(gasout gasin :colors bblue bred bgreen); call graph(gasin); call graph(gasout:plottype hist2d :heading 'Hist2d Plot' :ylabelpos .5 :ylabelleft 'This is a special label - 1 2 3 4 5 6' 'C9'); call graph(gasout:plottype hist3d :heading 'Hist3d Plot' ); call graph(gasout:plottype hist3dc:heading 'Hist3dc Plot'); call graph(gasout:plottype bar2d :heading 'Bar2d Plot' :colors bred bgreen); call graph(gasout:plottype bar2dv :heading 'Bar2d Plot' :colors bred bgreen); call graph(gasout:plottype bar2dc :heading 'Bar2dc Plot'); call graph(gasout:plottype Bar3d :heading 'Bar3d Plot'); call graph(gasout:plottype Bar3dc :heading 'Bar3dc Plot'); call print(ccf1); call graph(ccf1 :plottype hist2d); call graph(ccf1 :heading 'CCF1 '); call names; ccf1=ccf(gasin,gasout,24,lags); ccf2=ccf(gasin,gasin ,24,lags); acf1=acf(gasin,24,se); call graph(acf1,se:heading 'ACF and SE'); call tabulate(ccf1,ccf2,acf1,lags); * special pie chart graph ; n=namelist(houston diana Will bobby); weight=vector(4:198,130,165,200); call tabulate(n weight); call names; call graph(weight,n :plottype pie :heading 'Family Weight'); b34srun$ /$ shows time plot b34sexec options ginclude('b34sdata.mac') member(res79); b34srun; b34sexec matrix; call loaddata; call names(all); year=getyear(bjulian_); call graph(year fms :plottype xyplot); b34srun; /$ Shows xyplot and xyscatter and scatter b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; x=array(4:1 20 3 4); y=array(4:4 3 2 1); z=2.*x; call graph(x y z :plottype xyplot :heading 'x y z using xyplot'); call graph(gasin,gasout :plottype xyscatter :markpoint 1 1 3 33 :nokey :heading 'gasin gasout xyscatter'); call graph(gasin,gasout :plottype scatter :markpoint 1 1 3 33 :nokey :heading 'gasin gasout scatter'); b34srun; /; /;GRAPH1 Illustrates More Complex Settings /; b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; call graph(gasin :heading 'No Spline setting'); call graph(gasin :heading 'Spline setting' :fitspline); g1=gasout - 5.; g2=g1 - 5.; g3=g2 - 5.; g4=g3 - 5.; g5=g4 - 5.; g6=g5 - 5.; call graph(gasout g1 g2 g3 g4 g5 g6 :pspaceon :heading 'Shows all types of linetype & Proportional' :linetype solid dotted dashed dotdash dotdotdash longshort short :nokey); call graph(gasout g2 g4 g6 :nokey :heading 'Places dots where points are - 1 1 3 14' :markpoint 1 1 3 14); call graph(gasout g2 g4 g6 :nokey :heading 'Places dots where points are - 1 1 4 111' :markpoint 1 1 4 111); call graph(gasout g2 g4 g6 :nokey :heading 'Places dots where points are - 1 1 4 116' :markpoint 1 1 4 116); call graph(gasout g2 g4 g6 :nokey :heading 'Places dots where points are - 1 1 4 120' :markpoint 1 1 4 120); b34srun$ /; /;GRAPH2 3-D Graphics Examples /; b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; call graph(lnq lnl lnk :heading 'RES72 Data - plottype contourc' :plottype contourc :angle 22.0 :rotation 180.); call graph(lnq lnl lnk :heading 'RES72 Data - plottype contour3' :plottype contour3 :angle 22.0 :rotation 25.); call graph(lnq lnl lnk :heading 'RES72 Data - plottype contourc' :plottype contourc :angle 10.0 :rotation 90. :htitle 1.5 1.5); call graph(lnq lnl lnk :heading 'RES72 Data - plottype contour3' :plottype contour3 :grid :d3axis :d3border :angle 22.0 :rotation 180.); call graph(lnq lnl lnk :heading 'RES72 Data - plottype stepped3d' :plottype stepped3d :grid :d3axis :d3border :angle 10.0 :rotation 70. :htitle 1.5 1.5); call graph(lnq lnl lnk :heading 'RES72 Data - plottype stepped3dc - Default box' :plottype stepped3dc :grid :d3axis :d3border :angle 22.0 :rotation 130.); call graph(lnq lnl lnk :heading 'RES72 Data - plottype stepped3dc grid=100' :box 100 :plottype stepped3dc :grid :d3axis :d3border :angle 22.0 :rotation 190.); call graph(lnq lnk :Heading 'RES72 Data - plottype xyplot' :plottype xyplot :grid :d3axis :d3border :angle 22.0 :rotation 190.); call graph(lnq lnl lnk :Heading 'RES72 Data - plottype xyzplot' :plottype xyzplot :grid :d3axis :d3border :angle 22.0 :rotation 180.); b34srun$ /; /;GRAPH3 Makes a file of a graph /; /$ File illustrates saving a graph b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; call graph(gasout gasin :htitle 1.5 1.5 :heading 'Illustrates making a Graph in a file' :file 'junk.wmf'); b34srun$ /; /;GRAPH4A View Matrix(100,100) in 3D /; b34sexec matrix; n=100; k=100; x=rn(matrix(n,k:)); call graph(x :plottype mesh :angle 10. :d3axis :d3border :heading 'This is the data'); call graph(x :plottype meshc :d3axis :d3border :heading 'The data as a surface'); x=transpose(x)*x; call graph(x :plottype mesh :d3axis :d3border :heading 'This is what transpose(x)*x is'); call graph(x :plottype meshc :d3axis :d3border :heading 'Transpose(x)*x in color!!'); call graph(x :plottype meshc :grid :d3axis :d3border :heading 'Transpose(x)*x in color with Grid'); call graph(x :plottype mesh :angle 10. :d3axis :d3border :heading 'Transpose(x)*x - angle 10.'); call graph(x :plottype meshc :angle 10. :d3axis :d3border :heading 'Transpose(x)*x - angle 10.'); call graph(x :plottype mesh :rotation 90. :d3axis :d3border :heading 'Transpose(x)*x rotation 90.'); call graph(x :plottype meshc :rotation 90. :grid :d3axis :d3border :heading 'Transpose(x)*x rotation 90.'); call graph(x :plottype meshstep :rotation 70. :angle 10. :grid :heading 'Transpose(x)*x rotation 70. meshstep'); call graph(x :plottype meshstepc :rotation 70. :angle 30. :grid :d3axis :heading 'Trans(x)*x rotation 70. meshstepc angle 30.'); call graph(x :plottype meshstepc :rotation 70. :angle 0. :grid :heading 'Trans(x)*x rotation 70. meshstepc angle 0.'); b34srun; /; /;GRAPH4B View Alternative size Materices /; b34sexec matrix; do i=2,6,2; n=50; x=rn(matrix(n,i:)); call graph(x :plottype mesh :angle 10. :d3axis :d3border :heading 'This is the data'); call graph(x :plottype meshc :d3axis :d3border :heading 'The data as a surface'); x=transpose(x)*x; call graph(x :plottype mesh :d3axis :d3border :heading 'This is what transpose(x)*x is'); call graph(x :plottype meshc :d3axis :d3border :heading 'Transpose(x)*x in color!!'); call graph(x :plottype meshc :grid :d3axis :d3border :heading 'Transpose(x)*x in color with Grid'); call graph(x :plottype mesh :angle 10. :d3axis :d3border :heading 'Transpose(x)*x - angle 10.'); call graph(x :plottype meshc :angle 10. :d3axis :d3border :heading 'Transpose(x)*x - angle 10.'); call graph(x :plottype mesh :rotation 90. :d3axis :d3border :heading 'Transpose(x)*x rotation 90.'); call graph(x :plottype meshc :rotation 90. :grid :d3axis :d3border :heading 'Transpose(x)*x rotation 90.'); call graph(x :plottype meshstep :rotation 70. :angle 10. :grid :heading 'Transpose(x)*x rotation 70. meshstep'); call graph(x :plottype meshstepc :rotation 70. :angle 30. :grid :d3axis :heading 'Trans(x)*x rotation 70. meshstepc angle 30.'); call graph(x :plottype meshstepc :rotation 70. :angle 0. :grid :heading 'Trans(x)*x rotation 70. meshstepc angle 0.'); enddo; b34srun; /; /;GRAPH5A View 3-D Matrix in a Volume Plot /; b34sexec options ginclude('b34sdata.mac') member(windvel); b34srun; b34sexec matrix; call loaddata; call graph(vel :Heading 'Data looked at as a 1-D array'); call graph(vel :plottype vol3d :d3axis :d3border :grid :angle 10. :dimension index(35,41,15) :heading 'Vol3d plot of Wind Vel.'); call graph(vel :plottype vol3d :d3axis :d3border :grid :angle 30. :scale :dimension index(35,41,15) :heading 'Vol3d plot of Wind Vel.' ); vel=vel+100.; call graph(vel :plottype vol3dc :d3axis :d3border :grid :scale :dimension index(35,41,15) :angle 10. :heading 'Vol3dc plot of Wind Vel.'); b34srun; /; /;GRAPH5B View Slices of 3-D Volume Plot /; b34sexec options ginclude('b34sdata.mac') member(windvel); b34srun; b34sexec matrix; call loaddata; call graph(vel :plottype vol3dc :d3axis :d3border :grid :scale :dimension index(35,41,15) :angle 10. :heading 'Vol3dc plot of Wind Vel.'); velhold=vel; nn=35*41; dd=missing(); do i=15,4,-1; iii=index(35,41,15:1,1,i); jj=integers(1,nn)+iii-1; vel(jj)=dd; call graph(vel :plottype vol3dc :d3axis :d3border :grid :scale :dimension index(35,41,15) :angle 20. :heading 'Vol3dc plot of Wind Vel Cut Away'); enddo; vel=velhold; * here we make box smaller ; do i=15,12,-1; vel2=velhold(integers(1,(35*41*i))); call graph(vel2 :plottype vol3dc :d3axis :d3border :grid :scale :dimension index(35,41,i) :angle 20. :rotation 0.0 :heading 'Vol3dc plot of Wind Vel.'); enddo; b34srun; /; /;GRAPH6 ACF / Overlay Plots /; b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; acf1=acf(gasout,24,se1,pacf1); call graph(acf1,pacf1 :nokey :heading 'ACF & PACF of Gasout'); call graph(acf(dif(gasout),24) :Heading 'ACF of Gasout(1-B)'); call graph(acf(dif(gasout,2,1),24) :heading 'ACF of Gasout(1-B)**2'); acf2=acf(gasin,24,se2,pacf2); call graph(acf2,pacf2 :nokey :heading 'ACF & PACF of Gasin'); call graph(acf1,SE1 :nokey :heading 'ACF and SE of ACF of Gasout'); i=integers(24); call tabulate(i,acf1,acf2,se1,se2,pacf1,pacf2); call print('ACF, SE, PACF, Modified Q Prob Q for gasin':); acf2=acf(gasin,24, se2,pacf2,mq2,pmq2); call tabulate(acf2,se2,pacf2,mq2,pmq2); call graph(acf2,pmq2); call graph(acf2 se2 :overlay acfplot /$ /$ Un comment next line to get a hard copy /$ :file 'testacf.wmf' :heading 'Overlay plot of ACF of gasin'); call graph(pacf2 se2 :overlay acfplot3d :heading '3D Overlay plot of PACF of gasin'); call graph(acf2 :overlay acfplot :heading 'Just plot of ACF of gasin'); call graph(gasin gasout :heading 'Scaled Plot of gasin gasout' :nokey :scale :plottype obsplot); n=400; rr=rn(array(n:)); acf1=acf(rr,24,se1); acf2=acf(dif(rr) ,24,se2); acf3=acf(dif(rr,2,1),24,se3); call graph(acf1,se1 :overlay acfplot :heading 'ACF of Random series'); call graph(acf2,se2 :overlay acfplot :heading 'ACF of rn(1-B)'); call graph(acf3,se3 :overlay acfplot :heading 'ACF of rn(1-B)**2'); b34srun$ /; /;GRAPH7 Illustrates fonts/Character Sets /; b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; call graph(gasout :heading 'This is the current default'); call graph(gasout :heading 'This is a standard.chr' :grcharset 'standard.chr'); call grcharset('H'); call graph(gasout :heading 'This is a test 1' :pspaceon :grcharfont 1 :file 't1.wmf'); call graph(gasout :heading 'This is a test 2' :grcharfont 2 :file 't2.wmf'); call graph(gasout :heading 'This is a test 3' :grcharfont 3 :file 't3.wmf'); call graph(gasout :heading 'This is a test 4' :grcharfont 4 :file 't4.wmf'); call graph(gasout :heading 'This is a test 5' :grcharfont 5 :file 't5.wmf'); call graph(gasout :heading 'This is a test 6' :grcharfont 6 :file 't6.wmf'); call graph(gasout :heading 'This is a test 7' :grcharfont 7 :file 't7.wmf'); call graph(gasout :heading 'This is a test 8' :grcharfont 8 :file 't8.wmf'); call graph(gasout :heading 'This is a test roman.chr' :grcharset 'roman.chr'); call graph(gasout :heading 'This is a test romanbld.chr' :grcharset 'romanbld.chr'); call graph(gasout :heading 'This is a test swiss.chr' :grcharset 'swiss.chr'); call graph(gasout :heading 'This is a test swissbld.chr' :grcharset 'swissbld.chr'); call graph(gasout :heading 'This is a test fixed.chr' :grcharset 'fixed.chr'); call graph(gasout :heading 'This is a test fixedbld.chr' :grcharset 'fixedbld.chr'); call graph(gasout :heading 'This is a test simplexr.chr' :grcharset 'simplexr.chr'); call graph(gasout :heading 'This is a test duplexr.chr' :grcharset 'duplexr.chr'); call graph(gasout :heading 'This is a test triplexr.chr' :grcharset 'triplexr.chr'); call graph(gasout :heading 'This is a test complexr.chr' :grcharset 'complexr.chr'); call graph(gasout :heading 'This is a test H' :grcharset 'H'); call graph(gasout :heading 'This is a test complexi.chr' :grcharset 'complexi.chr'); call graph(gasout :heading 'This is a test triplexi.chr' :grcharset 'triplexi.chr'); call graph(gasout :heading 'This is a test simplexs.chr' :grcharset 'simplexs.chr'); call graph(gasout :heading 'This is a test complexs.chr' :grcharset 'complexs.chr'); call graph(gasout :heading 'This is a test simplexg.chr' :grcharset 'simplexg.chr'); call graph(gasout :heading 'This is a test complexg.chr' :grcharset 'complexg.chr'); call graph(gasout :heading 'This is a test complexc.chr' :grcharset 'complexc.chr'); call graph(gasout :heading 'This is a test gothicen.chr' :grcharset 'gothicen.chr'); call graph(gasout :heading 'This is a test gothicit.chr' :grcharset 'gothicit.chr'); call grcharset(' '); b34srun; /; /;GRAPHP Graph Program Command /; b34sexec matrix; call grcharset('H'); y=rn(array(20:)); yhat=rn(array(4:)); error=dfloat(integers(4))/2.; se =error+yhat; se2 =yhat - error; call character(title,'Test Forecast Plot'); call load(forplot); call print(forplot); /$ Graph using graph call graph(y :pgborder :heading 'graph command' :htitle 2. 2. :pgxscaletop 'I' :pgyscaleleft 'NT' :pgyscaleright 'I' :colors black bred ); /$ Foreplot using graphp call forplot(y,yhat,se,se2,title,' '); b34srun; /$ /$ Here we add to the graph with the toolbox /$ b34sexec matrix; call graphp(:start); call graphp(:cont :grarea array(:0. 0. 1. 1.) :grunits array(:0. 0. 100. 100.) :pgarea array(:.1 .1 .9 .9) :pgunits array(:0. 0. 100. 100.) :color red :pgborder :charjustify l /$ :charrotate 60. /$ :chardirection v /$ xpos ypos in range 0. - 100. :charout array(:1. 60.) 'This is at 1. 60.' :grcharset 'fixedbld.chr' :charoutrel 'Line 2! at fixedbld.chr' :grcharset ' ' :charout array(:1. 30.) 'This is at 1. 30.' :color bblue :pginfo :graphpvocab :grfillpattern index( 1 1 1) :grrectangle array(: 50. 50. 60. 80.) :grtriangle array(:30. 30. 60. 80. 90. 10.) :toolbox ); call graphp(:final); b34srun; /; /;GRAPHP2 Tests Drawing /; /$ Can modify this code to pass data to graphp b34sexec matrix; call graphp(:start); call graphp(:cont :grarea array(:0. 0. 1. 1.) :grunits array(:0. 0. 1. 1.) :color red :toolbox ); call graphp(:final); b34srun; /; /;GRAPHTEST Full Test of Graph Options /; /$ Master Graph Test b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; i=integers(60); gasout=gasout(i); gasin=gasin(i); ccf1=ccf(gasin gasout,24); call graph(gasout,gasin); call graph(gasout,gasin:nokey :heading 'Nokey & grid option' :grid); call graph(gasout gasin :colors bblue bred bgreen); call graph(gasin); call graph(gasout:plottype hist2d :heading 'Hist2d Plot' :ylabelpos .5 :ylabelleft 'This is a special label - 1 2 3 4 5 6' 'C9'); call graph(gasout:plottype hist3d :heading 'Hist3d Plot' ); call graph(gasout:plottype hist3dc:heading 'Hist3dc Plot'); call graph(gasout:plottype bar2d :heading 'Bar2d Plot' :colors bred bgreen); call graph(gasout:plottype bar2dv :heading 'Bar2d Plot' :colors bred bgreen); call graph(gasout:plottype bar2dc :heading 'Bar2dc Plot'); call graph(gasout:plottype Bar3d :heading 'Bar3d Plot'); call graph(gasout:plottype Bar3dc :heading 'Bar3dc Plot'); call print(ccf1); call graph(ccf1 :plottype hist2d); call graph(ccf1 :heading 'CCF1 '); call names; ccf1=ccf(gasin,gasout,24,lags); ccf2=ccf(gasin,gasin ,24,lags); acf1=acf(gasin,24,se); call graph(acf1,se:heading 'ACF and SE'); call tabulate(ccf1,ccf2,acf1,lags); * special pie chart graph ; n=namelist(houston diana Will bobby); weight=vector(4:198,130,165,200); call tabulate(n weight); call names; call graph(weight,n :plottype pie :heading 'Family Weight'); b34srun$ /$ shows time plot b34sexec options ginclude('b34sdata.mac') member(res79); b34srun; b34sexec matrix; call loaddata; call names(all); year=getyear(bjulian_); call graph(year fms :plottype xyplot); b34srun; b34sexec matrix; /$ Problems in Economics 322 developed by Houston Stokes /$ TR-TC q=grid(0.,40.,.1); tr = 250.*q - 3.*q**2.; tc = 1500. + 50.*q + 2.*q**2.; profit=tr-tc; call graph(q,profit :plottype xyplot); call graph(q,tr,tc :plottype xyplot); call print(q,tr,tc); b34srun; b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; call graph(gasin :heading 'No Spline setting'); call graph(gasin :heading 'Spline setting' :fitspline); g1=gasout - 5.; g2=g1 - 5.; g3=g2 - 5.; g4=g3 - 5.; g5=g4 - 5.; g6=g5 - 5.; call graph(gasout g1 g2 g3 g4 g5 g6 :pspaceon :heading 'Shows all types of linetype & Proportional' :linetype solid dotted dashed dotdash dotdotdash longshort short :nokey); call graph(gasout g2 g4 g6 :nokey :heading 'Places dots where points are - 1 1 3 14' :markpoint 1 1 3 14); call graph(gasout g2 g4 g6 :nokey :heading 'Places dots where points are - 1 1 4 111' :markpoint 1 1 4 111); call graph(gasout g2 g4 g6 :nokey :heading 'Places dots where points are - 1 1 4 116' :markpoint 1 1 4 116); call graph(gasout g2 g4 g6 :nokey :heading 'Places dots where points are - 1 1 4 120' :markpoint 1 1 4 120); b34srun$ b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; call graph(lnq lnl lnk :heading 'RES72 Data - plottype contourc' :plottype contourc :angle 22.0 :rotation 180.); call graph(lnq lnl lnk :heading 'RES72 Data - plottype contour3' :plottype contour3 :angle 22.0 :rotation 25.); call graph(lnq lnl lnk :heading 'RES72 Data - plottype contourc' :plottype contourc :angle 10.0 :rotation 90. :htitle 1.5 1.5); call graph(lnq lnl lnk :heading 'RES72 Data - plottype contour3' :plottype contour3 :d3axis :d3border :angle 22.0 :rotation 180.); call graph(lnq lnl lnk :heading 'RES72 Data - plottype stepped3d' :plottype stepped3d :d3axis :d3border :angle 10.0 :rotation 70. :htitle 1.5 1.5); call graph(lnq lnl lnk :heading 'RES72 Data - plottype stepped3dc - Default box' :plottype stepped3dc :d3axis :d3border :angle 22.0 :rotation 130.); call graph(lnq lnl lnk :heading 'RES72 Data - plottype stepped3dc grid=100' :box 100 :plottype stepped3dc :d3axis :d3border :angle 22.0 :rotation 190.); call graph(lnq lnk :Heading 'RES72 Data - plottype xyplot' :plottype xyplot :d3axis :d3border :angle 22.0 :rotation 190.); call graph(lnq lnl lnk :Heading 'RES72 Data - plottype xyzplot' :plottype xyzplot :d3axis :d3border :angle 22.0 :rotation 180.); b34srun$ b34sexec matrix; n=100; k=20; x=rn(matrix(n,k:)); call graph(x :plottype mesh :angle 10. :d3axis :d3border :heading 'This is the data'); call graph(x :plottype meshc :heading 'The data as a surface'); x=transpose(x)*x; call graph(x :plottype mesh :heading 'This is what transpose(x)*x is'); call graph(x :plottype meshc :heading 'Transpose(x)*x in color!!'); call graph(x :plottype meshc :grid :heading 'Transpose(x)*x in color with Grid'); call graph(x :plottype mesh :angle 10. :heading 'Transpose(x)*x - angle 10.'); call graph(x :plottype meshc :angle 10. :heading 'Transpose(x)*x - angle 10.'); call graph(x :plottype mesh :rotation 90. :heading 'Transpose(x)*x rotation 90.'); call graph(x :plottype meshc :rotation 90. :grid :d3axis :d3border :heading 'Transpose(x)*x rotation 90.'); call graph(x :plottype meshstep :rotation 70. :angle 10. :grid :heading 'Transpose(x)*x rotation 70. meshstep'); call graph(x :plottype meshstepc :rotation 70. :angle 30. :grid :d3axis :heading 'Trans(x)*x rotation 70. meshstepc angle 30.'); call graph(x :plottype meshstepc :rotation 70. :angle 0. :grid :heading 'Trans(x)*x rotation 70. meshstepc angle 0.'); b34srun; b34sexec options ginclude('b34sdata.mac') member(windvel); b34srun; b34sexec matrix; call loaddata; call graph(vel :Heading 'Data looked at as a 1-D array'); call graph(vel :plottype vol3d :d3axis :d3border :grid :angle 10. :dimension index(35,41,15) :heading 'Vol3d plot of Wind Vel.'); call graph(vel :plottype vol3d :d3axis :d3border :grid :angle 30. :scale :dimension index(35,41,15) :heading 'Vol3d plot of Wind Vel.' ); vel=vel+100.; call graph(vel :plottype vol3dc :d3axis :d3border :grid :scale :dimension index(35,41,15) :angle 10. :heading 'Vol3dc plot of Wind Vel.'); b34srun; b34sexec options ginclude('b34sdata.mac') member(windvel); b34srun; b34sexec matrix; call loaddata; call graph(vel :plottype vol3dc :d3axis :d3border :grid :scale :dimension index(35,41,15) :angle 10. :heading 'Vol3dc plot of Wind Vel.'); velhold=vel; nn=35*41; dd=missing(); do i=15,4,-1; iii=index(35,41,15:1,1,i); jj=integers(1,nn)+iii-1; vel(jj)=dd; call graph(vel :plottype vol3dc :d3axis :d3border :grid :scale :dimension index(35,41,15) :angle 20. :heading 'Vol3dc plot of Wind Vel Cut Away'); enddo; vel=velhold; * here we make box smaller ; do i=15,12,-1; vel2=velhold(integers(1,(35*41*i))); call graph(vel2 :plottype vol3dc :d3axis :d3border :grid :scale :dimension index(35,41,i) :angle 20. :rotation 0.0 :heading 'Vol3dc plot of Wind Vel.'); enddo; b34srun; b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; acf1=acf(gasout,24,se1,pacf1); call graph(acf1,pacf1 :nokey :heading 'ACF & PACF of Gasout'); call graph(acf(dif(gasout),24) :Heading 'ACF of Gasout(1-B)'); call graph(acf(dif(gasout,2,1),24) :heading 'ACF of Gasout(1-B)**2'); acf2=acf(gasin,24,se2,pacf2); call graph(acf2,pacf2 :nokey :heading 'ACF & PACF of Gasin'); call graph(acf1,SE1 :nokey :heading 'ACF and SE of ACF of Gasout'); i=integers(24); call tabulate(i,acf1,acf2,se1,se2,pacf1,pacf2); call print('ACF, SE, PACF, Modified Q Prob Q for gasin':); acf2=acf(gasin,24, se2,pacf2,mq2,pmq2); call tabulate(acf2,se2,pacf2,mq2,pmq2); call graph(acf2,pmq2); call graph(acf2 se2 :overlay acfplot /$ /$ Un comment next line to get a hard copy /$ :file 'testacf.wmf' :heading 'Overlay plot of ACF of gasin'); call graph(pacf2 se2 :overlay acfplot3d :heading '3D Overlay plot of PACF of gasin'); call graph(acf2 :overlay acfplot :heading 'Just plot of ACF of gasin'); call graph(gasin gasout :heading 'Scaled Plot of gasin gasout' :nokey :scale :plottype obsplot); n=400; rr=rn(array(n:)); acf1=acf(rr,24,se1); acf2=acf(dif(rr) ,24,se2); acf3=acf(dif(rr,2,1),24,se3); call graph(acf1,se1 :overlay acfplot :heading 'ACF of Random series'); call graph(acf2,se2 :overlay acfplot :heading 'ACF of rn(1-B)'); call graph(acf3,se3 :overlay acfplot :heading 'ACF of rn(1-B)**2'); b34srun$ /; /;GRAPHTEST2 Advanced Graph Scale Tests /; /$ Master Graph Test for advanced features - Graphtest2 b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; i=integers(60); gasout=gasout(i); gasin=gasin(i); ccf1=ccf(gasin gasout,24); call graph(gasout,gasin :heading 'Base case'); call graph(gasout,gasin :heading 'Base case pgaxesxy 0. 20.' :pgaxesxy array(:0. 20.)); call graph(gasout,gasin :heading 'Base case with :pgborder' :pgborder); call graph(gasout,gasin :heading 'Base case with :pgborder xscaletop yscaleright' :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :pgborder); call graph(gasout,gasin :heading 'Base case with :pgborder' :pgborder); call graph(gasout,gasin :LINEWIDTH INDEX(2,2) :heading 'linewidth index(2,2)'); call graph(gasout,gasin :xscale array(:0.,20. 50.) :heading 'using xscale array(:0.,20. 50.)'); call graph(gasout,gasin :yscale array(:0.,25. 50.) :heading 'using yscale array(:0.,25. 50.)'); call graph(gasout,gasin :setxscale array(:0.,10.) :nxticks 5 :heading 'using setxscale 0. 10 nxticks 5'); call graph(gasout,gasin :setyscale array(:0.,10.) :nyticks 4 :heading 'using setyscale 0. 10 nyticks 4'); call graph(gasout,gasin :setxrange array(:0.,100.) :heading 'using setxrange 0. 100.'); call graph(gasout,gasin :setyrange array(:0.,100.) :heading 'using setyrange 0. 100.'); call graph(ccf1 :plottype hist2d :heading 'base case'); call graph(ccf1 :plottype hist2d :histscale index(4 8 12) :heading 'histscale index(4 8 12)'); call graph(ccf1 :plottype bar2d :heading 'base case'); call graph(ccf1 :plottype bar2d :barscale index(4 8 12) :heading 'barscale index(4 8 12)'); acf1=acf(gasout,24,se1,pacf1); acf2=acf(gasin,24, se2,pacf2,mq2,pmq2); call graph(acf2 se2 :overlay acfplot :heading 'base case'); call graph(acf2 se2 :overlay acfplot :heading 'Tests histscale index(4 8 12 16)' :histscale index(4 8 12 16) ); call graph(pacf2 se2 :overlay acfplot3d :heading '3D Overlay plot of PACF of gasin'); call graph(acf2 :overlay acfplot :heading 'Just plot of ACF of gasin'); call graph(acf2 :overlay acfplot :pgborder :heading 'Just plot of ACF of gasin with pgborder'); call graph(acf2 se2 :overlay acfplot :pgborder :pgxscaletop 'i' :pgyscaleright 'i' :heading 'ACF + se2 with pgborder and ticks') call graph(pacf2 se2 :overlay acfplot3d :histscale index(4 8 12 16) :heading '3D Overlay histscale index(4 8 12 16)'); call graph(acf2 :overlay acfplot :histscale index(4 8 12 16) :heading 'Just plot of ACF histscale index(4 8 12 16)'); call graph(gasin gasout :heading 'Scaled Plot of gasin gasout' :nokey :scale :plottype obsplot); n=400; rr=rn(array(n:)); acf1=acf(rr,24,se1); acf2=acf(dif(rr) ,24,se2); acf3=acf(dif(rr,2,1),24,se3); call graph(acf1,se1 :overlay acfplot :pgborder :pgxscaletop 'i' :pgyscaleright 'in' :heading 'ACF of Random series numbers on right'); call graph(acf2,se2 :overlay acfplot :pgborder :pgxscaletop 'i' :pgyscaleright 'i' :heading 'ACF of rn(1-B) ticks and border' ); call graph(acf3,se3 :overlay acfplot :pgxscaletop 'i' :pgyscaleright 'i' :heading 'ACF of rn(1-B)**2 no border but ticks'); b34srun$ b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; i=integers(60); gasout=gasout(i); gasin=gasin(i); ccf1=ccf(gasin gasout,24); call graph(gasout,gasin); call graph(gasout,gasin:nokey :heading 'Nokey option'); call graph(gasout gasin :colors bblue bred bgreen); call graph(gasin); call graph(gasout:plottype hist2d :heading 'Hist2d Plot' :ylabelpos .5 :ylabelleft 'This is a special label - 1 2 3 4 5 6' 'C9'); call graph(gasout:plottype hist3d :heading 'Hist3d Plot' ); call graph(gasout:plottype hist3dc:heading 'Hist3dc Plot'); call graph(gasout:plottype bar2d :heading 'Bar2d Plot' :colors bred bgreen); call graph(gasout:plottype bar2dv :heading 'Bar2d Plot' :colors bred bgreen); call graph(gasout:plottype bar2dc :heading 'Bar2dc Plot'); call graph(gasout:plottype Bar3d :heading 'Bar3d Plot'); call graph(gasout:plottype Bar3dc :heading 'Bar3dc Plot'); call print(ccf1); call graph(ccf1 :plottype hist2d); call graph(ccf1 :heading 'CCF1 '); call names; ccf1=ccf(gasin,gasout,24,lags); ccf2=ccf(gasin,gasin ,24,lags); acf1=acf(gasin,24,se); call graph(acf1,se:heading 'ACF and SE'); call tabulate(ccf1,ccf2,acf1,lags); * special pie chart graph ; n=namelist(houston diana Will bobby); weight=vector(4:198,130,165,200); call tabulate(n weight); call names; call graph(weight,n :plottype pie :heading 'Family Weight'); b34srun$ /$ shows time plot b34sexec options ginclude('b34sdata.mac') member(res79); b34srun; b34sexec matrix; call loaddata; call names(all); year=getyear(bjulian_); call graph(year fms :plottype xyplot); b34srun; /$ Shows xyplot and xyscatter and scatter b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; x=array(4:1 20 3 4); y=array(4:4 3 2 1); z=2.*x; call graph(x y z :plottype xyplot :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :pgborder :heading 'x y z using xyplot'); call graph(gasin,gasout :plottype xyscatter :markpoint 1 1 3 33 :nokey :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :pgborder :heading 'gasin gasout xyscatter'); call graph(gasin,gasout :plottype scatter :markpoint 1 1 3 33 :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :pgborder :nokey :heading 'gasin gasout scatter'); call graph(x y z :plottype xyplot :nocontact :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :pgborder :heading 'x y z using xyplot nocontact'); call graph(gasin,gasout :plottype xyscatter :nocontact :markpoint 1 1 3 33 :nokey :pgxscaletop 'I' :pgyscaleleft 'NI' :pgyscaleright 'NI' :nolabel :pgborder :heading 'gasin gasout xyscatter nocontact'); call graph(gasin,gasout :plottype scatter :nocontact :markpoint 1 1 3 33 :nokey :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :pgborder :heading 'gasin gasout scatter nocontact'); b34srun; /; /;GRAPHTEST4 + and - Graphs /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; yl=gasout-5.; yu=gasout+5.; call graph(gasout yl yu :heading 'Y +- 5.' ); call graph(gasout yl yu :plottype obsplotb :heading 'Y +- 5.' ); b34srun; /; /;GRCHARSET Reset Charset /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call grcharset('H'); call graph(gasout :heading 'This is a test 1'); call grcharset('triplexr.chr'); call graph(gasout :heading 'This is a test 2'); call grcharset(' '); b34srun; /; /;GRID Tests GRID command /; b34sexec matrix; g=grid(-2.0,2.0,.1); call print(g); ii=.1; x=grid(0.0, pi(),ii); call print(x,pi()); * 2 argument version ; x=grid(0.0, pi()); call print(x,pi()); b34srun$ /; /;GRREPLAY Replay Graph files /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call graph(gasout :file 'p1.hp1' :hardcopyfmt HP_GL2); call graph(gasin :file 'p2.hp1' :hardcopyfmt HP_GL2); call grreplay('p1.hp1','p2.hp1'); call grreplay('p1.hp1','p2.hp1' :file 'new.wmf' :hardcopyfmt wmf); call grreplay('new.wmf'); call grreplay('p1.hp1','p2.hp1' :file ' ' :hardcopyfmt wmf); b34srun; /; /;GRREPLAY_2 Replay Graph files using advanced commands /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call graph(gasout :file 'p1.hp1' :heading 'Gasout hp_GL2' :noshow :hardcopyfmt HP_GL2); call graph(gasin :file 'p2.hp1' :heading 'Gasin HP_GL2' :noshow :hardcopyfmt HP_GL2); call grreplay(:start); call grreplay(:cont 'p1.hp1' :gformat twograph 1); call grreplay(:cont 'p2.hp1' :gformat twograph 2); call grreplay(:final); b34srun; b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; call graph(lnq :heading 'Ln Q' :file 'plot1.wmf' :noshow); call graph(lnl :heading 'Ln L' :file 'plot2.wmf' :noshow); call graph(lnk :heading 'Ln k' :file 'plot3.wmf' :noshow); call graph(lnrm1 :heading 'Ln rm1' :file 'plot4.wmf' :noshow); call graph(lnrm2 :heading 'Ln rm2' :file 'plot5.wmf' :noshow); call graph(P :heading 'P ' :file 'plot6.wmf' :noshow); call graph(m1 :heading 'M1 ' :file 'plot7.wmf' :noshow); call graph(m2 :heading 'M2 ' :file 'plot8.wmf' :noshow); call graph(L :heading 'L ' :file 'plot9.wmf' :noshow); call grreplay(:start); call grreplay(:cont 'plot1.wmf' :gformat onegraph 1); call grreplay(:final); call grreplay(:start); call grreplay(:cont 'plot1.wmf' :gformat twograph 1); call grreplay(:cont 'plot2.wmf' :gformat twograph 2); call grreplay(:final); call grreplay(:start); call grreplay(:cont 'plot1.wmf' :gformat fourgraph 1); call grreplay(:cont 'plot2.wmf' :gformat fourgraph 2); call grreplay(:cont 'plot3.wmf' :gformat fourgraph 3); call grreplay(:cont 'plot4.wmf' :gformat fourgraph 4); call grreplay(:final); call grreplay(:start); call grreplay(:cont 'plot1.wmf' :gformat ninegraph 1); call grreplay(:cont 'plot2.wmf' :gformat ninegraph 2); call grreplay(:cont 'plot3.wmf' :gformat ninegraph 3); call grreplay(:cont 'plot4.wmf' :gformat twograph 2); call grreplay(:final); call grreplay(:start); call grreplay(:cont 'plot1.wmf' :gformat ninegraph 1); call grreplay(:cont 'plot2.wmf' :gformat ninegraph 2); call grreplay(:cont 'plot3.wmf' :gformat ninegraph 3); call grreplay(:cont 'plot4.wmf' :gformat ninegraph 4); call grreplay(:cont 'plot5.wmf' :gformat ninegraph 5); call grreplay(:cont 'plot6.wmf' :gformat ninegraph 6); call grreplay(:cont 'plot7.wmf' :gformat ninegraph 7); call grreplay(:cont 'plot8.wmf' :gformat ninegraph 8); call grreplay(:cont 'plot9.wmf' :gformat ninegraph 9); call grreplay(:final); call grreplay(:start); call grreplay(:cont 'plot1.wmf' :gformat onegraph 1 :zoom array(:.33333 .33333 .66666 .66666)); call grreplay(:final); call grreplay(:start); call grreplay(:cont 'plot1.wmf' :area array(:.33333 .33333 .66666 .66666) :zoom array(:.33333 .33333 .66666 .66666)); call grreplay(:final); b34srun; /; /;GR_TFLASH Tests for flash with hardcopy output /; b34sexec options ginclude('gas.b34'); b34srun; /$ Try to remove flash!!!! b34sexec matrix; call loaddata; do i=1,10; call graph(gasout :file 'p1.hp1' :noshow :hardcopyfmt HP_GL2); call graph(gasin :file 'p2.hp1' :noshow :hardcopyfmt HP_GL2); enddo; b34srun; /; /;GTEST Tests outfrom a ARCH / GARCH Model /; /$ /$ Joint GARCH Estimation using GARCHEST Subroutine /$ RATS used to test results. /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix ; call loaddata; call load(gtest); arch=array(norows(gasout):); call olsq(gasout gasout{1} gasout{2} :print); call print('RESVAR',%resvar :); call garchest(res,arch,gasout,func,2,n :cparms array(2:%coef(3), %resvar) :nar 2 :arparms array(2: %coef(1) %coef(2)) :ngar 1 :ngma 1 :gmaparms array(:.05) :print ); call tabulate(%resobs,res,arch); call gtest(res,arch,gasout,48); b34srun; /; /;GWRITE Saves Series in a GAUSS Format /; b34sexec matrix; call load(gwrite); call open(70,'testdata'); y=array(2,2:1 2 3 4); xx=rn(matrix(5,5:)); nn=namelist(y); call gwrite(y,nn,70); nn=namelist(xx); call gwrite(xx,nn,70); i=integers(1,23); ii=namelist(i); call gwrite(i,ii,70); call close(70); b34srun; /; /;GWRITE2 Passing large dataset to GAUSS in two files /; b34sexec matrix; /$ /$ User gives command gaussb testdata > jj.out /$ This sample job turns off the GAUSS run /$ call load(gwrite2); call open(70,'testdata'); x1=rn(array(10000:)); nn=namelist(x1); call gwrite2(x1,nn,70); yy=10. + x1 + 10.*rn(x1); nn=namelist(yy); call gwrite2(yy,nn,70); /$ Do an OLS Model in GAUSS call character(cc,'ols("",yy,x1);'); call write(cc,70); call close(70); /$ Run GAUSS and place output back in B34S /$ call system('gaussb testdata > jj.out'); b34srun; /$ b34sexec options npageout /$ writeout('Output from GAUSS',' ',' ') /$ copyfout('jj.out'); /$ b34srun; /; /;GWRITE_2 OLS In GAUSS from under B34S Matrix /; b34sexec matrix; /$ /$ User gives command gaussb testdata > jj.out /$ This sample job turns off the GAUSS run /$ call load(gwrite); call open(70,'testdata'); x1=rn(array(100:)); nn=namelist(x1); call gwrite(x1,nn,70); yy=10. + x1 + rn(x1); nn=namelist(yy); call gwrite(yy,nn,70); call character(cc,'ols("",yy,x1);'); call write(cc,70); call close(70); /$ call system('gaussb testdata > jj.out'); b34srun; /$ b34sexec options npageout /$ writeout('Output from GAUSS',' ',' ') /$ copyfout('jj.out'); /$ b34srun; /; /;HEXTOCH Illustrates Programming with HEXTOCH /; b34sexec matrix; /$ Illustrates Character Handeling and Hex Conversion; /$ Looking at Printable Characters ; i=integers(33,127); call igetchari(i,cc); call names(all); call tabulate(i,cc); call igetichar(cc,iitest); call chtohex(cc,hexcc); /$ Repack this character*2 array saved as character*1; /$ Next two statments work the same /$ hexcc2= array(norows(hexcc)/2,2:hexcc); hexcc2=c1array(norows(hexcc)/2,2:hexcc); hex1=hexcc2(,1); hex2=hexcc2(,2); call hextoch(hexcc,cctest); xx=transpose(hexcc2); call print(xx,hexcc2); call hextoch(xx,cctest2); call names(all); /$ get hexcc2 in a printable variable; blank=c1array(norows(hex1):); call names(all); c8var=catcol(hex1, hex2,blank,blank, blank, blank,blank,blank); call names(all); /$ call print(c8var); c8var=c8array(norows(c8var):transpose(c8var)); call tabulate(i,cc,iitest,hex1,hex2,cctest,cctest2,c8var); b34srun; /; /;HINICH82 Call Hinich82 => Hinich(82) Nonlinearity Test /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call hinich82(gasout,m,g,l:meanonly); call print('Mean Data for Hinich(82) Test on Gasout',g,l); m=17; call hinich82(gasout,m,g,l:setm); call print('Mean Data for Hinich(82) Test on Gasout M Set',m,g,l); call hinich82(gasout,m,g,l); call print('Hinich(82) Test on Gasout not Smoothed'); call tabulate(m,g,l); call hinich82(gasout,m,g,l:meanonly :smoothspec); call print('Mean Data for Hinich(82) Test on Gasout',g,l); m=16; call hinich82(gasout,m,g,l:setm :smoothspec); call print('Mean Data for Hinich(82) Test on Gasout Mean Set',g,l); call hinich82(gasout,m,g,l :smoothspec); call print('Hinich(82) Test on Gasout Smoothed'); call tabulate(m,g,l); b34srun; /$ This sections validates matrix Command B34SEXEC BJIDEN$ var =gasout $ seriesn var = gasout $ rauto gasout$ bispec iauto iturno vhtest $ B34SEEND$ B34SEXEC BJIDEN$ var =gasout $ seriesn var = gasout $ rauto gasout$ bispec iauto iturno vhtest ismoo$ B34SEEND$ /; /;HINICH82_1 Estimate Critical values for Hinich(1982) /; /$ /$ Break key allows termination between models. /$ Hit break key only once /$ /$ Job establishes critical values for Hinich (1982) /$ /$ Job illustrates how matrix command can be used to get /$ critical values of a test. If Setup with NCASE1=3000 => /$ over 24 hours on a 400 MH machine. 27,000,000 data points /$ are estimated and tested. 21,000 datasets are /$ generated. For each of the 21,000 21 Hinich bases are /$ investigated. Each daaset contains 2000 observations. /$ Progress in the analysis is monitored using outstring /$ and outinteger. The user can use the break key to /$ kill a model. /$ /$ Unless ncase1 is set to 10, the command call echooff /$ should not be removed. /$ /$ B34S workspace should be large when running this job. /$ b34sexec matrix ; call echooff; * ncase=3000; ncase = 10; n=2000; coef=array(7:-.9,-.6,-.3,0.0,.3,.6,.9); do j=1,7; l1 = array(ncase:); l7 = array(ncase:); l21= array(ncase:); l22= array(ncase:); call outstring(1,2,'Model '); call outinteger(12,2,j); do i=1,ncase; call outstring(1,4,'Ncase'); call outinteger(12,4,i); ar=coef(j); call free(ma); const=1.0; start=.1; wnv=1.0; nout=200; ar1=genarma(ar,ma,const,start,wnv,n,nout); call hinich82(ar1,m,g,l:smoothspec); * call print(l); l1(i) =l(1); l7(i) =l(7); l21(i)=l(21); l22(i)=l(22); enddo; * call print(l1,l7,l21,l22); q=array(4:.90,.95,.975,.99); call quantile(l1, q,value1); call quantile(l7, q,value7); call quantile(l21, q,value21); call quantile(l22, q,value22); Call Print('AR(1) Model at .90 .95 .975 .99 for ar =',coef(j)); call tabulate(q,value1,value7,value21,value22); call break('We are at the end of one model'); enddo; b34srun; /; /;HINICH96 Call Hinich96 => Hinich (96) Nonlinearity Test /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call echooff; call hinich96(gasout,0.0,V,H); call print('Mean Data for Hinich(96) Test on Gasout',V,H); c=grid(.2 .45,.02); v=array(norows(c):); h=array(norows(c):); do i=1,norows(c); call hinich96(gasout,c(i),vv,hh); v(i)=vv; h(i)=hh; enddo; call print('Hinich(96) Test on Gasout for various c values'); call tabulate(c,v,h); b34srun; /; /;HPFILTER Hodrick-Prescott Decomposition /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; s=1600.; call hpfilter(gasout,gast,gasdev,s); call graph(gasout,gast,gasdev); call hpfilter(gasout,gast2,gasdev2,0.0); call tabulate(gasout,gast,gasdev,gast2,gasdev2); b34srun; /; /;HP_2 Tests HP_2 Routine /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(hp_2); call print(hp_2); julian=array(norows(gasin):); nwindow=50; ncc=10; lamda=100.; series1=gasin; series2=gasout; call echooff; call hp_2(series1,series2,nwindow,ncc, lamda,cortrhp,cordevhp,var1trh,var2trh,var1devh,var2devh, corrmat1,corrmat2,corrmat3,corrmat4); call names; call graph(var1trh,var1devh); b34srun; /; /;HP_BP_1 HP_BP_1 Subroutine /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(hp_bp_1); call print(hp_bp_1); julian=array(norows(gasin):); series1=gasin; series1=gasout; call character(name,'Gasout Series'); call echooff; /$ HELP FILE ********************************************** /$ call hp_bp_1(julian,series,name,highfreq, /$ lowfreq,nterms,lamda, /$ printit,graphit,rjulian,rseries, /$ hptrend,hpdev,bptrend,bpdev); /$ /$ Performs Hodrick - Prescott and Baxter King Analysis /$ julian = Julian date. If not available pass series /$ of zero same length as series /$ series = Input series /$ name = Character object of name /$ highfreq = Barter-King High Freq (6) /$ lowfreq = Baxter-King Low Freq (32) /$ nterms = # of terms for Baxter - King /$ lamda = Hodrick-Prescott Lamda /$ printit = 0 => nothing, ne 0 => print /$ graphit = 0 => nothing, ne 0 => graph /$ rjulian = Revised julian /$ rseries = Revised series /$ hptrend = Hodrick-Prescott trend /$ hpdev = Hodrick-Prescott dev /$ bptrend = Baxter-King trend /$ bpdev = Baxter-King dev /$ /$ ***************************************************** highf=6.; lowf=32.; nterms=10; lamda=1600.; printit=1; graphit=1; call hp_bp_1(julian,series1,name,highf,lowf,nterms, lamda,printit,graphit,rjulian,rseries, hptrend,hpdev,bptrend,bpdev); call names; b34srun; /; /;HP_BP_2 Moving HP and BK Filtering Routine /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(hp_bp_2); call print(hp_bp_2); julian=array(norows(gasin):); nwindow=50; ncc=10; lamda=1600.; highfreq=6.; lowfreq=32.; nterms=20; series1=gasin; series2=gasout; call echooff; /$ call hp_bp_2(julian,series1,series2,nwindow,ncc, /$ highfreq,lowfreq,nterms,lamda,njulian, /$ cortrhp,cordevhp,cortrbp,cordevbp, /$ var1trh,var2trh,var1devh,var2devh, /$ var1trb,var2trb,var1devb,var2devb, /$ corrmat1,corrmat2,corrmat3,corrmat4); /$ /$ Performs Hodrick - Prescott and Baxter King Analysis on two series /$ for a moving period /$ /$ Since both Hodrick - Prescott and Baxter - King analysis is done, /$ the estimated Hodrick - Prescott Series are truncated BEFORE /$ variances and correlations are calculated /$ /$ julian = Julian date. If not available pass series /$ of zero same length as series /$ series1 = Input series /$ series2 = Input series /$ nwindow = number in window /$ ncc = # of lags for cross correlations /$ highfreq = Barter-King High Freq (6.) /$ lowfreq = Baxter-King Low Freq (32.) /$ nterms = # of terms for Baxter - King /$ lamda = Hodrick-Prescott Lamda 1600. /$ njulian = Revised julian vector /$ cortrhp = Correlation of trend HP data /$ cordevhp = Correlation of dev HP data /$ cortrbp = Correlation of trend BP data /$ cordevbp = Correlation of dev BP data /$ var1trh = Variance of series 1 trend HP data /$ var2trh = Variance of series 2 trend HP data /$ var1devh = Variance of series 1 dev HP data /$ var2devh = Variance of series 2 dev HP data /$ var1trb = Variance of series 1 trend BP data /$ var2trb = Variance of series 2 trend BP data /$ var1devb = Variance of series 1 dev BP data /$ var2devb = Variance of series 2 dev BP data /$ corrmat1 = Correlation matrix for trend HP data /$ corrmat2 = Correlation matrix for dev HP data /$ corrmat3 = Correlation matrix for trend BP data /$ corrmat4 = Correlation matrix for dev BP data /$ call hp_bp_2(julian,series1,series2,nwindow,ncc, highfreq,lowfreq,nterms,lamda,njulian, cortrhp,cordevhp,cortrbp,cordevbp, var1trh,var2trh,var1devh,var2devh, var1trb,var2trb,var1devb,var2devb, corrmat1,corrmat2,corrmat3,corrmat4); call names; call graph(var1trh,var1devh :Heading 'Variance of trend and Dev HP Series 1'); call graph(var1trb,var1devb :Heading 'Variance of trend and Dev BK Series 1'); call graph(var2trh,var2devh :Heading 'Variance of trend and Dev HP Series 2'); call graph(var2trb,var2devb :Heading 'Variance of trend and Dev BK Series 2'); b34srun; /; /;HUGE Largest number of type /; b34sexec matrix; i=1; x=1.; y=sngl(x); call print('Largest integer ',huge(i):); call print('Largest real*4 ',huge(y):); call print('Largest real*8 ',huge(x):); call print('Smallest real*4 ',tiny(y):); call print('Smallest real*8 ',tiny(x):); call print('Epsilon real*4 ',epsilon(y):); call print('Epsilon real*8 ',epsilon(x):); x=.1d+00; y=sngl(x); j=1; call echooff; do i=1,1000,100; x=x*dfloat(i); y=float(i)*y ; spx(j)=spacing(x); spy(j)=spacing(y); nearpr8(j)=nearest(x, 1.); nearmr8(j)=nearest(x,-1.); nearpr4(j)=nearest(y, 1.); nearmr4(j)=nearest(y,-1.); testnum(j)=x; j=j+1; enddo; call print('Spacing for Real*8 and Real*4'); call tabulate(testnum,spx,spy,nearpr8,nearmr8,nearpr4,nearmr4); call names(all); call graph(testnum,spx :plottype xyplot :heading 'Spacing'); b34srun; /; /;HYPDF Evaluate Hypergeometric Distribution Function /; b34sexec matrix; k=7; n=100; m=70; l=1000; pr=hypdf(k,n,m,l); call print('Evaluate Hypergeometric Distribution Function ':); call print('Probability that X is LE 7 = ',pr:); Call print('Note: Answer should be .5995':); b34srun; /; /;HYPPR Evaluate Hypergeometric Probability Function /; b34sexec matrix; k=7; n=100; m=70; l=1000; pr=hyppr(k,n,m,l); call print('Evaluate Hypergeometric Probability Function':); call print('Probability that X is 7 = ',pr:); Call print('Note: Answer should be .1628':); b34srun; /; /;IALEN Actual length of a string /; b34sexec matrix; call character(cc,'This ends at 15 '); call ialen(cc,ipos); call print('Should be 15',ipos); b34srun; /; /;IB34S11 Tokenize a string /; /; b34sexec matrix; call character(cc,'10. 11 test y(10) jj=44 print'); ibase=1; call echooff; do j=1,100; imax=0; call ib34s11(cc,ibase,ifbase,isize,itokty,inewp,imax); if(isize.eq.0)go to finish; call print('ifbase found ',ifbase :line); call print('Size of token found ',isize :line); call print('Type of token found ',itokty :line); call print('inewp of token found ',inewp :line); i=integers(ifbase,ifbase+isize-1); find=cc(i); call character(tt,'Token found was: '); call expand(tt,find,20,(20+isize)); call print(tt :line); call print(' ' :line); ibase=inewp; if(inewp.eq.-99)go to finish; enddo; finish continue; call print('All done tokenizing'); b34srun; /; /;IBFCLOSE Close a file open for binary I/O /; b34sexec matrix; call ibfopen('test.ff',writeonly,ihandle); x=array(5:1 2 3 4 5); call print(x); call ibfwriter(ihandle,x,norows(x)*8,iwrite); call ifilesize(' ','test.ff',isize); call print('isize was ',isize); call ibfclose(ihandle); call dodos('erase test.ff'); call dounix('rm test.ff'); b34srun; /; /;IBFOPEN Open a file for binary I/O /; b34sexec matrix; call ibfopen('test.ff',writeonly,ihandle); r=rn(array(10:)); call print(r); call ibfwriter(ihandle,r,norows(r)*8,iwrite); call ifilesize(' ','test.ff',isize); call print('isize was ',isize); call ibfclose(ihandle); call dodos('erase test.ff'); call dounix('rm test.ff'); b34srun; /; /;IBFREADC Read Character Data from Binary File /; b34sexec matrix; /$ /$ Tests both Character and real reading and writting /$ call ibfopen('test.ff',writeonly,ihandle); x=rn(array(10:)); j=norows(x)*8; call ibfwriter(ihandle,x,j,iwrite); call print('Number of bites written ',iwrite); call names(all); call ibfclose(ihandle); call ifilesize(' ','test.ff',isize); call print('The file size for test.ff is ',isize); xnew=array((isize/8)+1:); call ibfopen('test.ff',readonly,ihandle); ipos=0; call ibfseek(ihandle,ipos,fromstart); call ibfreadr(ihandle,xnew,isize,ii); call tabulate(x,xnew); call ibfclose(ihandle); /$ /$ Character Tests /$ call ibfopen('test.cff',writeonly,ihandle); call character(x,'abcdefghi'); j=norows(x); call ibfwritec(ihandle,x,j,iwrite); call print('Number of bites written ',iwrite); call names(all); call ibfclose(ihandle); call ifilesize(' ','test.cff',isize); call print('The file size for test.cff is ',isize); xnew=rtoch(array((isize/8)+1:)); call character(cnew,xnew); call ibfopen('test.cff',readonly,ihandle); ipos=0; call ibfseek(ihandle,ipos,fromstart); call names(all); call print(cnew); call ibfreadc(ihandle,cnew,isize,ii); call print(x,cnew); call ibfclose(ihandle); call dodos('erase test.ff'); call dounix('rm test.ff'); b34srun; /; /;IBFREADR Read Real Data from Binary File /; b34sexec matrix; /$ /$ Tests both Character and real reading and writting /$ call ibfopen('test.ff',writeonly,ihandle); x=rn(array(10:)); j=norows(x)*8; call ibfwriter(ihandle,x,j,iwrite); call print('Number of bites written ',iwrite); call names(all); call ibfclose(ihandle); call ifilesize(' ','test.ff',isize); call print('The file size for test.ff is ',isize); xnew=array((isize/8)+1:); call ibfopen('test.ff',readonly,ihandle); ipos=0; call ibfseek(ihandle,ipos,fromstart); call ibfreadr(ihandle,xnew,isize,ii); call tabulate(x,xnew); call ibfclose(ihandle); /$ /$ Character Tests /$ call ibfopen('test.cff',writeonly,ihandle); call character(x,'abcdefghi'); j=norows(x); call ibfwritec(ihandle,x,j,iwrite); call print('Number of bites written ',iwrite); call names(all); call ibfclose(ihandle); call ifilesize(' ','test.cff',isize); call print('The file size for test.cff is ',isize); xnew=rtoch(array((isize/8)+1:)); call character(cnew,xnew); call ibfopen('test.cff',readonly,ihandle); ipos=0; call ibfseek(ihandle,ipos,fromstart); call names(all); call print(cnew); call ibfreadc(ihandle,cnew,isize,ii); call print(x,cnew); call ibfclose(ihandle); call dodos('erase test.ff'); call dounix('rm test.ff'); b34srun; /; /;IBFSEEK Position to read /; b34sexec matrix; call ibfopen('test.ff',READWRITE,ihandle); x=rn(array(10:)); call ibfwriter(ihandle,x,norows(x)*8,iwrite); call ifilesize(' ','test.ff',isize); xnew=array(isize/8:); ipos=0; call ibfseek(ihandle,ipos,fromstart); call ibfreadr(ihandle,xnew,isize,ii); call tabulate(x,xnew); call ibfclose(ihandle); call dodos('erase test.ff'); call dounix('rm test.ff'); b34srun; /; /;IBFWRITEC Write Character Data to a Binary File /; b34sexec matrix; /$ /$ Tests both Character and real reading and writting /$ call ibfopen('test.ff',writeonly,ihandle); x=rn(array(10:)); j=norows(x)*8; call ibfwriter(ihandle,x,j,iwrite); call print('Number of bites written ',iwrite); call names(all); call ibfclose(ihandle); call ifilesize(' ','test.ff',isize); call print('The file size for test.ff is ',isize); xnew=array(isize/8:); call ibfopen('test.ff',readonly,ihandle); ipos=0; call ibfseek(ihandle,ipos,fromstart); call ibfreadr(ihandle,xnew,isize,ii); call tabulate(x,xnew); call ibfclose(ihandle); /$ /$ Character Tests /$ call ibfopen('test.cff',writeonly,ihandle); call character(x,'abcdefghi'); j=norows(x); call ibfwritec(ihandle,x,j,iwrite); call print('Number of bites written ',iwrite); call names(all); call ibfclose(ihandle); call ifilesize(' ','test.cff',isize); call print('The file size for test.cff is ',isize); xnew=rtoch(array(isize:)); call character(cnew,xnew); call ibfopen('test.cff',readonly,ihandle); ipos=0; call ibfseek(ihandle,ipos,fromstart); call names(all); call print(cnew); call ibfreadc(ihandle,cnew,isize,ii); call print(x,cnew); call ibfclose(ihandle); call dodos('erase test.ff'); call dounix('rm test.ff'); b34srun; /; /;IBFWRITER Write Real Data to a Binary File /; b34sexec matrix; /$ /$ Tests both Character and real reading and writting /$ call ibfopen('test.ff',writeonly,ihandle); x=rn(array(10:)); j=norows(x)*8; call ibfwriter(ihandle,x,j,iwrite); call print('Number of bites written ',iwrite); call names(all); call ibfclose(ihandle); call ifilesize(' ','test.ff',isize); call print('The file size for test.ff is ',isize); xnew=array(isize/8:); call ibfopen('test.ff',readonly,ihandle); ipos=0; call ibfseek(ihandle,ipos,fromstart); call ibfreadr(ihandle,xnew,isize,ii); call tabulate(x,xnew); call ibfclose(ihandle); /$ /$ Character Tests /$ call ibfopen('test.cff',writeonly,ihandle); call character(x,'abcdefghi'); j=norows(x); call ibfwritec(ihandle,x,j,iwrite); call print('Number of bites written ',iwrite); call names(all); call ibfclose(ihandle); call ifilesize(' ','test.cff',isize); call print('The file size for test.cff is ',isize); xnew=rtoch(array(isize:)); call character(cnew,xnew); call ibfopen('test.cff',readonly,ihandle); ipos=0; call ibfseek(ihandle,ipos,fromstart); call names(all); call print(cnew); call ibfreadc(ihandle,cnew,isize,ii); call print(x,cnew); call ibfclose(ihandle); call dodos('erase test.ff'); call dounix('rm test.ff'); b34srun; /; /;ICOLOR Gets Color integer value /; b34sexec matrix; call print(icolor(red)); call print(icolor(green)); call print(icolor(blue)); b34srun; /; /;IDINT idint function => Convert real*8 to integer /; b34sexec matrix; x=grid(1.,10.,1.); call print('A real* array',x); ix=idint(x); call print('An integer array',ix); x=rn(matrix(5,5:)) + 20.; ix=idint(x); call print(x,ix); b34seend; /; /;IDNINT idnint function => Convert Rounded real*8 to integer /; b34sexec matrix; x=grid(1.,10.,.1); ix=idint(x); ix2=idnint(x); call print('x = real*8, ix idint, ix2=idnint'); call tabulate(x,ix,ix2); b34seend; /; %b34sendif; %b34sif(&test3.eq.1)%then; /;IFILESIZE Gets File Size /; b34sexec matrix; call ifilesize('c:\b34slm','gas.b34',isize); call print(isize); b34srun; /; /;IFILLSTR Fill a string /; b34sexec matrix; call character(cc,'This is a string'); newcc=cc; call ifillstr(newcc,'a'); call print(cc,newcc); b34srun; /; /;IF_TEST IF Test Cases /; b34sexec matrix; * Simple do loop; do i=1,10; call print('This is in the simple loop',i); if(i.ge.2.and.i.lt.6)then; call print('I is ge 2 and lt 6'); endif; if(i.ne.9)call print('I was not = 9 in this pass'); if(i.eq.9)call print('I was 9 in this pass'); enddo; call print('All Done'); b34srun; /$ More complex Cases b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; if(sfam(lnq(1)) .ne. sfam(lnq(2)))jj=10; if(sfam(lnq(1)) .eq. sfam(lnq(1)))then; call print('test case 1',lnq(1)); endif; s=sfam(lnq(1)); if(s.ne.1.0)call print('simple test'); if(sfam(lnq(1)) .eq. sfam(lnq(1))) call print('test case 2',lnq(1)); if(lnq(1).ne.0.0)lnq(1)=-9999.; call print(lnq); b34srun; /; /;IGETCHARI From Integer get char value /; b34sexec matrix; call character(astring,'ABCDEFG'); call igetichar(astring,ichar); ichar2=ichar+1; call igetchari(ichar2,newstr); call print(astring,ichar,ichar2,newstr); b34srun; /; /;IGETICHAR Get ICHAR value from string /; b34sexec matrix; call character(astring,'ABCDEFG'); call igetichar(astring,ichar); ichar2=ichar+1; call igetchari(ichar2,newstr); call print(astring,ichar,ichar2,newstr); b34srun; /; /;IJUSTSTR Left/Center/Right a String /; b34sexec matrix; call character(c,'This is a statement '); leftc=c; centerc=c; rightc=c; call ijuststr(leftc, left); call ijuststr(centerc,center); call ijuststr(rightc, right); call print(c,leftc,centerc,rightc); b34srun; /; /;ILCOPY Byte Copy Command /; b34sexec matrix; call character(cc,'This is a test'); call displayb(cc); call character(cc2,'This is a test with numbers 1 2 3 # $ % 7 && 8 &'); call displayb(cc2); * Put in reals we know what they are; x=array(20:integers(20)); call print(x); call displayb(x); x(1)=0.0; x(2)=1.0; * Hide an integer in a real; call displayb(x); i1=1; i2=2; call ilcopy(4,i1,1,1,x,1,1); call ilcopy(4,i2,1,1,x,1,5); call displayb(x); b34srun; /; /;ILOCATESTR Locate a string within an array /; b34sexec matrix; call character(cc,' in5to11 '); call ilocatestr(cc,in,iout); call print(cc,in,iout); b34srun; /; /;ILOWER Lower case a string /; b34sexec matrix; call character(cc,'THIS IS UPPER'); lower=cc; call ilower(lower); upper=lower; call iupper(upper); call print(cc,lower,upper); b34srun; /; /;IMATRIX Shell called by IntMatrix button for Display Manager /; /$ This shell can be modified to load data set if desired b34sexec matrix; call manual; b34srun; /; /;INDEX Define Integer vector /; b34sexec matrix; xx=index(1,2,3,4,5,4,3); call names(all); call print(xx); call print('Integer*4 Array ',index(1 2 3 4 5 4 3)); call print('# elements in 1 2 3 4 is 24',index(2 3 4:)); call print('Position of 1 2 in a 4 by 4 is 5',index(4 4:1 2):); call print('Integer*4 Array ',index(1,2,3,4,5 4 3)); call print('# elements in 1 2 3 5 is 30',index(2,3,5:)); call print('Position of 1 3 in a 4 by 4 is 9',index(4,4:1,3):); * bigger example showing large matrix; maxsize=index(4,5,6:); xbig =array(maxsize:integers(maxsize)); call print(xbig); ii2 =index(4,5,6:1 1 2); subx=xbig(integers(ii2,ii2+20-1)); call print(subx); b34srun; /; /;INEXTI4 Get next Int /; b34sexec matrix; call character(cc,'2.3 5. 99 Bob'); call print(cc); call inextr8(cc,r8); call print(cc); call inextr4(cc,r4); call print(cc); call inexti4(cc,i4); call print(cc); call inextstr(cc,ss,ihave); call print(cc,ss); call inextstr(cc,ss2,ihave2); call print(r8,r4,i4,ss,ihave,ihave2); b34srun; /; /;INEXTR4 Get next real*4 /; b34sexec matrix; call character(cc,'2.3 5. 99 Bob'); call print(cc); call inextr8(cc,r8); call print(cc); call inextr4(cc,r4); call print(cc); call inexti4(cc,i4); call print(cc); call inextstr(cc,ss,ihave); call print(cc,ss); call inextstr(cc,ss2,ihave2); call print(r8,r4,i4,ss,ihave,ihave2); b34srun; /; /;INEXTR8 Get next real*8 /; b34sexec matrix; call character(cc,'2.3 5. 99 Bob'); call print(cc); call inextr8(cc,r8); call print(cc); call inextr4(cc,r4); call print(cc); call inexti4(cc,i4); call print(cc); call inextstr(cc,ss,ihave); call print(cc,ss); call inextstr(cc,ss2,ihave2); call print(r8,r4,i4,ss,ihave,ihave2); b34srun; /; /;INEXTSTR Get next string /; b34sexec matrix; call character(cc,'2.3 5. 99 Bob'); call print(cc); call inextr8(cc,r8); call print(cc); call inextr4(cc,r4); call print(cc); call inexti4(cc,i4); call print(cc); call inextstr(cc,ss,ihave); call print(cc,ss); call inextstr(cc,ss2,ihave2); call print(r8,r4,i4,ss,ihave,ihave2); b34srun; /; /;INFOGRAPH Graphics info /; b34sexec matrix; r=array(14:); ii=integers(14); do i=1,14; r(i)=infograph(i); enddo; call tabulate(ii,r); b34srun; /; /;INLINE Inline creatioon of a Program /; /$ Shows two ways to create a program /$ Note that the program copy places program at level 100 /$ /$ Default name %INLINE_ if no : found /$ /$ second job uses inline model specification for maxf2 b34sexec matrix; call testarg('x=10;','y=10.+15.9*sin(yy);':test); /$ Note we have to use the same name !!!!!!! funny2=inline('x=10;','y=10.+15.9*sin(yy);':funny2); program funny; x=10.; call print(x); return; end; funny3=inline('x=10;','y=10.+15.9*sin(yy);'); call print('FUNNY3 hides %INLINE_'); call print(funny,funny2,funny3); call names(all); b34srun; /$ MAXF2 is used to minimize a function /$ Answers should be x1=.9999 and x2=.9999 b34sexec matrix; * Problem is classic Rosenbrock banana problem. ; * Problem used as a test case in IMSL and in MATLAB fmins function ; call echooff; call maxf2(func :name inline('func=-1.0*(100.*(x2-x1*x1)**2. + (1.-x1)**2.);') :parms x1 x2 :ivalue array(2:-1.2,1.0) :print); b34srun; /; /;INT Converts real*4 to integer /; b34sexec matrix; r8g=grid(.1,6.,.3) ; i=integers(norows(r8g)); r4i= float(i) ; r8i=dfloat(i) ; i4idint=idint(r8g) ; i4idnint=idnint(r8g) ; i4fromr4=int(r4i) ; r8dint=dint(r8g) ; call names(all) ; call tabulate(i,r4i,r8i,r8g,i4idint,i4idnint,i4fromr4 r8dint); b34srun; /; /;INTEGERS INTEGERS function => Generate a vector of integers /; b34sexec matrix; i1=integers(24); i2=integers(2,26); i3=integers(0,30); call tabulate(i1,i2,i3); b34srun$ /; /;INTEGERS Illustrates INTEGER command /; b34sexec matrix; call print(integers(10)); call print(integers(0,30,3)); b34srun; /; /;INTTOSTR Integer to String /; b34sexec matrix; call inttostr(88,is88,'(i4)'); call character(cc,'99.88D32'); call istrtor8(cc,bigr8); call character(cc,'77'); call istrtoint(cc,is77); xx=99.99; call ir8tostr(xx,is99p99,'(g12.4)'); call print(is88,bigr8,is77,is99p99); b34srun; /; /;INV Inv function => calculate inverse /; /$ This job does not print very much n can be increased /$ at "change this n" to test accuracy of LINPACK vs LAPACK!! b34sexec matrix; * Small sample ; n=4; x=rec(matrix(n,n:)); t1=(1.0/x); t2=inv(x); test1=x*t1; test2=x*t2; if(n.le.5)then; call print(x,t1,t2,x*t1); call print(x*inv(x),x*inv(x:refine),x*inv(x:refinee)); endif; if(n.le.5)then; cx=complex(x,2.*x); ct1=(complex(1.0,0.0)/cx); ct2=inv(cx); ctest1=cx*ct1; ctest2=cx*ct2; call print(ct1,ct2,ctest1,ctest2); call print(cx*inv(cx),cx*inv(cx:refine),cx*inv(cx:refinee)); endif; * change this n ; call echooff; n=100; x=rec(matrix(n,n:)); x(1,)=x(1,)*10000.; t1=(1.0/x); t2=inv(x); test1=x*t1; test2=x*t2; if(n.le.5)then; call print(x,t1,t2,x*t1); endif; call echooff; call print('Order of system ',n:); call print('LINPACK for T1':); call print('LINPACK for T2':); call print('dmax( (matrix(n,n:)+1.)- (x*t1) )', dmax( (matrix(n,n:)+1.) - (x*t1) ):); call print('dmax( (matrix(n,n:)+1.)- (x*t2) )' dmax( (matrix(n,n:)+1.)- (x*t2) ):); call print('sumsq((matrix(n,n:)+1.)- (x*t1) )' sumsq((matrix(n,n:)+1.) - (x*t1) ):); call print('sumsq((matrix(n,n:)+1.)- (x*t2) )' sumsq((matrix(n,n:)+1.)- (x*t2) ):); t2=inv(x:gmat); test2=x*t2; call print('LAPACK for T2':); call print('dmax( (matrix(n,n:)+1.)- (x*t2) )' dmax( (matrix(n,n:)+1.)- (x*t2) ):); call print('sumsq((matrix(n,n:)+1.)- (x*t2) )' sumsq((matrix(n,n:)+1.)- (x*t2) ):); t2=inv(x:refine); test2=x*t2; call print('LAPACK refine for T2':); call print('dmax( (matrix(n,n:)+1.)- (x*t2) )' dmax( (matrix(n,n:)+1.)- (x*t2) ):); call print('sumsq((matrix(n,n:)+1.)- (x*t2) )' sumsq((matrix(n,n:)+1.)- (x*t2) ):); t2=inv(x:refinee); test2=x*t2; call print('LAPACK refinee for T2':); call print('dmax( (matrix(n,n:)+1.)- (x*t2) )' dmax( (matrix(n,n:)+1.)- (x*t2) ):); call print('sumsq((matrix(n,n:)+1.)- (x*t2) )' sumsq((matrix(n,n:)+1.)- (x*t2) ):); b34srun; /; /;INV2 Simple Inversion test with Printing /; /$ Job illustrates inverse of PDMATRIX 6 ways /$ gminv uses LAPACK /$ pdmac uses LINPACK /$ pdmac2 uses LAPACK /$ b34sexec matrix; n=4; x=rn(matrix(n,n:)); x=transpose(x)*x; t1=(1.0/x); t2=inv(x); test1=x*t1; test2=x*t2; call gminv(x,t3); cx=mfam(complex(afam(x),dsqrt(dabs(afam(x))))); scx=transpose(cx)*cx; cx=dconj(transpose(cx))*cx; ct1=(complex(1.0,0.0)/cx); ct2=inv(cx); call gminv(cx,ct3); ctest1=cx*ct1; ctest2=cx*ct2; ctest3=cx*ct3; call print(x,t1,t2,t3,cx,ct1,ct2,ct3,ctest1,ctest2,ctest3); t2a=inv(x:smat); t2b=inv(x:pdmat); t2c=inv(x:pdmat2); call print(t1,t2,t3,t2a,t2b, t2c); ct2a=inv(scx:smat); tct2a=complex(1.0,0.0)/scx; ct2b=inv(cx:pdmat); ct2c=inv(cx:pdmat2); call print(cx,ct1,ct2,ct3,ct2b,ct2c); call print('Note that Complex Symmetric matrix NE PD Complex'); call print(scx,ct2a,tct2a); b34srun; /; /;INV3 LAPACK vs LINPACK /; b34sexec matrix; call echooff; * above 5 only tests max difference; n=5; x=rn(matrix(n,n:)); * Play with this parameter; x(,1)=x(,1)*100000000.; test1=inv(x); test2=inv(x:refine); test3=inv(x:refinee); dd=matrix(n,n:)+1.; call print('Rank of matrix was ',n:); if(n.le.5)call print(x,test1,test2,test3); call print('Error of LINPACK ',sumsq((test1*x)-dd):); call print('Error of LAPACK REFINE ',sumsq((test2*x)-dd):); call print('Error of LAPACK REFINEE ',sumsq((test3*x)-dd):); call free(dd,test1,test2,test3); cx =complex(x,2.*x); cdd=complex(matrix(n,n:),matrix(n,n:)) + complex(1.,0.0); ctest1=inv(cx); ctest2=inv(cx:refine); ctest3=inv(cx:refinee); if(n.le.5)call print(cx,ctest1,ctest2,ctest3); call print('Real Error LINPACK ',sumsq(real((ctest1*cx)-cdd)):); call print('Real Error LAPACK REFINE ',sumsq(real((ctest2*cx)-cdd)):); call print('Real Error LAPACK REFINEE',sumsq(real((ctest3*cx)-cdd)):); call print('Imag Error LINPACK ',sumsq(imag((ctest1*cx)-cdd)):); call print('Imag Error LAPACK REFINE ',sumsq(imag((ctest2*cx)-cdd)):); call print('Imag Error LAPACK REFINEE',sumsq(imag((ctest3*cx)-cdd)):); b34srun; /; /;INVBETA Inverse of Beta distribution /; b34sexec matrix; * Sample problem from IMSL page 915 ; pin= 12.0; qin= 12.0; p = .9 ; test=invbeta(p,pin,qin); call print('X is less than ',p,' with probability ',test, 'Answer should be .6299'); b34srun; /; /;INVCHISQ Inverse of Chisq distribution /; b34sexec matrix; * Sample problem from IMSL page 921 ; df1 = 2.0; p = .99 ; test1=invchisq(p,df1); df2 = 64.; test2=invchisq(p,df2); call print('The ',p,' percentage point of Chi-square with df ',df1,test1 'Answer should be 9.210' 'The ',p,' percentage point of Chi-square with df ',df2,test2 'Answer should be 93.217'); b34srun; /; /;INVFDIS Inverse F Distribution /; b34sexec matrix; * IMSL page 927 ; p=.99; dfn=1.; dfd=7.0; f=invfdis(p,dfn,dfd); call print('F(1,7) critical value at .01 is GE ',f, 'Answer should be 12.246'); n1=100; n2=10; ftab=array(n1,n2:); call echooff; do i=1,norows(ftab); do j=1,nocols(ftab); ftab(i,j)=invfdis(.95,dfloat(i),dfloat(j)); enddo; enddo; call print('F table at 95% probability',ftab); b34srun; /; /;INVTDIS Inverse t distribution /; b34sexec matrix; p=.950; df=6.; t=invtdis(p,df); call print('The two sided t(',df,') value is ',t, 'Correct value should be 2.447'); n=100; pval=array(4:.975 .95,.90,.85); tval=array(n,norows(pval):); call echooff; do j=1,norows(pval); do i=1,n; df=dfloat(i); tval(i,j)=invtdis(pval(j),df); enddo; enddo; at975=tval(,1); at95=tval(,2); at90=tval(,3); at85=tval(,4); df=integers(n); call tabulate(df,at975,at95,at90,at85); b34srun; /; /;IOCOMMANDS READ/WRITE/OPEN/REWIND/CLOSE /; b34sexec matrix; * Tests I/O package ; n=10000; test=rn(array(n:)); call open(70,'testdata'); call write(test,70); tmean=mean(test); call print(tmean); call names(all); call free(test); call rewind(70); call close(70); call open(71,'testdata'); test2=array(n:); call read(test2,71); tmean2=mean(test2); call print(tmean2); call names(all); call close(71); b34srun; /; /;IQINT iqint function => Convert real*16 to integer /; b34sexec matrix; x=r8tor16(grid(1.,10.,1.)); call print('A real*16 array',x); ix=iqint(x); call print('An integer array',ix); x=r8tor16(rn(matrix(5,5:)) + 20.); ix=iqint(x); call print(x,ix); b34seend; /; /;IQNINT iqnint function => Convert Rounded real*16 to integer /; b34sexec matrix; x=r8tor16(grid(1.,10.,.1)); ix=iqint(x); ix2=iqnint(x); call print('x = real*16, ix iqint, ix2=iqnint'); call tabulate(x,ix,ix2); b34seend; /; /;IR8TOSTR Real*8 to String /; b34sexec matrix; call inttostr(88,is88,'(i4)'); call character(cc,'99.88D32'); call istrtor8(cc,bigr8); call character(cc,'77'); call istrtoint(cc,is77); xx=99.99; call ir8tostr(xx,is99p99,'(g12.4)'); call print(is88,bigr8,is77,is99p99); b34srun; /; /;ISEXTRACT Move data into and out of a datatype /; b34sexec matrix; people=namelist(pname,ssn,age,race,income); pname =namelist(sue,joan,bob); ssn =array(:99,9821,22); age =idint(array(:35,45,58)); race =namelist(hisp,white,black); income=array(:40000,35000,50000); call tabulate(pname,ssn,age,race,income); call print(sextract(people(3))); call print('Second person',sextract(people(1),2), sextract(people(3),2)); nage=age+1; call isextract(people(3),nage); call print(age); call isextract(people(3),77,1); call print(age); b34srun; /; /;ISMISSING Testing for Missing values /; b34sexec matrix; x=0.0; xmiss=missing(); call print(x,xmiss); y=grid(1.,20.,1.); oldy=y; do i=1,norows(y); if(dmod(y(i),2.).eq.0.0)y(i)=missing(); enddo; test=ismissing(y); call tabulate(oldy,y,test); b34srun; /; /;ISTRTOINT String to Integer /; b34sexec matrix; call inttostr(88,is88,'(i4)'); call character(cc,'99.88D32'); call istrtor8(cc,bigr8); call character(cc,'77'); call istrtoint(cc,is77); xx=99.99; call ir8tostr(xx,is99p99,'(g12.4)'); call print(is88,bigr8,is77,is99p99); b34srun; /; /;ISTRTOR8 String to Real*8 /; b34sexec matrix; call inttostr(88,is88,'(i4)'); call character(cc,'99.88D32'); call istrtor8(cc,bigr8); call character(cc,'77'); call istrtoint(cc,is77); xx=99.99; call ir8tostr(xx,is99p99,'(g12.4)'); call print(is88,bigr8,is77,is99p99); b34srun; /; /;IUPPER Upper case a string /; b34sexec matrix; call character(cc,'THIS IS UPPER'); lower=cc; call ilower(lower); upper=lower; call iupper(upper); call print(cc,lower,upper); b34srun; /; /;IWEEK Variable form of Week Day /; /$ Tests Y2K capability of B34S /$ /$ day month year read in and converted to julian /$ /$ julian = # of days since 1 Jan 1960 /$ /$ b34s data step looks at day ahead and behind /$ /$ dates in 1400's, 1800's 1900's 2000's and 2100's tested /$ /$ ******************************************************* /$ b34sexec options sasdateon; b34srun; b34sexec data heading('Y2K test') idvar=cdate1; input day month year ; build dayinyr dbehind1 dbehind2 dahead1 cweekd iweekd dahead2 qt cdate1 cdate2 julian julianp1 julianm1; character cdate1 cdate2 dbehind1 dbehind2 dahead1 dahead2 cweekd; gen julian = juldaydmy(day,month,year); gen dayinyr = julian - juldaydmy(1,1,getyear(julian))+1.; gen cdate1 = chardate(julian); gen cdate2 = chardatemy(julian); gen julianp1=julian+1.; gen julianm1=julian-1.; gen dbehind1= chardate(julianm1); gen dbehind2= chardatemy(julianm1); gen dahead1 = chardate(julianp1); gen dahead2 = chardatemy(julianp1); gen qt = getqt(julian); gen iweekd = iweek(julian); gen cweekd = cweek(julian); datacards; 9 9 1999 31 12 1999 1 1 2000 2 1 2000 3 1 2000 28 2 2000 29 2 2000 1 3 2000 31 12 2000 1 1 1850 31 12 1899 1 1 2001 5 1 2100 1 5 1492 1 1 1999 2 1 1999 1 2 1999 1 1 1960 b34sreturn; b34seend; b34sexec list ; b34srun; b34sexec list; var julian julianp1 julianm1; b34srun; /$ /$ Data passed to Matrix to see it it prints OK /$ b34sexec matrix; call loaddata; call names; call tabulate(day month year julian dayinyr dbehind1 dbehind2 dahead1 dahead2 qt); call tabulate(day month year julian julianm1 julianp1 cdate1 cdate2); tj =chardate(julian); tjm1 =chardate(julianm1); tjp1 =chardate(julianp1); iiweekd =iweek(julian); ccweekd =cweek(julian); julian =idint(julian); julianm1=idint(julianm1); julianp1=idint(julianp1); call print('This tests calculations within MATRIX of julian data'); call tabulate(day month year julian julianm1 julianp1 tj tjm1 tjp1); call tabulate(day,month,year,julian,iiweekd,ccweekd,iweekd,cweekd); b34srun; /; /;I_DRNBET Random numbers from beta distribuition /; b34sexec matrix; * Test problem from IMSL; p=3.; q=2.; n=5; beta=array(n:); call i_rnset(123457); call i_drnbet(beta,p,q); call print('Beta(3. 2.) Distribution', 'Answers should be .2814 .9483 .3984 .3103 .8296', beta); n=500; beta=array(n:); call i_drnbet(beta,p,q); call graph(beta :heading 'Beta Distribution'); b34srun; /; /;I_DRNCHI Random numbers from Chi-squared distribution /; b34sexec matrix; * Test problem from IMSL; df=5.; n=5; chisq=array(n:); call i_rnset(123457); call i_drnchi(chisq,df); call print('Chisq Distribution', 'Answers should be 12.0900 .4808 1.7976 14.8712 1.7477', chisq); n=500; chisq=array(n:); call i_drnchi(chisq,df); call graph(chisq :heading 'Chi-squared Distribution'); b34srun; /; /;I_DRNCHY Random numbers from Cauchy distribution /; b34sexec matrix; * Test problem from IMSL; n=5; cauchy=array(n:); call i_rnset(123457); call i_drnchy(cauchy); call print('Cauchy Distribution', 'Answers should be 3.5765 .9353 15.5797 2.0815 -.1333', cauchy); n=5; cauchy=array(n:); call i_drnchy(cauchy); call graph(cauchy :heading 'Cauchy Distribution'); b34srun; /; /;I_DRNEXP Random numbers from standard exponential /; b34sexec matrix; * Test problem from IMSL; n=5; expdis=array(n:); call i_rnset(123457); call i_drnexp(expdis); call print('Exponential Distribution', 'Answers should be .0344 1.3443 .2662 .5633 .1686', expdis); n=500; expdis=array(n:); call i_drnexp(expdis); call graph(expdis :heading 'Standard Exponential Distribution'); b34srun; /; /;I_DRNEXT Random numbers from mixture of two exponential distri /; b34sexec matrix; * Test problem from IMSL; n=5; theta1=2.0; theta2=1.0; p=.5; mexp=array(n:); call i_rnset(123457); call i_drnext(mexp,theta1,theta2,p); call print('Mixture of two Exponentials', 'Answers should be .0700 1.3024 .6301 1.9756 .3716', mexp); n=500; mexp=array(n:); call i_drnext(mexp,theta1,theta2,p); call graph(mexp :heading 'Mixture of two Exponentials'); b34srun; /; /;I_DRNGAM Random numbers from standard gamma distribution /; b34sexec matrix; * Test problem from IMSL; n=5; a=3.0; gamma=array(n:); call i_rnset(123457); call i_drngam(gamma,a); call print('Gamma Distribution', 'Answers should be 6.8428 3.4452 1.8535 3.9992 .7794', gamma); n=500; gamma=array(n:); call i_rnset(123457); call i_drngam(gamma,a); call graph(gamma :heading 'Standard Gamma Distribution'); b34srun; /; /;I_DRNGCT Random numbers from general continuous distribution /; b34sexec matrix; * Problem from IMSL. Tests Berta(3.,2.) distribution; x =grid(0.0,1.,.01); pp =array(norows(x):)+3.; qq =array(norows(x):)+2.; cdf=betaprob(x,pp,qq); call tabulate(x,cdf); call i_rnset(123457); n=5; xr=array(n:); call i_drngct(xr,x,cdf); call print('Test values should be', '.9208 .4641 .7668 .6536 .8171',xr); n=500; xr=array(n:); call i_drngct(xr,x,cdf); call graph(xr :heading 'Random Numbers from Beta using i_drngct'); b34srun; /; /;I_DRNGDA Random integers from discrete distribution alias appr /; b34sexec matrix; * Sample problem from IMSL; imin=1; n=5; ir=idint(array(n:)); pf=array(:.05 .45 .31 .04 .15); call i_rnset(123457); call i_drngda(ir,imin,pf); ir2=ir; call i_drngda(ir2,imin,pf); call print('Random integers from Discrete Distribution - Alias Approach' 'Test values should be 3 2 2 3 5',ir,'and 1 3 4 5 3',ir2); b34srun; /; /;I_DRNGDT Random integers from discrete using table lookup /; b34sexec matrix; * Sample problem from IMSL; imin=1; n=5; ir=idint(array(n:)); pf=array(:.05 .45 .31 .04 .15); call i_rnset(123457); call i_drngdt(ir,imin,pf); call print('Random integers from Discrete Distribution - Table Lookup', 'Test values should be 5 2 3 3 4',ir); b34srun; /; /;I_DRNGES Get the table used in the shuffled generators. /; b34sexec matrix; table=rec(array(128:)); call i_drnses(table); call i_drnges(table2); call tabulate(table,table2); b34srun; /; /;I_DRNLNL Random numbers from lognormal distribution /; b34sexec matrix; * Test problem from IMSL; n=5; xmean=0.0; xsd=1.0; lognorm=array(n:); call i_rnset(123457); call i_drnlnl(lognorm,xmean,xsd); call print('Log Normal Distribution', 'Answers should be 7.7801 2.9543 1.0861 3.5885 .2935', lognorm); n=500; lognorm=array(n:); call i_rnset(123457); call i_drnlnl(lognorm,xmean,xsd); call graph(lognorm :heading 'Log Normal Distribution'); b34srun; /; /;I_DRNMVN Random numbers from multivariate normal /; b34sexec matrix; * Problem from IMSL; nr=5; k=2; r=array(nr,k:); cov=matrix(k,k:.5 .375 .375 .5); rsig=pdfac(cov); call print(rsig); call i_rnset(123457); call i_drnmvn(r,rsig); call print('Multivariate Normal Deviates' 'Col 1 1.4507 .7660 .0584 .9035 -.8669' 'Col 2 1.2463 -.0429 -.6692 .4628 -.9334', r); b34srun; /; /;I_DRNNOA Random normal numbers using acceptance/rejection /; b34sexec matrix; * problem from IMSL ; x=array(5:); call i_rnset(123457); call i_drnnoa(x); call print('answers should be ', ' 2.0516 1.0833 .0826 1.2777 -1.2260',x); x=array(500:); call i_drnnoa(x); call graph(x :Heading 'Random Normal Values'); b34srun; /; /;I_DRNNOR Random normal numbers using CDF method /; b34sexec matrix; * problem from IMSL ; x=array(5:); call i_rnset(123457); call i_drnnor(x); call print('answers should be ', ' 1.8279 -.6412 .7266 .1747 1.0145',x); x=array(500:); call i_drnnor(x); call graph(x :Heading 'Random Normal Values - CDF Method'); b34srun; /; /;I_DRNSES Initializes the table used in the shuffled generators /; b34sexec matrix; table=rec(array(128:)); call i_drnses(table); call i_drnges(table2); call tabulate(table,table2); b34srun; /; /;I_DRNSPH Random numbers on the unit circle /; b34sexec matrix; * problem from IMSL; n=2; k=3; r=array(n,k:); call i_rnset(123457); call i_drnsph(r); call print('Random points on unit circle' 'Row 1 .8893 .2316 .3944' 'Row 2 .1901 .0396 -.9810',r); b34srun; /; /;I_DRNSTA Random numbers from stable distribution /; b34sexec matrix; * Test problem from IMSL; n=5; sta=array(n:); call i_rnset(123457); alpha=1.5; bprime=0.0; call i_drnsta(sta,alpha,bprime); call print('Stable Distribution', 'Answers should be 4.4091 1.0564 2.5463 5.6724 2.1656' sta); n=500; sta=array(n:); call i_drnsta(sta,alpha,bprime); call graph(sta :heading 'Stable Distribution'); b34srun; /; /;I_DRNTRI Random numbers from triangular dsitribution /; b34sexec matrix; * Test problem from IMSL; n=5; tri=array(n:); call i_rnset(123457); call i_drntri(tri); call print('Triangular Distribution', 'Answers should be .8700 .3610 .6581 .5360 .7215' tri); n=500; tri=array(n:); call i_drntri(tri); call graph(tri :heading 'Triangular Distribution'); b34srun; /; /;I_DRNUN Uniform (0,1) Generator /; b34sexec matrix; * IMSL test case; call i_rnset(123457); x=array(5:); call i_drnun(x); call print('answers should be' ' .9662 .2607 .7663 .5693 .8448'); call print(x); n=300; x=array(n:); call i_drnun(x); call graph(x :heading 'random numbers'); b34srun; /; /;I_DRNVMS Random numbers from Von Mises distribution /; b34sexec matrix; * Test problem from IMSL; n=5; vm=array(n:); c=1.0; call i_rnset(123457); call i_drnvms(vm,c); call print('Von Mises Distribution', 'Answers should be .2472 -2.4326 -1.0216 -2.1722 -.5029' vm); n=500; vm=array(n:); call i_drnvms(vm,c); call graph(vm :heading 'Von Mises Distribution'); b34srun; /; /;I_DRNWIB Random numbers from Weibull distribution /; b34sexec matrix; * Test problem from IMSL; n=5; wb=array(n:); a=2.0; scale=6.; call i_rnset(123457); call i_drnwib(wb,a); wb=wb*scale; call print('Weibull Distribution', 'Answers should be 1.1122 6.9567 3.0959 4.5031 2.4638' wb); n=500; wb=array(n:); call i_drnvms(wb,a); wb=wb*scale; call graph(wb :heading 'Weibull Distribution'); b34srun; /; /;I_RNBIN Random integers from binomial distribution /; b34sexec matrix; * Problem from IMSL ; ir=idint(array(5:)); ntrials = 20; probs = .5; call i_rnset(123457); call i_rnbin(ir,ntrials,probs); call print('answers should be 14 9 12 10 12',ir, 'Number of trials ',ntrials, 'Probability of Success ',probs); b34srun; /; /;I_RNGEO Random integers from Geometric distribution /; b34sexec matrix; * Problem from IMSL ; ir=idint(array(5:)); p=.3; call i_rnset(123457); call i_rngeo(ir,p); call print('Geometric Distribution', 'Answers should be 1 4 1 2 1', ir,'Probability of Success',p); b34srun; /; /;I_RNGET Gets seed used in IMSL Random Number generators. /; b34sexec matrix; call i_rnget; call i_rnget(ii); call print('Seed was ',ii); call i_rnset(3452); call i_rnget; b34srun; /; /;I_RNHYP Random integers from hypergeometric distribution /; b34sexec matrix; * Sample problem from IMSL ; ii=idint(array(5:)); call i_rnset(123457); n=4; m=12; l=20; call i_rnhyp(ii,n,m,l); call print('Should be 4 2 3 3 3 ',ii, 'Items in sample ',n, 'Special items in population ',m, 'Number of items in lot ',l); b34srun; /; /;I_RNMTN Random numbers from multinomial distribution /; b34sexec matrix; * Test problem from IMSL; nr=5; k=3; ir=idint(array(nr,k:)); n=20; p=array(k:.1 .3 .6); call i_rnset(123457); call i_rnmtn(ir,n,p); call print('Multinomial distribution', 'Answers should be:', 'col 1 5 3 3 5 4' 'col 2 4 6 3 5 5' 'col 3 11 11 14 10 11' ir); b34srun; /; /;I_RNNBN Negative binomial distribution /; b34sexec matrix; * Test problem from IMSL; * Since R is an integer we have a Pascal distribution; r=4.; p=.3; n=5; ii=idint(array(n:)); call i_rnset(123457); call i_rnnbn(ii,r,p); call print('Pascal Distribution', 'Answers should be 5 1 3 2 3', ii); b34srun; /; /;I_RNOPG Gets the type of generator currently in use. /; b34sexec matrix; call i_rnopg; call echooff; do i=1,7; call i_rnopt(i); call i_rnopg; call i_rnopg(j); if(i.ne.j)then; call epprint('ERROR: i_rnopt and i_rnopg not correct'); call epprint('sett was ',i,' return was ',j); endif; enddo; call i_rnopg(ii,recver,rnver); call print('imsl code ',ii,recver,rnver); b34srun; /; /;I_RNOPT Selects the type of uniform (0,1) generator. /; b34sexec matrix; call i_rnopg; call echooff; do i=1,7; call i_rnopt(i); call i_rnopg; call i_rnopg(j); if(i.ne.j)then; call epprint('ERROR: i_rnopt and i_rnopg not correct'); call epprint('sett was ',i,' return was ',j); endif; enddo; b34srun; /; /;I_RNPER Random pertibation of integers /; b34sexec matrix; * Test problem from IMSL; n=10; ii=idint(array(n:)); call i_rnset(123457); call i_rnper(ii); call print('Random Pertibation of Integers', 'Answers should be 5 9 2 8 1 6 4 7 3 10', ii); b34srun; /; /;I_RNSET Sets seed used in IMSL Random Number generators. /; b34sexec matrix; call i_rnget; call i_rnget(ii); call print('Seed was ',ii); call i_rnset(3452); call i_rnget; b34srun; /; /;I_RNSRI Index of random sample without replacement /; b34sexec matrix; * Test problem from IMSL; nsamp=5; npop =100; ii=idint(array(nsamp:)); call i_rnset(123457); call i_rnsri(ii,npop); call print('Random Sample of Indices without replacement' 'Answer should be 2 22 53 61 79' ii); b34srun; /; /;JULDAYDMY Gets Julday from Day, Month, year /; b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; /; /;JULDAYQY Illustrates Date processing /; b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; /; /;JULDAYY Illustrates Date processing /; b34sexec matrix; call echooff; n12=12; n28=28; juldata= array(n12,n28:); fyear2 = array(n12,n28:); day = array(n12,n28:); month = array(n12,n28:); year = array(n12,n28:); quarter= array(n12,n28:); date1 =rtoch(array(n12,n28:)); date2 =rtoch(array(n12,n28:)); do i=1,n12; year=1960+i; call print('Year ',year,chardate(juldayy(year)),'Test 2 ', chardate(juldayqy(1,year))); enddo; do i=1,n12; do j=1,n28; juldata(i,j)=juldaydmy(j,i,1989); date1(i,j) =chardate(juldata(i,j)); date2(i,j) =chardatemy(juldata(i,j)); fyear2(i,j) =fyear(juldata(i,j)); day(i,j) =getday(juldata(i,j)); month(i,j) =getmonth(juldata(i,j)); year(i,j) =getyear(juldata(i,j)); quarter(i,j)=getqt(juldata(i,j)); enddo; enddo; call print(juldata,date1,date2,fyear2,day,month,year,quarter); * time ; base=juldaydmy(1,1,1992); n=50; hour = array(n:); second = array(n:); minute = array(n:); fday = array(n:); cbase = rtoch(array(n:)); cbase2 = rtoch(array(n:)); base2 = array(n:); do i=1,n; base=base+.1; base2(i)=base; hour(i) =gethour(base); second(i) =getsecond(base); minute(i) =getminute(base); cbase(i) =chardate(base); cbase2(i) =chardatemy(base); fday(i) =fdayhms(hour(i),minute(i),second(i)); enddo; call tabulate(cbase,base2,hour,second,minute,fday); call free(year,qt); do year=1985,1990; do qt=1,4; call print(year,qt,chardate(juldayqy(qt,year)), chardatemy(juldayqy(qt,year))); enddo; enddo; b34srun; /; /;KEENAN Illustrates Keenan Test /; b34sexec options ginclude('gas.b34'); b34srun; /; /; See Keenan D. 'A Tukey Nonadditive Type Test for Time Series /; Nonlinearity' Biometrika 72, 39-44 1985 /; b34sexec matrix; call echooff; call loaddata; do i=2,18; call keenan(gasout,tt,i,pp); j=i-1; test(j) =tt; prob(j) =pp; order(j) =i; enddo; call print('Keenan (1985) Test of Gasout Series'); call tabulate(order,test,prob); b34srun; /; /;KEEPFIRST Illustrates KEEPFIRST, KEEPLAST, DROPFIRST, DROPLAST /; b34sexec matrix; n=10; maxlag=2; x=array(n:integers(n)); lag1x=lag(x,1:nomiss); lag2x=lag(x,2:); last2=keeplast(x,2); first2=keepfirst(x,2); dropl2=droplast(x,2); dropf2=dropfirst(x,2); call tabulate(x,lag1x,lag2x,last2,first2,dropl2,dropf2); b34srun; /; /;KEEPLAST Illustrates KEEPFIRST, KEEPLAST, DROPFIRST, DROPLAST /; b34sexec matrix; n=10; maxlag=2; x=array(n:integers(n)); lag1x=lag(x,1:nomiss); lag2x=lag(x,2:); last2=keeplast(x,2); first2=keepfirst(x,2); dropl2=droplast(x,2); dropf2=dropfirst(x,2); call tabulate(x,lag1x,lag2x,last2,first2,dropl2,dropf2); b34srun; /; /;KIND Kind of an object /; b34sexec matrix; x=rn(matrix(3,3:)); ii=idint(2.0); cc=complex(1.2,3.3); call print(kind(x), kind(ii),kind(cc), klass(x),klass(ii),klass(cc)); b34srun; /; /;KINDAS Change kind of an object /; b34sexec matrix; x=10.; one1=kindas(x,1.0); one2=kindas(r8tor16(x),1.0); call names(all); b34srun; /$ Illustrates use of kindas for a general subroutine b34sexec matrix ; subroutine test(x); call print('now in test'); call print('x found to be ',x); call names(all); x=x*kindas(x,2.); return; end; x=array(2:11 22); r16x=r8tor16(x); call print(x); call test(x); call print(x); call print(r16x); call test(r16x); call print(r16x); b34srun; /; /;KLASS Klass of an object /; b34sexec matrix; x=rn(matrix(3,3:)); ii=idint(2.0); cc=complex(1.2,3.3); call print(kind(x), kind(ii),kind(cc), klass(x),klass(ii),klass(cc)); b34srun; /; /;KPROD Kronecker Product /; b34sexec matrix; * Example from Greene (2000) page 35; a=matrix(2,2:3 0 5 2); b=matrix(2,2:1 4 4 7); x=kprod(a,b); call print('Answer matrix(2,2: 3* b , 0 * b , 5 * b , 2 * b)':); call print(a,b,x); * Complex case; aa=complex(a,-1.*dsqrt(a)); bb=complex(b,-1.*dsqrt(b)); cx=kprod(aa,bb); call print(aa,bb,cx); * Matlab 11-1 case; x=matrix(2,2:1. 2. 3. 4.); y=matrix(2,2:)+1.; call print(x,y,kprod(x,y),kprod(y,x)); b34srun; /; /;KSWTEST K Period Stock Watson Test /; b34sexec options ginclude('gas.b34'); b34srun$ b34sexec matrix; call load(buildlag); call load(varest); call load(swartest); call load(kswtest); /$ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% /$ /;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/; /$ SUBROUTINE for Multi Breaking Periods /$ /$ /$ subroutine kswtest(x,vbegin1,vend1,nlag,nterms,iprint,iprint2); /$ /$ Generate k by k Stock Watson Test Statistics /$ /$ X = Data to be Analysed. X is 1D or 2D array/Matrix /$ vbegin1 = vector/array of subperiod beginning points integer*4 /$ vend1 = vector/array of subperiod endinf points integer*4 /$ nlag = # of AR lags /$ nterms = # of MA terms /$ iprint = Controls printing in SWARTEST. Usually = 0. /$ iprint2 = Controls printing in kswtest. /$ = 1 to print in kswtest /$ = 0 to save data in global variable. /$ =-1 to print and save data. /$ /$ Optional data saved: /$ /$ %var_i /$ %varh_i /$ %rsq_i /$ %fac_i /$ %dfac_i /$ %dstr_i /$ %dvar_i /$ /$ Developed 24 April 2003 by Jin-Man Lee /$ Refinements made by Houston H. Stokes /$ /$ Routines needed: buildlag, varest, swartest /$ /$ **************************************************************** /$ /$ /;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/;/; nlag = 8; nterms = 20; iprint = 0; iprint2= 0; call get(gasin,gasout :dropmiss); call echooff; * Single series model ; vbegin1 = index( 1 100); vend1 = index( 99 189) ; x=gasout; call kswtest(x,vbegin1,vend1,nlag,nterms,iprint,iprint2) ; /$ call names(all); call print(%var___1, %varh__1 %rsq___1 %fac___1 %dfac__1 %dstr__1 %dvar__1); vbegin1 = index( 1 100 190); vend1 = index( 99 189 296) ; x=gasout; call kswtest(x,vbegin1,vend1,nlag,nterms,iprint,iprint2) ; /$ call names(all); call print(%var___1, %varh__1 %rsq___1 %fac___1 %dfac__1 %dstr__1 %dvar__1); * multi series model; vbegin1 = index( 1 100); vend1 = index( 99 189) ; x = mfam(catcol(gasin,gasout)); call kswtest(x,vbegin1,vend1,nlag,nterms,iprint,iprint2) ; /$ call names(all); call print(%var___1 %varh__1 %rsq___1 %fac___1 %dfac__1 %dstr__1 %dvar__1 %var___2 %varh__2 %rsq___2 %fac___2 %dfac__2 %dstr__2 %dvar__2 ); vbegin1 = index( 1 100 190); vend1 = index( 99 189 296) ; x = mfam(catcol(gasin,gasout)); call kswtest(x,vbegin1,vend1,nlag,nterms,iprint,iprint2) ; /$ call names(all); call print(%var___1, %varh__1 %rsq___1 %fac___1 %dfac__1 %dstr__1 %dvar__1 %var___2 %varh__2 %rsq___2 %fac___2 %dfac__2 %dstr__2 %dvar__2 ); b34srun ; /; /;KSWTESTM Moving Period Stock Watson Test /; b34sexec options ginclude('gas.b34'); b34srun$ b34sexec matrix; call load(buildlag); call load(varest); call load(swartest); call load(kswtestm); nlag = 8; nterms = 20; iprint = 0; iprint2= 0; call get(gasin,gasout :dropmiss); /$ **************************************************************** call echooff; * Single series model ; vbegin1 = index( 1 100); vend1 = index( 99 199); vbegin2 = index(100 200); vend2 = index(199 296); x=gasout; call echooff; call kswtestm(x,vbegin1,vend1, vbegin2,vend2,nlag,nterms, iprint,iprint2) ; call names(all); call print(%t11___1 %t12___1 %t22___1 %t21___1 %VAR1__1 %VAR2__1 %RSQ1__1 %VARH1_1 %VARH2_1 %RSQ2__1 %DFAC__1 %DVAR1_1 %DVAR2_1 %DSTR1_1 %DSTR2_1); /$ Multi Series Model call print('Multi Series Model':); call print('******************':); x = mfam(catcol(gasin,gasout)); call kswtestm(x,vbegin1,vend1,vbegin2,vend2, nlag,nterms,iprint,iprint2) ; /$ call names(all); call print(%t11___1 %t12___1 %t22___1 %t21___1 %VAR1__1 %VAR2__1 %RSQ1__1 %VARH1_1 %VARH2_1 %RSQ2__1 %DFAC__1 %DVAR1_1 %DVAR2_1 %DSTR1_1 %DSTR2_1 %t11___2 %t12___2 %t22___2 %t21___2 %VAR1__2 %VAR2__2 %RSQ1__2 %VARH1_2 %VARH2_2 %RSQ2__2 %DFAC__2 %DVAR1_2 %DVAR2_2 %DSTR1_2 %DSTR2_2 ); b34srun ; /; /;LABEL Illustrate LABEL /; b34sexec matrix; short=10.; long= 20; call names; call setlabel(short,'test'); call setlabel(long, 'This is a long label'); call names; call print('Label for long' ,label(long), 'Label for short',label(short)); b34srun; /; /;LAG Lag function /; b34sexec matrix; n=10; x=array(n:integers(n)); lagx =lag(x,1); lagx2=lag(x,2); lagxm =lag(x,-1); lagxm2=lag(x,-2); misslagx=ismissing(lagx); call tabulate(x,lagx,lagx2,lagxm,lagxm2,misslagx); b34srun; b34sexec matrix; n=10; maxlag=2; x=array(n:integers(n)); lag1x=lag(x,1:nomiss); lag2x=lag(x,2:); last2=keeplast(x,2); first2=keepfirst(x,2); dropl2=droplast(x,2); dropf2=dropfirst(x,2); call tabulate(x,lag1x,lag2x,last2,first2,dropl2,dropf2); b34srun; /; /;LAGTEST Illustrate LAGTEST Subroutine /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(lagtest); call echooff; /$ subroutine lagtest(y,x,ylag,xlag,nsubsets,rss); /$ /$ Purpose: Use 3-D Graph to display RSS for /$ alternative lags /$ /$ y y-variable /$ x x-variable /$ ylag # lags on y /$ xlag # lags on x /$ nsubsets # subsets /$ ylag = 24; xlag = 24; nsubsets = 12; call lagtest(gasout,gasin,ylag,xlag,nsubsets,rss); call checkpoint; b34srun; /; /;LAGTEST2 Tests Alternative lags of MARS Model /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(lagtest2); call echooff; ylag = 12; xlag = 12; nsubsets = 5; nk=20; mi=2; call lagtest2(gasout,gasin,ylag, xlag,nsubsets,mi,nk,rss); call checkpoint; b34srun; /; /;LAGTEST_2 Mink-Muskrat Lags /; b34sexec options ginclude('b34sdata.mac') member(mink); b34srun; b34sexec matrix; call loaddata; call load(lagtest); call echooff; /$ subroutine lagtest(y,x,ylag,xlag,nsubsets,rss); /$ /$ Purpose: Use 3-D Graph to display RSS for /$ alternative lags /$ /$ y y-variable /$ x x-variable /$ ylag # lags on y /$ xlag # lags on x /$ nsubsets # subsets /$ ylag = 6 ; xlag = 6 ; nsubsets = 5 ; call lagtest(mink,muskrat,ylag,xlag,nsubsets,rss); call checkpoint; b34srun; /; /;LAGTEST_3 AAA=f(PD_M1) /; b34sexec options ginclude('b34sdata.mac') member(res79); b34srun; b34sexec matrix; call loaddata; call load(lagtest); call echooff; /$ subroutine lagtest(y,x,ylag,xlag,nsubsets,rss); /$ /$ Purpose: Use 3-D Graph to display RSS for /$ alternative lags of OLS Model /$ /$ y y-variable /$ x x-variable /$ ylag # lags on y /$ xlag # lags on x /$ nsubsets # subsets /$ ylag = 24; xlag = 24; nsubsets = 12; call lagtest(fyaac,pcrm1,ylag,xlag,nsubsets,rss); call checkpoint; b34srun; /; /;LAPACK Sets LAPACK /; b34sexec matrix; x=rec(matrix(4,4:)); call lapack; xi=inv(x:gmat); call print(x,xi); call lapack(1,1); call lapack; xi=inv(x:gmat); call print(x,xi); call lapack(:reset); call lapack; b34srun; /; /;LEVEL Level function => Determine level /; b34sexec matrix; subroutine test(y); call names(all); call print('In test level and y were ',level(),y); call test2(y); return; end; subroutine test2(x); call names(all); call print('In test2 level and x were ',level(),x); return; end; call print('Level in root',level()); i=1.; call test(i); call print('Back in root. Level was',level()); call names(all); b34srun; /; /;LM Engle LM ARCH test Test /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call echooff; n=30; lmvalue=array(n:); lag=idint(array(n:)); prob=array(n:); do i=1,n; lag(i)=i; call lm(gasout,value,i,pp); lmvalue(i)=value; prob(i)=pp; enddo; call print('Engle LM Test for ARCH in Gasout Series'); call tabulate(lag,lmvalue,prob); b34srun; /; /;LMTEST Test LMTEST Subroutine /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call echooff; call load(lmtest); call lmtest(gasout,30,lag,tt,prob,1); b34srun; /; /;LOAD Call LOAD => Load a subroutine, function or program /; b34sexec matrix; * The Load command cannot be used in the Manual mode; call load(testpgm); call testpgm; call load(testsub); call testsub(2.); call load(testfun); f=testfun(4.0); call print(f); call load(pvalue_1); call pvalue_1(1,.06,a); call print(a); call names(all); b34srun; /; /;LOADDATA Call LOADDATA => Load B34S data into Matrix command /; b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix saveasvector$ call print('This Loads the gas data.', 'Simple graphs are next done.'); call loaddata; call print('This is GASIN',gasin); call graph(gasout:heading 'This is GASOUT'); call names; b34srun$ /; /;LOWERT Lower Triangle /; b34sexec matrix; x=rn(matrix(6,6:)); call print(x); call print(zerou(x)); call print(zerou(x :nodiag)); call print(zerol(x)); call print(zerol(x : :nodiag)); call print(uppert(x)); call print(uppert(x :nodiag)); call print(lowert(x)); call print(lowert(x :nodiag)); b34srun; /; /;LPMAX Linear Programing MAXIMUM /; b34sexec matrix; neq=0; a=matrix(4,2: 1., 0., 0., 1., 1., 1., -1.,-1.); b=vector( :1., 1.,1.5, -.5); c=vector( :1., 3.); call lpmax(c,a,b,neq :print); /; Problem from Lindo /; Answers Objective function 2628. /; x1 = 150., x2 = 650. /; Shadow prices 3.22 0. 0. 0. .08 .0 neq=0; aa=matrix(6,2: 1., 1., 10., 6., 9., 6.5, 1., 0., 0., 1., 0., -1.); bb=vector( 6:800.,6000.,5850.,450.,650.,-300.); cc=vector( 2:3.22 3.3); call lpmax(cc,aa,bb,neq :print); /; Problem from Lindo /; Answers Objective function 2640. /; x1 = 260., x2 = 540. /; Shadow prices 3.30 0. 0. 0. 0. .0 /; Note price change for x1 neq=0; aa=matrix(6,2: 1., 1., 10., 6., 9., 6.5, 1., 0., 0., 1., 0., -1.); bb=vector( 6:800.,6000.,5850.,450.,650.,-300.); cc=vector( 2:3.3 3.3); call lpmax(cc,aa,bb,neq :print); b34srun; b34sexec lpmax n=2 m1=4 m2=0; * Sample problem from IMSL ; amatrix(1.0,0., 0., 1., 1., 1., -1.,-1.); bvector(1.,1.,1.5,-.5); cvector(1,3.); b34srun; b34sexec matrix; * problem from Hadley(1962) page 3; * max should be 127370588235294 ; * primal = 294.118 1500 0.0 58.8235 ; * Dual = 1.95353 .242353 1.37824 ; neq=0; a=matrix(3,4: 1.5 1.0 2.4 1. 1. 5. 1. 3.5 1.5 3. 3.5 1.); b=vector(: 2000. 8000. 5000.); c=vector(: 5.24 7.30 8.34 4.18); call lpmax(c,a,b,neq :print); call names; b34srun; b34sexec lpmax n=4 m1=3 m2=0; * problem from Hadley(1962) page 3; * max should be 127370588235294 ; * primal = 294.118 1500 0.0 58.8235 ; * Dual = 1.95353 .242353 1.37824 ; amatrix(1.5 1.0 2.4 1. 1. 5. 1. 3.5 1.5 3. 3.5 1.); bvector(2000 8000 5000); cvector(5.24 7.30 8.34 4.18); b34srun; b34sexec matrix; * problem from Hadley(1962) page 135; * max should be 12.37. x1=1.053 x2=2.368; neq=0; a=matrix(2,2:3. 5. 5. 2.); b=vector(: 15. 10.); c=vector(: 5. 3.); call lpmax(c,a,b,neq :print); call names; b34srun; b34sexec lpmax n=2 m1=2 m2=0; * problem from Hadley(1962) page 135; * max should be 12.37. x1=1.053 x2=2.368; amatrix( 3. 5. 5. 2. ); bvector(15. 10. ); cvector( 5. 3. ); b34srun; b34sexec matrix ; * problem from Hadley (1962) page 138; * answer should be 40 x1=7.273 x3 = 6.36364; neq=0; a=matrix(3,4: 1., 3., 2., 5., -2.,-16., -1., -1., 3., -1., -5., 10. ); b=vector( :20., -4., -10. ); c=vector( :2. , 1., 4. 5. ); call lpmax(c,a,b,neq :print); call names; b34srun; b34sexec lpmax n=4 m1=3 m2=0; * problem from Hadley (1962) page 138; * answer should be 40 x1=7.273 x3 = 6.36364; amatrix(1. 3., 2., 5., -2., -16., -1., -1., 3., -1., -5., 10.); bvector(20. -4. -10.); cvector(2. 1. 4. 5.); b34srun; /; /;LPMAX_2 Extended Dief Problem solved as a Max /; b34sexec matrix; * Dorfman- Samuelson-Solow page 45; * Extended Diet Problem ; * max z = 700*u1 + 400*u2 ; * u1 le 2 ; * u2 le 20 ; * u1 le 3 ; * u1+u2 le 11 ; * 2u1+u2 le 12 ; * Page 57-58 z = 4700 ; * u1=1, u2=10, x4=100, x5=300 ; neq=0; a=matrix(5,2: 1., 0., 0., 1., 1., 0., 1., 1. 2., 1.); b=vector( :2.,20.,3.,11.,12.); c=vector( :700.,400.); call lpmax(c,a,b,neq :print); b34srun; /; /;LPMIN Linear Programing Mininum /; b34sexec matrix; * Test Problem from IMSL ; * Problem solved as a MAX problem ; * Objective = 3.5 ; * Primal = .5 1. ; * Dual =1. .0; ncon=2; nvar=2; a=matrix(ncon,nvar:1.0 1.0 1.0 1.0); b=vector(ncon:1.5 .1); c=vector(nvar:1.0 3.0); call lpmin(c,a,b:lowerx vector(:0.0 0.0) :upperx vector(:1.0 1.0) :constr namelist(LE GE) :print :max); call names; b34srun; /; /;LPMIN_2 Extended Diet Problem Solved Two ways /; b34sexec matrix; * Test Problem from Dorfman-Samuelson-Solow page 45 ; * Unless we constrain lowerx to 0.0 we get unbounded ; ncon=2; nvar=5; a=matrix(ncon,nvar: 1.0, 0.0, 1.0, 1.0, 2.0, 0.0, 1.0, 0.0, 1.0, 1.0); b=vector(ncon:700.,400.); c=vector(nvar: 2.0, 20., 3., 11., 12.); call lpmin(c,a,b :lowerx array(:0.,0.,0.,0.,0.) :constr namelist(GE GE) :print); * Solve as a max; * Dorfman-Samuelson-Solow page 45; * Extended Diet Problem ; * max z = 700*u1 + 400*u2 ; * u1 le 2 ; * u2 le 20 ; * u1 le 3 ; * u1+u2 le 11 ; * 2u1+u2 le 12 ; * Page 57-58 z = 4700 ; * u1=1, u2=10, x4=100, x5=300 ; nvar=2; ncon=5; a=matrix(ncon,nvar: 1.0, 0.0, 0.0, 1.0, 1.0, 0.0, 1.0, 1.0, 2.0, 1.0); b=vector(ncon:2., 20.,3.,11.,12.); c=vector(nvar: 700., 400.); call lpmin(c,a,b :max :constr namelist(LE LE LE LE LE) :print); b34srun; /; /;LRE Log Relative Error /; b34sexec options ginclude('b34sdata.mac') member(wampler); b34srun; b34sexec matrix; call loaddata; n=16; call print(' ':); call print('With QR':); call olsq(y5 x1 x2 x3 x4 x5 :print ); c=array(norows(%coef):)+1.0; call lre(c,n,%coef,lrevalue,bits); d=afam(c)-afam(%coef); call tabulate(c,%coef,lrevalue,bits,d); call print('Results using Cholesky':); call lre(c,n,%coef,lrevalue,bits :print); call olsq(y5 x1 x2 x3 x4 x5 :print :qr); call print('Results using QR':); call lre(c,n,%coef,lrevalue,bits :print); nn=5; x=rn(matrix(nn,nn:)); invx=inv(x); tt=x*invx; get=diag(tt); value=array(norows(x):)+1.0d+00; call print('Inversion test':); call lre(value,16,get,lrevalue,bits :print); dd=det(x); altdd=real(prod(eig(x))); call print('Determinant two Ways - Easy Problem':); call lre(dd,16,altdd,test,bits :print); xtest=mfam(catcol(x1 x2 x3 x4 x5)); xnew=transpose(xtest)*xtest; dd=det(xnew); altdd=real(prod(eig(xnew))); call print('Determinant two Ways - Harder Problem':); call lre(dd,16,altdd,test,bits :print); call print('Real*16 results *******************':); n=32; call print(' ':); call print('With QR':); y5=r8tor16(y5); x1=r8tor16(x1); x2=r8tor16(x2); x3=r8tor16(x3); x4=r8tor16(x4); x5=r8tor16(x5); call olsq(y5 x1 x2 x3 x4 x5 :print ); c=r8tor16(array(norows(%coef):)+1.0); call lre(c,n,%coef,lrevalue,bits); d=afam(c)-afam(%coef); call tabulate(c,%coef,lrevalue,bits,d); call print('Results using Cholesky':); call lre(c,n,%coef,lrevalue,bits :print); call olsq(y5 x1 x2 x3 x4 x5 :print :qr); call print('Results using QR':); call lre(c,n,%coef,lrevalue,bits :print); x=r8tor16(x); invx=inv(x); tt=x*invx; get=diag(tt); value=r8tor16(array(norows(x):)+1.0d+00); call print('Inversion test Real*16':); call lre(value,n,get,lrevalue,bits :print); dd=det(x); altdd=qreal(prod(eig(x))); call print('Determinant two Ways - Easy Problem':); call lre(dd,n,altdd,test,bits :print); xtest=mfam(catcol(x1 x2 x3 x4 x5)); xnew=transpose(xtest)*xtest; dd=det(xnew); altdd=qreal(prod(eig(xnew))); call print('Determinant two Ways - Harder Problem':); call lre(dd,n,altdd,test,bits :print); b34srun; /; /;LRE_2 Tests Matrix Power /; /$ /$ Matrix Power does with Eigen Analysis. /$ This is tested against multiple matrix mult. /$ b34sexec matrix; call echooff; r=18.0; n=10; x=rn(matrix(n,n:)); x=transpose(x)*x; x(,1)=x(,1)*1.d+15; test1=x**r; test2=x; do i=2,idint(r); test2=test2*x; enddo; call print('Are test1 and test2 the same?':); call print(test1,test2); zero=matrix(n,n:); zero1=test1-test2; call lre(zero,16,zero1,lretest,bits:print); call print('In Complex Domain with fractional Powers':); r=.5; n=4; x=rn(matrix(n,n:)); test1=complex(x)**complex(r); test2= test1**complex(1.0/r); call print(x,test1,test2); e1=eig(complex(x) :lapack); e2=eig(test2 :lapack); call print(e1,e2,prod(e1),prod(e2)); call lre(x,16,real(test2),lrtest,bits:print); * Full Complex implementation; r=.5; n=4; x=complex(rn(matrix(n,n:)),rn(matrix(n,n:))); test1=x**complex(r); test2=test1**complex(1.0/r); call print(x,test1,test2); e1=eig(x ); e2=eig(test2); call print(e1,e2,prod(e1),prod(e2)); call print('Tests Real Part':); call lre(real(x),16,real(test2),lrtest,bits:print); call print('Tests Imag Part':); call lre(imag(x),16,imag(test2),lrtest,bits:print); b34srun; /; /;MAKEDATA Makes a datastep from matrix data /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; newgasi=gasin; newgaso=gasout; call makedata(gasin,newgasi,gasout,newgaso:file 'full.b34'); xx=rn(array(norows(gasout)/2:)); call makedata(gasin,newgasi,gasout,newgaso,xx:file 'full2.b34'); b34srun; b34sexec options include('full.b34'); b34srun; b34sexec options include('full2.b34'); b34srun; b34sexec list; b34srun; /$ shows MAKEDATA with a matrix b34sexec matrix; x=rn(matrix(100,20:)); call makedata(x :file 'full3.b34'); b34srun; b34sexec options include('full3.b34'); b34srun; /; /;MAKEGLOBAL Call MAKEGLOBAL => Make a local object global /; b34sexec matrix; n=4 ;x=rn(matrix(n,n:));pdx=transpose(x)*x; call free(n:); call names(info); call makeglobal(pdx); call names(info); r=pdfac(pdx); call print(pdx,r); call makelocal(pdx); call names(info); r=pdfac(pdx); call print(pdx,r); pdx(1,1)=.9999; call print(pdx,'We now free at the local level'); call free(pdx); call names(info); b34srun; /; /;MAKEJUL Makes a Julian Variable from a Series /; b34sexec matrix; x=rn(array(120:)); call settime(x,1960,1,12.); call print(timebase(x),timestart(x),freq(x)); jdate=makejul(x); year=fyear(jdate); call graph(year,x :plottype xyplot); b34srun; /; /;MAKELOCAL Call MAKELOCAL => Make a global object local /; b34sexec matrix; n=4 ;x=rn(matrix(n,n:));pdx=transpose(x)*x; call free(n:); call names(info); call makeglobal(pdx); call names(info); r=pdfac(pdx); call print(pdx,r); call makelocal(pdx); call names(info); r=pdfac(pdx); call print(pdx,r); pdx(1,1)=.9999; call print(pdx,'We now free at the local level'); call free(pdx); call names(info); b34srun; /; /;MAKEMAD Makes a SCA MAD file from matrix data /; /$ /$ In SCA the commands: /$ call procedure is name. file is 'full.mad' /$ /$ /$ will read the data /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; newgasi=gasin; newgaso=gasout; call makemad(gasin,newgasi,gasout,newgaso :file 'full.mad' :member test); call print(mean(gasin)); xx=rn(matrix(300,60:)); call makemad(xx :file 'full.mad' :member mm :add); b34srun; b34sexec scaio readsca file('full.mad') dataset(test); b34srun; b34sexec scaio readsca file('full.mad') dataset(mm); b34srun; /; /;MAKEMATLAB Gets & Makes Matlab Data saved with MAKEB34S command /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; /$ When using the MATLAB GETB34S file use full path /$ xx=getb34s('c:\junk\junk.ttt'); call loaddata; call names; xx=rn(matrix(5,5:)); call makematlab(gasout,gasin:file 'junk.ttt'); call makematlab(xx :file 'junk2.ttt'); call getmatlab(x, :file 'junk.ttt'); call getmatlab(xx2 :file 'junk2.ttt'); call print(x,xx,xx2); call names; cx=complex(xx,xx*2.); call makematlab(cx :file 'junk3.ttt'); call getmatlab(cx2, :file 'junk3.ttt'); call print(cx,cx2); b34srun; /; /;MAKERATS Make Rats Portable File - Shows Obs and Dated File /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; newgasi=gasin; newgaso=gasout; call makerats(gasin,newgasi,gasout,newgaso :file 'full.por'); call print(mean(gasin) mean(newgasi) mean(newgaso) mean(gasout) ); call cleardat; call getrats('full.por'); call print(mean(gasin) mean(newgasi) mean(newgaso) mean(gasout) ); call names; call tabulate(obsnum,gasin,newgasi,gasout,newgaso); b34srun; /$ /$ Time series section /$ b34sexec matrix; call loaddata; newgasi=gasin; newgaso=gasout; call makerats(gasin,newgasi,gasout,newgaso :timeseries juldaydmy(1,02,1945) 12. :file 'tfull.por'); call print(mean(gasin) mean(newgasi) mean(newgaso) mean(gasout) ); call cleardat; call getrats('tfull.por'); call print(mean(gasin) mean(newgasi) mean(newgaso) mean(gasout) ); call names; cdate=chardate(julian_); call tabulate(julian_,cdate,gasin,newgasi,gasout,newgaso); b34srun; /$ /$ Missing data section /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; do i=1,20; gasout(i)=missing(); enddo; call tabulate(gasin,gasout); call makerats(gasin,gasout :file 'junk.por' :timeseries 366. 12.); b34srun; b34sexec matrix; call getrats('junk.por'); call tabulate(gasin,gasout); call names; call cleardat; call getrats('junk.por' :keepmiss); call tabulate(gasin,gasout); call names; call print('Means of gasin and gasout' mean(goodrow(gasin )),mean(goodrow(gasout))); b34srun; /; /;MAKESCA Makes a SCA FSAVE file from matrix data /; /$ /$ In SCA the commands: /$ finput file is 'full.fsv'. @ /$ dataset is test. /$ /$ will read the data /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; newgasi=gasin; newgaso=gasout; call makesca(gasin,newgasi,gasout,newgaso :file 'full.fsv' :member test); call print(mean(gasin)); xx=rn(matrix(300,60:)); call makesca(xx :file 'full.fsv' :member mm :add); call cleardat; call getsca('full.fsv' :member test); call print(mean(gasin)); b34srun; /; /;MANUAL Call Manual => Get into interactive mode /; b34sexec matrix ; * Illustrates Running in Manual Mode.; n=6; v=rn(vector(n:)); sin=dsin(grid(.1 40.,.1)); cos=dcos(grid(.1 40.,.1)); call graph(sin, cos:heading 'This graphs sin and cos'); i=idint(array(3:3,2,4)); call print(v,i); * We jump into manual mode here; call manual; * We are back in run mode here; x=rn(matrix(n,n:)); call print(x); b34srun; /; /;MARS MARS Under Matrix /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call olsq(gasout gasin{1 to 6} gasout{1 to 6} :print); call graph(%res :heading 'Residual from OLS 1-6'); call graph(%y %yhat:heading 'Fit from OLS 1-6'); call mars(gasout gasin{1 to 6} gasout{1 to 6} :print); call names(all); call graph(%res :heading 'Residual from Mars 1-6'); call graph(%y %yhat:heading 'Fit from Mars 1-6'); call mars(gasout gasin{1 to 6} gasout{1 to 6} :nk 80 :mi 3 :print); call names(all); call graph(%res :heading 'Residual from :nk 80 :mi 3 Mars 1-6'); call graph(%y %yhat:heading 'Fit from :nk 80 :mi 3 Mars 1-6'); b34srun; /; /;MARS_2 Data from Friedman /; b34sexec options ginclude('b34sdata.mac') member(friedman); b34srun; b34sexec matrix; call loaddata; call olsq(y x1 x2 x3 x4 x5 :print); call graph(%res :heading 'Residual from ols '); call graph(%y %yhat:heading 'Fit from ols '); olsres=%res; call mars(y x1 x2 x3 x4 x5 :print); call graph(%res :heading 'Residual from Mars '); call graph(%y %yhat:heading 'Fit from Mars '); marsres=%res; call graph(olsres marsres :heading 'OLS vs MARS'); b34srun; /; /;MARS_3 Advanced Forecasting /; /$ Job shows an estimate and a forecast b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; * We forecast the last 10 insample data points ; npred=10; call echooff; xin=matrix(npred,1:); nn=norows(gasout)-npred; do i=1,npred; xin(i,1)=gasin(nn+i); enddo; call print(xin ); call names(all); call mars(gasout gasin :print :forecast xin ); call tabulate(%y %yhat %res gasout gasin); call tabulate(%fore %foreobs); b34srun; /$ Job shows an estimate and a model save b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call open(60,'junk.mod'); call mars(gasout gasin :print :savemodel :murewind); b34srun; /$ now see if can get model b34sexec matrix; call loaddata; * We forecast the last 10 insample data points ; npred=10; call echooff; xin=matrix(npred,1:); nn=norows(gasout)-npred; do i=1,npred; xin(i,1)=gasin(nn+i); enddo; call print(xin ); call names(all); call mars(gasout gasin :print :getmodel :forecast xin ); call tabulate(%fore %foreobs); b34srun; /; /;MARS_4 Graphs of Curves and Surfaces /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; /$ /$ Job MARS_4B shows the automatic plot program MARSPLOT /$ b34sexec matrix; call loaddata; call mars(gasout gasin{1 to 6} gasout{1 to 6} :ngc 100 :ngs 200 :graph :mi 2 :nk 15 :print); call print('%ns ',%ns); call print('%nc ',%nc); call tabulate(%y %yhat %res); call names(all); call echooff; /$ /$ This illustrates the logic of MARSPLOT /$ i=integers(1,%ngc*2*%nc); bigm=matrix(%ngc,2*%nc: %crv(i)); ii_=0; do ii=1,%nc,2; ii_=ii_+1; m1=submatrix(bigm,1,%ngc,ii,ii+1); call char1(cc,'Curve Plot '); call inttostr(ii_,cc2,'(i4)'); ii2=integers(4); ii3=ii2+11; cc(ii3)=cc2(ii2); call graph(m1 :plottype meshstepc /$ :plottype meshc :grid :d3axis :d3border :heading cc); enddo; i=integers(1,%ngs*%ngs*%ns); bigm=matrix(%ngs,%ngs*%ns:%srf(i)); do ii=1,%ns; icol1=1+((ii-1)*%ngs); icol2=icol1+%ngs-1; m1=submatrix(bigm,1,%ngs,icol1,icol2); call char1(cc,'Surface Plot '); call inttostr(ii,cc2,'(i4)'); ii2=integers(4); ii3=ii2+13; cc(ii3)=cc2(ii2); call graph(m1 :plottype meshc /$ :plottype meshstepc :grid :d3axis :d3border :plottype meshc :heading cc); enddo; b34srun; /; /;MARS_4B Plots Curves and Surfaces using MARSPLOT /; b34sexec options ginclude('b34sdata.mac') member(friedman); b34srun; b34sexec matrix; call loaddata; call load(marsplot); call olsq(y x1 x2 x3 x4 x5 :print); call graph(%res :heading 'Residual from ols '); call graph(%y %yhat:heading 'Fit from ols '); olsres=%res; call mars(y x1 x2 x3 x4 x5 :graph :mi 2 :nk 15 :print); call graph(%res :heading 'Residual from Mars '); call graph(%y %yhat:heading 'Fit from Mars '); marsres=%res; call graph(olsres marsres :heading 'OLS vs MARS'); call echooff; call marsplot; b34srun; /; /;MARS_5 Effect of NK on Residual Variance /; /$ /$ Shows effect of NK of residual variance /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call echooff; call olsq(gasout gasout{1 to 6} gasin{1 to 6} :print); nn=25; nk=integers(nn); resvar=array(nn:); do i=1,nn; call mars(gasout gasout{1 to 6} gasin{1 to 6} :mi 3:nk i ); resvar(i)=%resvar; enddo; call tabulate(nk,resvar); call graph(resvar); b34srun; /; /;MARS_6 3D Plots RESVAR=f(NK,lag,mi) /; /$ /$ Shows effect of NK of residual variance & lags /$ Try various MAXMI values /$ maxmi=1 and maxmi=2 are of interest /$ /$ As set up Job runs nn*lag MARS models or 250 /$ /$ Hooks are in place to run the OLS Version. /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call echooff; call olsq(gasout gasout{1 to 6} gasin{1 to 6} :print); nn=25; lag=10; maxmi=1; rss =array(lag,nn:); do j=1,lag; do i=1,nn; call mars(gasout gasout{1 to j} gasin{1 to j} :mi maxmi :nk i ); rss(j,i)=%rss ; enddo; enddo; /$ 123456789012345678901234567890123456 call character(cc,'Lags - Knots - Degree '); call inttostr(1, n1,'(i1)'); call inttostr(norows(rss),n2,'(i2)'); call inttostr(1, n3,'(i2)'); call inttostr(nocols(rss),n4,'(i2)'); cc =place(n1, 7, 7,cc); cc =place(n2, 9,10,cc); cc =place(n3,19,20,cc); cc =place(n4,22,23,cc); call inttostr(0,nn,'(i3)'); cc =place(nn,32,34,cc); call graph(rss :plottype meshc :grid :d3axis d3border :rotation 0. :heading cc); call inttostr(90,nn,'(i3)'); cc =place(nn,32,34,cc); call graph(rss :plottype meshc :grid :d3axis d3border :rotation 90. :heading cc); call inttostr(180,nn,'(i3)'); cc =place(nn,32,34,cc); call graph(rss :plottype meshc :grid :d3axis d3border :rotation 180. :heading cc); call inttostr(270,nn,'(i3)'); cc =place(nn,32,34,cc); call graph(rss :plottype meshc :grid :d3axis d3border :rotation 270. :heading cc); call graph(submatrix(rss,2,norows(rss),3,25) :plottype meshc :grid :d3axis d3border :rotation 0. :heading 'submatrix(rss,2,norows(resvar),3,25)'); call print(rss); call checkpoint; b34srun; b34sexec matrix; call loaddata; call echooff; nn=15; lag=15; rss=array(nn,lag:); do j=1,lag; do i=1,nn; call olsq(gasout gasout{1 to j} gasin{1 to i}); rss(i,j)=%rss; enddo; enddo; call graph(rss :plottype meshc :grid :d3axis d3border :rotation 0. :heading 'Full lags displayed 0.0 degrees'); call graph(rss :plottype meshc :grid :d3axis d3border :rotation 90. :heading 'Full lags displayed 90. degrees'); call graph(rss :plottype meshc :grid :d3axis d3border :rotation 180. :heading 'Full lags displayed 180 degrees'); call graph(rss :plottype meshc :grid :d3axis d3border :rotation 270. :heading 'Full lags displayed 270. degrees'); do i=1,10; /$ 123456789012345678901234567890123456 call character(cc,'X lags - Y lags - '); call inttostr(i, n1,'(i2)'); call inttostr(norows(rss),n2,'(i2)'); call inttostr(i, n3,'(i2)'); call inttostr(nocols(rss),n4,'(i2)'); cc =place(n1,10,11,cc); cc =place(n2,13,14,cc); cc =place(n3,29,30,cc); cc =place(n4,32,33,cc); call graph(submatrix(rss,i,norows(rss),i,nocols(rss)) :plottype meshc :grid :d3axis d3border :rotation 0. :heading cc); enddo; call print(rss); call checkpoint; b34srun; /; /;MASKADD Illustrates Mask Add /; b34sexec matrix; c1='a cdefg'; c2=' bcd fg'; newc=maskadd(c1,c2); call print(c1,c2,newc); call character(cc1,'abcd fghijklmnopqrst'); call character(cc2,'ab defghijklmnopqrst'); call print(cc1,cc2,maskadd(cc1,cc2)); newc=masksub(c1,c2); call print(c1,c2,newc); call print(cc1,cc2,masksub(cc1,cc2)); b34srun; /; /;MASKSUB Illustrates Mask Subtract /; b34sexec matrix; c1='a cdefg'; c2=' bcd fg'; newc=maskadd(c1,c2); call print(c1,c2,newc); call character(cc1,'abcd fghijklmnopqrst'); call character(cc2,'ab defghijklmnopqrst'); call print(cc1,cc2,maskadd(cc1,cc2)); newc=masksub(c1,c2); call print(c1,c2,newc); call print(cc1,cc2,masksub(cc1,cc2)); b34srun; /; /;MATH1 Illustrates matrix command math /; b34sexec matrix; * Math with matrix and vectors ; * For bigger problems, change n; n=3; right=integers(1,((n*n)-1))+10; call print('Right ',right); x=matrix(n,n:right,-7); x2=x*2.; v=vector(n:integers(1,n)); call print('X, 2*x v' ,x,x2,v) ; call print('Inverse of x (INV)' ,(1./x)) ; call print('X*inv' ,x*(1./x)); call print('Vector times matrix (v*x)' ,v*x) ; call print('Matrix times vector (x*v)' ,x*v) ; call print('Matrix times matrix (x*x2)' ,x*x2) ; call print('Matrix times scaler (x*2.)' ,x*2.) ; call print('Scaler times Matrix (3.*x)' ,3.*x) ; call print('Vector plus matrix (v+x)' ,v+x) ; call print('Matrix plus vector (x+v)' ,x+v) ; call print('Matrix plus matrix (x+x2)' ,x+x2) ; call print('Matrix plus scaler (x+2.)' ,x+2.) ; call print('Scaler plus matrix (3.+x)' ,3.+x) ; call print('Vector minus matrix (v-x)' ,v-x) ; call print('Matrix minus vector (x-v)' ,x-v) ; call print('Matrix minus matrix (x-x2)' ,x-x2) ; call print('Matrix minus scaler (x-2.)' ,x-2.) ; call print('Scaler minus matrix (3.-x)' ,3.-x) ; call print('Array Math Here '); x=afam(x); v=afam(v); x2=x*2.; call print('X, 2*x v' ,x,x2,v) ; call print('Inverse of x (INV)' ,(1./x)) ; call print('X*inv' ,x*(1./x)); call print('Array(1) times Array(2) (v*x)' ,v*x) ; call print('Array(2) times Array(1) (x*v)' ,x*v) ; call print('Array(2) times Array(2) (x*x2)' ,x*x2) ; call print('Array(2) times Scaler (x*2.)' ,x*2.) ; call print('Scaler times Array(2) (3.*x)' ,3.*x) ; call print('Array(1) plus Array(2) (v+x)' ,v+x) ; call print('Array(2) plus Array(1) (x+v)' ,x+v) ; call print('Array(2) plus Array(2) (x+x2)' ,x+x2) ; call print('Array(2) plus Scaler (x+2.)' ,x+2.) ; call print('Scaler plus Array(2) (3.+x)' ,3.+x) ; call print('Array(1) minus Array(2) (v-x)' ,v-x) ; call print('Array(2) minus Array(1) (x-v)' ,x-v) ; call print('Array(2) minus Array(2) (x-x2)' ,x-x2) ; call print('Array(2) minus scaler (x-2.)' ,x-2.) ; call print('Scaler minus Array(2) (3.-x)' ,3.-x) ; call print(' Complex Results ' '++++++++++++++++++++++++++++++++++++++++'); x=mfam(complex(x,x2)); v=vfam(complex(v,v+8.0)); x2=mfam(complex(x2)); call print('X, x2 v' ,x,x2,v) ; call print('Inverse of x (INV)' , (complex(1.)/x)) ; call print('X*inv' , x*(complex(1.)/x)); call print('Vector times matrix (v*x)' ,v*x) ; call print('Matrix times vector (x*v)' ,x*v) ; call print('Matrix times matrix (x*x2)' ,x*x2) ; call print('Matrix times scaler (x*2.)',x*complex(2.)) ; call print('Scaler times Matrix (3.*x)',complex(3.)*x) ; call print('Vector plus matrix (v+x)',v+x) ; call print('Matrix plus vector (x+v)',x+v) ; call print('Matrix plus matrix (x+x2)',x+x2) ; call print('Matrix plus scaler (x+2.)',x+complex(2.)) ; call print('Scaler plus matrix (3.+x)',complex(3.)+x) ; call print('Vector minus matrix (v-x)',,v-x) ; call print('Matrix minus vector (x-v)' ,x-v) ; call print('Matrix minus matrix (x-x2)',x-x2) ; call print('Matrix minus scaler (x-2.)',x-complex(2.)) ; call print('Scaler minus matrix (3.-x)',complex(3.)-x) ; call print('Array Math Here '); x=afam(x); v=afam(v); x2=afam(x2); call print('X, 2*x v' ,x,x2,v) ; call print('Inverse of x (INV)', (complex(1.)/x)) ; call print('X*inv' , x*(complex(1.)/x)); call print('Array(1) times Array(2) (v*x)' ,v*x) ; call print('Array(2) times Array(1) (x*v)' ,x*v) ; call print('Array(2) times Array(2) (x*x2)' ,x*x2) ; call print('Array(2) times Scaler (x*complex(2.))',x*complex(2.)); call print('Scaler times Array(2) (complex(3.)*x)',complex(3.)*x); call print('Array(1) plus Array(2) (v+x)' ,v+x) ; call print('Array(2) plus Array(1) (x+v)' ,x+v) ; call print('Array(2) plus Array(2) (x+x2)' ,x+x2) ; call print('Array(2) plus Scaler (x+complex(2.))',x+complex(2.)); call print('Scaler plus Array(2) (complex(3.)+x)',complex(3.)+x); call print('Array(1) minus Array(2) (v-x)' ,v-x) ; call print('Array(2) minus Array(1) (x-v)' ,x-v) ; call print('Array(2) minus Array(2) (x-x2)' ,x-x2) ; call print('Array(2) minus scaler (x-complex(2.))',x-complex(2.)); call print('Scaler minus Array(2) (complex(3.)-x)',complex(3.)-x); * Matrix Power Calculations ; x=rn(matrix(3,3:)); call print(x,x*x,x**2.); e1=eig(x,c1); cc=c1(1,1); call print(cc,cc*complex(2.)); call print(c1); call print(c1**2.); call print(c1*c1); call print(c1**complex( 2.0)); call print(c1**complex( 2.2)); call print(c1**complex(-2.2)); * Array Tests ; x=afam(x); c1=afam(c1); call print(x,x*x,x**2.); cc=c1(1,1); call print(cc,cc*complex(2.)); call print(c1); call print(c1**complex(2.)); call print(c1*c1); * tests run with a defective matrix from Matlab ; defmat=matrix(3,3: 6., 12., 19. , -9.,-20.,-33., 4., 9., 15.); call print(defmat,defmat*defmat,defmat**2.); call print(complex(defmat)**complex( 2.)); call print(complex(defmat)**complex( 2.2)); call print(complex(defmat)**complex( -2.2)); call print(complex(defmat)**complex( 102.)); call print(complex(defmat)**complex( 102.2)); call print(complex(defmat)**complex(-102.2)); b34srun; /; /;MATH2 Logic Math Examples /; b34sexec matrix; * Tests Logical math; x=2.0; y= x.eq.1.0; y2=x.eq.2.0; call print(x,y,y2); call names(all); a1=array(:0 1 1); a2=array(:0 1 2); test=a1.eq.a2; call print('Test will = 1 if a1 = a2'); call tabulate(a1 a2 test); a1=namelist(judy mary sue); a2=namelist(judy Diana sue); test=a1.eq.a2; call print('Test will = 1 if a1 = a2'); call tabulate(a1 a2 test); z=1.0; y3=1.0; isitone1=z.or.y3; isitzero=y2.and.y; isitone=z.and.y2; call print(isitone,isitone1,isitzero); * If this statemented is uncommented it will return an error; * since x ne 0 or 1; * bad=x.and.y; b34srun; /; /;MATH3 Tests Logic Processing /; b34sexec matrix; x=array(:1,-2,3,-4,5,-6,7,-8,9,-10); y=array(:0,-2,1,-4,6,-6,2,-8,5,-10); z=array(:1, 2,3, 4,5, 6,7,9,90,-10); yhold=array(norows(x):); m99=yhold; call setcol(m99,1,-99.); xyz_and_=m99; xy_or_xz=m99; yhold=m99; where(x.ne.y)yhold=y; where(x.eq.y)q=y; x_eq_y=x.eq.y; xy_or_xz=x.eq.y.or.x.eq.z; xyz_and_=x.eq.y.and.x.eq.z; call tabulate(x,y,z,x_eq_y,xy_or_xz,xyz_and_); xyz_and_=m99; xy_or_xz=m99; where(x.eq.y.and.x.eq.z)xyz_and_=y; where(x.eq.y.or.x.eq.z)xy_or_xz=y; call print('We set yhold = -99 where x = y', 'We set yhold = y where x ne y', 'We set q = y where x = y', 'We set q = 0 where x ne y'); call tabulate(y,x,z,yhold,q,xyz_and_,xy_or_xz); x=array(:1 2 3 4 5 6 7 8 9 -10); y=array(:1 2 30 4 4 6 7 8 9 -10); x_gt_y=m99; x_ge_y=m99; x_eq_y=m99; x_lt_y=m99; x_le_y=m99; x_gt_y=x.gt.y; x_ge_y=x.ge.y; x_eq_y=x.eq.y; x_lt_y=x.lt.y; x_le_y=x.le.y; call tabulate(x,y,x_gt_y,x_ge_y,x_eq_y,x_lt_y,x_le_y); b34srun; /; /;MATH4 Simple test cases showing variable storage /; /$ Job shows location of vector copies into existing /$ variable locations b34sexec matrix; x=dfloat(integers(20)); call print(x); call names(all); y=50.; x(3)=y; call names(all); call print(x); x(21)=y+10.; call names(all); call print(x); z=x; call names(all); x=x*2.; z=x; call names(all); call print(z); * show effect of integer placement; yi=50; x(3)=yi; call print('Note that array is all zero except location 3',x); b34srun; /; /;MATH5 Array addressing Examples /; /$b34sexec options debugsubs(b34smat06,b34smat12b); b34srun; b34sexec matrix; nn=4; /$ itest1 and itest2 trap error conditions itest1=0; itest2=0; x=array(:1 2 3 4 5); call print(x); x(6)=99.; j=integers(5); call print(x); x(j)=5.; call print(x); x=rn(matrix(nn,nn:)); holdx=x; call print('x before copy ',x); x(2,)=1.0; call print('row scaler copy',x); x=holdx; call print('x before copy',x); x(2,)=vector(:integers(nn)); call print('row vector copy',x); x=holdx; call print('x before copy ',x); x(2,2)=99.; call print('x(2,2)=99.; copy',x); x=holdx; call print('x before copy ',x); x(,1)=99.; call print('col scaler copy',x); x=holdx; call print('x before copy'); x(,1)=vector(:integers(nn)); call print('col vector copy',x); x=rn(matrix(nn,nn:)); holdx=x; call print('x before structured copy',x); jj=integers(nn); x(2,jj)=88.; call print(x); x=holdx; x(jj,2)=77.; call print(x); jj=integers(2,nn); x(2,jj)=88.; call print('subset copy 2-4',x); x=holdx; x(jj,2)=77.; call print('subset copy 2-4',x); /$ Short case -- if run gets an error message if(itest1.eq.1)then; call print('Subset of y copied *************'); y=array(:11. 22. 33. .88888); ii=integers(2,4); x=array(:1 2 3 4 5 6 7); call print(x); x(ii)=y; call print('Subset of y copied',x,ii,y); endif; /$Long case -- if run gets an error message if(itest2.eq.1)then; call print('More than length of y copied ***************'); y=array(:11. 22. 33. .88888); ii=integers(2,10); x=array(:1 2 3 4 5 6 7); call print(x); x(ii)=y; call print('More than y copied',x,ii,y); endif; b34srun; /; /;MATH6 Real*16 Complex*32 /; /$ Illustrates Real*16 and Complex*32 Processing b34sexec matrix; n=4; ncase=1; x=rn(matrix(n,n:)); y=rn(x); xty=x*y; call print(x,y,xty); r16x=r8tor16(x); r16y=r8tor16(y); r16xty=r16x*r16y; call print(r16x,r16y,r16xty); diff=xty-r16tor8(r16xty); call print('Difference',diff); call print('Transpose test',transpose(x),transpose(r16x)); v8=rn(vector(9:)); c16=complex(v8,2.*v8); call print('Are these the same?',c16,c16toc32(c16)); v16=r8tor16(v8); call print(v16); call print(r8tor16(2.)*v16); c32=qcomplex(v16,r8tor16(2.)*v16); c16m=complex(x,y); c32m=qcomplex(r16x,r16y); call print('are these the same?',c16m,c32m); call tabulate(v8,v16,c16,c32); do i=1,ncase; x=rn(x); r16x=r8tor16(x); c16x= complex(x); c32x=qcomplex(r16x); call print('In real*16 real*8 complex*32 complex*16',r16x,x,c32x,c16x); ix=inv(x); ir16x=inv(r16x); ic16x=inv(c16x); ic32x=inv(c32x); call print('Inverse real*16 real*8 complex*32 complex*16', ir16x,ix,ic32x,ic16x); call print('errors of inverse' x*ix,r16x*ir16x,c16x*ic16x,c32x*ic32x); /$ SM Problems x=rn(matrix(n,n:)); x=transpose(x)*x; r16x=r8tor16(x); call print(inv(x :smat)); call print(inv(r16x:smat)); cx=complex(x); cx32=c16toc32(cx); call print(inv(cx :smat)); call print(inv(cx32:smat)); call print((inv(cx) -inv(cx:smat))); call print((inv(cx32)-inv(cx32:smat))); /$ PD problems pdx=transpose(x)*x; pdxr16=transpose(r16x)*r16x; call print(inv(pdx), inv(pdxr16)); call print(inv(pdx:pdmat),inv(pdxr16:pdmat)); pdc16x=dconj(transpose(c16x))*c16x; pdc32x=dconj(transpose(c32x))*c32x; call print(inv(pdc16x), inv(pdc32x)); call print(inv(pdc16x:pdmat),inv(pdc32x:pdmat)); /$ Test inline inverse test1=kindas(r16x,1.0)/r16x; ir16x=inv(r16x); call print(test1,ir16x); test2=kindas(c16x,complex(1.0))/c16x; ic16x=inv(c16x); call print(test2,ic16x); enddo; b34srun; /; /;MATHR16C32 Math with Real*16 and Complex*32 /; b34sexec matrix showuse; do i=1,1; n=7; x=rn(matrix(n,n:)); y=rn(x); xty=x*y; call print(x,y,xty); r16x=r8tor16(x); r16y=r8tor16(y); r16xty=r16x*r16y; call print(r16x,r16y,r16xty); diff=xty-r16tor8(r16xty); call print('Difference',diff); call print('Transpose test',transpose(x),transpose(r16x)); v8=rn(vector(n:)); call print(v8,v8*v8,afam(v8)*afam(v8)); a8=afam(v8); a8_2=a8/kindas(a8,2.); call tabulate(a8,a8_2); two= 2.; four=4.; call print('Is this 6? ', r8tor16(two)+ r8tor16(four):); call print('Is this -2?',r8tor16(two)- r8tor16(four) :); call print('Is this 8? ',r8tor16(two)* r8tor16(four) :); call print('Is this .5?',r8tor16(two)/ r8tor16(four) :); call print('Is this 16?',r8tor16(two)**r8tor16(four) :); two =complex(two); four =complex(four); call print('Two and four',two,four); call names(all); call print(c16toc32(two)+ c16toc32(four)); call print(c16toc32(two)- c16toc32(four)); call print(c16toc32(two)* c16toc32(four)); call print(c16toc32(two)/ c16toc32(four)); call print(c16toc32(two)**c16toc32(four)); call print('Complex*16 math ok!!',two**four:); two= array(4:1 2 3 4); four=4.; call print(r8tor16(two)+ r8tor16(four)); call print(r8tor16(two)- r8tor16(four)); call print(r8tor16(two)* r8tor16(four)); call print(r8tor16(two)/ r8tor16(four)); call print(r8tor16(two)**r8tor16(four)); two =complex(two); four =complex(four); call print(c16toc32(two)+ c16toc32(four)); call print(c16toc32(two)- c16toc32(four)); call print(c16toc32(two)* c16toc32(four)); call print(c16toc32(two)/ c16toc32(four)); call print(c16toc32(two)**c16toc32(four)); call print('Complex*16 math ok!!',two**four); two= array(2:10 20); four=array(2:1 2); call print(r8tor16(two)+ r8tor16(four)); call print(r8tor16(two)- r8tor16(four)); call print(r8tor16(two)* r8tor16(four)); call print(r8tor16(two)/ r8tor16(four)); call print(r8tor16(two)**r8tor16(four)); two =complex(two); four =complex(four); call print(c16toc32(two)+ c16toc32(four)); call print(c16toc32(two)- c16toc32(four)); call print(c16toc32(two)* c16toc32(four)); call print(c16toc32(two)/ c16toc32(four)); call print(c16toc32(two)**c16toc32(four)); call print('Complex*16 math ok!! ',two**four); enddo; b34srun; /; /;MATH16_32 Illustrates gain from real*16/Comples*32 /; b34sexec matrix; * Test case for Real Matrix from IMSL Math (10) pp 295-297; * eig => matlab notation; * eigenval => speakeasy notation; a=matrix(3,3:8.,-1.,-5.,-4., 4.,-2.,18.,-5.,-7.); call print('A Matrix',a); call print('eig(a)',eig(a)); e=eig(a,evec); call print('Eigenvalues of a', e, 'Sum of the eigenvalues of General Martix A',sum(e), 'Trace of General Matrix A',trace(a), 'Product of the eigenvalues of Martix A',prod(e), 'Determinant of Matrix A',det(a) 'Test Factorization evec*diagmat(e)*inv(evec)' evec*diagmat(e)*inv(evec)); * real*16 case; r16a=r8tor16(a); call print('eig(r16a)',eig(r16a)); r16e=eig(r16a,r16evec); call print(r16e,r16a,r16evec); call print('Eigenvalues of r16a', r16e, 'Sum of the eigenvalues of General Martix A',sum(r16e), 'Trace of General Matrix A',trace(r16a), 'Product of the eigenvalues of Martix A',prod(r16e), 'Determinant of Matrix A',det(r16a) 'Test Factorization evec*diagmat(e)*inv(evec)' r16evec*diagmat(r16e)*inv(r16evec)); * Complex Case See IMSL Math (10) pp 302-304 ; r=matrix(4,4:5., 5.,-6.,-7., 3., 6.,-5.,-6., 2., 3.,-1.,-5., 1., 2.,-3.,0.0); i=matrix(4,4:9., 5.,-6.,-7., 3.,10.,-5.,-6., 2., 3., 3.,-5., 1., 2.,-3., 4.); ca=complex(r,i); call print('CA Complex Matrix',ca); call print('eig(ca)',eig(ca)); ce=eig(ca,cevec); call print('Eigenvectors of CA',cevec); call print('Eigenvalues of ca', ce, 'Sum of the eigenvalues of General Martix CA',sum(ce), 'Trace of General Matrix CA',trace(ca), 'Product of the eigenvalues of Martix CA',prod(ce), 'Determinant of Matrix CA',det(ca) 'Test Factorization evec*diagmat(ee)*inv(evec)' cevec*diagmat(ce)*inv(cevec) ); * Complex*32 case; c32ca=c16toc32(ca); call print('CA Complex Matrix',c32ca); call print('eig(c32ca)',eig(c32ca)); c32ce=eig(c32ca,c32cevec); call print('Eigenvectors of c32CA',c32cevec); call print('Eigenvalues of c32ca', c32ce, 'Sum of the eigenvalues of General Martix CA',sum(c32ce), 'Trace of General Matrix CA',trace(c32ca), 'Product of the eigenvalues of Martix CA',prod(c32ce), 'Determinant of Matrix CA',det(c32ca) 'Test Factorization evec*diagmat(ee)*inv(evec)' c32cevec*diagmat(c32ce)*inv(c32cevec) ); * Inversion tests ; n=6; x=rn(matrix(n,n:)); ix=inv(x); r16x=r8tor16(x); ir16x=inv(r16x); call print(x,ix,ir16x,x*ix,r16x*ir16x); b34srun; /; /;MATRIX MATRIX function => input a matrix /; b34sexec matrix$ x=matrix(3,3:); call print(x); x1=matrix(3,3:1 2 3 4 5 6 7 8 9); tx=matrix(3,3:x1); call print(x1,tx); v=vector(4:1 2 3 4); xx=matrix(2,2:v); xx2=matrix(2,2:v+2.); cx=complex(xx,xx2); call print(xx); call print(cx); * Advanced tricks ; x=matrix(3,3:1 2 3 4 5 6 7 8 9); v=vector(:1 2 3 4 5 6 7 8 9); xx=matrix(3,3:v); xx2=matrix(9,1:xx); xx3=matrix(3,3:xx2); call print(x,v,xx,xx2,xx3); b34srun; /; /;MAX2_C Maximize using User supplied Gradiant /; b34sexec matrix; * MAXF2 is used to minimize a function ; * Answers should be x1=.9999 and x2=.9999 ; * Problem uses user gradiant - goes fast !! ; * Problem is classic Rosenbrock banana problem. ; * Problem used as a test case in IMSL and in MATLAB fmins function ; program test; func=-1.0*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; program der; g(1)= (400.0*(x2-x1*x1)*x1) + (2.*(1.0-x1)); g(2)= -200.0*(x2-x1*x1); return; end; call print(test,der); rvec=array(2:-1.2 1.0); call echooff; call maxf2(func g :name test der :parms x1 x2 :ivalue rvec :print); b34srun; /; /;MAXF1_2A Uses OLS to validate solution found /; b34sexec options ginclude('gas.b34'); b34srun; /$ Using minimum to solve OLS problem /$ OLSQ used as a test b34sexec matrix; * This test run tests both commands maxf1 and maxf2 ; call loaddata; program test; func=(-1.0)*sumsq(gasout -(a+b*gasin)); call outstring(3, 3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b); return; end; call olsq(gasout gasin :print); rvec=array(2:-1.2, 1.0); call echooff; call maxf1(func :name test :parms a b :ivalue rvec :print); rvec=array(2:-1.2, 1.0); call maxf2(func :name test :parms a b :ivalue rvec :print); b34srun; /; /;MAXF1_2B Generate Data for Maximize - 2 variables models /; /$ Using minimum to solve OLS problem /$ OLSQ used as a test /$ Simple Model used /$ Looking at pattern of estimated SE from MAXF2 b34sexec matrix; program test; func=(-1.0)*sumsq(y -(a+b*x)); call outstring(3, 3,'Function to be minimized'); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b); return; end; n=1000; x=rn(array(n:)); y = 10. + 55. * x + 2.0*rn(x); call olsq(y x :print); rvec=array(2:-1.2, 1.0); call echooff; call maxf1(func :name test :parms a b :ivalue rvec :print); call print(1./mfam(%hessian)); rvec=array(2:-1.2, 1.0); call maxf2(func :name test :parms a b :ivalue rvec :print); call print(1./mfam(%hessian)); b34srun; /; /;MAXF1_2C Using maximize to solve OLS 3 variable problem /; /$ Using minimum to solve OLS 3 variable problem /$ OLSQ used as a test /$ Simple Model used /$ Looking at pattern of estimated SE from MAXF2 b34sexec matrix; program test; func=(-1.0)*sumsq(y -(a+b1*x1+b2*x2)); call outstring(3, 3,'Function to be minimized'); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b1); call outdouble(36,5, b2); return; end; n=10000; x1=rn(array(n:)); x2=rn(array(n:)); y = 10. + 10.*x1 + 5.*x2 + 20.*rn(x1); call olsq(y x1 x2:print); rvec=array(3:-1.2, 1.0, 1.0); call echooff; call maxf1(func :name test :parms a b1 b2 :ivalue rvec :print); call print(1./mfam(%hessian)); rvec=array(3:-1.2, 1.0, 1.0); call maxf2(func :name test :parms a b1 b2 :ivalue rvec :print); call print(1./mfam(%hessian)); b34srun; /; /;MAXF1_A Using MAXF1 to minimize a model /; /$ MAXF1 is used to minimize a function /$ Answers should be x1=.9999 and x2=.9999 /$ /$ Problem is classic Rosenbrock banana problem. /$ Problem used as a test case in IMSL and in MATLAB fmins function /$ b34sexec matrix; * MAXF1 is used to minimize a function ; * Answers should be x1=.9999 and x2=.9999 ; * Problem is classic Rosenbrock banana problem. ; * Problem used as a test case in IMSL and in MATLAB fmins function ; program test; func=-1.0*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function '); call outdouble(36,3 func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; call print(test); rvec=array(2:-1.2 1.0); call echooff; call maxf1(func :name test :parms x1 x2 :ivalue rvec :print); b34srun; /; /;MAXF1_B Minimization using grid search maxf1 tested /; /$ MAXF1 is used to minimize a function /$ NLSTART is used to investigate how answer changes /$ Given different starting values /$ Answers should be x1=.9999 and x2=.9999 /$ /$ Problem is classic Rosenbrock banana problem. /$ Problem used as a test case in IMSL and in MATLAB fmins function /$ b34sexec matrix; * MAXF1 is used to minimize a function ; * Answers should be x1=.9999 and x2=.9999 ; * Problem tests if starting values make a difference ; * Problem is classic Rosenbrock banana problem. ; * Problem used as a test case in IMSL and in MATLAB fmins function ; program test; func=-1.0*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outstring(3,4,'Test case '); call outinteger(36,4,i); call outdouble(4, 5, x1); call outdouble(36,5, x2); return; end; call print(test); n=2; k=10; a=array(n: -3., -3.); b=array(n: 3., 3.); result=array(k:); ak =array(k:); bk =array(k:); call nlstart(a,b,k,s); call print(s); call echooff; do i=1,k; rvec=s(,i); ak(i)=rvec(1); bk(i)=rvec(2); call maxf1(func :name test :parms x1 x2 :ivalue rvec :print); result(i)=%func; enddo; call tabulate(result,ak,bk); call graph(result); b34srun; /; /;MAXF2_A Minimize function /; /$ MAXF2 is used to minimize a function /$ Answers should be x1=.9999 and x2=.9999 b34sexec matrix; * MAXF2 is used to minimize a function ; * Answers should be x1=.9999 and x2=.9999 ; * Problem tests if starting values make a difference ; * Problem is classic Rosenbrock banana problem. ; * Problem used as a test case in IMSL and in MATLAB fmins function ; program test; func=-1.0*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; call print(test); rvec=array(2:-1.2 1.0); call echooff; call maxf2(func :name test :parms x1 x2 :ivalue rvec :print); b34srun; /; /;MAXF2_B Minimize function using range of starting values /; /$ MAXF2 is used to minimize a function /$ NLSTART is used to investigate how answer changes /$ Given different starting values /$ Answers should be x1=.9999 and x2=.9999 /$ b34sexec matrix; * MAXF2 is used to minimize a function ; * Answers should be x1=.9999 and x2=.9999 ; * Problem tests if starting values make a difference ; * Problem is classic Rosenbrock banana problem. ; * Problem used as a test case in IMSL and in MATLAB fmins function ; program test; func=-1.0*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outstring(3,4,'Test case '); call outinteger(36,4,i); call outdouble(4, 5, x1); call outdouble(36,5, x2); return; end; call print(test); n=2; k=10; a=array(n: -3., -3.); b=array(n: 3., 3.); result=array(k:); ak =array(k:); bk =array(k:); coef1 =array(k:); coef2 =array(k:); call nlstart(a,b,k,s); call print(s); call echooff; do i=1,k; rvec=s(,i); ak(i)=rvec(1); bk(i)=rvec(2); call maxf2(func :name test :parms x1 x2 :ivalue rvec :print); result(i)=%func; coef1(i)=%coef(1); coef2(i)=%coef(2); enddo; call tabulate(result,ak,bk,coef1,coef2); call graph(result); call graph(coef1); call graph(coef2); b34srun; /; /;MAXF2_D Min. func. using range of start. val. & user gradiant /; b34sexec matrix; * MAXF2 is used to minimize a function ; * Answers should be x1=.9999 and x2=.9999 ; * Problem tests if starting values make a difference ; * Problem is classic Rosenbrock banana problem. ; * Since user gradiant supplied speed will be fast ; * Problem used as a test case in IMSL and in MATLAB fmins function ; program test; func=-1.0*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outstring(3,4,'Test case '); call outinteger(36,4,i); call outdouble(4, 5, x1); call outdouble(36,5, x2); return; end; program der; g(1)= (400.0*(x2-x1*x1)*x1) + (2.*(1.0-x1)); g(2)= -200.0*(x2-x1*x1); return; end; call print(test,der); n=2; k=10; a=array(n: -3., -3.); b=array(n: 3., 3.); result=array(k:); ak =array(k:); bk =array(k:); coef1 =array(k:); coef2 =array(k:); call nlstart(a,b,k,s); call print(s); call echooff; do i=1,k; rvec=s(,i); ak(i)=rvec(1); bk(i)=rvec(2); call maxf2(func g :name test der :parms x1 x2 :ivalue rvec :print); result(i)=%func; coef1(i)=%coef(1); coef2(i)=%coef(2); enddo; call tabulate(result,ak,bk,coef1,coef2); call graph(result); call graph(coef1); call graph(coef2); b34srun; /; /;MAXF2_E Minimize a two variable exponential Function /; /$ /$ MAXF2 is used to minimize an exponential function /$ b34sexec matrix; * MAXF2 is used to minimize a function ; * Answers should be x1=.5 and x2=1.0 ; * Problem from Matlib Optimization toolbox page 1-6 ; * Problem used as a test case in MATLAB fmins function ; program test; func=-1.0*dexp(x1)*((4.*x1*x1)+(2.*x2*x2)+(4.*x1*x2)+(2.*x2)+1.0); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; call print(test); rvec=array(2:-1., 1.0); call echooff; call maxf2(func :name test :parms x1 x2 :ivalue rvec :print); b34srun; /; /;MAXF3_2A Uses OLS to validate solution found /; b34sexec options ginclude('gas.b34'); b34srun; /$ Using minimum to solve OLS problem /$ OLSQ used as a test b34sexec matrix; * This test run tests both commands maxf1 and maxf2 and maxf3; call loaddata; program test; func=(-1.0)*sumsq(gasout -(a+b*gasin)); call outstring(3, 3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b); return; end; call echooff; call olsq(gasout gasin :print); rvec=array(2:-1.2, 1.0); call maxf1(func :name test :parms a b :ivalue rvec :print); rvec=array(2:-1.2, 1.0); call maxf2(func :name test :parms a b :ivalue rvec :print); rvec=array(2:-1.2, 1.0); call maxf3(func :name test :parms a b :ivalue rvec :maxit 300 :print); b34srun; /; /;MAXF3_2B Generate Data for Maximize /; /$ Using minimum to solve OLS problem /$ OLSQ used as a test /$ Simple Model used b34sexec matrix; program test; func=(-1.0)*sumsq(y -(a+b*x)); call outstring(3, 3,'Function to be minimized'); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b); return; end; n=1000; x=rn(array(n:)); y = 10. + 55. * x + rn(x); call olsq(y x :print); rvec=array(2:-1.2, 1.0); call echooff; call maxf1(func :name test :parms a b :ivalue rvec :print); rvec=array(2:-1.2, 1.0); call maxf2(func :name test :parms a b :ivalue rvec :print); rvec=array(2:-1.2, 1.0); call maxf3(func :name test :parms a b :ivalue rvec :print); b34srun; /; /;MAXF3_a Using MAXF3 to minimize a model /; /$ MAXF1 is used to minimize a function /$ Answers should be x1=.9999 and x2=.9999 /$ /$ Problem is classic Rosenbrock banana problem. /$ Problem used as a test case in IMSL and in MATLAB fmins function /$ b34sexec matrix; * MAXF3 is used to minimize a function ; * Answers should be x1=.9999 and x2=.9999 ; * Problem is classic Rosenbrock banana problem. ; * Problem used as a test case in IMSL and in MATLAB fmins function ; program test; func=-1.0*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function '); call outdouble(36,3 func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; call print(test); rvec=array(2:-1.2 1.0); call echooff; call maxf3(func :name test :parms x1 x2 :ivalue rvec :maxit 400 :print); b34srun; /; /;MAXF3_b Mimimization using grid search maxf3 tested /; /$ MAXF3 is used to minimize a function /$ NLSTART is used to investigate how answer changes /$ Given different starting values /$ Answers should be x1=.9999 and x2=.9999 /$ /$ Problem is classic Rosenbrock banana problem. /$ Problem used as a test case in IMSL and in MATLAB fmins function /$ b34sexec matrix; * MAXF1 is used to minimize a function ; * Answers should be x1=.9999 and x2=.9999 ; * Problem tests if starting values make a difference ; * Problem is classic Rosenbrock banana problem. ; * Problem used as a test case in IMSL and in MATLAB fmins function ; program test; func=-1.0*(100.*(x2-x1*x1)**2. + (1.-x1)**2.); call outstring(3,3,'Function'); call outdouble(36,3,func); call outstring(3,4,'Test case '); call outinteger(36,4,i); call outdouble(4, 5, x1); call outdouble(36,5, x2); return; end; call print(test); n=2; k=10; a=array(n: -3., -3.); b=array(n: 3., 3.); result=array(k:); ak =array(k:); bk =array(k:); call nlstart(a,b,k,s); call print(s); call echooff; do i=1,k; rvec=s(,i); ak(i)=rvec(1); bk(i)=rvec(2); call maxf3(func :name test :parms x1 x2 :ivalue rvec :maxit 400 :print); result(i)=%func; enddo; call tabulate(result,ak,bk); call graph(result); b34srun; %b34sendif; %b34sif(&test4.eq.1)%then; /; /;MAXFTEST Tests OLS with MAXF1,2 /; /$ /$ OLS two ways /$ b34sexec matrix; nob=100000; y=array(nob:); x1=rn(array(nob:)); x2=rn(array(nob:)); y=1.+10.*x1+8.5*x2 + 10.*rn(x1); call olsq(y x1,x2 :print); program test; func=(-1.0)*sumsq(y -(a+b1*x1+b2*x2)); call outstring(3, 3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, a ); call outdouble(26,4, b1); call outdouble(56,4, b2); return; end; call echooff; rvec=array(3:1. 1. 1.); call maxf1(func :name test :parms a b1 b2 :ivalue rvec :print); rvec=array(3:1. 1. 1.); call maxf2(func :name test :parms a b1 b2 :ivalue rvec :print); b34srun; /; /;MAXFTEST_2 Illustrates a Break Point Test Case /; b34sexec options ginclude('b34sdata.mac') member(marsbrk); b34srun; /$ /$ Using minimum to solve OLS problem where there is a break at 5 /$ OLSQ used as a test /$ /$ Simplex is able to find points. When we use maxf2 to refine /$ /$ Model is y = 0.0 + 10.* x if X GT 5 /$ y = 0.0 + 5.* x if X LT 5 /$ /$ Data From Greg Sterijevski Break at 5.0 /$ MARS smooths the kink ************************* b34sexec MARS MI = 2 NK=5 ; model Y = X$ b34seend$ b34sexec reg; model y=x1 x2; b34srun; b34sexec sort; by x; b34srun; /$ /$ List will show that there is no x = 5.0 point !!!! /$ /$ b34sexec list; var x y ; b34srun; /$ b34sexec matrix; * This test run tests both commands maxf1 ,maxf2 and maxf3 ; * maxf3 is needed !!!!!!!!!!!!! ; call loaddata; program test; mask1 = x .gt. break ; mask2 = x .le. break ; func=(-1.0)*sumsq(y -(a+(b1*x*mask1)+(b2*x*mask2))); call outstring(3, 3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b1); call outdouble(4 5, b2); call outdouble(36,4, break); return; end; call print(test); call olsq(y x1 x2 :print); call olsq(y x :print); rvec=array(4: %coef(2),%coef(1),%coef(1),2. ); call print(rvec); call echooff; call maxf1(func :name test :parms a b1 b2 break :ivalue rvec :print); call maxf2(func :name test :parms a b1 b2 break :ivalue rvec :print); * Simplex then use these as starting values ; call maxf3(func :name test :parms a b1 b2 break :ivalue rvec :maxit 1000 :print); rvec=array(4: %coef(1),%coef(2),%coef(3), %coef(4)); call maxf2(func :name test :parms a b1 b2 break :ivalue rvec :print); call tabulate(x mask1,mask2); b34srun; /; /;MAXF_4 Simple Function Maximixe from Greene Page 201 /; b34sexec matrix; * This test run tests both commands maxf1, maxf2 and maxf3 ; * See Greene 4ed page 201 ; * Greene page 202 suggests answer is 2.23607 ; program test; func=dlog(theta)-.1*theta*theta; call outstring(3, 3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, theta); return; end; call echooff; rvec=array(:1.); call maxf1(func :name test :parms theta :ivalue rvec :print); rvec=array(:1.0); call maxf2(func :name test :parms theta :ivalue rvec :print); call maxf3(func :name test :parms theta :ivalue rvec :print); b34srun; /; /;MCLEODLI Tests McLeod-Li Test /; b34sexec options ginclude('gas.b34'); b34srun; /; /; See McLeod-Li 'Diagnostic Checking of ARMA Time Series Models /; Using Square Residual Autocorrelations' /; McLeod, A. & Li, Journal of Time Series /; 4,:3:24 1983 b34sexec matrix; call loaddata; call load(mcleodli); call mcleodli(gasin, 12,12,1); call mcleodli(gasout,12,12,1); call print(%mltest); call tabulate(%res,%ressq2,%acf1); /; Random number tests x=rn(array(10000:)); call mcleodli(x, 12,12,1); call print(%mltest); call mcleodli(x, 100,100,1); call print(%mltest); b34srun; /; /;MEAN MEAN function => average of an object /; b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; mgasin=mean(gasin); mgasout=mean(gasout); call print('Gasin Mean',mgasin); call print('Gasout Mean',mgasout); vgasin=variance(gasin); vgasout=variance(gasout); call print('Gasin Variance',vgasin); call print('Gasout Variance',vgasout); b34srun$ /; /;MELD Melds Vectors /; b34sexec matrix; * Illustrates Two cases; i=array(:1. 2. 3.); j=array(:4.,5.,6.); k=array(:7.,8.,9.); call tabulate(i,j,k); call meld(i,j,k); f=i**2. + j**2. + k**2.; call tabulate(i,j,k,f); i=array(:1. 2. 3. 4.); j=array(:5.,6.,7.,8.); k=array(:9.,10.,11.,12.); call tabulate(i,j,k); call meld(i,j,k); f=i**2. + j**2. + k**2.; call tabulate(i,j,k,f); i=array(:1. 2.); j=array(:1. 2. 3.); k=array(:1. 2. 3. 4. 5.); call meld(i,j,k); f=i**2. + j**2. + k**2.; call tabulate(i,j,k,f); i=array(:1. 2.); j=array(:1. 2. 3.); call meld(i,j); f2=i**2. + j**2.; call graph(i,j,f2:plottype contour3 :d3axis :heading 'f(i**2. + j**2.)':d3border); a1=-.5; a2= .5; b1= .6; b2= 1.8; * Four views of the Banana ; do i=1,4; x=grid(a1,a2,.125); y=grid(b1,b2,.125); call meld(x,y); z=100.*(y-x*x)**2. + (1.-x)**2.; call graph(x,y,z:plottype contour3 :d3border :d3axis :heading 'Rosenbrock Banana'); call graph(x,y,z:plottype contourc :d3border :d3axis :heading 'Rosenbrock Banana'); a1=a1-1.; a2=a2+1.; b1=b1-1.; b2=b2+1.; enddo; b34srun; /; /;MEMORY Shows speed and Memory Savings /; /$ show memory usage /$ Job # 1 is done for speed and memory savings. X is built /$ outside the loop. /$ Job # 2 requires a copy be made and the variable x /$ copied at each step. Job # 1 only moves /$ the new data into the array that is already /$ built. Job # 2 could be compressed if /$ desired by command call compress; /$ b34sexec matrix; n=10; x=array(n:); call names(all); do i=1,n; x(i)=dfloat(i); call names(all); enddo; b34srun; b34sexec matrix; n=10; call names(all); do i=1,n; x(i)=dfloat(i); call names(all); enddo; b34srun; /; /;MENU User Menus including Message /; b34sexec matrix; i1=1; call menu(i1 :menutype menutwo :text 'stop' :text 'go' :prompt 'Continue with graph =>' ); call print('Graph Control',i1:); call outstring(3,,5,'menutwo'); call outinteger(12,5,i1); i2=2; call menu(i2 :menutype menuhoriz :text 'file' :text 'save' :text 'stop' :heading 'Simulated message for menu horiz' ); call print('Process Control',i2:); call outstring(3, 7,'menuvert'); call outinteger(12,7,i2); i3=3; call menu(i3 :menutype menuvert :text 'Use raw data ' :text 'Use (1-B)*X ' :text 'Use (1-B)**2. * X' :heading 'ACF Control' ); call print('ACF Control i was ',i3); call outstring( 3,9,'menuvert'); call outinteger(12,9,i3); i=100; call menu(i :menutype inputint :prompt '# of cases =>' ); call print('Input integer was ',i:); call outstring(3, 11,'Integer*4'); call outinteger(12,11,i); r8=.01; call menu(r8 :menutype inputreal8 :prompt 'Tolerance =>' ); call print('Input real*8 ',r8:); call outstring(3,,13,'Real *8'); call outdouble(12,13,r8); call menu(cc :menutype inputtext :prompt 'Save file name.=>' ); call print('File input found was ',cc); call outstring(3, 15,'File =>'); call outstring(12,15,cc); call message('Illustrates MESSAGE','Testing Message',jj); call print('Message returns',jj); call outinteger(3,17,jj); b34srun; /; /;MESSAGE Screen I/O OUTSTRING/OUTDOUBLE/OUTINTEGER/MESSAGE /; b34sexec matrix; x=matrix(3,3:11 22 33 55 66 77 88 99 00); v=vector(3:1 2 3); call print(x,v); inv=(1./x); call print(inv); test=x*inv; call print(test); vx=v*x; call print(vx); xx=x*x; call print(xx); xv=x*v; call print(xv); call message('Illustrates MESSAGE','Testing Message',jj); call print('Message returns',jj); call cls(3); call outstring(3,3,'This is jj'); call outinteger(30,3,jj); call cls(4); call outstring(3,4,'This is 5'); call outinteger(30,4,5 ); call cls(5); call outstring(3,5,'This is 88.88!!'); call outdouble(40,5,88.8); call cls(6); call outstring(3,6,'We have paused!! Now hit enter.'); /$ This is a pause call stop(pause); b34srun; /; /;MFAM MFAM function => Create a matrix from a 2D array /; b34sexec matrix$ x=array(3,3:); x=rn(x); call print(x); mx=mfam(x); call print(mx); b34srun; /; /;MINIMAX Estimate Minimax with MAXF2 /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call echooff; call loaddata; call olsq(gasout gasin :l1 :minimax :print); /$ This code gets SE for Minimax. Uses MAXF2 call load(minimax); call print(minimax); * See if can get minimax ; iprint=1; y=gasout; x=matrix(norows(gasin),2:); x(,1)=1.0; x(,2)=vfam(gasin); call minimax; call print('Sum absolute errors ',sumabs:); call print('Max absolute error ',maxerror:); b34srun; /; /;MISSING1 Missing values /; b34sexec matrix; x=0.0; xmiss=missing(); call print(x,xmiss); y=grid(1.,20.,1.); oldy=y; do i=1,norows(y); if(dmod(y(i),2.).eq.0.0)y(i)=missing(); enddo; test=ismissing(y); call tabulate(oldy,y,test); b34srun; /; /;MISSING2 Tests on Missing values /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; laggas=lag(gasout,1); test=1.0+laggas; call names; call tabulate(laggas,test); b34srun; b34sexec matrix; * Illustrates missing data calculations; x=rn(array(10:)); lagx=lag(x,1); y=x+(10.*lagx); goody=goodrow(y); test1=dsqrt(dabs(y)); test2=dlog10(dabs(y)); test3=dlog(dabs(y)); call tabulate(x,lagx,y,goody,test1,test2,test3); b34srun; /; /;MISSPLOT_1 Plot of Missing Data /; b34sexec matrix; call load(missplot); y=rn(array(20:)); call character(title,'Test missplot Plot'); y(3)=missing(); points=0; dots=0; noline=0; call missplot(y,points,dots,noline,title); call missplot(y,1 ,dots,noline,title); call missplot(y,points,1 ,noline,title); call missplot(y,1 ,1 ,0 ,title); call missplot(y,1 ,dots,1 ,title); b34srun; /; /;MLSUM MLSUM function => sum log of elements /; b34sexec matrix; * mlsum useful in ML estimation ; * Can also be used to trap bad dlog values ; a=array(5:1 2 3 4 5); s=sum(dlog(a)); call print('Sum of log of 1 2 3 4 5',s,'MLSUM',mlsum(a)); a(2)=-10.; s2=mlsum(a,n); call print('Sum of bad data ',s2,' # bad cases ',n); s2=mlsum(a,n,0.0); call print('Sum of bad data using zero ',s2,' # bad cases ',n); * log 10 cases ; a=array(5:1 2 3 4 5); s=sum(dlog10(a)); call print('Sum of log10 of 1 2 3 4 5',s,'MLSUM',mlsum(a :dlog10)); a(2)=-10.; s2=mlsum(a,n:dlog10); call print('Sum of bad data ',s2,' # bad cases ',n); s2=mlsum(a,n,0.0:dlog10); call print('Sum of bad data using zero ',s2,' # bad cases ',n); * dexp cases ; a=array(5:1 2 3 4 5); s=sum(dexp(a)); call print('Sum of log of 1 2 3 4 5',s,'MLSUM',mlsum(a :dexp)); a(2)=800d+00; s2=mlsum(a,n :dexp); call print('Sum of bad data ',s2,' # bad cases ',n); s2=mlsum(a,n,0.0:dexp); call print('Sum of bad data using zero ',s2,' # bad cases ',n); b34srun$ /; /;MOVEAVE Tests Moving average moving variance /; b34sexec matrix; call echooff; call load(moveave); call load(movevar); n=20; a=array(n:integers(n)); call print('Mean of a',mean(a)); call moveave(a,norows(a),test); call print('Test of MA where use whole period',test); call moveave(a,2,test2); call moveave(a,3,test3); call print('Two & Three period Moving average'); call tabulate(a,test2,test3); call print(a); call print('Variance of a',variance(a)); call movevar(a,norows(a),test); call print('Test of MVAR where use whole period',test); call movevar(a,4,test4); call movevar(a,5,test5); call print('4 & 5 period Moving Variance'); call tabulate(a,test4,test4); b34srun; /; /;MOVEBJ Moving Forecasting Example /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(movebj); call print(movebj); call echooff; nout=1; iseas=0; ibegin=200; iprint=0; call movebj(gasout,iseas,ibegin,actual,fore,obs,nout,iprint); call tabulate(obs,actual,fore); call graph(obs fore,actual :plottype xyplot :nolabel :heading '1 step ahead moving forecast'); nout=3; call movebj(gasout,iseas,ibegin,actual,fore,obs,nout,iprint); call tabulate(obs,actual,fore); call graph(obs fore,actual :plottype xyplot :nolabel :heading '3 step ahead moving forecast'); b34srun; /; /;MOVECOR Tests Moving Correlation /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(movecorr); call echooff; n=60; call movecorr(gasin,gasout,n,cvec,0); call print(cvec); call graph(cvec(,1)); call movecorr(gasin,gasout,n,cvec,10); call print(cvec); call echoon; b34srun; /; /;MOVEH82 Tests moving Hinich 82 test /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call echooff; call loaddata; call load(moveh82); n=200; call moveh82(gasout,n,g1,l1,1); call tabulate(g1,l1); call graph(g1,l1); call echoon; b34srun; /; /;MOVEH96 Tests Moving Hinich 96 test /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(moveh96); call echooff; call olsq(gasout gasout{1 to 12}); call graph(gasout); call graph(%res); n=200; call moveh96(%res,n,0.0,v,h); call tabulate(v,h); call graph(v,h); call echoon; b34srun; /; /;MOVELEFT Tests moveleft / moveright /; b34sexec matrix; call character(cc2,'abcdefghijklmnop'); test='12345678'; call print(test,'right 4',moveright(test,4),'left 3',moveleft(test,3)); do i=1,10; newcc2=moveleft(cc2,i); call print('Moveleft',cc2,i,newcc2); enddo; do i=1,10; newcc2=moveright(cc2,i); call print('Moveright',cc2,i,newcc2); enddo; b34srun; /; /;MOVEOLS Tests Moving OLS /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(moveols); call echooff; n=60; call moveols(gasout,gasin,n,rss,rsq,resvar,6,1); call tabulate(rss,rsq,resvar); call graph(rss :heading 'Moving rss for gasout'); call graph(rsq :heading 'Moving R**2 for gasout'); call graph(resvar :heading 'Moving resvar for gasout'); call echoon; b34srun; /; /;MOVERIGHT Tests moveleft / moveright /; b34sexec matrix; call character(cc2,'abcdefghijklmnop'); test='12345678'; call print(test,'right 4',moveright(test,4),'left 3',moveleft(test,3)); do i=1,10; newcc2=moveleft(cc2,i); call print('Moveleft',cc2,i,newcc2); enddo; do i=1,10; newcc2=moveright(cc2,i); call print('Moveright',cc2,i,newcc2); enddo; b34srun; /; /;MOVEVAR Tests Moving average moving variance /; b34sexec matrix; call echooff; call load(moveave); call load(movevar); n=20; a=array(n:integers(n)); call print('Mean of a',mean(a)); call moveave(a,norows(a),test); call print('Test of MA where use whole period',test); call moveave(a,2,test2); call moveave(a,3,test3); call print('Two & Three period Moving average'); call tabulate(a,test2,test3); call print(a); call print('Variance of a',variance(a)); call movevar(a,norows(a),test); call print('Test of MVAR where use whole period',test); call movevar(a,4,test4); call movevar(a,5,test5); call print('4 & 5 period Moving Variance'); call tabulate(a,test4,test4); b34srun; /; /;MQSTAT Multivariate Q Statistic /; b34sexec scaio readsca /$ file('/usr/local/lib/b34slm/findat01.mad') file('c:\b34slm\findat01.mad') dataset(m_ibmln2); b34srun; /$ /$ For further detail on this procedure see Tsay (2002) page 302-308 b34sexec matrix; call loaddata; x=array(norows(ibmln),2:); x(,1)=ibmln; x(,2)=spln; call mqstat(x,12 :print :squared :npar 4); call tabulate(%df %qorg1 %sqorg1 %qnew1 %sqnew1 %qstar1 %sqstar1); call tabulate(%df %qorg2 %sqorg2 %qnew2 %sqnew2 %qstar2 %sqstar2); b34srun; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(varest); call load(buildlag); call echooff; x=catcol(gasin,gasout); call print('Looking at raw data':); call mqstat(x,12 :print); nlag=6; ibegin1=1; iend2=norows(x); iprint=1; call print('Looking at the residuals':); call varest(x,nlag,ibegin1,iend2,beta,t,sigma,corr,resid,iprint, a,ia,varx,varxhat,rsq); call mqstat(resid,nlag :print); b34srun; /; /;M_MATLAB Matlab / Matrix Script /; /$ Running Matlab script under B34S Matrix b34sexec options; pgmcards; x=rand(6) xi=inv(x); x*xi yy=[1 2 3 2 1] plot(yy) pause quit b34sreturn; b34srun; b34sexec matrix; call open(77,'test.m'); call rewind(77); call rewind(4); call copyf(4,77); call close(77); call copyout('test.m'); b34srun; /; /;NAMELIST NAMELIST function => Save names /; b34sexec matrix; * Note: if use form names=namelist( ) will lose call names( ) ; weight=array(4:180.,120.,125.,128.); namesl=namelist(John Sue Carol Diana); call names; call names(all); call tabulate(namesl,weight); b34srun$ /; /;NAMES List Names in storage /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(moveh82); n=200; call names(all:); call names; call print(%names%); call print(%namesL%); subroutine test(i); call print('in test'); call names(dostat); call print(%down,%donow,%dowhile,%ifnow); return; end; call names(dostat); call print(%down,%donow,%dowhile,%ifnow); do i=1,2; call names(dostat); call print(%down,%donow,%dowhile,%ifnow); if(i.eq.1)then; call names(dostat); call print(%down,%donow,%dowhile,%ifnow); endif; call test(1); enddo; b34srun; /; /;NCCHISQ Noncentral Chi-Square /; b34sexec matrix; * Test problem from IMSL page 923 ; chsq=8.642; df=2.0; alam=1.0; p=ncchisq(chsq,df,alam); call print('Prob. that a noncentral chi-square random var. with', 'DF and noncentrality ',df,alam,' is less than ', chsq,' is ',p,' Answer should be .950'); b34srun; /; /;NEAREST Nearest distinct number of a given type /; b34sexec matrix; i=1; x=1.; y=sngl(x); call print('Largest integer ',huge(i):); call print('Largest real*4 ',huge(y):); call print('Largest real*8 ',huge(x):); call print('Smallest real*4 ',tiny(y):); call print('Smallest real*8 ',tiny(x):); call print('Epsilon real*4 ',epsilon(y):); call print('Epsilon real*8 ',epsilon(x):); x=.1d+00; y=sngl(x); j=1; call echooff; do i=1,1000,100; x=x*dfloat(i); y=float(i)*y ; spx(j)=spacing(x); spy(j)=spacing(y); nearpr8(j)=nearest(x, 1.); nearmr8(j)=nearest(x,-1.); nearpr4(j)=nearest(y, 1.); nearmr4(j)=nearest(y,-1.); testnum(j)=x; j=j+1; enddo; call print('Spacing for Real*8 and Real*4'); call tabulate(testnum,spx,spy,nearpr8,nearmr8,nearpr4,nearmr4); call names(all); call graph(testnum,spx :plottype xyplot :heading 'Spacing'); g=grid(1000.,10000.,1000.); nl=nearest(g,-1.); nu=nearest(g,1. ); diff=nu-nl; call tabulate(g,nl,nu,diff); b34srun; /; /;NL2SOL Madsen Problem for NL2SOL /; /$ /$ Run1 nl2sol with out gradiant /$ Run2 nl2sol with gradiant /$ Run3 maxf1 and maxf2 on same problem /$ b34sexec matrix; * answers can switch sign; * Results replicated by maxf1 & maxf2 for coefficients; * SEs differ; program test; r(1)=x1**2. + x2**2. +x1*x2; r(2)=dsin(x1); r(3)=dcos(x2); return; end; program test2; j(1,1) = 2.0*x1 + x2 ; j(1,2) = 2.0*x2 + x1 ; j(2,1) = dcos(x1) ; j(2,2) = 0.0 ; j(3,1) = 0.0 ; j(3,2) = (-1.0)*dsin(x2) ; return; end; rvec=array(2:3.,11.0); call echooff; r=array(3:); /$ x1=.1; x2=.2; call nl2sol(r :name test :parms x1 x2 :ivalue rvec :print /$ :itprint ); rvec=array(2:3., 1.0); call echooff; r=array(3:); j=array(3,2:); call nl2sol(r j :name test test2 :parms x1 x2 :ivalue rvec :print /$ :itprint ); b34srun; /$ /$ Using minimum of sum of squares to solve /$ by nonlinear LS Madsen Problem /$ b34sexec matrix; * answers can switch sign; * Results replicated by nl2sol for coefficients; * SEs differ; program test; r(1)=x1**2. + x2**2. +x1*x2; r(2)=dsin(x1); r(3)=dcos(x2); func=(-1.0)*sumsq(r); return; end; rvec=array(2:3., 1.0); call echooff; call maxf1(func :name test :parms x1 x2 :ivalue rvec :print); rvec=array(2:3., 1.0); call maxf2(func :name test :parms x1 x2 :ivalue rvec :print); b34srun; /; /;NLEQ_1A Solve a System of Nonlinear Equations nsig = default /; /$ Solution to 0.0 = x1 + exp(x1 - 1.0) +((x2+x3)*(x2+x3)) -27. /$ 0.0 = exp(x2-2.0)/x1+x3*x3 -10. /$ 0.0 = x3+sin(x2-2.0)+x2*x2 -7. /$ /$ with answers FNORM = 0.0 /$ x1 = 1.00001, x2 = 2.0000 x3 = 3.00000 /$ /$ can be found with the commands: /$ b34sexec matrix; * answers ; * x1 = 1.00001 ; * x2 = 2.00000 ; * x3 = 3.00000 ; program test; func(1)=x1 + dexp(x1 - 1.0) +((x2+x3)*(x2+x3)) -27.0; func(2)=dexp(x2-2.0)/x1+x3*x3 - 10.; func(3)=x3+dsin(x2-2.0)+x2*x2 - 7.; return; end; call print(test); call echooff; rvec=array(3:4.0 4.0 4.0); call nleq(func :name test :parms x1 x2 x3 :ivalue rvec :print); b34srun; /; /;NLEQ_1B Solve a System of Nonlinear Equations Here nsig=7 /; /$ Solution to 0.0 = x1 + exp(x1 - 1.0) +((x2+x3)*(x2+x3)) -27. /$ 0.0 = exp(x2-2.0)/x1+x3*x3 -10. /$ 0.0 = x3+sin(x2-2.0)+x2*x2 -7. /$ /$ with answers FNORM = 0.0 /$ x1 = 1.00001, x2 = 2.0000 x3 = 3.00000 /$ /$ can be found with the commands: /$ /$ Note that here we have nsig 7 /$ b34sexec matrix; * answers ; * x1 = 1.00001 ; * x2 = 2.00000 ; * x3 = 3.00000 ; program test; func(1)=x1 + dexp(x1 - 1.0) +((x2+x3)*(x2+x3)) -27.0; func(2)=dexp(x2-2.0)/x1+x3*x3 - 10.; func(3)=x3+dsin(x2-2.0)+x2*x2 - 7.; return; end; call print(test); call echooff; rvec=array(3:4.0 4.0 4.0); call nleq(func :name test :parms x1 x2 x3 :maxit 100 :nsig 7 :ivalue rvec :print); b34srun; /; /;NLEQ_2 MATLAB(r) Test Problem # 1 /; /$ Solution to 0.0 = 2.*x1 - x2-dexp((-1.)*x1) /$ 0.0 = -1.*x1 + 2.*x2-dexp((-1.)*x2) /$ /$ with answers FNORM = 0.0 /$ x1 = .5671, x2 = .5671 /$ /$ Problem discussed in MATLAB(r) Optimization Toolbox p 4-81 /$ /$ can be found with the commands: /$ b34sexec matrix; * answers ; * x1 = .5671 ; * x2 = .5671 ; program test; func(1)= 2. *x1 - x2-dexp((-1.)*x1); func(2)=(-1.)*x1 + 2.*x2-dexp((-1.)*x2); return; end; call print(test); call echooff; rvec=array(2:-5.0,-5.0); call nleq(func :name test :parms x1 x2 :nsig 7 :ivalue rvec :print); b34srun; /; /;NLEQ_3 MATLAB(r) Test Problem # 3 /; /$ Solution to 2,2 matrix X such that /$ /$ X*X*X=matrix(2,2:1. 2. 3. 4.); /$ /$ with answers x=matrix(2,2:-.1291, .8602, 1.2903, 1.1612); /$ /$ Problem discussed in MATLAB(r) Optimization Toolbox p 4-83 /$ can be found with the commands: /$ b34sexec matrix; * answers x11 = -.1291; * x12 = .8602; * x21 = 1.2903; * x22 = 1.1612; testx=matrix(2,2:); right=matrix(2,2:1. 2. 3. 4.); program test; testx(1,1)=x11; testx(1,2)=x12; testx(2,1)=x21; testx(2,2)=x22; testx=(testx*testx*testx)-right; func(1)= testx(1,1); func(2)= testx(1,2); func(3)= testx(2,1); func(4)= testx(2,2); return; end; call print(test); call echooff; rvec=array(4:1.,1.,1.,1.); call nleq(func :name test :parms x11 x12 x21 x22 :nsig 7 :ivalue rvec :print); b34srun; /; /;NLEQ_4 MATLAB(r) Test Problem # 4 /; /$ Solution to 0.0 = 3.*x1 + 11.*x2 -2.*x3 -7. /$ 0.0 = x1 + x2 -2.*x3 -4. /$ 0.0 = x1 - x2 + x3 -19. /$ /$ with answers FNORM = 0.0 /$ x1 = 13.2188, x2 =-2.3438 x3 = 3.4375 /$ /$ can be found with the commands: /$ /$ Problem discussed in Matlab(r) Optimization Toolbox page 4-83,4-84 /$ b34sexec matrix; * Solution to 0.0 = 3.*x1 + 11.*x2 -2.*x3 -7. ; * 0.0 = x1 + x2 -2.*x3 -4. ; * 0.0 = x1 - x2 + x3 -19. ; * ; * with answers FNORM = 0.0 ; * x1 = 13.2188, x2 =-2.3438 x3 = 3.4375 ; program test; func(1)= 3.*x1 + 11.*x2 -2.*x3 -7.; func(2)= x1 + x2 -2.*x3 -4.; func(3)= x1 - x2 + x3 -19.; return; end; call print(test); call echooff; rvec=array(3:1., 1., 1.); call nleq(func :name test :parms x1 x2 x3 :nsig 7 :ivalue rvec :print); b34srun; /; /;NLLS1 NLLS using Subroutines /; /$ This illustrates power of Matrix Command but is slow b34sexec matrix cbuffer=10000; call echooff; call load(dud); call load(marq); program prob1; /$ /$ test marquardt method of nonlinear estimation /$ calls marquardt subroutine marq /$ user supplied resid and deriv /$ /$ imar=0 marquardt , =1 = dud /$ call message('enter=> deriv. method, Cancel=> deriv. free method', 'Estimation Options', itest); imar=0; if(itest.eq.23)imar=1; /$ get data call uspopdat; /$ initial values call free(deriv,resid,beta,r); resid=resid1 ; deriv=deriv1 ; /$ /$ rename routines on the fly /$ call subrename(resid); call subrename(deriv); call makeglobal(resid,deriv) ; beta(1)=3.9 ; beta(2)=.022 ; beta=vfam(beta) ; year=mfam(year) ; pop=mfam(pop) ; lamda=.1e-8 ; iprint=0 ; iout=1 ; /$call print('IMAR',imar); if(imar .eq. 0) call marq(year,pop,beta,r,f,sse,seb,covb,corrb, lamda,iprint,iout); if(imar .eq. 1) call dud(year,pop,beta,r,f,sse,seb,covb,corrb, iprint,iout); return; end; subroutine resid1(beta,f,r,sse,xvar,yvar); /$ /$ user supplied routine with model /$ sas tech report a-102 page 8-7 /$ f=vfam(beta(1)* exp(beta(2)*afam(xvar-1790.))); r=yvar-f; sse=sumsq(r); return ; end ; subroutine deriv1(der,f,beta,xvar); /$ /$ user routine to calculate derivatives /$ der=matrix(norows(f),norows(beta):); der(,1)=vfam(afam(f)/beta(1)); der(,2)=vfam(afam(xvar-1790.)*afam(f)); return; end; program uspopdat; /$ data from sas technical report page 9-2 year=dfloat(integers(179,197)); year=year*10. ; pop=array(:3.929 5.308 7.239 9.638 12.866 17.069 23.191 31.443 39.818 50.155 62.947 75.994 91.972 105.710 122.775 131.669 151.325 179.323 203.211 ); call tabulate(year pop); return; end; call print(prob1,resid1,deriv1); call prob1; b34srun; /; /;NLLS2 Illustrates NLLS Using Subroutines /; b34sexec matrix cbuffer=10000; call load(dud); call echooff; subroutine resid2(beta,f,r,sse,xvar,yvar); /$ user supplied routine for model listed page 7-6 of /$ sas tech report a-102 x=xvar-1790. ; z=exp(beta(2) + (beta(3)*afam(x))) ; f=vfam(beta(1) / (1. + afam(z))) ; r=yvar-f ; sse=sumsq(r) ; return ; end ; program prob2; /$ /$ test marquardt method of nonlinear estimation /$ user supplied resid /$ /$ get data call uspopdat; /$ initial values call free(deriv,resid,beta,r); resid=resid2 ; /$ /$ Rename the routines on the fly /$ call subrename(resid) ; call makeglobal(resid) ; beta(1)=400. ; beta(2)=4. ; beta(3)=-.03 ; beta=vfam(beta) ; year=vfam(year) ; pop=mfam(pop) ; iprint=0 ; iout=1 ; call print('Initial Beta',beta); /$call echooff; call dud(year,pop,beta,r,f,sse,seb,covb,corrb,iprint,iout); return; end; program uspopdat; /$ data from sas technical report page 9-2 year=dfloat(integers(179,197)); year=year*10. ; pop=array(:3.929 5.308 7.239 9.638 12.866 17.069 23.191 31.443 39.818 50.155 62.947 75.994 91.972 105.710 122.775 131.669 151.325 179.323 203.211 ); call tabulate(year pop); return; end; call print(resid2,prob2); call prob2; b34srun; /; /;NLLS3 Sinai-Stokes (1972) /; b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix cbuffer=10000; call echooff; call load(dud); subroutine resid3(beta,f,r,sse,xvar,yvar); /$ /$ estimate a ces production function /$ /$ see sinai & stokes res may 1981 /$ beta=afam(beta) ; xvar=afam(xvar) ; f=(beta(2)*(xvar(,1)**beta(4)))+ ((1.-beta(2))*(xvar(,2)**beta(4))); f=beta(1)*(f**(beta(3)/beta(4))) ; beta=vfam(beta) ; f=vfam(f) ; r=vfam(yvar) - vfam(f) ; sse=sumsq(r) ; return ; end ; program prob3; /$ uses data on q, l and k in period 1929 - 1967 to estimate ces model call print('see Sinai - Stokes res(1981) page 315 equation ces 6'); call free(deriv,resid); resid=resid3; /$ /$ Rename on the fly /$ call subrename(resid); call makeglobal(resid) ; /$ deriv=deriv3; call free(beta); beta(1)=.05 ; beta(2)=.3 ; beta(3)=1.5 ; beta(4)= .3 ; beta=vfam(beta); lamda=.1e-12 ; iprint=0 ; iout =1 ; call loaddata ; call tabulate(q,l,k) ; call print('Initial Beta',beta); x=matrix(norows(q),2:) ; x(,1)=vfam(k) ; x(,2)=vfam(l) ; q=vfam(q) ; call dud(x,q,beta,r,f,sse,seb,covb,corrb,iprint,iout); return; end; call print(resid3,prob3); call prob3; b34srun; /; /;NLLS3_A Real*8 / Real*16 Version of NLLS3 /; /$ Can be run real*8 or real*16 b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix cbuffer=10000; call echooff; call load(dud2); call print(dud2); subroutine resid3(beta,f,r,sse,xvar,yvar); /$ /$ estimate a ces production function /$ /$ see sinai & stokes res may 1981 /$ beta=afam(beta) ; xvar=afam(xvar) ; f= ( beta(2)*(xvar(,1)**beta(4)))+ ((kindas(yvar,1.)-beta(2))* (xvar(,2)**beta(4))); f=beta(1)*(f**(beta(3)/beta(4))) ; beta=vfam(beta) ; f=vfam(f) ; r=vfam(yvar) - vfam(f) ; sse=sumsq(r) ; return ; end ; program prob3; /$ uses data on q, l and k in period 1929 - 1967 to estimate ces model call print('see Sinai - Stokes res(1981) page 315 equation ces 6'); call free(deriv,resid); resid=resid3; /$ /$ Rename on the fly /$ call subrename(resid); call makeglobal(resid) ; /$ deriv=deriv3; call free(beta); beta(1)=.05 ; beta(2)=.3 ; beta(3)=1.5 ; beta(4)= .3 ; lamda=.1e-12; beta=vfam(beta); iprint=0 ; iout =1 ; call loaddata ; call tabulate(q,l,k) ; call print('Initial Beta',beta); x=matrix(norows(q),2:) ; x(,1)=vfam(k) ; x(,2)=vfam(l) ; q=vfam(q) ; eps1=1.001; eps2= .0000001; call names(all); call dud2(x,q,beta,r,f,sse,seb,covb,corrb,iprint, iout,eps1,eps2); return; end; call print(resid3,prob3); call prob3; b34srun; /; /;NLLS4 Illustrates NLLS Using Subroutines /; b34sexec matrix cbuffer=10000; call load(dud); call load(marq); * ---------------------------------------------------------; * setup for Ron Gallant (1987) example 1 problem page 35 ; * Gallant answers using SAS were: ; * Coef SE ; * -.02588970 .01262384 ; * 1.01567967 .00993793 ; * -1.11569714 .16354199 ; * 0.50490286 .02565721 ; * ---------------------------------------------------------; call echooff; subroutine resid4(beta,f,r,sse,x,y); beta=afam(beta) ; x=afam(x) ; f=(beta(1)*x(,1))+ (beta(2)*x(,2)) + (beta(4)*exp(beta(3)*x(,3))); r=afam(y)-f ; f=vfam(f) ; r=vfam(r) ; beta=vfam(beta) ; sse=sumsq(r) ; return ; end ; subroutine deriv4(der,f,beta,x); /$ setup for Ron Gallant(1987) example 1 problem page 35 der=matrix(norows(x),norows(beta):) ; der(,1)=vfam(x(,1)) ; der(,2)=vfam(x(,2)) ; der(,3)=vfam(afam(beta(4))*afam(x(,3))*exp(afam(beta(3))*afam(x(,3)))); der(,4)=vfam(exp(afam(beta(3))*afam(x(,3)))); return; end; program prob4; Call print('See gallant(1987 page 4) example 1 - answers on page 35'); call free(y,x1,x2,x3); call free(deriv,resid); call free(f,r,beta,sse,seb,covb,corrb); resid=resid4 ; deriv=deriv4 ; call subrename(resid); call subrename(deriv); call rgex1; call makeglobal(resid,deriv) ; call free(beta) ; beta(1)=-0.04866; beta(2)=1.03884 ; beta(3)=-0.73792; beta(4)=-0.51362; beta=vfam(beta) ; lamda=.1e-8 ; iprint=0 ; /$ iprint = 1 > print intermediate results /$ iout = 1 > print table of results iout=1 ; call message('enter=> deriv. method, Cancel=> deriv. free method', 'Estimation Options', itest); imar=0; if(itest.eq.23)imar=1; x=matrix(norows(y),3:); i=integers(norows(y)); x(i,1)=x1(i) ; x(i,2)=x2(i) ; x(i,3)=x3(i) ; call echooff; if(imar .eq. 0) call marq(x,y,beta,r,f,sse,seb,covb,corrb,lamda,iprint,iout); if(imar .eq. 1) call dud(x,y,beta,r,f,sse,seb,covb,corrb,iprint,iout); return; end; program rgex1; /$ loads data from gallant(1987) page 4 * Test comment; t=integers(1,30); y=array(:.98610 1.03848 .95482 1.04184 1.02324 .90475 .96263 1.05026 .98861 1.03437 .98982 1.01214 .66768 .55107 .96822 .98823 .59759 .99418 1.01962 .69163 1.04255 1.04343 .97526 1.04969 .80219 1.01046 .95196 .97658 .50811 .91840 ); x1=array(:1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0); x2=array(norows(x1):); x2=x2+1.; x3=array(:6.28 9.86 9.11 8.43 8.11 1.82 6.58 5.02 6.52 3.75 9.86 7.31 .47 .07 4.07 4.61 .17 6.99 4.39 .39 4.73 9.42 8.9 3.02 .77 3.31 4.51 2.65 .08 6.11); call tabulate(t y x1 x2 x3); return; end; call print(rgex1,resid4,prob4,deriv4); call prob4; b34srun; /; /;NLLSQ1 OLS using NLLSQ and REG Shows Lags /; /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix /$ OLS Model estimated using nonlinear methods b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec reg; model lnq=lnk lnl lnrm1 time; b34srun; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; call tabulate (q l k m1dp time); program res72; call echooff; yhat=a+g1*lnk + g2*lnl +r*lnrm1 + v*time; call outstring(3,3,'Coefficients'); call outstring(3,4,'g1 g2 v r'); call outdouble(14,4,g1); call outdouble(34,4,g2); call outdouble(50,4,v); call outdouble(14,5,r); return; end; call print(res72); call nllsq(lnq,yhat :name res72 :parms a r g1 g2 v :print result residuals); call graph(%res); * Show that other commands can be run; x=matrix(3,3:1. 2. 3. 4. 5. 6. 7. 8. .9); call print(x); c=1./x; call print(c,c*x); b34srun; /$ Illustrate lags using both commands b34sexec reg; model lnq=lnk lnk{1} lnl lnrm1 time; b34srun; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; * Cannot use subscripted approach if model is recursive ; program res72; call echooff; i=integers(norows(lnk)-1); yhat(i)= g1*lnk(i+1)+ gnew*lnk(i)+g2*lnl(i+1)+r*lnrm1(i+1)+ v*time(i+1) +a; call outstring(3,3,'Coefficients'); call outstring(3,4,'g1 g2 v r'); call outdouble(14,4,g1); call outdouble(34,4,g2); call outdouble(50,4,v); call outdouble(14,5,r); return; end; call print(res72); call nllsq(lnq,yhat :name res72 :parms a r g1 gnew g2 v :print result residuals); call graph(%res); call print(yhat); b34srun; /; /;NLLSQ2 CES Production Function using NLLSQ /; /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix /$ CES Model estimated using nonlinear methods /$ /$ Illustrates use of visual readout of model estimation /$ b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; program res72; call echooff; yhat=a*((g1*(k**r)) + (g2*(l**r)) + ((1.0-g1-g2)*(m1dp**r)) )**(v/r); call outstring(3,3,'Coefficients'); call outstring(3,4,'g1 g2 v r'); call outdouble(14,4,g1); call outdouble(34,4,g2); call outdouble(50,4,v); call outdouble(14,5,r); return; end; call print(res72); call nllsq(q,yhat :name res72 :parms g1 g2 a r v :maxit 50 :flam 1. :flu 10. :eps2 .004 :ivalue array(:.27698 .7754 1.0,-.05 1.8 ) :print result residuals); call graph(%res); call print(mean(%res)); call names; call print(%corrmat); call tabulate(%coef,%se,%t); * Illustrate other commands can be run; x=matrix(3,3:1. 2. 3. 4. 5. 6. 7. 8. .9); call print(x); c=1./x; call print(c,c*x); b34srun; /; /;NLLSQ3 Nonlinear Least Squares using NLLSQ Command /; /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; * Problem 1 is very very hard !!!!!! ; * problem=1; program res72; call echooff; yhat=a*(g1*k**r+(1.0-g1)*l**r)**(v/r); call outstring(3,3,'Coefficients'); call outstring(3,4,'g1 v r'); call outdouble(14,4,g1); call outdouble(34,4,v); call outdouble(50,4,r); return; end; call print(res72); call nllsq(q,yhat :name res72 :parms g1 a v r :maxit 50 :flam 1. :flu 10. :eps2 .004 :ivalue array(:.3053 1.0 1.85 .03) :print result residuals); call graph(%res); b34srun; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; * problem 2 ; program res72; call echooff; yhat=a*(g1*k**r+g2*l**r+(1.0-g1-g2)*(m1/p)**r)**(v/r); call cls(2); call cls(3); call cls(6); call outstring(3,3,'Coefficients'); call outstring(3,4,'g1 g2 v r'); call outdouble(34,4,g1); call outdouble(50,4,g2); call outdouble(34,5,v); call outdouble(50,5,r); return; end; call print(res72); call nllsq(q,yhat :name res72 :parms g1 g2 a r v :maxit 50 :flam 1. :flu 10. :eps2 .004 :ivalue array(:.27698 .7754 1.,-.05 1.8) :print result residuals); call graph(%res); b34srun; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; * problem 3; program res72; call echooff; i=integers(norows(q)-2); yhat=((a*(g1*k(i+2)**r+g2*l(i+2)**r+ (1.0-g1-g2)*(m1(i+2)/p(i+2))**r)**(v/r)) + lam1*q(i+1) + lam2*q(i) - (lam1*a*(g1*k(i+1)**r+g2*l(i+1)**r+ (1.0-g1-g2)*(m1(i+1)/p(i+1))**r)**(v/r)) - (lam2*a*(g1*k(i )**r+g2*l(i )**r+ (1.0-g1-g2)*(m1(i )/p(i ))**r)**(v/r))); /$ Shows how coefficients change as model is estimated call cls(2); call cls(3); call cls(5); call cls(6); call outstring( 3,3,'g1 g2 v r'); call outdouble(20,3,g1); call outdouble(40,3,g2); call outdouble(60,3,v); call outstring( 3,4,'r lam1 lam2'); call outdouble(20,4,r); call outdouble(40,4,lam1); call outdouble(60,4,lam2); return; end; call print(res72); call nllsq(q,yhat :name res72 :parms g1 g2 a r v lam1 lam2 :maxit 500 :flam .1 :flu 10. :eps2 .004 :ivalue array(:.27698 .7754 1.00 .05 1.8 .8, -.6) :print result iter residuals); call graph(%res); b34srun; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; * problem=4; program res72; call echooff; i=integers(norows(q)-2); yhat=((dexp(tt*dfloat(i+2))*a*(g1*k(i+2)**r+g2*l(i+2)**r+ (1.0-g1-g2)*(m1(i+2)/p(i+2))**r)**(v/r)) + lam1*q(i+1) + lam2*q(i) - (lam1*dexp(tt*dfloat(i+1))*a*(g1*k(i+1)**r+g2*l(i+1)**r+ (1.0-g1-g2)*(m1(i+1)/p(i+1))**r)**(v/r)) - (lam2*dexp(tt*dfloat(i)) *a*(g1*k(i )**r+g2*l(i )**r+ (1.0-g1-g2)*(m1(i )/p(i ))**r)**(v/r))); call cls(2); call cls(3); call cls(6); call outstring( 3,3,'Coefficients g1 g2 v r lam1 lam2'); call outdouble(3 ,4,g1); call outdouble(23,4,g2); call outdouble(53,4,v); call outdouble(3 ,5,r); call outdouble(23,5,lam1); call outdouble(53,5,lam2); return; end; call print(res72); call nllsq(q,yhat :name res72 :parms g1 g2 a r v tt lam1 lam2 :maxit 500 :flam .1 :flu 10. :eps2 .004 :ivalue array(:.27698 .7754 1.00 .05 1.8 .0004 .8, -.6) :print result iter residuals); call graph(%res); b34srun; /; /;NLLSQ4 Restricted OLS Using NLLSQ Command /; /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix /$ Restricted OLS Model estimated using nonlinear methods /$ Results tested against full OLS model /$ Results graphed /$ /$ OLS model run inside and outside matrix command /$ /$ Note that :ivalue needed to start v at a low number to avoid /$ overflow. /$ b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; b34sexec reg; model lnq=lnk lnl lnrm1 time; b34srun; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; call tabulate (q l k m1dp time); call olsq(lnq lnk lnl lnrm1 time:print); rssols=dexp(afam(lnq))-dexp(afam(%yhat)); yhatols=dexp(afam(%yhat)); call tabulate(q,dexp(%yhat),rssols); program res72; call echooff; yhat=a*((k**g1)*(l**g2)*(m1dp**(1.0-g1-g2)))*dexp(v*time); return; end; call print(res72); call nllsq(q,yhat :name res72 :parms a g1 g2 v :ivalue array(:.1 .1 .1 .00001) :print result residuals); call graph(%res,rssols); yhat=q-%res; call graph(q,yhatols,yhat); call tabulate(q,yhatols,yhat,rssols,%res); b34srun; /; /;NLPMIN1A Nonlinear Programming /; /$ /$ Uses IMSL dn2onf /$ b34sexec matrix; * Answers .8229 .9114 ; * Problem: min( (x1-2)**2 +(x2-1)**2) ; * st x1 - 2*x2 +1 = 0.0; * -(x1**2)/4 -x2**2 + 1 GE 0.0; program test; func=(x1-2.)**2. + (x2-1.)**2. ; if(%active(1)) g(1)=x1 - 2.0*x2 + 1. ; if(%active(2)) g(2)=((-1.)*(x1**2.)/4.) - (x2**2.) + 1. ; return; end; call print(test); call echooff; call NLPMIN1(func g :name test :parms x1 x2 :ivalue array(:2.,2.) :nconst 2 1 :lower array(:-1.d+6, -1.d+6) :upper array(: 1.d+6, 1.d+6) :print :maxit 100 :iprint final); b34srun; /; /;NLLSQ_GLS GLS Using NLLSQ /; b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; /$ /$ Illustrated GLS a number of ways /$ b34sexec regression toll=.1e-6 maxgls=1; model lnq=lnk lnl lnrm1 time; b34srun; b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; call tabulate (q l k m1dp time); program res72; call echooff; yhat(jj2)=a*(1.-rho)+rho*lnq(jj2)+g1*lnk(jj) -g1*rho*lnk(jj2) +g2*lnl(jj) -g2*rho*lnl(jj2) +r* lnrm1(jj) - r*rho*lnrm1(jj2) +v* time(jj) - v*rho*time(jj2); call outstring(3,3,'Coefficients'); call outstring(3,4,'g1 g2 v r'); call outdouble(14,4,g1); call outdouble(34,4,g2); call outdouble(50,4,v); call outdouble(14,5,r); call outdouble(34,5,rho); return; end; call print(res72); jj=integers(2,norows(lnq)); jj2=jj-1; lnq2=lnq(jj); call nllsq(lnq,yhat :name res72 :parms a r g1 g2 v rho :print result residuals); call graph(%res); b34srun; /; /;NLPMIN1B Uses NLPMIN1 to solve OLS Model /; /; b34sexec options ginclude('gas.b34'); b34srun; /$ Using NLPMIN to solve OLS problem /$ OLSQ used as a test /$ Uses IMSL dn2onf /$ Note that M and ME set = 0. G(1)=0.0d+00 is a dummy b34sexec matrix; call loaddata; program test; func=sumsq(gasout -(a+b*gasin)); call outstring(3, 3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b); g(1)=0.0d+00; return; end; call print(test); call olsq(gasout gasin :print); call echooff; call NLPMIN1(func g :name test :parms a b :ivalue array(:2.,2.) :nconst 0 0 :lower array(:-1.d+6, -1.d+6) :upper array(: 1.d+6, 1.d+6) :print :maxit 100 :iprint final); b34srun; /; /;NLPMIN1C Uses NLPMIN1 to minimize a function /; /$ Answers should be x1=.9999 and x2=.9999 b34sexec matrix; * dn2onf is used to minimize a function ; * Answers should be x1=.9999 and x2=.9999 ; * Problem tests if starting values make a difference ; * Problem is classic Rosenbrock banana problem. ; * Problem used as a test case in IMSL and in MATLAB fmins function ; program test; func=100.*(x2-x1*x1)**2. + (1.-x1)**2.; call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); g(1)=0.0d+00; return; end; call print(test); call echooff; call NLPMIN1(func g :name test :parms x1 x2 :ivalue array(:.1 ,.1 ) :nconst 0 0 :lower array(:-1.d+6, -1.d+6) :upper array(: 1.d+6, 1.d+6) :print :maxit 100 :iprint final); b34srun; /; /;NLPMIN1D Minimize a two var. constrained exponential function /; b34sexec matrix; * NLPMIN1 is used to minimize a function ; * Answers should be x1=-9.5474 and x2=1.0474 ; * Problem from Matlib Optimization toolbox page 1-9 ; * Test problem illustrates a nonlinear function and nonlienar constraints ; * Min dexp(x1)*((4.*x1*x1)+(2.*x2*x2)+(4.*x1*x2)+(2.*x2)+1.0); * s. t. x1*x2 -x1-x2 le -1.5 ; * x1*x2 GE -10 ; program test; func=dexp(x1)*((4.*x1*x1)+(2.*x2*x2)+(4.*x1*x2)+(2.*x2)+1.0); if(%active(1)) g(1) =-1.*(((x1*x2)-x1-x2)+1.5) ; if(%active(2)) g(2) =(x1*x2)+10. ; call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; call print(test); rvec=array(2:-1., 1.0); call echooff; call nlpmin1(func g :name test :parms x1 x2 :ivalue rvec :nconst 2 0 :lower array(:-1.d+6, -1.d+6) :upper array(: 1.d+6, 1.d+6) :print :maxit 100 :iprint final); b34srun; /; /;NLPMIN1E IGARCH(1,1) solved with NLPMIN1 /; /$ IGARCH(1,1) using NLPMIN1 - shows general case /$ /$ Note that SE are not available b34sexec options ginclude('b34sdata.mac') member(garchdat); b34srun; b34sexec matrix ; call loaddata; y=sp500; vstart=variance(y-mean(y)); arch=array(norows(y):)+ vstart; res= y-mean(y); call print('mean y ',mean(y):); call print('vstart ',vstart :); program test; call garch(res,arch,y,func,1,nbad :gar array(:gar) idint(array(:1)) :gma array(:gma) idint(array(:1)) :constant array(:a0 b0) ); if(%active(1)) g(1)=gar+gma-1.; func=(-1.)*func; return; end; call print(test); call echooff; call NLPMIN1(func g :name test :parms gar gma a0 b0 :ivalue array(:.5,.5,mean(y),vstart) :nconst 1 0 :lower array(: 1.d-6, 1.d-6, 1.d-6, 1.d-6) :upper array(: 1.d+2, 1.d+2, 1.d+2, 1.d+2) :print :maxit 100 :iprint final); b34srun; /; /;NLPMIN2 Nonlinear Programming - User Gradiant /; /$ /$ Uses IMSL dn2ong /$ b34sexec matrix; * Answers .8229 .9114 ; * Problem: min( (x1-2)**2 +(x2-1)**2) ; * st x1 - 2*x2 +1 = 0.0; * -(x1**2)/4 -x2**2 + 1 GE 0.0; program test; func=(x1-2.)**2. + (x2-1.)**2. ; if(%active(1)) g(1)=x1 - 2.0*x2 + 1. ; if(%active(2)) g(2)=(((-1.)*(x1**2.))/4.) - (x2**2.) + 1. ; return; end; program grad; df(1)=2.0*(x1-2.0) ; df(2)=2.0*(x2-1.0) ; if(%active(1))then; dg(1,1)=1.; dg(1,2)=-2.; endif; if(%active(2))then; dg(2,1)= -.5 * x1; dg(2,2)= -2. * x2; endif; return; end; call print(test,grad); call echooff; call nlpmin2(func g df dg :name test grad :parms x1 x2 :ivalue array(:2.,2.) :nconst 2 1 :lower array(:-1.d+6, -1.d+6) :upper array(: 1.d+6, 1.d+6) :print :maxit 100 :iprint final); b34srun; /; /;NLPMIN3 Nonlinear Programming - User Gradiant - Gets Hessian /; /$ /$ Uses IMSL dn0onf /$ b34sexec matrix; * Answers .8229 .9114 ; * Problem: min( (x1-2)**2 +(x2-1)**2) ; * st x1 - 2*x2 +1 = 0.0; * -(x1**2)/4 -x2**2 + 1 GE 0.0; program test; func=(x1-2.)**2. + (x2-1.)**2. ; if(%active(1)) g(1)=x1 - 2.0*x2 + 1. ; if(%active(2)) g(2)=(((-1.)*(x1**2.))/4.) - (x2**2.) + 1. ; return; end; program grad; df(1)=2.0*(x1-2.0) ; df(2)=2.0*(x2-1.0) ; if(%active(1))then; dg(1,1)=1.; dg(1,2)=-2.; endif; if(%active(2))then; dg(2,1)= -.5 * x1; dg(2,2)= -2. * x2; endif; return; end; call print(test,grad); call echooff; call nlpmin3(func g df dg :name test grad :parms x1 x2 :ivalue array(:2.,2.) :nconst 2 1 :lower array(:-1.d+6, -1.d+6) :upper array(: 1.d+6, 1.d+6) :print :maxit 100 :iprint final); b34srun; /; /;NLSTART Generate Nonlinear Starting values /; b34sexec matrix; n=2; k=10; a=array(n:1. 1.); b=array(n:3. 2.); call nlstart(a,b,k,s); call print(s); b34srun; /; /;NOCOLS Number of columns in an object /; b34sexec matrix; i=integers(1,20); x=rn(matrix(5,6:)); call print(norows(i),norows(x), nocols(i),nocols(x), noels(i), noels(x)); b34srun; /; /;NOELS Number of elements in an object /; b34sexec matrix; i=integers(1,20); x=rn(matrix(5,6:)); call print(norows(i),norows(x), nocols(i),nocols(x), noels(i), noels(x)); b34srun; /; /;NORMDEN NORMDEN function => Density of Normal Distribution /; b34sexec matrix$ z=grid(-4.5,4.5,.01); prob=probnorm(z); den=normden(z); call tabulate(z,prob,den); call graph(prob,den:htitle 1.5 1.5 :heading ' Normal Probabily and Density'); b34srun; /; /;NORMDIST 1-norm, 2-norm and i-norm distance /; b34sexec matrix; x=array(:1.,-1.,0.0, 2.); y=array(:4., 2.,1. ,-3.); call tabulate(x,y); call print('1-norm ',normdist(x,y,1)); call print('2-norm ',normdist(x,y,2)); call print('i-norm ',normdist(x,y)); call print(' '); call print('answers should be 12., 6.63325 and 5.0'); b34srun; /; /;NOROWS Number of columns in an object /; b34sexec matrix; i=integers(1,20); x=rn(matrix(5,6:)); call print(norows(i),norows(x), nocols(i),nocols(x), noels(i), noels(x)); b34srun; /; /;NOTFIND Illustrates Not find /; b34sexec matrix; * note that namelist makes all names upper case; cc=namelist(mary sue aron); nota =notfind(cc,'a'); nota2=notfind(cc,'A'); call tabulate(nota,cc,nota2); call character(cc2,'abcdefghijklmnop'); call print('Where is a not?',cc2,notfind(cc2,'a')); b34srun; /; /;OBJECT Object function => merging objects /; b34sexec matrix; test1=object(x,y); test2=object(x,y,1); call names; call names(all); call print(test1,test2); b34srun; /; /;OLS4_TTEST Illustrates Distribution of T statistic /; /$ Illustrates Problems of significance tests using OLS /$ /$ Illustrates T score distribution /$ b34sexec matrix; call echooff; listfreq=0; n=1000; nob=10000; y=array(nob:); x=array(nob:); t1=array(n:); t2=array(n:); do i=1,n; call outinteger(3,20,i); x=rn(x); /$ Note that x is not in the Y variable calculation y=1.+rn(x); call olsq(y x); t1(i)=%t(1); t2(i)=%t(2); enddo; call graph(t2(ranker(t2)) :heading 'T scores for constant'); call graph(t1(ranker(t1)) :heading 'T scores for random x variable'); q=array(8:.25,.50,.75,.90,.95,.975,.99,1.0); call quantile(t1,q,qvalue1); call quantile(t2,q,qvalue2); call tabulate(q,qvalue1,qvalue2); if(listfreq.ne.0)then; call load(cfreq); call cfreq(t1,tt1,ttt1); call cfreq(t2,tt2,ttt2); call tabulate(t1,tt1,ttt1,t2,tt2,ttt2); endif; b34srun; /; /;OLSPLOT Plots of OLS Y, Yhat and Residual /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(olsplot); call olsq(gasout gasin{1 to 6} gasout{1 to 6}); call character(cc,'Gasout Model'); call olsplot(%yhat, %y, %res, cc); b34srun; /; /;OLSQ1 Ordinary Least Squares using Matrix Command /; /$ Illustrates OLS Capability under Matrix Command b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec reg; model gasout=gasin; b34srun; b34sexec robust; model gasout=gasin; b34srun; b34sexec reg; model gasout=gasin{0 to 1} gasout{1}; b34srun; b34sexec matrix; call loaddata; call olsq(gasout gasin:print :diag); call graph(%res :heading 'Residual'); call graph(%y %yhat :heading 'Fitted and Actual'); call olsq(gasout gasin{0 to 1} gasout{1} :print); call names; call print('Model of ',%yvar); call tabulate(%names,%lag,%coef,%se,%t); call tabulate(gasout,%y,%yhat,%res); call graph(%res,:heading 'Residuals'); call graph(%y,%yhat :heading 'Fitted and Actual Values.'); maxi=24; do i=1,maxi; call olsq(gasout gasin{0 to i} gasout{1 to i}:print); call print(acf(%res,24)); enddo; b34srun; /; /;OLSQ2 Effect of # Lags on R**2 and RSS /; /$ Illustrates OLS Capability under Matrix Command /$ /$ Shows Effect of Lag on RSS, RES and RSQ /$ /$ We only adjust gasin lags /$ b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; maxi=24; fit=array(maxi:); holdrss=array(maxi:); do i=1,maxi; call olsq(gasout gasin{0 to i} gasout{1}); fit(i)=%rsq; holdrss(i)=%rss; call graph(%res); enddo; call tabulate(fit,holdrss); call graph(fit); call graph(holdrss); b34srun; /; /;OLSQ3 OLS - L1 - MINIMAX /; /$ Illustrates OLS / L1 / Minimax Capability under Matrix Command b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec robust; model gasout=gasin{0 to 6} gasout{1 to 6}; b34srun; b34sexec matrix; call loaddata; call olsq(gasout gasin{0 to 6} gasout{1 to 6}:print :diag :l1 :minimax); call names(all); call graph(%res,%l1res,%mmres :heading 'Residual'); call graph(%y %yhat %l1yhat %mmyhat :heading 'Fitted and Actual'); call graph(%y %yhat :heading 'OLS Fitted and Actual'); call graph(%y %l1yhat :heading 'L1 Fitted and Actual'); call graph(%y %mmyhat :heading 'MM Fitted and Actual'); call print('Model of ',%yvar); call tabulate(%names,%lag,%coef,%se,%t,%l1coef %mmcoef); call tabulate(gasout,%y,%yhat,%res,%l1yhat,%l1res,%mmyhat,%mmres); b34srun; /; /;OLSQ4 Subset sample /; /$ Illustrates OLS Capability under Matrix Command b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; mask = (gasin .gt. 0.0); call olsq(gasout gasin :sample mask :print :diag :qr); call olsq(gasout gasin :sample mask :print :diag); call graph(%res :heading 'Residual'); call graph(%y %yhat :heading 'Fitted and Actual'); /; /;OLSQ5 Illustrates effect on RSS of Lags /; /$ /$ See also MARS_6 example /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call echooff; nn=15; lag=15; rss=array(nn,lag:); do j=1,lag; do i=1,nn; call olsq(gasout gasout{1 to j} gasin{1 to i}); rss(i,j)=%rss; enddo; enddo; call graph(rss :plottype meshc :grid :d3axis d3border :rotation 0. :heading 'Full lags displayed 0.0 degrees'); call graph(rss :plottype meshc :grid :d3axis d3border :rotation 90. :heading 'Full lags displayed 90. degrees'); call graph(rss :plottype meshc :grid :d3axis d3border :rotation 180. :heading 'Full lags displayed 180 degrees'); call graph(rss :plottype meshc :grid :d3axis d3border :rotation 270. :heading 'Full lags displayed 270. degrees'); do i=1,10; /$ 123456789012345678901234567890123456 call character(cc,'X lags - Y lags - '); call inttostr(i, n1,'(i2)'); call inttostr(norows(rss),n2,'(i2)'); call inttostr(i, n3,'(i2)'); call inttostr(nocols(rss),n4,'(i2)'); cc =place(n1,10,11,cc); cc =place(n2,13,14,cc); cc =place(n3,29,30,cc); cc =place(n4,32,33,cc); call graph(submatrix(rss,i,norows(rss),i,nocols(rss)) :plottype meshc :grid :d3axis d3border :rotation 0. :heading cc); enddo; call print(rss); call checkpoint; b34srun; /; /;OLSQ6 Forecasting with AR(k) model /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; r16gasin=r8tor16(gasin); r16gasot=r8tor16(gasout); idumpmat=0; call olsq(gasout gasin :savex :print); xxr8=%x; call olsq(r16gasot r16gasin :savex :print); xxr16=%x; if(idumpmat.ne.0)call print(xxr8,xxr16); maxlag=9; do i=1,4; call print('******** Forecasts out ',i:); call olsq(gasout gasout{i to maxlag},gasin{i to maxlag} :savex :print); xx1=%x; if(idumpmat.ne.0)call print(xx1,%xfobs,%xfuture); f1=%xfuture*%coef; call tabulate(%xfobs,f1); call olsq(r16gasot r16gasot{i to maxlag} r16gasin{i to maxlag} :savex :print); xx2=%x; if(idumpmat.ne.0)call print(xx2,%xfobs,%xfuture); ff1=%xfuture*%coef; ff1=r16tor8(ff1); call tabulate(%xfobs,ff1); enddo; b34srun; /; /;OLSQ7 White SE Tests /; /$ /$ Illustrates Robust Options in Matrix and optionally REG and Rats /$ Se see both OLS and /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call olsq(gasout gasin{0 to 3} gasout{1 to 3} :print); call olsq(gasout gasin{0 to 3} gasout{1 to 3} :white :print); call tabulate(%coef %se %t %whitese %whitet); gasin =r8tor16(gasin); gasout=r8tor16(gasout); call olsq(gasout gasin{0 to 3} gasout{1 to 3} :print); call olsq(gasout gasin{0 to 3} gasout{1 to 3} :white :print); call tabulate(%coef %se %t %whitese %whitet); b34srun; /; /;OLSQ8 Alternate White Tests /; /$ /$ Note Greene (2003) page 215 uses 72 observations /$ /$ :white1 and :white2 reults in Greene(2003) Table 11.1 /$ Note that SE for :white2 for ownrent is 95.672 not 95.632 /$ /$ Davidson & MacKinnon (2004) 199-200 discuss these tests which /$ are also discussed in Greene (2003) page 219=221 /$ b34sexec options ginclude('greene.mac') member(a5_1); b34srun; /$ b34sexec data set dropmiss; build incomesq; gen incomesq=income*income; gen if(exp.le.0.0)exp=missing(); b34srun; b34sexec matrix; call loaddata; call olsq(exp age ownrent income incomesq :print); call olsq(exp age ownrent income incomesq :white :print); call tabulate(%coef %se %t %whitese %whitet); call olsq(exp age ownrent income incomesq :print); call olsq(exp age ownrent income incomesq :white1 :print); call tabulate(%coef %se %t %whitese %whitet); call olsq(exp age ownrent income incomesq :print); call olsq(exp age ownrent income incomesq :white2 :print); call tabulate(%coef %se %t %whitese %whitet); call olsq(exp age ownrent income incomesq :print); call olsq(exp age ownrent income incomesq :white3 :print); call tabulate(%coef %se %t %whitese %whitet); exp =r8tor16(exp); age =r8tor16(age); ownrent =r8tor16(ownrent); income =r8tor16(income); incomesq=r8tor16(incomesq); call olsq(exp age ownrent income incomesq :print); call olsq(exp age ownrent income incomesq :white :print); call tabulate(%coef %se %t %whitese %whitet); call olsq(exp age ownrent income incomesq :print); call olsq(exp age ownrent income incomesq :white1 :print); call tabulate(%coef %se %t %whitese %whitet); call olsq(exp age ownrent income incomesq :print); call olsq(exp age ownrent income incomesq :white2 :print); call tabulate(%coef %se %t %whitese %whitet); call olsq(exp age ownrent income incomesq :print); call olsq(exp age ownrent income incomesq :white3 :print); call tabulate(%coef %se %t %whitese %whitet); b34srun; /; /;OLSQ_QR QR Test /; /$ First a major problem case then a more normal case. /$ Test proglem show value of QR in some cases. b34sexec options ginclude('b34sdata.mac') member(wampler); b34srun; b34sexec matrix; call loaddata; * y1 = 1+ x1 + x1**2 + x1**3 + x1**4 + x1**5 $ * y2 = 1 + .1*x1 +.01*x1**2 +.001*x1**3 + .0001*x1**4 + .00001*x1**5$ * y3 = y1 + delta $ * y4 = y1 + 100*delta $ * y5 = y1 + 10000*delta $ call olsq(y1 x1 x2 x3 x4 x5 :print ); call olsq(y1 x1 x2 x3 x4 x5 :print :qr); call olsq(y2 x1 x2 x3 x4 x5 :print ); call olsq(y2 x1 x2 x3 x4 x5 :print :qr); call olsq(y3 x1 x2 x3 x4 x5 :print ); call olsq(y3 x1 x2 x3 x4 x5 :print :qr); call olsq(y4 x1 x2 x3 x4 x5 :print ); call olsq(y4 x1 x2 x3 x4 x5 :print :qr); call olsq(y5 x1 x2 x3 x4 x5 :print ); call olsq(y5 x1 x2 x3 x4 x5 :print :qr); b34srun; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; /; Use QR command b34sexec qr; model gasout=gasin; b34srun; b34sexec matrix; call loaddata; call olsq(gasout gasin :print); call olsq(gasout gasin :print :qr); call olsq(gasout gasout{1 to 40} gasin{1 to 40} :print); call olsq(gasout gasout{1 to 40} gasin{1 to 40} :print :qr); b34srun; /; /;OLS_L1MM Shows OLS, MINIMAX and L1 where an outlier /; b34sexec matrix; * outlier analysis ; n=1000; k=6; vv=2.; x=rn(matrix(n,k:)); x(,1)=1.; beta=vector(k:)+10.; y=x*beta+vv*rn(vector(n:)); call olsq(y x :noint :print :l1 :minimax); y(1)=200.; call olsq(y x :noint :print :l1 :minimax); b34srun; /; /;OLSQ_RR Recursive Residual Analysis /; /$ /$ This job validates the rrplots routine and the /$ RR option on the OLSQ command /$ b34sexec options ginclude('b34sdata.mac') macro(eeam88)$ b34seend$ b34sexec rr ntest=2 irb=1 irrls=list ibcls=list icum=list icumsq=list iquant=list$ model lnq = lnk lnl $ b34seend$ b34sexec matrix; call loaddata; call load(rrplots); call olsq( lnq lnk lnl :rr 1 :print); call tabulate(%rrobs,%ssr1,%ssr2,%rr,%rrstd,%res); call print('Sum of squares of std RR ',sumsq(goodrow(%rrstd)):); call print('Sum of squares of OLS RES ',sumsq(goodrow(%res)):); call print(%rrcoef,%rrcoeft); call rrplots(%rrstd,%rss,%nob,%k,%ssr1,%ssr2,1); call names(all); call print('REAL*16 *******************************':); lnq=r8tor16(lnq); lnk=r8tor16(lnk); lnl=r8tor16(lnl); call olsq( lnq lnk lnl :rr 1 :print); call tabulate(%rrobs,%ssr1,%ssr2,%rr,%rrstd,%res); call print('Sum of squares of std RR ',sumsq(goodrow(%rrstd)):); call print('Sum of squares of OLS RES ',sumsq(goodrow(%res)):); call print(%rrcoef,%rrcoeft); %rrstd=r16tor8(%rrstd); %rss =r16tor8(%rss ); %ssr1 =r16tor8(%ssr1 ); %ssr2 =r16tor8(%ssr2 ); call rrplots(%rrstd,%rss,%nob,%k,%ssr1,%ssr2,1); call names(all); b34srun; /; /;OLSQ_16 Real*8 and Real*16 results /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; /$ Illustrates real*8 and Real*16 OLSQ b34sexec matrix; call loaddata; call olsq(gasout gasin{0 to 3} :l1 :minimax :print :diag); call olsq(gasout gasin{0 to 3} :qr :print :diag); call olsq(gasout gasin{0 to 3} :rr 3 :print :diag); rr1 =r8tor16(%rr); rrcoef1=r8tor16(%rrcoef); gasout=r8tor16(gasout); gasin =r8tor16(gasin); call print('++++++++++++++ Real*16 +++++++++++++++++++':); call olsq(gasout gasin{0 to 3} :l1 :minimax :print :diag); call olsq(gasout gasin{0 to 3} :qr :print :diag); call olsq(gasout gasin{0 to 3} :rr 3 :print :diag); rr2 =%rr; rrcoef2=%rrcoef; d1=rr1-rr2; d2=rrcoef1-rrcoef2; call print(d1,d2); b34srun; /; /;OUTDOUBLE Screen I/O OUTSTRING/OUTDOUBLE/OUTINTEGER/MESSAGE /; b34sexec matrix; call message('Illustrates MESSAGE','Testing Message',jj); call print('Message returns',jj); call cls(3); /$ clear message call cls(2); call outstring(3,3,'This is at 3,3',:); call cls(4); call outstring(3,4,'This is at 3,4'); call cls(5); call outstring(3,5,'This is at 3,5'); call cls(6); call outstring(3,6,'int 123 at 40,6'); jj=123; call outinteger(40,6,jj); call stop(pause); xx=dsqrt(12.88); call outstring(3,2,'(12.88)**.5 printed on 3-6 rows'); do i=3,6; call cls(i); call outdouble(3,i,xx); enddo; call stop(pause); b34srun; /; /;OUTINTEGER Screen I/O OUTSTRING/OUTDOUBLE/OUTINTEGER/MESSAGE /; b34sexec matrix; call message('Illustrates MESSAGE','Testing Message',jj); call print('Message returns',jj); call cls(3); /$ clear message call cls(2); call outstring(3,3,'This is at 3,3',:); call cls(4); call outstring(3,4,'This is at 3,4'); call cls(5); call outstring(3,5,'This is at 3,5'); call cls(6); call outstring(3,6,'int 123 at 40,6'); jj=123; call outinteger(40,6,jj); call stop(pause); xx=dsqrt(12.88); call outstring(3,2,'(12.88)**.5 printed on 3-6 rows'); do i=3,6; call cls(i); call outdouble(3,i,xx); enddo; call stop(pause); b34srun; /; /;OUTSTRING Screen I/O OUTSTRING/OUTDOUBLE/OUTINTEGER/MESSAGE /; b34sexec matrix; call message('Illustrates MESSAGE','Testing Message',jj); call print('Message returns',jj); call cls(3); /$ clear message call cls(2); call outstring(3,3,'This is at 3,3',:); call cls(4); call outstring(3,4,'This is at 3,4'); call cls(5); call outstring(3,5,'This is at 3,5'); call cls(6); call outstring(3,6,'int 123 at 40,6'); jj=123; call outinteger(40,6,jj); call stop(pause); xx=dsqrt(12.88); call outstring(3,2,'(12.88)**.5 printed on 3-6 rows'); do i=3,6; call cls(i); call outdouble(3,i,xx); enddo; call stop(pause); b34srun; /; /;OVERVIEW Shows Programing with Object Oriented Language /; b34sexec matrix; /$ call echooff; call print('The B34S MATRIX Command is demonstrated.', 'Objects are built and transformed.'); n=4; a= array(n:integers(1,n)); v=vector(n:integers(1,n)); ax=rn(array(4,4:)); mx=rn(matrix(4,4:)); call print(a,v,ax,mx ' ' 'Inverse of mx (1./mx)' (1./mx), ' ' 'Test inverse by mx * (1./mx) ' mx * (1./mx) ' ' 'Better test. See largest error' 'dmax((matrix(n,n:)+1.)-(mx*(1./mx))) ' dmax((matrix(n,n:)+1.)-(mx*(1./mx))) ); call print(' ','Structured Index'); n=6; x=rn(matrix(n,n:)); call print(x); row1mean=mean(x(1,)); col1mean=mean(x(,1)); row2sum=sum(x(2,)); col2sum=sum(x(,2)); call tabulate(row1mean col1mean row2sum col2sum); call print(' '); call print('Matrix Commands are illustrated with complete jobs.'); call print('The file c:\b34slm\matrix2.mac contains subroutines.'); * Variable Expansion - Real*8 and Character*8 examples; r(1)=10.; c(1)='test1234'; call print('Printing char*8 and real*8',c,r); r(2)=20.; c(2)='aa'; call print('Printing char*8 and real*8',c,r); * simple graphics; n=100; x=dfloat(integers(1,n)); ss=dsin(x); cc=dcos(x); call graph(ss,cc); b34srun; /; /;OVERVIEW_1 Illustrates Structured Index /; b34sexec matrix; /$ Illustrates structured index i=integers(10,20); test=array(20:); x=rn(test); j=i-9; test(j)=x(i); call tabulate(i,test,x); /$ Complex Case c=complex(x,dsqrt(dabs(x))); cc=c*complex(1.0,0.0); call print('Before ',c,cc); cc(j)=c(i); call print('After cc(j)=c(i)'); call tabulate(i,j,c,cc); x=matrix(2,2:1. 2. 3. 4.); c=complex(x,dsqrt(x)); cc1=c*complex(0.,1.); cc2=c*complex(1.,0.); cc3=c*complex(1.,1.); cc4=c*complex(0.,0.); call print(c,cc1,cc2,cc3,cc4); b34srun; /; /;OVERVIEW_2 Advanced Structured Index Processing Examples /; /$ Illustrates Structural Index Processing b34sexec matrix; x =rn(matrix(6,6:)); y =matrix(6,6:); yy =matrix(6,6:); z =matrix(6,6:); zz =matrix(6,6:); i=integers(4,6); j=integers(1,3); xhold=x; hold=x(,i); call print('cols 4-6 x go to hold',x,hold); y(i, )=xhold(j,); call print('Rows 1-3 xhold in rows 4-6 y ',xhold,y); y=y*0.0; j2 =xhold(j,); y(i, )=j2 ; call print('Rows 1-3 xhold in rows 4-6 y ',xhold,y); z(,i)=xhold(,j); call print('cols 1-3 xhold in cols 4-6 z ',xhold,z); j55 =xhold(,j); z=z*0.0; z(,i)=j55; call print('cols 1-3 xhold in cols 4-6 z ',xhold,z); yy=yy*0.0; yy(i,)=xhold; call print('rows 1-3 xhold in rows 4-6 yy',xhold,yy); zz=zz*0.0; do ii=1,3; jj=ii+3; zz(,jj)=xhold(ii,); enddo; call print('Note that zz(,j)=xhold(i,) will not work'); call print('rows 1-3 xhold in cols 4-6 zz',xhold,zz); zz=zz*0.0; do ii=1,3; jj=ii+3; zz(jj,)=xhold(,ii); enddo; call print('Note that zz(j,)=xhold(,i) will not work'); call print('cols 1-3 xhold in rows 4-6 zz',xhold,zz); oldx=rn(matrix(20,6:)); newx= matrix(20,5:); i=integers(4); newx(,i)=oldx(,i); call print('Col 1-4 in oldx goes to newx',oldx,newx); oldx=rn(matrix(20,6:)); newx= matrix(20,5:); i=integers(4); newx(1,i)=oldx(1,i); call print('This puts the first element in col ',oldx,newx); newx=newx*0.0; newx(i,1)=oldx(i,1); call print('This puts the first element in row ',oldx,newx); newx=newx*0.0; newx( ,i)=oldx( ,i); call print('Whole col copied here',oldx,newx); oldx=rn(matrix(10,5:)); newx= matrix(20,5:); i=integers(4); newx(i,1)=oldx(i,1); call print('This puts the first element in row ',oldx,newx); newx=newx*0.0; newx(i,)=oldx(i,); call print('Whole row copied',oldx,newx); * We subset a matrix here ; a=rn(matrix(10,5:)); call print('Pull off rows 1-3, cols 2-4', a,a(integers(1,3),integers(2,4))); b34srun; /; /;OVERVIEW_3 Looks at Regression Calculations using Moment Matrix /; b34sexec data heading('Goldberger(1964) page 187'); * This Job is Based on aclassic example in Golberger (1964) ; * From the Raw Moment Matrix we get OLS Coef, SE, Res Var etc.; * All calculations are inside matrix mm defined as; * Transpose(bigx)*bigx where we define bigx as ; * bigx = catcol(constant x1 x2 x3 y) ; input x1 x2 x3 y; * x3 changed from 113 to 118 to make it agree with Checksum; build check; gen check=1. + x1 + x2 + x3 + y; datacards; 47 54 1 142 43 59 2 127 39 57 3 118 34 48 4 98 34 36 5 94 36 24 6 102 38 19 7 116 41 18 8 128 42 22 9 140 37 24 10 131 40 23 11 143 42 27 12 157 47 36 13 182 51 9 18 209 53 25 19 214 53 39 20 225 50 51 21 221 52 62 22 243 54 75 23 257 54 94 24 265 55 108 25 276 52 118 26 271 54 124 27 291 b34sreturn; b34srun; b34sexec matrix; call loaddata; call tabulate(constant,x1 x2 x3,y,check); call olsq(y x1 x2 x3 :print); y=mfam(y); x1=mfam(x1); x2=mfam(x2); x3=mfam(x3); constant=mfam(constant); x =catcol(constant,x1,x2,x3); bigx=catcol(constant,x1,x2,x3,y); cprod=transpose(bigx)*bigx; xpx=transpose(x)*x; call print(bigx); ols1=inv(transpose(x)*x)*transpose(x)*y; /$ /$ Get b from raw moment matrix see Golberger page 188 /$ call print('Partition cprod as ' 'm(xx) m(xy) ' ' 0 tranpose(y)*y '); k=norows(cprod)-1; call print('Raw Moment Matrix as discussed in Goldberger',cprod); m_xx=submatrix(cprod,1,k,1,k); m_xy=submatrix(cprod,1,k,k+1,k+1); m_yy=cprod(k+1,k+1); call print('M_xx & M_xy M_yy',m_xx,m_xy,m_yy); ols2=inv(submatrix(cprod,1,k,1,k))*submatrix(cprod,1,k,k+1,k+1); call print('Getting OLS from the moment matrix',ols1,ols2); Call print('Get the Total Sum of squares as transpose(beta)*m_xy'); call print('Total Sum of Squares ',transpose(ols2)*m_xy:); tss=transpose(ols2)*m_xy; call Print('Residual Sum of squares ',m_yy-tss:); call print('Now we get the Residual Variance ', (m_yy-tss)/dfloat(norows(x1)-k):); sigmasq=(m_yy-tss)/dfloat(norows(x1)-k); call print('Get SE of coef still using Moment Matrix', 'First we get Variance Covariance of Beta'); v_c_beta=sfam(sigmasq)*inv(m_xx); call print(v_c_beta); call print('SE from the diagonal' dsqrt(diag(v_c_beta))); /$ Now we look at x and make some more calculations xpy=transpose(x)*y; call print(cprod,xpx,xpy,ols1); /$ Get Variance Covariance using M call print(' ' 'Define Idempotent matrix M. Diagonal = 1-(1/n). Off Diag -(1/n)':); n=norows(x1); i=matrix(n,1:vector(n:)+1.); /$ Get mean two ways using M mm1=mean(x1); mm2=mean(x2); mm3=mean(x3); mmy=mean(y); call print('Means from the Mean Command ',mm1,mm2,mm3,mmy); meanmm1=i*transpose(i)*x1/dfloat(norows(x1)); meanmm2=i*transpose(i)*x2/dfloat(norows(x1)); meanmm3=i*transpose(i)*x3/dfloat(norows(x1)); meanmmy=i*transpose(i)*y /dfloat(norows(x2)); call print('Means from M ',meanmm1,meanmm2,meanmm2,meanmm3,meanmmy); bigi=matrix(n,n:)+1.; m=bigi-(1.0/dfloat(n))*i*transpose(i); sumsqdev=x1*transpose(m)*m*x1; call print(' ' 'We test if M is idempotent':); call print('m',m,transpose(m)*m,m*m, ' ' 'Have we calculated the sum of squared deviations about mean using M?' sumsqdev,variance(x1)*(dfloat(n)-1.) ' ' 'Now we use M to get the variance-covariance' ' '); vcov=transpose(bigx)*m*bigx; call print('Varcov ',vcov); call print('We test if the varcov is correct':); call print('We look at x1 x2 and y':); call print('sum(x1(i)-mean(x1))**2.)',sumsq(x1-mean(x1)):); call print('sum(x2(i)-mean(x2))**2.)',sumsq(x2-mean(x2)):); call print('sum(x3(i)-mean(x3))**2.)',sumsq(x3-mean(x3)):); call print('sum(y(i)-mean(y))**2.)', sumsq(y-mean(y)):); call print('sum(((x(i)-mean(x))*(y(i)-mean(y)))', ddot((x1-mean(x1)),(y -mean(y ))), ddot((x2-mean(x2)),(y -mean(y ))), ddot((x3-mean(x3)),(y -mean(y ))), ddot((x1-mean(x1)),(x2-mean(x2))), ddot((x1-mean(x1)),(x3-mean(x3))), ddot((x2-mean(x2)),(x3-mean(x3))) ); b34srun; /; /;PCOPY Pointer Copy /; b34sexec matrix; x=array(:integers(20)); newx=array(30:); ip1=pointer(x); ip2=pointer(newx); call print('pointer(x)',ip1,'pointer(newx)',ip2); call print(pointer(x,4)); * places x 1-10 in locations starting at 4 in newx; call pcopy(10,pointer(x),1,pointer(newx,4),1,8); call tabulate(x,newx); /$ /$ Character Example /$ /$ Job shows creating char*8 and char*1 variables /$ and moving data between the variable types /$ c8=c8array(3,3:); c1=c1array(3,8:); call names; c8(1,1)='John'; c8(1,2)='Carol'; c8(1,3)='Sue'; call character(cc1,'12345678'); call character(cc2,'abcdefgh'); c1(1,)=cc1; c1(2,)=cc2; call print(c1,c8); /$ /$ Move from Character*8 to Character*1 /$ Note the user of kind = -1 to force LCOPY /$ /$ want to place 'John' on line three of c1 call names; call pcopy(4,pointer(c8),1, pointer(c1)+2, norows(c1),-1); call print(c1); /$ move Sue next to John with a space call pcopy(3,pointer(c8)+(16*norows(c8)),1, pointer(c1)+2+5*norows(c1), norows(c1),-1); call print(c1); b34srun; b34sexec matrix; * Illustrates pointer and pcopy ; n=3; x=matrix(n,n:1 2 3 4 5 6 7 8 9); call print(x); y=55.; call pcopy(1,pointer(y),1,pointer(x,2),1,8); call print(x); call pcopy(2,pointer(y),0,pointer(x,4),2,8); call print(x); b34srun; /; /;PDFAC pdfac function => Factor Positive Definite Matrix /; b34sexec matrix; * Problem from 'Applied Numerical Analysis using Matlab'; * by Laurene Fausett page 174; a=matrix(3,3:1. 4. 5. 4. 20. 32. 5. 32. 64.); call print(a, pdfac(a)); n=4;x=rn(matrix(n,n:));pdx=transpose(x)*x; r=pdfac(pdx); call print('Positive Definite Matrix',pdx, 'Factorization',r, 'Test if the Factorization was OK', 'transpose(r)*r', transpose(r)*r, ' ','Complex Case'); cpdx=complex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx=dconj(transpose(cpdx))*cpdx; cr=pdfac(cpdx); i=integers(norows(cpdx)); cpdx(i,i)=complex(real(cpdx(i,i)),0.0); call print('Positive Definite Matrix',cpdx, 'Factorization', cr, 'Test if the Factorization was OK', 'dconj(transpose(cr))*cr', dconj(transpose(cr))*cr,' '); r=pdfac(pdx,r1);cr=pdfac(cpdx,r2); call print(' ', 'Condition of Real Matrix ',r1, ' ', 'Condition of Complex Matrix',r2); * Problem from Introduction to Scientific Computing by Charles VN Loan (page 242 ; test=matrix(3,3: 4.,-10., 2., -10., 34.,-17., 2.,-17.,18. ); call print(test); p=pdfac(test); call print(p); call print('Validate ',transpose(p)*p); x=r8tor16(x); pdx=transpose(x)*x; r=pdfac(pdx); call print('Real*16 case' 'Positive Definite Matrix',pdx, 'Factorization',r, 'Test if the Factorization was OK', 'transpose(r)*r', transpose(r)*r, ' ','Complex Case'); cpdx=complex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx=c16toc32(cpdx); cpdx=dconj(transpose(cpdx))*cpdx; cr=pdfac(cpdx); i=integers(norows(cpdx)); cpdx(i,i)=dcomplex(dreal(cpdx(i,i)),r8tor16(0.0)); call print('Complex*32 Case', 'Positive Definite Matrix',cpdx, 'Factorization', cr, 'Test if the Factorization was OK', 'dconj(transpose(cr))*cr', dconj(transpose(cr))*cr,' '); r=pdfac(pdx,r1);cr=pdfac(cpdx,r2); call print(' ', 'Condition of Real*16 Matrix ',r1, ' ', 'Condition of Complex*32 Matrix',r2); b34srun; /; /;PDFACDD pdfacdd function => downdate Fac. of PD Matrix /; b34sexec matrix; n=4; x=rn(matrix(n,n:)); pdx=transpose(x)*x; r=pdfac(pdx); v = rn(vector(norows(pdx):)); npdx=pdx; nn=norows(pdx)+1; npdx(nn,)=v; npdx= transpose(npdx)*npdx; call print('Positive Definite Matrix', pdx, 'Factorization', r, 'Test if the Factorization was OK', 'transpose(r)*r', transpose(r)*r, 'Update of factorization of pdx' pdfacud(r,v), 'Test if update was OK' 'pdfac(npdx)' pdfac(npdx) 'Other tests involving update/downdate' 'pdfac(pdx)' pdfac(pdx) 'pdfacud(r,v)' pdfacud(r,v) 'pdfacdd(pdfacud(r,v),v)' pdfacdd(pdfacud(r,v),v) ); cpdx=complex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx=dconj(transpose(cpdx))*cpdx; i=integers(norows(cpdx)); cpdx(i,i)=complex(real(cpdx(i,i)),0.0); cr=pdfac(cpdx); cv=complex(v,2.0*v); call print('Positive Definite Matrix',cpdx,'Factorization',cr, 'Test if the Factorization was OK', 'dconj(transpose(cr))*cr', dconj(transpose(cr))*cr, 'Update of factorization' 'pdfacud(cr,cv)', pdfacud(cr,cv), 'Test if update was OK' 'pdfac(cpdx)' pdfac(cpdx) 'pdfacdd(pdfacud(cr,cv),cv)' pdfacdd(pdfacud(cr,cv),cv)); x=r8tor16(x); pdx=transpose(x)*x; call print(eig(pdx)); r=pdfac(pdx); v = r8tor16(rn(vector(norows(pdx):))); npdx=pdx; nn=norows(pdx)+1; npdx(nn,)=v; npdx= transpose(npdx)*npdx; call print('Positive Definite Matrix', pdx, 'Factorization', r, 'Test if the Factorization was OK', 'transpose(r)*r', transpose(r)*r, 'Update of factorization of pdx' pdfacud(r,v), 'Test if update was OK' 'pdfac(npdx)' pdfac(npdx) 'Other tests involving update/downdate' 'pdfac(pdx)' pdfac(pdx) 'pdfacud(r,v)' pdfacud(r,v) 'pdfacdd(pdfacud(r,v),v)' pdfacdd(pdfacud(r,v),v) ); call names(all); cpdx=qcomplex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx=dconj(transpose(cpdx))*cpdx; i=integers(norows(cpdx)); cpdx(i,i)=qcomplex(qreal(cpdx(i,i)),r8tor16(0.0)); cr=pdfac(cpdx); cv=qcomplex(v,r8tor16(2.0)*v); call print('Positive Definite Matrix',cpdx,'Factorization',cr, 'Test if the Factorization was OK', 'dconj(transpose(cr))*cr', dconj(transpose(cr))*cr, 'Update of factorization' 'pdfacud(cr,cv)', pdfacud(cr,cv), 'Test if update was OK' 'pdfac(cpdx)' pdfac(cpdx) 'pdfacdd(pdfacud(cr,cv),cv)' pdfacdd(pdfacud(cr,cv),cv)); b34srun; /; /;PDFACDD2 Example from IMSL on Downdate of PD Matrix /; b34sexec matrix; * IMSL # 10 Page 274; a=matrix(3,3:10., 3., 5. , 3., 14., -3. , 5., -3., 7. ); x=vector(3:3.0 ,2.0 , 1.0); b=vector(3:53.0,20.0,31.0); fac=pdfac(a); call print(a,fac); call print('Solve system ',pdsolv(fac,b)); newfac=pdfacdd(fac,x); call print('New Factorization',newfac); call print('Solve New system ',pdsolv(newfac,b)); b34srun; /; /;PDFACUD pdfacud function => Update Fac. of PD Matrix /; b34sexec matrix; n=4; x=rn(matrix(n,n:)); pdx=transpose(x)*x; r=pdfac(pdx); v = rn(vector(norows(pdx):)); npdx=pdx; nn=norows(pdx)+1; npdx(nn,)=v; npdx= transpose(npdx)*npdx; call print('Positive Definite Matrix', pdx, 'Factorization', r, 'Test if the Factorization was OK', 'transpose(r)*r', transpose(r)*r, 'Update of factorization of pdx' pdfacud(r,v), 'Test if update was OK' 'pdfac(npdx)' pdfac(npdx) 'Other tests involving update/downdate' 'pdfac(pdx)' pdfac(pdx) 'pdfacud(r,v)' pdfacud(r,v) 'pdfacdd(pdfacud(r,v),v)' pdfacdd(pdfacud(r,v),v) ); cpdx=complex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx=dconj(transpose(cpdx))*cpdx; i=integers(norows(cpdx)); cpdx(i,i)=complex(real(cpdx(i,i)),0.0); cr=pdfac(cpdx); cv=complex(v,2.0*v); call print('Positive Definite Matrix',cpdx,'Factorization',cr, 'Test if the Factorization was OK', 'dconj(transpose(cr))*cr', dconj(transpose(cr))*cr, 'Update of factorization' 'pdfacud(cr,cv)', pdfacud(cr,cv), 'Test if update was OK' 'pdfac(cpdx)' pdfac(cpdx) 'pdfacdd(pdfacud(cr,cv),cv)' pdfacdd(pdfacud(cr,cv),cv)); b34srun; /; /;PDFACUD2 Example from IMSL on Update of PD Matrix /; b34sexec matrix; * IMSL # 10 Page 271; a=matrix(3,3:1., -3., 2. , -3., 10., -5. , 2., -5., 6.0); x=vector(3:3.0 ,2.0 , 1.0); b=vector(3:53.0,20.0,31.0); fac=pdfac(a); call print(a,fac); call print('Solve system ',pdsolv(fac,b)); newfac=pdfacud(fac,x); call print('New Factorization',newfac); call print('Solve New system ',pdsolv(newfac,b)); b34srun; /; /;PDINV pdinv function => Invert Positive Definite Matrix /; b34sexec matrix; n=4;x=rn(matrix(n,n:));pdx=transpose(x)*x; r=pdfac(pdx);inv=pdinv(r); call print('Positive Definite Matrix',pdx,'Factorization',r, 'Inverse ',inv, 'Inverse using MATRIX math',(1.0/pdx), 'Test if inverse was OK', inv*pdx,' ','Complex Case'); cpdx=complex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx=dconj(transpose(cpdx))*cpdx; i=integers(norows(cpdx)); cpdx(i,i)=complex(real(cpdx(i,i)),0.0); cr=pdfac(cpdx); cinv=pdinv(cr); call print('Positive Definite Matrix',cpdx,'Factorization',cr, 'Inverse ',cinv, 'Inverse using MATRIX math',(complex(1.0)/cpdx), 'Test if inverse was OK', cinv*cpdx,' '); inv1=pdinv(pdfac(pdx),d1);inv2=pdinv(pdfac(cpdx),d2); call print('Determinate of pdx ',d1, 'Determinate of cpdx',d2); call print('Determinate of pdx using det(pdx) ', det(pdx), 'Determinate of cpdx using det(cpdx)', det(cpdx)); /$ Real*16 pdx=r8tor16(pdx); r=pdfac(pdx);inv=pdinv(r); call print('Real*16 Case', 'Positive Definite Matrix',pdx,'Factorization',r, 'Inverse ',inv, 'Inverse using MATRIX math',(r8tor16(1.0)/pdx), 'Test if inverse was OK', inv*pdx,' ','Complex Case*32'); cpdx=qcomplex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx=dconj(transpose(cpdx))*cpdx; i=integers(norows(cpdx)); cpdx(i,i)=qcomplex(qreal(cpdx(i,i)),r8tor16(0.0)); cr=pdfac(cpdx); cinv=pdinv(cr); call print('Positive Definite Matrix',cpdx,'Factorization',cr, 'Inverse ',cinv, 'Inverse using MATRIX math',(qcomplex(r8tor16(1.0))/cpdx), 'Test if inverse was OK', cinv*cpdx,' '); inv1=pdinv(pdfac(pdx),d1);inv2=pdinv(pdfac(cpdx),d2); call print('Determinate of pdx ',d1, 'Determinate of cpdx',d2); call print('Determinate of pdx using det(pdx) ', det(pdx), 'Determinate of cpdx using det(cpdx)', det(cpdx)); b34srun; /; /;PDINV_2 Shows Speed Differences /; b34sexec matrix; * Tests speed of Linpack vs LAPACK vs svd (pinv) vs ; * Requires a large size ; call echooff; icount=0; n=0; upper=250; mesh=50; top continue; icount=icount+1; n=n+mesh; if(n .gt. upper)go to done; call print('Doing size ',n:); x=rn(matrix(n,n:)); x=transpose(x)*x; ii=matrix(n,n:)+1.; call timer(base1); call gminv(x,xinv1,info); call timer(base2); error1(icount)=sum(dabs(ii-(xinv1*x))); call timer(base3); xinv1=inv(x); call timer(base4); error2(icount)=sum(dabs(ii-(xinv1*x))); call timer(base5); xinv1=pinv(x); call timer(base6); error3(icount)=sum(dabs(ii-(xinv1*x))); call timer(base7); xinv1=inv(x :pdmat); call timer(base8); error4(icount)=sum(dabs(ii-(xinv1*x))); size(icount) =dfloat(n); lapack(icount) =(base2-base1); linpack(icount)=(base4-base3); svdt(icount) =(base6-base5); chol(icount) =(base8-base7); call free(x,xinv1,ii) call compress; go to top; done continue; call tabulate(size,lapack,linpack,svdt,chol,error1,error2,error3,error4); call graph(size lapack,linpack :heading 'Lapack Vs Linpack' :plottype xyplot); call graph(size lapack,linpack svdt :heading 'LAPACK vs Linpack vs SVD' :plottype xyplot); b34srun; /; /;PDSOLV Solve Symetric System using factorization /; b34sexec matrix; n=4;x=rn(matrix(n,n:));pdx=transpose(x)*x; * nn is number of right hand sides; nn=3; r=pdfac(pdx); v = rn(matrix(norows(pdx),nn:)); ans=pdsolv(r,v); call print('Positive Definite Matrix',pdx,'Factorization',r, 'Right hand side',v 'Solution ', 'pdsolv(pdfac(pdx),v)', pdsolv(pdfac(pdx),v) 'test of solution' (1.0/pdx)*v, ' ','Complex Case'); cpdx=complex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx=dconj(transpose(cpdx))*cpdx; i=integers(norows(cpdx)); cpdx(i,i)=complex(real(cpdx(i,i)),0.0); cr=pdfac(cpdx); cv=complex(v,2.0*v); ans=pdsolv(cr,cv); call print('Positive Definite Matrix',cpdx,'Factorization',cr, 'Right hand side',cv 'Solution ', 'pdsolv(pdfac(cpdx),cv)', pdsolv(pdfac(cpdx),cv), 'test of solution', (complex(1.0)/cpdx)*cv); /$ Real*16 pdx=r8tor16(pdx); r=pdfac(pdx); v = r8tor16(v); ans=pdsolv(r,v); call print('Real*16 ', 'Positive Definite Matrix',pdx,'Factorization',r, 'Right hand side',v 'Solution ', 'pdsolv(pdfac(pdx),v)', pdsolv(pdfac(pdx),v) 'test of solution' (r8tor16(1.0)/pdx)*v, ' ','Complex*32 Case'); cpdx=qcomplex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx=dconj(transpose(cpdx))*cpdx; i=integers(norows(cpdx)); cpdx(i,i)=qcomplex(qreal(cpdx(i,i)),r8tor16(0.0)); cr=pdfac(cpdx); cv=qcomplex(v,r8tor16(2.0)*v); ans=pdsolv(cr,cv); call print('Positive Definite Matrix',cpdx,'Factorization',cr, 'Right hand side',cv 'Solution ', 'pdsolv(pdfac(cpdx),cv)', pdsolv(pdfac(cpdx),cv), 'test of solution', (qcomplex(r8tor16(1.0))/cpdx)*cv); b34srun; /; /;PERMUTE Reorder Moment Matrix /; b34sexec matrix; call load(permute); * Problem 5 in Greene (2003) Chapter 15; * Illustrates ols from moment matrix; * Assume 25 obs; * y1=g1*y2 + b11*x1 ; * y2=g2*y1 + b22*x2 + b32*x3 ; * matrix order is y1 y2 x1 x2 x3 ; mm=matrix(5,5: 20 6 4 3 5 6 10 3 6 7 4 3 5 2 3 3 6 2 10 8 5 7 3 8 15); * OLS ; x1 =submatrix(mm,2,3,2,3); x1py1=submatrix(mm,2,3,1,1); call print(x1,x1py1); d1=inv(x1)*x1py1; call print('OLS eq 1 ',d1 ); call print('Answers should be .439024 .536585':); * We reorder Moment Matrix; * New Order y2 y1 x2 x3 x1; call echooff; call permute(mm,mm2, 1,2); call permute(mm2,mm3,3,4); call permute(mm3,mm4,4,5); call print(mm,mm2,mm3,mm4); call echoon; x2 =submatrix(mm4,2,4,2,4); x2py2=submatrix(mm4,2,4,1,1); call print(x2,x2py2); d2=inv(x2)*x2py2; call print('OLS eq 2 ',d2 ); call print('Answers should be .193016 .384127 .19746',:); b34srun; /; /;PI Set values to pi /; b34sexec matrix; x=pi(); y=array(4:); y=pi(y); call print(x,y); b34srun; /; /;PINV Generalized Inverse /; b34sexec matrix; * IMSL example ; a=matrix(3,2:1., 0., 1., 1., 100.,-50.); ginv=pinv(a); call print(a,ginv); s=svd(a,ibad,21,u,v); call print('Testing svd'); call print(v*inv(diagmat(s))*transpose(u)); * Test with a full rank system; n=5; xx=rn(matrix(n,n:)); inv1=inv(xx); inv2=pinv(xx,rank); call print(rank,xx,inv1,inv2,xx*inv1,xx*inv2); s=svd(xx,ibad,21,u,v); call print('Testing svd'); call print(v*inv(diagmat(s))*transpose(u)); b34srun; /; /;PINV_2 Shows slow speed of GINV /; b34sexec matrix; * Tests speed of Linpack vs LAPACK vs svd (pinv); call echooff; icount=0; n=0; upper=250; mesh=50; top continue; icount=icount+1; n=n+mesh; if(n .eq. upper)go to done; x=rn(matrix(n,n:)); ii=matrix(n,n:)+1.; call timer(base1); call gminv(x,xinv1,info); call timer(base2); error1(icount)=sum(dabs(ii-(xinv1*x))); call timer(base3); xinv1=inv(x); call timer(base4); error2(icount)=sum(dabs(ii-(xinv1*x))); call timer(base5); xinv1=pinv(x); call timer(base6); error3(icount)=sum(dabs(ii-(xinv1*x))); size(icount) =dfloat(n); lapack(icount) =(base2-base1); linpack(icount)=(base4-base3); svdt(icount) =(base6-base5); call free(x,xinv1,ii) call compress; go to top; done continue; call tabulate(size,lapack,linpack,svdt,error1,error2,error3); call graph(size lapack,linpack :heading 'Lapack Vs Linpack' :plottype xyplot); call graph(size lapack,linpack svdt :heading 'LAPACK vs Linpack vs SVD' :plottype xyplot); b34srun; /; /;PISPLINE PISPLINE Under Matrix /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; /$ Both PISPLINE Commands shown b34sexec pispline; model gasout = gasin; b34srun; b34sexec matrix; call loaddata; call pispline(gasout gasin :print); call names(all); call graph(%res :heading 'Residual from pispline'); call graph(%y %yhat:heading 'Fit from Pispline'); b34srun; /; /;PISPLINE2 Data from Breiman /; b34sexec options ginclude('b34sdata.mac') member(breiman); b34srun; /$ Both PISPLINE Commands shown B34SEXEC PISPLINE CENTER=2.526 $ FORECAST C_RATIO(12. 12.) E_RATIO(.907 .761)$ MODEL Y = E_RATIO C_RATIO$ B34SEEND$ b34sexec matrix; call loaddata; call pispline( y e_ratio c_ratio :center 2.526 :print); call graph(%res :heading 'Residual from pispline'); call graph(%y %yhat:heading 'Fit from pispline'); b34srun; /; /;PISPLINE3 Illustrates Forecasting /; b34sexec options ginclude('b34sdata.mac') member(breiman); b34srun; /$ Both PISPLINE Commands shown B34SEXEC PISPLINE CENTER=2.526 PMODEL$ FORECAST C_RATIO(12. 12.) E_RATIO(.907 .761)$ MODEL Y = E_RATIO C_RATIO$ B34SEEND$ b34sexec matrix; call loaddata; * We forecast 2 insample data points ; npred=2; xin=matrix(npred,2:); xin(1,1)=.907 ; xin(1,2)= 12. ; xin(2,1)=.761 ; xin(2,2)= 12. ; call print(xin ); call names(all); call pispline(y e_ratio c_ratio :pmodel :print :center 2.526 :forecast xin ); call tabulate(%y %yhat %res y e_ratio c_ratio); call tabulate(%fore %foreobs); /$ Now we show forecasting using a saved model call open(60,'junk.mod'); call pispline(y e_ratio c_ratio :print :center 2.526 :savemodel :murewind); call pispline(y e_ratio c_ratio :print :center 2.526 :getmodel :forecast xin ); call tabulate(%fore %foreobs); b34srun; /; /;PLACE Tests Place /; b34sexec matrix; call character(cc2,'abcdefghijklmnop'); do i=1,10; j=10; newc=extract(cc2,i,j); call print(cc2,i,j,newc); enddo; do i=1,8; newc=place(cc2,1,i); call print(cc2,newc,i); enddo; /$ Tests 4th argument call character(cc2,'abcdefghijklmnop'); call character(cc3,'1234567890987654'); do i=1,8; newc=place(cc2,1,i,cc3); call print(cc2,cc3,newc,i); enddo; name='Mary'; name2='Rho'; call names(all); newname1=place(name2,6,8,name); newname2=place('Sue',6,8,name); call print(name,newname1,newname2); b34srun; /; /;PLOT Call plot to do line printer graphs /; b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; ccf1=ccf(gasin gasout,24); call plot(gasout,gasin); call plot(ccf1 :heading 'CCF1 of gasin & Gasout' :xlabel 'Lags ' :ylabel 'Cross Correlation Values'); end=20.; inc=.1; x=grid(1.,end,inc); y=dsin(x); call plot(x,y :xyplot :heading 'Sine Function'); b34srun; /; /;POIDF Evaluate Poisson Distribution Function /; b34sexec matrix; k=7; theta=10.; pr=poidf(k,theta); call print('Evaluate Poisson Distribution Function':); call print('Probability that X is LE 7 = ',pr:); Call print('Note: Answer should be .2202':); b34srun; /; /;POINTER Pointer Capability /; b34sexec matrix; x=array(:integers(20)); newx=array(30:); ip1=pointer(x); ip2=pointer(newx); call print('pointer(x)',ip1,'pointer(newx)',ip2); call print(pointer(x,4)); * places x 1-10 in locations starting at 4 in newx; call pcopy(10,pointer(x),1,pointer(newx,4),1,8); call tabulate(x,newx); * Character examples including dup copies ; n=namelist(mary sue Diana); nn=namelist(a b c d e); nn2=nn; call pcopy(4,pointer(n),0,pointer(nn),1,-8); call pcopy(3,pointer(n),1,pointer(nn2),1,-8); call tabulate(n,nn,nn2); /$ /$ Job shows creating char*8 and char*1 variables /$ and moving data between the variable types /$ c8=c8array(3,3:); c1=c1array(3,8:); call names; c8(1,1)='John'; c8(1,2)='Carol'; c8(1,3)='Sue'; call character(cc1,'12345678'); call character(cc2,'abcdefgh'); c1(1,)=cc1; c1(2,)=cc2; call print(c1,c8); /$ /$ Move from Character*8 to Character*1 /$ Note the user of kind = -1 to force LCOPY /$ /$ want to place 'John' on line three of c1 call names; call pcopy(4,pointer(c8),1, pointer(c1)+2, norows(c1),-1); call print(c1); /$ move Sue next to John with a space call pcopy(3,pointer(c8)+(16*norows(c8)),1, pointer(c1)+2+5*norows(c1), norows(c1),-1); call print(c1); b34srun; b34sexec matrix; * Illustrates pointer and pcopy ; n=3; x=matrix(n,n:1 2 3 4 5 6 7 8 9); call print(x); y=55.; call pcopy(1,pointer(y),1,pointer(x,2),1,8); call print(x); call pcopy(2,pointer(y),0,pointer(x,4),2,8); call print(x); b34srun; /; /;POIPR Evaluate Poisson Probability Function /; b34sexec matrix; k=7; theta=10.; pr=poipr(k,theta); call print('Evaluate Poisson Probability Function':); call print('Probability that X is 7= ',pr:); Call print('Note: Answer should be .0901':); b34srun; /; /;POLYDV Divide two polynomials /; b34sexec matrix; top=1.0; bot=array(2:1.0, -.9); result=polydv(top,bot,20); i=integers(20); call tabulate(i,result); call print('Prove Multiplier',sum(polydv(top,bot,200)):); /$ as a test get close to unit root by making ar1 = .99 ar1=-.9; ma1= .9; nterms=40; top=array(2:1.,ar1); bot=array(2:1.,ma1); call print(' (1-ar1*B)*y(t)=(1.-ma1*B)*e(t) '); call print('AR1 = ',ar1); call print('MA1 = ',ma1); ar=polydv(top,bot,nterms); ma=polydv(bot,top,nterms); call print('AR is arma(1,1) AR form ':); call print('MA is arma(1,1) MA form ':); call tabulate(ar,ma); call graph(ar :heading 'arma(1,1) AR form '); call graph(ma :heading 'arma(1,1) MA form '); b34srun; /; /;POLYFIT Fit an nth degree polynomial /; b34sexec matrix; call load(polyfit); call load(polyval); call print(polyfit,polyval); * Polyfit test case - See Mastering Matlab 6 page 327; x=dfloat(integers(0,10))/10.; y=array(11:-.447,1.978,3.28,6.16,7.08,7.34,7.66,9.56, 9.48,9.30,11.2); xx=x*x; call olsq(y,x,xx:print); call tabulate(%yhat); call echooff; call polyfit(x,y,2,coef,1); call polyval(coef,x,yhat); call tabulate(x,y,yhat); b34srun; /; /;POLYMCONV Convert storage of a polynomial matrix /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call echooff; ibegin=1; iend=296; nlag=2; call olsq(gasin gasin{1 to nlag} gasout{1 to nlag} :print); b1=%coef; call olsq(gasout gasin{1 to nlag} gasout{1 to nlag} :print); b2=%coef; beta=matrix(2,norows(%coef):); beta(1,)=vfam(b1); beta(2,)=vfam(b2); /$ /$ Convert both ways /$ call polymconv(:byvarin beta new inew); call polymconv(:byorderin new inew beta2); call print(beta,new,inew,beta2); call polymdisp(:display new inew); b34srun; /; /;POLYMDISP Display/Extract a polynomial matrix /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call echooff; ibegin=1; iend=296; nlag=3; x=catcol(gasin,gasout); call olsq(gasin gasin{1 to nlag} gasout{1 to nlag} :print); beta=array(2,(nlag+nlag+1):); beta(1,)=%coef; call olsq(gasout gasin{1 to nlag} gasout{1 to nlag} :print); beta(2,)=%coef; call polymconv(:byvarin beta new inew); call print(new,inew); call polymconv(:byorderin new inew beta2); call print(beta,new,inew,beta2); call polymdisp(:display new inew); call polymdisp(:extract new inew oldterm index(2 1 2)); call print('row 2 col 1 order 2-1 ',oldterm); oldterm=oldterm*3.; call polymdisp(:load new inew oldterm index(2 1 2)); call print('row 2 col 1 order 2-1 ',oldterm); call polymdisp(:extract new inew oldtermv index(2 1 0)); call print('This is a vector pulled out ',oldtermv); call polymdisp(:display new inew); b34srun; /; /;POLYMINV Invert a Polynomial Matrix /; b34sexec matrix; * problem from Enders Robinson page 158; a=array(:2,1,0,6,1,0,1,1); ia=index(2,2,2); nterms=10; call echooff; call polymdisp(:display a ia); call polyminv(a,ia,ainv,iainv,nterms); call names(all); call print(%p,%det); call polymdisp(:display ainv iainv); call polymdisp(:display %adj %iadj); call polymmult(a ia ainv iainv test itest); call polymdisp(:display test itest); call polymdisp(:extract ainv iainv vec1 index(1,1,0)); call polymdisp(:extract ainv iainv vec2 index(2,1,0)); call polymdisp(:extract ainv iainv vec3 index(1,2,0)); call polymdisp(:extract ainv iainv vec4 index(2,2,0)); call names(all); call tabulate(vec1,vec2,vec3,vec4); b34srun; b34sexec matrix; * problem from Enders Robinson page 159; * Here Det = constant ; a=array(:2,0,5,1,3,1,6,1); ia=index(2,2,2); nterms=20; call polymdisp(:display a ia); call polyminv(a,ia,ainv,iainv,nterms); call names(all); call print(%p,%det); call polymdisp(:display ainv iainv); call polymdisp(:display %adj %iadj); call polymmult(a ia ainv iainv test itest); call polymdisp(:display test itest); b34srun; b34sexec matrix; * problem from Enders Robinson page 164; a=array(:1,0,0,1,-3,14,21,1,2,5,-6,14); ia=index(2,2,3); nterms=10; call polymdisp(:display a ia); call polyminv(a,ia,ainv,iainv,nterms); call names(all); call print(%p,%det); call polymdisp(:display ainv iainv); call polymdisp(:display %adj %iadj); call polymmult(a ia ainv iainv test itest); call polymdisp(:display test itest); * testing division using Enders answers; top11=array(:1,1,14); term1_1=polydv(top11,%det,10); top12=array(:0,-21,6); term1_2=polydv(top12,%det,10); top21=array(:0,-14,-5); term2_1=polydv(top21,%det,10); top22=array(:1,-3,2); term2_2=polydv(top22,%det,10); call tabulate(term1_1,term1_2,term2_1,term2_2); b34srun; /; /;POLYMINV_1 Psi Weights using OLSQ /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call load(buildlag); call load(varest); call echooff; ibegin=1; iend=296; nlag=3; nterms=12; x=catcol(gasin,gasout); /$ /$ From Beta forms the (I-L(B)) matrix. If this is /$ inverted, we get Psi weights /$ call varest(x,nlag,ibegin,iend,beta,t,sigma,corr,residual,1, a,ia,var1,varxhat1,rsq1); call polymdisp(:display a ia); call polyminv(a,ia,ainv,iainv,nterms); call polymdisp(:display ainv iainv); call polymdisp(:extract ainv iainv col1_1 index(1,1,0)); call polymdisp(:extract ainv iainv col2_1 index(2,1,0)); call polymdisp(:extract ainv iainv col1_2 index(1,2,0)); call polymdisp(:extract ainv iainv col2_2 index(2,2,0)); call tabulate(col1_1,col2_1,col1_2,col2_2); b34srun; /; /;POLYMINV_2 Psi Weights from a VAR Model - Test Cases /; /$ /$ Illustrates Calculation of Psi Weights from a VAR Model /$ These are tested indirectly with BTEST and Directly by /$ inverting the BTEST coefficients /$ /$ Cofficients are calculated two ways!!!! /$ /$ VAREST is used and validated against a direct call. /$ Note: Beta needs to be transformed in VAREST not used. /$ b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call load(buildlag); call load(varest); /$ call echooff; ibegin=1; iend=296; nlag=2; nterms=12; x=catcol(gasin,gasout); /$ /$ From Beta forms the (I-L(B)) matrix. If this is /$ inverted, we get Psi weights /$ call varest(x,nlag,ibegin,iend,beta,t,sigma,corr,residual,1, a,ia,var1,varxhat1,rsq1); call print(beta,t,sigma,corr); call polymdisp(:display a ia); call polyminv(a,ia,ainv,iainv,nterms); call print(%p,%det); call polymdisp(:display ainv iainv); call polymdisp(:display %adj %iadj); call polymmult(a ia ainv iainv test itest); call polymdisp(:display test itest); call polymdisp(:extract ainv iainv col1_1 index(1,1,0)); call polymdisp(:extract ainv iainv col2_1 index(2,1,0)); call polymdisp(:extract ainv iainv col1_2 index(1,2,0)); call polymdisp(:extract ainv iainv col2_2 index(2,2,0)); call tabulate(col1_1,col2_1,col1_2,col2_2); /$ an alternative way to go requiring more work and use /$ of dispmconv to get a and ia nlag=2; x=catcol(gasin,gasout); call olsq(gasin gasin{1 to nlag} gasout{1 to nlag} :print); beta=array(2,(nlag+nlag+1):); beta(1,)=%coef; call olsq(gasout gasin{1 to nlag} gasout{1 to nlag} :print); beta(2,)=%coef; call print(beta); call polymconv(:byvarin beta a ia); /$ /$ form [I-B(L)] then invert /$ call print(a); a=-1.*afam(a); a(1,1)=1.0; a(2,2)=1.0; call polymdisp(:display a ia); call polyminv(a,ia,ainv,iainv,nterms); call print(%p,%det); call polymdisp(:display ainv iainv); b34srun; /$ /$ Test against BTEST calculation of psi !!!! /$ b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec btest$ title=('Estimation run with gas data') $ seriesn var=gasin name=('b-j gas input data') $ seriesn var=gasout name=('b-j gas output data') $ ar(1,1,1)=.1 $ ar(1,1,2)=.1 $ ar(1,2,1)=.1 $ ar(1,2,2)=.1 $ ar(2,1,1)=.1 $ ar(2,1,2)=.1 $ ar(2,2,1)=.1 $ ar(2,2,2)=.1 $ output iprint lagrho=12 nfmat=12 $ constant=(yes,yes) $ forecast nt=(296,250) nf=(24,20) se actual $ b34seend$ /$ Test BTEST Coefficients b34sexec matrix; a=array(:1.,0. 0.,1., -1.81304, -.234096, .075556,-1.44623, .960862, .642300,-.046309, .579840); ia=index(2 2 3); nterms=12; call polymdisp(:display a ia); call polyminv(a,ia,ainv,iainv,nterms); call print(%p,%det); call polymdisp(:display ainv iainv); b34srun; /; /;POLYMMULT Multiply a Polynomial Matrix /; b34sexec matrix; * Test cases from Enders Robinson page 155-156; a=array(:0,1,0,-1, 2,0,1,1, 1,1,0,0,); ia=index(2 2 3); b=array(:0,1,0,0,0,1,1,1,1,0,1,0); ib=index(2 2 3); call polymmult(a,ia,b,ib,c,ic); call polymdisp(:display c ic); call polymmult(b,ib,a,ia,c2,ic2); call polymdisp(:display c2 ic2); call print(a,ia,b,ib,c,ic,c2,ic2); b34srun; /; /;POLYMULT Multiply two polynomials /; b34sexec matrix; a=array(2:1., .9); b=array(3:1., -.4, .3); c=polymult(a,b); call print('(1+.9B)*(1.-.4B+.3B**2)', '= (1.-.4B+.3B**2+.9B-.36B**2+.27B**3)', '= (1.+.5B-.06B**2-.27B**3)', a,b,c); top=1.; long=polydv(top,a,200); test=polymult(long,a); call print(test,long); b34srun; /; /;POLYROOT Polyroot function => solve Real*8 & Complex*16 Polyno /; /$ Tests Polyroot command b34sexec matrix$ * Simple Case ; coef=array(:-12.,-1.,1.); roots=polyroot(coef); call print('Tests Real Polynomial Solution' 'x**2-x-12=0', coef,roots); * Problem from Enters Robinson page 171; coef=array(:120,-154,71,-14,1); roots=polyroot(coef); call print('Enders Robinston Edition 2 page 171',coef,roots); ccoefr=array(4:10., -8.,-3.,1. ); ccoefi=array(4:0.0, 12.,-6.,0.0); ccoef=complex(ccoefr,ccoefi); croots=polyroot(ccoef); call print('Tests Complex Polynomial Solution' 'x**3-(3+6i)*x**2-(8-12i)*x+10.=0', ccoef,croots); * Big problem ; n=30; coef=rn(array(n:)); roots=polyroot(coef); call print('Tests Large Real Polynomial Solution' coef,roots); ccoefi=rn(array(n:)); ccoef=complex(coef,ccoefi); croots=polyroot(ccoef); call print('Tests Large Complex Polynomial Solution' ccoef,croots); b34srun$ /; /;POLYROOT1 Tests Stability of AR models /; b34sexec matrix$ * Polyroot Equation used to test if AR model is stable ; * Following Enders Model is stable if Characteristic roots < 1; * or inside unit circle.; * For high order systems necessary condition is sum (coef) < 1; * Sufficient condition is sum (abs(coef)) < 1 ; * At least one root is unity if sum(coef) = 1; * test y(t) = -.9*y(t-1) + u(t) ; coef=array(2:.9,1.); roots=polyroot(coef); call print('Tests y(t) = -.9*y(t-1) + u(t)', coef,roots); * test y(t) = -1.1*y(t-1) + u(t) ; coef=array(2:1.1,1.); roots=polyroot(coef); call print('Tests y(t) = -1.1*y(t-1) + u(t)' coef,roots); * test y(t) = .2*y(t-1) + .35*y(t-2) + u(t) ; * Enders page 26 case 1 ; coef=array(3:-.35,-.2,1.); roots=polyroot(coef); call print('Tests y(t) -.2*y(t-1) - .35*y(t-2)= u(t)' coef,roots); * test y(t) = .7*y(t-1) + .35*y(t-2) + u(t) ; * Enders page 27 case 2; coef=array(3:-.35,-.7,1.); roots=polyroot(coef); call print('Tests y(t) -.7*y(t-1) - .35*y(t-2)= u(t)' coef,roots); * Enders page 30 Imaginary case 1; coef=array(3:.9,-1.6,1.); roots=polyroot(coef); call print('Tests y(t) -1.6*y(t-1) + .9*y(t-2)= u(t)' coef,roots); * Enders page 30 Imaginary case 2; coef=array(3:.9,.6,1.); roots=polyroot(coef); call print('Tests y(t) +.6*y(t-1) + .9*y(t-2)= u(t)' coef,roots); b34srun$ /; /;POLYROOT2 Outside and inside unit corcle tests of AR(1) /; b34sexec matrix$ /$ Model y(t) = .9*y(t-1) + u(t) ; /$ Roots of COEF test using form of inside unit circle ; /$ Roots of COEF2 test using form of outside unit circle; coef =array(2:-.9, 1. ); coef2=array(2:1., -.9); call print('Test of Model y(t) = .9*y(t-1) + u(t)', 'Inside unit circle test ',polyroot(coef), ' ', 'Outside unit circle test', polyroot(coef2)); b34srun$ /; /;POLYVAL Evaluate an nth degree polynomial /; b34sexec matrix; call load(polyfit); call load(polyval); call print(polyfit,polyval); * Polyfit test case - See Mastering Matlab 6 page 327; x=dfloat(integers(0,10))/10.; y=array(11:-.447,1.978,3.28,6.16,7.08,7.34,7.66,9.56, 9.48,9.30,11.2); xx=x*x; call olsq(y,x,xx:print); call tabulate(%yhat); call echooff; call polyfit(x,y,2,coef,1); call polyval(coef,x,yhat); call tabulate(x,y,yhat); b34srun; /; /;PP Phillips-Perron Test /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call echooff; call print('Phillips-Perron Tests on Gasout'); call pp(gasout,p :print); n=30; app=array(n+1:); appt=array(n+1:); lag=array(n+1:); papp=array(n+1:); pappt=array(n+1:); do i=0,n; j=i+1; call pp(gasout,a1:app i); app(j)=a1; papp(j)=%ppprob; call df(gasout,a2:adft i); appt(j)=a2; pappt(j)=%ppprob; lag(j)=dfloat(i); enddo; call print('Phillips-Perron test':); call tabulate(lag,app,papp,appt,pappt); b34srun; /; /;PP1 Looks at Phillips-Perron Table /; /$ /$ /$ Job establishes critical values for PP test /$ /$ Unit root and noise generated /$ b34sexec matrix dseed=12332.; call echooff; * ncase=1000; ncase=10; n =5000; unit=array(n:); test =array(ncase:); test1=array(ncase:); test2=array(ncase:); test3=array(ncase:); do i=1,ncase; call outstring(2,3,'Case'); call outinteger(20,3,i); noise=rn(unit); unit=cusum(noise); call pp(unit, d); call pp(unit, d1 :app 4); call pp(unit, d2 :appt 4); call pp(noise,d3); test(i)=d; test1(i)=d1; test2(i)=d2; test3(i)=d3; enddo; q=array(8:.01 .025 .05 .10 .90,.95,.975,.99); call quantile(test, q,value); call quantile(test1,q,value1); call quantile(test2,q,value2); call quantile(test3,q,value3); call print('# cases ',ncase:); call print('# observations ',n:); Call Print('DF Test at .01 .025 .05 .10 .90 .95 .975 .99'); call tabulate(q,value,value1,value2,value3); call graph(test(ranker(test)) :heading 'Unit root Distribution - Case 1'); call graph(test1(ranker(test1)) :heading 'Unit root app Distribution - Case 2'); call graph(test2(ranker(test2)) :heading 'Unit root appt Distribution - Case 4'); call graph(test3(ranker(test3)) :heading 'Random Variable Distribution'); * For a discussion of why we cannot use these methods for Case # 4 in some cases see Hamilton page 497 ; b34srun; /; /;PP2 Negative unit root /; /$ /$ /$ Job establishes critical values for DF test /$ "unit root with negative" <= /$ /$ PP test does not detect ########### /$ /$ Unit root and noise generated /$ b34sexec matrix dseed=12332.; call echooff; * ncase=1000; ncase=10; n =5000; unit=array(n:); hold=array(n:); test =array(ncase:); test1=array(ncase:); test2=array(ncase:); test3=array(ncase:); jj=integers(1,n); hold(jj)=(-1.)**dfloat(jj); do i=1,ncase; call outstring(2,3,'Case'); call outinteger(20,3,i); noise=rn(unit); unit=cusum(noise); unit=afam(unit)*afam(hold); call pp(unit, d); call pp(unit, d1 :app 4); call pp(unit, d2 :appt 4); call pp(noise,d3); test(i)=d; test1(i)=d1; test2(i)=d2; test3(i)=d3; enddo; q=array(8:.01 .025 .05 .10 .90,.95,.975,.99); call quantile(test, q,value); call quantile(test1,q,value1); call quantile(test2,q,value2); call quantile(test3,q,value3); call print('# cases ',ncase,' # observations ',n); Call Print('PP Test at .01 .025 .05 .10 .90 .95 .975 .99'); call tabulate(q,value,value1,value2,value3); call graph(test(ranker(test)) :heading 'Unit root Distribution - Case 1'); call graph(test1(ranker(test1)) :heading 'Unit root adf Distribution - Case 2'); call graph(test2(ranker(test2)) :heading 'Unit root adf Distribution - Case 4'); call graph(test3(ranker(test3)) :heading 'Random Variable Distribution'); * For a discussion of why we cannot use these methods for Case # 4 in some cases see Hamilton page 497 ; b34srun; /; /;PRINT call print => Print objects and strings /; b34sexec matrix; x=matrix(3,3:11 22 33 55 66 77 88 99 00); v=vector(3:1 2 3); call print(x,v); inv=(1./x); call print(inv); cc=complex(inv,inv+3.); call print(cc); cv=complex(v,v-2.); call print(cv); test=x*inv; call print('This is the Identity Matrix',test); b34srun; /; /;PRINT1 Tests and Illustrates Print Formats /; /$ Tests various print formats b34sexec matrix display=col80fixed ; /$ b34sexec matrix display=col80medium ; /$ b34sexec matrix display=col80high ; /$ b34sexec matrix display=col129fixed ; /$ b34sexec matrix display=col129medium; /$ b34sexec matrix display=col129high ; * math with matrix and vectors ; n=30; call print('This is n',n); right=integers(1,((n*n))); call print('Integer',right); x=matrix(n,n:);x=rn(x); call print(x,afam(x)); v=vector(n:integers(1,n));call print('v',v) ; call names; call print(' Real*4 Results ' '++++++++++++++++++++++++++++++++++++++++'); rx=sngl(x+300.); call print(rx,afam(rx)); rv=sngl(v+300.); call print(rv,afam(rv)); call names; call print(' Integer Results ' '++++++++++++++++++++++++++++++++++++++++'); ix=idint(x+300.); call print(ix,afam(ix)); iv=idint(v+300.); call print(iv,afam(iv)); call names; call print(' Complex Results ' '++++++++++++++++++++++++++++++++++++++++'); x2=x+2.; x=mfam(complex(x,x2)); call print(x,afam(x)); v=mfam(complex(v,v+8.0)); call print(v,afam(v)); call names; call names(all); call print(' Character*8 Results ' '++++++++++++++++++++++++++++++++++++++++'); nn=namelist(Dan Jay Sarah Diana Carol Sylvia Judy Minna Liz); call print(nn); nn33=array(3,3:nn); call print(nn33); call names(all); b34srun; /; /;PRINT2 Printing Simulated output /; b34sexec matrix; call echooff; call print('Test of line 1':line); call print('Test of line 2':line); call print('Real Number ',.99 :line); call print('An integer ',11 :line); xx=.99; xx=sngl(xx); call print('A real*4 ',xx :line); call print(' ':line); call print('Print number with and without a header':line); call print(' ',.99:line); call print(.99:line); b34srun; /; /;PRINTALL Prints all variables in storage /; b34sexec matrix; x=rn(matrix(4,4:)); cc=inv(x); c=complex(1.2,3.3); call printall; b34srun; /; /;PRINTOFF Turn off all output /; b34sexec matrix; do i=1,10; call print(i); enddo; * Now we run silently ; call echooff; call printoff; do i=1,10; call print(i); enddo; call printon; call print('We are done!!'); b34srun; /; /;PRINTON Start Printing again /; b34sexec matrix; do i=1,10; call print(i); enddo; * Now we run silently ; call echooff; call printoff; do i=1,10; call print(i); enddo; call printon; call print('We are done!!'); b34srun; /; /;PROBIT Probit function /; b34sexec matrix; n=20; * Generate Rec variable in range 0.0 - 1.0 ; test=rec(array(n:)); pp=probit(test); call tabulate(test,pp); test=array(:.1 .2 .3 .4 .5 .6 .7 .8 .9 .95 .99); pp=probit(test); call tabulate(test,pp); b34srun; /; /;PROBNORM Probnorm function => Normal Probability /; b34sexec matrix$ z=grid(-4.5,4.5,.01); prob=probnorm(z); den=normden(z); call tabulate(z,prob,den); call graph(prob,den:htitle 1.5 1.5 :heading ' Normal Probabily and Density'); b34srun; /; /;PROBNORM2 Bivariate Normal Probability /; b34sexec matrix$ * IMSL Test Problem; x=-2.0; y=0.0; rho=.90; prob=probnorm2(x,y,rho); call print('Probability ',prob); x =array(:0.0 0.0 0.0); y =array(:0.0 0.0 0.0); rho=array(:0.0 1.0 .5); prob=probnorm2(x,y,rho); call tabulate(x,y,rho,prob); b34srun; /; /;PROD Prod function => shows dot product /; b34sexec matrix; x=vector(5:1 2 3 4 5); call print(x,prod(x)); xx=rn(matrix(6,6:)); e=eigenval(xx); call print('We note: Product of eigenvalues = det',det(xx),prod(e)); call print('We note: Sum of eigenvalues = trace',sum(e),trace(xx)); b34srun; /; /;PROGTEST1 Illustrates Program Calls /; /$ Tests of one programing calling another /$ Multiple calls are made b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call print('Means of gasout and gasin in root', mean(gasout),mean(gasin)); program meanp; * test program ; xmean1=mean(gasout); xmean2=mean(gasin); call print('Mean in Program for gasout was',xmean1); call print('Mean in Program for gasin was',xmean2); call matops; call graph(gasin,gasout); return; end; program matops; * Test program to be called by meanp or stand alone; x=matrix(4,4:); x=rec(x); call print(x); ix=1./x; call print(ix); call print('Did the Inverse work?',ix*x); return; end; call names(all); call print(meanp,matops); call meanp; call meanp; call meanp; b34srun; /; /;PROGTEST2 Illustrates use of programs at different levels /; b34sexec matrix showuse; * Illustrates how a program can access variables at current level; n=4; call names(all); x=rn(matrix(n,n:)); program listx; * this lists x at the level where it is called; call print('This is x as known at this point',x); return; end; subroutine level2(i); call print('Subroutine level2 called. I was ',I); x=rn(matrix(i,i:)); call print('x from print statement in level2',x); call listx; call print('We are leaving level2'); call names(all); return; end; call print('x from print statement at base level',x); call listx; j=3; call level2(j); call names(all); b34srun$ /; /;PVALUE_1 Present Value of $1 recieved at end of n years /; b34sexec matrix; call print('PV of $1 recieved at end of n years'); call print('See Douglas table 1',:); call echooff; call load(pvalue_1); interest=.06; n=20; years=integers(n); pv=array(n:); do i=1,n; call pvalue_1(i,interest,a); pv(i)=a; enddo; call tabulate(years,pv :noobslist :title 'Present value of 6% recieved after n years'); b34srun; /; /;PVALUE_2 Present Value of an Annuity of $1 /; b34sexec matrix; call print('PV of an Annuity of $1 after n years'); call print('See Douglas table 2',:); call echooff; call load(pvalue_2); call load(pvalue_1); sum=0.0; n=20; interest=.06; aa=array(n:); do i=1,n; call pvalue_2(i,interest,a); aa(i)=a; enddo; yearpays=integers(n); call tabulate(yearpays,aa :noobslist :title 'Present value of 6% annuity after n years'); b34srun; /; /;PVALUE_3 Present Value of $1 recieved thoughout year /; b34sexec matrix; call print('PV of $1 recieved througout year on daily basis',:); call print('Years Hence',:); call print('See Douglas table 3',:); call echooff; call load(pvalue_3); interest=.06; n=20; years=integers(n); pv=array(n:); do i=1,n; call pvalue_3(i,i,interest,a); pv(i)=a; enddo; call tabulate(years,pv :noobslist :title 'Present value of 6% annuity $1 daily'); b34srun; /; /;QFLOAT Integer to real*16 /; b34sexec matrix; r16g=r8tor16(grid(.1,6.,.3)) ; i=integers(norows(r16g)); r4i =float(i); r16i=qfloat(i) ; i4iqint=iqint(r16g) ; i4iqnint=iqnint(r16g) ; i4fromr4=int(r4i) ; r16qint=qint(r16g) ; call names(all) ; call tabulate(i,r4i,r16i,r16g,i4iqint,i4iqnint,i4fromr4 r16qint); b34srun; /; /;QINT Integer part of real*16 /; b34sexec matrix; r16g=r8tor16(grid(.1,6.,.3)) ; i=integers(norows(r16g)); r4i =float(i); r16i=qfloat(i) ; i4iqint=iqint(r16g) ; i4iqnint=iqnint(r16g) ; i4fromr4=int(r4i) ; r16qint=qint(r16g) ; r16qnint=qnint(r16g) ; call names(all) ; call tabulate(i,r4i,r16i,r16g,i4iqint,i4iqnint, i4fromr4 r16qint r16qnint); b34srun; /; /;QNINT Integer part of real*16 in a real*16 /; b34sexec matrix; r16g=r8tor16(grid(.1,6.,.3)) ; i=integers(norows(r16g)); r4i =float(i); r16i=qfloat(i) ; i4iqint=iqint(r16g) ; i4iqnint=iqnint(r16g) ; i4fromr4=int(r4i) ; r16qint=qint(r16g) ; r16qnint=qnint(r16g) ; call names(all) ; call tabulate(i,r4i,r16i,r16g,i4iqint,i4iqnint, i4fromr4 r16qint r16qnint); b34srun; /; /;QPMIN Quadratic Programing test case /; b34sexec matrix; * answers should be vector of 1. ; * Problem came from IMSL ; ncon=2; nvar=5; neq= 2; a=matrix(ncon,nvar: 1., 1., 1., 1., 1., 0., 0., 1.,-2.,-2. ); b=vector(ncon : 5.,-3.); g=vector(nvar :-2., 0., 0., 0.,0. ); h=matrix(nvar,nvar: 2., 0., 0., 0., 0. 0., 2.,-2., 0., 0. 0.,-2., 2., 0., 0. 0., 0., 0., 2.,-2. 0., 0., 0.,-2., 2. ); call qpmin(g,a,b,h,neq :print); b34srun; /; /;QRFACT QR Factorization /; b34sexec matrix; n=4;x=rn(matrix(n,n:)); pdx=transpose(x)*x; r1=pdfac(transpose(x)*x); r2=qrfac(x); call print('Positive Definite Matrix',pdx, 'Factorization from pdfac',r1, 'Factorization from qrfac',r2, 'Test if the Factorization was OK', 'transpose(r1)*r1', transpose(r1)*r1, 'transpose(r2)*r2', transpose(r2)*r2, ' ','Complex Case'); cpdx2=complex(pdx,mfam(dsqrt(dabs(pdx)))); cpdx =dconj(transpose(cpdx2))*cpdx2; cr1=pdfac(cpdx); cr2=qrfac(cpdx2); i=integers(norows(cpdx)); cpdx(i,i)=complex(real(cpdx(i,i)),0.0); call print('Positive Definite Matrix',cpdx, 'Factorization from pdfac', cr1, 'Factorization from qrfac', cr2, 'Test if the Factorization was OK', 'dconj(transpose(cr1))*cr1', dconj(transpose(cr1))*cr1,' ', 'dconj(transpose(cr2))*cr2', dconj(transpose(cr2))*cr2,' '); pdx=transpose(x)*x; /$ real*16 x=r8tor16(x); pdx=r8tor16(pdx); r1=pdfac(transpose(x)*x); r2=qrfac(x); call print('Real*16 Case', 'Positive Definite Matrix',pdx, 'Factorization from pdfac',r1, 'Factorization from qrfac',r2, 'Test if the Factorization was OK', 'transpose(r1)*r1', transpose(r1)*r1, 'transpose(r2)*r2', transpose(r2)*r2, ' ','Complex Case*32'); cpdx2=c16toc32(cpdx2); cpdx =dconj(transpose(cpdx2))*cpdx2; cr1=pdfac(cpdx); cr2=qrfac(cpdx2); i=integers(norows(cpdx)); cpdx(i,i)=qcomplex(qreal(cpdx(i,i)),r8tor16(0.0)); call print('Positive Definite Matrix',cpdx, 'Factorization from pdfac', cr1, 'Factorization from qrfac', cr2, 'Test if the Factorization was OK', 'dconj(transpose(cr1))*cr1', dconj(transpose(cr1))*cr1,' ', 'dconj(transpose(cr2))*cr2', dconj(transpose(cr2))*cr2,' '); b34srun; /; /;QRSOLVE QR Approach to OLSQ /; b34sexec options ginclude('b34sdata.mac') member(theil); b34srun; b34sexec matrix; call loaddata; call olsq(ct ri rpt :print); res1=%res; yhat1=%yhat; x=array(norows(ct),3:); x(,1)=ri ; x(,2)=rpt; x(,3)=1. ; x=mfam(x); r=qrfac(x,qr,pivot); * here we use qr to get beta ; call print(qr,pivot); beta=qrsolve(qr,pivot,ct,info); diffbeta=%coef-beta; call tabulate(%coef,beta,diffbeta); diffyhat=%yhat-yhat1; diffres =%res -res1; call tabulate(%qy,%qty,%res,%yhat,res1,yhat1,diffyhat,diffres); call print('Real*16 results':); x=r8tor16(x); r=qrfac(x,qr,pivot); * here we use qr to get beta ; call print(qr,pivot); beta=qrsolve(qr,pivot,r8tor16(ct),info); call print('beta',beta); b34srun; /; /;QUANTILE Quantile of Data /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; dd=grid(.00 1.0,.01); * Note that the 50% quantile is the median ; q=array(4:.25,.50,.75,1.0); call quantile(dd,q,qvalue); call tabulate(q,qvalue); call quantile(gasout,q,qvalue); call tabulate(q,qvalue); call load(cfreq); call cfreq(gasout,sgasout,cc); call echoon; call tabulate(gasout,sgasout,cc); b34srun; /; /;QUANTREG Test LI and Quantile Regression /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call echooff; call loaddata; call olsq(gasout gasin :l1 :minimax :print); call load(quantreg); * See if can get L1; /$ l1 ********************************************** iprint=1; theta=.5; y=gasout; x=matrix(norows(gasin),2:); x(,1)=1.0; x(,2)=vfam(gasin); call quantreg; call print('Sum absolute errors L1 (Theta = .5)',sumabs:); /$ Theta = .1 theta=.1; call quantreg; call print('Sum absolute errors (Theta = .1)',sumabs:); /$ Theta = .9 theta=.9; call quantreg; call print('Sum absolute errors (Theta = .9)',sumabs:); /$ Look at a range of Thetas beta1=array(9:); beta2=array(9:); fit =array(9:); iprint=0; do i=1,9; theta=dfloat(i)/10.; call quantreg; ttheta(i)=theta; beta1(i)=%coef(1); beta2(i)=%coef(2); fit(i)=sumabs; enddo; call tabulate(ttheta,beta1,beta2,fit:title 'Regression Quantiles for Various Theta'); call graph(ttheta,fit :plottype xyplot :Heading 'Fit Vs Quantile'); call graph(ttheta,beta1 :plottype xyplot); call graph(ttheta,beta2 :plottype xyplot); b34srun; /; /;RANDOM1 Random function => random number generation /; b34sexec matrix; n=5; c= rn(array(n:)); c2 = rn(vector(n:)); r =rec(array(n:)); r2 = rec(vector(n:)); call tabulate(c,c2,r,r2); b34srun; /; /;RANDOM2 Graphically Inspects Values Generated /; b34sexec matrix; n=100000; x=rn(array(n:)); x=x(ranker(x)); call graph(x :Heading '100,000 Random Normal Numbers'); x=rec(array(n:)); x=x(ranker(x)); call graph(x :Heading '100,000 Rectangular Numbers'); b34srun; /; /;RANDOM3 Tests IMSL-10 Gnerators /; /$ Tests IMSL Version 10 REC and Randon Number Generators /$ b34sexec matrix; n=20; x=array(n:); r1=rec(x); r2=rec(x:); rn1=rn(x); rn2=rn(x:drnnoa); rn3=rn(x:drnnor); call tabulate(r1,r2,rn1,rn2,rn3); b34srun; /; /;RANDOM4 Looks at Three RN Generators via ACF /; /$ Tests IMSL Version 10 REC and Randon Number Generators /$ Program will not run on RS/6000 + Sun since IMSL-10 /$ not supported /$ b34sexec matrix; n=200000; nacf=200; x=array(n:); rn1=rn(x); rn2=rn(x:drnnoa); rn3=rn(x:drnnor); call graph(rn1 rn2,rn3); acfrn1=acf(rn1:nacf); acfrn2=acf(rn2:nacf); acfrn3=acf(rn3:nacf); call graph(acfrn1,acfrn2,acfrn3); b34srun; /; /;RANKER ranker function => sort pointers /; b34sexec matrix; n=10; v=rn(vector(n:)); r=ranker(v); test=v(r); call tabulate(v r v(r) test); b34srun; /; /;READ1 READ/WRITE/OPEN/REWIND/CLOSE /; b34sexec matrix; * Tests I/O package ; * Real*8, Integer, Character*1 & Character*8 are written and read back ; * Note: Before reading, structure of object must be known!!!! ; n=1000; test=rn(array(n:)); call open(70,'testdata'); call write(test,70); tmean=mean(test); call print(tmean); i=integers(1,20); call write(i,70); call character(cc,'This is a test I hope it works'); call write(cc,70); a=array(3:'joan','Margo','Nancy'); call write(a,70); call names(all); call free(test); call rewind(70); call close(70); call open(71,'testdata'); test2=array(n:); call character(cc,'this is less '); call read(test2,71); /$ /$ test real*16 IO /$ call rewind(71); r16=r8tor16(test2); call read(r16,71); call tabulate(test2,r16); i=i+100; call read(i,71); call print(i); call read(cc,71); call print(cc); a(1)='bob'; call read(a,71); call print(a); tmean2=mean(test2); call print(tmean2); call names(all); call close(71); b34srun; /; /;READ2 End of file trapping /; b34sexec matrix; * Tests I/O package - attempting a read for more data that is there; n=10; test=rn(array(n:)); ii=integers(n); call open(70,'testdata'); call rewind(70); call write(test,70); tmean=mean(test); call print(tmean); call free(test); call rewind(70); call close(70); call open(71,'testdata'); n=20; test2=array(n:); call read(test2,71); call print(test2); tmean2=mean(goodrow(test2)); call print(tmean2); call names(all); call close(71); call open(70,'testdata'); call rewind(70); call write(ii,70); call print(ii); call free(ii); call rewind(70); call close(70); call open(71,'testdata'); n=20; test2=idint(array(n:)); call read(test2,71); call print(test2); call names(all); call close(71); b34srun; /; /;READ3 Illustrates Read/Write Implementation of MATLAB I/O /; b34sexec matrix ; /$ Shows Matrix subroutine implementations of built in /$ makematlab and getmatlab commands /$ /$ Job illustrates read / write i/o /$ subroutine gmatlab(c,xx); n=70; call open(n,c); call character(line,' '); call read(line,n); call print(line); xi=1.; xj=1.; call read(xi,n,'(20x,e16.8)'); call read(xj,n,'(20x,e16.8)'); xx=array(idint(xi),idint(xj):); call read(xx,n,'(5e16.8)'); call close(n); return; end; subroutine mmatlab(c,xx); n=70; call open(n,c); call character(ccc,'--File built by B34S(r) MATRIX Facility'); call write(ccc,n); i=norows(xx); j=nocols(xx); call write(dfloat(i),n,'(20x,e16.8)'); call write(dfloat(j),n,'(20x,e16.8)'); call write(xx,n,'(5e16.8)'); call close(n); return; end; xx=rn(array(100,50:)); call character(ccc,'c:\junk\test.mmm'); call mmatlab(ccc,xx); call gmatlab(ccc,crap); call print(crap); b34srun; /; /;REAL Real*8 from Complex*16 /; b34sexec matrix; xr=matrix(2,2:1 2 3 4); xi=dsqrt(xr); cc=complex(xr,xi); call print(cc,real(cc),imag(cc)); b34srun; /; /;REAL16 Creates a real*16 variable from Character string /; b34sexec matrix; r16= real16('.9q+00'); r16a=r8tor16(.9); call print('R16', r16:); call print('R16A' r16a:); call print('Difference ',(r16a-r16):); b34srun; /; /;R8TOR16 Real*8 to Real*16 Examples /; /$ Illustrates Real*16 and Complex*32 Processing b34sexec matrix; n=4; ncase=1; x=rn(matrix(n,n:)); y=rn(x); xty=x*y; call print(x,y,xty); r16x=r8tor16(x); r16y=r8tor16(y); r16xty=r16x*r16y; call print(r16x,r16y,r16xty); diff=xty-r16tor8(r16xty); call print('Difference',diff); call print('Transpose test',transpose(x),transpose(r16x)); v8=rn(vector(9:)); c16=complex(v8,2.*v8); call print('Are these the same?',c16,c16toc32(c16)); v16=r8tor16(v8); call print(v16); call print(r8tor16(2.)*v16); c32=qcomplex(v16,r8tor16(2.)*v16); c16m=complex(x,y); c32m=qcomplex(r16x,r16y); call print('are these the same?',c16m,c32m); call tabulate(v8,v16,c16,c32); b34srun; /; /;R16TOR8 Real*16 to Real*8 Examples /; /$ Illustrates Real*16 and Complex*32 Processing b34sexec matrix ; n=4; x=rn(matrix(n,n:)); r16x=r8tor16(x); r8now=r16tor8(r16x); call print(x,r16x,r8now); diff=x-r8now; call print('Difference',diff); b34srun; /; /;RECODE Recode a variable /; b34sexec matrix; x =array(:1 2 3 0 6 0); cx =namelist(test1 test2 test3 test4 test5); xi =index(1 2 3 4 5 4 3); newx =recode(x,0.0,missing()); newcx=recode(cx,'TEST2','new2'); newxi=recode(xi,4,99); call tabulate(x,newx,cx,newcx,xi,newxi); b34srun; /; /;RECURSIVE Illustrates Recursive Calls /; b34sexec matrix cbuffer=500000 showuse; * Shows slow times for recursive calls ; * Do loops faster!!!!; * Use of FORMULA and SOLVE statements are a still better way to go!!; call echooff; function test(i); i=i+1; j=i; call outinteger(3,3,i); if(i.gt.50)go to done; j=test(i); done continue; return(j); end; program testp; i=i+1; j=i; call outinteger(3,3,i); if(i.gt.50)go to done; call testp; done continue; return; end; call timer(base); i=1; k=test(i); call names(all); call print(k); call timer(base2); call print(' Function calls took',base2-base); call timer(base); i=1; call testp; call names(all); k=i; call print(k); call timer(base2); call print('Program calls took',base2-base); call timer(base); j=0; do i=1,50; j=j+1; call outinteger(3,3,j); enddo; call print(j); call timer(base2); call print('Do took',base2-base); b34srun; /; /;RENAME Rename an object /; b34sexec matrix; test1=object(x,y); test2=object(x,y,1); call names; call print(test1,test2); x=10.; y=40.; call rename(x,test1); call rename(y,object(p,v,0)); call names; call print(xy,pv0); b34srun; /; /;RESET Illustrates Ramsey (1969) Reset Test /; b34sexec options ginclude('gas.b34'); b34srun; /; /; See Ramsey, J. 'Tests for Specification Errors in Classical /; Linear Least Squares Regression Analysis' /; Journal of the Royal Statistical Society, /; Series B: 350-371 /; b34sexec matrix; call echooff; call loaddata; lower=2; do ik=2,6; do ip=lower,18; call reset(gasin,tt,ip,ik,pp); j=ip-lower+1; test(j) =tt; prob(j) =pp; order(j)=ip; enddo; call print('Ramsey (1969) test for',ik); call tabulate(order,test,prob); enddo; b34srun; /; /;RESET77 Illustrates Thursby - Schmidt RESET(77) Test /; b34sexec matrix ; /; /; Ref: "Some Properties of Tests for Spwecification Error in a /; Linear Regression Model" JASA September 1977 Vol 72 /; Number 359 pp 635-641 /; /; Set up to run big cases such as n=100000 ncases=100 /; By not having a loop => can call comress as "end" of loop /; call echooff ; call load(reset77); call print(reset77); /; Build an AR model n=10000 ; ncases=10; ar=0.25 ; call free(ma); const=0.0; start=.1; wnv=1.0; nout=200; i=0; /$ Loop using go to => can use a compress test continue; i=i+1; ar1yt =genarma(ar,ma,const,start,wnv,n,nout); call reset77(ar1yt,1,4,res77,pres77,1); call compress; if(i.lt.ncases)go to test; b34srun ; /; /;RESTORE Call restore => Reload workspace /; /$ The file matrix.psv can be read by Speakeasy with /$ the command importall(matrix) b34sexec options ginclude('b34sdata.mac') macro(res72); b34srun; b34sexec matrix; call loaddata; call print(mean(l), mean(k),mean(q),mean(lnl), mean(lnk),mean(lnq)); call names; call names(all); call save; call cleardat; call restore(:list); call names(all); call restore; call names(all); call tabulate(l k q lnl lnk lnq); call print(mean(l), mean(k),mean(q),mean(lnl), mean(lnk),mean(lnq)); b34srun; /; /;RESTORE2 Tests Restore & Save with further examples /; b34sexec matrix; * Math with matrix and vectors ; * For bigger problems, change n; n=3; right=integers(1,((n*n)-1))+10; call print('Right ',right); x=matrix(n,n:right,-7); x2=x*2.; v=vector(n:integers(1,n)); call print('X, 2*x v' ,x,x2,v) ; call print('Inverse of x (INV)' ,(1./x)) ; call print('X*inv' ,x*(1./x)); call print('Vector times matrix (v*x)' ,v*x) ; call print('Matrix times vector (x*v)' ,x*v) ; call print('Matrix times matrix (x*x2)' ,x*x2) ; call print('Matrix times scaler (x*2.)' ,x*2.) ; call print('Scaler times Matrix (3.*x)' ,3.*x) ; call print('Vector plus matrix (v+x)' ,v+x) ; call print('Matrix plus vector (x+v)' ,x+v) ; call print('Matrix plus matrix (x+x2)' ,x+x2) ; call print('Matrix plus scaler (x+2.)' ,x+2.) ; call print('Scaler plus matrix (3.+x)' ,3.+x) ; call print('Vector minus matrix (v-x)' ,v-x) ; call print('Matrix minus vector (x-v)' ,x-v) ; call print('Matrix minus matrix (x-x2)' ,x-x2) ; call print('Matrix minus scaler (x-2.)' ,x-2.) ; call print('Scaler minus matrix (3.-x)' ,3.-x) ; call print('Array Math Here '); x=afam(x); v=afam(v); x2=x*2.; call print('X, 2*x v' ,x,x2,v) ; call print('Inverse of x (INV)' ,(1./x)) ; call print('X*inv' ,x*(1./x)); call print('Array(1) times Array(2) (v*x)' ,v*x) ; call print('Array(2) times Array(1) (x*v)' ,x*v) ; call print('Array(2) times Array(2) (x*x2)' ,x*x2) ; call print('Array(2) times Scaler (x*2.)' ,x*2.) ; call print('Scaler times Array(2) (3.*x)' ,3.*x) ; call print('Array(1) plus Array(2) (v+x)' ,v+x) ; call print('Array(2) plus Array(1) (x+v)' ,x+v) ; call print('Array(2) plus Array(2) (x+x2)' ,x+x2) ; call print('Array(2) plus Scaler (x+2.)' ,x+2.) ; call print('Scaler plus Array(2) (3.+x)' ,3.+x) ; call print('Array(1) minus Array(2) (v-x)' ,v-x) ; call print('Array(2) minus Array(1) (x-v)' ,x-v) ; call print('Array(2) minus Array(2) (x-x2)' ,x-x2) ; call print('Array(2) minus scaler (x-2.)' ,x-2.) ; call print('Scaler minus Array(2) (3.-x)' ,3.-x) ; call print(' Complex Results ' '++++++++++++++++++++++++++++++++++++++++'); x=mfam(complex(x,x2)); v=vfam(complex(v,v+8.0)); x2=mfam(complex(x2)); call print('X, x2 v' ,x,x2,v) ; call print('Inverse of x (INV)' , (complex(1.)/x)) ; call print('X*inv' , x*(complex(1.)/x)); call print('Vector times matrix (v*x)' ,v*x) ; call print('Matrix times vector (x*v)' ,x*v) ; call print('Matrix times matrix (x*x2)' ,x*x2) ; call print('Matrix times scaler (x*2.)',x*complex(2.)) ; call print('Scaler times Matrix (3.*x)',complex(3.)*x) ; call print('Vector plus matrix (v+x)',v+x) ; call print('Matrix plus vector (x+v)',x+v) ; call print('Matrix plus matrix (x+x2)',x+x2) ; call print('Matrix plus scaler (x+2.)',x+complex(2.)) ; call print('Scaler plus matrix (3.+x)',complex(3.)+x) ; call print('Vector minus matrix (v-x)',,v-x) ; call print('Matrix minus vector (x-v)' ,x-v) ; call print('Matrix minus matrix (x-x2)',x-x2) ; call print('Matrix minus scaler (x-2.)',x-complex(2.)) ; call print('Scaler minus matrix (3.-x)',complex(3.)-x) ; call print('Array Math Here '); x=afam(x); v=afam(v); x2=afam(x2); call print('X, 2*x v' ,x,x2,v) ; call print('Inverse of x (INV)', (complex(1.)/x)) ; call print('X*inv' , x*(complex(1.)/x)); call print('Array(1) times Array(2) (v*x)' ,v*x) ; call print('Array(2) times Array(1) (x*v)' ,x*v) ; call print('Array(2) times Array(2) (x*x2)' ,x*x2) ; call print('Array(2) times Scaler (x*complex(2.))',x*complex(2.)); call print('Scaler times Array(2) (complex(3.)*x)',complex(3.)*x); call print('Array(1) plus Array(2) (v+x)' ,v+x) ; call print('Array(2) plus Array(1) (x+v)' ,x+v) ; call print('Array(2) plus Array(2) (x+x2)' ,x+x2) ; call print('Array(2) plus Scaler (x+complex(2.))',x+complex(2.)); call print('Scaler plus Array(2) (complex(3.)+x)',complex(3.)+x); call print('Array(1) minus Array(2) (v-x)' ,v-x) ; call print('Array(2) minus Array(1) (x-v)' ,x-v) ; call print('Array(2) minus Array(2) (x-x2)' ,x-x2) ; call print('Array(2) minus scaler (x-complex(2.))',x-complex(2.)); call print('Scaler minus Array(2) (complex(3.)-x)',complex(3.)-x); call save(:file 'mathdata.psv'); call names; call cleardat; call restore(:file 'mathdata.psv'); call names; b34srun; %b34sendif; %b34sif(&test5.eq.1)%then; /; /;REVERSE Hinich-Rothman (1998) Reverse Test /; b34sexec options ginclude('b34sdata.mac') member(rothtr1); b34srun; b34sexec matrix; call loaddata; n=2000; x=rn(array(n:)); /$ rn data call reverse(x :print :rb 20. ); call reverse(nomgnp :print :rb 9.5 :norm divide ); call rothman(nomgnp :order 5 :test tr1 :ar 1 :tran dif :print); b34srun; b34sexec options ginclude('b34sdata.mac') member(rothtr2); b34srun; b34sexec matrix; call loaddata; call reverse(gnpdefl :print :rb 9.5 :norm divide ); call rothman(gnpdefl :order 5 :test tr2 :ar 1 :tran dif :print); b34srun; /; /;REVERSE_2 Hinich-Rothman Tests of Barnett Nonlinearity Datsets /; b34sexec options ginclude('b34sdata.mac') member(barnett); b34srun; b34sexec matrix; call loaddata; rb=20.; call reverse(model1 :print :rb rb); call reverse(model2 :print :rb rb); call reverse(model3 :print :rb rb); call reverse(model4 :print :rb rb); call reverse(model5 :print :rb rb); b34srun; /; /;RN Tests IMSL-10 Generators /; /$ Tests IMSL Version 10 REC and Randon Number Generators /$ Look at RANDOM1 and RANDOM2 test problems /$ b34sexec options recver(ggubs) rnver(ggnml); b34srun; b34sexec matrix showuse; n=20; x=array(n:); r1=rec(x); r2=rec(x:); rn1=rn(x); rn2=rn(x:drnnoa); rn3=rn(x:drnnor); call tabulate(r1,r2,rn1,rn2,rn3); b34srun; /$ Reset back to IMSL b34sexec options recver(imsl_1) rnver(drnnoa); b34srun; /; /;RN2 Resetting Seed on the fly /; b34sexec matrix showuse; call i_rnget(i); call print('seed at start',i:); x=array(8:); call print(rn(x :drnnoa)); call i_rnget(j); call print('seed now is ',j:); call i_rnset(i); call print(rn(x:drnnoa)); b34srun; /; /;RN3 Resetting Seed on the fly using calls /; b34sexec matrix; call i_rnget(i); call print('seed at start',i:); x=array(8:); call i_drnnoa(x); call print(x); call i_rnget(j); call print('seed now is ',j:); call i_rnset(i); call i_drnnoa(x); call print(x); b34srun; /; /;ROLLDOWN Rolldown function => move matrix rows down /; b34sexec matrix; n=10; v=rn(vector(n:)); downv=rolldown(v); call tabulate(v downv); x=rn(matrix(5,5:)); call print('Illustrates Rolldown',x,rolldown(x)); x=rn(matrix(5,6:)); call print('Illustrates Rolldown',x,rolldown(x)); b34srun; /; /;ROLLLEFT rollLeft function => move cols left /; b34sexec matrix; n=10; v=rn(vector(n:)); leftv=rollleft(v); call tabulate(v leftv); x=rn(matrix(5,5:)); call print('Illustrates Rollleft',x,rollleft(x)); x=rn(matrix(5,6:)); call print('Illustrates Rollleft',x,rollleft(x)); b34srun; /; /;ROLLRIGHT Rollright function => move matrix cols right /; b34sexec matrix; n=10; v=rn(vector(n:)); rightv=rollright(v); call tabulate(v rightv); x=rn(matrix(5,5:)); call print('Illustrates Rollright',x,rollright(x)); x=rn(matrix(5,6:)); call print('Illustrates Rollright',x,rollright(x)); b34srun; /; /;ROLLUP Rollup function => move matrix rows up /; b34sexec matrix; n=10; v=rn(vector(n:)); upv=rollup(v); call tabulate(v upv); x=rn(matrix(5,5:)); call print('Illustrates Rollup',x,rollup(x)); x=rn(matrix(5,6:)); call print('Illustrates Rollup',x,rollup(x)); b34srun; /; /;ROTHMAN Rothman Reversability Test /; b34sexec options ginclude('b34sdata.mac') member(rothtr1); b34srun; /$ /$ Tests setup to exactly replicate Rothman (1997) test output /$ Rothman code fixed to remove three bugs: /$ 1. backforecasts were overwritting code /$ 2. Backforecasts were not initialized. Now randon numbers used /$ 3. 100 observations dropped for simulations to stabilize model /$ b34sexec matrix; call loaddata; call rothman(nomgnp :maxit 100 :test tr1 :order 5 :ar 1 :tran dif :iseed 25443332 :print); call names(all); b34srun; b34sexec options ginclude('b34sdata.mac') member(rothtr2); b34srun; b34sexec matrix; call loaddata; call rothman(gnpdefl :maxit 100 :test tr2 :order 5 :ar 1 :tran dif :iseed 25443332 :print); call names(all); b34srun; /; /;RRPLOTS Plots of Recursive Residuals /; /$ /$ This job validates the rrplots routine and the /$ RR option on the OLSQ command /$ b34sexec options ginclude('b34sdata.mac') macro(eeam88)$ b34seend$ b34sexec matrix; call loaddata; call load(rrplots); call olsq( lnq lnk lnl :rr 1 :print); call tabulate(%rrobs,%ssr1,%ssr2,%rr,%rrstd,%res); call print('Sum of squares of std RR ',sumsq(goodrow(%rrstd)):); call print('Sum of squares of OLS RES ',sumsq(goodrow(%res)):); call print(%rrcoef,%rrcoeft); call rrplots(%rrstd,%rss,%nob,%k,%ssr1,%ssr2,1); b34srun; /; /;RTEST ACF and PACF of OLS Model /; /$ Illustrates incomplete and complete Model b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call load(rtest); call olsq(gasout gasin:print :diag); call rtest(%res,gasout,48); call olsq(gasout gasin{1 to 6} gasout{1 to 6} :print); call rtest(%res,gasout,48); b34srun; /; /;RTEST2 ACF and PACG of OLS Model no Y and Res Plot /; /$ Illustrates incomplete and complete Model b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call load(rtest2); call olsq(gasout gasin:print :diag); call rtest2(%res,gasout,48); call olsq(gasout gasin{1 to 6} gasout{1 to 6} :print); call rtest2(%res,gasout,48); b34srun; /; /;RTOCH Converts real*8 to Character*8 /; b34sexec matrix; x=array(5:1 2 3 4 5); call print(x); cx=rtoch(x); call names; newx=chtor(cx); call tabulate(x,newx); b34srun; /; /;RUNMATLAB1 Run Matlab Using a Script /; /$ Running Matlab script under B34S Matrix b34sexec matrix; /$ /$ These are malab commands /$ datacards; % See Matlab Graph Manual page 2-26 t = 0:pi/20:2*pi; [x,y]=meshgrid(t); subplot(2,2,1) plot(sin(t),cos(t)) axis equal title('plot(sin(t),cos(t))') subplot(2,2,2) z=sin(x)+cos(y); plot(t,z) axis ([0 2*pi -2 2]) title('z=sin(x)+cos(y)') subplot(2,2,3) z=sin(x).*cos(y); plot(t,z) axis([0 2*pi -1 1]) title('z=sin(x).*cos(y)') subplot(2,2,4) z = (sin(x).^2)-(cos(y).^2); plot(t,z) axis([0 2*pi -1 1]) title('z = (sin(x).^2)-(cos(y).^2))') pause quit b34sreturn; call open(77,'test.m'); call rewind(77); call rewind(4); call copyf(4,77); call close(77); call copyout('test.m'); b34srun; /; /;SAVE Call SAVE & Restore commands => Manage workspace /; /$ The file matrix.psv can be read by Speakeasy with /$ the command importall(matrix) b34sexec options ginclude('b34sdata.mac') macro(res72); b34srun; b34sexec matrix; call loaddata; call print(mean(l), mean(k),mean(q),mean(lnl), mean(lnk),mean(lnq)); call names; call names(all); call save; call cleardat; call restore(:list); call names(all); call restore; call names(all); call tabulate(l k q lnl lnk lnq); call print(mean(l), mean(k),mean(q),mean(lnl), mean(lnk),mean(lnq)); b34srun; /; /;SCHUR Performs Schur decomposition /; b34sexec matrix; * Example from Matlab - General Matrix; a=matrix(3,3: 6., 12., 19., -9., -20., -33., 4., 9., 15.); call schur(a,s,u); call print(a,s,u); is_ident=u*transpose(u); is_a =u*s*transpose(u); * Look at eigenvalues of this degenerate matrix ; e=eigenval(a,evec:lapack); * no scaling ; e_noscal=eigenval(a,evec_ns:lapack); call print('Tests of the schur', is_ident,is_a, e,evec,e_noscal,evec_ns); * Positive Def. case ; aa=transpose(a)*a; call schur(aa,ss,uu); ee=eigenval(aa:lapack); call print(aa,ss,uu,ee); * Expanded calls; call schur(a,s,u,wr,wi); call print('Real and Imag eigenvalues'); call tabulate(wr,wi); * Testing Properties; call print(is_a,is_ident); * Random Problem ; n=10; a=rn(matrix(n,n:)); call schur(a,s,u); call print(a,s,u); is_ident=u*transpose(u); is_a =u*s*transpose(u); call schur(a,s,u,wr,wi); call print('Real and Imag eigenvalues'); call tabulate(wr,wi); call print(is_a,is_ident); * Complex case ; a=matrix(3,3: 6., 12., 19., -9., -20., -33., 4., 9., 15.); ca=complex(a,2.*a); call schur(ca,cs,cu,cw); call print(ca,cs,cu,'Eigenvalues Two Ways', cw,eigenval(ca)); is_ca=cu*cs*transpose(dconj(cu)); call print(is_ca); b34srun; /; /;SCHUR_2 Illustrates real vs Complex Schur /; b34sexec matrix; * Complex Form of Schur has eigenvalues along diagonal ; a=rn(matrix(4,4:)); call schur(a,s,u); call print(eig(a),a,s,u); call schur(complex(a),cs,cu); call print(eig(complex(a)),a,cs,cu); * tests ; call print(a,u*s*transpose(u),cu*cs*transpose(dconj(cu))); b34srun; /; /;SCREENOUT Illustrates SCREENOUTON / SCREENOUTOFF /; b34sexec matrix; /$ Illustrates SCREENOUTON /$ Note that OUTSTRING, OUTDOUBLE, OUTINTEGER will not /$ work if SCREENOUTON is in effect /$ /$ User can change the size of the last problem by setting N call screenouton; x=matrix(3,3:11 22 33 55 66 77 88 99 00); v=vector(3:1 2 3); call print(x,v); inv=(1./x); call print(inv); test=x*inv; call print(test); vx=v*x; call print(vx); xx=x*x; call print(xx); xv=x*v; call print(xv); * Big tests !! ; /$call cls; call message('Illustrates MESSAGE','Testing Message',jj); call print('Message returns',jj); call cls(3); call outstring(3,3,'This is jj'); call outinteger(30,3,jj); call cls(4); call outstring(3,4,'This is 5'); call outinteger(30,4,5 ); call cls(5); call outstring(3,5,'This is 88.88!!'); call outdouble(40,5,88.8); call print('We have stopped!!!.',' ','Hit enter to proceed'); call stop(pause); n=100; x=matrix(n,n:); call timer(base); x=rn(x); /$call print(x); call timer(base2); call print('RN used ',base2-base); ff=(1./x); call timer(base); call print('Inverse used ',base-base2); test=x*ff; s=sum(test); call timer(base2); call print('Mult and test used ',base2-base); call print(s); b34srun; /; /;SCREEN_1 Illustrate Screenclose /; b34sexec matrix; call screenclose; call open(70,'test.f'); call rewind(70); call character(test," write(6,*)'This is a test # 2'" " n=1000 " " write(6,*)n " " do i=1,n " " write(6,*) sin(float(i)) " " enddo " " stop " " end "); call write(test,70); call close(70); call dodos('lf95 test.f'); call dounix('lf95 test.f -otest'); call dodos('test > testout':); call dounix('./test > testout':); call open(71,'testout'); call character(test2,' '); call read(test2,71); call print(test2); testd=0.0; n=0; call read(n,71); testd=array(n:); call read(testd,71); call print(testd); call close(71); call dodos('erase testout'); call dodos('erase test.f'); call dounix('rm testout'); call dounix('rm test.f'); call screenopen; b34srun; /; /;SCREEN_2 Illustrate Screenopen /; b34sexec matrix; call screenclose; call open(70,'test.f'); call rewind(70); call character(test," write(6,*)'This is a test # 2'" " n=1000 " " write(6,*)n " " do i=1,n " " write(6,*) sin(float(i)) " " enddo " " stop " " end "); call write(test,70); call close(70); call dodos('lf95 test.f'); call dounix('lf95 test.f -otest'); call dodos('test > testout':); call dounix('./test > testout':); call open(71,'testout'); call character(test2,' '); call read(test2,71); call print(test2); testd=0.0; n=0; call read(n,71); testd=array(n:); call read(testd,71); call print(testd); call close(71); call dodos('erase testout'); call dodos('erase test.f'); call dounix('rm testout'); call dounix('rm test.f'); call screenopen; b34srun; /; /;SEIG Symmetric Eigenvalue Analysis /; b34sexec matrix; * Test case for Real symmetric Matrix from IMSL Math (10) pp 309-311; a=matrix(3,3:7.,-8.,-8.,-8.,-16.,-18.,-8.,-18.,13.); call print('A Matrix',a); e=seig(a); call print('Eigenvalues of a', e, 'Sum of the eigenvalues of Symmetric Martix A',sum(e), 'Trace of Symmetric Matrix A',trace(a), 'Product of the eigenvalues of Symmetric Martix A',prod(e), 'Determinant of Symmetrix Matrix A',det(a)); ee=seig(a,evec); call print(ee,evec); call print('Test transpose(evec)*evec ', transpose(evec)*evec , ' ' 'Note: a*evec = evec*diagmat(ee)' a*evec,evec*diagmat(ee), 'Test evec*transpose(evec) ', evec*transpose(evec)) ; call print('Using EISPACK and LAPACK Test results':); e =eig(a,evec); e2=eig(a,evec2:lapack); call print('Eispack',evec, 'Test of eigenvalues note that diagonal matrix but not 1 on diag' transpose(evec)*evec 'Do we get a' evec*diagmat(e)*inv(evec) ' ' 'Test of LAPACK',evec2 'Do we get a' evec2*diagmat(e)*inv(evec2) evec2*transpose(evec2) transpose(evec2)*evec2); /$ Real*16 r16a=r8tor16(a); r16e=seig(r16a); call print('Eigenvalues of r16a', r16e, 'Sum of the eigenvalues of Symmetric Martix A',sum(r16e), 'Trace of Symmetric Matrix A',trace(r16a), 'Product of the eigenvalues of Symmetric Martix A',prod(r16e), 'Determinant of Symmetrix Matrix A',det(r16a)); r16ee= seig(r16a,r16evec); call print(r16ee,r16evec); call print('Test transpose(evec)*evec ', transpose(r16evec)*r16evec , ' ' 'Note: a*evec = evec*diagmat(ee)' r16a*r16evec,r16evec*diagmat(r16ee), 'Test evec*transpose(evec) ', r16evec* transpose(r16evec)) ; b34srun; /; /;SET Illustrates set command /; b34sexec matrix; n=4; x=rn(matrix(n,n:)); call print(x); call set(x,3.0); call print('Here all of x is 3.0',x); call set(x,0.0); call setcol(x,3,5.0); call print('Here col 3 is 5.0' ,x); call set(x,0.0); call setrow(x,4,88.0); call print('Here row 4 is 88.0',x); b34srun; /; /;SETCOL Illustrates setcol command /; b34sexec matrix; n=3; x=rn(matrix(n,n:)); call print(x); call setcol(x,1,3.0); call print(x); acol=array(n:); call setcol(acol,1,-55.); call print('Col 1 is -55.',acol); call print('Alternative'); acol(,1)=-88.; call print(acol); call print('While setcol checks for type.' 'x(,1)=88; ' 'Redefines as an integer '); x(,1)=88; call print(x); b34srun; /; /;SETLABEL Illustrate SETLABEL /; b34sexec matrix; short=10.; long= 20; call names; call setlabel(short,'test'); call setlabel(long, 'This is a long label'); call names; call print('Label for long' ,label(long), 'Label for short',label(short)); b34srun; /; /;SETLEVEL Illustrates setlevel /; b34sexec matrix; x=1.; call makeglobal(x); call setlevel(now); do i=1,20; xx=33.; call setlevel(up); call setlevel(now); call names(all); call setlevel(up); call setlevel(now); call setlevel(down); call setlevel(down); enddo; call setlevel(base); call names(all); b34srun; /; /;SETNDIMV Sets Value in an N dimensional object /; b34sexec matrix; mm=index(4,5,6:); xx=rn(array(mm:)); idim =index(4,5,6); idim2=index(2,2,2); call setndimv(idim,idim2,xx,10.); vv= getndimv(idim,idim2 ,xx); call print(xx,vv); b34srun; /; /;SETROW Illustrates setrow command /; b34sexec matrix; n=3; x=rn(matrix(n,n:)); call print(x); call setrow(x,2,3.0); call print('Here row 2 is 3.0',x); call print('Alternative'); x(2,)=-88.; call print(x); call print('While setrow checks for type.' 'x(2,)=88; ' 'Redefines as an integer '); x(2,)=88; call print(x); b34srun; /; /;SETTIME Sets internal time data in a series /; b34sexec matrix; x=rn(array(120:)); call settime(x,1960,1,12.); call print(timebase(x),timestart(x),freq(x)); jdate=makejul(x); year=fyear(jdate); call graph(year,x :plottype xyplot); b34srun; /; /;SEXTRACT Pull Data from a datatype /; b34sexec matrix; people=namelist(pname,ssn,age,race,income); pname =namelist(sue,joan,bob); ssn =array(:99,9821,22); age =idint(array(:35,45,58)); race =namelist(hisp,white,black); income=array(:40000,35000,50000); call tabulate(pname,ssn,age,race,income); call print(sextract(people(3))); call print('Second person',sextract(people(1),2), sextract(people(3),2)); nage=age+1; call isextract(people(3),nage); call print(age); call isextract(people(3),77,1); call print(age); b34srun; /; /;SFAM Conversion of Scaler Klass /; b34sexec matrix; x=array(1,1:1); call print(klass(x),klass(sfam(x))); b34srun; /; /;SIMULATE Dynamic Silulation of OLS Model /; /$ /$ Job illustrates use of SIMULATE in a bootstrap calculation /$ using the staging bootols subroutine /$ b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix$ call loaddata; call echooff; subroutine bootols(y,x,error,coef,nboot,bcoef,se,isave,lag); /$ /$ Bootstrap a model y = f(x) /$ We can assume no lags in tne model /$ /$ /$ Usually y = %y from olsq call /$ e = %x from olsq call with :savex option /$ error = %res from olsq call /$ coef = %coef from olsq call /$ hcoef = nboot by k matrix of estimated coefficients /$ hse = nboot by k matrix of estimated se scores /$ hrsq = nboot vector of r**2 /$ nboot = # of bootstraps /$ bcoef = bootstrap coef /$ bse = bootstrap se /$ isave = 0 => do not save internal variables /$ 1 => save %hcoef %hse %hrsq in global variables /$ lag NE 0 assumes there are lag y values in x /$ /$ Since lags already in the x matrix => works for cross section /$ or time series models /$ /$ Due to the recursive nature of the problem when lag > 0 the code /$ doe not run fast!! /$ /$ Command built 20 August 2003 /$ nob=norows(x)$ %hcoef=matrix(nboot,nocols(x):)$ %hse =matrix(nboot,nocols(x):)$ %hrsq =vector(nboot:)$ ywork=vector(nob:)$ error=vfam(error)$ if(lag.eq.0)then; do ii=1,nboot$ /$ ywork=vfam(coef)*transpose(mfam(x))+ error(booti(nob))$ call simulate(ywork,coef,x,bootv(error)); call olsq(ywork x :noint); %hcoef(ii,)=%coef$ %hse(ii,) =%se$ %hrsq(ii) =%rsq$ call outstring(3,3,'Bootstrap #'); call outinteger(30,3,ii); enddo$ endif; if(lag.ne.0)then; lagorder=integers(lag); do ii=1,nboot$ call simulate(ywork,coef,x,bootv(error) :lags lag bootv(y)); call olsq(ywork x :noint); %hcoef(ii,)=%coef$ %hse(ii,) =%se$ %hrsq(ii) =%rsq$ call outstring(3,4,'Time Series Bootstrap #'); call outinteger(30,4,ii); enddo$ endif; bcoef=vector(nocols(%hcoef):); se =vector(nocols(%hcoef):); /$ /$ This gets the SE /$ do j=1,nocols(%hcoef); bcoef(j)=mean(%hcoef(,j)); call quantile(%hcoef(,j),.025, lower); call quantile(%hcoef(,j),.975, upper); if(upper.ne.lower)se(j)=(upper-lower)/4.0; enddo; if(isave.eq.1)call makeglobal(%hcoef,%hse,%hrsq); return$ end$ call print(bootols)$ nlag=6$ call olsq(gasout gasout{1 to nlag} gasin{1 to nlag} :print :savex)$ nboot=500; isave=1; lag=0; call bootols(%y,%x,%res,%coef,nboot,bcoef,bse,isave,lag)$ /$ call print(%hcoef,%hse,%hrsq)$ call print(bcoef,bse); lag=nlag; call bootols(%y,%x,%res,%coef,nboot,bcoef,bse,isave,lag)$ /$ call print(%hcoef,%hse,%hrsq)$ call print(bcoef,bse); b34srun$ /; /;SMOOTH_A Exponential Smoothing Methods /; /$ /$ Illustrates "Automatic Methods" on Gas Data /$ Results Graphed /$ b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call smooth(gasout :method nce :print); call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'No Change Extrapolation'); call graph(%error :heading 'No Change Extrapolation'); call smooth(gasout :method ncept :print); call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'No Change Plus Trend'); call graph(%error :heading 'No Change Plus Trend'); call smooth(gasout :method avetd :print); call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'Average to Date'); call graph(%error :heading 'Average to Date'); call smooth(gasout :method mave :print); call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'Moving Average'); call graph(%error :heading 'Moving Average'); call smooth(gasout :method dmave :print); call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'Double Moving Average'); call graph(%error :heading 'Double Moving Average'); call smooth(gasout :method es :print); call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'Exponential Smoothing'); call graph(%error :heading 'Exponential Smoothing'); call smooth(gasout :method des :print); call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'Double Exponential Smoothing'); call graph(%error :heading 'Double Exponential Smoothing'); call smooth(gasout :method holt :print :alpha .4 :beta .1); call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'Holt Method'); call graph(%error :heading 'Hold Method'); call smooth(gasout :method winters :print :alpha .4 :beta .1); call tabulate(%xhatobs, %xhat, %actual, %error); call graph(%xhat,%actual :heading 'Winters Method'); call graph(%error :heading 'Winters Method'); b34srun; /; /;SMOOTH_B Tests Cases on SMOOTH Methods /; /$ Illustrates Various Test Cases /$ /$ Due to initial S( ) Winters will not replicate /$ text book /$ b34sexec options ginclude('class.mac') member(movie); b34srun; b34sexec matrix; call loaddata; * See Hanke & Reitsch page 145 ; call smooth(wsales :method mave :nma 3 :print); call tabulate(%actual %xhat %error); call print(%xhatmat); * See Hanke & Reitsch page 147 ; call smooth(wsales :method dmave :nma 3 :print); call tabulate(%actual %xhat %error); call print(%xhatmat); * See Hanke & Reitsch page 158 table 5.8 ; call smooth(wsales :method des :alpha .4 :print); call tabulate(%actual %xhat %error); call print(%xhatmat); b34srun; b34sexec options ginclude('class.mac') member(acme); b34srun; b34sexec matrix; call loaddata; call smooth(sales :method nce :print); call print(%xhatmat,ccf(%actual,%xhat)); call tabulate(%actual %xhat %error); call smooth(sales :method ncept :print); call print(%xhatmat); call tabulate(%actual %xhat %error); call smooth(sales :method avetd :print); call print(%xhatmat); call tabulate(%actual %xhat %error); * Page 150 table 5.6 ; call smooth(sales :method es :alpha .1 :print); call print(%xhatmat); call tabulate(%actual %xhat %error); call smooth(sales :method es :alpha .6 :print); call print(%xhatmat); call tabulate(%actual %xhat %error); call smooth(sales :method des :print); call print(%xhatmat); call tabulate(%actual %xhat %error); * Page 163 table 5.9 ; call smooth(sales :method holt :alpha .3 :lag 4 :beta .1 :print); call print(%xhatmat); call tabulate(%actual %xhat %error); call print(%rss %mad %mse %mape %mpe %corr); * Page 167 table 5.10 ; call smooth(sales :method winters :alpha .4 :lag 4 :beta .1 :gamma .3 :print); call print(%xhatmat); call tabulate(%actual %xhat %error); call print(%rss %mad %mse %mape %mpe %corr); b34srun; /; /;SMOOTH_C Uses CMAXF2 to get best Alpha /; b34sexec options ginclude('class.mac') member(movie); b34srun; b34sexec matrix; call loaddata; * See Hanke & Reitsch page 158 table 5.8 ; call smooth(wsales :method des :alpha .4 :print); call tabulate(%actual %xhat %error); call print(%xhatmat); * Search using constrained maximize to get better alpha; * Search begins with alpha = .7 ; * We want to see if ~.4 is close to what is appropriate; * %rss(1) %mad(1) %corr(1) ; program test; call smooth(wsales :method des :alpha a :print); func=-1.*%rss(1); call print(a); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, a); return; end; rvec=array(1:.7); ll= array(1:.01); uu= array(1:.99); call echooff; call cmaxf2(func :name test :parms a :ivalue rvec :lower ll :upper uu :print); b34srun; /; /;SNGL Converts real*8 to real*4 /; b34sexec matrix; x=dfloat(integers(20)); xreal4=sngl(x); call names(all); call tabulate(x,xreal4); call print('Range adjustments for real*4'); xlarge8=-1.e+64; xsmall8=.1e-50; xlarge4=sngl(xlarge8); xsmall4=sngl(xsmall8); call print(xlarge8,xsmall8,xlarge4,xsmall4); b34srun; /; /;SOBJECT1 Tests / Illustrates Structured Objects /; b34sexec matrix; test=vector(:1 2 3 4); call print(test); n=4; v=vector(n:11. 22. 33. 44.); x=matrix(n,n:integers(1,n*n)); call print(x,v); v1=v(1); v3=v(3); call print(v,'This should be element 1 of v',v1); call print(v,'This should be element 3 of v',v3); i=idint(array(2:2 4)); call names; call names(all); call print('This is the structure index array - contains 2 4',i); v2=v(i); call print(v,'This should be elements 2 and 4 of v',v2); test1=x(,1); test2=x(2,); test3=x(2,2); call print('Test1 = col 1, test2 = row 2 test3 is element 2,2', test1 test2 test3); * Tests 2d structured call; kk=integers(1,3); digg=x(kk,kk); call print('Digg is the 3 by 3 part of x',digg); digg1=x(kk,1); call print('Digg1 is x col 1',digg1); digg2=x(2,kk); call print('Digg2 is x row 2',digg2); digg3=x(kk,); call print('Digg3 is x col 1',digg3); digg4=x(,kk); call print('Digg4 is x row 2',digg4); * ; nkk=integers(2,4); ndigg=x(nkk,nkk); call print(nkk,'Submatrix from x x(nkk,nkk)',ndigg); v=rn(vector(n:)); call print(v); newx=x;call print(newx);newx(2,)=v; call print('Random # row 2',newx); newx=x;call print(newx);newx(,2)=v; call print('Random # col 2',newx); * create a new variable ; notx(3,3)=digg; call print(digg,notx); i=idint(array(:1 3 4)); newx=x(i); call print('Contains rows 1 3 4 of x',newx); a=matrix(3,3:); call print(mean(x)); a(1,1)= mean(x); a(3,)=mean(x);call print(a); a=vector(2:); call free(a); call names; call names(all); call free(a);a(3 )= mean(x); call print(a); call free(a);a(3,)= mean(x); call print(a); call free(a);a(,3)= mean(x); call print(a); v=vector(3:1 2 3); a(2,)=v; call print(a); i=idint(array(2:1,3)); * place 1 3 in newv; call print(i); newv=v(i); call print('Term 1 and 3 of v in newv',newv); x=matrix(3,3:integers(1,9)); call print(x); * place 1 2 3 7 8 9 in newx; call free(newx); newx=x(i,); call print('Row1 and Row3 of x in newx',newx); call free(newx); newx=x(,i); call print('Col1 and Col3 of x in newx',newx); b34srun; /; /;SOBJECT2 Further tests with structured objects /; b34sexec matrix; v=vector(:6 5 4 3 2 1); a=array(:1 2 3 4 5 6); call print(a,v); * note we trick program by passing an integer will use same size of v but zero it out; v2=v; a(2)=44.0; v(3)=-44; v2(3)=-44.; vnew(3)=-44.; * vnew will have only 3 elements. Elements 1 & 2 = 0; call print(a,v,v2,vnew); a(4)=110.; call print(a); a(7)=99.; * Here a expands one element; call print(a); * Here we change element 7 of a; a(7)=98.; call print(a); mat1=matrix(3,3:1 2 3 4 5 6 7 8 9); call print(mat1); arr2=array(3,3: 1 2 3 4 5 6 7 8 9); call print(arr2); mat1(2,2)=-999.; arr2(2,2)=-888.; call print(mat1,arr2); b34srun; /; /;SOBJECT3 Further Structured Object Illustrations /; b34sexec matrix; x=rn(matrix(3,3:)); call print(x); * Place x(3,3) inside y. Note scaler subscripts; y(3,3)=x; call print('Note that the base of x is as 3,3',y); * Uses arrays i and j to put x in yy ; i=integers(3); j=i; yy=x(i,j); call print(yy); * Uses arrays i and j to put subset of x in yy ; i=integers(2,3); j=i; yyy=x(i,j); call print(yyy); * Illustrates use of scaler positioning in yyyy ; yyyy(2,3)=x(i,j); call print(yyyy); b34srun; /; /;SOBJECT4 Advanced structured objects /; b34sexec matrix; * Program illustrates two cases; * # 1 Put data into a fixed location; * # 2 Put data into a structure ; x=vector(3:1 2 3); i=integers(3,1,-1); r=integers(3); call print(x,i); call print('Putting Data in a new variable.'); * test=vector(3:); test=x(i); call print('This is just a copy of x',test); test(i)=x(i); call print('This is just a copy of x',test); v(r)=x(i); call print('This reverses x',v); call print(i); xa=matrix(3,1:); xa(,1)=x(i); call print(xa); xabase(,1)=x; call print(xabase); xb=matrix(3,3:); xb1(i,1)=x(i); call print('X is now in col 1',xb1); xb2(i,2)=x(i); call print('X is now in col 2',xb2); xc1(1,i)=x(i); call print('X is now in row 1',xc1); xc2(2,i)=x(i); call print('X is now in row 2',xc2); j=integers(3); xb3(j,3)=x(i); call print('Uses i and j pointers',xb3); b34srun; /; /;SOBJECT5 Using Structured Objects in Programs /; b34sexec matrix cbuffer=10000; * Shows subscript index working with programs; program prob4; call free(beta) ; beta(1)=-0.04866; beta(2)=1.03884 ; beta(3)=-0.73792; beta(4)=-0.51362; beta=vfam(beta) ; call rgex1; x=matrix(norows(y),3:); i=integers(norows(y)); xx=matrix(norows(y),3:); * Loading with an structured index ; x(i,1)=x1(i) ; x(i,2)=x2(i) ; x(i,3)=x3(i) ; * Loading with a base address. I. e. Copy into a col ; xx(,1)=x1; xx(,2)=x2; xx(,3)=x3; call print(x,xx); nx(i,1)=x1(i) ; nx(i,2)=x2(i) ; nx(i,3)=x3(i) ; nxx(,1)=x1; nxx(,2)=x2; nxx(,3)=x3; call print(nx,nxx); sx(i,1)=x1 ; sx(i,2)=x2 ; sx(i,3)=x3 ; sxx(,1)=x1; sxx(,2)=x2; sxx(,3)=x3; call print(sx,sxx); Call print('Row copy examples'); z=matrix(3,norows(y):); i=integers(norows(y)); zz=matrix(3,norows(y):); * Loading with an structured index ; z(1,i)=x1(i) ; z(2,i)=x2(i) ; z(3,i)=x3(i) ; * Loading with a base address. I. e. Copy into a row ; zz(1,)=x1; zz(2,)=x2; zz(3,)=x3; call print(z,zz); nz(1,i)=x1(i) ; nz(2,i)=x2(i) ; nz(3,i)=x3(i) ; nzz(1,)=x1; nzz(2,)=x2; nzz(3,)=x3; call print(nz,nzz); sz(1,i)=x1 ; sz(2,i)=x2 ; sz(3,i)=x3 ; szz(1,)=x1; szz(2,)=x2; szz(3,)=x3; call print(sz,szz); call print('Copy into a position'); cell(2,2)=x1(3); call print(cell); test=x1(3); call print(test); return; end; program uspopdat; /$ data from sas technical report page 9-2 year=dfloat(integers(179,197)); year=year*10. ; pop=array(:3.929 5.308 7.239 9.638 12.866 17.069 23.191 31.443 39.818 50.155 62.947 75.994 91.972 105.710 122.775 131.669 151.325 179.323 203.211 ); call tabulate(year pop); return; end; program rgex1; /$ loads data from gallant(1987) page 4 * Test comment; t=integers(1,30); y=array(:.98610 1.03848 .95482 1.04184 1.02324 .90475 .96263 1.05026 .98861 1.03437 .98982 1.01214 .66768 .55107 .96822 .98823 .59759 .99418 1.01962 .69163 1.04255 1.04343 .97526 1.04969 .80219 1.01046 .95196 .97658 .50811 .91840 ); x1=array(:1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0 1 0); x2=array(norows(x1):); x2=x2+1.; x3=array(:6.28 9.86 9.11 8.43 8.11 1.82 6.58 5.02 6.52 3.75 9.86 7.31 .47 .07 4.07 4.61 .17 6.99 4.39 .39 4.73 9.42 8.9 3.02 .7 3.31 4.51 2.65 .08 6.11); call tabulate(t y x1 x2 x3); return; end; call prob4; b34srun; /; /;SOLVE Illustrates use of Formula + Solve /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix solvefree(50); * Shows use of formulas in simple case where ; * Here the analytic statement works same way as formula; * Formula allows resursive solutions ; * Formula solved one row at a time ; * DOUBLE case shows a recursive call ; call loaddata; test1=gasout*2.; formula simple = gasout(t)*2.; solve(test2=simple(t)*2. :range 1,norows(gasout): block simple); formula double = gasout(t)*2. +(.9*double(t-1)); solve(test3=double(t) :range 2, norows(gasout) :block double); call print('Test1 should equal test2/2.':); call print('simple = gasout*2.':); call print('test3 should equal double':); call tabulate(gasout,test1,test2,simple,test3,double); call print(mean(test1),mean(test2/2.)); call names(all); b34srun; /; /; /;SORT SORT command on real*8 and Character Data /; b34sexec matrix; n=10; x=rn(array(n:)); sx=x; call sort(x); call tabulate(x,sx); n=namelist(:sue ann bobby houston); cn=n; call sort(cn); call tabulate(n,cn); call character(cc,'abcd12343210'); cc2=c1array(12,1:cc); call print(cc,cc2); call vocab(cb); ccb=cb; call sort(ccb); call print(cb,ccb); cfb=vocab(); ccfb=cfb; call sort(ccfb); call print(cfb,ccfb); b34srun; /; /;SPACING Absolute spacing near a given Number /; b34sexec matrix; i=1; x=1.; y=sngl(x); call print('Largest integer ',huge(i):); call print('Largest real*4 ',huge(y):); call print('Largest real*8 ',huge(x):); call print('Smallest real*4 ',tiny(y):); call print('Smallest real*8 ',tiny(x):); call print('Epsilon real*4 ',epsilon(y):); call print('Epsilon real*8 ',epsilon(x):); x=.1d+00; y=sngl(x); j=1; call echooff; do i=1,1000,100; x=x*dfloat(i); y=float(i)*y ; spx(j)=spacing(x); spy(j)=spacing(y); nearpr8(j)=nearest(x, 1.); nearmr8(j)=nearest(x,-1.); nearpr4(j)=nearest(y, 1.); nearmr4(j)=nearest(y,-1.); testnum(j)=x; j=j+1; enddo; call print('Spacing for Real*8 and Real*4'); call tabulate(testnum,spx,spy,nearpr8,nearmr8,nearpr4,nearmr4); call names(all); call graph(testnum,spx :plottype xyplot :heading 'Spacing'); b34srun; /; /;SPECTRAL Call SPECTRAL Command => Advanced spectral Analysis /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call spectral(gasin,sinx,cosx,px,sx,freq); freq2=freq/(2.0*pi()); period=vfam(1.0/afam(freq2)); call tabulate(freq freq2 period sinx cosx px sx); call spectral(gasin,sinx,cosx,px,sx,freq:1 2 3 2 1); call tabulate(freq freq2 period sinx cosx px sx); call graph(freq2,sx:heading 'Spectrum of Gasin' :plottype xyplot); b34srun; /; /;SPECTRUM SPECTRUM Function => Spectral Analysis of 1 series /; b34sexec options ginclude('gas.b34'); b34srun; /$ /$ Job tests various options in calling spectrum function /$ b34sexec matrix; call loaddata; p1=spectrum(gasin); p =spectrum(gasin,freq); p2=spectrum(gasin,freq2:1 2 3 4 3 2 1); s =spectrum(gasin :1 2 3 4 3 2 1); call names(all); call tabulate(p1,p,freq,freq2,p2,s); freq2=freq/(2.0*pi()); period=vfam(1.0/afam(freq2)); call tabulate(freq,freq2,period,p,s); call graph(freq2,p s:heading 'Periodogram and Spectrum of Gasin' :plottype xyplot); call graph(freq2,p:heading 'Periodogram of Gasin' :plottype xyplot); call graph(freq2,s:heading 'Spectrum of Gasin' :plottype xyplot); call graph(freq2,spectrum(gasin:1 4 1), spectrum(gasin:1 1 1) spectrum(gasin:1 1 1 1 1 1 1) :heading 'Effect of Weighting on Spectrum' :plottype xyplot); b34srun$ /; /;STATA1_A Stata Probit Model using MAXF1 /; b34sexec options ginclude('stata.mac') member(auto); b34srun; /$ /$ Problem page 1 /$ "Maximum Likelihood Estimation with Stata" /$ William Gould & William Sribney /$ b34sexec probit; model foreign = mpg weight; b34srun; b34sexec matrix; * This test run tests both command maxf1 ; * Uses mlsum to avoid problems ; call loaddata; theta=array(norows(foreign):); func=-10.d+32; mask1=array(norows(foreign):); mask2=mask1+1.; mask0=mask1; where(foreign.eq.1.0)mask1=mask2; where(foreign.eq.0.0)mask0=-1.0*mask2; program test; theta=(a+b1*mpg+b2*weight); add=probnorm(mask0*theta+mask1*theta); func=mlsum(add); call outstring(3, 3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b1); call outdouble(4, 5, b2); return; end; call print(test); call olsq(foreign mpg weight: print); call print(%coef); rvec=array(3:%coef(3),%coef(1),%coef(2)); /$ rvec=array(3:8.2,-.1,-.002) ; call echooff; call maxf1(func :name test :parms a b1 b2 :ivalue rvec :print); b34srun; /; /;STATA1_B Stata Probit Model using maxf2 /; b34sexec options ginclude('stata.mac') member(auto); b34srun; /$ /$ Problem page 1 /$ "Maximum Likelihood Estimation with Stata" /$ William Gould & William Sribney /$ b34sexec probit; model foreign = mpg weight; b34srun; b34sexec matrix; * This test run tests both command maxf2 ; * Uses mlsum to avoid problems ; call loaddata; theta=array(norows(foreign):); func=-10.d+32; mask1=array(norows(foreign):); mask2=mask1+1.; mask0=mask1; where(foreign.eq.1.0)mask1=mask2; where(foreign.eq.0.0)mask0=-1.0*mask2; program test; theta=(a+b1*mpg+b2*weight); add=probnorm(mask0*theta+mask1*theta); func=mlsum(add); call outstring(3, 3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b1); call outdouble(4, 5, b2); return; end; call print(test); call olsq(foreign mpg weight: print); call print(%coef); rvec=array(3:%coef(3),%coef(1),%coef(2)); /$ rvec=array(3:8.2,-.1,-.002) ; call echooff; call maxf2(func :name test :parms a b1 b2 :ivalue rvec :print); b34srun; /; /;SUBMATRIX Extract a submatrix /; b34sexec matrix; x =rec(matrix(6,10:)); sx =submatrix(x,1,3,2,5); call print(x,sx); cx =complex(x,dsqrt(x)); csx =submatrix(cx,1,3,2,5); call print(cx,csx); /$ Character*1 example call character(cc,'1234567890abcdef'); c4by4=c1array(4,4:cc); s1=submatrix(c4by4,1,2,2,3); s2=submatrix(c4by4,3,4,3,4); call print(cc,c4by4,s1,s2); call names(all); b34srun; /; /;SUBRENAME Subroutine rename /; /$ Tests SUBRENAME command /$ Command renames a routine in place b34sexec matrix; subroutine test(x); call print(x); return; end; x=rn(array(10:)); call test(x); newtest=test; call names(all); call free(test); call names(all); call print(newtest); call subrename(newtest); call print(newtest); call names(all); call newtest(x); b34srun; /$ Job Part # 2 b34sexec matrix ; * Shows use of formulas in simple case; function test(i); x=i*i; return(i); end; formula double = gasout*2.; call names; call print(double); call printall; call save; b34srun; b34sexec matrix; call restore; call names(all); call printall; y=double; call print('This has a bad copy ',y); tt=test; call printall; call subrename(y); call print('This is a good copy',y); b34srun; /; /;SUBSET Subset of an object using subsert function /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call echooff; call loaddata; call load(subset); mask = (gasin .gt. 0.0); call olsq(gasout gasin :sample mask :print :diag :qr); call olsq(gasout gasin :sample mask :print :diag); call graph(%res :heading 'Residual'); call graph(%y %yhat :heading 'Fitted and Actual'); g2=subset(gasout,mask); g1=subset(gasin,mask); call olsq(g2,g1 :print); b34srun; /; /;SUBSET_1 Subset a matrix /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call echooff; call loaddata; call load(subset); x=matrix(norows(gasout),3:); x(,1)=1.; x(,2)=vfam(gasin); x(,3)=vfam(gasout); mask = (gasin .gt. 0.0); newx=subset(x,mask); call print(x,newx); b34srun; /; /;SUBTEST_1 Subroutine Call examples /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call print('Mean root program',mean(gasout)); subroutine means(x,xmean); call names(all); xmean=mean(x); call print('Mean in subroutine was',xmean); call names(all); call print('About to leave!!'); call print(x); x(1)=-99.; call print(x); return; end; call names; call names(all); call print(means); call means(gasout,testmean); * GASOUT will have changed for element # 1 ; call print(gasout); call names(all); call print('This was the mean that came out of the call',testmean); b34srun; /; /;SUBTEST_2 Tests Subroutine Calls Under NL Options /; /$ This file tests the calling of subroutines from under a running /$ Nonlinear problems. The output is just a test. In this situation /$ the subroutine may not be useful b34sexec options ginclude('b34sdata.mac') member(res72); b34srun; /$ Tests a subroutine call from a program under NLLS /$ Test problem used for code validation b34sexec matrix; call loaddata; * Sinai-Stokes RES Data --- Nonlinear Models ; * Problem 1 is very very hard !!!!!! ; * problem=1; subroutine funny(yhat,a,g1,k,r,l,v); * Slow way to go since another step; yhat=a*(g1*k**r+(1.0-g1)*l**r)**(v/r); return; end; program res72; call echooff; /$ Slow way to proceed call funny(yhat,a,g1,k,r,l,v); /$ yhat=a*(g1*k**r+(1.0-g1)*l**r)**(v/r); call outstring(3,3,'Coefficients'); call outstring(3,4,'g1 v r'); call outdouble(14,4,g1); call outdouble(34,4,v); call outdouble(50,4,r); return; end; call print(res72,funny); call nllsq(q,yhat :name res72 :parms g1 a v r :maxit 50 :flam 1. :flu 10. :eps2 .004 :ivalue array(:.3053 1.0 1.85 .03) :print result residuals); call graph(%res); b34srun; b34sexec matrix; * Constrained Minimum tests both commands CMAXF1 and CMAXF2 ; * func = 3.*x2**2. + 4*x1**2 - x2 + 2.*x1 ; * where -1. LE x1 LE 0. and 0. LE x2 LE 1 ; * where answers should be -.2500, .1667 and func = -.3333 ; subroutine funny(func,x1,x2); func=(-1.0)*(((3.)*(x2**2.)) + (4.*(x1**2.)) - x2 + (2.*x1)); return; end; program test; call funny(func,x1,x2); /$ func=(-1.0)*(((3.)*(x2**2.)) + (4.*(x1**2.)) - x2 + (2.*x1)); call outstring(3,3,'Function'); call outdouble(36,3,func); call outdouble(4, 4, x1); call outdouble(36,4, x2); return; end; call print(test,funny); rvec=array(2:-1.2 1.0); ll=array(2:-1.,0.0); uu=array(2:.0 ,1.0 ); call echooff; call cmaxf2(func :name test :parms x1 x2 :lower ll :upper UU :print); b34srun; /$ Tests if can call a subroutine fron inside routine /$ /$ Uses IMSL dn2onf /$ b34sexec matrix; * Answers .8229 .9114 ; * Problem: min( (x1-2)**2 +(x2-1)**2) ; * st x1 - 2*x2 +1 = 0.0; * -(x1**2)/4 -x2**2 + 1 GE 0.0; subroutine funny(func,x1,x2); func=(x1-2.)**2. + (x2-1.)**2. ; return; end; program test; call funny(func,x1,x2); /$ func=(x1-2.)**2. + (x2-1.)**2. ; if(%active(1)) g(1)=x1 - 2.0*x2 + 1. ; if(%active(2)) g(2)=((-1.)*(x1**2.)/4.) - (x2**2.) + 1. ; return; end; call print(test,funny); call echooff; call NLPMIN1(func g :name test :parms x1 x2 :ivalue array(:2.,2.) :nconst 2 1 :lower array(:-1.d+6, -1.d+6) :upper array(: 1.d+6, 1.d+6) :print :maxit 100 :iprint final); b34srun; b34sexec options ginclude('gas.b34'); b34srun; /$ Using minimum to solve OLS problem /$ OLSQ used as a test /$ Uses IMSL dn2onf /$ Note that M and ME set = 0. G(1)=0.0d+00 is a dummy b34sexec matrix; call loaddata; subroutine funny(func,gasout,gasin,a,b); func=sumsq(gasout -(a+b*gasin)); return; end; program test; call funny(func,gasout,gasin,a,b); /$ func=sumsq(gasout -(a+b*gasin)); call outstring(3, 3,'Function '); call outdouble(36,3,func); call outdouble(4, 4, a); call outdouble(36,4, b); g(1)=0.0d+00; return; end; call print(test); call olsq(gasout gasin :print); call echooff; call NLPMIN1(func g :name test :parms a b :ivalue array(:2.,2.) :nconst 0 0 :lower array(:-1.d+6, -1.d+6) :upper array(: 1.d+6, 1.d+6) :print :maxit 100 :iprint final); b34srun; /$ /$ Uses IMSL dn2ong /$ b34sexec matrix; * Answers .8229 .9114 ; * Problem: min( (x1-2)**2 +(x2-1)**2) ; * st x1 - 2*x2 +1 = 0.0; * -(x1**2)/4 -x2**2 + 1 GE 0.0; subroutine funny(func,x1,x2); func=(x1-2.)**2. + (x2-1.)**2. ; return; end; subroutine funny2(df,dg,a); call print(df,dg,a); return; end; program test; call funny(func,x1,x2); /$ func=(x1-2.)**2. + (x2-1.)**2. ; if(%active(1)) g(1)=x1 - 2.0*x2 + 1. ; if(%active(2)) g(2)=(((-1.)*(x1**2.))/4.) - (x2**2.) + 1. ; return; end; program grad; df(1)=2.0*(x1-2.0) ; df(2)=2.0*(x2-1.0) ; if(%active(1))then; dg(1,1)=1.; dg(1,2)=-2.; endif; if(%active(2))then; dg(2,1)= -.5 * x1; dg(2,2)= -2. * x2; endif; call funny2(df,dg,%active); return; end; call print(test,grad,funny,funny2); call echooff; call nlpmin2(func g df dg :name test grad :parms x1 x2 :ivalue array(:2.,2.) :nconst 2 1 :lower array(:-1.d+6, -1.d+6) :upper array(: 1.d+6, 1.d+6) :print :maxit 100 :iprint final); b34srun; /$ /$ Uses IMSL dn0onf /$ b34sexec matrix; * Answers .8229 .9114 ; * Problem: min( (x1-2)**2 +(x2-1)**2) ; * st x1 - 2*x2 +1 = 0.0; * -(x1**2)/4 -x2**2 + 1 GE 0.0; subroutine funny(func,x1,x2); func=(x1-2.)**2. + (x2-1.)**2. ; return; end; subroutine funny2(df,dg,a); call print(df,dg,a); return; end; program test; call funny(func,x1,x2); /$ func=(x1-2.)**2. + (x2-1.)**2. ; if(%active(1)) g(1)=x1 - 2.0*x2 + 1. ; if(%active(2)) g(2)=(((-1.)*(x1**2.))/4.) - (x2**2.) + 1. ; return; end; program grad; df(1)=2.0*(x1-2.0) ; df(2)=2.0*(x2-1.0) ; if(%active(1))then; dg(1,1)=1.; dg(1,2)=-2.; endif; if(%active(2))then; dg(2,1)= -.5 * x1; dg(2,2)= -2. * x2; endif; call funny2(df,dg,%active); return; end; call print(test,grad,funny,funny2); call echooff; call nlpmin3(func g df dg :name test grad :parms x1 x2 :ivalue array(:2.,2.) :nconst 2 1 :lower array(:-1.d+6, -1.d+6) :upper array(: 1.d+6, 1.d+6) :print :maxit 100 :iprint final); b34srun; /; /;SUM SUM function => sum elements /; b34sexec matrix; a=array(5:1 2 3 4 5); s=sum(a); call print('Sum of 1 2 3 4 5',s); b34srun$ /; /;SUMCOLS SUM Elements in a col /; b34sexec matrix; x=array(8,2:1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16); call print(x,sumrows(x),sumcols(x)); call print(mfam(x),sumrows(mfam(x)),sumcols(mfam(x))); b34srun; /; /;SUMROWS SUM Elements in a row /; b34sexec matrix; x=array(8,2:1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16); call print(x,sumrows(x),sumcols(x)); call print(mfam(x),sumrows(mfam(x)),sumcols(mfam(x))); b34srun; /; /;SUMSQ SUMSQ function => Sum squared elements /; b34sexec matrix; a=array(5:1 2 3 4 5); s=sumsq(a);s2=sum(a*a); s3=ddot(a,a); call print(s,s2,s3); b34srun$ /; /;SVD SVD function => Singular Value Deconposition /; b34sexec matrix; * SVD uses LINPACK DSVDC and ZSVDC $ * n sets rank for matrix tests; * noob sets # of observations for PC tests ; n=4; noob=20; x=rn(matrix(noob,n:)); s=svd(x,b,11,u,v); call print('X',x,'Singular values',s,'Left Singular vectors',U, 'Right Singular vectors',v); call print('Test of Factorization. Is S along diagonal?', 'Transpose(u)*x*v',transpose(u)*x*v, 'Is U orthagonal?','transpose(U)*U', transpose(U)*U, 'Is V orthagonal?','transpose(V)*V', transpose(V)*V, ' ' 'Square Case'); n=4; noob=4; x=rn(matrix(noob,n:)); s=svd(x,b,11,u,v); call print('X',x,'Singular values',s,'Left Singular vectors',U, 'Right Singular vectors',v); call print('Test of Factorization. Is S along diagonal?', 'Transpose(u)*x*v',transpose(u)*x*v, 'Is U orthagonal?','transpose(U)*U', transpose(U)*U, 'Is V orthagonal?','transpose(V)*V', transpose(V)*V, ' ' 'Complex Case'); x=afam(x);x=x*-1.;x=dsqrt(complex(x,0.0)) + complex(x,0.0); x=mfam(x); s=svd(x,b,11,u,v); call print('X',x,'Singular values',s,'Left Singular vectors',U, 'Right Singular vectors',v); call print('Test of Factorization. Is S along diagonal?', 'dconj(transpose(u))*x*v',dconj(transpose(u))*x*v, 'Is U orthagonal?','dconj(transpose(U))*U', dconj(transpose(U))*U, 'Is V orthagonal?','dconj(transpose(V))*V', dconj(transpose(V))*V, ' ' 'OLS Examples using SVD',' '); * ####################### ; x=rn(matrix(noob,n:)); call setcol(x,1,1.0); y=rn(vector(noob:)); call print(x,y,'OLS Results' '(1.0/(transpose(x)*x))*transpose(x)*mfam(y)', (1.0/(transpose(x)*x))*transpose(x)*mfam(y)); s=svd(x,b,21,u1,v); call names; call print('Singular values',s, 'X from SVD ' 'U1*diagmat(s)*transpose(v)', U1*diagmat(s)*transpose(v), 'Principle Component Coefficients' 'transpose(u1)*mfam(y)', transpose(u1)*mfam(y) ' ' 'Calculate OLS Coefficients using SVD values' '(V*(1./diagmat(s)))*(transpose(u1)*mfam(Y)) ' (V*(1./diagmat(s)))*(transpose(u1)*mfam(Y)) ); call print(diagmat(s)); A=transpose(u1)*mfam(y); B=V*(1./diagmat(s))*A; call print('A = PC Coefficients',A, 'B = OLS Coefficients',B); pred1=u1*a; pred2=x*b; call print('We compare two ways to get predicted values'); call tabulate(pred1,pred2); b34srun; b34sexec matrix; * shows that svd of PD matrix produces eigenvalues; x=rn(matrix(5,5:)); xpx=Transpose(x)*x; e=eig(xpx); ee=seig(xpx); s=svd(xpx); call print(e,ee,s); b34srun; /; /;SVD2 Difficult SVD Problem /; b34sexec matrix display=col80high; * Example from Matlab Symbolic toolkit page 1-82; * Matrix is generated slowly; * Most of svd values close to pi; call echooff; n=16; x=matrix(n,n:); do i=1,n; do j=1,n; x(i,j)=1./(dfloat(i)-dfloat(j)+.5); next j; next i; call print(x,svd(x)); b34srun; /; /;SWARTEST Stock-Watson VAR Test /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; call load(buildlag); call load(varest); call load(swartest); call echooff; ibegin1=1; iend1=200; ibegin2=201; iend2=296; nlag=2; nterms=10; iprint=1; x=catcol(gasin,gasout); call print('Two variable test':); call swartest(x,ibegin1,iend1,ibegin2,iend2, sigma1,sigma2,psi1,ipsi1,psi2,ipsi2,iprint, nterms,nlag,test11,test12,test21,test22, var1,var2,varxhat1,varxhat2,rsq1,rsq2); /$ One variable test x=matrix(norows(gasout),1:gasout); call print('One Variable Test':); call swartest(x,ibegin1,iend1,ibegin2,iend2, sigma1,sigma2,psi1,ipsi1,psi2,ipsi2,iprint, nterms,nlag,test11,test12,test21,test22, var1,var2,varxhat1,varxhat2,rsq1,rsq2); /$ One variable test on random data n=2000; x=matrix(n,1:); x=rn(x); ibegin1 = 1; iend1 = n/2; ibegin2 = iend1+1; iend2 = n; nlag=12; nterms=20; call print('Test using Random Data':); call swartest(x,ibegin1,iend1,ibegin2,iend2, sigma1,sigma2,psi1,ipsi1,psi2,ipsi2,iprint, nterms,nlag,test11,test12,test21,test22 var1,var2,varxhat1,varxhat2,rsq1,rsq2); b34srun; /; /;SWARTEST1A Illustrates Test for one series AR(1) Case /; b34sexec matrix; call load(buildlag); call load(varest); call load(swartest); n=300; ibegin1=1; iend1=n; ibegin2=n+1; iend2=2*n; nlag=1; nterms=10; iprint=1; ar=array(:.9); start=array(:.1); testar1a=genarma(ar,ma,1.0,start,.1,n); ar=array(: .5); testar1b=genarma(ar,ma,1.0,start,.1,n); testar1a=testar1a-mean(testar1a); testar1b=testar1b-mean(testar1b); x=array(2*n:testar1a,testar1b); call graph(x :heading 'Coefficient shift in AR Model'); call echooff; call print(' ':); call print('Shows a coef shift in AR Model':); call swartest(x,ibegin1,iend1,ibegin2,iend2, sigma1,sigma2,psi1,ipsi1,psi2,ipsi2,iprint, nterms,nlag,test11,test12,test21,test22, var1,var2,varxhat1,varxhat2,rsq1,rsq2); call echoon; ar=array(:.9); start=array(:.1); testar1a=genarma(ar,ma,1.0,start,.1,n); ar=array(: .9); testar1b=genarma(ar,ma,10.0,start,.1,n); testar1a=testar1a-mean(testar1a); testar1b=testar1b-mean(testar1b); x=array(2*n:testar1a,testar1b); call graph(x :heading 'Variance shift in AR model'); call echooff; call swartest(x,ibegin1,iend1,ibegin2,iend2, sigma1,sigma2,psi1,ipsi1,psi2,ipsi2,iprint, nterms,nlag,test11,test12,test21,test22, var1,var2,varxhat1,varxhat2,rsq1,rsq2); call echoon; ar=array(:.9); start=array(:.1); testar1a=genarma(ar,ma,10.0,start,.1,n); ar=array(: .5); testar1b=genarma(ar,ma,1.0,start,.1,n); testar1a=testar1a-mean(testar1a); testar1b=testar1b-mean(testar1b); x=array(2*n:testar1a,testar1b); call graph(x :heading 'Both Coef and Variance are shifting'); call echooff; call print(' ':); call print('Shows Both coef and var shift':); call swartest(x,ibegin1,iend1,ibegin2,iend2, sigma1,sigma2,psi1,ipsi1,psi2,ipsi2,iprint, nterms,nlag,test11,test12,test21,test22, var1,var2,varxhat1,varxhat2,rsq1,rsq2); b34srun; /; /;SWARTEST1B Illustrates Test for one series MA(2) Case /; /$ /$ Shows estimation of a MA as an AR and then inverting model /$ Get out MA structure /$ b34sexec matrix; call load(buildlag); call load(varest); call load(swartest); n=300; ibegin1=1; iend1=n; ibegin2=n+1; iend2=2*n; nlag=8; nterms=10 ; iprint=1; ma=array(:.9,-.4); start=array(:.1); testar1a=genarma(ar,ma,1.0,start,.1,n); ma=array(: .5,-.4); testar1b=genarma(ar,ma,1.0,start,.1,n); testar1a=testar1a-mean(testar1a); testar1b=testar1b-mean(testar1b); x=array(2*n:testar1a,testar1b); call graph(x :heading 'Coef shift in MA Model'); call print(' ':); call print('Coef shift in MA Model':); call echooff; call swartest(x,ibegin1,iend1,ibegin2,iend2, sigma1,sigma2,psi1,ipsi1,psi2,ipsi2,iprint, nterms,nlag,test11,test12,test21,test22, var1,var2,varxhat1,varxhat2,rsq1,rsq2); call echoon; ma=array(:.9,-.4); start=array(:.1); testar1a=genarma(ar,ma,1.0,start,.1,n); ma=array(: .9,-.4); testar1b=genarma(ar,ma,6.0,start,.1,n); testar1a=testar1a-mean(testar1a); testar1b=testar1b-mean(testar1b); x=array(2*n:testar1a,testar1b); call graph(x :heading 'Var shift in MA Model'); call echooff; call print(' ':); call print('Var shift in MA Model':); call swartest(x,ibegin1,iend1,ibegin2,iend2, sigma1,sigma2,psi1,ipsi1,psi2,ipsi2,iprint, nterms,nlag,test11,test12,test21,test22, var1,var2,varxhat1,varxhat2,rsq1,rsq2); call echoon; ma=array(:.9,-.4); start=array(:.1); testar1a=genarma(ar,ma,3.0,start,.1,n); ma=array(: .5,-.4); testar1b=genarma(ar,ma,1.0,start,.1,n); testar1a=testar1a-mean(testar1a); testar1b=testar1b-mean(testar1b); x=array(2*n:testar1a,testar1b); call graph(x :heading 'Both Coef and Var Shift':); call echooff; call print(' ':); call print('Shows Both coef and var shift':); call swartest(x,ibegin1,iend1,ibegin2,iend2, sigma1,sigma2,psi1,ipsi1,psi2,ipsi2,iprint, nterms,nlag,test11,test12,test21,test22, var1,var2,varxhat1,varxhat2,rsq1,rsq2); b34srun; /; /;SWARTEST2 Runs Stock Watson Test over a Range of Obs /; /$ /$ Runs Stock-Watson over a range of values /$ Uses Neuburger - Stokes /$ b34sexec options ginclude('b34sdata.mac') macro(res79)$ b34srun$ b34sexec matrix; call loaddata; call load(buildlag); call load(varest); call load(swartest); call echooff; diffm=dif(m2dp,2,1); diffi=dif(fycp,1,1); i=norows(diffi); ix=integers(2,i); xin=diffm; yin=diffi(ix); n=norows(xin); istart=80; iend=n-istart; htest11=array(iend-istart+1:); htest12=array(iend-istart+1:); htest21=array(iend-istart+1:); htest22=array(iend-istart+1:); icount=1; x=catcol(xin,yin); do ii=istart,iend; ibegin1=1; iend1=ii; ibegin2=ii+1; iend2=n; nlag=19; nterms=30; iprint=0; call swartest(x,ibegin1,iend1,ibegin2,iend2, sigma1,sigma2,psi1,ipsi1,psi2,ipsi2,iprint, nterms,nlag,test11,test12,test21,test22, var1,var2,varxhat1,varxhat2,rsq1,rsq2); call outinteger(2,2,icount); call outdouble(2, 4,test11(2)); call outdouble(22,4,test12(2)); call outdouble(2, 5,test21(2)); call outdouble(22,5,test22(2)); htest11(icount)=test11(2); htest12(icount)=test12(2); htest21(icount)=test21(2); htest22(icount)=test22(2); call compress; icount=icount+1; enddo; call tabulate(htest11,htest12,htest21,htest22); call print('Mean sigma11 ',mean(htest11)); call print('Mean sigma12 ',mean(htest12)); call print('Mean sigma21 ',mean(htest21)); call print('Mean sigma22 ',mean(htest22)); call graph(htest11 :noshow :pgborder :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'htest11.hp1' :hardcopyfmt HP_GL2 :heading 'Sigma(11)'); call graph(htest12 :noshow :pgborder :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'htest12.hp1' :hardcopyfmt HP_GL2 :heading 'Sigma(12)'); call graph(htest21 :noshow :pgborder :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'htest21.hp1' :hardcopyfmt HP_GL2 :heading 'sigma(21)'); call graph(htest22 :noshow :pgborder :pgxscaletop 'I' :pgyscaleright 'I' :nolabel :file 'htest22.hp1' :hardcopyfmt HP_GL2 :heading 'Sigma(22)'); call menu(cc :menutype inputtext :prompt ' Save File Name. blank => clipboard' ); call grreplay(:start :file cc ); call grreplay(:cont 'htest11.hp1' :gformat fourgraph 1); call grreplay(:cont 'htest12.hp1' :gformat fourgraph 2); call grreplay(:cont 'htest21.hp1' :gformat fourgraph 3); call grreplay(:cont 'htest22.hp1' :gformat fourgraph 4); call grreplay(:final); call grreplay(:start ); call grreplay(:cont 'htest11.hp1' :gformat fourgraph 1); call grreplay(:cont 'htest12.hp1' :gformat fourgraph 2); call grreplay(:cont 'htest21.hp1' :gformat fourgraph 3); call grreplay(:cont 'htest22.hp1' :gformat fourgraph 4); call grreplay(:final); b34srun; /; /;TABULATE Tests Tabulate for Simple Case /; b34sexec matrix; subroutine fix(rad,ss,cc,title); call tabulate(rad,ss,cc :title title); return; end; n=12; rad=array(n:); ss=array(n:); cc=array(n:); call echooff; do i=1,n; rad(i)=dfloat(i)*pi()/6.; ss(i)=dsin(rad(i)); cc(i)=dcos(rad(i)); enddo; /$ Change format call tabulate(rad,ss,cc); call tabulate(rad,ss,cc :format '(f12.3)'); /$ Title call tabulate(rad,ss,cc :title 'Simple Title Example'); call character(title,'Calling a routine'); call fix(rad,ss,cc,title); b34srun; /; /;TABULATE2 Tests Tabulate Writting to a file /; b34sexec matrix; n=12; rad=array(n:); ss=array(n:); cc=array(n:); call echooff; do i=1,n; rad(i)=dfloat(i)*pi()/6.; ss(i)=dsin(rad(i)); cc(i)=dcos(rad(i)); enddo; /$ Shows both uses of tabulate call open(71,'tab.txt'); call tabulate(rad,ss,cc:title 'Test of Tabulate'); call tabulate(rad,ss,cc:unit 71 :cdf); call close(71); b34srun; /; /;TABULATE3 Formating Options /; b34sexec matrix; n=12; rad=array(n:); ss=array(n:); cc=array(n:); do i=1,n; rad(i)=dfloat(i)*pi()/6.; ss(i)=dsin(rad(i)); cc(i)=dcos(rad(i)); enddo; /$ Change format call tabulate(rad,ss,cc); call tabulate(rad,ss :title 'BIG title **************'); call tabulate(rad,ss :title 'little t'); /$ Note: Number must be within length of 12 /$ Checking not completely done call tabulate(rad,ss,cc :format "('A ',F8.3)"); call tabulate(rad,ss,cc :format '(f10.0)'); /$ place commas in Character*8 and print cc1=','; c=rtoch(array(12:)); c(,1)=cc1; call tabulate(rad,ss,cc,c); call tabulate(rad,ss,cc :ljname :title 'Left Just name'); call tabulate(rad,ss,cc :rjname :title 'Right Just name'); call tabulate(rad,ss,cc :cname :title 'Center name'); b34srun; /; /;TARCH1A Tests Simple Arch Model /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; /$ /$ Solving an ARCH model of form /$ res=gasout-(b0+b1*gasout{1} + b2*gasout{2} /$ vv= a0+a1*vv{1} /$ Max: (-.5)*(dlog(archvar)+((resid**2.)/archvar) ) /$ call loaddata; maxlag1=2; call olsq(gasout gasout{1 to maxlag1} :print); rvec=array(5:); rvec(1)=%coef(3); rvec(2)=%coef(1); rvec(3)=%coef(2); rvec(4)=dsqrt(%resvar); rvec(5)=.05; ylag1=afam(lag(gasout,1)); ylag2=afam(lag(gasout,2)); call echooff; program test; resid =gasout-b0-b1*ylag1-b2*ylag2; archvar=dabs(a0+(a1*(lag(resid,1)**2.))); func=sum(goodrow((-.5)*(dlog(archvar)+((resid**2.)/archvar)))); call outstring(3,3,'Function to be maximized'); call print(func); call outdouble(36,3,func); return; end; call print(test); call print(rvec); call maxf1(func :name test :parms b0 b1 b2 a0 a1 :nsig 6 :maxfun 5000 :ivalue rvec :print); b34srun; /; /;TBPF Tests Baxter - King Filter Program /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(BPF); highfreq=6.; lowfreq=32.; nterms=20; call print(gasout); call bpf(gasout,ngasout,highfreq,lowfreq,nterms); ngasout2=gasout-ngasout; call tabulate(gasout,ngasout,ngasout2); call graph(gasout,ngasout,ngasout2); b34srun; /; /;TBPFM Tests Baxter - King Filter Program /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(bpfm); call print(bpfm); highfreq=6.; lowfreq=32.; nterms=20; call print(gasout); call bpfm(gasout,ngasout,highfreq,lowfreq,nterms); ngasout2=gasout-ngasout; call tabulate(gasout,ngasout,ngasout2); b34srun; /; /;TDEN Student t density /; b34sexec matrix; t=grid(-4.0,4.0,.1); df=array(norows(t):)+10.; ttden =tden(t,df); ttprob =tprob(t,df); normden2 =normden(t); call print('DF was ',df:); call tabulate(t,ttden,ttprob,normden2); df=array(norows(t):)+1000.; ttden =tden(t,df); ttprob =tprob(t,df); normden2 =normden(t); call print('DF was ',df:); call tabulate(t,ttden,ttprob,normden2); df=array(norows(t):)+100000.; ttden =tden(t,df); ttprob =tprob(t,df); normden2 =normden(t); call print('DF was ',df:); call tabulate(t,ttden,ttprob,normden2); * Test interpolation ; * Rats gets .06115 .06104 .06094 .06084 .06075 .06065 ; * Matlab Truncates ; call print('tden(2.,10. )',tden(2.,10. ):); call print('tden(2.,10.2)',tden(2.,10.2):); call print('tden(2.,10.4)',tden(2.,10.4):); call print('tden(2.,10.6)',tden(2.,10.6):); call print('tden(2.,10.8)',tden(2.,10.8):); call print('tden(2.,11. )',tden(2.,11. ):); b34srun; /; /;TESTARG Call testarg => Show variable Linkage /; b34sexec matrix; a=matrix(3,3:); a=rn(a);b=rn(vector(3:)); call testarg(a,b,c,a*b,'This is a comment'); b34srun; /; /;TESTOLS1 Simple OLS Models using MATRIX /; b34sexec options ginclude('gas.b34'); b34srun; /$ /$ OLS is done three ways: 1. with reg /$ 2. with matrix /$ 3. with olsq /$ b34sexec reg; model gasout=gasin; b34srun; b34sexec matrix; call loaddata; x=matrix(norows(gasin),2:); x(,1)=vfam(gasin); call setcol(x,2,1.0); xpx=transpose(x)*x; call names; beta=vfam((1./xpx)*transpose(x)*mfam(gasout)); call print(xpx,beta); fgasout=vfam(x*mfam(beta)); resid=vfam(gasout)-vfam(fgasout); call names; ss=resid*resid; sigma=ss/dfloat(norows(resid)-2); se=dsqrt(diag(sigma*(1.0/xpx))); t=afam(beta)/afam(se); n=namelist(gasin,const); call print('Gasout = a + b*Gasin','RSS',ss); call tabulate(n,beta,se,t); call tabulate(gasout fgasout resid); call graph(resid:heading 'Residuals from Gas Data'); call olsq(gasout,gasin :print); call tabulate(%y,%yhat,%res); b34srun; /; /;TFDIFINFO Tests FDIFIUNFO /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; b34sexec matrix; call loaddata; d=1./3.; fdgas=fracdif(gasout,d,20); call tabulate(%fdacoef,%fdmcoef); call tabulate(fdgas,gasout); acf1=acf(gasout,12); acf2=acf(fdgas ,12); call tabulate(acf1,acf2); call graph(acf1,acf2 :Heading 'ACF of GASOUT and FD GASOUT'); b34srun; b34sexec matrix; * See Cambell-Lo-MacKinley page 60-61 ; call load(fdifinfo); d1=1./3.; nterms=20; /$ Note that dgamma limits us in terms of number of terms call fdifinfo(d1,nterms,ar1,ma1,p1); call print('Results for d = 1/3 - See Page 61'); call tabulate(ar1,ma1,p1); d1=(-1.)/3.; call fdifinfo(d1,nterms,ar2,ma2,p2); call print('Results for d = -1/3 - See Page 61'); call tabulate(ar2,ma2,p2); b34srun; /; /;THP_BP_1 Tests H-P and B-P Filters /; /; Tests the H-P and B-K Filters when passed /; random normal data & ARMA data /; /; Spectrum of trend and dev data are calculated and /; displayed for HP and BK filter. /; /; Note that high and low freq are NOT in dev data for /; BK filter. /; b34sexec matrix; n=5000; s=1600; highfreq=8.; lowfreq=32.; nterms=20; * i=0 for random numbers, =1 for arma ; i=0; * random case ; if(i.eq.0)x=rn(array(n:)); * arma case ; if(i.eq.1)then; ar=array(:.6,-.3); * ma=array(:-.5,-.25); start=array(:.1,.1); x=genarma(ar,ma,1.0,start,.1,n); endif; acf1=acf(x,dmax1(norows(x)/50,2),se,pacf1); call graph(acf1,pacf1 :heading 'ACF & PACF '); call spectral(x,sinx,cosx,px,sx,freq :1 2 3 2 1); freq2=freq/(2.0*pi()); period=vfam(1.0/afam(freq2)); /; call tabulate(freq freq2 period sinx cosx px sx); call graph(freq2,sx:heading 'Spectrum of x' :plottype xyplot); call hpfilter(x,xhpt,xhpdev,s); call graph(x,xhpt,xhpdev); call bpfilter(x,xbpt,xbpdev,highfreq,lowfreq,nterms:); xx=goodrow(catcol(x,xbpt,xbpdev)); newx =xx(,1); xbpt =xx(,2); xbpdev =xx(,3); call graph(newx,xbpt,xbpdev); call spectral(xhpdev,sinx,cosx,px,sx,freq :1 2 3 2 1); freq2=freq/(2.0*pi()); period=vfam(1.0/afam(freq2)); /; call tabulate(freq freq2 period sinx cosx px sx); call graph(freq2,sx:heading 'Spectrum of xhpdev' :plottype xyplot); call spectral(xhpt,sinx,cosx,px,sx,freq :1 2 3 2 1); freq2=freq/(2.0*pi()); period=vfam(1.0/afam(freq2)); /; call tabulate(freq freq2 period sinx cosx px sx); call graph(freq2,sx:heading 'Spectrum of xhpt' :plottype xyplot); call spectral(xbpdev,sinx,cosx,px,sx,freq :1 2 3 2 1); freq2=freq/(2.0*pi()); period=vfam(1.0/afam(freq2)); /; call tabulate(freq freq2 period sinx cosx px sx); call graph(freq2,sx:heading 'Spectrum of xbpdev' :plottype xyplot); call spectral(xbpt,sinx,cosx,px,sx,freq :1 2 3 2 1); freq2=freq/(2.0*pi()); period=vfam(1.0/afam(freq2)); /; call tabulate(freq freq2 period sinx cosx px sx); call graph(freq2,sx:heading 'Spectrum of xbpt' :plottype xyplot); b34srun; /; /;TIMEBASE Illustrate Timebase /; b34sexec options ginclude('b34sdata.mac') member(theil); b34srun; b34sexec matrix; call loaddata; call print(timebase(ct),timestart(ct),freq(ct)); b34srun; /; /;TIMENOW Time now in form hh:mm:ss /; b34sexec matrix; call print('Date now is ',datenow():); call print('Time now is ',timenow():); b34srun; /; /;TIMESTART Illustrate Timestart /; b34sexec options ginclude('b34sdata.mac') member(theil); b34srun; b34sexec matrix; call loaddata; call print(timebase(ct),timestart(ct),freq(ct)); b34srun; /; /;TINY Smallest Number of type /; b34sexec matrix; i=1; x=1.; y=sngl(x); call print('Largest integer ',huge(i):); call print('Largest real*4 ',huge(y):); call print('Largest real*8 ',huge(x):); call print('Smallest real*4 ',tiny(y):); call print('Smallest real*8 ',tiny(x):); call print('Epsilon real*4 ',epsilon(y):); call print('Epsilon real*8 ',epsilon(x):); x=.1d+00; y=sngl(x); j=1; call echooff; do i=1,1000,100; x=x*dfloat(i); y=float(i)*y ; spx(j)=spacing(x); spy(j)=spacing(y); nearpr8(j)=nearest(x, 1.); nearmr8(j)=nearest(x,-1.); nearpr4(j)=nearest(y, 1.); nearmr4(j)=nearest(y,-1.); testnum(j)=x; j=j+1; enddo; call print('Spacing for Real*8 and Real*4'); call tabulate(testnum,spx,spy,nearpr8,nearmr8,nearpr4,nearmr4); call names(all); call graph(testnum,spx :plottype xyplot :heading 'Spacing'); b34srun; /; /;TNLLSQ_1 Test of NLLSQ Using Gallant (1987) Data /; /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix /$ OLS Model estimated using nonlinear methods /$ Model taked from Gallant (1987) page 35 b34sexec options ginclude('b34sdata.mac') member(rgtab_1); b34srun; b34sexec matrix; call loaddata; call load(nlvarcov); * R. Gallant (1987) Page 35 --- Nonlinear Models ; * Parameters SE ; * -0.02588970 .01262384 ; * 1.01567967 .00993793 ; * -1.11569714 .16354199 ; * -0.50490286 .02565721 ; * Starting values suggested by Gallant ; program model1; call echooff; yhat=t1*x1 + t2*x2 + t4*dexp(t3*x3); call outstring(3,3,'Coefficients'); call outstring(3,4,'t1 t2 t3 t4'); call outdouble(14,4,t1); call outdouble(34,4,t2); call outdouble(50,4,t3); call outdouble(14,5,t4); return; end; call print(model1); /$ Note: Without The Gallant starting values we go to a local /$ minimum /$ Can start with .0001 .0001 and -1. -1. to get to /$ answers. This is close to what Gallant suggests call nllsq(y,yhat :name model1 :parms t1 t2 t3 t4 :eps2 .1d-13 :eps1 .1d-13 /$ These are Gallant's starting values /$ :ivalue array(4:-.048866,1.03884,-.73792,-.51362) /$ If parameter # 3 is not set < 0 => problems /$ :ivalue array(4: .0001,.0001,-1.0,-1.0) :ivalue array(4:.1, 1., -.1, .1) :diff array(4: .1d-9 .1d-9 .1d-9 .1d-9) /$ :flam 1.0 :flu 20. :print result residuals); call graph(%res); /$ callprint(nlvarcov); * See Gallant (1987) page 36 ; call nlvarcov(%resvar,%corrmat,%se,varcov); call print(varcov); b34srun; /; /;TNLLSQ_2A Test of NLLSQ Restrictions Using Gallant (1987) /; /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix /$ OLS Model estimated using nonlinear methods /$ Model taken from Gallant (1987) page 35 /$ Restrictions are tested b34sexec options ginclude('b34sdata.mac') member(rgtab_1); b34srun; b34sexec matrix; call loaddata; * R. Gallant (1987) Page 35 --- Nonlinear Models ; * Parameters SE ; * -0.02588970 .01262384 ; * 1.01567967 .00993793 ; * -1.11569714 .16354199 ; * -0.50490286 .02565721 ; * Starting values suggested by Gallant ; program model1; call echooff; yhat=t1*x1 + t2*x2 + t4*dexp(t3*x3); call outstring(3,3,'Coefficients'); call outstring(3,4,'t1 t2 t3 t4'); call outdouble(14,4,t1); call outdouble(34,4,t2); call outdouble(50,4,t3); call outdouble(14,5,t4); return; end; call print(model1); /$ Note: Without The Gallant starting values we go to a local /$ minimum /$ Can start with .0001 .0001 and -1. -1. to get to /$ answers. This is close to what Gallant suggests call nllsq(y,yhat :name model1 :parms t1 t2 t3 t4 :eps2 .1d-13 :eps1 .1d-13 /$ These are Gallant's starting values /$ :ivalue array(4:-.048866,1.03884,-.73792,-.51362) /$ If parameter # 3 is not set < 0 => problems /$ :ivalue array(4: .0001,.0001,-1.0,-1.0) :ivalue array(4:.1, 1., -.1, .1) :diff array(4: .1d-9 .1d-9 .1d-9 .1d-9) /$ :flam 1.0 :flu 20. :print result residuals); * Tests on coefficicient restrictions; fullss=%fss; fullcoef=%coef; * we assume t1=0; t1=0.0; call nllsq(y,yhat :name model1 :parms t2 t3 t4 :eps2 .1d-13 :eps1 .1d-13 /$ These are Gallant's starting values /$ :ivalue array(4:-.048866,1.03884,-.73792,-.51362) /$ If parameter # 2 is not set < 0 => problems /$ :ivalue array(3:.0001,.0001,-1.0,-1.0) :ivalue array(3: 1., -.1, .1) :diff array(3: .1d-9 .1d-9 .1d-9) /$ :flam 1.0 :flu 20. :print result residuals); rss1=%fss; q=4; * See Galland page 60 ; lr=((rss1-fullss)/1.)/(fullss/(dfloat(%nob-q))); call print(lr,'Probility of F ',fprob(lr,1.0,dfloat(%nob-q)), '95% Critical Value ',invfdis(.95,1.0,dfloat(%nob-q)) ); * Second set of restrictions ; * We test if t(3)*t(4)*dexp((3))=.2 ; * Same as asserting t(4)= 1./(5.*t(3)*dexp(t(3))); program model2; call echooff; t4=1./(5.*t3*dexp(t3)); yhat=t1*x1 + t2*x2 + t4*dexp(t3*x3); call outstring(3,3,'Coefficients'); call outstring(3,4,'t1 t2 t3 t4'); call outdouble(14,4,t1); call outdouble(34,4,t2); call outdouble(50,4,t3); call outdouble(14,5,t4); return; end; t1=0.0; call nllsq(y,yhat :name model2 :parms t1 t2 t3 :eps2 .1d-13 :eps1 .1d-13 /$ These are Gallant's starting values /$ If parameter # 2 is not set < 0 => problems /$ :ivalue array(3:.0001,.0001,-1.0,-1.0) :ivalue array(3: fullcoef(1),fullcoef(2),fullcoef(3)) :diff array(3: .1d-9 .1d-9 .1d-9) /$ :flam 1.0 :flu 20. :print result residuals); rss1=%fss; q=4; * See Galland page 62 ; lr=((rss1-fullss)/1.)/(fullss/(dfloat(%nob-q))); call print(lr,'Probility of F ',fprob(lr,1.0,dfloat(%nob-q)), '95% Critical Value ',invfdis(.95,1.0,dfloat(%nob-q)) ); * Final Test where BOTH t(1) = 0 and t(3)*t(4)*dexp((3))=.2; T1=0.0; call nllsq(y,yhat :name model2 :parms t2 t3 :eps2 .1d-13 :eps1 .1d-13 /$ These are Gallant's starting values :ivalue array(2: fullcoef(2),fullcoef(3)) :diff array(2: .1d-9 .1d-9) /$ :flam 1.0 :flu 20. :print result residuals); rss1=%fss; q=4; * See Gallant page 64 ; lr=((rss1-fullss)/ dfloat(4-2)) / (fullss/(dfloat(%nob-q))); call print(lr,'Probility of F ',fprob(lr,2.0,dfloat(%nob-q)), '95% Critical Value ',invfdis(.95,2.0,dfloat(%nob-q)) ); b34srun; /; /;TNLLSQ_2B Runs TNLLSQ_2 using RATS /; /$ Illustrates Nonlinear Estimation using RATS Command under b34s /$ Model taken from Gallant (1987) page 35 /$ Restrictions are tested. Note that Rats appears NOT /$ to rerun the model with the restriction in place. /$ The resulting test is NOT EXACTLY is obtained when the /$ model is rerun as suggested by Gallant (1987) /$ b34sexec options ginclude('b34sdata.mac') member(rgtab_1); b34srun; /$ B34SEXEC OPTIONS OPEN('rats.dat') UNIT(28) DISP=UNKNOWN$ B34SRUN$ B34SEXEC OPTIONS OPEN('rats.in') UNIT(29) DISP=UNKNOWN$ B34SRUN$ B34SEXEC OPTIONS CLEAN(28)$ B34SRUN$ B34SEXEC OPTIONS CLEAN(29)$ B34SRUN$ B34SEXEC PGMCALL$ RATS PASSASTS PCOMMENTS('* ', '* Data passed from B34S(r) system to RATS', '* ') $ PGMCARDS$ * * Rats TEST command appears to NOT reestimate the coefficients * Rather the old values are used and the test is imposed * * Gallant (1987) suggests rerunning the model with the restriction * In this problem there are minor differences * * Gallant;s starting values * $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ * RATS and b34s are both influenced by the starting values nonlin t1 t2 t3 t4 frml yhat = t1*x1 + t2*x2 + t4*exp(t3*x3); input t1 t2 t3 t4 -.048866,1.03884,-.73792,-.51362 * If parameter # 3 is not set < 0 => problems nlls(frml=yhat,trace) y test # 1 # 0.0 * Tests with different starting values * Values Used by b34s * $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ nonlin t1 t2 t3 t4 frml yhat = t1*x1 + t2*x2 + t4*exp(t3*x3); input t1 t2 t3 t4 .0001,.0001,-1.0,-1.0 * -.048866,1.03884,-.73792,-.51362 * If parameter # 3 is not set < 0 => problems * .0001,.0001,-1.0,-1.0 nlls(frml=yhat,trace) y test # 1 # 0.0 * These starting values cause problems!!! * $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ nonlin t1 t2 t3 t4 frml yhat = t1*x1 + t2*x2 + t4*exp(t3*x3); input t1 t2 t3 t4 .0001,.0001,1.0,1.0 nlls(frml=yhat,trace) y test # 1 # 0.0 B34SRETURN$ B34SRUN $ /; /;TNLLSQ_3 Further NLLSQ Test of Restrictions /; /$ Illustrates Nonlinear Estimation using NLLSQ Command under matrix /$ OLS Model estimated using nonlinear methods /$ Model taken from Gallant (1987) page 66 /$ Restrictions are tested b34sexec options ginclude('b34sdata.mac') member(rgtab_2); b34srun; b34sexec matrix; call loaddata; * R. Gallant (1987) Page 66 --- Nonlinear Models ; * Parameters SE ; * 1.37396966 .04864622 ; * 0.40265518 .0132439 ; * Starting values suggested by Gallant ; program model; call echooff; yhat=t1*(dexp(-1.*t2*x1)-dexp(-1.*t1*x1))/(t1-t2); call outstring(3,3,'Coefficients'); call outstring(3,4,'t1 t2 '); call outdouble(14,4,t1); call outdouble(34,4,t2); return; end; call print(model); /$ Note: Without The Gallant starting values we go to a local /$ minimum call nllsq(modelb, yhat :name model :parms t1 t2 :eps2 .1d-13 :eps1 .1d-13 /$ These are Gallant's starting values :ivalue array(2:1.4,.4) :diff array(2: .1d-9 .1d-9) /$ :flam 1.0 :flu 20. :print result residuals); * Tests on coefficicient restrictions; fullss=%fss; fullcoef=%coef; /$ Due to 'loop', this code runs slowly but corrrectly program model2; call echooff; t2=rho; z1=1.4; z2=0.0; c=t2-dlog(t2); loop continue; if(dabs(z1-z2).le.1.d-13)go to nextstep; z2=z1; z1=dlog(z1)+c; go to loop; nextstep continue; t1=z1; yhat=t1*(dexp(-1.*t2*x1)-dexp(-1.*t1*x1))/(t1-t2); call outstring(3,3,'Coefficients'); call outstring(3,4,'rho'); call outdouble(14,4,rho); return; end; call print(model2); call nllsq(modelb, yhat :name model2 :parms rho :eps2 .1d-13 :eps1 .1d-10 /$ These are Gallant's starting values :ivalue fullcoef(2) :diff .1d-9 /$ :flam 1.0 :flu 20. :print result residuals); q=2; newq=1;call loaddata; lr=((%fss-fullss)/dfloat(newq))/(fullss/dfloat(%nob-q)); call print(lr,'Probility of F ',fprob(lr,dfloat(newq),dfloat(%nob-q)), '95% Critical Value ',invfdis(.95,dfloat(newq),dfloat(%nob-q))); * These results replicate Gallant (1987) page 69 ; * Rho and SE should be .47754289 with SE .03274044 ; * LR = 74.670 which indicates rejection ; b34srun; /; /;TNONLIN_A Tests series using Hinich, Tsay, BDS /; b34sexec matrix; * Job takes time depending on n setting ; * TSAY, Hinich, Keenan and BDS tests illustrated ; * Note for low n (say 1000) get false positives in all but Hinich; call echooff; n=5000; call print('Random Data'); x=rn(array(n:)); call graph(acf(x) :heading 'Graph of acf of x'); call tsay(x,10,tsaytest,prob:); call hinich82(x,m,g,l:smoothspec); call print('Hinich Test on x'); call tabulate(m,g,l); call bds(x,.5 10:); do i=2,10; call keenan(x,tt,i,pp); j=i-1; test(j) =tt; prob(j) =pp; order(j) =i; enddo; call print('Keenan (1985) Test of X Series'); call tabulate(order,test,prob); call hinich96(x,0.0,V,H); call print('Mean Data for Hinich(96) Test on X',V,H); c=grid(.2 .45,.02); v=array(norows(c):); h=array(norows(c):); do i=1,norows(c); call hinich96(x,c(i),vv,hh); v(i)=vv; h(i)=hh; enddo; call print('Hinich(96) Test on X for various c values'); call tabulate(c,v,h); call print('Simple Nonlinear Data'); i=integers(norows(x)-1); xx=array(norows(i):); xx=x(i+1)*dexp(x(i))+rn(xx); call graph(acf(xx) :heading 'Graph of acf of xx'); call tsay(xx,10,tsaytest,prob:); call hinich82(xx,m,g,l:smoothspec); call print('Hinich Test on xx'); call tabulate(m,g,l); call bds(xx,.5,10:); do i=2,10; call keenan(xx,tt,i,pp); j=i-1; test(j) =tt; prob(j) =pp; order(j) =i; enddo; call print('Keenan (1985) Test of XX Series'); call tabulate(order,test,prob); call hinich96(xx,0.0,V,H); call print('Mean Data for Hinich(96) Test on XX',V,H); c=grid(.2 .45,.02); v=array(norows(c):); h=array(norows(c):); do i=1,norows(c); call hinich96(xx,c(i),vv,hh); v(i)=vv; h(i)=hh; enddo; call print('Hinich(96) Test on XX for various c values'); call tabulate(c,v,h); b34srun; /; /;TPAD Test PAD Subroutine /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec matrix; call loaddata; call load(pad); call print(pad); call pad(gasout,ngasout,10,20,missing()); call tabulate(gasout,ngasout); b34srun; /; /;TPROB Student t distribution /; b34sexec matrix; t=2.447; df=6.; p=tprob(t,df); call print('The prob: that a t(',df,') variate is GE abs(', t,') is ',p,'Note answer should be .9500'); b34srun; /; /;TRACE TRACE function => Trace of a matrix /; b34sexec matrix; m=matrix(3,3:1 2 3 4 5 6 7 8 9); call names(all); t=trace(m); call print('Matrix M',m); call print('Trace of M',t); e=eigenval(m); call print('Sum of eigenvalues = trace',sum(e),trace(m)); b34srun; %b34sendif; %b34sif(&test6.eq.1)%then; /; /;TRANSPOSE Transpose function => Transpose of a matrix /; /$ b34sexec options debugsubs(b34smat12); b34srun; b34sexec matrix; real8=matrix(3,3:1 2 3 4 5 6 7 8 9); call print('Matrix and its transpose',real8,transpose(real8)); comp=complex(real8,real8); call print('Matrix and its transpose',comp,transpose(comp)); nn=namelist(a b c d e f g h i); nn2=c8array(3,3:nn); /$ nn2=array(3,3:nn); call names(all); call print('Matrix and its transpose',nn2 ,transpose(nn2 )); call character(cc,'ABCDEFGHI'); ch1=c1array(3,3:cc); /$ ch1=array(3,3:cc); call print('Matrix and its transpose',ch1 ,transpose(ch1 )); int4=idint(real8);real4=sngl(real8); call print('Matrix and its transpose',int4,transpose(int4)); call print('Matrix and its transpose',real4,transpose(real4)); call names(all); b34srun; /; /;TRIPLES Triples Reversal Test /; b34sexec matrix ; * Program tests TRIPLES test using internal MATRIX Command; * Correct Answers should be: ; * eta =-.23333 ; * vareta = .01333 ; * Stat =-2.0207 ; n=6; x=vector(n: 2.373, 3.339, 1.980, 3.102, 0.000 3.335) ; call names(all); call triples(x :print); n=100; x=rn(vector(n:)); call triples(x :print); b34srun ; /$ b34sexec options stop; b34srun; /; /;TRIPLES_2 Tests Triples using MATRIX Code /; b34sexec matrix ; * Program tests TRIPLES test using MATRIX Command; * Program written by JinMan Lee ; * Correct Answers should be: ; * eta =-.23333 ; * vareta = .01333 ; * Stat =-2.0207 ; call echooff ; * Program uses makeglobal to move x array around and save memory ; N = 6 ; * x=rn(vector(n:)) ; x=vector(n: 2.373, 3.339, 1.980, 3.102, 0.000 3.335) ; NN = dfloat(N) ; call makeglobal(x,n); /; *************************** FUNCTION FSTAR(i,j,k) ; T1=X(I)+X(J)-2.0*X(K) ; T2=X(I)+X(K)-2.0*X(J) ; T3=X(K)+X(J)-2.0*X(I) ; T4=T1*T2*T3 ; IF (T4 .EQ. 0.0) THEN ; TMP = 0.0 ; ENDIF ; IF (T4 .NE. 0.0) THEN ; T1=T1/dabs(T1) ; T2=T2/dabs(T2) ; T3=T3/dabs(T3) ; TMP=(T1+T2+T3)/3.0 ; ENDIF ; return(tmp) ; end ; /; *************************** FUNCTION FX1I(I) ; T1=0.0 ; iia = i+1 ; if(i.lt.3) go to loop1 ; DO J=1,I-2 ; DO K=J+1,I-1 ; t1temp = FSTAR(J,K,I) ; T1=T1+t1temp ; enddo ; enddo ; loop1 continue ; if(i.lt.2) go to loop2 ; if(iia.gt.N) go to loop2 ; DO J=1,I-1 ; DO K=I+1,N ; t1temp = FSTAR(J,I,K) ; T1=T1+t1temp ; enddo ; enddo ; loop2 continue ; n_1 = n-1 ; if(iia.gt.n_1)go to loop3 ; DO J=iia,N-1 ; DO K=J+1,N ; t1temp = FSTAR(I,J,K) ; T1=T1+t1temp ; enddo ; enddo ; loop3 continue ; return(t1) ; end ; /; *************************** /; *************************** FUNCTION FX2IJ(I,J) ; II=I ; JJ=J ; IF(I.GT.J)THEN ; II=J ; JJ=I ; ENDIF ; IIA = II+1 ; JJ_1 = JJ-1 ; JJA = JJ+1 ; T1=0.0 ; if(II.le.1)go to loop1 ; DO K=1,II-1 ; t1temp =FSTAR(K,II,JJ) ; T1=T1+ t1temp ; enddo ; loop1 continue ; if(jj.le.1)go to loop2 ; if(IIA.gt.JJ_1)go to loop2 ; DO K=II+1,JJ-1 ; t1temp =FSTAR(II,K,JJ) ; T1=T1+ t1temp ; enddo ; loop2 continue ; if(jja.gt.N)go to loop3 ; DO K=JJ+1,N ; t1temp =FSTAR(II,JJ,K) ; T1=T1+ t1temp ; enddo ; loop3 continue; return(t1) ; end ; /; *************************** HALFN=DINT(NN/2.0) ; NNMIN2=NN-2.0 ; NNCHUS3=(NN*(NN-1.0)*(NN-2.0))/6.0 ; NNCHUS2=(NN*(NN-1.0))/2.0 ; NNMIN1C2=((NN-1.0)*(NN-2.0))/2.0 ; /; CALCULATE ETA eta = 0.0 ; Do i=1, n-2 ; Do j=i+1, n-1 ; Do k=j+1, n ; eta1 = fstar(i,j,k) ; eta = eta + eta1 ; enddo ; enddo ; enddo ; ETA=ETA/NNCHUS3 ; /; CALCULATE KSI1 KSI1=0.0 ; DO I=1,N ; tempt1 = FX1I(I) ; temp=tempT1/NNMIN1C2 ; TEMP2=(TEMP-ETA)*(TEMP-ETA) ; KSI1=KSI1+TEMP2 ; enddo ; KSI1=KSI1/NN ; /; call print('KSI1 : ',ksi1) ; /; CALCULATE KSI2 KSI2=0.0 ; DO I=1,N-1 ; DO J=I+1,N ; TEMPT1=FX2IJ(I,J) ; TEMP = TEMPT1/NNMIN2 ; TEMP2=(TEMP-ETA)*(TEMP-ETA) ; KSI2=KSI2+TEMP2 ; enddo ; enddo ; KSI2=KSI2/NNCHUS2 ; /; call print('KSI2 : ',ksi2) ; /; CALCULATE KSI3 KSI3=(1.0/9.0)-(ETA*ETA) ; /; call print('KSI3 : ',ksi3) ; /; CALCULATE VARIANCE V=KSI1*3.0*(NN-3.0)*(NN-4.0)/2.0 ; V=V+(KSI2*3.0*(NN-3.0))+KSI3 ; V=V/NNCHUS3 ; /; CALCULATE TEST STATISTIC (WHICH IS STD. N) IF (V.GT.0.0)THEN ; STAT3 = ETA/DSQRT(V) ; ENDIF ; IF (V.LE.0.0)THEN ; STAT3 = 999999 ; ENDIF ; call print('ETA : ',eta :); call print('VARIANCE : ',v :); call print('TRIPLES Test STAT : ',stat3 :); b34srun ; /; /;TSAY Tsay (1986) Nonlinearity Test /; b34sexec options ginclude('gas.b34'); b34srun; b34sexec reg; model gasout=gasin{0 to 12} gasout{1 to 12}; bispec iauto iturno bds tsay tsayorder=10; b34srun; b34sexec options ginclude('b34sdata.mac') member(blake); b34srun; b34sexec matrix; * Both TSAY and BDS tests illustrated ; call loaddata; call bds(blake,.5,5:); call tsay(blake,20,tsaytest,prob:); call print('Random Data'); x=rn(array(5000:)); call tsay(x,20,tsaytest,prob:); b34srun; /; /;UPPERT Upper Triangle /; b34sexec matrix; x=rn(matrix(6,6:)); call print(x); call print(zerou(x)); call print(zerou(x :nodiag)); call print(zerol(x)); call print(zerol(x : :nodiag)); call print(uppert(x)); call print(uppert(x :nodiag)); call print(lowert(x)); call print(lowert(x :nodiag)); b34srun; /; /;VAREST VAR Modeling /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; /$ This validates with BTEST b34sexec matrix; call loaddata; call load(buildlag); call load(varest); call echooff; ibegin=1; iend=296; nlag=2; nterms=10; x=catcol(gasin,gasout); call varest(x,nlag,ibegin,iend,beta,t,sigma,corr,residual,1, a,ai,varx,varxhat,rsq); call print(beta,t,sigma,corr); call tabulate(varx,varxhat,rsq); call polymdisp(:display a ai); call polyminv(a ai psi ipsi nterms); call polymdisp(:display psi ipsi); b34srun; b34sexec btest$ title=('Estimation run with gas data') $ seriesn var=gasin name=('b-j gas input data') $ seriesn var=gasout name=('b-j gas output data') $ ar(1,1,1)=.1 $ ar(1,1,2)=.1 $ ar(1,2,1)=.1 $ ar(1,2,2)=.1 $ ar(2,1,1)=.1 $ ar(2,1,2)=.1 $ ar(2,2,1)=.1 $ ar(2,2,2)=.1 $ output iprint lagrho=12 nfmat=12 $ constant=(yes,yes) $ forecast nt=(296,250) nf=(24,20) se actual $ b34seend$ /$ /$ Use BTIDEN to test lag 20 model /$ b34sexec btiden$ title=('Identification run with Gas Data and 20 lags') $ seriesn var=gasin name=('Exogenous Series') $ seriesn var=gasout name=('Endogenous Series') $ estvar p=20 output=normal numirf=10 granger ilarf$ bispec iauto iturno df pp$ b34seend$ /; /;VAREST_16 Illustrates real*8 and real*16 /; b34sexec options ginclude('b34sdata.mac') member(gas); b34srun; /$ This validates with BTEST b34sexec matrix; call loaddata; call load(buildlag); call load(varest); call echooff; ibegin=1; iend=296; nlag=2; nterms=10; x=catcol(gasin,gasout); call varest(x,nlag,ibegin,iend,beta,t,sigma,corr,residual,1, a,ai,varx,varxhat,rsq); call print(beta,t,sigma,corr); call tabulate(varx,varxhat,rsq); call polymdisp(:display a ai); call polyminv(a ai psi ipsi nterms); call polymdisp(:display psi ipsi); call print('+++++++++++ real*16 +++++++++++++++++++':); x=r8tor16(x); call varest(x,nlag,ibegin,iend,beta,t,sigma,corr,residual,1, a,ai,varx,varxhat,rsq); call print(beta,t,sigma,corr); call tabulate(varx,varxhat,rsq); a =kindas(1.0,a); call polymdisp(:display a ai); call polyminv(a ai psi ipsi nterms); call polymdisp(:display psi ipsi); b34srun; /; /;VARIANCE Variance function => variance of an object /; b34sexec options ginclude('gas.b34')$ b34srun$ b34sexec matrix; call loaddata; mgasin=mean(gasin); mgasout=mean(gasout); call print('Gasin Mean',mgasin); call print('Gasout Mean',mgasout); vgasin=variance(gasin); vgasout=variance(gasout); call print('Gasin Variance',vgasin); call print('Gasout Variance',vgasout); b34srun$ /$ problem # 2 b34sexec matrix; /$ /$ Test variance with Wilkinson - Dallal (1977) data /$ Variance should be 1. /$ /$ "Accuracy of Sample Moments Calculations Among /$ Widely Used Statistical Programs," American /$ Statistican, 31:3, pp. 128-31. /$ x=array(3: 90000001., 90000002., 90000003.); v=variance(x); testv=v-1.0d+00; call print(v,testv); b34srun; /; /;VECTOR VECTOR function => create a vector /; b34sexec matrix$ v=vector(4:1 2 3 4); call print(v); b34srun; /; /;VFAM VFAM function => change array obj. to vector obj. /; b34sexec matrix$ x=array(3,3:); x=rn(x); call print(x); mx=vfam(x); call print(mx); xa=array(3:1 2 3); vxa=vfam(xa); call print(xa,vxa); b34srun; /; /;VOCAB SORT command on real*8 and Character Data /; b34sexec matrix; call vocab(cb); ccb=cb; call sort(ccb); call print(cb,ccb); cfb=vocab(); ccfb=cfb; call sort(ccfb); call print(cfb,ccfb); b34srun; /; /;VOCAB_2 Lists Internal Command Numbers /; b34sexec matrix; call vocab(cb:); cfb=vocab(:); b34srun; /; /;WHERE Where Command => Masking operation /; b34sexec matrix; x=array(:1,-2,3,-4,5,-6,7,-8,9,-10); y=array(:0,-2,1,-4,6,-6,2,-8,5,-10); yhold=array(norows(x):); call setcol(yhold,1,-99.); where(x.ne.y)yhold=y; where(x.eq.y)q=y; call print('We set yhold = -99 where x = y', 'We set yhold = y where x ne y', 'We set q = y where x = y', 'We set q = 0 where x ne y'); call tabulate(x,y,yhold,q); where(x.gt.0.0)isgtzero=1.; where(x.gt.0.0)isminus=missing(); call tabulate(x,isgtzero,isminus); b34srun; /$ /$ Illustrate resetting /$ b34sexec matrix; x=array(:1,-2,3,-4,5,-6,7,-8,9,-10); y=array(:0,-2,1,-4,6,-6,2,-8,5,-10); x2bad=x; x2good=x; dummy=array(norows(x):)+missing(); where(x.eq.y)x2bad =missing(); where(x.eq.y)x2good =dummy; call tabulate(x,y,x2bad,x2good); b34srun; /; /;WRITE1 READ/WRITE/OPEN/REWIND/CLOSE /; b34sexec matrix; * Tests I/O package ; * Real*8, Integer, Character*1 & Character*8 are written and read back ; * Note: Before reading, structure of object must be known!!!! ; n=1000; test=rn(array(n:)); call open(70,'testdata'); call write(test,70); tmean=mean(test); call print(tmean); i=integers(1,20); call write(i,70); call character(cc,'This is a test I hope it works'); call write(cc,70); a=array(3:'joan','Margo','Nancy'); call write(a,70); call names(all); call free(test); call rewind(70); call close(70); call open(71,'testdata'); test2=array(n:); call character(cc,'this is less '); call read(test2,71); i=i+100; call read(i,71); call print(i); call read(cc,71); call print(cc); a(1)='bob'; call read(a,71); call print(a); tmean2=mean(test2); call print(tmean2); call names(all); b34srun; /; /;WRITE2 Illustrates WRITE/READ to build MATLAB I/O System /; b34sexec matrix ; /$ Shows Matrix subroutine implementation of built in /$ makematlab and getmatlab commands /$ /$ Job illustrates read / write i/o /$ subroutine gmatlab(c,xx); n=70; call open(n,c); call character(line,' '); call read(line,n); call print(line); xi=1.; xj=1.; call read(xi,n,'(20x,e16.8)'); call read(xj,n,'(20x,e16.8)'); xx=array(idint(xi),idint(xj):); call read(xx,n,'(5e16.8)'); call close(n); return; end; subroutine mmatlab(c,xx); n=70; call open(n,c); call character(ccc,'--File built by B34S(r) MATRIX Facility'); call write(ccc,n); i=norows(xx); j=nocols(xx); call write(dfloat(i),n,'(20x,e16.8)'); call write(dfloat(j),n,'(20x,e16.8)'); call write(xx,n,'(5e16.8)'); call close(n); return; end; xx=rn(array(100,50:)); call character(ccc,'c:\junk\test.mmm'); call mmatlab(ccc,xx); call gmatlab(ccc,crap); call print(crap); b34srun; /; /;WRITE3 Character Writes /; b34sexec matrix; call open(99,'test'); call character(c,'Line one' 'Line 222222222222222222222' 'Line three '); call names(all); call print(c); call write(c,99); call close(99); b34srun; /; /;ZDOTC Inner product and related commands /; b34sexec matrix; n=10; x=rn(vector(n:)); y=rn(x); call print(x,y); call print(x*y,ddot(x,y),afam(x)*afam(y),ddot(x,y:), sum(afam(x)*afam(y))); * Complex case ; cx=complex(x,y); cy=complex(y,x); call print(cx,cy); call print(cx*cy,dconj(cx)*cy,zdotu(cx,cy),zdotc(cx,cy), afam(cx)*afam(cy),dconj(afam(cx))*afam(cy), zdotu(cx,cy:),zdotc(cx,cy:), sum( afam(cx) *afam(cy)), sum(dconj(afam(cx))*afam(cy)) ); b34srun; /; /;ZDOTU Inner product and related commands /; b34sexec matrix; n=10; x=rn(vector(n:)); y=rn(x); call print(x,y); call print(x*y,ddot(x,y),afam(x)*afam(y),ddot(x,y:), sum(afam(x)*afam(y))); * Complex case ; cx=complex(x,y); cy=complex(y,x); call print(cx,cy); call print(cx*cy,dconj(cx)*cy,zdotu(cx,cy),zdotc(cx,cy), afam(cx)*afam(cy),dconj(afam(cx))*afam(cy), zdotu(cx,cy:),zdotc(cx,cy:), sum( afam(cx) *afam(cy)), sum(dconj(afam(cx))*afam(cy)) ); b34srun; /; /;ZEROL Zero out lower triangle /; b34sexec matrix; x=rn(matrix(6,6:)); call print(x); call print(zerou(x)); call print(zerou(x :nodiag)); call print(zerol(x)); call print(zerol(x : :nodiag)); call print(uppert(x)); call print(uppert(x :nodiag)); call print(lowert(x)); call print(lowert(x :nodiag)); b34srun; /; /;ZEROU Zero out upper triangle /; b34sexec matrix; x=rn(matrix(6,6:)); call print(x); call print(zerou(x)); call print(zerou(x :nodiag)); call print(zerol(x)); call print(zerol(x : :nodiag)); call print(uppert(x)); call print(uppert(x :nodiag)); call print(lowert(x)); call print(lowert(x :nodiag)); b34srun; /; %b34sendif;