// - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
// Calculating Ds = D + S for the BDMCMC sampling algorithm
// - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
void get_Ds( double K[], double Z[], int R[], int not_continuous[], double D[], double Ds[], double S[], int *gcgm, int *n, int *p )
{
int dim = *p;
( *gcgm == 0 ) ? copula( Z, K, R, not_continuous, n, &dim ) : copula_NA( Z, K, R, not_continuous, n, &dim );
// S <- t(Z) %*% Z; NOTE, I'm using Ds instead of S, for saving memory
double alpha = 1.0, beta = 0.0;
char transA = 'T', transB = 'N';
F77_NAME(dgemm)( &transA, &transB, &dim, &dim, n, &alpha, Z, n, Z, n, &beta, &S[0], &dim );
#pragma omp parallel for
for( int i = 0; i < dim * dim; i++ )
Ds[ i ] = D[ i ] + S[ i ];
}
//version without cholesky decomp for non positive definite matrix A
double quadform2(double *x, double *A, int N, int incx, int LDA)
{
int i=0;
double dOne=1;
double dZero=0;
double sumSq=0;
double y[N];
int iOne=1;
F77_NAME(dgemv)("N", &N, &N, &dOne, A, &LDA, x, &incx, &dZero, y, &iOne);
for(i=0;i<N;i++){
sumSq += y[i]*x[i];
}
return(sumSq);
}
void logDeterminant(Matrix* A, double* logDeterminant)
{
int info;
double* matrixMemoryCopy = calloc(A->rows * A->columns, sizeof(double));
int* ipiv = calloc(A->rows, sizeof(int));
double sign = 1.0;
int i;
memcpy(matrixMemoryCopy, A->pointer, sizeof(double) * A->rows * A->columns);
F77_NAME(dgetrf)(&A->rows,
&A->rows,
matrixMemoryCopy,
&A->rows,
ipiv,
&info);
*logDeterminant = 0.0;
for(i = 0; i < A->rows; i++)
{
if(ipiv[i] != (i+1))
{
sign = -sign;
}
}
for(i = 0; i < A->rows; i++)
{
if(matrixMemoryCopy[i + i * A->rows] < 0)
{
*logDeterminant += log(-matrixMemoryCopy[i + i * A->rows]);
sign = -sign;
}
else
{
*logDeterminant += log(matrixMemoryCopy[i + i * A->rows]);
}
}
*logDeterminant *= sign;
free(ipiv);
free(matrixMemoryCopy);
}
void LapackInvAndDet(cDMatrix& theMatrix, cDMatrix& theInvMatrix, double& theDet)
{
uint myNCol = theMatrix.GetNCols() ;
double *myAP = new double[myNCol*(myNCol + 1)/2],
*myW = new double[myNCol],
*myZ = new double[myNCol*myNCol],
*myWork = new double[myNCol * 3] ;
int myInfo,
myN = (int)(myNCol),
myldz = (int)(myNCol) ;
for (register int i = 0 ; i < myN ; i++)
for (register int j = i ; j < myldz ; j++)
myAP[i+(j+1)*j/2] = theMatrix[i][j] ;
F77_NAME(dspev)("V", "U", &myN, myAP, myW, myZ, &myldz, myWork, &myInfo) ;
if (myInfo != 0)
throw cOTError("Non inversible matrix") ;
theDet = 1.0L ;
cDVector myInvEigenValue = cDVector(myNCol) ;
cDMatrix myEigenVector(myNCol, myNCol) ;
for (register uint i = 0 ; i < myNCol ; i++)
{ theDet *= myW[i] ;
myInvEigenValue[i] = 1.0 /myW[i] ;
for (register int j = 0 ; j < myN ; j++)
myEigenVector[i][j] = myZ[i + j*myN] ;
}
theInvMatrix = myEigenVector ;
cDMatrix myAuxMat1 = Diag(myInvEigenValue), myAuxMat2 = Transpose(myEigenVector) ;
cDMatrix myAuxMat = myAuxMat1 * myAuxMat2 ;
theInvMatrix = theInvMatrix * myAuxMat ;
delete myAP ;
delete myW ;
delete myZ ;
delete myWork ;
}
void lapack_dsteqr1(INTEGER N, double *D, double *E, double *W, double **ev)
{
int i,j;
char *COMPZ="I";
double *Z;
INTEGER LDZ;
double *WORK;
INTEGER INFO;
LDZ = N;
Z = (double*)malloc(sizeof(double)*LDZ*N);
WORK = (double*)malloc(sizeof(double)*2*N);
F77_NAME(dsteqr,DSTEQR)( COMPZ, &N, D, E, Z, &LDZ, WORK, &INFO );
/* store eigenvectors */
for (i=0; i<N; i++) {
for (j=0; j<N; j++) {
ev[i+1][j+1]= Z[i*N+j];
}
}
/* shift ko by 1 */
for (i=N; i>=1; i--){
W[i]= D[i-1];
}
if (INFO>0) {
printf("\n error in dstevx_, info=%d\n\n",INFO);fflush(stdout);
}
if (INFO<0) {
printf("info=%d in dstevx_\n",INFO);fflush(stdout);
MPI_Finalize();
exit(0);
}
free(Z);
free(WORK);
}
void symmetricRank1Update(Matrix* A, Vector* x, double alpha)
{
char uplo = 'U';
int one = 1;
int i, j;
F77_NAME(dsyr)(&uplo,
&A->rows,
&alpha,
x->pointer,
&one,
A->pointer,
&A->rows);
for(i = 0; i < A->rows; i++)
{
for(j = i; j < A->columns; j++)
{
A->pointer[j + i * A->rows] = A->pointer[i + j * A->rows];
}
}
}
int main (int argc, char* const* argv)
#endif
{
int opt = 0;
char *fName = NULL;
char *defaultName = "data";
opt = getopt(argc, argv, optString);
while ( opt != -1) {
switch (opt) {
case 'o': // The user wants to specify an output name.
fName = optarg;
//printf ("DEBUG : %s\n", optarg);
break;
case 'h' : case '?': // The help message is printed
default :
fprintf (stderr, "Usage : %s -o <output_name_without_.dat>\n", argv[0]);
return -1;
break;
}
opt = getopt ( argc, argv, optString ) ;
}
// If used did not specify the "-o" switch, use the default output name.
if (fName == NULL){
fName = defaultName;
}
int len = strlen(fName);
char *datName = (char*)malloc(len + 4); // "fName.dat + \0"
sprintf(datName, "%s.dat", fName);
printf ("Output is set as %s\n", fName);
F77_NAME(setup_main, SETUP_MAIN)(fName, datName);
}
void choleskyFactorization(Matrix* matrix, Matrix* result)
{
char uplo = 'U';
int info;
int i, j;
memcpy(result->pointer, matrix->pointer, sizeof(double) * matrix->rows * matrix->columns);
F77_NAME(dpotf2)(&uplo,
&result->rows,
result->pointer,
&result->rows,
&info);
//Not sure if it's necessary to zero the lower triangle but do it just in case
for(i = 0; i < result->rows; i++)
{
for(j = 0; j < result->columns; j++)
{
if(i > j) result->pointer[i + j * result->rows] = 0.0;
}
}
}
SEXP gmrfEdge(
SEXP LinvQab, // dense rectangular matrix
SEXP points, // SpatialPoints*
SEXP params
){
SEXP result, typePrecision; // dense symmetric
int Nrow, Ncol;
double one = 1.0;
Nrow=INTEGER(getAttrib(
LinvQab,
R_DimSymbol))[0];
Ncol=INTEGER(getAttrib(
LinvQab,
R_DimSymbol))[1];
PROTECT(typePrecision = NEW_CHARACTER(1));
SET_STRING_ELT(typePrecision, 0, mkChar("precision"));
PROTECT(result = maternPoints(
points,
params,
typePrecision));
// result = crossprod(LinvQab) + result
// blas DSYRK https://www.math.utah.edu/software/lapack/lapack-blas/dsyrk.html
F77_NAME(dsyrk)(
"L","T", &Ncol, &Nrow,
&one, REAL(LinvQab), &Nrow,
&one, REAL(GET_SLOT(result, install("x"))), &Ncol
);
UNPROTECT(2);
return result;
}
#include <R_ext/RS.h>
#include <stdlib.h> // for NULL
#include <R_ext/Rdynload.h>
/* FIXME:
Check these declarations against the C/Fortran source code.
*/
/* .Fortran calls */
extern void F77_NAME(front41)( int *imArg, int *ipcArg, int *iceptArg,
int *nnArg, int *ntArg, int *nobArg, int *nbArg, int *nmuArg, int *netaArg,
int *iprintArg, int *indicArg, double *tolArg, double *tol2Arg, double *bignumArg,
double *step1Arg, int *igrid2Arg, double *gridnoArg, int *maxitArg, double *bmuArg,
int *mrestartArg, double *frestartArg, int *nrestartArg,
int *nStartVal, double *startVal, int *nRowData, int *nColData, double *dataTable,
int *nParamTotal, double *ob, double *ga, double *gb,
double *startLogl, double *y, double *h, double *fmleLogl,
int *nIter, int *icodeArg, int *nfunctArg );
static const R_FortranMethodDef FortranEntries[] = {
{"front41", (DL_FUNC) &F77_NAME(front41), 38},
{NULL, NULL, 0}
};
void R_init_frontier(DllInfo *dll)
{
R_registerRoutines(dll, NULL, NULL, FortranEntries, NULL);
R_useDynamicSymbols(dll, FALSE);
R_forceSymbols(dll, TRUE);
}
void TRAN_Calc_CentGreenLesser_old(
/* input */
dcomplex w,
double ChemP_e[2],
int nc,
int Order_Lead_Side[2],
dcomplex *SigmaL,
dcomplex *SigmaL_Ad,
dcomplex *SigmaR,
dcomplex *SigmaR_Ad,
dcomplex *GC,
dcomplex *GC_Ad,
dcomplex *HCCk,
dcomplex *SCC,
/* work, nc*nc */
dcomplex *v1,
dcomplex *v2,
/* output */
dcomplex *Gless
)
#define GC_ref(i,j) GC[nc*((j)-1)+(i)-1]
#define GC_Ad_ref(i,j) GC_Ad[nc*((j)-1)+(i)-1]
#define SigmaL_ref(i,j) SigmaL[nc*((j)-1)+(i)-1]
#define SigmaL_Ad_ref(i,j) SigmaL_Ad[nc*((j)-1)+(i)-1]
#define SigmaR_ref(i,j) SigmaR[nc*((j)-1)+(i)-1]
#define SigmaR_Ad_ref(i,j) SigmaR_Ad[nc*((j)-1)+(i)-1]
#define SCC_ref(i,j) SCC[nc*((j)-1)+(i)-1]
#define HCCk_ref(i,j) HCCk[nc*((j)-1)+(i)-1]
#define v1_ref(i,j) v1[nc*((j)-1)+(i)-1]
#define v2_ref(i,j) v2[nc*((j)-1)+(i)-1]
#define Gless_ref(i,j) Gless[nc*((j)-1)+(i)-1]
{
int i,j;
int side;
dcomplex alpha,beta;
dcomplex ctmp;
alpha.r = 1.0;
alpha.i = 0.0;
beta.r = 0.0;
beta.i = 0.0;
/******************************************************
retarded Green's function of the left or right part
******************************************************/
/* v1 = 1/2z^* S - 1/2H - \sigama_{L or R}(z^*) */
if (Order_Lead_Side[1]==0){
for (i=1; i<=nc; i++) {
for (j=1; j<=nc; j++) {
v1_ref(i,j).r = 0.0*( 0.5*w.r*SCC_ref(i,j).r + 0.5*w.i*SCC_ref(i,j).i) - 0.5*HCCk_ref(i,j).r - SigmaL_Ad_ref(i,j).r;
v1_ref(i,j).i = 0.0*(-0.5*w.i*SCC_ref(i,j).r + 0.5*w.r*SCC_ref(i,j).i) - 0.5*HCCk_ref(i,j).i - SigmaL_Ad_ref(i,j).i;
}
}
}
else{
for (i=1; i<=nc; i++) {
for (j=1; j<=nc; j++) {
v1_ref(i,j).r = 0.0*( 0.5*w.r*SCC_ref(i,j).r + 0.5*w.i*SCC_ref(i,j).i) - 0.5*HCCk_ref(i,j).r - SigmaR_Ad_ref(i,j).r;
v1_ref(i,j).i = 0.0*(-0.5*w.i*SCC_ref(i,j).r + 0.5*w.r*SCC_ref(i,j).i) - 0.5*HCCk_ref(i,j).i - SigmaR_Ad_ref(i,j).i;
}
}
}
/* v2 = G(z) [1/2z^* S - 1/2 H - \sigama_{L or R}(z^*)] */
F77_NAME(zgemm,ZGEMM)("N","N", &nc, &nc, &nc, &alpha, GC, &nc, v1, &nc, &beta, v2, &nc);
/* Gless = G(z) [1/2z^* S - 1/2H - \sigama_{L or R}(z^*)] G(z^*) */
F77_NAME(zgemm,ZGEMM)("N","N", &nc, &nc, &nc, &alpha, v2, &nc, GC_Ad, &nc, &beta, Gless, &nc);
/******************************************************
advanced Green's function of the left or right part
******************************************************/
/* v1 = 1/2z S - 1/2 H - \sigama_{L or R}(z) */
if (Order_Lead_Side[1]==0){
for (i=1; i<=nc; i++) {
for (j=1; j<=nc; j++) {
v1_ref(i,j).r = 0.0*(0.5*w.r*SCC_ref(i,j).r - 0.5*w.i*SCC_ref(i,j).i) - 0.5*HCCk_ref(i,j).r - SigmaL_ref(i,j).r;
v1_ref(i,j).i = 0.0*(0.5*w.i*SCC_ref(i,j).r + 0.5*w.r*SCC_ref(i,j).i) - 0.5*HCCk_ref(i,j).i - SigmaL_ref(i,j).i;
}
}
}
else{
for (i=1; i<=nc; i++) {
for (j=1; j<=nc; j++) {
v1_ref(i,j).r = 0.0*(0.5*w.r*SCC_ref(i,j).r - 0.5*w.i*SCC_ref(i,j).i) - 0.5*HCCk_ref(i,j).r - SigmaR_ref(i,j).r;
v1_ref(i,j).i = 0.0*(0.5*w.i*SCC_ref(i,j).r + 0.5*w.r*SCC_ref(i,j).i) - 0.5*HCCk_ref(i,j).i - SigmaR_ref(i,j).i;
}
}
}
/* v2 = G(z) [1/2z S - 1/2 H - \sigama_{L or R}(z^*)] */
F77_NAME(zgemm,ZGEMM)("N","N", &nc, &nc, &nc, &alpha, GC, &nc, v1, &nc, &beta, v2, &nc);
/* v1 = G(z) [1/2z S - 1/2 H - \sigama_{L or R}(z)] G(z^*) */
F77_NAME(zgemm,ZGEMM)("N","N", &nc, &nc, &nc, &alpha, v2, &nc, GC_Ad, &nc, &beta, v1, &nc);
/******************************************************
-1/(i 2Pi) times
(retarded Green's function
minus
advanced Green's function of the left or right part)
******************************************************/
for (i=1; i<=nc; i++) {
for (j=1; j<=nc; j++) {
ctmp.r = (Gless_ref(i,j).r - v1_ref(i,j).r)/(2.0*PI);
ctmp.i = (Gless_ref(i,j).i - v1_ref(i,j).i)/(2.0*PI);
Gless_ref(i,j).r =-ctmp.i;
Gless_ref(i,j).i = ctmp.r;
}
}
}
void LESP(char *file)
{
static int i,j,k,ct_AN;
static double *EZ0;
static double *EZ;
static double **A,*A2;
static double x,y,z;
static double tdp,dpx,dpy,dpz;
static FILE *fp;
static char ctmp1[YOUSO10];
static INTEGER N, NRHS, LDA, *IPIV, LDB, INFO;
char fp_buf[fp_bsize]; /* setvbuf */
printf("Effective charge estimated by a local ESP method\n");
if ((fp = fopen(file,"r")) != NULL){
#ifdef xt3
setvbuf(fp,fp_buf,_IOFBF,fp_bsize); /* setvbuf */
#endif
/* atomnum */
fscanf(fp,"%d",&atomnum);
/* allocation of arrays */
EZ0 = (double*)malloc(sizeof(double)*(atomnum+10));
EZ = (double*)malloc(sizeof(double)*(atomnum+10));
A = (double**)malloc(sizeof(double*)*(atomnum+10));
for (i=0; i<(atomnum+10); i++){
A[i] = (double*)malloc(sizeof(double)*(atomnum+10));
}
A2 = (double*)malloc(sizeof(double)*(atomnum+10)*(atomnum+10));
/* read data */
for (i=0; i<atomnum; i++){
fscanf(fp,"%d %lf",&j,&EZ0[i]);
EZ[i] = EZ0[i];
}
/* set data */
for (i=1; i<(atomnum+10); i++){
for (j=1; j<(atomnum+10); j++){
A[i][j] = 0.0;
}
}
for (i=1; i<=atomnum; i++){
A[i][i] = 2.0;
A[i][atomnum+1] = 1.0;
A[atomnum+1][i] = 1.0;
}
/* A to A2 */
i = 0;
for (k=1; k<=(atomnum+1); k++){
for (j=1; j<=(atomnum+1); j++){
A2[i] = A[j][k];
i++;
}
}
/* solve A*EZ = EZ0 */
N = atomnum + 1;
NRHS = 1;
LDA = N;
LDB = N;
IPIV = (INTEGER*)malloc(sizeof(INTEGER)*N);
F77_NAME(dgesv,DGESV)(&N, &NRHS, A2, &LDA, IPIV, EZ, &LDB, &INFO);
if( INFO==0 ){
printf("Success\n" );
}
else{
printf("Failure: linear dependent\n" );
exit(0);
}
printf("\n");
printf(" without with charge conservation\n");
for(i=0; i<atomnum; i++){
printf(" Atom=%4d Local ESP Charge= %12.8f %12.8f\n",i+1,EZ0[i],EZ[i]);
}
fclose(fp);
printf("\n");
/* calculate dipole moment */
dpx = 0.0;
dpy = 0.0;
dpz = 0.0;
for (ct_AN=1; ct_AN<=atomnum; ct_AN++){
x = Gxyz[ct_AN][1];
y = Gxyz[ct_AN][2];
z = Gxyz[ct_AN][3];
dpx += AU2Debye*EZ[ct_AN-1]*x;
dpy += AU2Debye*EZ[ct_AN-1]*y;
dpz += AU2Debye*EZ[ct_AN-1]*z;
}
tdp = sqrt(dpx*dpx + dpy*dpy + dpz*dpz);
printf("\n");
printf(" Magnitude of dipole moment %15.10f (Debye)\n",tdp);
printf(" Component x y z %15.10f %15.10f %15.10f\n\n",dpx,dpy,dpz);
/* freeing of arrays */
free(IPIV);
free(EZ0);
free(EZ);
for (i=0; i<(atomnum+10); i++){
free(A[i]);
}
free(A);
free(A2);
}
else{
printf("Failure of reading LESP file.\n\n");
exit(0);
}
}
void calc_esp()
{
static int ct_AN,n1,n2,n3,po,spe;
static int i,j,k;
static int Rn1,Rn2,Rn3;
static int num_grid;
static double sum0,sum1,rij,rik;
static double cx,cy,cz;
static double bik,bij;
static double x,y,z;
static double dif,total_diff;
static double GridVol;
static double dx,dy,dz;
static double dpx,dpy,dpz,tdp;
static double tmp[4];
static double **A,*B;
static double *A2;
static INTEGER N, NRHS, LDA, *IPIV, LDB, INFO;
/* find the number of grids in the shell */
num_grid = 0;
for (n1=0; n1<Ngrid1; n1++){
for (n2=0; n2<Ngrid2; n2++){
for (n3=0; n3<Ngrid3; n3++){
if (grid_flag[n1][n2][n3]==1) num_grid++;
}
}
}
printf("Number of grids in a van der Waals shell = %2d\n",num_grid);
Cross_Product(gtv[2],gtv[3],tmp);
GridVol = fabs( Dot_Product(gtv[1],tmp) );
printf("Volume per grid = %15.10f (Bohr^3)\n",GridVol);
/* make a matrix A and a vector B */
A = (double**)malloc(sizeof(double*)*(atomnum+10));
for (i=0; i<(atomnum+10); i++){
A[i] = (double*)malloc(sizeof(double)*(atomnum+10));
for (j=0; j<(atomnum+10); j++) A[i][j] = 0.0;
}
A2 = (double*)malloc(sizeof(double)*(atomnum+10)*(atomnum+10));
B = (double*)malloc(sizeof(double)*(atomnum+10));
for (j=1; j<=atomnum; j++){
for (k=1; k<=atomnum; k++){
sum0 = 0.0;
sum1 = 0.0;
for (n1=0; n1<Ngrid1; n1++){
for (n2=0; n2<Ngrid2; n2++){
for (n3=0; n3<Ngrid3; n3++){
if (grid_flag[n1][n2][n3]==1){
x = X_grid[n1][n2][n3];
y = Y_grid[n1][n2][n3];
z = Z_grid[n1][n2][n3];
bij = 0.0;
bik = 0.0;
for (Rn1=-MaxRn1; Rn1<=MaxRn1; Rn1++){
for (Rn2=-MaxRn2; Rn2<=MaxRn2; Rn2++){
for (Rn3=-MaxRn3; Rn3<=MaxRn3; Rn3++){
cx = (double)Rn1*tv[1][1] + (double)Rn2*tv[2][1] + (double)Rn3*tv[3][1];
cy = (double)Rn1*tv[1][2] + (double)Rn2*tv[2][2] + (double)Rn3*tv[3][2];
cz = (double)Rn1*tv[1][3] + (double)Rn2*tv[2][3] + (double)Rn3*tv[3][3];
/* rij */
dx = x - (Gxyz[j][1] + cx);
dy = y - (Gxyz[j][2] + cy);
dz = z - (Gxyz[j][3] + cz);
rij = sqrt(dx*dx + dy*dy + dz*dz);
bij += 1.0/rij;
/* rik */
dx = x - (Gxyz[k][1] + cx);
dy = y - (Gxyz[k][2] + cy);
dz = z - (Gxyz[k][3] + cz);
rik = sqrt(dx*dx + dy*dy + dz*dz);
bik += 1.0/rik;
}
}
}
sum0 += bij*bik;
if (j==1){
/*
sum1 -= (VHart[n1][n2][n3] + VNA[n1][n2][n3])*bik;
*/
sum1 -= VHart[n1][n2][n3]*bik;
}
}
}
}
}
A[j][k] = sum0;
if (j==1) B[k-1] = sum1;
}
}
/* MK */
if (Modified_MK==0){
for (k=1; k<=atomnum; k++){
A[atomnum+1][k] = 1.0;
A[k][atomnum+1] = 1.0;
}
A[atomnum+1][atomnum+1] = 0.0;
B[atomnum] = 0.0;
/* A to A2 */
i = 0;
for (k=1; k<=(atomnum+1); k++){
for (j=1; j<=(atomnum+1); j++){
A2[i] = A[j][k];
i++;
}
}
/* solve Aq = B */
N = atomnum + 1;
NRHS = 1;
LDA = N;
LDB = N;
IPIV = (INTEGER*)malloc(sizeof(INTEGER)*N);
F77_NAME(dgesv,DGESV)(&N, &NRHS, A2, &LDA, IPIV, B, &LDB, &INFO);
if( INFO==0 ){
printf("Success\n" );
}
else{
printf("Failure: linear dependent\n" );
exit(0);
}
printf("\n");
for(i=0; i<atomnum; i++){
printf(" Atom=%4d Fitting Effective Charge=%15.11f\n",i+1,B[i]);
}
}
/* Modified MK */
else if (Modified_MK==1){
for (k=1; k<=atomnum; k++){
A[atomnum+1][k] = 1.0;
A[k][atomnum+1] = 1.0;
A[atomnum+2][k] = Gxyz[k][1];
A[atomnum+3][k] = Gxyz[k][2];
A[atomnum+4][k] = Gxyz[k][3];
A[k][atomnum+2] = Gxyz[k][1];
A[k][atomnum+3] = Gxyz[k][2];
A[k][atomnum+4] = Gxyz[k][3];
}
B[atomnum ] = 0.0;
B[atomnum+1] = Ref_DipMx/AU2Debye;
B[atomnum+2] = Ref_DipMy/AU2Debye;
B[atomnum+3] = Ref_DipMz/AU2Debye;
/* A to A2 */
i = 0;
for (k=1; k<=(atomnum+4); k++){
for (j=1; j<=(atomnum+4); j++){
A2[i] = A[j][k];
i++;
}
}
/* solve Aq = B */
N = atomnum + 4;
NRHS = 1;
LDA = N;
LDB = N;
IPIV = (INTEGER*)malloc(sizeof(INTEGER)*N);
F77_NAME(dgesv,DGESV)(&N, &NRHS, A2, &LDA, IPIV, B, &LDB, &INFO);
if( INFO==0 ){
printf("Success\n" );
}
else{
printf("Failure: linear dependent\n" );
exit(0);
}
printf("\n");
for(i=0; i<atomnum; i++){
printf(" Atom=%4d Fitting Effective Charge=%15.11f\n",i+1,B[i]);
}
}
dpx = 0.0;
dpy = 0.0;
dpz = 0.0;
for (ct_AN=1; ct_AN<=atomnum; ct_AN++){
x = Gxyz[ct_AN][1];
y = Gxyz[ct_AN][2];
z = Gxyz[ct_AN][3];
dpx += AU2Debye*B[ct_AN-1]*x;
dpy += AU2Debye*B[ct_AN-1]*y;
dpz += AU2Debye*B[ct_AN-1]*z;
}
tdp = sqrt(dpx*dpx + dpy*dpy + dpz*dpz);
printf("\n");
printf(" Magnitude of dipole moment %15.10f (Debye)\n",tdp);
printf(" Component x y z %15.10f %15.10f %15.10f\n",dpx,dpy,dpz);
/* calc diff */
total_diff = 0.0;
for (n1=0; n1<Ngrid1; n1++){
for (n2=0; n2<Ngrid2; n2++){
for (n3=0; n3<Ngrid3; n3++){
if (grid_flag[n1][n2][n3]==1){
x = X_grid[n1][n2][n3];
y = Y_grid[n1][n2][n3];
z = Z_grid[n1][n2][n3];
for (Rn1=-MaxRn1; Rn1<=MaxRn1; Rn1++){
for (Rn2=-MaxRn2; Rn2<=MaxRn2; Rn2++){
for (Rn3=-MaxRn3; Rn3<=MaxRn3; Rn3++){
cx = (double)Rn1*tv[1][1] + (double)Rn2*tv[2][1] + (double)Rn3*tv[3][1];
cy = (double)Rn1*tv[1][2] + (double)Rn2*tv[2][2] + (double)Rn3*tv[3][2];
cz = (double)Rn1*tv[1][3] + (double)Rn2*tv[2][3] + (double)Rn3*tv[3][3];
for (j=1; j<=atomnum; j++){
dx = x - (Gxyz[j][1] + cx);
dy = y - (Gxyz[j][2] + cy);
dz = z - (Gxyz[j][3] + cz);
rij = sqrt(dx*dx + dy*dy + dz*dz);
dif = -VHart[n1][n2][n3] + B[j-1]/rij;
total_diff += dif*dif;
}
}
}
}
}
}
}
}
total_diff = sqrt(total_diff)/(GridVol*num_grid);
printf("RMS between the given ESP and fitting charges (Hartree/Bohr^3)=%15.12f\n\n",
total_diff);
/* freeing of arrays */
for (i=0; i<(atomnum+10); i++){
free(A[i]);
}
free(A);
free(B);
free(A2);
free(IPIV);
}
/*
* calculate surface green function
*
* G00(w) = (w S00 - H00 - (H01-w S01)^-1 * T )^-1 ---(53)
*
*
* t_0 = (w S00-H00)^-1 (H01-w S01)^+
* bar_t_0 = (w S00-H00)^-1 (H01-w S01)
* T_0 = t_0
* bar_T_0 = bar_t_0
*
* * loop
*
* t_i = (1-t_(i-1) bar_t_(i-1) - bar_t_(i-1) t_(i-1) )^-1 (t_(i-1))^2
* bar_t_i = (1-t_(i-1) bar_t_(i-1) - bar_t_(i-1) t_(i-1) )^-1 (bar_t_(i-1))^2
*
* bar_T_i = bar_T_i bar_t_i
* T_i = T_(i-1) + bar_T_(i-1) t_i
*
* * loop_end
*
* G00 = (w S00-H00-H01 T_i)^-1
*
*
*/
void TRAN_Calc_SurfGreen_transfer(
/* input */
dcomplex w,
int n,
dcomplex *h00,
dcomplex *h01,
dcomplex *s00,
dcomplex *s01,
int iteration_max,
double eps,
dcomplex *G00 /* output */
)
#define h00_ref(i,j) h00[ n*((j)-1)+(i)-1 ]
#define h01_ref(i,j) h01[ n*((j)-1)+(i)-1 ]
#define s00_ref(i,j) s00[ n*((j)-1)+(i)-1 ]
#define s01_ref(i,j) s01[ n*((j)-1)+(i)-1 ]
#define gr00_ref(i,j) gr00[ n*((j)-1)+(i)-1 ]
#define H10_ref(i,j) H10[ n*((j)-1)+(i)-1 ]
#define H01_ref(i,j) H01[ n*((j)-1)+(i)-1 ]
#define G00_ref(i,j) G00[ n*((j)-1)+(i)-1 ]
#define G00_old_ref(i,j) G00_old[ n*((j)-1)+(i)-1 ]
#define t_i_ref(i,j) t_i[ n*((j)-1)+(i)-1 ]
#define bar_t_i_ref(i,j) bar_t_i[ n*((j)-1)+(i)-1 ]
#define T_i_ref(i,j) T_i[ n*((j)-1)+(i)-1 ]
#define T_i_old_ref(i,j) T_i_old[ n*((j)-1)+(i)-1 ]
#define bar_T_i_ref(i,j) bar_T_i[ n*((j)-1)+(i)-1 ]
#define tt1_ref(i,j) tt1[ n*((j)-1)+(i)-1 ]
#define tt2_ref(i,j) tt2[ n*((j)-1)+(i)-1 ]
#define tt3_ref(i,j) tt3[ n*((j)-1)+(i)-1 ]
{
static char *thisprogram="TRAN_Calc_SurfGreen_tranfermatrix";
int i,j,iter;
dcomplex a,b,cval;
double rms2,val;
dcomplex *gr00, *H10, *H01;
dcomplex *t_i, *bar_t_i, *bar_T_i, *T_i;
dcomplex *t_i_old, *bar_t_i_old, *bar_T_i_old, *T_i_old;
dcomplex *tt1, *tt2;
int n2,one;
n2 = n*n;
one=1;
/* printf("w=%le %le, n=%d, ite_max=%d eps=%le\n",w.r, w.i, n, iteration_max, eps); */
/* parameters for BLAS */
a.r=1.0; a.i=0.0;
b.r=0.0; b.i=0.0;
t_i = (dcomplex*)malloc(sizeof(dcomplex)*n2) ;
bar_t_i = (dcomplex*)malloc(sizeof(dcomplex)*n2) ;
T_i = (dcomplex*)malloc(sizeof(dcomplex)*n2) ;
bar_T_i = (dcomplex*)malloc(sizeof(dcomplex)*n2) ;
t_i_old = (dcomplex*)malloc(sizeof(dcomplex)*n2) ;
bar_t_i_old = (dcomplex*)malloc(sizeof(dcomplex)*n2) ;
T_i_old = (dcomplex*)malloc(sizeof(dcomplex)*n2) ;
bar_T_i_old = (dcomplex*)malloc(sizeof(dcomplex)*n2) ;
tt1 = (dcomplex*)malloc(sizeof(dcomplex)*n2) ;
tt2 = (dcomplex*)malloc(sizeof(dcomplex)*n2) ;
gr00 = (dcomplex*)malloc(sizeof(dcomplex)*n2) ;
H10 = (dcomplex*)malloc(sizeof(dcomplex)*n2) ;
H01 = (dcomplex*)malloc(sizeof(dcomplex)*n2) ;
/* gr02 = w*s00-h00 */
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
gr00_ref(i,j).r = w.r*s00_ref(i,j).r - w.i*s00_ref(i,j).i - h00_ref(i,j).r;
gr00_ref(i,j).i = w.i*s00_ref(i,j).r + w.r*s00_ref(i,j).i - h00_ref(i,j).i;
}
}
/* gr00^-1 */
Lapack_LU_Zinverse(n,gr00);
/* H01 = -w * s01 + h01 */
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
H01_ref(i,j).r = -w.r*s01_ref(i,j).r + w.i*s01_ref(i,j).i + h01_ref(i,j).r;
H01_ref(i,j).i = -w.i*s01_ref(i,j).r - w.r*s01_ref(i,j).i + h01_ref(i,j).i;
}
}
/* for (32) */
/* H10 = -w*s10 + h10 */
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
H10_ref(i,j).r = H01_ref(j,i).r;
H10_ref(i,j).i = H01_ref(j,i).i;
}
}
/* t_0 = gr00*H10 */
F77_NAME(zgemm,ZGEMM)("N","N",&n,&n,&n,&a,gr00,&n,H10, &n,&b, t_i,&n);
/* bar_t_0 = gr00*H01 */
F77_NAME(zgemm,ZGEMM)("N","N",&n,&n,&n,&a,gr00,&n,H01, &n,&b, bar_t_i,&n);
F77_NAME(zcopy,ZCOPY)(&n2, t_i,&one, t_i_old,&one);
F77_NAME(zcopy,ZCOPY)(&n2, bar_t_i,&one,bar_t_i_old,&one);
F77_NAME(zcopy,ZCOPY)(&n2, t_i,&one, T_i_old,&one); /* T_i = (50) */
F77_NAME(zcopy,ZCOPY)(&n2, t_i,&one, T_i,&one);
/* bar_T_(i) = bar_t_0 bar_t_1 ... bar_t_(i) */
F77_NAME(zcopy,ZCOPY)(&n2, bar_t_i,&one, bar_T_i_old,&one);
for (iter=1;iter<iteration_max; iter++) {
/* t_i_old * bar_t_i_old */
F77_NAME(zgemm,ZGEMM)("N","N",&n,&n,&n,&a,t_i_old,&n,bar_t_i_old, &n,&b, tt1,&n);
/* bar_t_i_old * t_i_old */
F77_NAME(zgemm,ZGEMM)("N","N",&n,&n,&n,&a,bar_t_i_old,&n,t_i_old, &n,&b, tt2,&n);
/* I - t_i-1 bar_t_i-1 - bar_t_i-1 t_i-1 */
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
tt1_ref(i,j).r = -tt1_ref(i,j).r - tt2_ref(i,j).r;
tt1_ref(i,j).i = -tt1_ref(i,j).i - tt2_ref(i,j).i;
}
}
for (i=1;i<=n;i++) {
j=i;
tt1_ref(i,j).r += 1.0;
}
/* tt1 = ( I - t_i-1 bar_t_i-1 - bar_t_i-1 t_i-1 )^-1 */
Lapack_LU_Zinverse(n,tt1);
/* tt2 = t_i-1 t_i-1 */
F77_NAME(zgemm,ZGEMM)("N","N",&n,&n,&n,&a,t_i_old,&n,t_i_old, &n,&b, tt2,&n);
F77_NAME(zgemm,ZGEMM)("N","N",&n,&n,&n,&a,tt1,&n,tt2, &n,&b, t_i,&n);
/* update t_i (40) */
/* for (41) */
/* tt2 = bar_t_i-1 bar_t_i-1 */
F77_NAME(zgemm,ZGEMM)("N","N",&n,&n,&n,&a,bar_t_i_old,&n,bar_t_i_old, &n,&b, tt2,&n);
/* bar_t_i = tt1 * tt2 */
F77_NAME(zgemm,ZGEMM)("N","N",&n,&n,&n,&a,tt1,&n,tt2, &n,&b, bar_t_i,&n);
/* update bar_t_i (41) */
/* update bar_T_i = bar_t_0 bar_t_1 bar_t_2 bar_t_3 ... bar_t_(i-i) */
/* bar_T_i = bar_T_(i-1) * bar_t_i */
F77_NAME(zgemm,ZGEMM)("N","N",&n,&n,&n,&a,bar_T_i_old,&n,bar_t_i, &n,&b, bar_T_i,&n);
/* T_i = t0+ bt0 t1 + bt0 bt1 t2 + ... */
/* T_i = T_(i-1) + bar_T_(i-1) t_i */
/* F77_NAME(zcopy,ZCOPY)(&n2,T_i_old,&one, T_i, &one);*/ /* needless */
b.r=1.0; b.i=0.0;
F77_NAME(zgemm,ZGEMM)("N","N",&n,&n,&n,&a,bar_T_i_old,&n,t_i, &n,&b, T_i,&n);
b.r=0.0; b.i=0.0;
/* updated T_i, (50) */
/* RMS = max [ T_i - T_(i-1) ] */
rms2 = 0.0;
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
cval.r = T_i_ref(i,j).r- T_i_old_ref(i,j).r;
cval.i = T_i_ref(i,j).i- T_i_old_ref(i,j).i;
val = cval.r*cval.r+ cval.i*cval.i;
rms2 = (rms2> val)? rms2: val;
}
}
/* printf("iter=%d rms2=%lf\n",iter,rms2); */
rms2 =sqrt(rms2);
if ( rms2 < eps ) {
goto last;
}
/* loop again */
F77_NAME(zcopy,ZCOPY)(&n2, t_i,&one, t_i_old,&one);
F77_NAME(zcopy,ZCOPY)(&n2, bar_t_i,&one, bar_t_i_old,&one);
F77_NAME(zcopy,ZCOPY)(&n2, T_i,&one, T_i_old,&one);
F77_NAME(zcopy,ZCOPY)(&n2, bar_T_i,&one, bar_T_i_old,&one);
}
last:
/* printf("iter=%d rms=%lf\n",iter,rms2); */
if (iter>=iteration_max) {
printf("ERROR: TRAN_Calc_SurfGreen_trans: iter=%d itermax=%d, rms=%le, eps=%le\n",
iter, iteration_max, rms2, eps);
}
/* (53) */
F77_NAME(zgemm,ZGEMM)("N","N",&n,&n,&n,&a,H01,&n,T_i, &n,&b, G00,&n);
/* (w S00 -H00 -H01 T_i) */
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
G00_ref(i,j).r = w.r*s00_ref(i,j).r - w.i*s00_ref(i,j).i - h00_ref(i,j).r - G00_ref(i,j).r;
G00_ref(i,j).i = w.i*s00_ref(i,j).r + w.r*s00_ref(i,j).i - h00_ref(i,j).i - G00_ref(i,j).i;
}
}
Lapack_LU_Zinverse(n,G00); /* (53) */
free(H01);
free(H10);
free(gr00);
free(tt2);
free(tt1);
free(T_i_old);
free(bar_T_i_old);
free(bar_t_i_old);
free(t_i_old);
free(bar_T_i);
free(T_i);
free(bar_t_i);
free(t_i);
}
void Eigen_lapack(double **a, double *ko, int n0)
{
/* input: n;
input: a[n][n]; matrix A
output: a[n][n]; eigevectors
output: ko[n]; eigenvalues */
static char *name="Eigen_lapack";
char *JOBZ="V";
char *RANGE="A";
char *UPLO="L";
INTEGER n=n0;
INTEGER LDA=n;
double VL,VU; /* dummy */
INTEGER IL,IU; /* dummy */
double ABSTOL=1.0e-10;
INTEGER M;
double *A,*Z;
INTEGER LDZ=n;
INTEGER LWORK;
double *WORK;
INTEGER *IWORK;
INTEGER *IFAIL, INFO;
INTEGER i,j;
A=(double*)malloc(sizeof(double)*n*n);
Z=(double*)malloc(sizeof(double)*n*n);
LWORK=n*8;
WORK=(double*)malloc(sizeof(double)*LWORK);
IWORK=(INTEGER*)malloc(sizeof(INTEGER)*n*5);
IFAIL=(INTEGER*)malloc(sizeof(INTEGER)*n);
for (i=0;i<n;i++) {
for (j=0;j<n;j++) {
A[i*n+j]= a[i+1][j+1];
}
}
#if 0
printf("A=\n");
for (i=0;i<n;i++) {
for (j=0;j<n;j++) {
printf("%f ",A[i*n+j]);
}
printf("\n");
}
fflush(stdout);
#endif
F77_NAME(dsyevx,DSYEVX)( JOBZ, RANGE, UPLO, &n, A, &LDA, &VL, &VU, &IL, &IU,
&ABSTOL, &M, ko, Z, &LDZ, WORK, &LWORK, IWORK,
IFAIL, &INFO );
/* store eigenvectors */
for (i=0;i<n;i++) {
for (j=0;j<n;j++) {
/* a[i+1][j+1]= Z[i*n+j]; */
a[j+1][i+1]= Z[i*n+j];
}
}
/* shift ko by 1 */
for (i=n;i>=1;i--){
ko[i]= ko[i-1];
}
if (INFO>0) {
printf("\n%s: error in dsyevx_, info=%d\n\n",name,INFO);
}
if (INFO<0) {
printf("%s: info=%d\n",name,INFO);
exit(10);
}
free(IFAIL); free(IWORK); free(WORK); free(Z); free(A);
}
void TRAN_Calc_SurfGreen_Normal(
/* input */
dcomplex w,
int n,
dcomplex *h00,
dcomplex *h01,
dcomplex *s00,
dcomplex *s01,
int iteration_max,
double eps,
dcomplex *gr /* output */
)
#define h00_ref(i,j) h00[ n*((j)-1)+(i)-1 ]
#define h01_ref(i,j) h01[ n*((j)-1)+(i)-1 ]
#define s00_ref(i,j) s00[ n*((j)-1)+(i)-1 ]
#define s01_ref(i,j) s01[ n*((j)-1)+(i)-1 ]
#define es0_ref(i,j) es0[ n*((j)-1)+(i)-1 ]
#define e00_ref(i,j) e00[ n*((j)-1)+(i)-1 ]
#define alp_ref(i,j) alp[ n*((j)-1)+(i)-1 ]
#define bet_ref(i,j) bet[ n*((j)-1)+(i)-1 ]
#define gr_ref(i,j) gr[ n*((j)-1)+(i)-1 ]
#define gr00_ref(i,j) gr00[ n*((j)-1)+(i)-1 ]
#define gr01_ref(i,j) gr01[ n*((j)-1)+(i)-1 ]
#define gr02_ref(i,j) gr02[ n*((j)-1)+(i)-1 ]
#define gt_ref(i,j) gt[ n*((j)-1)+(i)-1 ]
{
static char *thisprogram="TRAN_Calc_SurfGreen_direct";
int i,j,iter;
dcomplex a,b;
double rms2,val;
dcomplex cval;
dcomplex *es0, *e00, *alp, *bet ;
dcomplex *gr00, *gr02, *gr01;
dcomplex *gt;
/* printf("w=%le %le, n=%d, ite_max=%d eps=%le\n",w.r, w.i, n, iteration_max, eps); */
a.r=1.0; a.i=0.0;
b.r=0.0; b.i=0.0;
es0 = (dcomplex*)malloc(sizeof(dcomplex)*n*n) ;
e00 = (dcomplex*)malloc(sizeof(dcomplex)*n*n) ;
alp = (dcomplex*)malloc(sizeof(dcomplex)*n*n) ;
bet = (dcomplex*)malloc(sizeof(dcomplex)*n*n) ;
gr00 = (dcomplex*)malloc(sizeof(dcomplex)*n*n) ;
gr01 = (dcomplex*)malloc(sizeof(dcomplex)*n*n) ;
gr02 = (dcomplex*)malloc(sizeof(dcomplex)*n*n) ;
gt = (dcomplex*)malloc(sizeof(dcomplex)*n*n) ;
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
es0_ref(i,j).r = w.r*s00_ref(i,j).r - w.i*s00_ref(i,j).i - h00_ref(i,j).r;
es0_ref(i,j).i = w.i*s00_ref(i,j).r + w.r*s00_ref(i,j).i - h00_ref(i,j).i;
}
}
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
e00_ref(i,j).r = w.r*s00_ref(i,j).r - w.i*s00_ref(i,j).i - h00_ref(i,j).r;
e00_ref(i,j).i = w.i*s00_ref(i,j).r + w.r*s00_ref(i,j).i - h00_ref(i,j).i;
}
}
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
alp_ref(i,j).r = -w.r*s01_ref(i,j).r + w.i*s01_ref(i,j).i + h01_ref(i,j).r;
alp_ref(i,j).i = -w.i*s01_ref(i,j).r - w.r*s01_ref(i,j).i + h01_ref(i,j).i;
}
}
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
/* taking account of the complex conjugate of H and S */
bet_ref(i,j).r = -w.r*s01_ref(j,i).r - w.i*s01_ref(j,i).i + h01_ref(j,i).r;
bet_ref(i,j).i = -w.i*s01_ref(j,i).r + w.r*s01_ref(j,i).i - h01_ref(j,i).i;
}
}
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
gr00_ref(i,j).r = es0_ref(i,j).r;
gr00_ref(i,j).i = es0_ref(i,j).i;
}
}
Lapack_LU_Zinverse(n,gr00);
/* save gr00 to calculate rms */
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
gt_ref(i,j).r = gr00_ref(i,j).r;
gt_ref(i,j).i = gr00_ref(i,j).i;
}
}
for( iter=1; iter<iteration_max; iter++) {
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
gr02_ref(i,j).r = e00_ref(i,j).r;
gr02_ref(i,j).i = e00_ref(i,j).i;
}
}
Lapack_LU_Zinverse(n,gr02);
F77_NAME(zgemm,ZGEMM)("N","N",&n,&n,&n,&a, gr02,&n,bet,&n,&b, gr01,&n);
F77_NAME(zgemm,ZGEMM)("N","N",&n,&n,&n,&a, alp,&n,gr01,&n,&b, gr00,&n);
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
es0_ref(i,j).r = es0_ref(i,j).r - gr00_ref(i,j).r;
es0_ref(i,j).i = es0_ref(i,j).i - gr00_ref(i,j).i;
}
}
F77_NAME(zgemm,ZGEMM)("N","N",&n,&n,&n,&a, gr02,&n,alp,&n,&b, gr01,&n);
F77_NAME(zgemm,ZGEMM)("N","N",&n,&n,&n,&a, gr02,&n,bet,&n,&b, gr00,&n);
F77_NAME(zgemm,ZGEMM)("N","N",&n,&n,&n,&a, bet,&n,gr01,&n,&b, gr02,&n);
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
e00_ref(i,j).r=e00_ref(i,j).r-gr02_ref(i,j).r;
e00_ref(i,j).i=e00_ref(i,j).i-gr02_ref(i,j).i;
}
}
F77_NAME(zgemm,ZGEMM)("N","N",&n,&n,&n,&a, alp,&n,gr00,&n,&b, gr02,&n);
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
e00_ref(i,j).r = e00_ref(i,j).r - gr02_ref(i,j).r;
e00_ref(i,j).i = e00_ref(i,j).i - gr02_ref(i,j).i;
}
}
F77_NAME(zgemm,ZGEMM)("N","N",&n,&n,&n,&a, alp,&n,gr01,&n,&b, gr02,&n);
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
alp_ref(i,j).r=gr02_ref(i,j).r;
alp_ref(i,j).i=gr02_ref(i,j).i;
}
}
F77_NAME(zgemm,ZGEMM)("N","N",&n,&n,&n,&a, bet,&n,gr00,&n,&b, gr02,&n);
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
bet_ref(i,j).r = gr02_ref(i,j).r;
bet_ref(i,j).i = gr02_ref(i,j).i;
}
}
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
gr00_ref(i,j).r = es0_ref(i,j).r;
gr00_ref(i,j).i = es0_ref(i,j).i;
}
}
Lapack_LU_Zinverse(n,gr00);
/* calculate rms */
rms2=0.0;
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
cval.r = gt_ref(i,j).r - gr00_ref(i,j).r;
cval.i = gt_ref(i,j).i - gr00_ref(i,j).i;
val = cval.r*cval.r + cval.i*cval.i;
if ( rms2 < val ) { rms2 = val ; }
}
}
rms2 = sqrt(rms2);
/*debug*/
/*
printf("TRAN_Calc_SurfGreen: iter=%d itermax=%d, rms2=%le, eps=%le\n",
iter, iteration_max, rms2, eps);
*/
/*
printf("TRAN_Calc_SurfGreen: iter=%d itermax=%d, rms2=%15.12f, eps=%15.12f\n",
iter, iteration_max, rms2, eps);
*/
/*debug end*/
if ( rms2 < eps ) {
/* converged */
goto last;
}
else {
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
gt_ref(i,j).r = gr00_ref(i,j).r;
gt_ref(i,j).i = gr00_ref(i,j).i;
}
}
}
} /* iteration */
last:
if (iter>=iteration_max) {
printf("ERROR: TRAN_Calc_SurfGreen: iter=%d itermax=%d, rms2=%le, eps=%le\n",
iter, iteration_max, rms2, eps);
}
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
gr_ref(i,j).r = gr00_ref(i,j).r;
gr_ref(i,j).i = gr00_ref(i,j).i;
}
}
free(gt);
free(gr02);
free(gr01);
free(gr00);
free(bet);
free(alp);
free(e00);
free(es0);
}
#include <R.h>
#include <R_ext/Rdynload.h>
extern void F77_NAME(hbin )(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
extern void F77_NAME(herode)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
extern void F77_NAME(hsm )(void *, void *, void *, void *, void *, void *, void *);
static const R_FortranMethodDef FortranEntries[] = {
{"hbin", (DL_FUNC) &F77_NAME(hbin), 13},
{"herode", (DL_FUNC) &F77_NAME(herode), 10},
{"hsm", (DL_FUNC) &F77_NAME(hsm), 7},
{NULL, NULL, 0}
};
void R_init_myLib(DllInfo *info) {
R_registerRoutines(info, NULL, NULL, FortranEntries, NULL);
R_useDynamicSymbols(info, FALSE);
R_forceSymbols(info, TRUE);
}
extern void F77_NAME(jacklins)(void *, void *, void *, void *, void *);
extern void F77_NAME(largrec)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
extern void F77_NAME(maxempr)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
extern void F77_NAME(rcorr)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
/* extern void F77_NAME(wcidxy)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); */
extern void F77_NAME(wclosepw)(void *, void *, void *, void *, void *, void *, void *, void *);
extern void F77_NAME(wclosest)(void *, void *, void *, void *, void *);
static const R_CallMethodDef CallEntries[] = {
{"do_mchoice_match", (DL_FUNC) &do_mchoice_match, 3},
{"do_nstr", (DL_FUNC) &do_nstr, 2},
{NULL, NULL, 0}
};
static const R_FortranMethodDef FortranEntries[] = {
{"cidxcn", (DL_FUNC) &F77_NAME(cidxcn), 11},
{"cidxcp", (DL_FUNC) &F77_NAME(cidxcp), 17},
{"hoeffd", (DL_FUNC) &F77_NAME(hoeffd), 12},
{"jacklins", (DL_FUNC) &F77_NAME(jacklins), 5},
{"largrec", (DL_FUNC) &F77_NAME(largrec), 11},
{"maxempr", (DL_FUNC) &F77_NAME(maxempr), 10},
{"rcorr", (DL_FUNC) &F77_NAME(rcorr), 12},
/* {"wcidxy", (DL_FUNC) &F77_NAME(wcidxy), 11}, */
{"wclosepw", (DL_FUNC) &F77_NAME(wclosepw), 8},
{"wclosest", (DL_FUNC) &F77_NAME(wclosest), 5},
{NULL, NULL, 0}
};
void R_init_Hmisc(DllInfo *dll)
{
R_registerRoutines(dll, NULL, CallEntries, FortranEntries, NULL);
#include <R_ext/RS.h>
#include <stdlib.h> // for NULL
#include <R_ext/Rdynload.h>
/* .Fortran calls */
extern void F77_NAME(grow_forest_wrapper)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
extern void F77_NAME(grow_tree_wrapper)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
extern void F77_NAME(predict_forest_wrapper)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
extern void F77_NAME(predict_tree_wrapper)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
extern void F77_NAME(fortran_unit_tests_wrapper)(void *);
static const R_FortranMethodDef FortranEntries[] = {
{"grow_forest_wrapper", (DL_FUNC) &F77_NAME(grow_forest_wrapper), 21},
{"grow_tree_wrapper", (DL_FUNC) &F77_NAME(grow_tree_wrapper), 18},
{"predict_forest_wrapper", (DL_FUNC) &F77_NAME(predict_forest_wrapper), 16},
{"predict_tree_wrapper", (DL_FUNC) &F77_NAME(predict_tree_wrapper), 15},
{"fortran_unit_tests_wrapper", (DL_FUNC) &F77_NAME(fortran_unit_tests_wrapper), 1},
{NULL, NULL, 0}
};
void R_init_ParallelForest(DllInfo *dll)
{
R_registerRoutines(dll, NULL, NULL, FortranEntries, NULL);
R_useDynamicSymbols(dll, FALSE);
}
/* Note:
Generate this C code by running in R in the package folder
tools::package_native_routine_registration_skeleton(".")
*/
#include <stdlib.h> // for NULL
#include <R_ext/Rdynload.h>
/* FIXME:
Check these declarations against the C/Fortran source code.
*/
/* .Fortran calls */
extern void F77_NAME(bestmatches)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
extern void F77_NAME(computecost)(void *, void *, void *, void *, void *, void *, void *);
extern void F77_NAME(g)(void *, void *, void *, void *);
extern void F77_NAME(tracepath)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
static const R_FortranMethodDef FortranEntries[] = {
{"bestmatches", (DL_FUNC) &F77_NAME(bestmatches), 11},
{"computecost", (DL_FUNC) &F77_NAME(computecost), 7},
{"g", (DL_FUNC) &F77_NAME(g), 4},
{"tracepath", (DL_FUNC) &F77_NAME(tracepath), 11},
{NULL, NULL, 0}
};
void R_init_dtwSat(DllInfo *dll)
{
R_registerRoutines(dll, NULL, NULL, FortranEntries, NULL);
R_useDynamicSymbols(dll, FALSE);
R_forceSymbols(dll, FALSE);
}
// propclusttrial, propclustaccel, propensityclustering
propclusttrial_t[] = {SINGLESXP, INTSXP, REALSXP, REALSXP, REALSXP, REALSXP, INTSXP, INTSXP, INTSXP, INTSXP},
// propdecompaccel, propensitydecomposition
propdecompaccel_t[] = {SINGLESXP, INTSXP, REALSXP, REALSXP, REALSXP, REALSXP, INTSXP, INTSXP, INTSXP},
// singleclusterupdate
singleclusterupdate_t[] = {SINGLESXP, REALSXP, REALSXP, REALSXP, INTSXP, INTSXP};
static const R_CMethodDef R_CMethods[] = {
CDEF(minWhichMin, 5, minWhich_t),
{NULL, NULL, 0, NULL} };
static const R_FortranMethodDef R_FortranMethods[] = {
{"propclusttrial", (DL_FUNC) &F77_NAME(propclusttrial), 10, propclusttrial_t},
{"propclustaccel", (DL_FUNC) &F77_NAME(propclusttrial), 10, propclusttrial_t},
{"propensityclustering", (DL_FUNC) &F77_NAME(propclusttrial), 10, propclusttrial_t},
{"propensitydecomposition", (DL_FUNC) &F77_NAME(propensitydecomposition), 9, propdecompaccel_t},
{"propdecompaccel", (DL_FUNC) &F77_NAME(propdecompaccel), 9, propdecompaccel_t},
{"singleclusterupdate", (DL_FUNC) & F77_NAME(singleclusterupdate), 6, singleclusterupdate_t},
{NULL, NULL, 0, NULL}
};
void R_init_PropClust(DllInfo *dll)
{
R_registerRoutines(dll, R_CMethods, NULL, R_FortranMethods, NULL);
R_useDynamicSymbols(dll, FALSE);
R_forceSymbols(dll, TRUE);
}
int Eigen_lapack_x3(double *a, double *ko, int n0, int EVmax)
{
/*
F77_NAME(dsyevx,DSYEVX)()
input: n;
input: a[n][n]; matrix A
output: a[n][n]; eigevectors
output: ko[n]; eigenvalues
*/
char *name="Eigen_lapack";
char *JOBZ="V";
char *RANGE="I";
char *UPLO="L";
INTEGER n=n0;
INTEGER LDA=n0;
double VL,VU; /* dummy */
INTEGER IL,IU;
double ABSTOL=LAPACK_ABSTOL;
INTEGER M;
double *A,*Z;
INTEGER LDZ=n;
INTEGER LWORK;
double *WORK;
INTEGER *IWORK;
INTEGER *IFAIL, INFO;
int i,j;
A=(double*)malloc(sizeof(double)*n*n);
Z=(double*)malloc(sizeof(double)*n*n);
LWORK=n*8;
WORK=(double*)malloc(sizeof(double)*LWORK);
IWORK=(INTEGER*)malloc(sizeof(INTEGER)*n*5);
IFAIL=(INTEGER*)malloc(sizeof(INTEGER)*n);
IL = 1;
IU = EVmax;
for (i=0; i<n; i++) {
for (j=0; j<n; j++) {
A[i*n+j] = a[i*n+j];
}
}
#if 0
printf("A=\n");
for (i=0;i<n;i++) {
for (j=0;j<n;j++) {
printf("%f ",A[i*n+j]);
}
printf("\n");
}
fflush(stdout);
#endif
F77_NAME(dsyevx,DSYEVX)( JOBZ, RANGE, UPLO, &n, A, &LDA, &VL, &VU, &IL, &IU,
&ABSTOL, &M, ko, Z, &LDZ, WORK, &LWORK, IWORK,
IFAIL, &INFO );
if (INFO>0) {
/* printf("\n%s: error in dsyevx_, info=%d\n\n",name,INFO); */
}
else if (INFO<0) {
printf("%s: info=%d\n",name,INFO);
exit(10);
}
else{ /* (INFO==0) */
/* store eigenvectors */
for (i=0;i<EVmax;i++) {
for (j=0;j<n;j++) {
a[i*n+j]= Z[i*n+j];
}
}
}
free(IFAIL); free(IWORK); free(WORK); free(Z); free(A);
return INFO;
}
void TRAN_Calc_CentGreenLesser(
/* input */
dcomplex w,
double ChemP_e[2],
int nc,
int Order_Lead_Side[2],
dcomplex *SigmaL,
dcomplex *SigmaL_Ad,
dcomplex *SigmaR,
dcomplex *SigmaR_Ad,
dcomplex *GC,
dcomplex *GC_Ad,
dcomplex *HCCk,
dcomplex *SCC,
/* work, nc*nc */
dcomplex *v1,
dcomplex *v2,
/* output */
dcomplex *Gless
)
#define GC_ref(i,j) GC[nc*((j)-1)+(i)-1]
#define GC_Ad_ref(i,j) GC_Ad[nc*((j)-1)+(i)-1]
#define SigmaL_ref(i,j) SigmaL[nc*((j)-1)+(i)-1]
#define SigmaL_Ad_ref(i,j) SigmaL_Ad[nc*((j)-1)+(i)-1]
#define SigmaR_ref(i,j) SigmaR[nc*((j)-1)+(i)-1]
#define SigmaR_Ad_ref(i,j) SigmaR_Ad[nc*((j)-1)+(i)-1]
#define SCC_ref(i,j) SCC[nc*((j)-1)+(i)-1]
#define HCCk_ref(i,j) HCCk[nc*((j)-1)+(i)-1]
#define v1_ref(i,j) v1[nc*((j)-1)+(i)-1]
#define v2_ref(i,j) v2[nc*((j)-1)+(i)-1]
#define Gless_ref(i,j) Gless[nc*((j)-1)+(i)-1]
{
int i,j;
int side;
dcomplex alpha,beta;
dcomplex ctmp;
alpha.r = 1.0;
alpha.i = 0.0;
beta.r = 0.0;
beta.i = 0.0;
/******************************************************
lesser Green's function
******************************************************/
/* v1 = -\sigama_{L or R}(z^*) */
if (Order_Lead_Side[1]==0){
for (i=1; i<=nc; i++) {
for (j=1; j<=nc; j++) {
v1_ref(i,j).r = SigmaL_ref(i,j).r - SigmaL_Ad_ref(i,j).r;
v1_ref(i,j).i = SigmaL_ref(i,j).i - SigmaL_Ad_ref(i,j).i;
}
}
}
else{
for (i=1; i<=nc; i++) {
for (j=1; j<=nc; j++) {
v1_ref(i,j).r = SigmaR_ref(i,j).r - SigmaR_Ad_ref(i,j).r;
v1_ref(i,j).i = SigmaR_ref(i,j).i - SigmaR_Ad_ref(i,j).i;
}
}
}
/* v2 = G(z) * v1 */
F77_NAME(zgemm,ZGEMM)("N","N", &nc, &nc, &nc, &alpha, GC, &nc, v1, &nc, &beta, v2, &nc);
/* Gless = G(z) * v1 * G(z^*) */
F77_NAME(zgemm,ZGEMM)("N","N", &nc, &nc, &nc, &alpha, v2, &nc, GC_Ad, &nc, &beta, Gless, &nc);
/******************************************************
-1/(i 2Pi) * Gless
******************************************************/
for (i=1; i<=nc; i++) {
for (j=1; j<=nc; j++) {
ctmp.r = Gless_ref(i,j).r/(2.0*PI);
ctmp.i = Gless_ref(i,j).i/(2.0*PI);
Gless_ref(i,j).r =-ctmp.i;
Gless_ref(i,j).i = ctmp.r;
}
}
}
void TRAN_Calc_SurfGreen_Multiple_Inverse(
/* input */
dcomplex w,
int n,
double *h00,
double *h01,
double *s00,
double *s01,
int iteration_max,
double eps,
dcomplex *gr /* output */
)
#define h00_ref(i,j) h00[ n*((j)-1)+(i)-1 ]
#define h01_ref(i,j) h01[ n*((j)-1)+(i)-1 ]
#define s00_ref(i,j) s00[ n*((j)-1)+(i)-1 ]
#define s01_ref(i,j) s01[ n*((j)-1)+(i)-1 ]
#define gr_ref(i,j) gr[ n*((j)-1)+(i)-1 ]
#define g0_ref(i,j) g0[ n*((j)-1)+(i)-1 ]
#define h0_ref(i,j) h0[ n*((j)-1)+(i)-1 ]
#define hl_ref(i,j) hl[ n*((j)-1)+(i)-1 ]
#define hr_ref(i,j) hr[ n*((j)-1)+(i)-1 ]
#define tmpv1_ref(i,j) tmpv1[ n*((j)-1)+(i)-1 ]
#define tmpv2_ref(i,j) tmpv2[ n*((j)-1)+(i)-1 ]
{
static char *thisprogram="TRAN_Calc_SurfGreen_tranfermatrix";
int i,j,iter;
dcomplex a,b;
double rms2,val;
dcomplex cval;
dcomplex *g0;
dcomplex *h0,*hl,*hr;
dcomplex *tmpv1,*tmpv2;
/* printf("w=%le %le, n=%d, ite_max=%d eps=%le\n",w.r, w.i, n, iteration_max, eps); */
a.r=1.0; a.i=0.0;
b.r=0.0; b.i=0.0;
g0 = (dcomplex*)malloc(sizeof(dcomplex)*n*n) ;
h0 = (dcomplex*)malloc(sizeof(dcomplex)*n*n) ;
hl = (dcomplex*)malloc(sizeof(dcomplex)*n*n) ;
hr = (dcomplex*)malloc(sizeof(dcomplex)*n*n) ;
tmpv1 = (dcomplex*)malloc(sizeof(dcomplex)*n*n) ;
tmpv2 = (dcomplex*)malloc(sizeof(dcomplex)*n*n) ;
/* h0 = ws00-h00 */
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
h0_ref(i,j).r = w.r*s00_ref(i,j) - h00_ref(i,j);
h0_ref(i,j).i = w.i*s00_ref(i,j);
}
}
/* hl = ws01-h01 */
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
hl_ref(i,j).r = w.r*s01_ref(i,j) - h01_ref(i,j);
hl_ref(i,j).i = w.i*s01_ref(i,j);
}
}
/* hr = hl^t */
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
hr_ref(i,j).r = hl_ref(j,i).r;
hr_ref(i,j).i = hl_ref(j,i).i;
}
}
/* initial g0 = h0 */
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
g0_ref(i,j).r = h0_ref(i,j).r;
g0_ref(i,j).i = h0_ref(i,j).i;
}
}
/* initial g0 -> g0^-1 */
Lapack_LU_Zinverse(n,g0);
/* solve iteratively the closed form */
for( iter=1; iter<iteration_max; iter++) {
/* hl*g0 -> tmpv1 */
F77_NAME(zgemm,ZGEMM)("N","N", &n, &n, &n, &a, hl, &n, g0, &n, &b, tmpv1, &n);
/* tmpv1*hr (=hl*g0*hr) -> tmpv2 */
F77_NAME(zgemm,ZGEMM)("N","N", &n, &n, &n, &a, tmpv1, &n, hr, &n, &b, tmpv2, &n);
/* tmpv2 = h0 - tmpv2 (= h0-hl*g0*hr) */
for (i=1; i<=n; i++) {
for (j=1; j<=n; j++) {
tmpv2_ref(i,j).r = h0_ref(i,j).r - tmpv2_ref(i,j).r;
tmpv2_ref(i,j).i = h0_ref(i,j).i - tmpv2_ref(i,j).i;
}
}
/* tmpv2 -> tmpv2^-1 */
Lapack_LU_Zinverse(n,tmpv2);
/* calculate rms */
rms2=0.0;
for (i=1; i<=n; i++) {
for (j=1; j<=n; j++) {
cval.r = tmpv2_ref(i,j).r - g0_ref(i,j).r;
cval.i = tmpv2_ref(i,j).i - g0_ref(i,j).i;
val = cval.r*cval.r + cval.i*cval.i;
if ( rms2 < val ) { rms2 = val ; }
}
}
rms2 = sqrt(rms2);
/*debug*/
/*
printf("TRAN_Calc_SurfGreen: iter=%d itermax=%d, rms2=%le, eps=%le\n",
iter, iteration_max, rms2, eps);
*/
printf("TRAN_Calc_SurfGreen: iter=%d itermax=%d, rms2=%15.12f, eps=%15.12f\n",
iter, iteration_max, rms2, eps);
/* tmpv2 -> g0 */
for (i=1; i<=n; i++) {
for (j=1; j<=n; j++) {
g0_ref(i,j).r = tmpv2_ref(i,j).r;
g0_ref(i,j).i = tmpv2_ref(i,j).i;
}
}
if ( rms2 < eps ) {
/* converged */
goto last;
}
} /* iteration */
last:
if (iter>=iteration_max) {
/*
printf("ERROR: TRAN_Calc_SurfGreen: iter=%d itermax=%d, rms2=%le, eps=%le\n",
iter, iteration_max, rms2, eps);
*/
}
for (i=1;i<=n;i++) {
for (j=1;j<=n;j++) {
gr_ref(i,j).r = g0_ref(i,j).r;
gr_ref(i,j).i = g0_ref(i,j).i;
}
}
free(g0);
free(h0);
free(hl);
free(hr);
free(tmpv1);
free(tmpv2);
}
SEXP spMisalign(SEXP Y_r, SEXP X_r, SEXP p_r, SEXP n_r, SEXP m_r, SEXP coordsD_r,
SEXP betaPrior_r, SEXP betaNorm_r,
SEXP KPrior_r, SEXP KPriorName_r,
SEXP PsiPrior_r,
SEXP nuUnif_r, SEXP phiUnif_r,
SEXP phiStarting_r, SEXP AStarting_r, SEXP PsiStarting_r, SEXP nuStarting_r,
SEXP phiTuning_r, SEXP ATuning_r, SEXP PsiTuning_r, SEXP nuTuning_r,
SEXP nugget_r, SEXP covModel_r, SEXP amcmc_r, SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP verbose_r, SEXP nReport_r){
/*****************************************
Common variables
*****************************************/
int h, i, j, k, l, b, s, ii, jj, kk, info, nProtect= 0;
char const *lower = "L";
char const *upper = "U";
char const *nUnit = "N";
char const *yUnit = "U";
char const *ntran = "N";
char const *ytran = "T";
char const *rside = "R";
char const *lside = "L";
const double one = 1.0;
const double negOne = -1.0;
const double zero = 0.0;
const int incOne = 1;
/*****************************************
Set-up
*****************************************/
double *Y = REAL(Y_r);
double *X = REAL(X_r);
int *p = INTEGER(p_r);
int *n = INTEGER(n_r);
int m = INTEGER(m_r)[0];
int nLTr = m*(m-1)/2+m;
int N = 0;
int P = 0;
for(i = 0; i < m; i++){
N += n[i];
P += p[i];
}
int mm = m*m;
int NN = N*N;
int NP = N*P;
int PP = P*P;
double *coordsD = REAL(coordsD_r);
std::string covModel = CHAR(STRING_ELT(covModel_r,0));
//priors
std::string betaPrior = CHAR(STRING_ELT(betaPrior_r,0));
double *betaMu = NULL;
double *betaC = NULL;
if(betaPrior == "normal"){
betaMu = (double *) R_alloc(P, sizeof(double));
F77_NAME(dcopy)(&P, REAL(VECTOR_ELT(betaNorm_r, 0)), &incOne, betaMu, &incOne);
betaC = (double *) R_alloc(PP, sizeof(double));
F77_NAME(dcopy)(&PP, REAL(VECTOR_ELT(betaNorm_r, 1)), &incOne, betaC, &incOne);
}
double *phiUnif = REAL(phiUnif_r);
std::string KPriorName = CHAR(STRING_ELT(KPriorName_r,0));
double KIW_df = 0; double *KIW_S = NULL;
double *ANormMu = NULL; double *ANormC = NULL;
if(KPriorName == "IW"){
KIW_S = (double *) R_alloc(mm, sizeof(double));
KIW_df = REAL(VECTOR_ELT(KPrior_r, 0))[0]; KIW_S = REAL(VECTOR_ELT(KPrior_r, 1));
}else{//assume A normal (can add more specifications later)
ANormMu = (double *) R_alloc(nLTr, sizeof(double));
ANormC = (double *) R_alloc(nLTr, sizeof(double));
for(i = 0; i < nLTr; i++){
ANormMu[i] = REAL(VECTOR_ELT(KPrior_r, 0))[i];
ANormC[i] = REAL(VECTOR_ELT(KPrior_r, 1))[i];
}
}
bool nugget = static_cast<bool>(INTEGER(nugget_r)[0]);
double *PsiIGa = NULL; double *PsiIGb = NULL;
if(nugget){
PsiIGa = (double *) R_alloc(m, sizeof(double));
PsiIGb = (double *) R_alloc(m, sizeof(double));
for(i = 0; i < m; i++){
PsiIGa[i] = REAL(VECTOR_ELT(PsiPrior_r, 0))[i];
PsiIGb[i] = REAL(VECTOR_ELT(PsiPrior_r, 1))[i];
}
}
//matern
double *nuUnif = NULL;
if(covModel == "matern"){
nuUnif = REAL(nuUnif_r);
}
bool amcmc = static_cast<bool>(INTEGER(amcmc_r)[0]);
int nBatch = INTEGER(nBatch_r)[0];
int batchLength = INTEGER(batchLength_r)[0];
double acceptRate = REAL(acceptRate_r)[0];
int nSamples = nBatch*batchLength;
int verbose = INTEGER(verbose_r)[0];
int nReport = INTEGER(nReport_r)[0];
if(verbose){
Rprintf("----------------------------------------\n");
Rprintf("\tGeneral model description\n");
Rprintf("----------------------------------------\n");
Rprintf("Model fit with %i outcome variables.\n\n", m);
Rprintf("Number of observations within each outcome:"); printVec(n, m);
Rprintf("\nNumber of covariates for each outcome (including intercept if specified):"); printVec(p, m);
Rprintf("\nTotal number of observations: %i\n\n", N);
Rprintf("Total number of covariates (including intercept if specified): %i\n\n", P);
Rprintf("Using the %s spatial correlation model.\n\n", covModel.c_str());
if(amcmc){
Rprintf("Using adaptive MCMC.\n\n");
Rprintf("\tNumber of batches %i.\n", nBatch);
Rprintf("\tBatch length %i.\n", batchLength);
Rprintf("\ttarget acceptance rate %.5f.\n", acceptRate);
Rprintf("\n");
}else{
Rprintf("Number of MCMC samples %i.\n\n", nSamples);
}
if(!nugget){
Rprintf("Psi not included in the model (i.e., no nugget model).\n\n");
}
Rprintf("Priors and hyperpriors:\n");
if(betaPrior == "flat"){
Rprintf("\tbeta flat.\n");
}else{
Rprintf("\tbeta normal:\n");
Rprintf("\tmu:"); printVec(betaMu, P);
Rprintf("\tcov:\n"); printMtrx(betaC, P, P);
}
Rprintf("\n");
if(KPriorName == "IW"){
Rprintf("\tK IW hyperpriors df=%.5f, S=\n", KIW_df);
printMtrx(KIW_S, m, m);
}else{
Rprintf("\tA Normal hyperpriors\n");
Rprintf("\t\tparameter\tmean\tvar\n");
for(j = 0, i = 0; j < m; j++){
for(k = j; k < m; k++, i++){
Rprintf("\t\tA[%i,%i]\t\t%3.1f\t%1.2f\n", j+1, k+1, ANormMu[i], ANormC[i]);
}
}
}
Rprintf("\n");
if(nugget){
Rprintf("\tDiag(Psi) IG hyperpriors\n");
Rprintf("\t\tparameter\tshape\tscale\n");
for(j = 0; j < m; j++){
Rprintf("\t\tPsi[%i,%i]\t%3.1f\t%1.2f\n", j+1, j+1, PsiIGa[j], PsiIGb[j]);
}
}
Rprintf("\n");
Rprintf("\tphi Unif hyperpriors\n");
Rprintf("\t\tparameter\ta\tb\n");
for(j = 0; j < m; j++){
Rprintf("\t\tphi[%i]\t\t%0.5f\t%0.5f\n", j+1, phiUnif[j*2], phiUnif[j*2+1]);
}
Rprintf("\n");
if(covModel == "matern"){
Rprintf("\tnu Unif hyperpriors\n");
for(j = 0; j < m; j++){
Rprintf("\t\tnu[%i]\t\t%0.5f\t%0.5f\n", j+1, nuUnif[j*2], nuUnif[j*2+1]);
}
Rprintf("\n");
}
}
/*****************************************
Set-up MCMC sample matrices etc.
*****************************************/
//spatial parameters
int nParams, AIndx, PsiIndx, phiIndx, nuIndx;
if(!nugget && covModel != "matern"){
nParams = nLTr+m;//A, phi
AIndx = 0; phiIndx = nLTr;
}else if(nugget && covModel != "matern"){
nParams = nLTr+m+m;//A, diag(Psi), phi
AIndx = 0; PsiIndx = nLTr; phiIndx = PsiIndx+m;
}else if(!nugget && covModel == "matern"){
nParams = nLTr+2*m;//A, phi, nu
AIndx = 0; phiIndx = nLTr, nuIndx = phiIndx+m;
}else{
nParams = nLTr+3*m;//A, diag(Psi), phi, nu
AIndx = 0; PsiIndx = nLTr, phiIndx = PsiIndx+m, nuIndx = phiIndx+m;
}
double *params = (double *) R_alloc(nParams, sizeof(double));
//starting
covTrans(REAL(AStarting_r), ¶ms[AIndx], m);
if(nugget){
for(i = 0; i < m; i++){
params[PsiIndx+i] = log(REAL(PsiStarting_r)[i]);
}
}
for(i = 0; i < m; i++){
params[phiIndx+i] = logit(REAL(phiStarting_r)[i], phiUnif[i*2], phiUnif[i*2+1]);
if(covModel == "matern"){
params[nuIndx+i] = logit(REAL(nuStarting_r)[i], nuUnif[i*2], nuUnif[i*2+1]);
}
}
//tuning and fixed
double *tuning = (double *) R_alloc(nParams, sizeof(double));
int *fixed = (int *) R_alloc(nParams, sizeof(int)); zeros(fixed, nParams);
for(i = 0; i < nLTr; i++){
tuning[AIndx+i] = REAL(ATuning_r)[i];
if(tuning[AIndx+i] == 0){
fixed[AIndx+i] = 1;
}
}
if(nugget){
for(i = 0; i < m; i++){
tuning[PsiIndx+i] = REAL(PsiTuning_r)[i];
if(tuning[PsiIndx+i] == 0){
fixed[PsiIndx+i] = 1;
}
}
}
for(i = 0; i < m; i++){
tuning[phiIndx+i] = REAL(phiTuning_r)[i];
if(tuning[phiIndx+i] == 0){
fixed[phiIndx+i] = 1;
}
if(covModel == "matern"){
tuning[nuIndx+i] = REAL(nuTuning_r)[i];
if(tuning[nuIndx+i] == 0){
fixed[nuIndx+i] = 1;
}
}
}
for(i = 0; i < nParams; i++){
tuning[i] = log(sqrt(tuning[i]));
}
//return stuff
SEXP samples_r, accept_r, tuning_r;
PROTECT(samples_r = allocMatrix(REALSXP, nParams, nSamples)); nProtect++;
if(amcmc){
PROTECT(accept_r = allocMatrix(REALSXP, nParams, nBatch)); nProtect++;
PROTECT(tuning_r = allocMatrix(REALSXP, nParams, nBatch)); nProtect++;
}else{
PROTECT(accept_r = allocMatrix(REALSXP, 1, nSamples/nReport)); nProtect++;
}
// /*****************************************
// Set-up MCMC alg. vars. matrices etc.
// *****************************************/
int status=1, batchAccept=0, reportCnt=0;
double logMHRatio =0, logPostCurrent = R_NegInf, logPostCand = 0, det = 0, paramsjCurrent = 0;
double Q, logDetK, SKtrace;
double *paramsCurrent = (double *) R_alloc(nParams, sizeof(double));
double *accept = (double *) R_alloc(nParams, sizeof(double)); zeros(accept, nParams);
double *C = (double *) R_alloc(NN, sizeof(double));
double *K = (double *) R_alloc(mm, sizeof(double));
double *Psi = (double *) R_alloc(m, sizeof(double));
double *A = (double *) R_alloc(mm, sizeof(double));
double *phi = (double *) R_alloc(m, sizeof(double));
double *nu = (double *) R_alloc(m, sizeof(double));
int P1 = P+1;
double *vU = (double *) R_alloc(N*P1, sizeof(double));
double *z = (double *) R_alloc(N, sizeof(double));
double *tmp_N = (double *) R_alloc(N, sizeof(double));
double *tmp_mm = (double *) R_alloc(mm, sizeof(double));
double *tmp_PP = (double *) R_alloc(PP, sizeof(double));
double *tmp_P = (double *) R_alloc(P, sizeof(double));
double *tmp_NN = NULL;
double *Cbeta = NULL;
if(betaPrior == "normal"){
tmp_NN = (double *) R_alloc(NN, sizeof(double));
Cbeta = (double *) R_alloc(NN, sizeof(double));
F77_NAME(dgemv)(ntran, &N, &P, &negOne, X, &N, betaMu, &incOne, &zero, z, &incOne);
F77_NAME(daxpy)(&N, &one, Y, &incOne, z, &incOne);
F77_NAME(dsymm)(rside, lower, &N, &P, &one, betaC, &P, X, &N, &zero, vU, &N);
F77_NAME(dgemm)(ntran, ytran, &N, &N, &P, &one, vU, &N, X, &N, &zero, tmp_NN, &N);
}
int sl, sk;
if(verbose){
Rprintf("-------------------------------------------------\n");
Rprintf("\t\tSampling\n");
Rprintf("-------------------------------------------------\n");
#ifdef Win32
R_FlushConsole();
#endif
}
GetRNGstate();
for(b = 0, s = 0; b < nBatch; b++){
for(i = 0; i < batchLength; i++, s++){
for(j = 0; j < nParams; j++){
//propose
if(amcmc){
if(fixed[j] == 1){
paramsjCurrent = params[j];
}else{
paramsjCurrent = params[j];
params[j] = rnorm(paramsjCurrent, exp(tuning[j]));
}
}else{
F77_NAME(dcopy)(&nParams, params, &incOne, paramsCurrent, &incOne);
for(j = 0; j < nParams; j++){
if(fixed[j] == 1){
params[j] = params[j];
}else{
params[j] = rnorm(params[j], exp(tuning[j]));
}
}
}
//extract and transform
covTransInvExpand(¶ms[AIndx], A, m);
for(k = 0; k < m; k++){
phi[k] = logitInv(params[phiIndx+k], phiUnif[k*2], phiUnif[k*2+1]);
if(covModel == "matern"){
nu[k] = logitInv(params[nuIndx+k], nuUnif[k*2], nuUnif[k*2+1]);
}
}
if(nugget){
for(k = 0; k < m; k++){
Psi[k] = exp(params[PsiIndx+k]);
}
}
//construct covariance matrix
sl = sk = 0;
for(k = 0; k < m; k++){
sl = 0;
for(l = 0; l < m; l++){
for(kk = 0; kk < n[k]; kk++){
for(jj = 0; jj < n[l]; jj++){
C[(sl+jj)*N+(sk+kk)] = 0.0;
for(ii = 0; ii < m; ii++){
C[(sl+jj)*N+(sk+kk)] += A[k+m*ii]*A[l+m*ii]*spCor(coordsD[(sl+jj)*N+(sk+kk)], phi[ii], nu[ii], covModel);
}
}
}
sl += n[l];
}
sk += n[k];
}
if(nugget){
sl = 0;
for(l = 0; l < m; l++){
for(k = 0; k < n[l]; k++){
C[(sl+k)*N+(sl+k)] += Psi[l];
}
sl += n[l];
}
}
if(betaPrior == "normal"){
for(k = 0; k < N; k++){
for(l = k; l < N; l++){
Cbeta[k*N+l] = C[k*N+l]+tmp_NN[k*N+l];
}
}
det = 0;
F77_NAME(dpotrf)(lower, &N, Cbeta, &N, &info); if(info != 0){error("c++ error: dpotrf failed\n");}
for(k = 0; k < N; k++) det += 2*log(Cbeta[k*N+k]);
F77_NAME(dcopy)(&N, z, &incOne, tmp_N, &incOne);
F77_NAME(dtrsv)(lower, ntran, nUnit, &N, Cbeta, &N, tmp_N, &incOne);//u = L^{-1}(y-X'beta)
Q = pow(F77_NAME(dnrm2)(&N, tmp_N, &incOne),2);
}else{//beta flat
det = 0;
F77_NAME(dpotrf)(lower, &N, C, &N, &info); if(info != 0){error("c++ error: dpotrf failed\n");}
for(k = 0; k < N; k++) det += 2*log(C[k*N+k]);
F77_NAME(dcopy)(&N, Y, &incOne, vU, &incOne);
F77_NAME(dcopy)(&NP, X, &incOne, &vU[N], &incOne);
F77_NAME(dtrsm)(lside, lower, ntran, nUnit, &N, &P1, &one, C, &N, vU, &N);//L^{-1}[v:U] = [y:X]
F77_NAME(dgemm)(ytran, ntran, &P, &P, &N, &one, &vU[N], &N, &vU[N], &N, &zero, tmp_PP, &P); //U'U
F77_NAME(dpotrf)(lower, &P, tmp_PP, &P, &info); if(info != 0){error("c++ error: dpotrf failed\n");}
for(k = 0; k < P; k++) det += 2*log(tmp_PP[k*P+k]);
F77_NAME(dgemv)(ytran, &N, &P, &one, &vU[N], &N, vU, &incOne, &zero, tmp_P, &incOne); //U'v
F77_NAME(dtrsv)(lower, ntran, nUnit, &P, tmp_PP, &P, tmp_P, &incOne);
Q = pow(F77_NAME(dnrm2)(&N, vU, &incOne),2) - pow(F77_NAME(dnrm2)(&P, tmp_P, &incOne),2) ;
}
//
//priors, jacobian adjustments, and likelihood
//
logPostCand = 0.0;
if(KPriorName == "IW"){
logDetK = 0.0;
SKtrace = 0.0;
for(k = 0; k < m; k++){logDetK += 2*log(A[k*m+k]);}
//jacobian \sum_{i=1}^{m} (m-i+1)*log(a_ii)+log(a_ii)
for(k = 0; k < m; k++){logPostCand += (m-k)*log(A[k*m+k])+log(A[k*m+k]);}
//S*K^-1
F77_NAME(dpotri)(lower, &m, A, &m, &info); if(info != 0){error("c++ error: dpotri failed\n");}
F77_NAME(dsymm)(rside, lower, &m, &m, &one, A, &m, KIW_S, &m, &zero, tmp_mm, &m);
for(k = 0; k < m; k++){SKtrace += tmp_mm[k*m+k];}
logPostCand += -0.5*(KIW_df+m+1)*logDetK - 0.5*SKtrace;
}else{
for(k = 0; k < nLTr; k++){
logPostCand += dnorm(params[AIndx+k], ANormMu[k], sqrt(ANormC[k]), 1);
}
}
if(nugget){
for(k = 0; k < m; k++){
logPostCand += -1.0*(1.0+PsiIGa[k])*log(Psi[k])-PsiIGb[k]/Psi[k]+log(Psi[k]);
}
}
for(k = 0; k < m; k++){
logPostCand += log(phi[k] - phiUnif[k*2]) + log(phiUnif[k*2+1] - phi[k]);
if(covModel == "matern"){
logPostCand += log(nu[k] - nuUnif[k*2]) + log(nuUnif[k*2+1] - nu[k]);
}
}
logPostCand += -0.5*det-0.5*Q;
//
//MH accept/reject
//
logMHRatio = logPostCand - logPostCurrent;
if(runif(0.0,1.0) <= exp(logMHRatio)){
logPostCurrent = logPostCand;
if(amcmc){
accept[j]++;
}else{
accept[0]++;
batchAccept++;
}
}else{
if(amcmc){
params[j] = paramsjCurrent;
}else{
F77_NAME(dcopy)(&nParams, paramsCurrent, &incOne, params, &incOne);
}
}
if(!amcmc){
break;
}
}//end params
/******************************
Save samples
*******************************/
F77_NAME(dcopy)(&nParams, params, &incOne, &REAL(samples_r)[s*nParams], &incOne);
R_CheckUserInterrupt();
}//end batch
//adjust tuning
if(amcmc){
for(j = 0; j < nParams; j++){
REAL(accept_r)[b*nParams+j] = accept[j]/batchLength;
REAL(tuning_r)[b*nParams+j] = tuning[j];
if(accept[j]/batchLength > acceptRate){
tuning[j] += std::min(0.01, 1.0/sqrt(static_cast<double>(b)));
}else{
tuning[j] -= std::min(0.01, 1.0/sqrt(static_cast<double>(b)));
}
accept[j] = 0.0;
}
}
//report
if(status == nReport){
if(verbose){
if(amcmc){
Rprintf("Batch: %i of %i, %3.2f%%\n", b+1, nBatch, 100.0*(b+1)/nBatch);
Rprintf("\tparameter\tacceptance\ttuning\n");
for(j = 0, i = 0; j < m; j++){
for(k = j; k < m; k++, i++){
Rprintf("\tA[%i,%i]\t\t%3.1f\t\t%1.2f\n", j+1, k+1, 100.0*REAL(accept_r)[b*nParams+AIndx+i], exp(tuning[AIndx+i]));
}
}
if(nugget){
for(j = 0; j < m; j++){
Rprintf("\tPsi[%i,%i]\t%3.1f\t\t%1.2f\n", j+1, j+1, 100.0*REAL(accept_r)[b*nParams+PsiIndx+j], exp(tuning[PsiIndx+j]));
}
}
for(j = 0; j < m; j++){
Rprintf("\tphi[%i]\t\t%3.1f\t\t%1.2f\n", j+1, 100.0*REAL(accept_r)[b*nParams+phiIndx+j], exp(tuning[phiIndx+j]));
}
if(covModel == "matern"){
Rprintf("\n");
for(j = 0; j < m; j++){
Rprintf("\tnu[%i]\t\t%3.1f\t\t%1.2f\n", j+1, 100.0*REAL(accept_r)[b*nParams+nuIndx+j], exp(tuning[nuIndx+j]));
}
}
}else{
Rprintf("Sampled: %i of %i, %3.2f%%\n", s, nSamples, 100.0*s/nSamples);
Rprintf("Report interval Metrop. Acceptance rate: %3.2f%%\n", 100.0*batchAccept/nReport);
Rprintf("Overall Metrop. Acceptance rate: %3.2f%%\n", 100.0*accept[0]/s);
}
Rprintf("-------------------------------------------------\n");
#ifdef Win32
R_FlushConsole();
#endif
}
if(!amcmc){
REAL(accept_r)[reportCnt] = 100.0*batchAccept/nReport;
reportCnt++;
}
status = 0;
batchAccept = 0;
}
status++;
}//end sample loop
PutRNGstate();
//untransform variance variables
for(s = 0; s < nSamples; s++){
covTransInv(&REAL(samples_r)[s*nParams+AIndx], &REAL(samples_r)[s*nParams+AIndx], m);
if(nugget){
for(i = 0; i < m; i++){
REAL(samples_r)[s*nParams+PsiIndx+i] = exp(REAL(samples_r)[s*nParams+PsiIndx+i]);
}
}
for(i = 0; i < m; i++){
REAL(samples_r)[s*nParams+phiIndx+i] = logitInv(REAL(samples_r)[s*nParams+phiIndx+i], phiUnif[i*2], phiUnif[i*2+1]);
if(covModel == "matern"){
REAL(samples_r)[s*nParams+nuIndx+i] = logitInv(REAL(samples_r)[s*nParams+nuIndx+i], nuUnif[i*2], nuUnif[i*2+1]);
}
}
}
//make return object
SEXP result_r, resultName_r;
int nResultListObjs = 2;
if(amcmc){
nResultListObjs++;
}
PROTECT(result_r = allocVector(VECSXP, nResultListObjs)); nProtect++;
PROTECT(resultName_r = allocVector(VECSXP, nResultListObjs)); nProtect++;
//samples
SET_VECTOR_ELT(result_r, 0, samples_r);
SET_VECTOR_ELT(resultName_r, 0, mkChar("p.theta.samples"));
SET_VECTOR_ELT(result_r, 1, accept_r);
SET_VECTOR_ELT(resultName_r, 1, mkChar("acceptance"));
if(amcmc){
SET_VECTOR_ELT(result_r, 2, tuning_r);
SET_VECTOR_ELT(resultName_r, 2, mkChar("tuning"));
}
namesgets(result_r, resultName_r);
//unprotect
UNPROTECT(nProtect);
return(result_r);
}
/* .Fortran calls */
extern void F77_NAME(complete)(void *, void *);
extern void F77_NAME(cspec)(void *, void *, void *, void *, void *, void *, void *);
extern void F77_NAME(display)();
extern void F77_NAME(forecast)();
extern void F77_NAME(kfilsm)();
extern void F77_NAME(loop)(void *, void *, void *);
extern void F77_NAME(setcom)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
extern void F77_NAME(setfor)(void *, void *, void *, void *, void *);
extern void F77_NAME(setkfilsm)(void *, void *, void *, void *, void *);
extern void F77_NAME(setup)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
extern void F77_NAME(setupdate)(void *);
extern void F77_NAME(update)();
static const R_FortranMethodDef FortranEntries[] = {
{"complete", (DL_FUNC) &F77_NAME(complete), 2},
{"cspec", (DL_FUNC) &F77_NAME(cspec), 7},
{"display", (DL_FUNC) &F77_NAME(display), 0},
{"forecast", (DL_FUNC) &F77_NAME(forecast), 0},
{"kfilsm", (DL_FUNC) &F77_NAME(kfilsm), 0},
{"loop", (DL_FUNC) &F77_NAME(loop), 3},
{"setcom", (DL_FUNC) &F77_NAME(setcom), 15},
{"setfor", (DL_FUNC) &F77_NAME(setfor), 5},
{"setkfilsm", (DL_FUNC) &F77_NAME(setkfilsm), 5},
{"setup", (DL_FUNC) &F77_NAME(setup), 31},
{"setupdate", (DL_FUNC) &F77_NAME(setupdate), 1},
{"update", (DL_FUNC) &F77_NAME(update), 0},
{NULL, NULL, 0}
};
void R_init_cts(DllInfo *dll)
void Eigen_DGGEVX( int n, double **a, double **s, double *eval, double *resr, double *resi )
{
static int i,j,k,l,num;
static char balanc = 'N';
static char jobvl = 'V';
static char jobvr = 'V';
static char sense = 'B';
static double *A;
static double *b;
static double *alphar;
static double *alphai;
static double *beta;
static double *vl;
static double *vr;
static double *lscale;
static double *rscale;
static double abnrm;
static double bbnrm;
static double *rconde;
static double *rcondv;
static double *work;
static double *tmpvecr,*tmpveci;
static INTEGER *iwork;
static INTEGER lda,ldb,ldvl,ldvr,ilo,ihi;
static INTEGER lwork,info;
static logical *bwork;
static double sumr,sumi,tmpr,tmpi;
static double *sortnum;
lda = n;
ldb = n;
ldvl = n;
ldvr = n;
A = (double*)malloc(sizeof(double)*n*n);
b = (double*)malloc(sizeof(double)*n*n);
alphar = (double*)malloc(sizeof(double)*n);
alphai = (double*)malloc(sizeof(double)*n);
beta = (double*)malloc(sizeof(double)*n);
vl = (double*)malloc(sizeof(double)*n*n);
vr = (double*)malloc(sizeof(double)*n*n);
lscale = (double*)malloc(sizeof(double)*n);
rscale = (double*)malloc(sizeof(double)*n);
rconde = (double*)malloc(sizeof(double)*n);
rcondv = (double*)malloc(sizeof(double)*n);
lwork = 2*n*n + 12*n + 16;
work = (double*)malloc(sizeof(double)*lwork);
iwork = (INTEGER*)malloc(sizeof(INTEGER)*(n+6));
bwork = (logical*)malloc(sizeof(logical)*n);
tmpvecr = (double*)malloc(sizeof(double)*(n+2));
tmpveci = (double*)malloc(sizeof(double)*(n+2));
sortnum = (double*)malloc(sizeof(double)*(n+2));
/* convert two dimensional arrays to one-dimensional arrays */
for (i=0; i<n; i++) {
for (j=0; j<n; j++) {
A[j*n+i]= a[i+1][j+1];
b[j*n+i]= s[i+1][j+1];
}
}
/* call dggevx_() */
F77_NAME(dggevx,DGGEVX)(
&balanc, &jobvl, & jobvr, &sense, &n, A, &lda, b, &ldb,
alphar, alphai, beta, vl, &ldvl, vr, &ldvr, &ilo, &ihi,
lscale, rscale, &abnrm, &bbnrm, rconde, rcondv, work,
&lwork, iwork, bwork, &info );
if (info!=0){
printf("Errors in dggevx_() info=%2d\n",info);
}
/*
for (i=0; i<n; i++){
printf("i=%4d %18.13f %18.13f %18.13f\n",i,alphar[i],alphai[i],beta[i]);
}
printf("\n");
*/
num = 0;
for (i=0; i<n; i++){
if ( 1.0e-13<fabs(beta[i]) && 0.0<alphai[i]/beta[i] ){
/* normalize the eigenvector */
for (j=0; j<n; j++) {
sumr = 0.0;
sumi = 0.0;
for (k=0; k<n; k++) {
sumr += s[j+1][k+1]*vr[i*n +k];
sumi += s[j+1][k+1]*vr[(i+1)*n+k];
}
tmpvecr[j] = sumr;
tmpveci[j] = sumi;
}
sumr = 0.0;
sumi = 0.0;
for (k=0; k<n; k++) {
sumr += vl[i*n+k]*tmpvecr[k] + vl[(i+1)*n+k]*tmpveci[k];
sumi += vl[i*n+k]*tmpveci[k] - vl[(i+1)*n+k]*tmpvecr[k];
}
/* calculate zero point and residue */
eval[num+1] = alphai[i]/beta[i];
tmpr = vr[i*n]*vl[i*n] + vr[(i+1)*n]*vl[(i+1)*n];
tmpi = -vr[i*n]*vl[(i+1)*n] + vr[(i+1)*n]*vl[i*n];
resr[num+1] = tmpi/sumi;
resi[num+1] = -tmpr/sumi;
num++;
}
else{
/*
printf("i=%4d %18.13f %18.13f %18.13f\n",i+1,alphar[i],alphai[i],beta[i]);
*/
}
}
/* check round-off error */
for (i=1; i<=num; i++){
if (1.0e-8<fabs(resi[i])){
printf("Could not calculate zero points and residues due to round-off error\n");
MPI_Finalize();
exit(0);
}
}
/* sorting */
qsort_double(num,eval,resr);
/* free arraies */
free(A);
free(b);
free(alphar);
free(alphai);
free(beta);
free(vl);
free(vr);
free(lscale);
free(rscale);
free(rconde);
free(rcondv);
free(work);
free(iwork);
free(bwork);
free(tmpvecr);
free(tmpveci);
free(sortnum);
}
void lapack_dstevx2(INTEGER N, INTEGER EVmax, double *D, double *E, double *W, dcomplex **ev, int ev_flag)
{
int i,j;
char *JOBZN="N";
char *JOBZV="V";
char *RANGE="I";
double VL,VU; /* dummy */
INTEGER IL,IU;
double ABSTOL=1.0e-14;
INTEGER M;
double *Z;
INTEGER LDZ;
double *WORK;
INTEGER *IWORK;
INTEGER *IFAIL;
INTEGER INFO;
IL = 1;
IU = EVmax;
M = IU - IL + 1;
LDZ = N;
Z = (double*)malloc(sizeof(double)*LDZ*N);
WORK = (double*)malloc(sizeof(double)*5*N);
IWORK = (INTEGER*)malloc(sizeof(INTEGER)*5*N);
IFAIL = (INTEGER*)malloc(sizeof(INTEGER)*N);
if (ev_flag){
F77_NAME(dstevx,DSTEVX)( JOBZV, RANGE, &N, D, E, &VL, &VU, &IL, &IU, &ABSTOL,
&M, W, Z, &LDZ, WORK, IWORK, IFAIL, &INFO );
}
else{
F77_NAME(dstevx,DSTEVX)( JOBZN, RANGE, &N, D, E, &VL, &VU, &IL, &IU, &ABSTOL,
&M, W, Z, &LDZ, WORK, IWORK, IFAIL, &INFO );
}
/* store eigenvectors */
if (ev_flag){
for (i=0; i<EVmax; i++) {
for (j=0; j<N; j++) {
ev[i+1][j+1].r = Z[i*N+j];
ev[i+1][j+1].i = 0.0;
}
}
}
/* shift ko by 1 */
for (i=EVmax; i>=1; i--){
W[i]= W[i-1];
}
if (INFO>0) {
/*
printf("\n error in dstevx_, info=%d\n\n",INFO);
*/
}
if (INFO<0) {
printf("info=%d in dstevx_\n",INFO);
MPI_Finalize();
exit(0);
}
free(Z);
free(WORK);
free(IWORK);
free(IFAIL);
}
#include <R_ext/RS.h>
#include <stdlib.h> // for NULL
#include <R_ext/Rdynload.h>
/* FIXME:
Check these declarations against the C/Fortran source code.
*/
/* .Fortran calls */
extern void F77_NAME(mainloop)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *);
static const R_FortranMethodDef FortranEntries[] = {
{"mainloop", (DL_FUNC) &F77_NAME(mainloop), 49},
{NULL, NULL, 0}
};
void R_init_mixor(DllInfo *dll)
{
R_registerRoutines(dll, NULL, NULL, FortranEntries, NULL);
R_useDynamicSymbols(dll, FALSE);
}
// [[register]]
SEXP mcmcbas(SEXP Y, SEXP X, SEXP Rweights, SEXP Rprobinit, SEXP Rmodeldim, SEXP incint, SEXP Ralpha,SEXP method, SEXP modelprior, SEXP Rupdate, SEXP Rbestmodel, SEXP plocal,
SEXP BURNIN_Iterations, SEXP MCMC_Iterations, SEXP LAMBDA, SEXP DELTA,
SEXP Rparents)
{
SEXP RXwork = PROTECT(duplicate(X)), RYwork = PROTECT(duplicate(Y));
int nProtected = 2, nUnique=0, newmodel=0;
int nModels=LENGTH(Rmodeldim);
// Rprintf("Allocating Space for %d Models\n", nModels) ;
SEXP ANS = PROTECT(allocVector(VECSXP, 15)); ++nProtected;
SEXP ANS_names = PROTECT(allocVector(STRSXP, 15)); ++nProtected;
SEXP Rprobs = PROTECT(duplicate(Rprobinit)); ++nProtected;
SEXP MCMCprobs= PROTECT(duplicate(Rprobinit)); ++nProtected;
SEXP R2 = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP shrinkage = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP modelspace = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
SEXP modeldim = PROTECT(duplicate(Rmodeldim)); ++nProtected;
SEXP counts = PROTECT(duplicate(Rmodeldim)); ++nProtected;
SEXP beta = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
SEXP se = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
SEXP mse = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP modelprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP priorprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP logmarg = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP sampleprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP NumUnique = PROTECT(allocVector(INTSXP, 1)); ++nProtected;
SEXP Rse_m = NULL, Rcoef_m = NULL, Rmodel_m;
double *Xwork, *Ywork, *wts, *coefficients,*probs, shrinkage_m, *MCMC_probs,
SSY, yty, mse_m, *se_m, MH=0.0, prior_m=1.0, *real_model,
R2_m, RSquareFull, alpha, prone, denom, logmargy, postold, postnew;
int nobs, p, k, i, j, m, n, l, pmodel, pmodel_old, *xdims, *model_m, *bestmodel, *varin, *varout;
int mcurrent, update, n_sure;
double mod, rem, problocal, *pigamma, eps, *hyper_parameters;
double *XtX, *XtY, *XtXwork, *XtYwork, *SSgam, *Cov, *priorCov, *marg_probs;
double lambda, delta, one=1.0;
int inc=1;
int *model, *modelold, bit, *modelwork, old_loc, new_loc;
// char uplo[] = "U", trans[]="T";
struct Var *vars; /* Info about the model variables. */
NODEPTR tree, branch;
/* get dimsensions of all variables */
nobs = LENGTH(Y);
xdims = INTEGER(getAttrib(X,R_DimSymbol));
p = xdims[1];
k = LENGTH(modelprobs);
update = INTEGER(Rupdate)[0];
lambda=REAL(LAMBDA)[0];
delta = REAL(DELTA)[0];
// Rprintf("delta %f lambda %f", delta, lambda);
eps = DBL_EPSILON;
problocal = REAL(plocal)[0];
// Rprintf("Update %i and prob.switch %f\n", update, problocal);
/* Extract prior on models */
hyper_parameters = REAL(getListElement(modelprior,"hyper.parameters"));
/* Rprintf("n %d p %d \n", nobs, p); */
Ywork = REAL(RYwork);
Xwork = REAL(RXwork);
wts = REAL(Rweights);
/* Allocate other variables. */
PrecomputeData(Xwork, Ywork, wts, &XtXwork, &XtYwork, &XtX, &XtY, &yty, &SSY, p, nobs);
alpha = REAL(Ralpha)[0];
vars = (struct Var *) R_alloc(p, sizeof(struct Var));
probs = REAL(Rprobs);
n = sortvars(vars, probs, p);
for (i =n; i <p; i++) REAL(MCMCprobs)[vars[i].index] = probs[vars[i].index];
for (i =0; i <n; i++) REAL(MCMCprobs)[vars[i].index] = 0.0;
MCMC_probs = REAL(MCMCprobs);
pigamma = vecalloc(p);
real_model = vecalloc(n);
marg_probs = vecalloc(n);
modelold = ivecalloc(p);
model = ivecalloc(p);
modelwork= ivecalloc(p);
varin= ivecalloc(p);
varout= ivecalloc(p);
/* create gamma gamma' matrix */
SSgam = (double *) R_alloc(n * n, sizeof(double));
Cov = (double *) R_alloc(n * n, sizeof(double));
priorCov = (double *) R_alloc(n * n, sizeof(double));
for (j=0; j < n; j++) {
for (i = 0; i < n; i++) {
SSgam[j*n + i] = 0.0;
Cov[j*n + i] = 0.0;
priorCov[j*n + i] = 0.0;
if (j == i) priorCov[j*n + i] = lambda;
}
marg_probs[i] = 0.0;
}
RSquareFull = CalculateRSquareFull(XtY, XtX, XtXwork, XtYwork, Rcoef_m, Rse_m, p, nobs, yty, SSY);
/* fill in the sure things */
for (i = n, n_sure = 0; i < p; i++) {
model[vars[i].index] = (int) vars[i].prob;
if (model[vars[i].index] == 1) ++n_sure;
}
GetRNGstate();
tree = make_node(-1.0);
/* Rprintf("For m=0, Initialize Tree with initial Model\n"); */
m = 0;
bestmodel = INTEGER(Rbestmodel);
INTEGER(modeldim)[m] = n_sure;
/* Rprintf("Create Tree\n"); */
branch = tree;
for (i = 0; i< n; i++) {
bit = bestmodel[vars[i].index];
if (bit == 1) {
if (i < n-1 && branch->one == NULL)
branch->one = make_node(-1.0);
if (i == n-1 && branch->one == NULL)
branch->one = make_node(0.0);
branch = branch->one;
}
else {
if (i < n-1 && branch->zero == NULL)
branch->zero = make_node(-1.0);
if (i == n-1 && branch->zero == NULL)
branch->zero = make_node(0.0);
branch = branch->zero;
}
model[vars[i].index] = bit;
INTEGER(modeldim)[m] += bit;
branch->where = 0;
}
/* Rprintf("Now get model specific calculations \n"); */
pmodel = INTEGER(modeldim)[m];
PROTECT(Rmodel_m = allocVector(INTSXP,pmodel));
model_m = INTEGER(Rmodel_m);
for (j = 0, l=0; j < p; j++) {
if (model[j] == 1) {
model_m[l] = j;
l +=1;}
}
SET_ELEMENT(modelspace, m, Rmodel_m);
Rcoef_m = NEW_NUMERIC(pmodel); PROTECT(Rcoef_m);
Rse_m = NEW_NUMERIC(pmodel); PROTECT(Rse_m);
coefficients = REAL(Rcoef_m);
se_m = REAL(Rse_m);
for (j=0, l=0; j < pmodel; j++) {
XtYwork[j] = XtY[model_m[j]];
for ( i = 0; i < pmodel; i++) {
XtXwork[j*pmodel + i] = XtX[model_m[j]*p + model_m[i]];
}
}
R2_m = 0.0;
mse_m = yty;
memcpy(coefficients, XtYwork, sizeof(double)*pmodel);
cholreg(XtYwork, XtXwork, coefficients, se_m, &mse_m, pmodel, nobs);
if (pmodel > 1) R2_m = 1.0 - (mse_m * (double) ( nobs - pmodel))/SSY;
SET_ELEMENT(beta, m, Rcoef_m);
SET_ELEMENT(se, m, Rse_m);
REAL(R2)[m] = R2_m;
REAL(mse)[m] = mse_m;
gexpectations(p, pmodel, nobs, R2_m, alpha, INTEGER(method)[0], RSquareFull, SSY, &logmargy, &shrinkage_m);
REAL(sampleprobs)[m] = 1.0;
REAL(logmarg)[m] = logmargy;
REAL(shrinkage)[m] = shrinkage_m;
prior_m = compute_prior_probs(model,pmodel,p, modelprior);
REAL(priorprobs)[m] = prior_m;
UNPROTECT(3);
old_loc = 0;
pmodel_old = pmodel;
nUnique=1;
INTEGER(counts)[0] = 0;
postold = REAL(logmarg)[m] + log(REAL(priorprobs)[m]);
memcpy(modelold, model, sizeof(int)*p);
/* Rprintf("model %d max logmarg %lf\n", m, REAL(logmarg)[m]); */
/* Rprintf("Now Sample the Rest of the Models \n"); */
m = 0;
while (nUnique < k && m < INTEGER(BURNIN_Iterations)[0]) {
memcpy(model, modelold, sizeof(int)*p);
pmodel = n_sure;
MH = 1.0;
if (pmodel_old == n_sure || pmodel_old == n_sure + n){
MH = random_walk(model, vars, n);
MH = 1.0 - problocal;
}
else {
if (unif_rand() < problocal) {
// random
MH = random_switch(model, vars, n, pmodel_old, varin, varout );
}
else {
// Randomw walk proposal flip bit//
MH = random_walk(model, vars, n);
}
}
branch = tree;
newmodel= 0;
for (i = 0; i< n; i++) {
bit = model[vars[i].index];
if (bit == 1) {
if (branch->one != NULL) branch = branch->one;
else newmodel = 1;
}
else {
if (branch->zero != NULL) branch = branch->zero;
else newmodel = 1.0;
}
pmodel += bit;
}
if (pmodel == n_sure || pmodel == n + n_sure) MH = 1.0/(1.0 - problocal);
if (newmodel == 1) {
new_loc = nUnique;
PROTECT(Rmodel_m = allocVector(INTSXP,pmodel));
model_m = INTEGER(Rmodel_m);
for (j = 0, l=0; j < p; j++) {
if (model[j] == 1) {
model_m[l] = j;
l +=1;}
}
Rcoef_m = NEW_NUMERIC(pmodel); PROTECT(Rcoef_m);
Rse_m = NEW_NUMERIC(pmodel); PROTECT(Rse_m);
coefficients = REAL(Rcoef_m);
se_m = REAL(Rse_m);
for (j=0, l=0; j < pmodel; j++) {
XtYwork[j] = XtY[model_m[j]];
for ( i = 0; i < pmodel; i++) {
XtXwork[j*pmodel + i] = XtX[model_m[j]*p + model_m[i]];
}
}
R2_m = 0.0;
mse_m = yty;
memcpy(coefficients, XtYwork, sizeof(double)*pmodel);
cholreg(XtYwork, XtXwork, coefficients, se_m, &mse_m, pmodel, nobs);
if (pmodel > 1) R2_m = 1.0 - (mse_m * (double) ( nobs - pmodel))/SSY;
prior_m = compute_prior_probs(model,pmodel,p, modelprior);
gexpectations(p, pmodel, nobs, R2_m, alpha, INTEGER(method)[0], RSquareFull, SSY, &logmargy, &shrinkage_m);
postnew = logmargy + log(prior_m);
}
else {
new_loc = branch->where;
postnew = REAL(logmarg)[new_loc] + log(REAL(priorprobs)[new_loc]);
}
MH *= exp(postnew - postold);
// Rprintf("MH new %lf old %lf\n", postnew, postold);
if (unif_rand() < MH) {
if (newmodel == 1) {
new_loc = nUnique;
insert_model_tree(tree, vars, n, model, nUnique);
INTEGER(modeldim)[nUnique] = pmodel;
SET_ELEMENT(modelspace, nUnique, Rmodel_m);
SET_ELEMENT(beta, nUnique, Rcoef_m);
SET_ELEMENT(se, nUnique, Rse_m);
REAL(R2)[nUnique] = R2_m;
REAL(mse)[nUnique] = mse_m;
REAL(sampleprobs)[nUnique] = 1.0;
REAL(logmarg)[nUnique] = logmargy;
REAL(shrinkage)[nUnique] = shrinkage_m;
REAL(priorprobs)[nUnique] = prior_m;
UNPROTECT(3);
++nUnique;
}
old_loc = new_loc;
postold = postnew;
pmodel_old = pmodel;
memcpy(modelold, model, sizeof(int)*p);
}
else {
if (newmodel == 1) UNPROTECT(3);
}
INTEGER(counts)[old_loc] += 1;
for (i = 0; i < n; i++) {
/* store in opposite order so nth variable is first */
real_model[n-1-i] = (double) modelold[vars[i].index];
REAL(MCMCprobs)[vars[i].index] += (double) modelold[vars[i].index];
}
// Update SSgam = gamma gamma^T + SSgam
F77_NAME(dsyr)("U", &n, &one, &real_model[0], &inc, &SSgam[0], &n);
m++;
}
for (i = 0; i < n; i++) {
REAL(MCMCprobs)[vars[i].index] /= (double) m;
}
// Rprintf("\n%d \n", nUnique);
// Compute marginal probabilities
mcurrent = nUnique;
compute_modelprobs(modelprobs, logmarg, priorprobs,mcurrent);
compute_margprobs(modelspace, modeldim, modelprobs, probs, mcurrent, p);
// Now sample W/O Replacement
// Rprintf("NumUnique Models Accepted %d \n", nUnique);
INTEGER(NumUnique)[0] = nUnique;
if (nUnique < k) {
update_probs(probs, vars, mcurrent, k, p);
update_tree(modelspace, tree, modeldim, vars, k,p,n,mcurrent, modelwork);
for (m = nUnique; m < k; m++) {
for (i = n; i < p; i++) {
INTEGER(modeldim)[m] += model[vars[i].index];
}
branch = tree;
for (i = 0; i< n; i++) {
pigamma[i] = 1.0;
bit = withprob(branch->prob);
/* branch->done += 1; */
if (bit == 1) {
for (j=0; j<=i; j++) pigamma[j] *= branch->prob;
if (i < n-1 && branch->one == NULL)
branch->one = make_node(vars[i+1].prob);
if (i == n-1 && branch->one == NULL)
branch->one = make_node(0.0);
branch = branch->one;
}
else {
for (j=0; j<=i; j++) pigamma[j] *= (1.0 - branch->prob);
if (i < n-1 && branch->zero == NULL)
branch->zero = make_node(vars[i+1].prob);
if (i == n-1 && branch->zero == NULL)
branch->zero = make_node(0.0);
branch = branch->zero;
}
model[vars[i].index] = bit;
INTEGER(modeldim)[m] += bit;
}
REAL(sampleprobs)[m] = pigamma[0];
pmodel = INTEGER(modeldim)[m];
/* Now subtract off the visited probability mass. */
branch=tree;
for (i = 0; i < n; i++) {
bit = model[vars[i].index];
prone = branch->prob;
if (bit == 1) prone -= pigamma[i];
denom = 1.0 - pigamma[i];
if (denom <= 0.0) {
if (denom < 0.0) {
warning("neg denominator %le %le %le !!!\n", pigamma, denom, prone);
if (branch->prob < 0.0 && branch->prob < 1.0)
warning("non extreme %le\n", branch->prob);}
denom = 0.0;}
else {
if (prone <= 0) prone = 0.0;
if (prone > denom) {
if (prone <= eps) prone = 0.0;
else prone = 1.0;
/* Rprintf("prone > 1 %le %le %le %le !!!\n", pigamma, denom, prone, eps);*/
}
else prone = prone/denom;
}
if (prone > 1.0 || prone < 0.0)
Rprintf("%d %d Probability > 1!!! %le %le %le %le \n",
m, i, prone, branch->prob, denom, pigamma);
/* if (bit == 1) pigamma /= (branch->prob);
else pigamma /= (1.0 - branch->prob);
if (pigamma > 1.0) pigamma = 1.0; */
branch->prob = prone;
if (bit == 1) branch = branch->one;
else branch = branch->zero;
/* Rprintf("%d %d \n", branch->done, n - i); */
/* if (log((double) branch->done) < (n - i)*log(2.0)) {
if (bit == 1) branch = branch->one;
else branch = branch->zero;
}
else {
branch->one = NULL;
branch->zero = NULL;
break; } */
}
/* Now get model specific calculations */
PROTECT(Rmodel_m = allocVector(INTSXP, pmodel));
model_m = INTEGER(Rmodel_m);
for (j = 0, l=0; j < p; j++) {
if (model[j] == 1) {
model_m[l] = j;
l +=1;}
}
SET_ELEMENT(modelspace, m, Rmodel_m);
for (j=0, l=0; j < pmodel; j++) {
XtYwork[j] = XtY[model_m[j]];
for ( i = 0; i < pmodel; i++) {
XtXwork[j*pmodel + i] = XtX[model_m[j]*p + model_m[i]];
}
}
PROTECT(Rcoef_m = allocVector(REALSXP,pmodel));
PROTECT(Rse_m = allocVector(REALSXP,pmodel));
coefficients = REAL(Rcoef_m);
se_m = REAL(Rse_m);
mse_m = yty;
memcpy(coefficients, XtYwork, sizeof(double)*pmodel);
cholreg(XtYwork, XtXwork, coefficients, se_m, &mse_m, pmodel, nobs);
/* olsreg(Ywork, Xwork, coefficients, se_m, &mse_m, &pmodel, &nobs, pivot,qraux,work,residuals,effects,v,betaols); */
if (pmodel > 1) R2_m = 1.0 - (mse_m * (double) ( nobs - pmodel))/SSY;
SET_ELEMENT(beta, m, Rcoef_m);
SET_ELEMENT(se, m, Rse_m);
REAL(R2)[m] = R2_m;
REAL(mse)[m] = mse_m;
gexpectations(p, pmodel, nobs, R2_m, alpha, INTEGER(method)[0], RSquareFull, SSY, &logmargy, &shrinkage_m);
REAL(logmarg)[m] = logmargy;
REAL(shrinkage)[m] = shrinkage_m;
REAL(priorprobs)[m] = compute_prior_probs(model,pmodel,p, modelprior);
if (m > 1) {
rem = modf((double) m/(double) update, &mod);
if (rem == 0.0) {
mcurrent = m;
compute_modelprobs(modelprobs, logmarg, priorprobs,mcurrent);
compute_margprobs(modelspace, modeldim, modelprobs, probs, mcurrent, p);
if (update_probs(probs, vars, mcurrent, k, p) == 1) {
// Rprintf("Updating Model Tree %d \n", m);
update_tree(modelspace, tree, modeldim, vars, k,p,n,mcurrent, modelwork);
}
}}
UNPROTECT(3);
}
}
compute_modelprobs(modelprobs, logmarg, priorprobs,k);
compute_margprobs(modelspace, modeldim, modelprobs, probs, k, p);
SET_VECTOR_ELT(ANS, 0, Rprobs);
SET_STRING_ELT(ANS_names, 0, mkChar("probne0"));
SET_VECTOR_ELT(ANS, 1, modelspace);
SET_STRING_ELT(ANS_names, 1, mkChar("which"));
SET_VECTOR_ELT(ANS, 2, logmarg);
SET_STRING_ELT(ANS_names, 2, mkChar("logmarg"));
SET_VECTOR_ELT(ANS, 3, modelprobs);
SET_STRING_ELT(ANS_names, 3, mkChar("postprobs"));
SET_VECTOR_ELT(ANS, 4, priorprobs);
SET_STRING_ELT(ANS_names, 4, mkChar("priorprobs"));
SET_VECTOR_ELT(ANS, 5,sampleprobs);
SET_STRING_ELT(ANS_names, 5, mkChar("sampleprobs"));
SET_VECTOR_ELT(ANS, 6, mse);
SET_STRING_ELT(ANS_names, 6, mkChar("mse"));
SET_VECTOR_ELT(ANS, 7, beta);
SET_STRING_ELT(ANS_names, 7, mkChar("mle"));
SET_VECTOR_ELT(ANS, 8, se);
SET_STRING_ELT(ANS_names, 8, mkChar("mle.se"));
SET_VECTOR_ELT(ANS, 9, shrinkage);
SET_STRING_ELT(ANS_names, 9, mkChar("shrinkage"));
SET_VECTOR_ELT(ANS, 10, modeldim);
SET_STRING_ELT(ANS_names, 10, mkChar("size"));
SET_VECTOR_ELT(ANS, 11, R2);
SET_STRING_ELT(ANS_names, 11, mkChar("R2"));
SET_VECTOR_ELT(ANS, 12, counts);
SET_STRING_ELT(ANS_names, 12, mkChar("freq"));
SET_VECTOR_ELT(ANS, 13, MCMCprobs);
SET_STRING_ELT(ANS_names, 13, mkChar("probs.MCMC"));
SET_VECTOR_ELT(ANS, 14, NumUnique);
SET_STRING_ELT(ANS_names, 14, mkChar("n.Unique"));
setAttrib(ANS, R_NamesSymbol, ANS_names);
UNPROTECT(nProtected);
// Rprintf("Return\n");
PutRNGstate();
return(ANS);
}
