void Ti_Optimization::hshreabid(double **a, int m, int n, double d[], double b[],
double em[])
{
int i,j,i1;
double norm,machtol,w,s,f,g,h;
norm=0.0;
for (i=1; i<=m; i++)
{
w=0.0;
for (j=1; j<=n; j++)
w += fabs(a[i][j]);
if (w > norm)
norm=w;
}
machtol=em[0]*norm;
em[1]=norm;
for (i=1; i<=n; i++)
{
i1=i+1;
s=tammat(i1,m,i,i,a,a);
if (s < machtol)
d[i]=a[i][i];
else
{
f=a[i][i];
s += f*f;
d[i] = g = (f < 0.0) ? sqrt(s) : -sqrt(s);
h=f*g-s;
a[i][i]=f-g;
for (j=i1; j<=n; j++)
elmcol(i,m,j,i,a,a,tammat(i,m,i,j,a,a)/h);
}
if (i < n)
{
s=mattam(i1+1,n,i,i,a,a);
if (s < machtol)
b[i]=a[i][i1];
else
{
f=a[i][i1];
s += f*f;
b[i] = g = (f < 0.0) ? sqrt(s) : -sqrt(s);
h=f*g-s;
a[i][i1]=f-g;
for (j=i1; j<=m; j++)
elmrow(i1,n,j,i,a,a,mattam(i1,n,i,j,a,a)/h);
}
}
}
}
void orthog(int n, int lc, int uc, real_t **x)
{
int *allocate_integer_vector(int, int);
void free_integer_vector(int *, int);
real_t tammat(int, int, int, int, real_t **, real_t **);
void elmcol(int, int, int, int, real_t **, real_t **, real_t);
int i,j,k;
real_t normx;
for (j=lc; j<=uc; j++) {
normx=sqrt(tammat(1,n,j,j,x,x));
for (i=1; i<=n; i++) x[i][j] /=normx;
for (k=j+1; k<=uc; k++) elmcol(1,n,k,j,x,x,-tammat(1,n,k,j,x,x));
}
}
void Ti_Optimization::psttfmmat(double **a, int n, double **v, double b[])
{
/*double matmat(int, int, int, int, double **, double **);
void elmcol(int, int, int, int, double **, double **, double);*/
int i,i1,j;
double h;
i1=n;
v[n][n]=1.0;
for (i=n-1; i>=1; i--) {
h=b[i]*a[i][i1];
if (h < 0.0) {
for (j=i1; j<=n; j++) v[j][i]=a[i][j]/h;
for (j=i1; j<=n; j++)
elmcol(i1,n,j,i,v,v,matmat(i1,n,i,j,a,v));
}
for (j=i1; j<=n; j++) v[i][j]=v[j][i]=0.0;
v[i][i]=1.0;
i1=i;
}
}
void Ti_Optimization::pretfmmat(double **a, int m, int n, double d[])
{
/*double tammat(int, int, int, int, double **, double **);
void elmcol(int, int, int, int, double **, double **, double);*/
int i,i1,j;
double g,h;
for (i=n; i>=1; i--) {
i1=i+1;
g=d[i];
h=g*a[i][i];
for (j=i1; j<=n; j++) a[i][j]=0.0;
if (h < 0.0) {
for (j=i1; j<=n; j++)
elmcol(i,m,j,i,a,a,tammat(i1,m,i,j,a,a)/h);
for (j=i; j<=m; j++) a[j][i] /= g;
} else
for (j=i; j<=m; j++) a[j][i]=0.0;
a[i][i] += 1.0;
}
}
void lsqdecomp(real_t **a, int n, int m, int n1, real_t aux[],
real_t aid[], int ci[])
{
real_t *allocate_real_vector(int, int);
void free_real_vector(real_t *, int);
real_t matmat(int, int, int, int, real_t **, real_t **);
real_t tammat(int, int, int, int, real_t **, real_t **);
void elmcol(int, int, int, int, real_t **, real_t **, real_t);
void ichcol(int, int, int, int, real_t **);
int j,k,kpiv,nr,s,fsum;
real_t beta,sigma,norm,aidk,akk,w,eps,temp,*sum;
sum=allocate_real_vector(1,m);
norm=0.0;
aux[3]=m;
nr=n1;
fsum=1;
for (k=1; k<=m; k++) {
if (k == n1+1) {
fsum=1;
nr=n;
}
if (fsum)
for (j=k; j<=m; j++) {
w=sum[j]=tammat(k,nr,j,j,a,a);
if (w > norm) norm=w;
}
fsum=0;
eps=aux[2]*sqrt(norm);
sigma=sum[k];
kpiv=k;
for (j=k+1; j<=m; j++)
if (sum[j] > sigma) {
sigma=sum[j];
kpiv=j;
}
if (kpiv != k) {
sum[kpiv]=sum[k];
ichcol(1,n,k,kpiv,a);
}
ci[k]=kpiv;
akk=a[k][k];
sigma=tammat(k,nr,k,k,a,a);
w=sqrt(sigma);
aidk=aid[k]=((akk < 0.0) ? w : -w);
if (w < eps) {
aux[3]=k-1;
break;
}
beta=1.0/(sigma-akk*aidk);
a[k][k]=akk-aidk;
for (j=k+1; j<=m; j++) {
elmcol(k,nr,j,k,a,a,-beta*tammat(k,nr,k,j,a,a));
temp=a[k][j];
sum[j] -= temp*temp;
}
if (k == n1)
for (j=n1+1; j<=n; j++)
for (s=1; s<=m; s++) {
nr = (s > n1) ? n1 : s-1;
w=a[j][s]-matmat(1,nr,j,s,a,a);
a[j][s] = (s > n1) ? w : w/aid[s];
}
}
free_real_vector(sum,1);
}
void arkmat(real_t *t, real_t te, int m, int n, real_t **u,
void (*der)(int, int, real_t, real_t **, real_t **),
int type, int *order, real_t *spr,
void (*out)(real_t, real_t, int, int, real_t **, int,
int, real_t *))
{
real_t **allocate_real_matrix(int, int, int, int);
void free_real_matrix(real_t **, int, int, int);
void elmcol(int, int, int, int, real_t **, real_t **, real_t);
void dupmat(int, int, int, int, real_t **, real_t **);
int sig,l,last,ta,tb,i;
real_t tau,lambda[10],**uh,**du,mlt;
static real_t lbd1[9]={1.0/9.0, 1.0/8.0, 1.0/7.0, 1.0/6.0,
1.0/5.0, 1.0/4.0, 1.0/3.0, 1.0/2.0, 4.3};
static real_t lbd2[9]={0.1418519249e-2, 0.3404154076e-2,
0.0063118569, 0.01082794375, 0.01842733851,
0.03278507942, 0.0653627415, 0.1691078577, 156.0};
static real_t lbd3[9]={0.3534355908e-2, 0.8532600867e-2,
0.015956206, 0.02772229155, 0.04812587964,
0.08848689452, 0.1863578961, 0.5, 64.0};
static real_t lbd4[9]={1.0/8.0, 1.0/20.0, 5.0/32.0, 2.0/17.0,
17.0/80.0, 5.0/22.0, 11.0/32.0, 1.0/2.0, 8.0};
uh=allocate_real_matrix(1,n,1,m);
du=allocate_real_matrix(1,n,1,m);
/* initialize */
if (type != 2 && type != 3) type=1;
if (type != 2)
*order = 2;
else
if (*order != 2) *order = 1;
switch ((type == 1) ? 1 : type+(*order)-1) {
case 1: for (i=0; i<=8; i++) lambda[i+1]=lbd1[i]; break;
case 2: for (i=0; i<=8; i++) lambda[i+1]=lbd2[i]; break;
case 3: for (i=0; i<=8; i++) lambda[i+1]=lbd3[i]; break;
case 4: for (i=0; i<=8; i++) lambda[i+1]=lbd4[i]; break;
}
sig = ((te == *t) ? 0 : ((te > *t) ? 1 : -1));
last=0;
do {
tau=((*spr == 0.0) ? fabs(te-(*t)) :
fabs(lambda[9]/(*spr)))*sig;
ta = (*t)+tau >= te;
tb = tau >= 0.0;
if ((ta && tb) || (!(ta || tb))) {
tau=te-(*t);
last=1;
}
/* difference scheme */
(*der)(m,n,*t,u,du);
for (i=1; i<=8; i++) {
mlt=lambda[i]*tau;
dupmat(1,n,1,m,uh,u);
for (l=1; l<=m; l++) elmcol(1,n,l,l,uh,du,mlt);
(*der)(m,n,(*t)+mlt,uh,du);
}
for (l=1; l<=m; l++) elmcol(1,n,l,l,u,du,tau);
*t = (last ? te : (*t)+tau);
(*out)(*t,te,m,n,u,type,*order,spr);
} while (!last);
free_real_matrix(uh,1,n,1);
free_real_matrix(du,1,n,1);
}
