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); }