static VALUE rb_gsl_sf_coupling_6j(VALUE obj, VALUE two_ja, VALUE two_jb, VALUE two_jc, VALUE two_jd, VALUE two_je, VALUE two_jf)
{
CHECK_FIXNUM(two_ja); CHECK_FIXNUM(two_jb); CHECK_FIXNUM(two_jc);
CHECK_FIXNUM(two_jd); CHECK_FIXNUM(two_je); CHECK_FIXNUM(two_jf);
return rb_float_new(gsl_sf_coupling_6j(FIX2INT(two_ja), FIX2INT(two_jb),
FIX2INT(two_jc), FIX2INT(two_jd),
FIX2INT(two_je), FIX2INT(two_jf)));
}
void CheMPS2::TensorX::addTermDRight(const int ikappa, TensorT * denT, TensorOperator * denD, double * workmemLR){
int dimR = denBK->gCurrentDim(index, sectorN1[ikappa], sectorTwoS1[ikappa], sectorI1[ikappa]);
const int IL = Irreps::directProd( sectorI1[ikappa], denBK->gIrrep(index-1) );
const int NL = sectorN1[ikappa]-1;
for (int geval=0; geval<4; geval++){
int TwoSLup, TwoSLdown;
switch(geval){
case 0:
TwoSLup = sectorTwoS1[ikappa]-1;
TwoSLdown = sectorTwoS1[ikappa]-1;
break;
case 1:
TwoSLup = sectorTwoS1[ikappa]+1;
TwoSLdown = sectorTwoS1[ikappa]-1;
break;
case 2:
TwoSLup = sectorTwoS1[ikappa]-1;
TwoSLdown = sectorTwoS1[ikappa]+1;
break;
case 3:
TwoSLup = sectorTwoS1[ikappa]+1;
TwoSLdown = sectorTwoS1[ikappa]+1;
break;
}
int dimLup = denBK->gCurrentDim(index-1,NL,TwoSLup, IL);
int dimLdown = denBK->gCurrentDim(index-1,NL,TwoSLdown,IL);
if ((dimLup>0) && (dimLdown>0)){
double * BlockD = denD->gStorage(NL,TwoSLdown,IL,NL,TwoSLup,IL);
double * BlockTup = denT->gStorage(NL,TwoSLup, IL,sectorN1[ikappa],sectorTwoS1[ikappa],sectorI1[ikappa]);
double * BlockTdown = (TwoSLup==TwoSLdown)? BlockTup : denT->gStorage(NL,TwoSLdown,IL,sectorN1[ikappa],sectorTwoS1[ikappa],sectorI1[ikappa]);
int fase = ((((TwoSLdown + sectorTwoS1[ikappa] + 1)/2)%2)!=0)?-1:1;
double factor = fase * sqrt(3.0 * (TwoSLup+1)) * gsl_sf_coupling_6j(1,1,2,TwoSLup,TwoSLdown,sectorTwoS1[ikappa]);
double beta = 0.0; //set
char totrans = 'T';
dgemm_(&totrans, &totrans, &dimR, &dimLdown, &dimLup, &factor, BlockTup, &dimLup, BlockD, &dimLdown, &beta, workmemLR, &dimR);
totrans = 'N';
factor = 1.0;
beta = 1.0; //add
dgemm_(&totrans, &totrans, &dimR, &dimR, &dimLdown, &factor, workmemLR, &dimR, BlockTdown, &dimLdown, &beta, storage+kappa2index[ikappa], &dimR);
}
}
}
void CheMPS2::TensorS1::makenewRight(TensorL * denL, TensorT * denT, double * workmem){
clear();
for (int ikappa=0; ikappa<nKappa; ikappa++){
const int IDR = Irreps::directProd(n_irrep,sectorI1[ikappa]);
int dimUR = denBK->gCurrentDim(index, sectorN1[ikappa], sectorTwoS1[ikappa], sectorI1[ikappa]);
int dimDR = denBK->gCurrentDim(index, sectorN1[ikappa]+2, sector_2S_down[ikappa], IDR );
for (int geval=0; geval<4; geval++){
int NLU,TwoSLU,ILU,TwoSLD,ILD; //NLD = NLU+1
switch(geval){
case 0:
NLU = sectorN1[ikappa];
TwoSLU = sectorTwoS1[ikappa];
ILU = sectorI1[ikappa];
TwoSLD = sector_2S_down[ikappa]-1;
ILD = Irreps::directProd( ILU, denL->get_irrep() );
break;
case 1:
NLU = sectorN1[ikappa];
TwoSLU = sectorTwoS1[ikappa];
ILU = sectorI1[ikappa];
TwoSLD = sector_2S_down[ikappa]+1;
ILD = Irreps::directProd( ILU, denL->get_irrep() );
break;
case 2:
NLU = sectorN1[ikappa]-1;
TwoSLU = sectorTwoS1[ikappa]-1;
ILU = Irreps::directProd( sectorI1[ikappa] , denBK->gIrrep(index-1) );
TwoSLD = sector_2S_down[ikappa];
ILD = IDR;
break;
case 3:
NLU = sectorN1[ikappa]-1;
TwoSLU = sectorTwoS1[ikappa]+1;
ILU = Irreps::directProd( sectorI1[ikappa] , denBK->gIrrep(index-1) );
TwoSLD = sector_2S_down[ikappa];
ILD = IDR;
break;
}
int dimLU = denBK->gCurrentDim(index-1, NLU, TwoSLU, ILU);
int dimLD = denBK->gCurrentDim(index-1, NLU+1, TwoSLD, ILD);
if ((dimLU>0) && (dimLD>0) && (abs(TwoSLU-TwoSLD)<2)){
double * BlockTup = denT->gStorage(NLU, TwoSLU, ILU, sectorN1[ikappa], sectorTwoS1[ikappa], sectorI1[ikappa]);
double * BlockTdown = denT->gStorage(NLU+1, TwoSLD, ILD, sectorN1[ikappa]+2, sector_2S_down[ikappa], IDR );
double * BlockL = denL->gStorage(NLU, TwoSLU, ILU, NLU+1, TwoSLD, ILD );
//factor * Tup^T * L -> mem
char trans = 'T';
char notrans = 'N';
double alpha = 1.0;
if (geval<=1){
int fase = ((((sectorTwoS1[ikappa] + sector_2S_down[ikappa] + 2)/2)%2)!=0)?-1:1;
alpha = fase * sqrt(3.0*(TwoSLD+1)) * gsl_sf_coupling_6j(1,1,2,sectorTwoS1[ikappa],sector_2S_down[ikappa],TwoSLD);
} else {
int fase = ((((TwoSLU + sector_2S_down[ikappa] + 1)/2)%2)!=0)?-1:1;
alpha = fase * sqrt(3.0*(sectorTwoS1[ikappa]+1)) * gsl_sf_coupling_6j(1,1,2,sectorTwoS1[ikappa],sector_2S_down[ikappa],TwoSLU);
}
double beta = 0.0; //set
dgemm_(&trans,¬rans,&dimUR,&dimLD,&dimLU,&alpha,BlockTup,&dimLU,BlockL,&dimLU,&beta,workmem,&dimUR);
//mem * Tdown -> storage
alpha = 1.0;
beta = 1.0; // add
dgemm_(¬rans,¬rans,&dimUR,&dimDR,&dimLD,&alpha,workmem,&dimUR,BlockTdown,&dimLD,&beta,storage+kappa2index[ikappa],&dimUR);
}
}
}
}
void CheMPS2::TensorS1::makenewLeft(TensorL * denL, TensorT * denT, double * workmem){
clear();
for (int ikappa=0; ikappa<nKappa; ikappa++){
const int IDL = Irreps::directProd(n_irrep,sectorI1[ikappa]);
int dimUL = denBK->gCurrentDim(index, sectorN1[ikappa], sectorTwoS1[ikappa], sectorI1[ikappa]);
int dimDL = denBK->gCurrentDim(index, sectorN1[ikappa]+2, sector_2S_down[ikappa], IDL );
for (int geval=0; geval<4; geval++){
int NRU,TwoSRU,IRU,TwoSRD,IRD; //NRD = NRU+1
switch(geval){
case 0:
NRU = sectorN1[ikappa]+1;
TwoSRU = sectorTwoS1[ikappa]-1;
IRU = Irreps::directProd( sectorI1[ikappa] , denBK->gIrrep(index) );
TwoSRD = sector_2S_down[ikappa];
IRD = IDL;
break;
case 1:
NRU = sectorN1[ikappa]+1;
TwoSRU = sectorTwoS1[ikappa]+1;
IRU = Irreps::directProd( sectorI1[ikappa] , denBK->gIrrep(index) );
TwoSRD = sector_2S_down[ikappa];
IRD = IDL;
break;
case 2:
NRU = sectorN1[ikappa]+2;
TwoSRU = sectorTwoS1[ikappa];
IRU = sectorI1[ikappa];
TwoSRD = sector_2S_down[ikappa]-1;
IRD = Irreps::directProd( sectorI1[ikappa] , denL->get_irrep() );
break;
case 3:
NRU = sectorN1[ikappa]+2;
TwoSRU = sectorTwoS1[ikappa];
IRU = sectorI1[ikappa];
TwoSRD = sector_2S_down[ikappa]+1;
IRD = Irreps::directProd( sectorI1[ikappa] , denL->get_irrep() );
break;
}
int dimRU = denBK->gCurrentDim(index+1, NRU, TwoSRU, IRU);
int dimRD = denBK->gCurrentDim(index+1, NRU+1, TwoSRD, IRD);
if ((dimRU>0) && (dimRD>0) && (abs(TwoSRD-TwoSRU)<2)){
double * BlockTup = denT->gStorage(sectorN1[ikappa], sectorTwoS1[ikappa], sectorI1[ikappa], NRU, TwoSRU, IRU);
double * BlockTdown = denT->gStorage(sectorN1[ikappa]+2, sector_2S_down[ikappa], IDL, NRU+1, TwoSRD, IRD);
double * BlockL = denL->gStorage(NRU, TwoSRU, IRU, NRU+1, TwoSRD, IRD);
//factor * Tup * L -> mem
char notrans = 'N';
double alpha = 1.0;
if (geval<=1){
int fase = ((((sectorTwoS1[ikappa] + sector_2S_down[ikappa] + 2)/2)%2)!=0)?-1:1;
alpha = fase * sqrt(3.0 * (TwoSRU+1)) * gsl_sf_coupling_6j(1,1,2,sectorTwoS1[ikappa],sector_2S_down[ikappa],TwoSRU);
} else {
int fase = ((((sectorTwoS1[ikappa] + TwoSRD + 1)/2)%2)!=0)?-1:1;
alpha = fase * sqrt(3.0 / (sector_2S_down[ikappa] + 1.0)) * (TwoSRD + 1) * gsl_sf_coupling_6j(1,1,2,sectorTwoS1[ikappa],sector_2S_down[ikappa],TwoSRD);
}
double beta = 0.0; //set
dgemm_(¬rans,¬rans,&dimUL,&dimRD,&dimRU,&alpha,BlockTup,&dimUL,BlockL,&dimRU,&beta,workmem,&dimUL);
//mem * Tdown -> storage
char trans = 'T';
alpha = 1.0;
beta = 1.0; // add
dgemm_(¬rans,&trans,&dimUL,&dimDL,&dimRD,&alpha,workmem,&dimUL,BlockTdown,&dimDL,&beta,storage+kappa2index[ikappa],&dimUL);
}
}
}
}
/**
* C++ version of gsl_sf_coupling_6j().
* @param two_ja Coupling coefficient in half-integer units
* @param two_jb Coupling coefficient in half-integer units
* @param two_jc Coupling coefficient in half-integer units
* @param two_jd Coupling coefficient in half-integer units
* @param two_je Coupling coefficient in half-integer units
* @param two_jf Coupling coefficient in half-integer units
* @return The Wigner 6-j coefficient
*/
inline double coupling_6j( int two_ja, int two_jb, int two_jc, int two_jd, int two_je, int two_jf ){
return gsl_sf_coupling_6j( two_ja, two_jb, two_jc, two_jd, two_je, two_jf ); }
PetscReal wigner6j(int a, int b, int c, int d, int e, int f) {
return gsl_sf_coupling_6j(2*a, 2*b, 2*c, 2*d, 2*e, 2*f);
}
void CheMPS2::Heff::addDiagram3J(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorQ ** Qright, TensorL ** Lleft, double * temp) const{
#ifdef CHEMPS2_MPI_COMPILATION
const int MPIRANK = MPIchemps2::mpi_rank();
#endif
int NL = denS->gNL(ikappa);
int TwoSL = denS->gTwoSL(ikappa);
int IL = denS->gIL(ikappa);
int N1 = denS->gN1(ikappa);
int N2 = denS->gN2(ikappa);
int TwoJ = denS->gTwoJ(ikappa);
int NR = denS->gNR(ikappa);
int TwoSR = denS->gTwoSR(ikappa);
int IR = denS->gIR(ikappa);
int theindex = denS->gIndex();
int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
int dimLup = denBK->gCurrentDim(theindex, NL,TwoSL,IL);
//First do 3J2
for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
if ((abs(TwoSLdown-TwoSRdown)<=TwoJ) && (TwoSLdown>=0) && (TwoSRdown>=0)){
int fase = phase(TwoSLdown+TwoSR+TwoJ+1 + ((N1==1)?2:0) + ((N2==1)?2:0) );
const double factor = fase * sqrt((TwoSLdown+1)*(TwoSRdown+1.0)) * gsl_sf_coupling_6j(TwoSL,TwoSR,TwoJ,TwoSRdown,TwoSLdown,1);
for (int l_index=0; l_index<theindex; l_index++){
#ifdef CHEMPS2_MPI_COMPILATION
if ( MPIchemps2::owner_q( Prob->gL(), l_index ) == MPIRANK )
#endif
{
int ILdown = Irreps::directProd(IL,denBK->gIrrep(l_index));
int IRdown = Irreps::directProd(IR,denBK->gIrrep(l_index));
int memSkappa = denS->gKappa(NL+1, TwoSLdown, ILdown, N1, N2, TwoJ, NR+1, TwoSRdown, IRdown);
if (memSkappa!=-1){
int dimRdown = denBK->gCurrentDim(theindex+2, NR+1, TwoSRdown, IRdown);
int dimLdown = denBK->gCurrentDim(theindex, NL+1, TwoSLdown, ILdown);
double * Lblock = Lleft[ theindex-1-l_index]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
double * Qblock = Qright[theindex+1-l_index]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
char trans = 'T';
char notra = 'N';
double beta = 0.0; //set
double alpha = factor;
dgemm_(¬ra,¬ra,&dimLup,&dimRdown,&dimLdown,&alpha,Lblock,&dimLup,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,temp,&dimLup);
beta = 1.0; //add
alpha = 1.0;
dgemm_(¬ra,&trans,&dimLup,&dimRup,&dimRdown,&alpha,temp,&dimLup,Qblock,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
}
}
}
}
}
}
//Then do 3J1
for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
if ((abs(TwoSLdown-TwoSRdown)<=TwoJ) && (TwoSLdown>=0) && (TwoSRdown>=0)){
int fase = phase(TwoSL+TwoSRdown+TwoJ+1 + ((N1==1)?2:0) + ((N2==1)?2:0) );
const double factor = fase * sqrt((TwoSL+1)*(TwoSR+1.0)) * gsl_sf_coupling_6j(TwoSL,TwoSR,TwoJ,TwoSRdown,TwoSLdown,1);
for (int l_index=0; l_index<theindex; l_index++){
#ifdef CHEMPS2_MPI_COMPILATION
if ( MPIchemps2::owner_q( Prob->gL(), l_index ) == MPIRANK )
#endif
{
int ILdown = Irreps::directProd(IL,denBK->gIrrep(l_index));
int IRdown = Irreps::directProd(IR,denBK->gIrrep(l_index));
int memSkappa = denS->gKappa(NL-1, TwoSLdown, ILdown, N1, N2, TwoJ, NR-1, TwoSRdown, IRdown);
if (memSkappa!=-1){
int dimRdown = denBK->gCurrentDim(theindex+2, NR-1, TwoSRdown, IRdown);
int dimLdown = denBK->gCurrentDim(theindex, NL-1, TwoSLdown, ILdown);
double * Lblock = Lleft[ theindex-1-l_index]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
double * Qblock = Qright[theindex+1-l_index]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
char trans = 'T';
char notra = 'N';
double beta = 0.0; //set
double alpha = factor;
dgemm_(&trans,¬ra,&dimLup,&dimRdown,&dimLdown,&alpha,Lblock,&dimLdown,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,temp,&dimLup);
beta = 1.0; //add
alpha = 1.0;
dgemm_(¬ra,¬ra,&dimLup,&dimRup,&dimRdown,&alpha,temp,&dimLup,Qblock,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
}
}
}
}
}
}
}
void CheMPS2::Heff::addDiagram3Land3G(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorQ * Qright, TensorL ** Lright, double * temp) const{
int NL = denS->gNL(ikappa);
int TwoSL = denS->gTwoSL(ikappa);
int IL = denS->gIL(ikappa);
int N1 = denS->gN1(ikappa);
int N2 = denS->gN2(ikappa);
int TwoJ = denS->gTwoJ(ikappa);
int NR = denS->gNR(ikappa);
int TwoSR = denS->gTwoSR(ikappa);
int IR = denS->gIR(ikappa);
int theindex = denS->gIndex();
int IRdown = Irreps::directProd(IR,denBK->gIrrep(theindex+1));
int TwoS1 = (N1==1)?1:0;
int dimL = denBK->gCurrentDim(theindex, NL,TwoSL,IL);
int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
if (N2==1){ //3L1A
for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
if ((abs(TwoSL-TwoSRdown)<=TwoS1) && (TwoSRdown>=0)){
int dimRdown = denBK->gCurrentDim(theindex+2, NR-1, TwoSRdown, IRdown);
int memSkappa = denS->gKappa(NL,TwoSL,IL,N1,0,TwoS1,NR-1,TwoSRdown,IRdown);
if (memSkappa!=-1){
int fase = phase(TwoSL+TwoSR+TwoS1+1);
double factor = sqrt((TwoJ+1)*(TwoSR+1.0)) * fase * gsl_sf_coupling_6j(TwoS1,TwoJ,1,TwoSR,TwoSRdown,TwoSL);
double beta = 1.0; //add
char notr = 'N';
double * BlockQ = Qright->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
dgemm_(¬r,¬r,&dimL,&dimRup,&dimRdown,&factor,memS+denS->gKappa2index(memSkappa),&dimL,BlockQ,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimL);
}
}
}
}
if (N2==2){ //3L1B and 3G1
for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
int dimRdown = denBK->gCurrentDim(theindex+2, NR-1, TwoSRdown, IRdown);
if (dimRdown>0){
int TwoJstart = ((TwoSRdown!=TwoSL) || (TwoS1==0)) ? 1 + TwoS1 : 0;
for (int TwoJdown=TwoJstart; TwoJdown<=1+TwoS1; TwoJdown+=2){
if (abs(TwoSL-TwoSRdown)<=TwoJdown){
int memSkappa = denS->gKappa(NL,TwoSL,IL,N1,1,TwoJdown,NR-1,TwoSRdown,IRdown);
if (memSkappa!=-1){
int fase = phase(TwoSL+TwoSR+TwoS1+2);
double factor = sqrt((TwoJdown+1)*(TwoSR+1.0)) * fase * gsl_sf_coupling_6j(TwoJdown,TwoS1,1,TwoSR,TwoSRdown,TwoSL);
double beta = 1.0; //add
char notr = 'N';
double * BlockQ = Qright->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
int inc = 1;
int size = dimRup * dimRdown;
dcopy_(&size,BlockQ,&inc,temp,&inc);
for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
if (denBK->gIrrep(l_index) == denBK->gIrrep(theindex+1)){
double alpha = Prob->gMxElement(theindex+1,theindex+1,theindex+1,l_index);
double * BlockL = Lright[l_index-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
daxpy_(&size, &alpha, BlockL, &inc, temp, &inc);
}
}
dgemm_(¬r,¬r,&dimL,&dimRup,&dimRdown,&factor,memS+denS->gKappa2index(memSkappa),&dimL,temp,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimL);
}
}
}
}
}
}
if (N2==0){ //3L2A
for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
int dimRdown = denBK->gCurrentDim(theindex+2, NR+1, TwoSRdown, IRdown);
if (dimRdown>0){
int TwoJstart = ((TwoSRdown!=TwoSL) || (TwoS1==0)) ? 1 + TwoS1 : 0;
for (int TwoJdown=TwoJstart; TwoJdown<=1+TwoS1; TwoJdown+=2){
if (abs(TwoSL-TwoSRdown)<=TwoJdown){
int memSkappa = denS->gKappa(NL,TwoSL,IL,N1,1,TwoJdown,NR+1,TwoSRdown,IRdown);
if (memSkappa!=-1){
int fase = phase(TwoSL+TwoSRdown+TwoS1+1);
double factor = sqrt((TwoJdown+1)*(TwoSRdown+1.0)) * fase * gsl_sf_coupling_6j(TwoJdown,TwoS1,1,TwoSR,TwoSRdown,TwoSL);
double beta = 1.0; //add
char notr = 'N';
char tran = 'T';
double * BlockQ = Qright->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
dgemm_(¬r,&tran,&dimL,&dimRup,&dimRdown,&factor,memS+denS->gKappa2index(memSkappa),&dimL,BlockQ,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa),&dimL);
}
}
}
}
}
}
if (N2==1){ //3L2B and 3G2
for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
if ((abs(TwoSL-TwoSRdown)<=TwoS1) && (TwoSRdown>=0)){
int dimRdown = denBK->gCurrentDim(theindex+2, NR+1, TwoSRdown, IRdown);
int memSkappa = denS->gKappa(NL,TwoSL,IL,N1,2,TwoS1,NR+1,TwoSRdown,IRdown);
if (memSkappa!=-1){
int fase = phase(TwoSL+TwoSRdown+TwoS1+2);
double factor = sqrt((TwoJ+1)*(TwoSRdown+1.0)) * fase * gsl_sf_coupling_6j(TwoS1,TwoJ,1,TwoSR,TwoSRdown,TwoSL);
double beta = 1.0; //add
char notr = 'N';
char tran = 'T';
double * BlockQ = Qright->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
int inc = 1;
int size = dimRup * dimRdown;
dcopy_(&size,BlockQ,&inc,temp,&inc);
for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
if (denBK->gIrrep(l_index) == denBK->gIrrep(theindex+1)){
double alpha = Prob->gMxElement(theindex+1,theindex+1,theindex+1,l_index);
double * BlockL = Lright[l_index-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
daxpy_(&size, &alpha, BlockL, &inc, temp, &inc);
}
}
dgemm_(¬r,&tran,&dimL,&dimRup,&dimRdown,&factor,memS+denS->gKappa2index(memSkappa),&dimL,temp,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa),&dimL);
}
}
}
}
}
void CheMPS2::Heff::addDiagram3Aand3D(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorQ * Qleft, TensorL ** Lleft, double * temp) const{
int NL = denS->gNL(ikappa);
int TwoSL = denS->gTwoSL(ikappa);
int IL = denS->gIL(ikappa);
int N1 = denS->gN1(ikappa);
int N2 = denS->gN2(ikappa);
int TwoJ = denS->gTwoJ(ikappa);
int NR = denS->gNR(ikappa);
int TwoSR = denS->gTwoSR(ikappa);
int IR = denS->gIR(ikappa);
int theindex = denS->gIndex();
int ILdown = Irreps::directProd(IL,denBK->gIrrep(theindex));
int TwoS2 = (N2==1)?1:0;
int dimR = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
int dimLup = denBK->gCurrentDim(theindex,NL,TwoSL,IL);
if (N1==2){ //3A1A and 3D1
for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
int dimLdown = denBK->gCurrentDim(theindex, NL+1, TwoSLdown, ILdown);
if (dimLdown>0){
int TwoJstart = ((TwoSR!=TwoSLdown) || (TwoS2==0)) ? 1 + TwoS2 : 0;
for (int TwoJdown=TwoJstart; TwoJdown<=1+TwoS2; TwoJdown+=2){
if (abs(TwoSLdown-TwoSR)<=TwoJdown){
int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,1,N2,TwoJdown,NR,TwoSR,IR);
if (memSkappa!=-1){
int fase = phase(TwoSL+TwoSR+2+TwoS2);
double factor = sqrt((TwoJdown+1)*(TwoSLdown+1.0))*fase*gsl_sf_coupling_6j(TwoJdown,TwoS2,1,TwoSL,TwoSLdown,TwoSR);
double beta = 1.0; //add
char notr = 'N';
double * BlockQ = Qleft->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
int inc = 1;
int size = dimLup * dimLdown;
dcopy_(&size, BlockQ, &inc, temp, &inc);
for (int l_index=0; l_index<theindex; l_index++){
if (denBK->gIrrep(l_index) == denBK->gIrrep(theindex)){
double alpha = Prob->gMxElement(l_index,theindex,theindex,theindex);
double * BlockL = Lleft[theindex-1-l_index]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
daxpy_(&size, &alpha, BlockL, &inc, temp, &inc);
}
}
dgemm_(¬r,¬r,&dimLup,&dimR,&dimLdown,&factor,temp,&dimLup,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
}
}
}
}
}
}
if (N1==1){ //3A1B
for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
if ((abs(TwoSLdown-TwoSR)<=TwoS2) && (TwoSLdown>=0)){
int dimLdown = denBK->gCurrentDim(theindex, NL+1, TwoSLdown, ILdown);
int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,0,N2,TwoS2,NR,TwoSR,IR);
if (memSkappa!=-1){
int fase = phase(TwoSL+TwoSR+1+TwoS2);
double factor = sqrt((TwoSLdown+1)*(TwoJ+1.0))*fase*gsl_sf_coupling_6j(TwoS2,TwoJ,1,TwoSL,TwoSLdown,TwoSR);
double beta = 1.0;
char notr = 'N';
double * BlockQ = Qleft->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
dgemm_(¬r,¬r,&dimLup,&dimR,&dimLdown,&factor,BlockQ,&dimLup,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
}
}
}
}
if (N1==0){ //3A2A
for (int TwoSLdown=TwoSL-1;TwoSLdown<=TwoSL+1;TwoSLdown+=2){
int dimLdown = denBK->gCurrentDim(theindex, NL-1, TwoSLdown, ILdown);
if (dimLdown>0){
int TwoJstart = ((TwoSR!=TwoSLdown) || (TwoS2==0)) ? 1 + TwoS2 : 0;
for (int TwoJdown=TwoJstart; TwoJdown<=1+TwoS2; TwoJdown+=2){
if (abs(TwoSLdown-TwoSR)<=TwoJdown){
int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,1,N2,TwoJdown,NR,TwoSR,IR);
if (memSkappa!=-1){
int fase = phase(TwoSLdown+TwoSR+1+TwoS2);
double factor = fase*sqrt((TwoSL+1)*(TwoJdown+1.0))*gsl_sf_coupling_6j(TwoJdown,TwoS2,1,TwoSL,TwoSLdown,TwoSR);
double beta = 1.0;
char notr = 'N';
char trans = 'T';
double * BlockQ = Qleft->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
dgemm_(&trans,¬r,&dimLup,&dimR,&dimLdown,&factor,BlockQ,&dimLdown,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
}
}
}
}
}
}
if (N1==1){ //3A2B ans 3D2
for (int TwoSLdown=TwoSL-1;TwoSLdown<=TwoSL+1;TwoSLdown+=2){
if ((abs(TwoSLdown-TwoSR)<=TwoS2) && (TwoSLdown>=0)){
int dimLdown = denBK->gCurrentDim(theindex, NL-1, TwoSLdown, ILdown);
int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,2,N2,TwoS2,NR,TwoSR,IR);
if (memSkappa!=-1){
int fase = phase(TwoSLdown+TwoSR+2+TwoS2);
double factor = fase*sqrt((TwoSL+1)*(TwoJ+1.0))*gsl_sf_coupling_6j(TwoS2,TwoJ,1,TwoSL,TwoSLdown,TwoSR);
double beta = 1.0;
char notr = 'N';
char trans = 'T';
double * BlockQ = Qleft->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
int inc = 1;
int size = dimLup * dimLdown;
dcopy_(&size, BlockQ, &inc, temp, &inc);
for (int l_index=0; l_index<theindex; l_index++){
if (denBK->gIrrep(l_index) == denBK->gIrrep(theindex)){
double alpha = Prob->gMxElement(l_index,theindex,theindex,theindex);
double * BlockL = Lleft[theindex-1-l_index]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
daxpy_(&size, &alpha, BlockL, &inc, temp, &inc);
}
}
dgemm_(&trans,¬r,&dimLup,&dimR,&dimLdown,&factor,temp,&dimLdown,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
}
}
}
}
}
void CheMPS2::TensorQ::AddTermsCF0DF1Left(TensorC * denC, TensorF0 ** deF0s, TensorD * denD, TensorF1 ** deF1s, TensorT * denT, double * workmem, double * workmem2){
for (int ikappa=0; ikappa<nKappa; ikappa++){
const int ILD = denBK->directProd(sectorI1[ikappa],Idiff);
int dimLU = denBK->gCurrentDim(index, sectorN1[ikappa], sectorTwoS1[ikappa], sectorI1[ikappa]);
int dimLD = denBK->gCurrentDim(index, sectorN1[ikappa]+1, sectorTwoSD[ikappa], ILD);
//case 1
const int IRU = denBK->directProd(sectorI1[ikappa],denBK->gIrrep(index));
for (int TwoSRU=sectorTwoS1[ikappa]-1; TwoSRU<=sectorTwoS1[ikappa]+1; TwoSRU+=2){
int dimRU = denBK->gCurrentDim(index+1, sectorN1[ikappa]+1, TwoSRU, IRU);
int dimRD = denBK->gCurrentDim(index+1, sectorN1[ikappa]+1, sectorTwoSD[ikappa], ILD);
if ((dimRU>0) && (dimRD>0)){
int dimRUxRD = dimRU * dimRD;
//first set to D
int fase = ((((sectorTwoS1[ikappa]+TwoSRU+3)/2)%2)!=0)?-1:1;
double factor = fase * sqrt(3.0/(sectorTwoSD[ikappa]+1.0)) * (TwoSRU+1) * gsl_sf_coupling_6j(1,1,2,TwoSRU,sectorTwoSD[ikappa],sectorTwoS1[ikappa]);
double * block = denD->gStorage( sectorN1[ikappa]+1, TwoSRU, IRU, sectorN1[ikappa]+1, sectorTwoSD[ikappa], ILD );
for (int cnt=0; cnt<dimRUxRD; cnt++){ workmem[cnt] = factor * block[cnt]; }
//add possible F1's
if (Idiff==denBK->gIrrep(index)){
fase = ((((TwoSRU-sectorTwoSD[ikappa])/2)%2)!=0)?-1:1;
factor *= fase * sqrt((sectorTwoSD[ikappa]+1.0) / (TwoSRU+1.0));
for (int loca=index+1; loca<Prob->gL(); loca++){
block = deF1s[loca-index-1]->gStorage( sectorN1[ikappa]+1, sectorTwoSD[ikappa], ILD, sectorN1[ikappa]+1, TwoSRU, IRU );
const double alpha = - factor * Prob->gMxElement(site,index,loca,loca);
for (int irow=0; irow<dimRU; irow++){
for (int icol=0; icol<dimRD; icol++){
workmem[irow + dimRU * icol] += alpha * block[icol + dimRD * irow];
}
}
}
}
//add C and F0's
if (TwoSRU==sectorTwoSD[ikappa]){
//C
factor = sqrt(0.5);
block = denC->gStorage( sectorN1[ikappa]+1, TwoSRU, IRU, sectorN1[ikappa]+1, sectorTwoSD[ikappa], ILD );
int inc = 1;
daxpy_(&dimRUxRD, &factor, block, &inc, workmem, &inc);
//F0
if (Idiff==denBK->gIrrep(index)){
for (int loca=index+1; loca<Prob->gL(); loca++){
block = deF0s[loca-index-1]->gStorage( sectorN1[ikappa]+1, sectorTwoSD[ikappa], ILD, sectorN1[ikappa]+1, TwoSRU, IRU );
const double alpha = factor * ( 2*Prob->gMxElement(site,loca,index,loca) - Prob->gMxElement(site,index,loca,loca) );
for (int irow=0; irow<dimRU; irow++){
for (int icol=0; icol<dimRD; icol++){
workmem[irow + dimRU * icol] += alpha * block[icol + dimRD * irow];
}
}
}
}
}
double * BlockTup = denT->gStorage( sectorN1[ikappa], sectorTwoS1[ikappa], sectorI1[ikappa], sectorN1[ikappa]+1, TwoSRU, IRU );
double * BlockTdo = denT->gStorage( sectorN1[ikappa]+1, sectorTwoSD[ikappa], ILD, sectorN1[ikappa]+1, sectorTwoSD[ikappa], ILD );
char notr = 'N';
double alpha = 1.0;
double beta = 0.0;
dgemm_(¬r,¬r,&dimLU,&dimRD,&dimRU,&alpha,BlockTup,&dimLU,workmem,&dimRU,&beta,workmem2,&dimLU);
beta = 1.0;
char trans = 'T';
dgemm_(¬r,&trans,&dimLU,&dimLD,&dimRD,&alpha,workmem2,&dimLU,BlockTdo,&dimLD,&beta,storage+kappa2index[ikappa],&dimLU);
}
}
//case 2
const int IRD = denBK->directProd(ILD,denBK->gIrrep(index));
for (int TwoSRD=sectorTwoSD[ikappa]-1; TwoSRD<=sectorTwoSD[ikappa]+1; TwoSRD+=2){
int dimRU = denBK->gCurrentDim(index+1, sectorN1[ikappa]+2, sectorTwoS1[ikappa], sectorI1[ikappa]);
int dimRD = denBK->gCurrentDim(index+1, sectorN1[ikappa]+2, TwoSRD, IRD);
if ((dimRU>0) && (dimRD>0)){
int dimRUxRD = dimRU * dimRD;
//first set to D
int fase = (((TwoSRD+1)%2)!=0)?-1:1;
double factor = fase * sqrt(3.0*(TwoSRD+1.0)*(sectorTwoS1[ikappa]+1.0)/(sectorTwoSD[ikappa]+1.0)) * gsl_sf_coupling_6j(1,1,2,sectorTwoS1[ikappa],TwoSRD,sectorTwoSD[ikappa]);
double * block = denD->gStorage( sectorN1[ikappa]+2, sectorTwoS1[ikappa], sectorI1[ikappa], sectorN1[ikappa]+2, TwoSRD, IRD );
for (int cnt=0; cnt<dimRUxRD; cnt++){ workmem[cnt] = factor * block[cnt]; }
//add possible F1's
if (Idiff==denBK->gIrrep(index)){
fase = ((((TwoSRD - sectorTwoS1[ikappa])/2)%2)!=0)?-1:1;
factor *= fase * sqrt((TwoSRD+1.0) / (sectorTwoS1[ikappa]+1.0));
for (int loca=index+1; loca<Prob->gL(); loca++){
block = deF1s[loca-index-1]->gStorage( sectorN1[ikappa]+2, TwoSRD, IRD, sectorN1[ikappa]+2, sectorTwoS1[ikappa], sectorI1[ikappa] );
const double alpha = - factor * Prob->gMxElement(site,index,loca,loca);
for (int irow=0; irow<dimRU; irow++){
for (int icol=0; icol<dimRD; icol++){
workmem[irow + dimRU * icol] += alpha * block[icol + dimRD * irow];
}
}
}
}
//add C and F0's
if (TwoSRD==sectorTwoS1[ikappa]){
//C
fase = ((((sectorTwoS1[ikappa]+1-sectorTwoSD[ikappa])/2)%2)!=0)?-1:1;
factor = fase * sqrt(0.5 * ( sectorTwoS1[ikappa]+1.0 ) / ( sectorTwoSD[ikappa] + 1.0 ) );
block = denC->gStorage( sectorN1[ikappa]+2, sectorTwoS1[ikappa], sectorI1[ikappa], sectorN1[ikappa]+2, TwoSRD, IRD );
int inc = 1;
daxpy_(&dimRUxRD, &factor, block, &inc, workmem, &inc);
//F0
if (Idiff==denBK->gIrrep(index)){
for (int loca=index+1; loca<Prob->gL(); loca++){
block = deF0s[loca-index-1]->gStorage( sectorN1[ikappa]+2, TwoSRD, IRD, sectorN1[ikappa]+2, sectorTwoS1[ikappa], sectorI1[ikappa] );
const double alpha = factor * ( 2*Prob->gMxElement(site,loca,index,loca) - Prob->gMxElement(site,index,loca,loca) );
for (int irow=0; irow<dimRU; irow++){
for (int icol=0; icol<dimRD; icol++){
workmem[irow + dimRU * icol] += alpha * block[icol + dimRD * irow];
}
}
}
}
}
double * BlockTup = denT->gStorage( sectorN1[ikappa], sectorTwoS1[ikappa],sectorI1[ikappa],sectorN1[ikappa]+2,sectorTwoS1[ikappa],sectorI1[ikappa] );
double * BlockTdo = denT->gStorage( sectorN1[ikappa]+1,sectorTwoSD[ikappa],ILD, sectorN1[ikappa]+2,TwoSRD, IRD);
char notr = 'N';
double alpha = 1.0;
double beta = 0.0;
dgemm_(¬r,¬r,&dimLU,&dimRD,&dimRU,&alpha,BlockTup,&dimLU,workmem,&dimRU,&beta,workmem2,&dimLU);
beta = 1.0;
char trans = 'T';
dgemm_(¬r,&trans,&dimLU,&dimLD,&dimRD,&alpha,workmem2,&dimLU,BlockTdo,&dimLD,&beta,storage+kappa2index[ikappa],&dimLU);
}
}
}
}
void CheMPS2::TensorQ::AddTermsABLeft(TensorA * denA, TensorB * denB, TensorT * denT, double * workmem, double * workmem2){
for (int ikappa=0; ikappa<nKappa; ikappa++){
const int ID = denBK->directProd(sectorI1[ikappa],Idiff);
int dimLU = denBK->gCurrentDim(index, sectorN1[ikappa], sectorTwoS1[ikappa], sectorI1[ikappa]);
int dimLD = denBK->gCurrentDim(index, sectorN1[ikappa]+1, sectorTwoSD[ikappa], ID);
//case 1
const int IRD = denBK->directProd(ID, denBK->gIrrep(index));
for (int TwoSRD=sectorTwoSD[ikappa]-1; TwoSRD<=sectorTwoSD[ikappa]+1; TwoSRD+=2){
int dimRU = denBK->gCurrentDim(index+1, sectorN1[ikappa], sectorTwoS1[ikappa], sectorI1[ikappa]);
int dimRD = denBK->gCurrentDim(index+1, sectorN1[ikappa]+2, TwoSRD, IRD);
if ((dimRU>0) && (dimRD>0)){
int fase = ((((TwoSRD + sectorTwoS1[ikappa] + 2)/2)%2)!=0)?-1:1;
double factorB = fase * sqrt(3.0/(sectorTwoSD[ikappa]+1.0)) * (TwoSRD+1) * gsl_sf_coupling_6j(1,1,2,sectorTwoS1[ikappa],TwoSRD,sectorTwoSD[ikappa]);
double alpha;
double * mem;
if (TwoSRD == sectorTwoS1[ikappa]){
fase = ((((sectorTwoS1[ikappa]+1-sectorTwoSD[ikappa])/2)%2)!=0)?-1:1;
double factorA = fase * sqrt( 0.5 * (sectorTwoS1[ikappa]+1.0) / (sectorTwoSD[ikappa]+1.0) );
double * BlockA = denA->gStorage( sectorN1[ikappa], sectorTwoS1[ikappa], sectorI1[ikappa], sectorN1[ikappa]+2, TwoSRD, IRD );
double * BlockB = denB->gStorage( sectorN1[ikappa], sectorTwoS1[ikappa], sectorI1[ikappa], sectorN1[ikappa]+2, TwoSRD, IRD );
mem = workmem;
for (int cnt=0; cnt<dimRU*dimRD; cnt++){ mem[cnt] = factorA * BlockA[cnt] + factorB * BlockB[cnt]; }
alpha = 1.0;
} else {
alpha = factorB;
mem = denB->gStorage( sectorN1[ikappa], sectorTwoS1[ikappa], sectorI1[ikappa], sectorN1[ikappa]+2, TwoSRD, IRD );
}
double * BlockTup = denT->gStorage(sectorN1[ikappa], sectorTwoS1[ikappa],sectorI1[ikappa],sectorN1[ikappa], sectorTwoS1[ikappa], sectorI1[ikappa]);
double * BlockTdo = denT->gStorage(sectorN1[ikappa]+1,sectorTwoSD[ikappa],ID, sectorN1[ikappa]+2,TwoSRD, IRD);
char notr = 'N';
double beta = 0.0; //set
dgemm_(¬r,¬r,&dimLU,&dimRD,&dimRU,&alpha,BlockTup,&dimLU,mem,&dimRU,&beta,workmem2,&dimLU);
alpha = 1.0;
beta = 1.0; //add
char trans = 'T';
dgemm_(¬r,&trans,&dimLU,&dimLD,&dimRD,&alpha,workmem2,&dimLU,BlockTdo,&dimLD,&beta,storage+kappa2index[ikappa],&dimLU);
}
}
//case 2
const int IRU = denBK->directProd(sectorI1[ikappa],denBK->gIrrep(index));
for (int TwoSRU=sectorTwoS1[ikappa]-1; TwoSRU<=sectorTwoS1[ikappa]+1; TwoSRU+=2){
int dimRU = denBK->gCurrentDim(index+1, sectorN1[ikappa]+1, TwoSRU, IRU);
int dimRD = denBK->gCurrentDim(index+1, sectorN1[ikappa]+3, sectorTwoSD[ikappa], ID);
if ((dimRU>0) && (dimRD>0)){
int fase = ((((sectorTwoS1[ikappa] + sectorTwoSD[ikappa] + 1)/2)%2)!=0)?-1:1;
double factorB = fase * sqrt(3.0*(TwoSRU+1)) * gsl_sf_coupling_6j(1,1,2,TwoSRU,sectorTwoSD[ikappa],sectorTwoS1[ikappa]);
double alpha;
double * mem;
if (TwoSRU == sectorTwoSD[ikappa]){
double factorA = - sqrt(0.5);
double * BlockA = denA->gStorage( sectorN1[ikappa]+1, TwoSRU, IRU, sectorN1[ikappa]+3, sectorTwoSD[ikappa], ID );
double * BlockB = denB->gStorage( sectorN1[ikappa]+1, TwoSRU, IRU, sectorN1[ikappa]+3, sectorTwoSD[ikappa], ID );
mem = workmem;
for (int cnt=0; cnt<dimRU*dimRD; cnt++){ mem[cnt] = factorA * BlockA[cnt] + factorB * BlockB[cnt]; }
alpha = 1.0;
} else {
alpha = factorB;
mem = denB->gStorage( sectorN1[ikappa]+1, TwoSRU, IRU, sectorN1[ikappa]+3, sectorTwoSD[ikappa], ID );
}
double * BlockTup = denT->gStorage(sectorN1[ikappa], sectorTwoS1[ikappa], sectorI1[ikappa], sectorN1[ikappa]+1, TwoSRU, IRU);
double * BlockTdo = denT->gStorage(sectorN1[ikappa]+1, sectorTwoSD[ikappa], ID, sectorN1[ikappa]+3, sectorTwoSD[ikappa], ID);
char notr = 'N';
double beta = 0.0; //set
dgemm_(¬r,¬r,&dimLU,&dimRD,&dimRU,&alpha,BlockTup,&dimLU,mem,&dimRU,&beta,workmem2,&dimLU);
alpha = 1.0;
beta = 1.0; //add
char trans = 'T';
dgemm_(¬r,&trans,&dimLU,&dimLD,&dimRD,&alpha,workmem2,&dimLU,BlockTdo,&dimLD,&beta,storage+kappa2index[ikappa],&dimLU);
}
}
}
}
void CheMPS2::TensorQ::AddTermsLLeft(TensorL ** Ltensors, TensorT * denT, double * workmem, double * workmem2){
bool OneToAdd = false;
for (int loca=index+1; loca<Prob->gL(); loca++){
if (Ltensors[loca-index-1]->gIdiff() == Idiff){ OneToAdd = true; }
}
if (OneToAdd){
for (int ikappa=0; ikappa<nKappa; ikappa++){
const int ID = denBK->directProd(sectorI1[ikappa],Idiff);
int dimLU = denBK->gCurrentDim(index, sectorN1[ikappa], sectorTwoS1[ikappa], sectorI1[ikappa]);
int dimLD = denBK->gCurrentDim(index, sectorN1[ikappa]+1, sectorTwoSD[ikappa], ID);
//case 1
int dimRU = denBK->gCurrentDim(index+1, sectorN1[ikappa]+2, sectorTwoS1[ikappa], sectorI1[ikappa]);
int dimRD = denBK->gCurrentDim(index+1, sectorN1[ikappa]+1, sectorTwoSD[ikappa], ID);
if ((dimRU>0) && (dimRD>0)){
int dimRUxRD = dimRU * dimRD;
for (int cnt=0; cnt<dimRUxRD; cnt++){ workmem[cnt] = 0.0; }
for (int loca=index+1; loca<Prob->gL(); loca++){
if (Ltensors[loca-index-1]->gIdiff() == Idiff){
double * BlockL = Ltensors[loca-index-1]->gStorage(sectorN1[ikappa]+1,sectorTwoSD[ikappa],ID,sectorN1[ikappa]+2,sectorTwoS1[ikappa],sectorI1[ikappa]);
double alpha = Prob->gMxElement(site,index,index,loca);
int inc = 1;
daxpy_(&dimRUxRD, &alpha, BlockL, &inc, workmem, &inc);
}
}
int fase = ((((sectorTwoS1[ikappa]+1-sectorTwoSD[ikappa])/2)%2)!=0)?-1:1;
double alpha = fase * sqrt((sectorTwoS1[ikappa]+1.0)/(sectorTwoSD[ikappa]+1.0));
double beta = 0.0; //set
double * BlockTup = denT->gStorage(sectorN1[ikappa], sectorTwoS1[ikappa], sectorI1[ikappa], sectorN1[ikappa]+2, sectorTwoS1[ikappa], sectorI1[ikappa]);
double * BlockTdo = denT->gStorage(sectorN1[ikappa]+1, sectorTwoSD[ikappa], ID, sectorN1[ikappa]+1, sectorTwoSD[ikappa], ID);
char trans = 'T';
char notr = 'N';
// factor * Tup * L^T --> mem2
dgemm_(¬r,&trans,&dimLU,&dimRD,&dimRU,&alpha,BlockTup,&dimLU,workmem,&dimRD,&beta,workmem2,&dimLU);
alpha = 1.0;
beta = 1.0; //add
// mem2 * Tdo^T --> storage
dgemm_(¬r,&trans,&dimLU,&dimLD,&dimRD,&alpha,workmem2,&dimLU, BlockTdo, &dimLD, &beta, storage+kappa2index[ikappa], &dimLU);
}
//case 2
dimRD = denBK->gCurrentDim(index+1, sectorN1[ikappa]+3, sectorTwoSD[ikappa], ID);
//dimRU same as case1
if ((dimRU>0) && (dimRD>0)){
int dimRUxRD = dimRU * dimRD;
for (int cnt=0; cnt<dimRUxRD; cnt++){ workmem[cnt] = 0.0; }
for (int loca=index+1; loca<Prob->gL(); loca++){
if (Ltensors[loca-index-1]->gIdiff() == Idiff){
double * BlockL = Ltensors[loca-index-1]->gStorage(sectorN1[ikappa]+2,sectorTwoS1[ikappa],sectorI1[ikappa],sectorN1[ikappa]+3,sectorTwoSD[ikappa],ID);
double alpha = 2*Prob->gMxElement(site,index,loca,index) - Prob->gMxElement(site,index,index,loca);
int inc = 1;
daxpy_(&dimRUxRD, &alpha, BlockL, &inc, workmem, &inc);
}
}
double alpha = 1.0; //factor = 1 in this case
double beta = 0.0; //set
double * BlockTup = denT->gStorage(sectorN1[ikappa], sectorTwoS1[ikappa], sectorI1[ikappa], sectorN1[ikappa]+2, sectorTwoS1[ikappa], sectorI1[ikappa]);
double * BlockTdo = denT->gStorage(sectorN1[ikappa]+1, sectorTwoSD[ikappa], ID, sectorN1[ikappa]+3, sectorTwoSD[ikappa], ID);
char notr = 'N';
// factor * Tup * L --> mem2
dgemm_(¬r,¬r,&dimLU,&dimRD,&dimRU,&alpha,BlockTup,&dimLU,workmem,&dimRU,&beta,workmem2,&dimLU);
beta = 1.0; //add
// mem2 * Tdo^T --> storage
char trans = 'T';
dgemm_(¬r,&trans,&dimLU,&dimLD,&dimRD,&alpha,workmem2,&dimLU, BlockTdo, &dimLD, &beta, storage+kappa2index[ikappa], &dimLU);
}
//case 3
for (int TwoSRU=sectorTwoS1[ikappa]-1; TwoSRU<=sectorTwoS1[ikappa]+1; TwoSRU+=2){
for (int TwoSRD=sectorTwoSD[ikappa]-1; TwoSRD<=sectorTwoSD[ikappa]+1; TwoSRD+=2){
if ((TwoSRD>=0) && (TwoSRU>=0) && (abs(TwoSRD-TwoSRU)<2)){
const int IRU = denBK->directProd(sectorI1[ikappa],denBK->gIrrep(index));
const int IRD = denBK->directProd(ID, denBK->gIrrep(index));
dimRU = denBK->gCurrentDim(index+1, sectorN1[ikappa]+1, TwoSRU, IRU);
dimRD = denBK->gCurrentDim(index+1, sectorN1[ikappa]+2, TwoSRD, IRD);
if ((dimRU>0) && (dimRD>0)){
int fase = ((((sectorTwoSD[ikappa]+TwoSRU)/2)%2)!=0)?-1:1;
double factor1 = fase * sqrt((TwoSRU+1.0)/(sectorTwoSD[ikappa]+1.0)) * (TwoSRD+1) * gsl_sf_coupling_6j(sectorTwoS1[ikappa], sectorTwoSD[ikappa], 1, TwoSRD, TwoSRU, 1);
double factor2 = (TwoSRD+1.0)/(sectorTwoSD[ikappa]+1.0);
int dimRUxRD = dimRU * dimRD;
for (int cnt=0; cnt<dimRUxRD; cnt++){ workmem[cnt] = 0.0; }
for (int loca=index+1; loca<Prob->gL(); loca++){
if (Ltensors[loca-index-1]->gIdiff() == Idiff){
double * BlockL = Ltensors[loca-index-1]->gStorage(sectorN1[ikappa]+1, TwoSRU, IRU, sectorN1[ikappa]+2, TwoSRD, IRD);
double alpha = factor1 * Prob->gMxElement(site,index,loca,index);
if (TwoSRU==sectorTwoSD[ikappa]){ alpha += factor2 * Prob->gMxElement(site,index,index,loca); }
int inc = 1;
daxpy_(&dimRUxRD, &alpha, BlockL, &inc, workmem, &inc);
}
}
double alpha = 1.0;
double beta = 0.0; //set
double * BlockTup = denT->gStorage(sectorN1[ikappa], sectorTwoS1[ikappa], sectorI1[ikappa], sectorN1[ikappa]+1, TwoSRU, IRU);
double * BlockTdo = denT->gStorage(sectorN1[ikappa]+1, sectorTwoSD[ikappa], ID, sectorN1[ikappa]+2, TwoSRD, IRD);
char notr = 'N';
// Tup * mem --> mem2
dgemm_(¬r,¬r,&dimLU,&dimRD,&dimRU,&alpha,BlockTup,&dimLU,workmem,&dimRU,&beta,workmem2,&dimLU);
beta = 1.0; //add
// mem2 * Tdo^T --> storage
char trans = 'T';
dgemm_(¬r,&trans,&dimLU,&dimLD,&dimRD,&alpha,workmem2,&dimLU, BlockTdo, &dimLD, &beta, storage+kappa2index[ikappa], &dimLU);
}
}
}
}
}
}
}
// antisymmetrized matrix elements of Minnesota potential in spherical HO basis
// V_acbd, where a-b and c-d are pairs of the same l,j (i.e. are coupled to J=0)
// direct term: a-b integrated over r1, c-d integrated over r2
// exchange term: a-d integrated over r1, c-b integrated over r2
// Uses multipolar expansion of gaussian in Minnesota: exp(-mu(vec{r1}-vec{r2})^2)
// = exp(-mu(r1-r2)^2) * 4pi * sum_LM iL(2*mu*r1*r2)/exp(2*mu*r1*r2) * Y*_LM(1) * Y_LM(2)
// where iL(2*mu*r1*r2)/exp(2*mu*r1*r2) is scaled modified spherical Bessel function
void V_me(Vi1_t *V, double hw)
{
// i1 and i2 label (j,l) subspaces (Ni elements)
// ir1, ir2 are integration indices (converted later to r1, r2)
// a,b are n-quantum numbers in i1=(j1,l1) subspace
// c,d are n-quantum numbers in i2=(j2,l2) subspace
int i1, i2, ir1, ir2, a, b, c, d, L, _2l1, _2l2;
double r1, r2, mw, rm2, rp2;
double sumR, sumS, sumRp, sumSp, bess, coef;
double ***sho_nlr, *halfint1, *halfint2, *halfint3, *coef1, *coef2;
Vi2_t *Vi2;
mw = hw / H2M;
// matrix elements use double integration by Gauss-Laguerre quadrature
gaulag_init(GLNODES, 1., 0.04 / sqrt(mw)); // then use gl.x[i] and gl.w[i]
halfint1 = (double*)malloc(gl.N * sizeof(double));
halfint2 = (double*)malloc(gl.N * sizeof(double));
halfint3 = (double*)malloc(gl.N * sizeof(double));
coef1 = (double*)malloc(Ni * sizeof(double));
coef2 = (double*)malloc(Ni * sizeof(double));
if ((halfint1 == NULL) || (halfint2 == NULL) || (halfint3 == NULL)
|| (coef1 == NULL) || (coef2 == NULL)) {
fprintf(stderr, "V_me: failed allocation of auxiliary arrays halfint[%d] or coef[%d]\n", gl.N, Ni);
exit(1);
}
sho_nlr = make_sho_table(mw, N_jl[0], (Ni+1)/2); // tabulate SHO w.f.
for (i1 = 0; i1 < Ni; i1++) { // zeroing the pairing matrix elements
for (a = 0; a < V[i1].N; a++) {
for (b = 0; b < V[i1].N; b++) {
Vi2 = V[i1].V_ab[a][b].Vi2;
for (i2 = 0; i2 < Ni; i2++) {
for (c = 0; c < Vi2[i2].N; c++) {
for (d = 0; d < Vi2[i2].N; d++)
Vi2[i2].V_cd_pair[c][d] = 0.;
}
}
}
}
}
for (i1 = 0; i1 < Ni; i1++) { // j,l of the first pair
for (a = 0; a < V[i1].N; a++) {
for (b = 0; b <= a; b++) {
for (ir2 = 0; ir2 < gl.N; ir2++) {
halfint1[ir2] = 0.; // for storage of r1-integrated direct term
r2 = gl.x[ir2];
for (ir1 = 0; ir1 < gl.N; ir1++) {
r1 = gl.x[ir1];
rm2 = (r1-r2)*(r1-r2);
rp2 = (r1+r2)*(r1+r2);
halfint1[ir2] += gl.w[ir1] * r1 * sho_nlr[a][V[i1].l1][ir1] * sho_nlr[b][V[i1].l1][ir1]
* (V0R*(exp(-kR*rm2)-exp(-kR*rp2))/(16*kR)
- V0S*(exp(-kS*rm2)-exp(-kS*rp2))/(16*kS));
}
}
Vi2 = V[i1].V_ab[a][b].Vi2;
for (i2 = 0; i2 <= i1; i2++) { // j,l of the second pair
_2l1 = 2 * V[i1].l1;
_2l2 = 2 * Vi2[i2].l2;
for (L = Vi2[i2].Lmin; L <= Vi2[i2].Lmax; L += 2) {
// Clebsch-Gordan coeficients and 6j symbols for exchange term
coef = gsl_sf_coupling_3j(_2l1, _2l2, 2*L, 0, 0, 0);
coef2[L] = coef1[L] = (2*L+1) * coef * coef;
coef = gsl_sf_coupling_6j(V[i1]._2j1, Vi2[i2]._2j2, 2*L, _2l2, _2l1, 1);
coef = (_2l1 + 1) * (_2l2 + 1) * coef * coef;
coef1[L] *= 1. - coef;
coef2[L] *= coef + (_2l1 + 1) * (_2l2 + 1)
* gsl_sf_coupling_9j(2*L,_2l2,_2l1, _2l2,Vi2[i2]._2j2, 1, _2l1,1,V[i1]._2j1);
}
for (c = 0; c < Vi2[i2].N; c++) {
for (ir1 = 0; ir1 < gl.N; ir1++) {
halfint2[ir1] = 0.; // for storage of r2-integrated exchange term
halfint3[ir1] = 0.; // for storage of r2-integrated pairing term
r1 = gl.x[ir1];
for (ir2 = 0; ir2 < gl.N; ir2++) {
r2 = gl.x[ir2];
rm2 = (r1-r2) * (r1-r2);
rp2 = 2 * r1 * r2;
sumR = 0.; sumS = 0.; // storage for terms from L-expansion
sumRp = 0.; sumSp = 0.; // terms for pairing
for (L = Vi2[i2].Lmin; L <= Vi2[i2].Lmax; L += 2) {
bess = gsl_sf_bessel_il_scaled(L, kR*rp2);
sumR += bess * coef1[L];
sumRp += bess * coef2[L];
bess = gsl_sf_bessel_il_scaled(L, kS*rp2);
sumS += bess * coef1[L];
sumSp += bess * coef2[L];
}
halfint2[ir1] += gl.w[ir2] * r2 * r2 * sho_nlr[c][Vi2[i2].l2][ir2] * sho_nlr[b][V[i1].l1][ir2]
* 0.5 * (V0R * exp(-kR*rm2) * sumR - V0S * exp(-kS*rm2) * sumS);
halfint3[ir1] += gl.w[ir2] * r2 * r2 * sho_nlr[c][Vi2[i2].l2][ir2] * sho_nlr[b][V[i1].l1][ir2]
* 0.5 * (V0R * exp(-kR*rm2) * sumRp - V0S * exp(-kS*rm2) * sumSp);
}
halfint2[ir1] *= sho_nlr[a][V[i1].l1][ir1];
halfint3[ir1] *= sho_nlr[a][V[i1].l1][ir1];
}
for (d = 0; d < Vi2[i2].N; d++) {
sumR = 0.; // for direct + exchange integral
sumRp = 0.; // for pairing integral
for (ir1 = 0; ir1 < gl.N; ir1++) {
r1 = gl.x[ir1]; // direct integral is done over r2, exchange and pairing over r1
sumR += gl.w[ir1] * (
halfint1[ir1] * sho_nlr[c][Vi2[i2].l2][ir1] // direct integral
+ halfint2[ir1] * r1 // exchange integral
) * r1 * sho_nlr[d][Vi2[i2].l2][ir1];
sumRp += gl.w[ir1] * halfint3[ir1] * r1 * r1 * sho_nlr[d][Vi2[i2].l2][ir1];
}
// term (2j+1) is from the summation over m-degenerate density matrices
sumS = sumR * (Vi2[i2]._2j2 + 1);
sumSp = sumRp * (Vi2[i2]._2j2 + 1);
V[i1].V_ab[a][b].Vi2[i2].V_cd[c][d] = sumS;
V[i1].V_ab[a][b].Vi2[i2].V_cd_pair[c][d] += sumSp;
V[i1].V_ab[a][b].Vi2[i2].V_cd_pair[d][c] += sumSp;
if (a != b) {
V[i1].V_ab[b][a].Vi2[i2].V_cd[d][c] = sumS;
V[i1].V_ab[b][a].Vi2[i2].V_cd_pair[d][c] += sumSp;
V[i1].V_ab[b][a].Vi2[i2].V_cd_pair[c][d] += sumSp;
}
if (i1 > i2) { // symmetry V_acbd = V_cadb (and V_abcd = V_cdab for pairing)
sumS = sumR * (V[i1]._2j1 + 1);
sumSp = sumRp * (V[i1]._2j1 + 1);
V[i2].V_ab[c][d].Vi2[i1].V_cd[a][b] = sumS;
V[i2].V_ab[c][d].Vi2[i1].V_cd_pair[a][b] += sumSp;
V[i2].V_ab[d][c].Vi2[i1].V_cd_pair[a][b] += sumSp;
if (a != b) {
V[i2].V_ab[d][c].Vi2[i1].V_cd[b][a] = sumS;
V[i2].V_ab[d][c].Vi2[i1].V_cd_pair[b][a] += sumSp;
V[i2].V_ab[c][d].Vi2[i1].V_cd_pair[b][a] += sumSp;
}
}
} // d
} // c
} // i2
} // b
} // a
} // i1
free(halfint1);
free(halfint2);
free(coef1);
free(coef2);
free(sho_nlr[0][0]); free(sho_nlr[0]); free(sho_nlr);
}
void CheMPS2::TensorOperator::update_moving_left(const int ikappa, TensorOperator * previous, TensorT * mps_tensor, double * workmem){
const int n_left_up = sectorN1[ ikappa ];
const int n_left_down = n_left_up + n_elec;
const int two_s_left_up = sectorTwoS1[ ikappa ];
const int two_s_left_down = sector_2S_down[ ikappa ];
const int irrep_left_up = sectorI1[ ikappa ];
const int irrep_left_down = Irreps::directProd( irrep_left_up, n_irrep );
int dim_left_up = denBK->gCurrentDim( index, n_left_up, two_s_left_up, irrep_left_up );
int dim_left_down = denBK->gCurrentDim( index, n_left_down, two_s_left_down, irrep_left_down );
for (int geval = 0; geval < 6; geval++){
int n_right_up, n_right_down, two_s_right_up, two_s_right_down, irrep_right_up, irrep_right_down;
switch ( geval ){
case 0: // MPS tensor sector (I,J,N) = (0,0,0)
two_s_right_up = two_s_left_up;
two_s_right_down = two_s_left_down;
n_right_up = n_left_up;
n_right_down = n_left_down;
irrep_right_up = irrep_left_up;
irrep_right_down = irrep_left_down;
break;
case 1: // MPS tensor sector (I,J,N) = (0,0,2)
two_s_right_up = two_s_left_up;
two_s_right_down = two_s_left_down;
n_right_up = n_left_up + 2;
n_right_down = n_left_down + 2;
irrep_right_up = irrep_left_up;
irrep_right_down = irrep_left_down;
break;
case 2: // MPS tensor sector (I,J,N) = (Ilocal,1/2,1)
two_s_right_up = two_s_left_up - 1;
two_s_right_down = two_s_left_down - 1;
n_right_up = n_left_up + 1;
n_right_down = n_left_down + 1;
irrep_right_up = Irreps::directProd( irrep_left_up, denBK->gIrrep(index) );
irrep_right_down = Irreps::directProd( irrep_left_down, denBK->gIrrep(index) );
break;
case 3: // MPS tensor sector (I,J,N) = (Ilocal,1/2,1)
two_s_right_up = two_s_left_up - 1;
two_s_right_down = two_s_left_down + 1;
n_right_up = n_left_up + 1;
n_right_down = n_left_down + 1;
irrep_right_up = Irreps::directProd( irrep_left_up, denBK->gIrrep(index) );
irrep_right_down = Irreps::directProd( irrep_left_down, denBK->gIrrep(index) );
break;
case 4: // MPS tensor sector (I,J,N) = (Ilocal,1/2,1)
two_s_right_up = two_s_left_up + 1;
two_s_right_down = two_s_left_down - 1;
n_right_up = n_left_up + 1;
n_right_down = n_left_down + 1;
irrep_right_up = Irreps::directProd( irrep_left_up, denBK->gIrrep(index) );
irrep_right_down = Irreps::directProd( irrep_left_down, denBK->gIrrep(index) );
break;
case 5: // MPS tensor sector (I,J,N) = (Ilocal,1/2,1)
two_s_right_up = two_s_left_up + 1;
two_s_right_down = two_s_left_down + 1;
n_right_up = n_left_up + 1;
n_right_down = n_left_down + 1;
irrep_right_up = Irreps::directProd( irrep_left_up, denBK->gIrrep(index) );
irrep_right_down = Irreps::directProd( irrep_left_down, denBK->gIrrep(index) );
break;
}
if ( abs( two_s_right_up - two_s_right_down ) <= two_j ){
int dim_right_up = denBK->gCurrentDim( index+1, n_right_up, two_s_right_up, irrep_right_up );
int dim_right_down = denBK->gCurrentDim( index+1, n_right_down, two_s_right_down, irrep_right_down );
if (( dim_right_up > 0 ) && ( dim_right_down > 0 )){
double * mps_block_up = mps_tensor->gStorage( n_left_up, two_s_left_up, irrep_left_up, n_right_up, two_s_right_up, irrep_right_up );
double * mps_block_down = mps_tensor->gStorage( n_left_down, two_s_left_down, irrep_left_down, n_right_down, two_s_right_down, irrep_right_down );
double * right_block = previous->gStorage( n_right_up, two_s_right_up, irrep_right_up, n_right_down, two_s_right_down, irrep_right_down );
// Prefactor
double alpha = 1.0;
if ( geval >= 2 ){
if ( two_j == 0 ){
alpha = ( ( jw_phase ) ? -1.0 : 1.0 ) * ( two_s_right_up + 1.0 ) / ( two_s_left_up + 1.0 );
} else {
if ( prime_last ){
alpha = CheMPS2::Heff::phase( two_s_right_up + two_s_left_down + two_j + ( ( jw_phase ) ? 3 : 1 ) )
* ( two_s_right_down + 1 ) * sqrt( ( two_s_right_up + 1.0 ) / ( two_s_left_down + 1.0 ) )
* gsl_sf_coupling_6j( two_s_right_up, two_s_right_down, two_j, two_s_left_down, two_s_left_up, 1 );
} else {
alpha = CheMPS2::Heff::phase( two_s_right_down + two_s_left_up + two_j + ( ( jw_phase ) ? 3 : 1 ) )
* ( two_s_right_up + 1 ) * sqrt( ( two_s_right_down + 1.0 ) / ( two_s_left_up + 1.0 ) )
* gsl_sf_coupling_6j( two_s_right_down, two_s_right_up, two_j, two_s_left_up, two_s_left_down, 1 );
}
}
}
// prefactor * mps_block_up * right_block --> mem
char notr = 'N';
double beta = 0.0; //set
dgemm_(¬r, ¬r, &dim_left_up, &dim_right_down, &dim_right_up,
&alpha, mps_block_up, &dim_left_up, right_block, &dim_right_up,
&beta, workmem, &dim_left_up);
// mem * mps_block_down^T --> storage
char trans = 'T';
alpha = 1.0;
beta = 1.0; //add
dgemm_(¬r, &trans, &dim_left_up, &dim_left_down, &dim_right_down,
&alpha, workmem, &dim_left_up, mps_block_down, &dim_left_down,
&beta, storage + kappa2index[ikappa], &dim_left_up);
}
}
}
}
