コード例 #1
0
ファイル: reallo_ppl_memory.c プロジェクト: NOAA-PMEL/Ferret
void reallo_ppl_memory(int *this_size)
{
  
/* local variable declaration */
  int current_size;

/* allocate or reallocate PLOT+ memory buffer */

  FORTRAN(get_ppl_memory_size)(&current_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;
}
コード例 #2
0
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);
    }
  }  

}
コード例 #3
0
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;
}
コード例 #4
0
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;
}
コード例 #5
0
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;
}
コード例 #6
0
ファイル: pardiso_as.c プロジェクト: JuliaFEM/CalculiX-cmake
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;
}
コード例 #7
0
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
}
コード例 #8
0
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);

}
コード例 #9
0
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
}
コード例 #10
0
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++;
}
コード例 #11
0
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));
}
コード例 #12
0
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);
}
コード例 #13
0
ファイル: pplld_pts_envelope.c プロジェクト: NOAA-PMEL/Ferret
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;
}
コード例 #14
0
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);
}
コード例 #15
0
/*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;
}
コード例 #16
0
/*
 * 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);
}
コード例 #17
0
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;
}
コード例 #18
0
ファイル: biosav.c プロジェクト: JuliaFEM/CalculiX-cmake
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;
}
コード例 #19
0
// 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);
}
コード例 #21
0
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;
}
コード例 #22
0
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;
}
コード例 #23
0
ファイル: pardiso_as.c プロジェクト: JuliaFEM/CalculiX-cmake
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;
}
コード例 #24
0
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;
}
コード例 #25
0
ファイル: pplldv_envelope.c プロジェクト: NOAA-PMEL/Ferret
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;
}
コード例 #26
0
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;
}
コード例 #27
0
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;
}
コード例 #28
0
// 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; 
}
コード例 #29
0
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;
}
コード例 #30
0
ファイル: tiedcontact.c プロジェクト: JuliaFEM/CalculiX-cmake
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;
}