void reallo_ppl_memory(int *this_size)
{
/* local variable declaration */
int current_size;
/* allocate or reallocate PLOT+ memory buffer */
FORTRAN(get_ppl_memory_size)(¤t_size);
/* free the currently allocated memory */
if (current_size != 0)
free ( (void *) ppl_memory );
/* allocate new ammount of memory */
ppl_memory = (float *) malloc(sizeof(float) * *this_size );
/* Check that the memory was allocated OK*/
if ( ppl_memory == (float *)0 ) {
printf("Unable to allocate the requested %d words of PLOT memory.\n",*this_size);
exit(0);
}
/* save the size of what was allocated */
FORTRAN(save_ppl_memory_size) (this_size);
return;
}
void FORTRAN(egradf)(const double* x, double* gradf)
{
#ifndef MPI
if (sigterminate)
longjmp(env, 1);
#endif
copyxtopara(x, Min.q);
Min.P->ParatoSlaterDet(Min.q, Min.Q);
// nail to center-of-mass
moveboostSlaterDet(Min.Q, Work.X);
double eintr, eproj;
calcgradprojectedHamiltonian(Min.Q,
Min.Int,
Min.j, Min.par, Min.ival,
Min.angpara, Min.cmpara,
&eintr, &eproj);
// add gradient from intrinsic energy
calcSlaterDetAux(Min.Q, Work.X);
calcgradSlaterDetAux(Min.Q, Work.X, Work.dX);
calcgradHamiltonian(Min.Int, Min.Q, Work.X, Work.dX, Work.dH);
addmulttogradSlaterDet(Work.dhproj, Work.dH, Min.alpha);
Min.P->ParaprojectgradSlaterDet(Min.q, Work.dhproj, gradf);
FORTRAN(o8cnt).icgf++;
fprintf(stderr, "grad %3d: \tE = %8.3f MeV, Eproj = %8.3f MeV, Eintr = %8.3f MeV\n",
FORTRAN(o8cnt).icgf, hbc*(eproj+Min.alpha*eintr), hbc*eproj, hbc*eintr);
if (Min.log && !(FORTRAN(o8cnt).icgf % Min.log)) {
char logfname[255];
sprintf(logfname, "%s.minvapp.%03d.log", Min.logfile, FORTRAN(o8cnt).icgf);
FILE* logfp;
if (!(logfp = fopen(logfname, "w"))) {
fprintf(stderr, "couldn't open %s for writing\n", logfname);
} else {
fprintinfo(logfp);
fprintf(logfp, "# step %3d: \tE = %8.3f MeV, Eproj = %8.3f MeV, Eintr = %8.3f MeV\n",
FORTRAN(o8cnt).icgf, hbc*(eproj+Min.alpha*eintr), hbc*eproj, hbc*eintr);
fprintf(logfp, "\n# Parameterization\n");
fprintf(logfp, "<Parameterization %s>\n", Min.P->name);
Min.P->Parawrite(logfp, Min.q);
fprintf(logfp, "\n# SlaterDet\n");
writeSlaterDet(logfp, Min.Q);
fclose(logfp);
}
}
}
const vector operator*(const matrix& arg1, const vector& arg2)
{
// matrix vector product
vector prod(arg1.Rows);
int Rows=arg1.Rows;
int Sz=arg2.Sz;
#ifdef BLAS
char trans = 'N';
int m=arg1.Rows;
int n=arg1.Columns;
double alpha=1.;
double beta=0.;
int lda=arg1.Rows;
int incx=1;
int incy=1;
FORTRAN(dgemv)(&trans,&m,&n,&alpha,arg1.TheMatrix,&lda,
arg2.TheVector,&incx,&beta,prod.TheVector,&incy);
return prod;
#endif
for (int i=0;i<Rows;i++) {
prod.TheVector[i]=0.;
for (int k=0;k<arg1.Columns;k++)
prod.TheVector[i]+=arg1.TheMatrix[i+k*Rows]*arg2.TheVector[k];
}
return prod;
}
void pardiso_solve_as(double *b, int *neq) {
char *env;
int maxfct=1,mnum=1,mtype=11,phase=33,*perm=NULL,nrhs=1,
msglvl=0,i,error=0;
double *x=NULL;
printf(" Solving the system of equations using the asymmetric pardiso solver\n");
iparmas[0]=0;
env=getenv("OMP_NUM_THREADS");
if(env) {
iparmas[2]=atoi(env);
}
else {
iparmas[2]=1;
}
printf(" number of threads =% d\n\n",iparmas[2]);
x=NNEW(double,*neq);
FORTRAN(pardiso,(ptas,&maxfct,&mnum,&mtype,&phase,neq,aupardisoas,
pointersas,irowpardisoas,perm,&nrhs,iparmas,&msglvl,
b,x,&error));
for(i=0; i<*neq; i++) {
b[i]=x[i];
}
free(x);
return;
}
const cmatrix operator*(const cmatrix& arg1, const cmatrix& arg2)
{
// cmatrix product
cmatrix prod(arg1.Rows,arg2.Columns);
int Rows=arg1.Rows;
int Columns=arg2.Columns;
#ifdef BLAS
char transa = 'N';
char transb = 'N';
int m=arg1.Rows;
int n=arg2.Columns;
int k=arg1.Columns;
complex alpha=complex(1.,0.);
complex beta=complex(0.,0.);
int lda=arg1.Rows;
int ldb=arg2.Rows;
int ldc=prod.Rows;
FORTRAN(zgemm)(&transa,&transb,&m,&n,&k,&alpha,arg1.TheMatrix,&lda,
arg2.TheMatrix,&ldb,&beta,prod.TheMatrix,&ldc);
return prod;
#endif
for (int i=0;i<Rows;i++) {
for (int j=0;j<Columns;j++) {
prod.TheMatrix[i+j*Rows]=complex(0.,0.);
for (int k=0;k<arg1.Columns;k++)
prod.TheMatrix[i+j*Rows]+=arg1.TheMatrix[i+k*Rows]
*arg2.TheMatrix[k+j*arg2.Rows];
}
}
if (!prod.TheMatrix) exit(1);
return prod;
}
void pardiso_solve_as(double *b, ITG *neq){
char *env;
ITG maxfct=1,mnum=1,mtype=11,phase=33,*perm=NULL,nrhs=1,
msglvl=0,i,error=0;
double *x=NULL;
printf(" Solving the system of equations using the asymmetric pardiso solver\n");
iparmas[0]=0;
/* pardiso_factor has been called befor, MKL_NUM_THREADS=nthread_mkl_as is set*/
printf(" number of threads =% d\n\n",nthread_mkl_as);
NNEW(x,double,*neq);
FORTRAN(pardiso,(ptas,&maxfct,&mnum,&mtype,&phase,neq,aupardisoas,
pointersas,irowpardisoas,perm,&nrhs,iparmas,&msglvl,
b,x,&error));
for(i=0;i<*neq;i++){b[i]=x[i];}
SFREE(x);
return;
}
const cvector operator*(const cmatrix& arg1, const cvector& arg2)
{
// cmatrix cvector product
cvector prod(arg1.Rows);
int Rows=arg1.Rows;
int Sz=arg2.Sz;
#ifdef BLAS
char trans = 'N';
int m=arg1.Rows;
int n=arg1.Columns;
complex alpha=complex(1.,0.);
complex beta=complex(0.,0.);
int lda=arg1.Rows;
int incx=1;
int incy=1;
FORTRAN(zgemv)(&trans,&m,&n,&alpha,arg1.TheMatrix,&lda,
arg2.TheVector,&incx,&beta,prod.TheVector,&incy);
return prod;
#else
for (int i=0;i<Rows;i++) {
prod.TheVector[i]=complex(0.,0.);
for (int k=0;k<arg1.Columns;k++)
prod.TheVector[i]+=arg1.TheMatrix[i+k*Rows]*arg2.TheVector[k];
}
if (!prod.TheVector) exit(1);
return prod;
#endif
}
void FORTRAN(ef)(const double* x, double* fx)
{
#ifndef MPI
if (sigterminate)
longjmp(env, 1);
#endif
copyxtopara(x, Min.q);
Min.P->ParatoSlaterDet(Min.q, Min.Q);
// nail to center-of-mass
moveboostSlaterDet(Min.Q, Work.X);
double eintr, eproj;
calcprojectedHamiltonian(Min.Q,
Min.Int,
Min.j, Min.par, Min.ival,
Min.angpara, Min.cmpara,
&eintr, &eproj);
*fx = (eproj+Min.alpha*eintr);
FORTRAN(o8cnt).icf++;
fprintf(stderr, "\tme E = % 8.3f MeV, Eproj = %8.3f MeV, Eintr = %8.3f MeV,\n",
hbc*(*fx), hbc*eproj, hbc*eintr);
}
const matrix operator*(const matrix& arg1, const matrix& arg2)
{
// matrix product
matrix prod(arg1.Rows,arg2.Columns);
int Rows=arg1.Rows;
int Columns=arg2.Columns;
#ifdef BLAS
char transa = 'N';
char transb = 'N';
int m=arg1.Rows;
int n=arg2.Columns;
int k=arg1.Columns;
double alpha=1.;
double beta=0.;
int lda=arg1.Rows;
int ldb=arg2.Rows;
int ldc=prod.Rows;
FORTRAN(dgemm)(&transa,&transb,&m,&n,&k,&alpha,arg1.TheMatrix,&lda,
arg2.TheMatrix,&ldb,&beta,prod.TheMatrix,&ldc);
return prod;
#else
for (int i=0;i<Rows;i++) {
for (int j=0;j<Columns;j++) {
prod.TheMatrix[i+j*Rows]=0.;
for (int k=0;k<arg1.Columns;k++)
prod.TheMatrix[i+j*Rows]+=arg1.TheMatrix[i+k*Rows]
*arg2.TheMatrix[k+j*arg2.Rows];
}
}
if (!prod.TheMatrix) exit(1);
return prod;
#endif
}
void FORTRAN(ef)(const double* x, double* fx)
{
complex double hd, hp, nd, np;
if (sigterminate)
longjmp(env, 1);
copyxtopara(x, Min.q);
Min.P->ParatoSlaterDet(Min.q, Min.Q);
calcSlaterDetAuxod(Min.Q, Min.Q, Min.X);
nd = Min.X->ovlap;
#ifdef MPI
calcHamiltonianodmpi(Min.Int, Min.Q, Min.Q, Min.X, &hd);
#else
calcHamiltonianod(Min.Int, Min.Q, Min.Q, Min.X, &hd);
#endif
copySlaterDet(Min.Q, Min.Qp);
invertSlaterDet(Min.Qp);
calcSlaterDetAuxod(Min.Q, Min.Qp, Min.X);
np = Min.X->ovlap;
#ifdef MPI
calcHamiltonianodmpi(Min.Int, Min.Q, Min.Qp, Min.X, &hp);
#else
calcHamiltonianod(Min.Int, Min.Q, Min.Qp, Min.X, &hp);
#endif
*fx = (hd+Min.par*hp)/(nd+Min.par*np);
FORTRAN(o8cnt).icf++;
}
void FORTRAN(egradf)(const double* x, double* gradf)
{
complex double hd, hp, nd, np;
complex double H, N;
if (sigterminate)
longjmp(env, 1);
copyxtopara(x, Min.q);
Min.P->ParatoSlaterDet(Min.q, Min.Q);
calcSlaterDetAuxod(Min.Q, Min.Q, Min.X);
calcgradSlaterDetAuxod(Min.Q, Min.Q, Min.X, Min.dX);
calcgradOvlapod(Min.Q, Min.Q, Min.X, Min.dX, Min.dNd);
#ifdef MPI
calcgradHamiltonianodmpi(Min.Int, Min.Q, Min.Q, Min.X, Min.dX, Min.dHd);
#else
calcgradHamiltonianod(Min.Int, Min.Q, Min.Q, Min.X, Min.dX, Min.dHd);
#endif
hd = Min.dHd->val;
nd = Min.X->ovlap;
copySlaterDet(Min.Q, Min.Qp);
invertSlaterDet(Min.Qp);
calcSlaterDetAuxod(Min.Q, Min.Qp, Min.X);
calcgradSlaterDetAuxod(Min.Q, Min.Qp, Min.X, Min.dX);
calcgradOvlapod(Min.Q, Min.Qp, Min.X, Min.dX, Min.dNp);
#ifdef MPI
calcgradHamiltonianodmpi(Min.Int, Min.Q, Min.Qp, Min.X, Min.dX, Min.dHp);
#else
calcgradHamiltonianod(Min.Int, Min.Q, Min.Qp, Min.X, Min.dX, Min.dHp);
#endif
hp = Min.dHp->val;
np = Min.X->ovlap;
H = hd+Min.par*hp;
N = nd+Min.par*np;
zerogradSlaterDet(Min.dH);
addmulttogradSlaterDet(Min.dH, Min.dHd, 1.0/N);
addmulttogradSlaterDet(Min.dH, Min.dHp, Min.par* 1.0/N);
addmulttogradSlaterDet(Min.dH, Min.dNd, -H/(N*N));
addmulttogradSlaterDet(Min.dH, Min.dNp, -Min.par*H/(N*N));
Min.P->ParaprojectgradSlaterDet(Min.q, Min.dH, gradf);
FORTRAN(o8cnt).icgf++;
fprintf(stderr, "step %3d: \tE = %8.3f (%8.3f) MeV\n",
FORTRAN(o8cnt).icgf, hbc*creal(H/N), hbc*creal(hd/nd));
}
void MinimizeDONLP2vapp(const Interaction* Int,
int j, int par, int ival,
double threshkmix, double minnormkmix,
double alpha,
angintegrationpara* angpara,
cmintegrationpara* cmpara,
const Constraint* Const, int nconst,
Parameterization* P, Para* q,
int maxsteps, int log, const char* logfile)
{
#ifndef MPI
// handler for INT and TERM signals
signal(SIGINT, catchterminate);
signal(SIGTERM, catchterminate);
#endif
Min.maxsteps = maxsteps;
Min.log = log;
Min.logfile = logfile;
Min.Int = Int;
Min.j = j;
Min.par = par;
Min.ival = ival;
Min.threshkmix = threshkmix;
Min.minnormkmix = minnormkmix;
Min.alpha = alpha;
Min.angpara = angpara;
Min.cmpara = cmpara;
Min.Const = Const;
Min.nconst = nconst;
Min.q = q;
Min.P = P;
Min.Q = malloc(sizeof(SlaterDet));
P->ParainitSlaterDet(q, Min.Q);
#ifndef MPI
// regular program execution or catched signal ?
if (!setjmp(env))
#endif
FORTRAN(donlp2)();
fprintf(stderr, "donlp2 terminated because of criterium %d\n",
(int) FORTRAN(o8itin).optite + 11);
copyxtopara(FORTRAN(o8xdat).x, Min.q);
}
void FORTRAN(pplld_pts_envelope)(int *npts,int *plot_mem_used)
{
/* local variable declaration */
int pmemsize;
/*
Is the currently allocated size of PLOT+ memory sufficient?
If not, then allocate a larger array
Note need to check if the reallocation is successful.
*/
FORTRAN(get_ppl_memory_size)(&pmemsize);
if (*plot_mem_used > pmemsize) reallo_ppl_memory(plot_mem_used);
FORTRAN(pplld_pts) (npts, ppl_memory);
return;
}
void MinimizeDONLP2par(const Interaction* Int, int par,
const Constraintod* Const, int nconst,
Parameterization* P, Para* q,
int maxsteps)
{
// handler for INT and TERM signals
signal(SIGINT, catchterminate);
signal(SIGTERM, catchterminate);
Min.maxsteps = maxsteps;
Min.Int = Int;
Min.par = par;
Min.Const = Const;
Min.nconst = nconst;
Min.q = q;
Min.P = P;
Min.Q = (SlaterDet*) malloc(sizeof(SlaterDet));
Min.Qp = (SlaterDet*) malloc(sizeof(SlaterDet));
Min.X = (SlaterDetAux*) malloc(sizeof(SlaterDetAux));
Min.Xp = (SlaterDetAux*) malloc(sizeof(SlaterDetAux));
Min.dX = (gradSlaterDetAux*) malloc(sizeof(gradSlaterDetAux));
Min.dH = (gradSlaterDet*) malloc(sizeof(gradSlaterDet));
Min.dHd = (gradSlaterDet*) malloc(sizeof(gradSlaterDet));
Min.dHp = (gradSlaterDet*) malloc(sizeof(gradSlaterDet));
Min.dNd = (gradSlaterDet*) malloc(sizeof(gradSlaterDet));
Min.dNp = (gradSlaterDet*) malloc(sizeof(gradSlaterDet));
Min.P->ParainitSlaterDet(q, Min.Q);
Min.P->ParainitSlaterDet(q, Min.Qp);
initSlaterDetAux(Min.Q, Min.X);
initSlaterDetAux(Min.Q, Min.Xp);
initgradSlaterDetAux(Min.Q, Min.dX);
initgradSlaterDet(Min.Q, Min.dH);
initgradSlaterDet(Min.Q, Min.dHd);
initgradSlaterDet(Min.Q, Min.dHp);
initgradSlaterDet(Min.Q, Min.dNd);
initgradSlaterDet(Min.Q, Min.dNp);
// regular program execution or catched signal ?
if (!setjmp(env))
FORTRAN(donlp2)();
copyxtopara(FORTRAN(o8xdat).x, Min.q);
}
/*void FT(cvector &v,int flag)
{
// not efficient but safe. check structure of complex!
int N=v.Sz;
int i;
vector u(2*N);
for (i=0;i<N;i++) {
u(2*i)=real(v(i));
u(2*i+1)=imag(v(i));
}
FORTRAN(four1)(u.TheVector,&N,&flag);
for (i=0;i<N;i++) v(i)=complex(u(2*i),u(2*i+1));
return;
}*/
matrix HCSCE(matrix &a,matrix &B)
{
matrix A=a;
char UPLO='U';
int INFO=0;
int ITYPE=1;
int LDA=A.Rows;
int LDB=LDA;
int N=LDA;
FORTRAN(spotrf)(&UPLO,&N,B.TheMatrix,&LDA,&INFO);
cout<<INFO<<endl;
FORTRAN(ssygst)(&ITYPE,&UPLO,&N,A.TheMatrix,&LDA,B.TheMatrix,&LDB,&INFO);
cout<<INFO<<endl;
// fill the lower triangle
for (int i=0;i<N;i++)
for (int j=0;j<i;j++)
A(i,j)=A(j,i);
return A;
}
/*
* Set the requested size (in words) for a specific work array.
* Calls the 6D function with 1 for the length of the E and F axes.
*/
void FORTRAN(ef_set_work_array_lens)(int *id_ptr, int *iarray,
int *xlen, int *ylen, int *zlen, int *tlen)
{
int elen, flen;
elen = 1;
flen = 1;
FORTRAN(ef_set_work_array_lens_6d)(id_ptr, iarray,
xlen, ylen, zlen,
tlen, &elen, &flen);
}
matrix inverse(const matrix& a)
{
// for symmetric positive definite matrix
matrix inv=a;
char UPLO='U';
int INFO=0;
int N=a.Rows;
int LDA=N;
FORTRAN(dpotrf)(&UPLO,&N,inv.TheMatrix,&LDA,&INFO);
FORTRAN(dpotri)(&UPLO,&N,inv.TheMatrix,&LDA,&INFO);
if (INFO != 0) {
if (INFO < 0) {cerr<<"illegal value for argument "<<INFO;
cerr<<"in dpotri (inverse)"<<endl;}
if (INFO > 0) cerr<<"inverse could not be computed"<<endl;
}
// fill the lower triangle
for (int i=0;i<N;i++)
for (int j=0;j<i;j++)
inv(i,j)=inv(j,i);
return inv;
}
void *biotsavartmt(ITG *i){
ITG nka,nkb;
nka=nkapar[*i]+1;
nkb=nkepar[*i]+1;
FORTRAN(biotsavart,(ipkon1,kon1,lakon1,ne1,co1,qfx1,h01,mi1,&nka,
&nkb));
return NULL;
}
// implement plain ql
matrix ql(vector &D,vector &E)
{
int N=D.Sz;
char COMPZ='I';
matrix Z(N,N); for (int i=0;i<N;i++) Z(i,i)=1.;
int INFO=0;
int LDZ=N;
vector WORK(2*N-2);
FORTRAN(dsteqr)(&COMPZ,&N,D.TheVector,E.TheVector,Z.TheMatrix,&LDZ,
WORK.TheVector,&INFO);
return Z;
}
void calcSpatialOrientation(const SlaterDet* Q, const SlaterDetAux* X,
double* alpha, double* beta, double* gamma)
{
double T[3][3];
calcInertiaTensor(Q, X, T);
char JOBZ='V';
char UPLO='U';
int N=3;
double W[3];
double WORK[15];
int LWORK=15;
int INFO;
FORTRAN(dsyev)(&JOBZ, &UPLO, &N, (double*)T, &N, W, WORK, &LWORK, &INFO);
// align supposed symmetry axis with z axis
int i;
double maxe=0.0;
for (i=0; i<3; i++)
maxe = fmax(maxe, fabs(W[i]));
double dif[3], mindif = 1.0;
int imin=-1;
for (i=0; i<3; i++) {
dif[i] = fabs(W[(i+1)%3]-W[(i+2)%3])/maxe;
if (dif[i] < mindif) {
mindif = dif[i];
imin = i;
}
}
// align z-axis with symmetry axis
double dummy;
for (i=0; i<3; i++) {
dummy = T[2][i];
T[2][i] = T[imin][i];
T[imin][i] = dummy;
}
if (det(T) < 0.0)
for (i=0; i<3; i++)
T[0][i] *= -1;
RotationMatrixToEulerAngles(T, alpha, beta, gamma);
}
cmatrix inverse(const cmatrix &A)
{
int N=A.Rows;
int INFO=0;
int LDA=N;
int LDB=N;
int NRHS=N;
int* IPIV=new int[N];
cmatrix B(N,N);
cmatrix AP=A;
for (int i=0;i<N;i++) B(i,i)=complex(1.,0.);
FORTRAN(zgesv)(&N,&NRHS,AP.TheMatrix,&LDA,IPIV,B.TheMatrix,&LDB,&INFO);
return B;
}
vector hermdl(cmatrix& a)
{
char UPLO='U';
char JOBZ='V';
int INFO=0;
int N=a.Rows;
int LDA=N;
int LWORK=2*N;
cvector WORK(LWORK);
vector W(N);
vector RWORK(3*N);
FORTRAN(cheev)(&JOBZ,&UPLO,&N,a.TheMatrix,&LDA,W.TheVector,WORK.TheVector,
&LWORK,RWORK.TheVector,&INFO);
if (INFO != 0) cerr<<"diagonalization failed"<<endl;
return W;
}
void pardiso_cleanup_as(ITG *neq){
ITG maxfct=1,mnum=1,mtype=11,phase=-1,*perm=NULL,nrhs=1,
msglvl=0,error=0;
double *b=NULL,*x=NULL;
FORTRAN(pardiso,(ptas,&maxfct,&mnum,&mtype,&phase,neq,aupardisoas,
pointersas,irowpardisoas,perm,&nrhs,iparmas,&msglvl,
b,x,&error));
SFREE(irowpardisoas);
SFREE(aupardisoas);
SFREE(pointersas);
return;
}
vector diag(matrix& a)
// returns eigenvalues in a vector and transforms the matrix argument
// for symmetric matrices
{
int N=a.Rows;
char UPLO='U';
char JOBZ='V';
int INFO=0;
int LDA=N;
int LWORK=3*N;
vector WORK(LWORK);
vector W(N);
FORTRAN(dsyev)(&JOBZ,&UPLO,&N,a.TheMatrix,&LDA,W.TheVector,WORK.TheVector,
&LWORK,&INFO);
if (INFO != 0) cerr<<"diagonalization failed"<<endl;
return W;
}
void FORTRAN(pplldv_envelope)(int *K, float *Z, int *MX, int *MY, int *IMN,int *IMX,
int *JMN,int *JMX)
#endif
/*******************/
{
/* The global pointer to PLOT+ memory is declared as extern here
(Defined in fermain_c.c)
*/
extern float *ppl_memory;
FORTRAN(pplldv) (K,Z,MX,MY,IMN,IMX,JMN,JMX,ppl_memory);
return;
}
cvector zmatvec(const cmatrix& arg1, const cvector& arg2,complex scalar)
{
// cmatrix cvector product scaled by alpha
cvector prod(arg1.Rows);
int Rows=arg1.Rows;
int Sz=arg2.Sz;
char trans = 'N';
int m=arg1.Rows;
int n=arg1.Columns;
complex alpha=scalar;
complex beta=complex(0.,0.);
int lda=arg1.Rows;
int incx=1;
int incy=1;
FORTRAN(zgemv)(&trans,&m,&n,&alpha,arg1.TheMatrix,&lda,
arg2.TheVector,&incx,&beta,prod.TheVector,&incy);
return prod;
}
cvector diag(cmatrix& a,cmatrix &VL,cmatrix &VR)
// returns eigenvalues in a vector and transforms the matrix argument
{
int N=a.Rows;
char JOBVL='V';
char JOBVR='V';
int INFO=0;
int LDA=N;
int LDVL=N;
int LDVR=N;
int LWORK=2*N;
cvector WORK(LWORK);
cvector W(N);
vector RWORK(2*N);
FORTRAN(zgeev)(&JOBVL,&JOBVR,&N,a.TheMatrix,&LDA,W.TheVector,VL.TheMatrix,&LDVL,
VR.TheMatrix,&LDVR,WORK.TheVector,&LWORK,
RWORK.TheVector,&INFO);
if (INFO != 0) cerr<<"diagonalization failed"<<endl;
return W;
}
// construct identity matrix
vector diaggen(matrix& a)
{
int N=a.Rows;
char JOBVL='V';
char JOBVR='V';
int INFO=0;
int LDA=N;
vector WR(N);
vector WI(N);
int LDVL=N;
int LDVR=N;
matrix VL(LDVL,N);
matrix VR(LDVR,N);
int LWORK=4*N;
vector WORK(LWORK);
vector W(N);
FORTRAN(dgeev)(&JOBVL,&JOBVR,&N,a.TheMatrix,&LDA,WR.TheVector,
WI.TheVector,VL.TheMatrix,&LDVL,VR.TheMatrix,&LDVR,WORK.TheVector,
&LWORK,&INFO);
if (INFO != 0) cerr<<"diagonalization failed"<<endl;
return WR;
}
void calcresidual(ITG *nmethod, ITG *neq, double *b, double *fext, double *f,
ITG *iexpl, ITG *nactdof, double *aux1, double *aux2, double *vold,
double *vini, double *dtime, double *accold, ITG *nk, double *adb,
double *aub, ITG *jq, ITG *irow, ITG *nzl, double *alpha,
double *fextini, double *fini, ITG *islavnode, ITG *nslavnode,
ITG *mortar, ITG *ntie,double *f_cm,
double* f_cs, ITG *mi,ITG *nzs,ITG *nasym){
ITG j,k,mt=mi[1]+1;
double scal1;
/* residual for a static analysis */
if(*nmethod!=4){
for(k=0;k<neq[1];++k){
b[k]=fext[k]-f[k];
// printf("calcresidual dof=%" ITGFORMAT ",fext=%e,f=%e,resi=%e\n",k,fext[k],f[k],b[k]);
}
}
/* residual for implicit dynamics */
else if(*iexpl<=1){
for(k=0;k<*nk;++k){
if(nactdof[mt*k]!=0){
aux2[nactdof[mt*k]-1]=(vold[mt*k]-vini[mt*k])/(*dtime);}
for(j=1;j<mt;++j){
if(nactdof[mt*k+j]!=0){aux2[nactdof[mt*k+j]-1]=accold[mt*k+j];}
}
}
if(*nasym==0){
FORTRAN(op,(&neq[1],aux2,b,adb,aub,jq,irow));
}else{
FORTRAN(opas,(&neq[1],aux2,b,adb,aub,jq,irow,nzs));
}
scal1=1.+*alpha;
for(k=0;k<neq[0];++k){
b[k]=scal1*(fext[k]-f[k])-*alpha*(fextini[k]-fini[k])-b[k];
}
for(k=neq[0];k<neq[1];++k){
b[k]=fext[k]-f[k]-b[k];
}
}
/* residual for explicit dynamics */
else{
for(k=0;k<*nk;++k){
if(nactdof[mt*k]!=0){
aux2[nactdof[mt*k]-1]=(vold[mt*k]-vini[mt*k])/(*dtime);}
for(j=1;j<mt;++j){
if(nactdof[mt*k+j]!=0){aux2[nactdof[mt*k+j]-1]=accold[mt*k+j];}
}
}
scal1=1.+*alpha;
for(k=0;k<neq[0];++k){
b[k]=scal1*(fext[k]-f[k])-*alpha*(fextini[k]-fini[k])
-adb[k]*aux2[k];
}
for(k=neq[0];k<neq[1];++k){
b[k]=fext[k]-f[k]-adb[k]*aux2[k];
}
}
return;
}
void tiedcontact(ITG *ntie, char *tieset, ITG *nset, char *set,
ITG *istartset, ITG *iendset, ITG *ialset,
char *lakon, ITG *ipkon, ITG *kon,
double *tietol,
ITG *nmpc, ITG *mpcfree, ITG *memmpc_,
ITG **ipompcp, char **labmpcp, ITG **ikmpcp, ITG **ilmpcp,
double **fmpcp, ITG **nodempcp, double **coefmpcp,
ITG *ithermal, double *co, double *vold, ITG *cfd,
ITG *nmpc_, ITG *mi, ITG *nk,ITG *istep,ITG *ikboun,
ITG *nboun,char *kind1,char *kind2){
char *labmpc=NULL;
ITG *itietri=NULL,*koncont=NULL,nconf,i,k,*nx=NULL,im,
*ny=NULL,*nz=NULL,*ifaceslave=NULL,*istartfield=NULL,
*iendfield=NULL,*ifield=NULL,ntrimax,index,
ncont,ncone,*ipompc=NULL,*ikmpc=NULL,
*ilmpc=NULL,*nodempc=NULL,ismallsliding=0,neq,neqterms,
nmpctied,mortar=0,*ipe=NULL,*ime=NULL,*imastop=NULL,ifreeme;
double *xo=NULL,*yo=NULL,*zo=NULL,*x=NULL,*y=NULL,*z=NULL,
*cg=NULL,*straight=NULL,*fmpc=NULL,*coefmpc=NULL;
ipompc=*ipompcp;labmpc=*labmpcp;ikmpc=*ikmpcp;ilmpc=*ilmpcp;
fmpc=*fmpcp;nodempc=*nodempcp;coefmpc=*coefmpcp;
/* identifying the slave surfaces as nodal or facial surfaces */
NNEW(ifaceslave,ITG,*ntie);
FORTRAN(identifytiedface,(tieset,ntie,set,nset,ifaceslave,kind1));
/* determining the number of triangles of the triangulation
of the master surface and the number of entities on the
slave side */
FORTRAN(allocont,(&ncont,ntie,tieset,nset,set,istartset,iendset,
ialset,lakon,&ncone,tietol,&ismallsliding,kind1,
kind2,&mortar,istep));
if(ncont==0){
SFREE(ifaceslave);return;
}
/* allocation of space for the triangulation;
koncont(1..3,i): nodes belonging to triangle i
koncont(4,i): face label to which the triangle belongs =
10*element+side number */
NNEW(itietri,ITG,2**ntie);
NNEW(koncont,ITG,4*ncont);
/* triangulation of the master surface */
FORTRAN(triangucont,(&ncont,ntie,tieset,nset,set,istartset,iendset,
ialset,itietri,lakon,ipkon,kon,koncont,kind1,kind2,co,nk));
/* catalogueing the neighbors of the master triangles */
RENEW(ipe,ITG,*nk);
RENEW(ime,ITG,12*ncont);
DMEMSET(ipe,0,*nk,0.);
DMEMSET(ime,0,12*ncont,0.);
NNEW(imastop,ITG,3*ncont);
FORTRAN(trianeighbor,(ipe,ime,imastop,&ncont,koncont,
&ifreeme));
SFREE(ipe);SFREE(ime);
/* allocation of space for the center of gravity of the triangles
and the 4 describing planes */
NNEW(cg,double,3*ncont);
NNEW(straight,double,16*ncont);
FORTRAN(updatecont,(koncont,&ncont,co,vold,cg,straight,mi));
/* determining the nodes belonging to the slave face surfaces */
NNEW(istartfield,ITG,*ntie);
NNEW(iendfield,ITG,*ntie);
NNEW(ifield,ITG,8*ncone);
FORTRAN(nodestiedface,(tieset,ntie,ipkon,kon,lakon,set,istartset,
iendset,ialset,nset,ifaceslave,istartfield,iendfield,ifield,
&nconf,&ncone,kind1));
/* determining the maximum number of equations neq */
if(*cfd==1){
if(ithermal[1]<=1){
neq=4;
}else{
neq=5;
}
}else{
if(ithermal[1]<=1){
neq=3;
}else if(ithermal[1]==2){
neq=1;
}else{
neq=4;
}
}
neq*=(ncone+nconf);
/* reallocating the MPC fields for the new MPC's
ncone: number of MPC'S due to nodal slave surfaces
nconf: number of MPC's due to facal slave surfaces */
RENEW(ipompc,ITG,*nmpc_+neq);
RENEW(labmpc,char,20*(*nmpc_+neq)+1);
RENEW(ikmpc,ITG,*nmpc_+neq);
RENEW(ilmpc,ITG,*nmpc_+neq);
RENEW(fmpc,double,*nmpc_+neq);
/* determining the maximum number of terms;
expanding nodempc and coefmpc to accommodate
those terms */
neqterms=9*neq;
index=*memmpc_;
(*memmpc_)+=neqterms;
RENEW(nodempc,ITG,3**memmpc_);
RENEW(coefmpc,double,*memmpc_);
for(k=index;k<*memmpc_;k++){
nodempc[3*k-1]=k+1;
}
nodempc[3**memmpc_-1]=0;
/* determining the size of the auxiliary fields */
ntrimax=0;
for(i=0;i<*ntie;i++){
if(itietri[2*i+1]-itietri[2*i]+1>ntrimax)
ntrimax=itietri[2*i+1]-itietri[2*i]+1;
}
NNEW(xo,double,ntrimax);
NNEW(yo,double,ntrimax);
NNEW(zo,double,ntrimax);
NNEW(x,double,ntrimax);
NNEW(y,double,ntrimax);
NNEW(z,double,ntrimax);
NNEW(nx,ITG,ntrimax);
NNEW(ny,ITG,ntrimax);
NNEW(nz,ITG,ntrimax);
/* generating the tie MPC's */
FORTRAN(gentiedmpc,(tieset,ntie,itietri,ipkon,kon,
lakon,set,istartset,iendset,ialset,cg,straight,
koncont,co,xo,yo,zo,x,y,z,nx,ny,nz,nset,
ifaceslave,istartfield,iendfield,ifield,
ipompc,nodempc,coefmpc,nmpc,&nmpctied,mpcfree,ikmpc,ilmpc,
labmpc,ithermal,tietol,cfd,&ncont,imastop,ikboun,nboun,kind1));
(*nmpc_)+=nmpctied;
SFREE(xo);SFREE(yo);SFREE(zo);SFREE(x);SFREE(y);SFREE(z);SFREE(nx);
SFREE(ny);SFREE(nz);SFREE(imastop);
SFREE(ifaceslave);SFREE(istartfield);SFREE(iendfield);SFREE(ifield);
SFREE(itietri);SFREE(koncont);SFREE(cg);SFREE(straight);
/* reallocating the MPC fields */
/* RENEW(ipompc,ITG,nmpc_);
RENEW(labmpc,char,20*nmpc_+1);
RENEW(ikmpc,ITG,nmpc_);
RENEW(ilmpc,ITG,nmpc_);
RENEW(fmpc,double,nmpc_);*/
*ipompcp=ipompc;*labmpcp=labmpc;*ikmpcp=ikmpc;*ilmpcp=ilmpc;
*fmpcp=fmpc;*nodempcp=nodempc;*coefmpcp=coefmpc;
/* for(i=0;i<*nmpc;i++){
j=i+1;
FORTRAN(writempc,(ipompc,nodempc,coefmpc,labmpc,&j));
}*/
return;
}