static void tddmrg_expMat(dreal tau, const mat2d_dreal *Mat, mat2d_dcmplx *expMat)
{
int ndim, idim, jdim;
dreal *mat = NULL, *eig = NULL;
dcmplx *zmat = NULL, *expdiag = NULL, *tmpmat = NULL;
ndim = Mat->nrow;
expMat->Reset(expMat);
mat = (dreal *) calloc(ndim*ndim, sizeof(dreal));
eig = (dreal *) calloc(ndim, sizeof(dreal));
zmat = (dcmplx *) calloc(ndim*ndim, sizeof(dcmplx));
expdiag = (dcmplx *) calloc(ndim*ndim, sizeof(dcmplx));
tmpmat = (dcmplx *) calloc(ndim*ndim, sizeof(dcmplx));
memcpy(mat, Mat->addr, ndim*ndim*sizeof(dreal));
lapack_dsyev(ndim, mat, eig);
for(idim = 0; idim < ndim; ++idim)
for(jdim = 0; jdim < ndim; ++jdim)
zmat[idim*ndim+jdim] = (dcmplx) mat[idim*ndim+jdim];
for(idim = 0; idim < ndim; ++idim)
expdiag[idim*ndim+idim] = cexp(-I * eig[idim] * tau);
lapack_zgemm(ndim, ndim, ndim, 'N', 'C', 1.0, expdiag, zmat, 0.0, tmpmat);
lapack_zgemm(ndim, ndim, ndim, 'N', 'N', 1.0, zmat, tmpmat, 0.0, expMat->addr);
freeup(tmpmat);
freeup(expdiag);
freeup(zmat);
freeup(eig);
freeup(mat);
}
/* check fracture criterion */
void Fracture_Check (DOM *dom)
{
short on = 0;
BODY *bod;
#if 0
for (bod = dom->bod; bod; bod = bod->next)
{
if (bod->flags & BODY_CHECK_FRACTURE)
{
double p [3], v [6], s [9], w [9];
MESH *msh = FEM_MESH (bod);
ELEMENT *ele;
int bulk;
VECTOR (p, 0.5, 0.5, 0.5);
for (ele = msh->surfeles, bulk = 0; ele; )
{
BULK_MATERIAL *mat = FEM_MATERIAL (bod, ele);
FEM_Element_Point_Values (bod, ele, p, VALUE_STRESS, v);
s [0] = v [0];
s [1] = v [3];
s [2] = v [4];
s [3] = s [1];
s [4] = v [1];
s [5] = v [5];
s [6] = s [2];
s [7] = s [5];
s [8] = v [2];
ASSERT (lapack_dsyev ('N', 'U', 3, s, 3, v, w, 9) == 0, ERR_LDY_EIGEN_DECOMP);
if (v [2] > mat->tensile) /* maximal eigenvalue larger than tensile strength */
{
bod->fracture = 1;
on = 1;
}
if (bulk) ele = ele->next;
else if (ele->next) ele = ele->next;
else ele = msh->bulkeles, bulk = 1;
}
}
}
#else
for (bod = dom->bod; bod; bod = bod->next)
{
if (bod->flags & BODY_CHECK_FRACTURE)
{
MESH *msh = FEM_MESH (bod);
ELEMENT *ele;
int bulk;
double body_energy = 0.0;
double frac_energy = 0.0;
for (ele = msh->surfeles, bulk = 0; ele; )
{
BULK_MATERIAL *mat = FEM_MATERIAL (bod, ele);
double volume;
body_energy += FEM_Element_Internal_Energy (bod, msh, ele, &volume);
frac_energy += mat->fracene * volume;
if (bulk) ele = ele->next;
else if (ele->next) ele = ele->next;
else ele = msh->bulkeles, bulk = 1;
}
// fracture condition
if (body_energy >= frac_energy)
{
bod->fracture = 1;
on = 1;
}
}
}
#endif
if (on) fracture_state_write (dom);
}
int main(int argc, char **argv){
printf("Computing dsyev...\n");
int n, lda;
double *A, *Acopy, *work, *w;
int info, lwork;
int i,j;
double t1,t2,elapsed;
struct timeval tp;
int rtn;
double normr, normb;
n = 100; lda = 100;
A = (double *)malloc(lda*n*sizeof(double)) ;
if (A==NULL){ printf("error of memory allocation\n"); exit(0); }
Acopy = (double *)malloc(lda*n*sizeof(double)) ;
if (Acopy==NULL){ printf("error of memory allocation\n"); exit(0); }
w=(double*)malloc(n*sizeof(double));
for(i=0;i<lda*n;i++)
A[i] = ((double) rand()) / ((double) RAND_MAX) - 0.5;
for(i=0;i<n;i++)
{
for(j=0;j<n;j++)
A[i+lda*j]=A[j+lda*i];
}
cblas_dcopy(lda*n,A,1,Acopy,1);
work=malloc(sizeof(double));
lwork = -1;
lapack_dsyev( lapack_compute_vectors, lapack_upper, n, A, lda, w, work, lwork, &info);
lwork=work[0];
free(work);
work=malloc(lwork*sizeof(double));
lapack_dsyev( lapack_compute_vectors, lapack_upper, n, A, lda, w, work, lwork, &info);
double *tmp;
tmp=(double*)malloc(n*lda*sizeof(double));
for(i=0;i<lda*n;i++)
tmp[i]=0;
for(i=0;i<n;i++)
tmp[i+lda*i]=1.0e0;
cblas_dgemm ( CblasColMajor, CblasNoTrans, CblasTrans, n, n, n, 1.0e0, A, lda, A, lda, -1.0e0, tmp, lda);
double ortho = 0.0e0;
double* v;
v=malloc(n*sizeof(double));
double* x;
x=malloc(n*sizeof(double));
int* isgn;
isgn=malloc(n*sizeof(int));
double est;
int kase;
double *work_dlange;
work_dlange=malloc(n*sizeof(double));
ortho = lapack_dlange( lapack_one_norm, n, n, tmp, lda, work_dlange);
free(work_dlange);
printf("Orthogonality error : %e\n",ortho);
for(i=0;i<lda*n;i++)
tmp[i]=0;
for(i=0;i<n;i++)
tmp[i+lda*i]=w[i];
double *tmp2;
tmp2=(double*)malloc(n*lda*sizeof(double));
cblas_dgemm ( CblasColMajor, CblasNoTrans, CblasNoTrans, n, n, n, 1.0e0, A, lda, tmp, lda, 0.0e0, tmp2, lda);
for(i=0;i<lda*n;i++)
tmp[i]=Acopy[i];
cblas_dgemm ( CblasColMajor, CblasNoTrans, CblasTrans, n, n, n, -1.0e0, tmp2, lda, A, lda, 1.0e0, tmp, lda);
double normA;
work_dlange=malloc(n*sizeof(double));
normA = lapack_dlange( lapack_one_norm, n, n, A, lda, work_dlange);
free(work_dlange);
double repr = 0.0e0;
work_dlange=malloc(n*sizeof(double));
repr = lapack_dlange( lapack_one_norm, n, n, tmp, lda, work_dlange);
free(work_dlange);
printf("Reprentativity error : %e\n",repr);
free(A);
free(Acopy);
free(work);
free(tmp);
free(tmp2);
printf("*******************************************************\n");
printf("Computing zheev...\n");
n = 300; lda = 300;
A = (double *)malloc(2*lda*n*sizeof(double)) ;
if (A==NULL){ printf("error of memory allocation\n"); exit(0); }
Acopy = (double *)malloc(2*lda*n*sizeof(double)) ;
if (Acopy==NULL){ printf("error of memory allocation\n"); exit(0); }
w=(double*)malloc(n*sizeof(double));
for(i=0;i<2*lda*n;i++)
A[i] = ((double) rand()) / ((double) RAND_MAX) - 0.5;
for (i=0;i<n;i++)
for (j=0;j<n;j++)
{
A[2*(i+lda*j)+1] = -A[2*(j+lda*i)+1];
A[2*(i+lda*j)] = A[2*(j+lda*i)];
}
for (i=0;i<n;i++)
A[2*(i+lda*i)+1]=0;
cblas_zcopy(lda*n,A,1,Acopy,1);
double *rwork;
rwork=malloc((3*n-2)*sizeof(double));
work=malloc(2*sizeof(double));
lwork = -1;
lapack_zheev( lapack_compute_vectors, lapack_upper, n, A, lda, w, work, lwork, rwork, &info);
lwork=work[0];
free(work);
work=malloc(2*lwork*sizeof(double));
lapack_zheev( lapack_compute_vectors, lapack_upper, n, A, lda, w, work, lwork, rwork, &info);
tmp=(double*)malloc(2*n*lda*sizeof(double));
double alpha[2];
double beta[2];
tmp2=(double*)malloc(2*n*lda*sizeof(double));
alpha[0]=1.0e0;
alpha[1]=0.0e0;
beta[0]=-1.0e0;
beta[1]=0.0e0;
for (i=0;i<2*n*lda;i++)
tmp[i]=0;
for (i=0;i<n;i++)
tmp[2*(i+lda*i)]=1;
cblas_zgemm ( CblasColMajor, CblasNoTrans, CblasConjTrans, n, n, n, alpha, A, lda, A, lda, beta, tmp, lda);
ortho=cblas_dnrm2(2*n*n,tmp,1);
printf("Orthogonality error : %e\n",ortho);
for (i=0;i<n;i++)
{
for (j=0;j<n;j++)
{
tmp[2*(i+lda*j)]=A[2*(i+lda*j)]*w[j];
tmp[2*(i+lda*j)+1]=A[2*(i+lda*j)+1]*w[j];
}
}
cblas_zcopy(lda*n,Acopy,1,tmp2,1);
cblas_zgemm ( CblasColMajor, CblasNoTrans, CblasConjTrans, n, n, n, alpha, tmp, lda, A, lda, beta, tmp2, lda);
repr=cblas_dnrm2(2*n*n,tmp2,1);
printf("Reprentativity error : %e\n",repr);
free(A);
free(Acopy);
free(work);
free(tmp);
free(tmp2);
exit(0);
}
/* update ellipsoid according to the given motion */
void ELLIP_Update (ELLIP *eli, void *body, void *shp, MOTION motion)
{
SGP sgp = {shp, eli, GOBJ_ELLIP, NULL};
double *ref = eli->ref_center,
(*ref_pnt) [3] = eli->ref_point,
*cur = eli->cur_center,
(*cur_pnt) [3] = eli->cur_point;
if (motion)
{
motion (body, &sgp, ref, cur);
motion (body, &sgp, ref_pnt [0], cur_pnt [0]);
motion (body, &sgp, ref_pnt [1], cur_pnt [1]);
motion (body, &sgp, ref_pnt [2], cur_pnt [2]);
BODY *bod = body;
switch (bod->kind)
{
case OBS:
case RIG:
{
double *R1 = bod->conf, *R0 = eli->ref_rot, *rot = eli->cur_rot;
NNMUL (R1, R0, rot);
}
break;
case PRB:
{
double *F = bod->conf, *sca0 = eli->ref_sca, *rot0 = eli->ref_rot, *sca1 = eli->cur_sca, *rot1 = eli->cur_rot;
double U[9] = {1.0/(sca0[0]*sca0[0]), 0.0, 0.0, 0.0, 1.0/(sca0[1]*sca0[1]), 0.0, 0.0, 0.0, 1.0/(sca0[2]*sca0[2])};
double A0[9], iF[9], det, X[3], Y[9], A[9];
NTMUL (U, rot0, Y);
NNMUL (rot0, Y, A0);
TNCOPY (F, Y); /* T --> since deformation gradient is stored row-wise */
INVERT (Y, iF, det);
ASSERT_TEXT (det > 0.0, "det(F) <= 0.0 during ellipsoid update");
NNMUL (A0, iF, Y);
TNMUL (iF, Y, A);
ASSERT_TEXT (lapack_dsyev ('V', 'U', 3, A, 3, X, Y, 9) == 0, "Eigen decomposition failed during ellipsoid update");
if (DET(A) < 0.0) /* det(A) is 1.0 or -1.0 */
{
SCALE9 (A, -1.0); /* keep positive space orientation */
}
NNCOPY (A, rot1);
sca1[0] = 1.0/sqrt(X[0]);
sca1[1] = 1.0/sqrt(X[1]);
sca1[2] = 1.0/sqrt(X[2]);
}
break;
default:
{
ASSERT_TEXT (0, "Invalid body kind during ellipsoid update");
}
break;
}
}
else
{
COPY (ref, cur);
COPY (ref_pnt [0], cur_pnt [0]);
COPY (ref_pnt [1], cur_pnt [1]);
COPY (ref_pnt [2], cur_pnt [2]);
sca_rot (eli->ref_center, eli->ref_point, eli->ref_sca, eli->ref_rot);
COPY (eli->ref_sca, eli->cur_sca);
NNCOPY (eli->ref_rot, eli->cur_rot);
}
}
