CheMPS2
HeffDiagrams4.cpp
1 /*
2  CheMPS2: a spin-adapted implementation of DMRG for ab initio quantum chemistry
3  Copyright (C) 2013-2016 Sebastian Wouters
4 
5  This program is free software; you can redistribute it and/or modify
6  it under the terms of the GNU General Public License as published by
7  the Free Software Foundation; either version 2 of the License, or
8  (at your option) any later version.
9 
10  This program is distributed in the hope that it will be useful,
11  but WITHOUT ANY WARRANTY; without even the implied warranty of
12  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13  GNU General Public License for more details.
14 
15  You should have received a copy of the GNU General Public License along
16  with this program; if not, write to the Free Software Foundation, Inc.,
17  51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
18 */
19 
20 #include <math.h>
21 #include <stdlib.h>
22 
23 #include "Heff.h"
24 #include "Lapack.h"
25 #include "MPIchemps2.h"
26 #include "Wigner.h"
27 
28 void CheMPS2::Heff::addDiagram4A1and4A2spin0(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorOperator * Atens) const{
29 
30  int NL = denS->gNL(ikappa);
31  int TwoSL = denS->gTwoSL(ikappa);
32  int IL = denS->gIL(ikappa);
33 
34  int NR = denS->gNR(ikappa);
35  int TwoSR = denS->gTwoSR(ikappa);
36  int IR = denS->gIR(ikappa);
37 
38  int N1 = denS->gN1(ikappa);
39  int N2 = denS->gN2(ikappa);
40  int TwoJ = denS->gTwoJ(ikappa);
41 
42  int theindex = denS->gIndex();
43  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
44  int dimR = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
45 
46  int ILdown = Irreps::directProd(IL,Atens->get_irrep());
47 
48  char trans = 'T';
49  char notrans = 'N';
50  double beta = 1.0; //add
51 
52  //4A1A.spin0
53  if ((N1==0) && (N2==0)){
54 
55  int memSkappa = denS->gKappa(NL-2,TwoSL,ILdown,1,1,0,NR,TwoSR,IR);
56  if (memSkappa!=-1){
57 
58  double factor = 1.0;
59  double * Ablock = Atens->gStorage(NL-2,TwoSL,ILdown,NL,TwoSL,IL);
60  int dimLdown = denBK->gCurrentDim(theindex,NL-2,TwoSL,ILdown);
61 
62  dgemm_(&trans,&notrans,&dimLup,&dimR,&dimLdown,&factor,Ablock,&dimLdown,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
63 
64  }
65  }
66 
67  //4A1B.spin0
68  if ((N1==1) && (N2==0)){
69 
70  int memSkappa = denS->gKappa(NL-2,TwoSL,ILdown,2,1,1,NR,TwoSR,IR);
71  if (memSkappa!=-1){
72 
73  double factor = - sqrt(0.5);
74  double * Ablock = Atens->gStorage(NL-2,TwoSL,ILdown,NL,TwoSL,IL);
75  int dimLdown = denBK->gCurrentDim(theindex,NL-2,TwoSL,ILdown);
76 
77  dgemm_(&trans,&notrans,&dimLup,&dimR,&dimLdown,&factor,Ablock,&dimLdown,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
78 
79  }
80  }
81 
82  //4A1C.spin0
83  if ((N1==0) && (N2==1)){
84 
85  int memSkappa = denS->gKappa(NL-2,TwoSL,ILdown,1,2,1,NR,TwoSR,IR);
86  if (memSkappa!=-1){
87 
88  double factor = - sqrt(0.5);
89  double * Ablock = Atens->gStorage(NL-2,TwoSL,ILdown,NL,TwoSL,IL);
90  int dimLdown = denBK->gCurrentDim(theindex,NL-2,TwoSL,ILdown);
91 
92  dgemm_(&trans,&notrans,&dimLup,&dimR,&dimLdown,&factor,Ablock,&dimLdown,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
93 
94  }
95  }
96 
97  //4A1D.spin0 and 4A2A.spin0
98  if ((N1==1) && (N2==1) && (TwoJ==0)){
99 
100  int memSkappa = denS->gKappa(NL-2,TwoSL,ILdown,2,2,0,NR,TwoSR,IR);
101  if (memSkappa!=-1){
102 
103  double factor = -1.0;
104  double * Ablock = Atens->gStorage(NL-2,TwoSL,ILdown,NL,TwoSL,IL);
105  int dimLdown = denBK->gCurrentDim(theindex,NL-2,TwoSL,ILdown);
106 
107  dgemm_(&trans,&notrans,&dimLup,&dimR,&dimLdown,&factor,Ablock,&dimLdown,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
108 
109  }
110  memSkappa = denS->gKappa(NL+2,TwoSL,ILdown,0,0,0,NR,TwoSR,IR);
111  if (memSkappa!=-1){
112 
113  double factor = 1.0;
114  double * Ablock = Atens->gStorage(NL,TwoSL,IL,NL+2,TwoSL,ILdown);
115  int dimLdown = denBK->gCurrentDim(theindex,NL+2,TwoSL,ILdown);
116 
117  dgemm_(&notrans,&notrans,&dimLup,&dimR,&dimLdown,&factor,Ablock,&dimLup,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
118 
119  }
120  }
121 
122  //4A2B.spin0
123  if ((N1==2) && (N2==1)){
124 
125  int memSkappa = denS->gKappa(NL+2,TwoSL,ILdown,1,0,1,NR,TwoSR,IR);
126  if (memSkappa!=-1){
127 
128  double factor = - sqrt(0.5);
129  double * Ablock = Atens->gStorage(NL,TwoSL,IL,NL+2,TwoSL,ILdown);
130  int dimLdown = denBK->gCurrentDim(theindex,NL+2,TwoSL,ILdown);
131 
132  dgemm_(&notrans,&notrans,&dimLup,&dimR,&dimLdown,&factor,Ablock,&dimLup,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
133 
134  }
135  }
136 
137  //4A2C.spin0
138  if ((N1==1) && (N2==2)){
139 
140  int memSkappa = denS->gKappa(NL+2,TwoSL,ILdown,0,1,1,NR,TwoSR,IR);
141  if (memSkappa!=-1){
142 
143  double factor = - sqrt(0.5);
144  double * Ablock = Atens->gStorage(NL,TwoSL,IL,NL+2,TwoSL,ILdown);
145  int dimLdown = denBK->gCurrentDim(theindex,NL+2,TwoSL,ILdown);
146 
147  dgemm_(&notrans,&notrans,&dimLup,&dimR,&dimLdown,&factor,Ablock,&dimLup,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
148 
149  }
150  }
151 
152  //4A2D.spin0
153  if ((N1==2) && (N2==2)){
154 
155  int memSkappa = denS->gKappa(NL+2,TwoSL,ILdown,1,1,0,NR,TwoSR,IR);
156  if (memSkappa!=-1){
157 
158  double factor = -1.0;
159  double * Ablock = Atens->gStorage(NL,TwoSL,IL,NL+2,TwoSL,ILdown);
160  int dimLdown = denBK->gCurrentDim(theindex,NL+2,TwoSL,ILdown);
161 
162  dgemm_(&notrans,&notrans,&dimLup,&dimR,&dimLdown,&factor,Ablock,&dimLup,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
163 
164  }
165  }
166 
167 }
168 
169 void CheMPS2::Heff::addDiagram4A1and4A2spin1(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorOperator * Btens) const{
170 
171  int NL = denS->gNL(ikappa);
172  int TwoSL = denS->gTwoSL(ikappa);
173  int IL = denS->gIL(ikappa);
174 
175  int NR = denS->gNR(ikappa);
176  int TwoSR = denS->gTwoSR(ikappa);
177  int IR = denS->gIR(ikappa);
178 
179  int N1 = denS->gN1(ikappa);
180  int N2 = denS->gN2(ikappa);
181  int TwoJ = denS->gTwoJ(ikappa);
182 
183  int theindex = denS->gIndex();
184  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
185  int dimR = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
186 
187  int ILdown = Irreps::directProd(IL,Btens->get_irrep());
188 
189  char trans = 'T';
190  char notrans = 'N';
191  double beta = 1.0; //add
192 
193  //4A1A.spin1
194  if ((N1==0) && (N2==0)){ //which means TwoSL==TwoSR --> no checker for TwoSLdown
195 
196  for (int TwoSLdown = TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
197  if (TwoSLdown>=0){
198 
199  int memSkappa = denS->gKappa(NL-2,TwoSLdown,ILdown,1,1,2,NR,TwoSR,IR);
200  if (memSkappa!=-1){
201 
202  double factor = 1.0;
203  double * Bblock = Btens->gStorage(NL-2,TwoSLdown,ILdown,NL,TwoSL,IL);
204  int dimLdown = denBK->gCurrentDim(theindex,NL-2,TwoSLdown,ILdown);
205 
206  dgemm_(&trans,&notrans,&dimLup,&dimR,&dimLdown,&factor,Bblock,&dimLdown,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
207 
208  }
209  }
210  }
211  }
212 
213  //4A1B.spin1
214  if ((N1==1) && (N2==0)){
215 
216  for (int TwoSLdown = TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
217  if ((abs(TwoSLdown-TwoSR)<=1) && (TwoSLdown>=0)){
218 
219  int memSkappa = denS->gKappa(NL-2,TwoSLdown,ILdown,2,1,1,NR,TwoSR,IR);
220  if (memSkappa!=-1){
221 
222  int fase = phase(TwoSLdown + TwoSR + 1);
223  double factor = fase * sqrt(3.0*(TwoSL+1)) * Wigner::wigner6j(1,1,2,TwoSL,TwoSLdown,TwoSR);
224  double * Bblock = Btens->gStorage(NL-2,TwoSLdown,ILdown,NL,TwoSL,IL);
225  int dimLdown = denBK->gCurrentDim(theindex,NL-2,TwoSLdown,ILdown);
226 
227  dgemm_(&trans,&notrans,&dimLup,&dimR,&dimLdown,&factor,Bblock,&dimLdown,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
228  }
229  }
230  }
231  }
232 
233  //4A1C.spin1
234  if ((N1==0) && (N2==1)){
235 
236  for (int TwoSLdown = TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
237  if ((abs(TwoSLdown-TwoSR)<=1) && (TwoSLdown>=0)){
238 
239  int memSkappa = denS->gKappa(NL-2,TwoSLdown,ILdown,1,2,1,NR,TwoSR,IR);
240  if (memSkappa!=-1){
241 
242  int fase = phase(TwoSLdown + TwoSR + 3);
243  double factor = fase * sqrt(3.0*(TwoSL+1)) * Wigner::wigner6j(1,1,2,TwoSL,TwoSLdown,TwoSR);
244  double * Bblock = Btens->gStorage(NL-2,TwoSLdown,ILdown,NL,TwoSL,IL);
245  int dimLdown = denBK->gCurrentDim(theindex,NL-2,TwoSLdown,ILdown);
246 
247  dgemm_(&trans,&notrans,&dimLup,&dimR,&dimLdown,&factor,Bblock,&dimLdown,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
248  }
249  }
250  }
251  }
252 
253  //4A1D.spin1 and 4A2A.spin1
254  if ((N1==1) && (N2==1) && (TwoJ==2)){
255 
256  int TwoSLdown = TwoSR;
257 
258  int memSkappa = denS->gKappa(NL-2,TwoSLdown,ILdown,2,2,0,NR,TwoSR,IR);
259  if (memSkappa!=-1){
260 
261  int fase = phase(TwoSLdown - TwoSL);
262  double factor = fase * sqrt((TwoSL+1.0)/(TwoSLdown+1.0));
263  double * Bblock = Btens->gStorage(NL-2,TwoSLdown,ILdown,NL,TwoSL,IL);
264  int dimLdown = denBK->gCurrentDim(theindex,NL-2,TwoSLdown,ILdown);
265 
266  dgemm_(&trans,&notrans,&dimLup,&dimR,&dimLdown,&factor,Bblock,&dimLdown,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
267 
268  }
269  memSkappa = denS->gKappa(NL+2,TwoSLdown,ILdown,0,0,0,NR,TwoSR,IR);
270  if (memSkappa!=-1){
271 
272  double factor = 1.0;
273  double * Bblock = Btens->gStorage(NL,TwoSL,IL,NL+2,TwoSLdown,ILdown);
274  int dimLdown = denBK->gCurrentDim(theindex,NL+2,TwoSLdown,ILdown);
275 
276  dgemm_(&notrans,&notrans,&dimLup,&dimR,&dimLdown,&factor,Bblock,&dimLup,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
277 
278  }
279  }
280 
281  //4A2B.spin1
282  if ((N1==2) && (N2==1)){
283 
284  for (int TwoSLdown = TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
285  if ((abs(TwoSLdown-TwoSR)<=1) && (TwoSLdown>=0)){
286 
287  int memSkappa = denS->gKappa(NL+2,TwoSLdown,ILdown,1,0,1,NR,TwoSR,IR);
288  if (memSkappa!=-1){
289 
290  int fase = phase(TwoSL + TwoSR + 1);
291  double factor = fase * sqrt(3.0*(TwoSLdown+1)) * Wigner::wigner6j(1,1,2,TwoSL,TwoSLdown,TwoSR);
292  double * Bblock = Btens->gStorage(NL,TwoSL,IL,NL+2,TwoSLdown,ILdown);
293  int dimLdown = denBK->gCurrentDim(theindex,NL+2,TwoSLdown,ILdown);
294 
295  dgemm_(&notrans,&notrans,&dimLup,&dimR,&dimLdown,&factor,Bblock,&dimLup,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
296  }
297  }
298  }
299  }
300 
301  //4A2C.spin1
302  if ((N1==1) && (N2==2)){
303 
304  for (int TwoSLdown = TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
305  if ((abs(TwoSLdown-TwoSR)<=1) && (TwoSLdown>=0)){
306 
307  int memSkappa = denS->gKappa(NL+2,TwoSLdown,ILdown,0,1,1,NR,TwoSR,IR);
308  if (memSkappa!=-1){
309 
310  int fase = phase(TwoSL + TwoSR + 3);
311  double factor = fase * sqrt(3.0*(TwoSLdown+1)) * Wigner::wigner6j(1,1,2,TwoSL,TwoSLdown,TwoSR);
312  double * Bblock = Btens->gStorage(NL,TwoSL,IL,NL+2,TwoSLdown,ILdown);
313  int dimLdown = denBK->gCurrentDim(theindex,NL+2,TwoSLdown,ILdown);
314 
315  dgemm_(&notrans,&notrans,&dimLup,&dimR,&dimLdown,&factor,Bblock,&dimLup,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
316  }
317  }
318  }
319  }
320 
321  //4A2D.spin1
322  if ((N1==2) && (N2==2)){ //TwoSL==TwoSR --> no extra check for TwoSLdown needed
323 
324  for (int TwoSLdown = TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
325 
326  if (TwoSLdown>=0){
327 
328  int memSkappa = denS->gKappa(NL+2,TwoSLdown,ILdown,1,1,2,NR,TwoSR,IR);
329  if (memSkappa!=-1){
330 
331  int fase = phase(TwoSLdown - TwoSL);
332  double factor = fase * sqrt((TwoSLdown+1.0)/(TwoSL+1.0));
333  double * Bblock = Btens->gStorage(NL,TwoSL,IL,NL+2,TwoSLdown,ILdown);
334  int dimLdown = denBK->gCurrentDim(theindex,NL+2,TwoSLdown,ILdown);
335 
336  dgemm_(&notrans,&notrans,&dimLup,&dimR,&dimLdown,&factor,Bblock,&dimLup,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
337  }
338  }
339  }
340  }
341 
342 }
343 
344 void CheMPS2::Heff::addDiagram4A3and4A4spin0(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorOperator * Ctens) const{
345 
346  int NL = denS->gNL(ikappa);
347  int TwoSL = denS->gTwoSL(ikappa);
348  int IL = denS->gIL(ikappa);
349 
350  int NR = denS->gNR(ikappa);
351  int TwoSR = denS->gTwoSR(ikappa);
352  int IR = denS->gIR(ikappa);
353 
354  int N1 = denS->gN1(ikappa);
355  int N2 = denS->gN2(ikappa);
356  int TwoJ = denS->gTwoJ(ikappa);
357 
358  int theindex = denS->gIndex();
359  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
360  int dimR = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
361 
362  int ILdown = Irreps::directProd(IL,Ctens->get_irrep());
363 
364  char trans = 'T';
365  char notrans = 'N';
366  double beta = 1.0; //add
367 
368  //4A3A.spin0
369  if ((N1==1) && (N2==0)){
370 
371  int memSkappa = denS->gKappa(NL,TwoSL,ILdown,0,1,1,NR,TwoSR,IR);
372  if (memSkappa!=-1){
373 
374  double factor = sqrt(0.5);
375  int dimLdown = denBK->gCurrentDim(theindex,NL,TwoSL,ILdown);
376  double * ptr = Ctens->gStorage(NL,TwoSL,ILdown,NL,TwoSL,IL);
377 
378  dgemm_(&trans,&notrans,&dimLup,&dimR,&dimLdown,&factor,ptr,&dimLdown,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
379 
380  }
381  }
382 
383  //4A3B.spin0
384  if ((N1==1) && (N2==1) && (TwoJ==0)){
385 
386  int memSkappa = denS->gKappa(NL,TwoSL,ILdown,0,2,0,NR,TwoSR,IR);
387  if (memSkappa!=-1){
388 
389  double factor = 1.0;
390  int dimLdown = denBK->gCurrentDim(theindex,NL,TwoSL,ILdown);
391  double * ptr = Ctens->gStorage(NL,TwoSL,ILdown,NL,TwoSL,IL);
392 
393  dgemm_(&trans,&notrans,&dimLup,&dimR,&dimLdown,&factor,ptr,&dimLdown,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
394 
395  }
396  }
397 
398  //4A3C.spin0
399  if ((N1==2) && (N2==0)){
400 
401  int memSkappa = denS->gKappa(NL,TwoSL,ILdown,1,1,0,NR,TwoSR,IR);
402  if (memSkappa!=-1){
403 
404  double factor = 1.0;
405  int dimLdown = denBK->gCurrentDim(theindex,NL,TwoSL,ILdown);
406  double * ptr = Ctens->gStorage(NL,TwoSL,ILdown,NL,TwoSL,IL);
407 
408  dgemm_(&trans,&notrans,&dimLup,&dimR,&dimLdown,&factor,ptr,&dimLdown,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
409 
410  }
411  }
412 
413  //4A3D.spin0
414  if ((N1==2) && (N2==1)){
415 
416  int memSkappa = denS->gKappa(NL,TwoSL,ILdown,1,2,1,NR,TwoSR,IR);
417  if (memSkappa!=-1){
418 
419  double factor = - sqrt(0.5);
420  int dimLdown = denBK->gCurrentDim(theindex,NL,TwoSL,ILdown);
421  double * ptr = Ctens->gStorage(NL,TwoSL,ILdown,NL,TwoSL,IL);
422 
423  dgemm_(&trans,&notrans,&dimLup,&dimR,&dimLdown,&factor,ptr,&dimLdown,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
424 
425  }
426  }
427 
428  //4A4A.spin0
429  if ((N1==0) && (N2==1)){
430 
431  int memSkappa = denS->gKappa(NL,TwoSL,ILdown,1,0,1,NR,TwoSR,IR);
432  if (memSkappa!=-1){
433 
434  double factor = sqrt(0.5);
435  int dimLdown = denBK->gCurrentDim(theindex,NL,TwoSL,ILdown);
436  double * ptr = Ctens->gStorage(NL,TwoSL,IL,NL,TwoSL,ILdown);
437 
438  dgemm_(&notrans,&notrans,&dimLup,&dimR,&dimLdown,&factor,ptr,&dimLup,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
439 
440  }
441  }
442 
443  //4A4B.spin0
444  if ((N1==0) && (N2==2)){
445 
446  int memSkappa = denS->gKappa(NL,TwoSL,ILdown,1,1,0,NR,TwoSR,IR);
447  if (memSkappa!=-1){
448 
449  double factor = 1.0;
450  int dimLdown = denBK->gCurrentDim(theindex,NL,TwoSL,ILdown);
451  double * ptr = Ctens->gStorage(NL,TwoSL,IL,NL,TwoSL,ILdown);
452 
453  dgemm_(&notrans,&notrans,&dimLup,&dimR,&dimLdown,&factor,ptr,&dimLup,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
454 
455  }
456  }
457 
458  //4A4C.spin0
459  if ((N1==1) && (N2==1) && (TwoJ==0)){
460 
461  int memSkappa = denS->gKappa(NL,TwoSL,ILdown,2,0,0,NR,TwoSR,IR);
462  if (memSkappa!=-1){
463 
464  double factor = 1.0;
465  int dimLdown = denBK->gCurrentDim(theindex,NL,TwoSL,ILdown);
466  double * ptr = Ctens->gStorage(NL,TwoSL,IL,NL,TwoSL,ILdown);
467 
468  dgemm_(&notrans,&notrans,&dimLup,&dimR,&dimLdown,&factor,ptr,&dimLup,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
469 
470  }
471  }
472 
473  //4A4D.spin0
474  if ((N1==1) && (N2==2)){
475 
476  int memSkappa = denS->gKappa(NL,TwoSL,ILdown,2,1,1,NR,TwoSR,IR);
477  if (memSkappa!=-1){
478 
479  double factor = - sqrt(0.5);
480  int dimLdown = denBK->gCurrentDim(theindex,NL,TwoSL,ILdown);
481  double * ptr = Ctens->gStorage(NL,TwoSL,IL,NL,TwoSL,ILdown);
482 
483  dgemm_(&notrans,&notrans,&dimLup,&dimR,&dimLdown,&factor,ptr,&dimLup,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
484 
485  }
486  }
487 
488 }
489 
490 void CheMPS2::Heff::addDiagram4A3and4A4spin1(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorOperator * Dtens) const{
491 
492  int NL = denS->gNL(ikappa);
493  int TwoSL = denS->gTwoSL(ikappa);
494  int IL = denS->gIL(ikappa);
495 
496  int NR = denS->gNR(ikappa);
497  int TwoSR = denS->gTwoSR(ikappa);
498  int IR = denS->gIR(ikappa);
499 
500  int N1 = denS->gN1(ikappa);
501  int N2 = denS->gN2(ikappa);
502  int TwoJ = denS->gTwoJ(ikappa);
503 
504  int theindex = denS->gIndex();
505  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
506  int dimR = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
507 
508  int ILdown = Irreps::directProd(IL,Dtens->get_irrep());
509 
510  char trans = 'T';
511  char notrans = 'N';
512  double beta = 1.0; //add
513 
514  //4A3A.spin1
515  if ((N1==1) && (N2==0)){
516 
517  for (int TwoSLdown=TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
518  if ((abs(TwoSLdown-TwoSR)<=1) && (TwoSLdown>=0)){
519 
520  int memSkappa = denS->gKappa(NL,TwoSLdown,ILdown,0,1,1,NR,TwoSR,IR);
521  if (memSkappa!=-1){
522 
523  int fase = phase(TwoSLdown + TwoSR + 1);
524  double factor = fase * sqrt(3.0*(TwoSL+1)) * Wigner::wigner6j(1, 1, 2, TwoSL, TwoSLdown, TwoSR);
525  int dimLdown = denBK->gCurrentDim(theindex,NL,TwoSLdown,ILdown);
526  double * ptr = Dtens->gStorage(NL,TwoSLdown,ILdown,NL,TwoSL,IL);
527 
528  dgemm_(&trans,&notrans,&dimLup,&dimR,&dimLdown,&factor,ptr,&dimLdown,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
529  }
530  }
531  }
532  }
533 
534  //4A3B.spin1
535  if ((N1==1) && (N2==1) && (TwoJ==2)){
536 
537  int TwoSLdown = TwoSR;
538 
539  int memSkappa = denS->gKappa(NL,TwoSLdown,ILdown,0,2,0,NR,TwoSR,IR);
540  if (memSkappa!=-1){
541 
542  int fase = phase(TwoSLdown - TwoSL);
543  double factor = fase * sqrt((TwoSL+1.0)/(TwoSLdown+1.0));
544  int dimLdown = denBK->gCurrentDim(theindex,NL,TwoSLdown,ILdown);
545  double * ptr = Dtens->gStorage(NL,TwoSLdown,ILdown,NL,TwoSL,IL);
546 
547  dgemm_(&trans,&notrans,&dimLup,&dimR,&dimLdown,&factor,ptr,&dimLdown,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
548 
549  }
550  }
551 
552  //4A3C.spin1
553  if ((N1==2) && (N2==0)){ //TwoSL==TwoSR --> no extra bounds needed on TwoSLdown
554 
555  for (int TwoSLdown=TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
556  if (TwoSLdown>=0){
557 
558  int memSkappa = denS->gKappa(NL,TwoSLdown,ILdown,1,1,2,NR,TwoSR,IR);
559  if (memSkappa!=-1){
560 
561  double factor = -1.0;
562  int dimLdown = denBK->gCurrentDim(theindex,NL,TwoSLdown,ILdown);
563  double * ptr = Dtens->gStorage(NL,TwoSLdown,ILdown,NL,TwoSL,IL);
564 
565  dgemm_(&trans,&notrans,&dimLup,&dimR,&dimLdown,&factor,ptr,&dimLdown,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
566  }
567  }
568  }
569  }
570 
571  //4A3D.spin1
572  if ((N1==2) && (N2==1)){
573 
574  for (int TwoSLdown=TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
575  if ((abs(TwoSLdown-TwoSR)<=1) && (TwoSLdown>=0)){
576 
577  int memSkappa = denS->gKappa(NL,TwoSLdown,ILdown,1,2,1,NR,TwoSR,IR);
578  if (memSkappa!=-1){
579 
580  int fase = phase(TwoSLdown + TwoSR + 1);
581  double factor = fase * sqrt(3.0*(TwoSL+1)) * Wigner::wigner6j(1, 1, 2, TwoSL, TwoSLdown, TwoSR);
582  int dimLdown = denBK->gCurrentDim(theindex,NL,TwoSLdown,ILdown);
583  double * ptr = Dtens->gStorage(NL,TwoSLdown,ILdown,NL,TwoSL,IL);
584 
585  dgemm_(&trans,&notrans,&dimLup,&dimR,&dimLdown,&factor,ptr,&dimLdown,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
586  }
587  }
588  }
589  }
590 
591  //4A4A.spin1
592  if ((N1==0) && (N2==1)){
593 
594  for (int TwoSLdown=TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
595  if ((abs(TwoSLdown-TwoSR)<=1) && (TwoSLdown>=0)){
596 
597  int memSkappa = denS->gKappa(NL,TwoSLdown,ILdown,1,0,1,NR,TwoSR,IR);
598  if (memSkappa!=-1){
599 
600  int fase = phase(TwoSL + TwoSR + 1);
601  double factor = fase * sqrt(3.0*(TwoSLdown+1)) * Wigner::wigner6j(1, 1, 2, TwoSL, TwoSLdown, TwoSR);
602  int dimLdown = denBK->gCurrentDim(theindex,NL,TwoSLdown,ILdown);
603  double * ptr = Dtens->gStorage(NL,TwoSL,IL,NL,TwoSLdown,ILdown);
604 
605  dgemm_(&notrans,&notrans,&dimLup,&dimR,&dimLdown,&factor,ptr,&dimLup,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
606  }
607  }
608  }
609  }
610 
611  //4A4B.spin1
612  if ((N1==0) && (N2==2)){ //TwoSL==TwoSR --> no extra bounds needed on TwoSLdown
613 
614  for (int TwoSLdown=TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
615  if (TwoSLdown>=0){
616 
617  int memSkappa = denS->gKappa(NL,TwoSLdown,ILdown,1,1,2,NR,TwoSR,IR);
618  if (memSkappa!=-1){
619 
620  int fase = phase(TwoSL - TwoSLdown);
621  double factor = fase * sqrt((TwoSLdown+1.0)/(TwoSL+1.0));
622  int dimLdown = denBK->gCurrentDim(theindex,NL,TwoSLdown,ILdown);
623  double * ptr = Dtens->gStorage(NL,TwoSL,IL,NL,TwoSLdown,ILdown);
624 
625  dgemm_(&notrans,&notrans,&dimLup,&dimR,&dimLdown,&factor,ptr,&dimLup,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
626  }
627  }
628  }
629  }
630 
631  //4A4C.spin1
632  if ((N1==1) && (N2==1) && (TwoJ==2)){
633 
634  int TwoSLdown = TwoSR;
635 
636  int memSkappa = denS->gKappa(NL,TwoSLdown,ILdown,2,0,0,NR,TwoSR,IR);
637  if (memSkappa!=-1){
638 
639  double factor = -1.0;
640  int dimLdown = denBK->gCurrentDim(theindex,NL,TwoSLdown,ILdown);
641  double * ptr = Dtens->gStorage(NL,TwoSL,IL,NL,TwoSLdown,ILdown);
642 
643  dgemm_(&notrans,&notrans,&dimLup,&dimR,&dimLdown,&factor,ptr,&dimLup,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
644 
645  }
646  }
647 
648  //4A4D.spin1
649  if ((N1==1) && (N2==2)){
650 
651  for (int TwoSLdown=TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
652  if ((abs(TwoSLdown-TwoSR)<=1) && (TwoSLdown>=0)){
653 
654  int memSkappa = denS->gKappa(NL,TwoSLdown,ILdown,2,1,1,NR,TwoSR,IR);
655  if (memSkappa!=-1){
656 
657  int fase = phase(TwoSL + TwoSR + 1);
658  double factor = fase * sqrt(3.0*(TwoSLdown+1)) * Wigner::wigner6j(1, 1, 2, TwoSL, TwoSLdown, TwoSR);
659  int dimLdown = denBK->gCurrentDim(theindex,NL,TwoSLdown,ILdown);
660  double * ptr = Dtens->gStorage(NL,TwoSL,IL,NL,TwoSLdown,ILdown);
661 
662  dgemm_(&notrans,&notrans,&dimLup,&dimR,&dimLdown,&factor,ptr,&dimLup,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
663  }
664  }
665  }
666  }
667 
668 }
669 
670 void CheMPS2::Heff::addDiagram4B1and4B2spin0(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorOperator *** Aleft, TensorL ** Lright, double * temp) const{
671 
672  #ifdef CHEMPS2_MPI_COMPILATION
673  const int MPIRANK = MPIchemps2::mpi_rank();
674  #endif
675 
676  int NL = denS->gNL(ikappa);
677  int TwoSL = denS->gTwoSL(ikappa);
678  int IL = denS->gIL(ikappa);
679 
680  int NR = denS->gNR(ikappa);
681  int TwoSR = denS->gTwoSR(ikappa);
682  int IR = denS->gIR(ikappa);
683 
684  int N1 = denS->gN1(ikappa);
685  int N2 = denS->gN2(ikappa);
686  int TwoJ = denS->gTwoJ(ikappa);
687  int TwoS2 = (N2==1)?1:0;
688 
689  int theindex = denS->gIndex();
690  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
691  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
692 
693  char trans = 'T';
694  char notrans = 'N';
695 
696  //4B1A.spin0
697  if (N1==0){
698 
699  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
700 
701  int TwoJstart = ((TwoSL!=TwoSRdown) || (TwoS2==0)) ? TwoS2+1 : 0;
702  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS2+1; TwoJdown+=2){
703  if ((abs(TwoSL-TwoSRdown)<=TwoJdown) && (TwoSRdown>=0)){
704 
705  int fase = phase(TwoSR + TwoSL + 1 + TwoJdown + 2*TwoS2);
706  const double factor = fase * sqrt(0.5*(TwoSR+1)*(TwoJdown+1)) * Wigner::wigner6j(TwoJdown, TwoS2, 1, TwoSR, TwoSRdown, TwoSL);
707 
708  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
709 
710  #ifdef CHEMPS2_MPI_COMPILATION
711  if ( MPIchemps2::owner_absigma( theindex, l_index ) == MPIRANK )
712  #endif
713  {
714  int ILdown = Irreps::directProd(IL, Aleft[l_index-theindex][0]->get_irrep() );
715  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
716  int memSkappa = denS->gKappa(NL-2, TwoSL, ILdown, 1, N2, TwoJdown, NR-1, TwoSRdown, IRdown);
717 
718  if (memSkappa!=-1){
719 
720  int dimLdown = denBK->gCurrentDim(theindex , NL-2, TwoSL, ILdown);
721  int dimRdown = denBK->gCurrentDim(theindex+2, NR-1, TwoSRdown, IRdown);
722 
723  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
724  double alpha = 1.0;
725  double beta = 0.0; //set
726  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRdown, &beta,temp,&dimLdown);
727 
728  double * Ablock = Aleft[l_index-theindex][0]->gStorage(NL-2,TwoSL,ILdown,NL,TwoSL,IL);
729  alpha = factor;
730  beta = 1.0; //add
731  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,Ablock,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
732 
733  }
734  }
735  }
736  }
737  }
738  }
739  }
740 
741  //4B1B.spin0
742  if (N1==1){
743 
744  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
745  if ((abs(TwoSL-TwoSRdown)<=TwoS2) && (TwoSRdown>=0)){
746 
747  int fase = phase(TwoSR + TwoSL + 2 + TwoJ + 2*TwoS2);
748  const double factor = fase * sqrt(0.5*(TwoSR+1)*(TwoJ+1)) * Wigner::wigner6j(TwoJ, TwoS2, 1, TwoSRdown, TwoSR, TwoSL);
749 
750  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
751 
752  #ifdef CHEMPS2_MPI_COMPILATION
753  if ( MPIchemps2::owner_absigma( theindex, l_index ) == MPIRANK )
754  #endif
755  {
756  int ILdown = Irreps::directProd(IL, Aleft[l_index-theindex][0]->get_irrep() );
757  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
758  int memSkappa = denS->gKappa(NL-2, TwoSL, ILdown, 2, N2, TwoS2, NR-1, TwoSRdown, IRdown);
759 
760  if (memSkappa!=-1){
761 
762  int dimLdown = denBK->gCurrentDim(theindex , NL-2, TwoSL, ILdown);
763  int dimRdown = denBK->gCurrentDim(theindex+2, NR-1, TwoSRdown, IRdown);
764 
765  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
766  double alpha = 1.0;
767  double beta = 0.0; //set
768  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRdown,&beta,temp,&dimLdown);
769 
770  double * Ablock = Aleft[l_index-theindex][0]->gStorage(NL-2,TwoSL,ILdown,NL,TwoSL,IL);
771  alpha = factor;
772  beta = 1.0; //add
773  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,Ablock,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
774 
775  }
776  }
777  }
778  }
779  }
780  }
781 
782  //4B2A.spin0
783  if (N1==1){
784 
785  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
786  if ((abs(TwoSL-TwoSRdown)<=TwoS2) && (TwoSRdown>=0)){
787 
788  int fase = phase(TwoSRdown + TwoSL + 1 + TwoJ + 2*TwoS2);
789  const double factor = fase * sqrt(0.5*(TwoSRdown+1)*(TwoJ+1)) * Wigner::wigner6j(TwoJ, TwoS2, 1, TwoSRdown, TwoSR, TwoSL);
790 
791  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
792 
793  #ifdef CHEMPS2_MPI_COMPILATION
794  if ( MPIchemps2::owner_absigma( theindex, l_index ) == MPIRANK )
795  #endif
796  {
797  int ILdown = Irreps::directProd(IL, Aleft[l_index-theindex][0]->get_irrep() );
798  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
799  int memSkappa = denS->gKappa(NL+2, TwoSL, ILdown, 0, N2, TwoS2, NR+1, TwoSRdown, IRdown);
800 
801  if (memSkappa!=-1){
802 
803  int dimLdown = denBK->gCurrentDim(theindex , NL+2, TwoSL, ILdown);
804  int dimRdown = denBK->gCurrentDim(theindex+2, NR+1, TwoSRdown, IRdown);
805 
806  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
807  double alpha = 1.0;
808  double beta = 0.0; //set
809  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRup,&beta,temp,&dimLdown);
810 
811  double * Ablock = Aleft[l_index-theindex][0]->gStorage(NL,TwoSL,IL,NL+2,TwoSL,ILdown);
812  alpha = factor;
813  beta = 1.0; //add
814  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,Ablock,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
815 
816  }
817  }
818  }
819  }
820  }
821  }
822 
823  //4B2B.spin0
824  if (N1==2){
825 
826  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
827 
828  int TwoJstart = ((TwoSL!=TwoSRdown) || (TwoS2==0)) ? TwoS2+1 : 0;
829  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS2+1; TwoJdown+=2){
830  if ((abs(TwoSL-TwoSRdown)<=TwoJdown) && (TwoSRdown>=0)){
831 
832  int fase = phase(TwoSRdown + TwoSL + 2 + TwoJdown + 2*TwoS2);
833  const double factor = fase * sqrt(0.5*(TwoSRdown+1)*(TwoJdown+1)) * Wigner::wigner6j(TwoJdown, TwoS2, 1, TwoSR, TwoSRdown, TwoSL);
834 
835  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
836 
837  #ifdef CHEMPS2_MPI_COMPILATION
838  if ( MPIchemps2::owner_absigma( theindex, l_index ) == MPIRANK )
839  #endif
840  {
841  int ILdown = Irreps::directProd(IL, Aleft[l_index-theindex][0]->get_irrep() );
842  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
843  int memSkappa = denS->gKappa(NL+2, TwoSL, ILdown, 1, N2, TwoJdown, NR+1, TwoSRdown, IRdown);
844 
845  if (memSkappa!=-1){
846 
847  int dimLdown = denBK->gCurrentDim(theindex , NL+2, TwoSL, ILdown);
848  int dimRdown = denBK->gCurrentDim(theindex+2, NR+1, TwoSRdown, IRdown);
849 
850  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
851  double alpha = 1.0;
852  double beta = 0.0; //set
853  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRup,&beta,temp,&dimLdown);
854 
855  double * Ablock = Aleft[l_index-theindex][0]->gStorage(NL,TwoSL,IL,NL+2,TwoSL,ILdown);
856  alpha = factor;
857  beta = 1.0; //add
858  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,Ablock,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
859 
860  }
861  }
862  }
863  }
864  }
865  }
866  }
867 
868 }
869 
870 void CheMPS2::Heff::addDiagram4B1and4B2spin1(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorOperator *** Bleft, TensorL ** Lright, double * temp) const{
871 
872  #ifdef CHEMPS2_MPI_COMPILATION
873  const int MPIRANK = MPIchemps2::mpi_rank();
874  #endif
875 
876  int NL = denS->gNL(ikappa);
877  int TwoSL = denS->gTwoSL(ikappa);
878  int IL = denS->gIL(ikappa);
879 
880  int NR = denS->gNR(ikappa);
881  int TwoSR = denS->gTwoSR(ikappa);
882  int IR = denS->gIR(ikappa);
883 
884  int N1 = denS->gN1(ikappa);
885  int N2 = denS->gN2(ikappa);
886  int TwoJ = denS->gTwoJ(ikappa);
887  int TwoS2 = (N2==1)?1:0;
888 
889  int theindex = denS->gIndex();
890  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
891  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
892 
893  char trans = 'T';
894  char notrans = 'N';
895 
896  //4B1A.spin1
897  if (N1==0){
898 
899  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
900  for (int TwoSLdown=TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
901 
902  int TwoJstart = ((TwoSLdown!=TwoSRdown) || (TwoS2==0)) ? TwoS2+1 : 0;
903  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS2+1; TwoJdown+=2){
904  if ((abs(TwoSLdown-TwoSRdown)<=TwoJdown) && (TwoSLdown>=0) && (TwoSRdown>=0)){
905 
906  int fase = (TwoS2==0)?1:-1;
907  const double factor = fase * sqrt(3.0*(TwoSR+1)*(TwoSL+1)*(TwoJdown+1))
908  * Wigner::wigner9j(2, TwoSLdown, TwoSL, 1, TwoSRdown, TwoSR, 1, TwoJdown, TwoS2);
909 
910  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
911 
912  #ifdef CHEMPS2_MPI_COMPILATION
913  if ( MPIchemps2::owner_absigma( theindex, l_index ) == MPIRANK )
914  #endif
915  {
916  int ILdown = Irreps::directProd(IL, Bleft[l_index-theindex][0]->get_irrep() );
917  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
918  int memSkappa = denS->gKappa(NL-2, TwoSLdown, ILdown, 1, N2, TwoJdown, NR-1, TwoSRdown, IRdown);
919 
920  if (memSkappa!=-1){
921 
922  int dimLdown = denBK->gCurrentDim(theindex , NL-2, TwoSLdown, ILdown);
923  int dimRdown = denBK->gCurrentDim(theindex+2, NR-1, TwoSRdown, IRdown);
924 
925  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
926  double alpha = 1.0;
927  double beta = 0.0; //set
928  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown, Lblock,&dimRdown, &beta,temp, &dimLdown);
929 
930  double * Bblock = Bleft[l_index-theindex][0]->gStorage(NL-2,TwoSLdown,ILdown,NL,TwoSL,IL);
931  alpha = factor;
932  beta = 1.0; //add
933  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,Bblock,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
934 
935  }
936  }
937  }
938  }
939  }
940  }
941  }
942  }
943 
944  //4B1B.spin1
945  if (N1==1){
946 
947  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
948  for (int TwoSLdown=TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
949  if ((abs(TwoSLdown-TwoSRdown)<=TwoS2) && (TwoSLdown>=0) && (TwoSRdown>=0)){
950 
951  int fase = phase(TwoSR - TwoSRdown + TwoSL + 3 - TwoSLdown + 2*TwoS2);
952  const double factor = fase * sqrt(3.0*(TwoSR+1)*(TwoSL+1)*(TwoJ+1))
953  * Wigner::wigner9j(2, TwoSL, TwoSLdown, 1, TwoSR, TwoSRdown, 1, TwoJ, TwoS2);
954 
955  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
956 
957  #ifdef CHEMPS2_MPI_COMPILATION
958  if ( MPIchemps2::owner_absigma( theindex, l_index ) == MPIRANK )
959  #endif
960  {
961  int ILdown = Irreps::directProd(IL, Bleft[l_index-theindex][0]->get_irrep() );
962  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
963  int memSkappa = denS->gKappa(NL-2, TwoSLdown, ILdown, 2, N2, TwoS2, NR-1, TwoSRdown, IRdown);
964 
965  if (memSkappa!=-1){
966 
967  int dimLdown = denBK->gCurrentDim(theindex , NL-2, TwoSLdown, ILdown);
968  int dimRdown = denBK->gCurrentDim(theindex+2, NR-1, TwoSRdown, IRdown);
969 
970  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
971  double alpha = 1.0;
972  double beta = 0.0; //set
973  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRdown,&beta,temp, &dimLdown);
974 
975  double * Bblock = Bleft[l_index-theindex][0]->gStorage(NL-2,TwoSLdown,ILdown,NL,TwoSL,IL);
976  alpha = factor;
977  beta = 1.0; //add
978  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,Bblock,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
979 
980  }
981  }
982  }
983  }
984  }
985  }
986  }
987 
988  //4B2A.spin1
989  if (N1==1){
990 
991  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
992  for (int TwoSLdown=TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
993  if ((abs(TwoSLdown-TwoSRdown)<=TwoS2) && (TwoSLdown>=0) && (TwoSRdown>=0)){
994 
995  int fase = (TwoS2==0)?1:-1;
996  const double factor = fase * sqrt(3.0*(TwoSRdown+1)*(TwoSLdown+1)*(TwoJ+1))
997  * Wigner::wigner9j(2, TwoSL, TwoSLdown, 1, TwoSR, TwoSRdown, 1, TwoJ, TwoS2);
998 
999  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
1000 
1001  #ifdef CHEMPS2_MPI_COMPILATION
1002  if ( MPIchemps2::owner_absigma( theindex, l_index ) == MPIRANK )
1003  #endif
1004  {
1005  int ILdown = Irreps::directProd(IL, Bleft[l_index-theindex][0]->get_irrep() );
1006  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
1007  int memSkappa = denS->gKappa(NL+2, TwoSLdown, ILdown, 0, N2, TwoS2, NR+1, TwoSRdown, IRdown);
1008 
1009  if (memSkappa!=-1){
1010 
1011  int dimLdown = denBK->gCurrentDim(theindex , NL+2, TwoSLdown, ILdown);
1012  int dimRdown = denBK->gCurrentDim(theindex+2, NR+1, TwoSRdown, IRdown);
1013 
1014  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
1015  double alpha = 1.0;
1016  double beta = 0.0; //set
1017  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRup,&beta,temp,&dimLdown);
1018 
1019  double * Bblock = Bleft[l_index-theindex][0]->gStorage(NL,TwoSL,IL,NL+2,TwoSLdown,ILdown);
1020  alpha = factor;
1021  beta = 1.0; //add
1022  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,Bblock,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
1023 
1024  }
1025  }
1026  }
1027  }
1028  }
1029  }
1030  }
1031 
1032  //4B2B.spin1
1033  if (N1==2){
1034 
1035  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
1036  for (int TwoSLdown=TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
1037 
1038  int TwoJstart = ((TwoSLdown!=TwoSRdown) || (TwoS2==0)) ? TwoS2+1 : 0;
1039  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS2+1; TwoJdown+=2){
1040  if ((abs(TwoSLdown-TwoSRdown)<=TwoJdown) && (TwoSLdown>=0) && (TwoSRdown>=0)){
1041 
1042  int fase = phase(TwoSLdown + 3 - TwoSL + TwoSRdown - TwoSR + 2*TwoS2);
1043  const double factor = fase * sqrt(3.0*(TwoSRdown+1)*(TwoJdown+1)*(TwoSLdown+1))
1044  * Wigner::wigner9j(2, TwoSLdown, TwoSL, 1, TwoSRdown, TwoSR, 1, TwoJdown, TwoS2);
1045 
1046  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
1047 
1048  #ifdef CHEMPS2_MPI_COMPILATION
1049  if ( MPIchemps2::owner_absigma( theindex, l_index ) == MPIRANK )
1050  #endif
1051  {
1052  int ILdown = Irreps::directProd(IL, Bleft[l_index-theindex][0]->get_irrep() );
1053  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
1054  int memSkappa = denS->gKappa(NL+2, TwoSLdown, ILdown, 1, N2, TwoJdown, NR+1, TwoSRdown, IRdown);
1055 
1056  if (memSkappa!=-1){
1057 
1058  int dimLdown = denBK->gCurrentDim(theindex , NL+2, TwoSLdown, ILdown);
1059  int dimRdown = denBK->gCurrentDim(theindex+2, NR+1, TwoSRdown, IRdown);
1060 
1061  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
1062  double alpha = 1.0;
1063  double beta = 0.0; //set
1064  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRup,&beta,temp, &dimLdown);
1065 
1066  double * Bblock = Bleft[l_index-theindex][0]->gStorage(NL,TwoSL,IL,NL+2,TwoSLdown,ILdown);
1067  alpha = factor;
1068  beta = 1.0; //add
1069  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,Bblock,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
1070 
1071  }
1072  }
1073  }
1074  }
1075  }
1076  }
1077  }
1078  }
1079 
1080 }
1081 
1082 void CheMPS2::Heff::addDiagram4B3and4B4spin0(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorOperator *** Cleft, TensorL ** Lright, double * temp) const{
1083 
1084  #ifdef CHEMPS2_MPI_COMPILATION
1085  const int MPIRANK = MPIchemps2::mpi_rank();
1086  #endif
1087 
1088  int NL = denS->gNL(ikappa);
1089  int TwoSL = denS->gTwoSL(ikappa);
1090  int IL = denS->gIL(ikappa);
1091 
1092  int NR = denS->gNR(ikappa);
1093  int TwoSR = denS->gTwoSR(ikappa);
1094  int IR = denS->gIR(ikappa);
1095 
1096  int N1 = denS->gN1(ikappa);
1097  int N2 = denS->gN2(ikappa);
1098  int TwoJ = denS->gTwoJ(ikappa);
1099  int TwoS2 = (N2==1)?1:0;
1100 
1101  int theindex = denS->gIndex();
1102  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
1103  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
1104 
1105  char trans = 'T';
1106  char notrans = 'N';
1107 
1108  //4B3A.spin0
1109  if (N1==1){
1110 
1111  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
1112  if ((abs(TwoSL-TwoSRdown)<=TwoS2) && (TwoSRdown>=0)){
1113 
1114  int fase = phase(TwoSR + TwoSL + TwoJ + 2*TwoS2);
1115  const double factor = fase * sqrt(0.5*(TwoSR+1)*(TwoJ+1)) * Wigner::wigner6j(TwoJ, TwoS2, 1, TwoSRdown, TwoSR, TwoSL);
1116 
1117  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
1118 
1119  #ifdef CHEMPS2_MPI_COMPILATION
1120  if ( MPIchemps2::owner_cdf( Prob->gL(), theindex, l_index ) == MPIRANK )
1121  #endif
1122  {
1123  int ILdown = Irreps::directProd(IL, Cleft[l_index-theindex][0]->get_irrep() );
1124  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
1125  int memSkappa = denS->gKappa(NL, TwoSL, ILdown, 0, N2, TwoS2, NR-1, TwoSRdown, IRdown);
1126 
1127  if (memSkappa!=-1){
1128 
1129  int dimLdown = denBK->gCurrentDim(theindex , NL, TwoSL, ILdown);
1130  int dimRdown = denBK->gCurrentDim(theindex+2, NR-1, TwoSRdown, IRdown);
1131 
1132  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
1133  double alpha = 1.0;
1134  double beta = 0.0; //set
1135  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRdown,&beta,temp,&dimLdown);
1136 
1137  double * ptr = Cleft[l_index-theindex][0]->gStorage(NL,TwoSL,ILdown,NL,TwoSL,IL);
1138 
1139  alpha = factor;
1140  beta = 1.0; //add
1141  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,ptr,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
1142 
1143  }
1144  }
1145  }
1146  }
1147  }
1148  }
1149 
1150  //4B3B.spin0
1151  if (N1==2){
1152 
1153  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
1154 
1155  int TwoJstart = ((TwoSL!=TwoSRdown) || (TwoS2==0)) ? TwoS2+1 : 0;
1156  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS2+1; TwoJdown+=2){
1157  if ((abs(TwoSL-TwoSRdown)<=TwoJdown) && (TwoSRdown>=0)){
1158 
1159  int fase = phase(TwoSR + TwoSL + 1 + TwoJdown + 2*TwoS2);
1160  const double factor = fase * sqrt(0.5*(TwoSR+1)*(TwoJdown+1)) * Wigner::wigner6j(TwoJdown, TwoS2, 1, TwoSR, TwoSRdown, TwoSL);
1161 
1162  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
1163 
1164  #ifdef CHEMPS2_MPI_COMPILATION
1165  if ( MPIchemps2::owner_cdf( Prob->gL(), theindex, l_index ) == MPIRANK )
1166  #endif
1167  {
1168  int ILdown = Irreps::directProd(IL, Cleft[l_index-theindex][0]->get_irrep() );
1169  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
1170  int memSkappa = denS->gKappa(NL, TwoSL, ILdown, 1, N2, TwoJdown, NR-1, TwoSRdown, IRdown);
1171 
1172  if (memSkappa!=-1){
1173 
1174  int dimLdown = denBK->gCurrentDim(theindex , NL, TwoSL, ILdown);
1175  int dimRdown = denBK->gCurrentDim(theindex+2, NR-1, TwoSRdown, IRdown);
1176 
1177  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
1178  double alpha = 1.0;
1179  double beta = 0.0; //set
1180  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRdown,&beta,temp, &dimLdown);
1181 
1182  double * ptr = Cleft[l_index-theindex][0]->gStorage(NL,TwoSL,ILdown,NL,TwoSL,IL);
1183 
1184  alpha = factor;
1185  beta = 1.0; //add
1186  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,ptr,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
1187 
1188  }
1189  }
1190  }
1191  }
1192  }
1193  }
1194  }
1195 
1196  //4B4A.spin0
1197  if (N1==0){
1198 
1199  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
1200 
1201  int TwoJstart = ((TwoSL!=TwoSRdown) || (TwoS2==0)) ? TwoS2+1 : 0;
1202  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS2+1; TwoJdown+=2){
1203  if ((abs(TwoSL-TwoSRdown)<=TwoJdown) && (TwoSRdown>=0)){
1204 
1205  int fase = phase(TwoSRdown + TwoSL + TwoJdown + 2*TwoS2);
1206  const double factor = fase * sqrt(0.5*(TwoSRdown+1)*(TwoJdown+1)) * Wigner::wigner6j(TwoJdown, TwoS2, 1, TwoSR, TwoSRdown, TwoSL);
1207 
1208  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
1209 
1210  #ifdef CHEMPS2_MPI_COMPILATION
1211  if ( MPIchemps2::owner_cdf( Prob->gL(), theindex, l_index ) == MPIRANK )
1212  #endif
1213  {
1214  int ILdown = Irreps::directProd(IL, Cleft[l_index-theindex][0]->get_irrep() );
1215  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
1216  int memSkappa = denS->gKappa(NL, TwoSL, ILdown, 1, N2, TwoJdown, NR+1, TwoSRdown, IRdown);
1217 
1218  if (memSkappa!=-1){
1219 
1220  int dimLdown = denBK->gCurrentDim(theindex , NL, TwoSL, ILdown);
1221  int dimRdown = denBK->gCurrentDim(theindex+2, NR+1, TwoSRdown, IRdown);
1222 
1223  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
1224  double alpha = 1.0;
1225  double beta = 0.0; //set
1226  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRup,&beta,temp,&dimLdown);
1227 
1228  double * ptr = Cleft[l_index-theindex][0]->gStorage(NL,TwoSL,IL,NL,TwoSL,ILdown);
1229 
1230  alpha = factor;
1231  beta = 1.0; //add
1232  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,ptr,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
1233 
1234  }
1235  }
1236  }
1237  }
1238  }
1239  }
1240  }
1241 
1242  //4B4B.spin0
1243  if (N1==1){
1244 
1245  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
1246  if ((abs(TwoSL-TwoSRdown)<=TwoS2) && (TwoSRdown>=0)){
1247 
1248  int fase = phase(TwoSRdown + TwoSL + 1 + TwoJ + 2*TwoS2);
1249  const double factor = fase * sqrt(0.5*(TwoSRdown+1)*(TwoJ+1)) * Wigner::wigner6j(TwoJ, TwoS2, 1, TwoSRdown, TwoSR, TwoSL);
1250 
1251  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
1252 
1253  #ifdef CHEMPS2_MPI_COMPILATION
1254  if ( MPIchemps2::owner_cdf( Prob->gL(), theindex, l_index ) == MPIRANK )
1255  #endif
1256  {
1257  int ILdown = Irreps::directProd(IL, Cleft[l_index-theindex][0]->get_irrep() );
1258  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
1259  int memSkappa = denS->gKappa(NL, TwoSL, ILdown, 2, N2, TwoS2, NR+1, TwoSRdown, IRdown);
1260 
1261  if (memSkappa!=-1){
1262 
1263  int dimLdown = denBK->gCurrentDim(theindex , NL, TwoSL, ILdown);
1264  int dimRdown = denBK->gCurrentDim(theindex+2, NR+1, TwoSRdown, IRdown);
1265 
1266  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
1267  double alpha = 1.0;
1268  double beta = 0.0; //set
1269  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRup,&beta,temp,&dimLdown);
1270 
1271  double * ptr = Cleft[l_index-theindex][0]->gStorage(NL,TwoSL,IL,NL,TwoSL,ILdown);
1272 
1273  alpha = factor;
1274  beta = 1.0; //add
1275  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,ptr,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
1276 
1277  }
1278  }
1279  }
1280  }
1281  }
1282  }
1283 
1284 }
1285 
1286 void CheMPS2::Heff::addDiagram4B3and4B4spin1(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorOperator *** Dleft, TensorL ** Lright, double * temp) const{
1287 
1288  #ifdef CHEMPS2_MPI_COMPILATION
1289  const int MPIRANK = MPIchemps2::mpi_rank();
1290  #endif
1291 
1292  int NL = denS->gNL(ikappa);
1293  int TwoSL = denS->gTwoSL(ikappa);
1294  int IL = denS->gIL(ikappa);
1295 
1296  int NR = denS->gNR(ikappa);
1297  int TwoSR = denS->gTwoSR(ikappa);
1298  int IR = denS->gIR(ikappa);
1299 
1300  int N1 = denS->gN1(ikappa);
1301  int N2 = denS->gN2(ikappa);
1302  int TwoJ = denS->gTwoJ(ikappa);
1303  int TwoS2 = (N2==1)?1:0;
1304 
1305  int theindex = denS->gIndex();
1306  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
1307  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
1308 
1309  char trans = 'T';
1310  char notrans = 'N';
1311 
1312  //4B3A.spin1
1313  if (N1==1){
1314 
1315  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
1316  for (int TwoSLdown=TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
1317  if ((abs(TwoSLdown-TwoSRdown)<=TwoS2) && (TwoSLdown>=0) && (TwoSRdown>=0)){
1318 
1319  int fase = phase(TwoSL-TwoSLdown + TwoSR - TwoSRdown + 3 + 2*TwoS2);
1320  const double factor = fase * sqrt(3.0*(TwoSR+1)*(TwoJ+1)*(TwoSL+1))
1321  * Wigner::wigner9j(2, TwoSL, TwoSLdown, 1, TwoSR, TwoSRdown, 1, TwoJ, TwoS2);
1322 
1323  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
1324 
1325  #ifdef CHEMPS2_MPI_COMPILATION
1326  if ( MPIchemps2::owner_cdf( Prob->gL(), theindex, l_index ) == MPIRANK )
1327  #endif
1328  {
1329  int ILdown = Irreps::directProd(IL, Dleft[l_index-theindex][0]->get_irrep() );
1330  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
1331  int memSkappa = denS->gKappa(NL, TwoSLdown, ILdown, 0, N2, TwoS2, NR-1, TwoSRdown, IRdown);
1332 
1333  if (memSkappa!=-1){
1334 
1335  int dimLdown = denBK->gCurrentDim(theindex , NL, TwoSLdown, ILdown);
1336  int dimRdown = denBK->gCurrentDim(theindex+2, NR-1, TwoSRdown, IRdown);
1337 
1338  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
1339  double alpha = 1.0;
1340  double beta = 0.0; //set
1341  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRdown,&beta,temp, &dimLdown);
1342 
1343  double * ptr = Dleft[l_index-theindex][0]->gStorage(NL,TwoSLdown,ILdown,NL,TwoSL,IL);
1344 
1345  alpha = factor;
1346  beta = 1.0; //add
1347  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,ptr,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
1348 
1349  }
1350  }
1351  }
1352  }
1353  }
1354  }
1355  }
1356 
1357  //4B3B.spin1
1358  if (N1==2){
1359 
1360  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
1361  for (int TwoSLdown=TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
1362 
1363  int TwoJstart = ((TwoSLdown!=TwoSRdown) || (TwoS2==0)) ? TwoS2+1 : 0;
1364  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS2+1; TwoJdown+=2){
1365  if ((abs(TwoSLdown-TwoSRdown)<=TwoJdown) && (TwoSLdown>=0) && (TwoSRdown>=0)){
1366 
1367  int fase = (TwoS2==0)?-1:1;
1368  const double factor = fase * sqrt(3.0*(TwoSR+1)*(TwoJdown+1)*(TwoSL+1))
1369  * Wigner::wigner9j(2, TwoSLdown, TwoSL, 1, TwoSRdown, TwoSR, 1, TwoJdown, TwoS2);
1370 
1371  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
1372 
1373  #ifdef CHEMPS2_MPI_COMPILATION
1374  if ( MPIchemps2::owner_cdf( Prob->gL(), theindex, l_index ) == MPIRANK )
1375  #endif
1376  {
1377  int ILdown = Irreps::directProd(IL, Dleft[l_index-theindex][0]->get_irrep() );
1378  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
1379  int memSkappa = denS->gKappa(NL, TwoSLdown, ILdown, 1, N2, TwoJdown, NR-1, TwoSRdown, IRdown);
1380 
1381  if (memSkappa!=-1){
1382 
1383  int dimLdown = denBK->gCurrentDim(theindex , NL, TwoSLdown, ILdown);
1384  int dimRdown = denBK->gCurrentDim(theindex+2, NR-1, TwoSRdown, IRdown);
1385 
1386  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
1387  double alpha = 1.0;
1388  double beta = 0.0; //set
1389  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRdown,&beta,temp, &dimLdown);
1390 
1391  double * ptr = Dleft[l_index-theindex][0]->gStorage(NL,TwoSLdown,ILdown,NL,TwoSL,IL);
1392 
1393  alpha = factor;
1394  beta = 1.0; //add
1395  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,ptr,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
1396 
1397  }
1398  }
1399  }
1400  }
1401  }
1402  }
1403  }
1404  }
1405 
1406  //4B4A.spin1
1407  if (N1==0){
1408 
1409  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
1410  for (int TwoSLdown=TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
1411 
1412  int TwoJstart = ((TwoSLdown!=TwoSRdown) || (TwoS2==0)) ? TwoS2+1 : 0;
1413  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS2+1; TwoJdown+=2){
1414  if ((abs(TwoSLdown-TwoSRdown)<=TwoJdown) && (TwoSLdown>=0) && (TwoSRdown>=0)){
1415 
1416  int fase = phase(TwoSRdown - TwoSR + TwoSLdown - TwoSL + 3 + 2*TwoS2);
1417  const double factor = fase * sqrt(3.0*(TwoSRdown+1)*(TwoJdown+1)*(TwoSLdown+1))
1418  * Wigner::wigner9j(2, TwoSLdown, TwoSL, 1, TwoSRdown, TwoSR, 1, TwoJdown, TwoS2);
1419 
1420  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
1421 
1422  #ifdef CHEMPS2_MPI_COMPILATION
1423  if ( MPIchemps2::owner_cdf( Prob->gL(), theindex, l_index ) == MPIRANK )
1424  #endif
1425  {
1426  int ILdown = Irreps::directProd(IL, Dleft[l_index-theindex][0]->get_irrep() );
1427  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
1428  int memSkappa = denS->gKappa(NL, TwoSLdown, ILdown, 1, N2, TwoJdown, NR+1, TwoSRdown, IRdown);
1429 
1430  if (memSkappa!=-1){
1431 
1432  int dimLdown = denBK->gCurrentDim(theindex , NL, TwoSLdown, ILdown);
1433  int dimRdown = denBK->gCurrentDim(theindex+2, NR+1, TwoSRdown, IRdown);
1434 
1435  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
1436  double alpha = 1.0;
1437  double beta = 0.0; //set
1438  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRup,&beta,temp, &dimLdown);
1439 
1440  double * ptr = Dleft[l_index-theindex][0]->gStorage(NL,TwoSL,IL,NL,TwoSLdown,ILdown);
1441 
1442  alpha = factor;
1443  beta = 1.0; //add
1444  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,ptr,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
1445 
1446  }
1447  }
1448  }
1449  }
1450  }
1451  }
1452  }
1453  }
1454 
1455  //4B4B.spin1
1456  if (N1==1){
1457 
1458  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
1459  for (int TwoSLdown=TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
1460  if ((abs(TwoSLdown-TwoSRdown)<=TwoS2) && (TwoSLdown>=0) && (TwoSRdown>=0)){
1461 
1462  int fase = (TwoS2==0)?-1:1;
1463  const double factor = fase * sqrt(3.0*(TwoSRdown+1)*(TwoJ+1)*(TwoSLdown+1))
1464  * Wigner::wigner9j(2, TwoSL, TwoSLdown, 1, TwoSR, TwoSRdown, 1, TwoJ, TwoS2);
1465 
1466  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
1467 
1468  #ifdef CHEMPS2_MPI_COMPILATION
1469  if ( MPIchemps2::owner_cdf( Prob->gL(), theindex, l_index ) == MPIRANK )
1470  #endif
1471  {
1472  int ILdown = Irreps::directProd(IL, Dleft[l_index-theindex][0]->get_irrep() );
1473  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
1474  int memSkappa = denS->gKappa(NL, TwoSLdown, ILdown, 2, N2, TwoS2, NR+1, TwoSRdown, IRdown);
1475 
1476  if (memSkappa!=-1){
1477 
1478  int dimLdown = denBK->gCurrentDim(theindex , NL, TwoSLdown, ILdown);
1479  int dimRdown = denBK->gCurrentDim(theindex+2, NR+1, TwoSRdown, IRdown);
1480 
1481  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
1482  double alpha = 1.0;
1483  double beta = 0.0; //set
1484  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRup,&beta,temp,&dimLdown);
1485 
1486  double * ptr = Dleft[l_index-theindex][0]->gStorage(NL,TwoSL,IL,NL,TwoSLdown,ILdown);
1487 
1488  alpha = factor;
1489  beta = 1.0; //add
1490  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,ptr,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
1491 
1492  }
1493  }
1494  }
1495  }
1496  }
1497  }
1498  }
1499 
1500 }
1501 
1502 void CheMPS2::Heff::addDiagram4C1and4C2spin0(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorOperator *** Aleft, TensorL ** Lright, double * temp) const{
1503 
1504  #ifdef CHEMPS2_MPI_COMPILATION
1505  const int MPIRANK = MPIchemps2::mpi_rank();
1506  #endif
1507 
1508  int NL = denS->gNL(ikappa);
1509  int TwoSL = denS->gTwoSL(ikappa);
1510  int IL = denS->gIL(ikappa);
1511 
1512  int NR = denS->gNR(ikappa);
1513  int TwoSR = denS->gTwoSR(ikappa);
1514  int IR = denS->gIR(ikappa);
1515 
1516  int N1 = denS->gN1(ikappa);
1517  int N2 = denS->gN2(ikappa);
1518  int TwoJ = denS->gTwoJ(ikappa);
1519  int TwoS1 = (N1==1)?1:0;
1520 
1521  int theindex = denS->gIndex();
1522  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
1523  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
1524 
1525  char trans = 'T';
1526  char notrans = 'N';
1527 
1528  //4C1A.spin0
1529  if (N2==0){
1530 
1531  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
1532 
1533  int TwoJstart = ((TwoSL!=TwoSRdown) || (TwoS1==0)) ? TwoS1+1 : 0;
1534  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS1+1; TwoJdown+=2){
1535  if ((abs(TwoSL-TwoSRdown)<=TwoJdown) && (TwoSRdown>=0)){
1536 
1537  const double factor = phase(TwoSR + TwoSL + 2 + TwoS1) * sqrt(0.5*(TwoSR+1)*(TwoJdown+1))
1538  * Wigner::wigner6j(TwoJdown, TwoS1, 1, TwoSR, TwoSRdown, TwoSL);
1539 
1540  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
1541 
1542  #ifdef CHEMPS2_MPI_COMPILATION
1543  if ( MPIchemps2::owner_absigma( theindex+1, l_index ) == MPIRANK )
1544  #endif
1545  {
1546  int ILdown = Irreps::directProd(IL, Aleft[l_index-theindex-1][1]->get_irrep() );
1547  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
1548  int memSkappa = denS->gKappa(NL-2, TwoSL, ILdown, N1, 1, TwoJdown, NR-1, TwoSRdown, IRdown);
1549 
1550  if (memSkappa!=-1){
1551 
1552  int dimLdown = denBK->gCurrentDim(theindex , NL-2, TwoSL, ILdown);
1553  int dimRdown = denBK->gCurrentDim(theindex+2, NR-1, TwoSRdown, IRdown);
1554 
1555  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
1556  double alpha = 1.0;
1557  double beta = 0.0; //set
1558  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRdown,&beta,temp,&dimLdown);
1559 
1560  double * Ablock = Aleft[l_index-theindex-1][1]->gStorage(NL-2,TwoSL,ILdown,NL,TwoSL,IL);
1561  alpha = factor;
1562  beta = 1.0; //add
1563  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,Ablock,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
1564 
1565  }
1566  }
1567  }
1568  }
1569  }
1570  }
1571  }
1572 
1573  //4C1B.spin0
1574  if (N2==1){
1575 
1576  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
1577  if ((abs(TwoSL-TwoSRdown)<=TwoS1) && (TwoSRdown>=0)){
1578 
1579  const double factor = phase(TwoSR + TwoSL + 3 + TwoS1) * sqrt(0.5*(TwoSR+1)*(TwoJ+1))
1580  * Wigner::wigner6j(TwoJ, TwoS1, 1, TwoSRdown, TwoSR, TwoSL);
1581 
1582  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
1583 
1584  #ifdef CHEMPS2_MPI_COMPILATION
1585  if ( MPIchemps2::owner_absigma( theindex+1, l_index ) == MPIRANK )
1586  #endif
1587  {
1588  int ILdown = Irreps::directProd(IL, Aleft[l_index-theindex-1][1]->get_irrep() );
1589  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
1590  int memSkappa = denS->gKappa(NL-2, TwoSL, ILdown, N1, 2, TwoS1, NR-1, TwoSRdown, IRdown);
1591 
1592  if (memSkappa!=-1){
1593 
1594  int dimLdown = denBK->gCurrentDim(theindex , NL-2, TwoSL, ILdown);
1595  int dimRdown = denBK->gCurrentDim(theindex+2, NR-1, TwoSRdown, IRdown);
1596 
1597  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
1598  double alpha = 1.0;
1599  double beta = 0.0; //set
1600  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRdown,&beta,temp,&dimLdown);
1601 
1602  double * Ablock = Aleft[l_index-theindex-1][1]->gStorage(NL-2,TwoSL,ILdown,NL,TwoSL,IL);
1603  alpha = factor;
1604  beta = 1.0; //add
1605  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,Ablock,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
1606 
1607  }
1608  }
1609  }
1610  }
1611  }
1612  }
1613 
1614  //4C2A.spin0
1615  if (N2==1){
1616 
1617  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
1618  if ((abs(TwoSL-TwoSRdown)<=TwoS1) && (TwoSRdown>=0)){
1619 
1620  const double factor = phase(TwoSRdown + TwoSL + 2 + TwoS1) * sqrt(0.5*(TwoSRdown+1)*(TwoJ+1))
1621  * Wigner::wigner6j(TwoJ, TwoS1, 1, TwoSRdown, TwoSR, TwoSL);
1622 
1623  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
1624 
1625  #ifdef CHEMPS2_MPI_COMPILATION
1626  if ( MPIchemps2::owner_absigma( theindex+1, l_index ) == MPIRANK )
1627  #endif
1628  {
1629  int ILdown = Irreps::directProd(IL, Aleft[l_index-theindex-1][1]->get_irrep() );
1630  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
1631  int memSkappa = denS->gKappa(NL+2, TwoSL, ILdown, N1, 0, TwoS1, NR+1, TwoSRdown, IRdown);
1632 
1633  if (memSkappa!=-1){
1634 
1635  int dimLdown = denBK->gCurrentDim(theindex , NL+2, TwoSL, ILdown);
1636  int dimRdown = denBK->gCurrentDim(theindex+2, NR+1, TwoSRdown, IRdown);
1637 
1638  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
1639  double alpha = 1.0;
1640  double beta = 0.0; //set
1641  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRup,&beta,temp,&dimLdown);
1642 
1643  double * Ablock = Aleft[l_index-theindex-1][1]->gStorage(NL,TwoSL,IL,NL+2,TwoSL,ILdown);
1644  alpha = factor;
1645  beta = 1.0; //add
1646  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,Ablock,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
1647 
1648  }
1649  }
1650  }
1651  }
1652  }
1653  }
1654 
1655  //4C2B.spin0
1656  if (N2==2){
1657 
1658  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
1659 
1660  int TwoJstart = ((TwoSL!=TwoSRdown) || (TwoS1==0)) ? TwoS1+1 : 0;
1661  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS1+1; TwoJdown+=2){
1662  if ((abs(TwoSL-TwoSRdown)<=TwoJdown) && (TwoSRdown>=0)){
1663 
1664  const double factor = phase(TwoSRdown + TwoSL + 3 + TwoS1) * sqrt(0.5*(TwoSRdown+1)*(TwoJdown+1))
1665  * Wigner::wigner6j(TwoJdown, TwoS1, 1, TwoSR, TwoSRdown, TwoSL);
1666 
1667  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
1668 
1669  #ifdef CHEMPS2_MPI_COMPILATION
1670  if ( MPIchemps2::owner_absigma( theindex+1, l_index ) == MPIRANK )
1671  #endif
1672  {
1673  int ILdown = Irreps::directProd(IL, Aleft[l_index-theindex-1][1]->get_irrep() );
1674  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
1675  int memSkappa = denS->gKappa(NL+2, TwoSL, ILdown, N1, 1, TwoJdown, NR+1, TwoSRdown, IRdown);
1676 
1677  if (memSkappa!=-1){
1678 
1679  int dimLdown = denBK->gCurrentDim(theindex , NL+2, TwoSL, ILdown);
1680  int dimRdown = denBK->gCurrentDim(theindex+2, NR+1, TwoSRdown, IRdown);
1681 
1682  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
1683  double alpha = 1.0;
1684  double beta = 0.0; //set
1685  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRup,&beta,temp,&dimLdown);
1686 
1687  double * Ablock = Aleft[l_index-theindex-1][1]->gStorage(NL,TwoSL,IL,NL+2,TwoSL,ILdown);
1688  alpha = factor;
1689  beta = 1.0; //add
1690  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,Ablock,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
1691 
1692  }
1693  }
1694  }
1695  }
1696  }
1697  }
1698  }
1699 
1700 }
1701 
1702 void CheMPS2::Heff::addDiagram4C1and4C2spin1(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorOperator *** Bleft, TensorL ** Lright, double * temp) const{
1703 
1704  #ifdef CHEMPS2_MPI_COMPILATION
1705  const int MPIRANK = MPIchemps2::mpi_rank();
1706  #endif
1707 
1708  int NL = denS->gNL(ikappa);
1709  int TwoSL = denS->gTwoSL(ikappa);
1710  int IL = denS->gIL(ikappa);
1711 
1712  int NR = denS->gNR(ikappa);
1713  int TwoSR = denS->gTwoSR(ikappa);
1714  int IR = denS->gIR(ikappa);
1715 
1716  int N1 = denS->gN1(ikappa);
1717  int N2 = denS->gN2(ikappa);
1718  int TwoJ = denS->gTwoJ(ikappa);
1719  int TwoS1 = (N1==1)?1:0;
1720 
1721  int theindex = denS->gIndex();
1722  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
1723  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
1724 
1725  char trans = 'T';
1726  char notrans = 'N';
1727 
1728  //4C1A.spin1
1729  if (N2==0){
1730 
1731  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
1732  for (int TwoSLdown=TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
1733 
1734  int TwoJstart = ((TwoSLdown!=TwoSRdown) || (TwoS1==0)) ? TwoS1+1 : 0;
1735  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS1+1; TwoJdown+=2){
1736  if ((abs(TwoSLdown-TwoSRdown)<=TwoJdown) && (TwoSLdown>=0) && (TwoSRdown>=0)){
1737 
1738  const double factor = phase(1 + TwoS1 - TwoJdown)
1739  * sqrt(3.0*(TwoSR+1)*(TwoSL+1)*(TwoJdown+1))
1740  * Wigner::wigner9j(2, TwoSLdown, TwoSL, 1, TwoSRdown, TwoSR, 1, TwoJdown, TwoS1);
1741 
1742  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
1743 
1744  #ifdef CHEMPS2_MPI_COMPILATION
1745  if ( MPIchemps2::owner_absigma( theindex+1, l_index ) == MPIRANK )
1746  #endif
1747  {
1748  int ILdown = Irreps::directProd(IL, Bleft[l_index-theindex-1][1]->get_irrep() );
1749  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
1750  int memSkappa = denS->gKappa(NL-2, TwoSLdown, ILdown, N1, 1, TwoJdown, NR-1, TwoSRdown, IRdown);
1751 
1752  if (memSkappa!=-1){
1753 
1754  int dimLdown = denBK->gCurrentDim(theindex , NL-2, TwoSLdown, ILdown);
1755  int dimRdown = denBK->gCurrentDim(theindex+2, NR-1, TwoSRdown, IRdown);
1756 
1757  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
1758  double alpha = 1.0;
1759  double beta = 0.0; //set
1760  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRdown,&beta,temp,&dimLdown);
1761 
1762  double * Bblock = Bleft[l_index-theindex-1][1]->gStorage(NL-2,TwoSLdown,ILdown,NL,TwoSL,IL);
1763  alpha = factor;
1764  beta = 1.0; //add
1765  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,Bblock,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
1766 
1767  }
1768  }
1769  }
1770  }
1771  }
1772  }
1773  }
1774  }
1775 
1776  //4C1B.spin1
1777  if (N2==1){
1778 
1779  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
1780  for (int TwoSLdown=TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
1781  if ((abs(TwoSLdown-TwoSRdown)<=TwoS1) && (TwoSLdown>=0) && (TwoSRdown>=0)){
1782 
1783  const double factor = phase(TwoSR - TwoSRdown + TwoSL - TwoSLdown + TwoS1 - TwoJ)
1784  * sqrt(3.0*(TwoSR+1)*(TwoSL+1)*(TwoJ+1))
1785  * Wigner::wigner9j(2, TwoSL, TwoSLdown, 1, TwoSR, TwoSRdown, 1, TwoJ, TwoS1);
1786 
1787  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
1788 
1789  #ifdef CHEMPS2_MPI_COMPILATION
1790  if ( MPIchemps2::owner_absigma( theindex+1, l_index ) == MPIRANK )
1791  #endif
1792  {
1793  int ILdown = Irreps::directProd(IL, Bleft[l_index-theindex-1][1]->get_irrep() );
1794  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
1795  int memSkappa = denS->gKappa(NL-2, TwoSLdown, ILdown, N1, 2, TwoS1, NR-1, TwoSRdown, IRdown);
1796 
1797  if (memSkappa!=-1){
1798 
1799  int dimLdown = denBK->gCurrentDim(theindex , NL-2, TwoSLdown, ILdown);
1800  int dimRdown = denBK->gCurrentDim(theindex+2, NR-1, TwoSRdown, IRdown);
1801 
1802  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
1803  double alpha = 1.0;
1804  double beta = 0.0; //set
1805  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRdown,&beta,temp,&dimLdown);
1806 
1807  double * Bblock = Bleft[l_index-theindex-1][1]->gStorage(NL-2,TwoSLdown,ILdown,NL,TwoSL,IL);
1808  alpha = factor;
1809  beta = 1.0; //add
1810  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,Bblock,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
1811 
1812  }
1813  }
1814  }
1815  }
1816  }
1817  }
1818  }
1819 
1820  //4C2A.spin1
1821  if (N2==1){
1822 
1823  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
1824  for (int TwoSLdown=TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
1825  if ((abs(TwoSLdown-TwoSRdown)<=TwoS1) && (TwoSLdown>=0) && (TwoSRdown>=0)){
1826 
1827  const double factor = phase(1 + TwoS1 - TwoJ)
1828  * sqrt(3.0*(TwoSRdown+1)*(TwoSLdown+1)*(TwoJ+1))
1829  * Wigner::wigner9j(2, TwoSL, TwoSLdown, 1, TwoSR, TwoSRdown, 1, TwoJ, TwoS1);
1830 
1831  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
1832 
1833  #ifdef CHEMPS2_MPI_COMPILATION
1834  if ( MPIchemps2::owner_absigma( theindex+1, l_index ) == MPIRANK )
1835  #endif
1836  {
1837  int ILdown = Irreps::directProd(IL, Bleft[l_index-theindex-1][1]->get_irrep() );
1838  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
1839  int memSkappa = denS->gKappa(NL+2, TwoSLdown, ILdown, N1, 0, TwoS1, NR+1, TwoSRdown, IRdown);
1840 
1841  if (memSkappa!=-1){
1842 
1843  int dimLdown = denBK->gCurrentDim(theindex , NL+2, TwoSLdown, ILdown);
1844  int dimRdown = denBK->gCurrentDim(theindex+2, NR+1, TwoSRdown, IRdown);
1845 
1846  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
1847  double alpha = 1.0;
1848  double beta = 0.0; //set
1849  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRup,&beta,temp,&dimLdown);
1850 
1851  double * Bblock = Bleft[l_index-theindex-1][1]->gStorage(NL,TwoSL,IL,NL+2,TwoSLdown,ILdown);
1852  alpha = factor;
1853  beta = 1.0; //add
1854  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,Bblock,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
1855 
1856  }
1857  }
1858  }
1859  }
1860  }
1861  }
1862  }
1863 
1864  //4C2B.spin1
1865  if (N2==2){
1866 
1867  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
1868  for (int TwoSLdown=TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
1869 
1870  int TwoJstart = ((TwoSLdown!=TwoSRdown) || (TwoS1==0)) ? TwoS1+1 : 0;
1871  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS1+1; TwoJdown+=2){
1872  if ((abs(TwoSLdown-TwoSRdown)<=TwoJdown) && (TwoSLdown>=0) && (TwoSRdown>=0)){
1873 
1874  const double factor = phase(TwoSLdown - TwoSL + TwoSRdown - TwoSR + TwoS1 - TwoJdown)
1875  * sqrt(3.0*(TwoSRdown+1)*(TwoJdown+1)*(TwoSLdown+1))
1876  * Wigner::wigner9j(2, TwoSLdown, TwoSL, 1, TwoSRdown, TwoSR, 1, TwoJdown, TwoS1);
1877 
1878  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
1879 
1880  #ifdef CHEMPS2_MPI_COMPILATION
1881  if ( MPIchemps2::owner_absigma( theindex+1, l_index ) == MPIRANK )
1882  #endif
1883  {
1884  int ILdown = Irreps::directProd(IL, Bleft[l_index-theindex-1][1]->get_irrep() );
1885  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
1886  int memSkappa = denS->gKappa(NL+2, TwoSLdown, ILdown, N1, 1, TwoJdown, NR+1, TwoSRdown, IRdown);
1887 
1888  if (memSkappa!=-1){
1889 
1890  int dimLdown = denBK->gCurrentDim(theindex , NL+2, TwoSLdown, ILdown);
1891  int dimRdown = denBK->gCurrentDim(theindex+2, NR+1, TwoSRdown, IRdown);
1892 
1893  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
1894  double alpha = 1.0;
1895  double beta = 0.0; //set
1896  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRup,&beta,temp,&dimLdown);
1897 
1898  double * Bblock = Bleft[l_index-theindex-1][1]->gStorage(NL,TwoSL,IL,NL+2,TwoSLdown,ILdown);
1899  alpha = factor;
1900  beta = 1.0; //add
1901  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,Bblock,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
1902 
1903  }
1904  }
1905  }
1906  }
1907  }
1908  }
1909  }
1910  }
1911 
1912 }
1913 
1914 void CheMPS2::Heff::addDiagram4C3and4C4spin0(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorOperator *** Cleft, TensorL ** Lright, double * temp) const{
1915 
1916  #ifdef CHEMPS2_MPI_COMPILATION
1917  const int MPIRANK = MPIchemps2::mpi_rank();
1918  #endif
1919 
1920  int NL = denS->gNL(ikappa);
1921  int TwoSL = denS->gTwoSL(ikappa);
1922  int IL = denS->gIL(ikappa);
1923 
1924  int NR = denS->gNR(ikappa);
1925  int TwoSR = denS->gTwoSR(ikappa);
1926  int IR = denS->gIR(ikappa);
1927 
1928  int N1 = denS->gN1(ikappa);
1929  int N2 = denS->gN2(ikappa);
1930  int TwoJ = denS->gTwoJ(ikappa);
1931  int TwoS1 = (N1==1)?1:0;
1932 
1933  int theindex = denS->gIndex();
1934  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
1935  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
1936 
1937  char trans = 'T';
1938  char notrans = 'N';
1939 
1940  //4C3A.spin0
1941  if (N2==1){
1942 
1943  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
1944  if ((abs(TwoSL-TwoSRdown)<=TwoS1) && (TwoSRdown>=0)){
1945 
1946  const double factor = phase(TwoSR + TwoSL + 1 + TwoS1) * sqrt(0.5*(TwoSR+1)*(TwoJ+1))
1947  * Wigner::wigner6j(TwoJ, TwoS1, 1, TwoSRdown, TwoSR, TwoSL);
1948 
1949  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
1950 
1951  #ifdef CHEMPS2_MPI_COMPILATION
1952  if ( MPIchemps2::owner_cdf( Prob->gL(), theindex+1, l_index ) == MPIRANK )
1953  #endif
1954  {
1955  int ILdown = Irreps::directProd(IL, Cleft[l_index-theindex-1][1]->get_irrep() );
1956  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
1957  int memSkappa = denS->gKappa(NL, TwoSL, ILdown, N1, 0, TwoS1, NR-1, TwoSRdown, IRdown);
1958 
1959  if (memSkappa!=-1){
1960 
1961  int dimLdown = denBK->gCurrentDim(theindex , NL, TwoSL, ILdown);
1962  int dimRdown = denBK->gCurrentDim(theindex+2, NR-1, TwoSRdown, IRdown);
1963 
1964  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
1965  double alpha = 1.0;
1966  double beta = 0.0; //set
1967  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRdown,&beta,temp,&dimLdown);
1968 
1969  double * ptr = Cleft[l_index-theindex-1][1]->gStorage(NL,TwoSL,ILdown,NL,TwoSL,IL);
1970 
1971  alpha = factor;
1972  beta = 1.0; //add
1973  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,ptr,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
1974 
1975  }
1976  }
1977  }
1978  }
1979  }
1980  }
1981 
1982  //4C3B.spin0
1983  if (N2==2){
1984 
1985  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
1986 
1987  int TwoJstart = ((TwoSL!=TwoSRdown) || (TwoS1==0)) ? TwoS1+1 : 0;
1988  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS1+1; TwoJdown+=2){
1989  if ((abs(TwoSL-TwoSRdown)<=TwoJdown) && (TwoSRdown>=0)){
1990 
1991  const double factor = phase(TwoSR + TwoSL + 2 + TwoS1) * sqrt(0.5*(TwoSR+1)*(TwoJdown+1))
1992  * Wigner::wigner6j(TwoJdown, TwoS1, 1, TwoSR, TwoSRdown, TwoSL);
1993 
1994  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
1995 
1996  #ifdef CHEMPS2_MPI_COMPILATION
1997  if ( MPIchemps2::owner_cdf( Prob->gL(), theindex+1, l_index ) == MPIRANK )
1998  #endif
1999  {
2000  int ILdown = Irreps::directProd(IL, Cleft[l_index-theindex-1][1]->get_irrep() );
2001  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
2002  int memSkappa = denS->gKappa(NL, TwoSL, ILdown, N1, 1, TwoJdown, NR-1, TwoSRdown, IRdown);
2003 
2004  if (memSkappa!=-1){
2005 
2006  int dimLdown = denBK->gCurrentDim(theindex , NL, TwoSL, ILdown);
2007  int dimRdown = denBK->gCurrentDim(theindex+2, NR-1, TwoSRdown, IRdown);
2008 
2009  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
2010  double alpha = 1.0;
2011  double beta = 0.0; //set
2012  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRdown,&beta,temp,&dimLdown);
2013 
2014  double * ptr = Cleft[l_index-theindex-1][1]->gStorage(NL,TwoSL,ILdown,NL,TwoSL,IL);
2015 
2016  alpha = factor;
2017  beta = 1.0; //add
2018  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,ptr,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
2019 
2020  }
2021  }
2022  }
2023  }
2024  }
2025  }
2026  }
2027 
2028  //4C4A.spin0
2029  if (N2==0){
2030 
2031  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
2032 
2033  int TwoJstart = ((TwoSL!=TwoSRdown) || (TwoS1==0)) ? TwoS1+1 : 0;
2034  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS1+1; TwoJdown+=2){
2035  if ((abs(TwoSL-TwoSRdown)<=TwoJdown) && (TwoSRdown>=0)){
2036 
2037  const double factor = phase(TwoSRdown + TwoSL + 1 + TwoS1) * sqrt(0.5*(TwoSRdown+1)*(TwoJdown+1))
2038  * Wigner::wigner6j(TwoJdown, TwoS1, 1, TwoSR, TwoSRdown, TwoSL);
2039 
2040  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
2041 
2042  #ifdef CHEMPS2_MPI_COMPILATION
2043  if ( MPIchemps2::owner_cdf( Prob->gL(), theindex+1, l_index ) == MPIRANK )
2044  #endif
2045  {
2046  int ILdown = Irreps::directProd(IL, Cleft[l_index-theindex-1][1]->get_irrep() );
2047  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
2048  int memSkappa = denS->gKappa(NL, TwoSL, ILdown, N1, 1, TwoJdown, NR+1, TwoSRdown, IRdown);
2049 
2050  if (memSkappa!=-1){
2051 
2052  int dimLdown = denBK->gCurrentDim(theindex , NL, TwoSL, ILdown);
2053  int dimRdown = denBK->gCurrentDim(theindex+2, NR+1, TwoSRdown, IRdown);
2054 
2055  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
2056  double alpha = 1.0;
2057  double beta = 0.0; //set
2058  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRup,&beta,temp,&dimLdown);
2059 
2060  double * ptr = Cleft[l_index-theindex-1][1]->gStorage(NL,TwoSL,IL,NL,TwoSL,ILdown);
2061 
2062  alpha = factor;
2063  beta = 1.0; //add
2064  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,ptr,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
2065 
2066  }
2067  }
2068  }
2069  }
2070  }
2071  }
2072  }
2073 
2074  //4C4B.spin0
2075  if (N2==1){
2076 
2077  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
2078  if ((abs(TwoSL-TwoSRdown)<=TwoS1) && (TwoSRdown>=0)){
2079 
2080  const double factor = phase(TwoSRdown+TwoSL+2+TwoS1) * sqrt(0.5*(TwoSRdown+1)*(TwoJ+1))
2081  * Wigner::wigner6j(TwoJ, TwoS1, 1, TwoSRdown, TwoSR, TwoSL);
2082 
2083  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
2084 
2085  #ifdef CHEMPS2_MPI_COMPILATION
2086  if ( MPIchemps2::owner_cdf( Prob->gL(), theindex+1, l_index ) == MPIRANK )
2087  #endif
2088  {
2089  int ILdown = Irreps::directProd(IL, Cleft[l_index-theindex-1][1]->get_irrep() );
2090  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
2091  int memSkappa = denS->gKappa(NL, TwoSL, ILdown, N1, 2, TwoS1, NR+1, TwoSRdown, IRdown);
2092 
2093  if (memSkappa!=-1){
2094 
2095  int dimLdown = denBK->gCurrentDim(theindex , NL, TwoSL, ILdown);
2096  int dimRdown = denBK->gCurrentDim(theindex+2, NR+1, TwoSRdown, IRdown);
2097 
2098  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
2099  double alpha = 1.0;
2100  double beta = 0.0; //set
2101  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRup,&beta,temp,&dimLdown);
2102 
2103  double * ptr = Cleft[l_index-theindex-1][1]->gStorage(NL,TwoSL,IL,NL,TwoSL,ILdown);
2104 
2105  alpha = factor;
2106  beta = 1.0; //add
2107  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,ptr,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
2108 
2109  }
2110  }
2111  }
2112  }
2113  }
2114  }
2115 
2116 }
2117 
2118 void CheMPS2::Heff::addDiagram4C3and4C4spin1(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorOperator *** Dleft, TensorL ** Lright, double * temp) const{
2119 
2120  #ifdef CHEMPS2_MPI_COMPILATION
2121  const int MPIRANK = MPIchemps2::mpi_rank();
2122  #endif
2123 
2124  int NL = denS->gNL(ikappa);
2125  int TwoSL = denS->gTwoSL(ikappa);
2126  int IL = denS->gIL(ikappa);
2127 
2128  int NR = denS->gNR(ikappa);
2129  int TwoSR = denS->gTwoSR(ikappa);
2130  int IR = denS->gIR(ikappa);
2131 
2132  int N1 = denS->gN1(ikappa);
2133  int N2 = denS->gN2(ikappa);
2134  int TwoJ = denS->gTwoJ(ikappa);
2135  int TwoS1 = (N1==1)?1:0;
2136 
2137  int theindex = denS->gIndex();
2138  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
2139  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
2140 
2141  char trans = 'T';
2142  char notrans = 'N';
2143 
2144  //4C3A.spin1
2145  if (N2==1){
2146 
2147  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
2148  for (int TwoSLdown=TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
2149  if ((abs(TwoSLdown-TwoSRdown)<=TwoS1) && (TwoSLdown>=0) && (TwoSRdown>=0)){
2150 
2151  int fase = phase(TwoSL-TwoSLdown + TwoSR - TwoSRdown + TwoS1 - TwoJ);
2152  const double factor = fase * sqrt(3.0*(TwoSR+1)*(TwoJ+1)*(TwoSL+1))
2153  * Wigner::wigner9j(2, TwoSL, TwoSLdown, 1, TwoSR, TwoSRdown, 1, TwoJ, TwoS1);
2154 
2155  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
2156 
2157  #ifdef CHEMPS2_MPI_COMPILATION
2158  if ( MPIchemps2::owner_cdf( Prob->gL(), theindex+1, l_index ) == MPIRANK )
2159  #endif
2160  {
2161  int ILdown = Irreps::directProd(IL, Dleft[l_index-theindex-1][1]->get_irrep() );
2162  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
2163  int memSkappa = denS->gKappa(NL, TwoSLdown, ILdown, N1, 0, TwoS1, NR-1, TwoSRdown, IRdown);
2164 
2165  if (memSkappa!=-1){
2166 
2167  int dimLdown = denBK->gCurrentDim(theindex , NL, TwoSLdown, ILdown);
2168  int dimRdown = denBK->gCurrentDim(theindex+2, NR-1, TwoSRdown, IRdown);
2169 
2170  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
2171  double alpha = 1.0;
2172  double beta = 0.0; //set
2173  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRdown,&beta,temp,&dimLdown);
2174 
2175  double * ptr = Dleft[l_index-theindex-1][1]->gStorage(NL,TwoSLdown,ILdown,NL,TwoSL,IL);
2176 
2177  alpha = factor;
2178  beta = 1.0; //add
2179  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,ptr,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
2180 
2181  }
2182  }
2183  }
2184  }
2185  }
2186  }
2187  }
2188 
2189  //4C3B.spin1
2190  if (N2==2){
2191 
2192  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
2193  for (int TwoSLdown=TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
2194 
2195  int TwoJstart = ((TwoSLdown!=TwoSRdown) || (TwoS1==0)) ? TwoS1+1 : 0;
2196  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS1+1; TwoJdown+=2){
2197  if ((abs(TwoSLdown-TwoSRdown)<=TwoJdown) && (TwoSLdown>=0) && (TwoSRdown>=0)){
2198 
2199  int fase = phase(3 + TwoS1 - TwoJdown);
2200  const double factor = fase * sqrt(3.0*(TwoSR+1)*(TwoJdown+1)*(TwoSL+1))
2201  * Wigner::wigner9j(2, TwoSLdown, TwoSL, 1, TwoSRdown, TwoSR, 1, TwoJdown, TwoS1);
2202 
2203  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
2204 
2205  #ifdef CHEMPS2_MPI_COMPILATION
2206  if ( MPIchemps2::owner_cdf( Prob->gL(), theindex+1, l_index ) == MPIRANK )
2207  #endif
2208  {
2209  int ILdown = Irreps::directProd(IL, Dleft[l_index-theindex-1][1]->get_irrep() );
2210  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
2211  int memSkappa = denS->gKappa(NL, TwoSLdown, ILdown, N1, 1, TwoJdown, NR-1, TwoSRdown, IRdown);
2212 
2213  if (memSkappa!=-1){
2214 
2215  int dimLdown = denBK->gCurrentDim(theindex , NL, TwoSLdown, ILdown);
2216  int dimRdown = denBK->gCurrentDim(theindex+2, NR-1, TwoSRdown, IRdown);
2217 
2218  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
2219  double alpha = 1.0;
2220  double beta = 0.0; //set
2221  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRdown,&beta,temp,&dimLdown);
2222 
2223  double * ptr = Dleft[l_index-theindex-1][1]->gStorage(NL,TwoSLdown,ILdown,NL,TwoSL,IL);
2224 
2225  alpha = factor;
2226  beta = 1.0; //add
2227  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,ptr,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
2228 
2229  }
2230  }
2231  }
2232  }
2233  }
2234  }
2235  }
2236  }
2237 
2238  //4C4A.spin1
2239  if (N2==0){
2240 
2241  for (int TwoSRdown = TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
2242  for (int TwoSLdown = TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
2243 
2244  int TwoJstart = ((TwoSLdown!=TwoSRdown) || (TwoS1==0)) ? TwoS1+1 : 0;
2245  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS1+1; TwoJdown+=2){
2246  if ((abs(TwoSLdown-TwoSRdown)<=TwoJdown) && (TwoSLdown>=0) && (TwoSRdown>=0)){
2247 
2248  int fase = phase(TwoSRdown - TwoSR + TwoSLdown - TwoSL + TwoS1 - TwoJdown);
2249  const double factor = fase * sqrt(3.0*(TwoSRdown+1)*(TwoJdown+1)*(TwoSLdown+1))
2250  * Wigner::wigner9j(2, TwoSLdown, TwoSL, 1, TwoSRdown, TwoSR, 1, TwoJdown, TwoS1);
2251 
2252  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
2253 
2254  #ifdef CHEMPS2_MPI_COMPILATION
2255  if ( MPIchemps2::owner_cdf( Prob->gL(), theindex+1, l_index ) == MPIRANK )
2256  #endif
2257  {
2258  int ILdown = Irreps::directProd(IL, Dleft[l_index-theindex-1][1]->get_irrep() );
2259  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
2260  int memSkappa = denS->gKappa(NL, TwoSLdown, ILdown, N1, 1, TwoJdown, NR+1, TwoSRdown, IRdown);
2261 
2262  if (memSkappa!=-1){
2263 
2264  int dimLdown = denBK->gCurrentDim(theindex , NL, TwoSLdown, ILdown);
2265  int dimRdown = denBK->gCurrentDim(theindex+2, NR+1, TwoSRdown, IRdown);
2266 
2267  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
2268  double alpha = 1.0;
2269  double beta = 0.0; //set
2270  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRup,&beta,temp,&dimLdown);
2271 
2272  double * ptr = Dleft[l_index-theindex-1][1]->gStorage(NL,TwoSL,IL,NL,TwoSLdown,ILdown);
2273 
2274  alpha = factor;
2275  beta = 1.0; //add
2276  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,ptr,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
2277 
2278  }
2279  }
2280  }
2281  }
2282  }
2283  }
2284  }
2285  }
2286 
2287  //4C4B.spin1
2288  if (N2==1){
2289 
2290  for (int TwoSRdown = TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
2291  for (int TwoSLdown = TwoSL-2; TwoSLdown<=TwoSL+2; TwoSLdown+=2){
2292  if ((abs(TwoSLdown-TwoSRdown)<=TwoS1) && (TwoSLdown>=0) && (TwoSRdown>=0)){
2293 
2294  int fase = phase(3 + TwoS1 - TwoJ);
2295  const double factor = fase * sqrt(3.0*(TwoSRdown+1)*(TwoJ+1)*(TwoSLdown+1))
2296  * Wigner::wigner9j(2, TwoSL, TwoSLdown, 1, TwoSR, TwoSRdown, 1, TwoJ, TwoS1);
2297 
2298  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
2299 
2300  #ifdef CHEMPS2_MPI_COMPILATION
2301  if ( MPIchemps2::owner_cdf( Prob->gL(), theindex+1, l_index ) == MPIRANK )
2302  #endif
2303  {
2304  int ILdown = Irreps::directProd(IL, Dleft[l_index-theindex-1][1]->get_irrep() );
2305  int IRdown = Irreps::directProd(IR, denBK->gIrrep(l_index) );
2306  int memSkappa = denS->gKappa(NL, TwoSLdown, ILdown, N1, 2, TwoS1, NR+1, TwoSRdown, IRdown);
2307 
2308  if (memSkappa!=-1){
2309 
2310  int dimLdown = denBK->gCurrentDim(theindex , NL, TwoSLdown, ILdown);
2311  int dimRdown = denBK->gCurrentDim(theindex+2, NR+1, TwoSRdown, IRdown);
2312 
2313  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
2314  double alpha = 1.0;
2315  double beta = 0.0; //set
2316  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,Lblock,&dimRup,&beta,temp,&dimLdown);
2317 
2318  double * ptr = Dleft[l_index-theindex-1][1]->gStorage(NL,TwoSL,IL,NL,TwoSLdown,ILdown);
2319 
2320  alpha = factor;
2321  beta = 1.0; //add
2322  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,ptr,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
2323 
2324  }
2325  }
2326  }
2327  }
2328  }
2329  }
2330  }
2331 
2332 }
2333 
2334 void CheMPS2::Heff::addDiagram4D(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorL ** Lleft, double * temp) const{
2335 
2336  #ifdef CHEMPS2_MPI_COMPILATION
2337  const int MPIRANK = MPIchemps2::mpi_rank();
2338  #endif
2339 
2340  int NL = denS->gNL(ikappa);
2341  int TwoSL = denS->gTwoSL(ikappa);
2342  int IL = denS->gIL(ikappa);
2343 
2344  int NR = denS->gNR(ikappa);
2345  int TwoSR = denS->gTwoSR(ikappa);
2346  int IR = denS->gIR(ikappa);
2347 
2348  int N1 = denS->gN1(ikappa);
2349  int N2 = denS->gN2(ikappa);
2350  int TwoJ = denS->gTwoJ(ikappa);
2351 
2352  int theindex = denS->gIndex();
2353  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
2354  int dimR = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
2355 
2356  char trans = 'T';
2357  char notrans = 'N';
2358  int inc = 1;
2359  double beta = 1.0; //add
2360  int ILdown = Irreps::directProd(IL, denBK->gIrrep(theindex+1));
2361 
2362  //4D1A and 4D1B
2363  #ifdef CHEMPS2_MPI_COMPILATION
2364  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4D1AB ) == MPIRANK ) && (N1==0) && (N2>0)){
2365  #else
2366  if ((N1==0) && (N2>0)){
2367  #endif
2368 
2369  int TwoS2down = (N2==1)?0:1;
2370  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
2371  if (abs(TwoSLdown-TwoSR)<=TwoS2down){
2372 
2373  int dimLdown = denBK->gCurrentDim(theindex,NL-1,TwoSLdown,ILdown);
2374  if (dimLdown>0){
2375 
2376  int size = dimLup * dimLdown;
2377  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
2378 
2379  int number = 0;
2380  for (int l_index=0; l_index<theindex; l_index++){
2381  if (denBK->gIrrep(l_index) == denBK->gIrrep(theindex+1)){
2382  double alpha = Prob->gMxElement(l_index,theindex+1,theindex,theindex);
2383  double * Lblock = Lleft[theindex-1-l_index]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
2384  daxpy_(&size,&alpha,Lblock,&inc,temp,&inc);
2385  number++;
2386  }
2387  }
2388 
2389  if (number>0){
2390 
2391  double factor = -1.0;
2392  if (N2==1){
2393  int fase = phase(TwoSR+1-TwoSL);
2394  factor = fase * sqrt((TwoSL+1.0)/(TwoSR+1.0));
2395  }
2396  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,2,N2-1,TwoS2down,NR,TwoSR,IR);
2397  dgemm_(&trans,&notrans,&dimLup,&dimR,&dimLdown,&factor,temp,&dimLdown,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
2398  }
2399  }
2400  }
2401  }
2402  }
2403 
2404  //4D2A and 4D2B
2405  #ifdef CHEMPS2_MPI_COMPILATION
2406  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4D2AB ) == MPIRANK ) && (N1==2) && (N2<2)){
2407  #else
2408  if ((N1==2) && (N2<2)){
2409  #endif
2410 
2411  int TwoS2down = (N2==0)?1:0;
2412  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
2413  if (abs(TwoSLdown-TwoSR)<=TwoS2down){
2414 
2415  int dimLdown = denBK->gCurrentDim(theindex,NL+1,TwoSLdown,ILdown);
2416  if (dimLdown>0){
2417 
2418  int size = dimLup * dimLdown;
2419  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
2420 
2421  int number = 0;
2422  for (int l_index=0; l_index<theindex; l_index++){
2423  if (denBK->gIrrep(l_index) == denBK->gIrrep(theindex+1)){
2424  double alpha = Prob->gMxElement(l_index,theindex+1,theindex,theindex);
2425  double * Lblock = Lleft[theindex-1-l_index]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
2426  daxpy_(&size,&alpha,Lblock,&inc,temp,&inc);
2427  number++;
2428  }
2429  }
2430 
2431  if (number>0){
2432 
2433  double factor = -1.0;
2434  if (N2==0){
2435  int fase = phase(TwoSR+1-TwoSLdown);
2436  factor = fase * sqrt((TwoSLdown+1.0)/(TwoSR+1.0));
2437  }
2438  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,0,N2+1,TwoS2down,NR,TwoSR,IR);
2439  dgemm_(&notrans,&notrans,&dimLup,&dimR,&dimLdown,&factor,temp,&dimLup,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
2440  }
2441  }
2442  }
2443  }
2444  }
2445 
2446  //4D3A and 4D3B and 4D3C and 4D3D
2447  #ifdef CHEMPS2_MPI_COMPILATION
2448  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4D3ABCD ) == MPIRANK ) && (N1>0) && (N2<2)){
2449  #else
2450  if ((N1>0) && (N2<2)){
2451  #endif
2452 
2453  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
2454 
2455  int dimLdown = denBK->gCurrentDim(theindex,NL-1,TwoSLdown,ILdown);
2456  if (dimLdown>0){
2457 
2458  int TwoSdownSum = ((N1==1)?1:0) + ((N2==0)?1:0);
2459  int TwoJstart = ((TwoSLdown!=TwoSR) || (TwoSdownSum<2)) ? TwoSdownSum : 0;
2460  for (int TwoJdown = TwoJstart ; TwoJdown <= TwoSdownSum ; TwoJdown+=2){
2461  if (abs(TwoSLdown-TwoSR)<=TwoJdown){
2462 
2463  int size = dimLup * dimLdown;
2464  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
2465 
2466  double alpha_fact = 0.0;
2467  if ((N1==1) && (N2==0)){ //4D3A
2468  int fase = phase(TwoSLdown + TwoSR + 2);
2469  alpha_fact = fase * sqrt((TwoSL+1.0)*(TwoJdown+1)) * Wigner::wigner6j(TwoJdown,1,1,TwoSL,TwoSLdown,TwoSR);
2470  }
2471  if ((N1==1) && (N2==1)){ //4D3B
2472  int fase = phase(TwoSLdown + TwoSR + 3 + TwoJ);
2473  alpha_fact = fase * sqrt((TwoSL+1.0)*(TwoJ+1)) * Wigner::wigner6j(TwoSL,TwoSR,TwoJ,1,1,TwoSLdown);
2474  }
2475  if ((N1==2) && (N2==0)){ //4D3C
2476  alpha_fact = -1.0;
2477  }
2478  if ((N1==2) && (N2==1)){ //4D3D
2479  int fase = phase(TwoSL+1-TwoSR);
2480  alpha_fact = fase * sqrt((TwoSL+1.0)/(TwoSR+1.0));
2481  }
2482 
2483  int number = 0;
2484  for (int l_index=0; l_index<theindex; l_index++){
2485  if (denBK->gIrrep(l_index) == denBK->gIrrep(theindex+1)){
2486 
2487  double alpha = 0.0;
2488  if ((N1==1) && (N2==0)){ //4D3A
2489  alpha = alpha_fact * ( Prob->gMxElement(l_index, theindex, theindex, theindex+1) + ((TwoJdown==0)?1:-1) * Prob->gMxElement(l_index, theindex, theindex+1, theindex) );
2490  }
2491  if ((N1==1) && (N2==1)){ //4D3B
2492  alpha = alpha_fact * Prob->gMxElement(l_index,theindex,theindex+1,theindex);
2493  if (TwoJ==0){
2494  alpha += sqrt(2.0) * Prob->gMxElement(l_index,theindex,theindex,theindex+1);
2495  }
2496  }
2497  if (N1==2){ //4D3C and 4D3D
2498  alpha = alpha_fact * ( Prob->gMxElement(l_index, theindex, theindex, theindex+1) - 2 * Prob->gMxElement(l_index, theindex, theindex+1, theindex) );
2499  }
2500 
2501  double * Lblock = Lleft[theindex-1-l_index]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
2502  daxpy_(&size,&alpha,Lblock,&inc,temp,&inc);
2503  number++;
2504  }
2505  }
2506 
2507  if (number>0){
2508 
2509  double factor = 1.0;
2510  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,N1,N2+1,TwoJdown,NR,TwoSR,IR);
2511  dgemm_(&trans,&notrans,&dimLup,&dimR,&dimLdown,&factor,temp,&dimLdown,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
2512  }
2513  }
2514  }
2515  }
2516  }
2517  }
2518 
2519  //4D4A and 4D4B and 4D4C and 4D4D
2520  #ifdef CHEMPS2_MPI_COMPILATION
2521  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4D4ABCD ) == MPIRANK ) && (N1>0) && (N2>0)){
2522  #else
2523  if ((N1>0) && (N2>0)){
2524  #endif
2525 
2526  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
2527 
2528  int dimLdown = denBK->gCurrentDim(theindex,NL+1,TwoSLdown,ILdown);
2529  if (dimLdown>0){
2530 
2531  //int N1down = N1;
2532  //int N2down = N2-1;
2533  int TwoSdownSum = ((N1==1)?1:0) + ((N2==2)?1:0);
2534  int TwoJstart = ((TwoSLdown!=TwoSR) || (TwoSdownSum<2)) ? TwoSdownSum : 0;
2535  for (int TwoJdown = TwoJstart ; TwoJdown <= TwoSdownSum ; TwoJdown+=2){
2536  if (abs(TwoSLdown-TwoSR)<=TwoJdown){
2537 
2538  int size = dimLup * dimLdown;
2539  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
2540 
2541  double alpha_fact = 0.0;
2542  if ((N1==1) && (N2==1)){ //4D4A
2543  int fase = phase(TwoSL + TwoSR + 2);
2544  alpha_fact = fase * sqrt((TwoSLdown+1.0)*(TwoJ+1)) * Wigner::wigner6j(TwoJ,1,1,TwoSLdown,TwoSL,TwoSR);
2545  }
2546  if ((N1==1) && (N2==2)){ //4D4B
2547  int fase = phase(TwoSL + TwoSR + 3 + TwoJdown);
2548  alpha_fact = fase * sqrt((TwoSLdown+1.0)*(TwoJdown+1)) * Wigner::wigner6j(TwoSLdown,TwoSR,TwoJdown,1,1,TwoSL);
2549  }
2550  if ((N1==2) && (N2==1)){ //4D4C
2551  alpha_fact = -1.0;
2552  }
2553  if ((N1==2) && (N2==2)){ //4D4D
2554  int fase = phase(TwoSLdown+1-TwoSR);
2555  alpha_fact = fase * sqrt((TwoSLdown+1.0)/(TwoSR+1.0));
2556  }
2557 
2558  int number = 0;
2559  for (int l_index=0; l_index<theindex; l_index++){
2560  if (denBK->gIrrep(l_index) == denBK->gIrrep(theindex+1)){
2561 
2562  double alpha = 0.0;
2563  if ((N1==1) && (N2==1)){ //4D4A
2564  alpha = alpha_fact * ( Prob->gMxElement(l_index, theindex, theindex, theindex+1) + ((TwoJ==0)?1:-1) * Prob->gMxElement(l_index, theindex, theindex+1, theindex) );
2565  }
2566  if ((N1==1) && (N2==2)){ //4D4B
2567  alpha = alpha_fact * Prob->gMxElement(l_index,theindex,theindex+1,theindex);
2568  if (TwoJdown==0){
2569  alpha += sqrt(2.0) * Prob->gMxElement(l_index,theindex,theindex,theindex+1);
2570  }
2571  }
2572  if (N1==2){ //4D4C and 4D4D
2573  alpha = alpha_fact * ( Prob->gMxElement(l_index, theindex, theindex, theindex+1) - 2 * Prob->gMxElement(l_index, theindex, theindex+1, theindex) );
2574  }
2575 
2576  double * Lblock = Lleft[theindex-1-l_index]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
2577  daxpy_(&size,&alpha,Lblock,&inc,temp,&inc);
2578  number++;
2579  }
2580  }
2581 
2582  if (number>0){
2583 
2584  double factor = 1.0;
2585  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,N1,N2-1,TwoJdown,NR,TwoSR,IR);
2586  dgemm_(&notrans,&notrans,&dimLup,&dimR,&dimLdown,&factor,temp,&dimLup,memS+denS->gKappa2index(memSkappa),&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
2587  }
2588  }
2589  }
2590  }
2591  }
2592  }
2593 
2594 }
2595 
2596 void CheMPS2::Heff::addDiagram4E(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorL ** Lleft, TensorL ** Lright, double * temp, double * temp2) const{
2597 
2598  #ifdef CHEMPS2_MPI_COMPILATION
2599  const int MPIRANK = MPIchemps2::mpi_rank();
2600  #endif
2601 
2602  int NL = denS->gNL(ikappa);
2603  int TwoSL = denS->gTwoSL(ikappa);
2604  int IL = denS->gIL(ikappa);
2605 
2606  int NR = denS->gNR(ikappa);
2607  int TwoSR = denS->gTwoSR(ikappa);
2608  int IR = denS->gIR(ikappa);
2609 
2610  int N1 = denS->gN1(ikappa);
2611  int N2 = denS->gN2(ikappa);
2612  int TwoJ = denS->gTwoJ(ikappa);
2613  int TwoS2 = (N2==1)?1:0;
2614 
2615  int theindex = denS->gIndex();
2616  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
2617  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
2618 
2619  char trans = 'T';
2620  char notrans = 'N';
2621  int inc = 1;
2622 
2623  //4E1
2624  #ifdef CHEMPS2_MPI_COMPILATION
2625  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4E1 ) == MPIRANK ) && (N1==0)){
2626  #else
2627  if (N1==0){
2628  #endif
2629 
2630  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
2631  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
2632  if ((abs(TwoSLdown-TwoSRdown)<=TwoJ) && (TwoSLdown>=0) && (TwoSRdown>=0)){
2633 
2634  int fase = phase(TwoSL+TwoSR-TwoS2);
2635  const double factor = fase * sqrt((TwoSL+1)*(TwoSRdown+1.0)) * Wigner::wigner6j(TwoSL,TwoSR,TwoS2,TwoSRdown,TwoSLdown,1);
2636 
2637  for (int Irrep=0; Irrep < (denBK->getNumberOfIrreps()); Irrep++){
2638 
2639  int ILdown = Irreps::directProd(IL,Irrep);
2640  int IRdown = Irreps::directProd(IR,Irrep);
2641  int dimLdown = denBK->gCurrentDim(theindex, NL-1,TwoSLdown,ILdown);
2642  int dimRdown = denBK->gCurrentDim(theindex+2,NR+1,TwoSRdown,IRdown);
2643 
2644  if ((dimLdown>0) && (dimRdown>0)){
2645  bool isPossibleLeft = false;
2646  for (int l_alpha=0; l_alpha<theindex; l_alpha++){
2647  if (Irrep == denBK->gIrrep(l_alpha)){ isPossibleLeft = true; }
2648  }
2649  bool isPossibleRight = false;
2650  for (int l_beta=theindex+2; l_beta<Prob->gL(); l_beta++){
2651  if (Irrep == denBK->gIrrep(l_beta)){ isPossibleRight = true; }
2652  }
2653  if ( (isPossibleLeft) && (isPossibleRight) ){
2654 
2655  for (int l_alpha=0; l_alpha<theindex; l_alpha++){
2656  if (Irrep == denBK->gIrrep(l_alpha)){
2657 
2658  int size = dimRup * dimRdown;
2659  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
2660  for (int l_beta=theindex+2; l_beta<Prob->gL(); l_beta++){
2661  if (Irrep == denBK->gIrrep(l_beta)){
2662  double * LblockRight = Lright[l_beta-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
2663  double prefact = Prob->gMxElement(l_alpha,l_beta,theindex,theindex);
2664  daxpy_(&size,&prefact,LblockRight,&inc,temp,&inc);
2665  }
2666  }
2667 
2668  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,2,N2,TwoS2,NR+1,TwoSRdown,IRdown);
2669  double alpha = factor;
2670  double beta = 0.0; //set
2671  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,temp,&dimRup,&beta,temp2,&dimLdown);
2672 
2673  alpha = 1.0;
2674  beta = 1.0; //add
2675  double * LblockLeft = Lleft[theindex-1-l_alpha]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
2676  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,LblockLeft,&dimLdown,temp2,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
2677  }
2678  }
2679  }
2680  }
2681  }
2682  }
2683  }
2684  }
2685  }
2686 
2687  //4E2
2688  #ifdef CHEMPS2_MPI_COMPILATION
2689  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4E2 ) == MPIRANK ) && (N1==2)){
2690  #else
2691  if (N1==2){
2692  #endif
2693 
2694  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
2695  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
2696  if ((abs(TwoSLdown-TwoSRdown)<=TwoJ) && (TwoSLdown>=0) && (TwoSRdown>=0)){
2697 
2698  int fase = phase(TwoSLdown+TwoSRdown-TwoS2);
2699  const double factor = fase * sqrt((TwoSLdown+1)*(TwoSR+1.0)) * Wigner::wigner6j(TwoSLdown,TwoSRdown,TwoS2,TwoSR,TwoSL,1);
2700 
2701  for (int Irrep=0; Irrep < (denBK->getNumberOfIrreps()); Irrep++){
2702 
2703  int ILdown = Irreps::directProd(IL,Irrep);
2704  int IRdown = Irreps::directProd(IR,Irrep);
2705  int dimLdown = denBK->gCurrentDim(theindex, NL+1,TwoSLdown,ILdown);
2706  int dimRdown = denBK->gCurrentDim(theindex+2,NR-1,TwoSRdown,IRdown);
2707 
2708  if ((dimLdown>0) && (dimRdown>0)){
2709  bool isPossibleLeft = false;
2710  for (int l_gamma=0; l_gamma<theindex; l_gamma++){
2711  if (Irrep == denBK->gIrrep(l_gamma)){ isPossibleLeft = true; }
2712  }
2713  bool isPossibleRight = false;
2714  for (int l_delta=theindex+2; l_delta<Prob->gL(); l_delta++){
2715  if (Irrep == denBK->gIrrep(l_delta)){ isPossibleRight = true; }
2716  }
2717  if ( (isPossibleLeft) && (isPossibleRight) ){
2718 
2719  for (int l_gamma=0; l_gamma<theindex; l_gamma++){
2720  if (Irrep == denBK->gIrrep(l_gamma)){
2721 
2722  int size = dimRup * dimRdown;
2723  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
2724  for (int l_delta=theindex+2; l_delta<Prob->gL(); l_delta++){
2725  if (Irrep == denBK->gIrrep(l_delta)){
2726  double * LblockRight = Lright[l_delta-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
2727  double prefact = Prob->gMxElement(l_gamma,l_delta,theindex,theindex);
2728  daxpy_(&size,&prefact,LblockRight,&inc,temp,&inc);
2729  }
2730  }
2731 
2732  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,0,N2,TwoS2,NR-1,TwoSRdown,IRdown);
2733  double alpha = factor;
2734  double beta = 0.0; //set
2735  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,temp,&dimRdown,&beta,temp2,&dimLdown);
2736 
2737  alpha = 1.0;
2738  beta = 1.0; //add
2739  double * LblockLeft = Lleft[theindex-1-l_gamma]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
2740  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,LblockLeft,&dimLup,temp2,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
2741  }
2742  }
2743  }
2744  }
2745  }
2746  }
2747  }
2748  }
2749  }
2750 
2751  //4E3A
2752  #ifdef CHEMPS2_MPI_COMPILATION
2753  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4E3A ) == MPIRANK ) && (N1==1)){
2754  #else
2755  if (N1==1){
2756  #endif
2757 
2758  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
2759  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
2760 
2761  int TwoJstart = ((TwoSLdown!=TwoSRdown) || (TwoS2==0)) ? TwoS2+1 : 0;
2762  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS2+1; TwoJdown+=2){
2763  if ((abs(TwoSLdown-TwoSRdown)<=TwoJdown) && (TwoSLdown>=0) && (TwoSRdown>=0)){
2764 
2765  int fase = phase(TwoSL + TwoSR + TwoJ + TwoSLdown + TwoSRdown + 1 - TwoS2);
2766  const double factor1 = fase * sqrt((TwoJ+1)*(TwoJdown+1)*(TwoSL+1)*(TwoSR+1.0)) * Wigner::wigner6j(TwoSL, TwoSRdown, TwoS2, TwoJdown, 1, TwoSLdown) * Wigner::wigner6j(TwoJ, 1, TwoS2, TwoSRdown, TwoSL, TwoSR);
2767 
2768  double factor2 = 0.0;
2769  if (TwoJ == TwoJdown){
2770  fase = phase(TwoSL+TwoSRdown+TwoJ+3+2*TwoS2);
2771  factor2 = fase * sqrt((TwoSL+1)*(TwoSR+1.0)) * Wigner::wigner6j(TwoSLdown, TwoSRdown, TwoJ, TwoSR, TwoSL, 1);
2772  }
2773 
2774  for (int Irrep=0; Irrep < (denBK->getNumberOfIrreps()); Irrep++){
2775 
2776  int ILdown = Irreps::directProd(IL,Irrep);
2777  int IRdown = Irreps::directProd(IR,Irrep);
2778  int dimLdown = denBK->gCurrentDim(theindex, NL-1,TwoSLdown,ILdown);
2779  int dimRdown = denBK->gCurrentDim(theindex+2,NR-1,TwoSRdown,IRdown);
2780 
2781  if ((dimLdown>0) && (dimRdown>0)){
2782  bool isPossibleLeft = false;
2783  for (int l_alpha=0; l_alpha<theindex; l_alpha++){
2784  if (Irrep == denBK->gIrrep(l_alpha)){ isPossibleLeft = true; }
2785  }
2786  bool isPossibleRight = false;
2787  for (int l_delta=theindex+2; l_delta<Prob->gL(); l_delta++){
2788  if (Irrep == denBK->gIrrep(l_delta)){ isPossibleRight = true; }
2789  }
2790  if ( (isPossibleLeft) && (isPossibleRight) ){
2791 
2792  for (int l_alpha=0; l_alpha<theindex; l_alpha++){
2793  if (Irrep == denBK->gIrrep(l_alpha)){
2794 
2795  int size = dimRup * dimRdown;
2796  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
2797  for (int l_delta=theindex+2; l_delta<Prob->gL(); l_delta++){
2798  if (Irrep == denBK->gIrrep(l_delta)){
2799  double * LblockRight = Lright[l_delta-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
2800  double prefact = factor1 * Prob->gMxElement(l_alpha,theindex,theindex,l_delta);
2801  if (TwoJ == TwoJdown){ prefact += factor2 * Prob->gMxElement(l_alpha,theindex,l_delta,theindex); }
2802  daxpy_(&size,&prefact,LblockRight,&inc,temp,&inc);
2803  }
2804  }
2805 
2806  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,1,N2,TwoJdown,NR-1,TwoSRdown,IRdown);
2807  double alpha = 1.0;
2808  double beta = 0.0; //set
2809  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,temp,&dimRdown,&beta,temp2,&dimLdown);
2810 
2811  beta = 1.0; //add
2812  double * LblockLeft = Lleft[theindex-1-l_alpha]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
2813  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,LblockLeft,&dimLdown,temp2,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
2814  }
2815  }
2816  }
2817  }
2818  }
2819  }
2820  }
2821  }
2822  }
2823  }
2824 
2825  //4E3B
2826  #ifdef CHEMPS2_MPI_COMPILATION
2827  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4E3B ) == MPIRANK ) && (N1==2)){
2828  #else
2829  if (N1==2){
2830  #endif
2831 
2832  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
2833  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
2834  if ((abs(TwoSLdown-TwoSRdown)<=TwoJ) && (TwoSLdown>=0) && (TwoSRdown>=0)){
2835 
2836  int fase = phase(TwoSL + TwoSRdown - TwoS2 + 3);
2837  const double factor = fase * sqrt((TwoSL+1)*(TwoSR+1.0)) * Wigner::wigner6j(TwoSLdown, TwoSRdown, TwoS2, TwoSR, TwoSL, 1);
2838 
2839  for (int Irrep=0; Irrep < (denBK->getNumberOfIrreps()); Irrep++){
2840 
2841  int ILdown = Irreps::directProd(IL,Irrep);
2842  int IRdown = Irreps::directProd(IR,Irrep);
2843  int dimLdown = denBK->gCurrentDim(theindex, NL-1,TwoSLdown,ILdown);
2844  int dimRdown = denBK->gCurrentDim(theindex+2,NR-1,TwoSRdown,IRdown);
2845 
2846  if ((dimLdown>0) && (dimRdown>0)){
2847  bool isPossibleLeft = false;
2848  for (int l_alpha=0; l_alpha<theindex; l_alpha++){
2849  if (Irrep == denBK->gIrrep(l_alpha)){ isPossibleLeft = true; }
2850  }
2851  bool isPossibleRight = false;
2852  for (int l_delta=theindex+2; l_delta<Prob->gL(); l_delta++){
2853  if (Irrep == denBK->gIrrep(l_delta)){ isPossibleRight = true; }
2854  }
2855  if ( (isPossibleLeft) && (isPossibleRight) ){
2856 
2857  for (int l_alpha=0; l_alpha<theindex; l_alpha++){
2858  if (Irrep == denBK->gIrrep(l_alpha)){
2859 
2860  int size = dimRup * dimRdown;
2861  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
2862  for (int l_delta=theindex+2; l_delta<Prob->gL(); l_delta++){
2863  if (Irrep == denBK->gIrrep(l_delta)){
2864  double * LblockRight = Lright[l_delta-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
2865  double prefact = Prob->gMxElement(l_alpha,theindex,theindex,l_delta) - 2 * Prob->gMxElement(l_alpha,theindex,l_delta,theindex);
2866  daxpy_(&size,&prefact,LblockRight,&inc,temp,&inc);
2867  }
2868  }
2869 
2870  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,2,N2,TwoS2,NR-1,TwoSRdown,IRdown);
2871  double alpha = factor;
2872  double beta = 0.0; //set
2873  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,temp,&dimRdown,&beta,temp2,&dimLdown);
2874 
2875  alpha = 1.0;
2876  beta = 1.0; //add
2877  double * LblockLeft = Lleft[theindex-1-l_alpha]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
2878  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,LblockLeft,&dimLdown,temp2,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
2879  }
2880  }
2881  }
2882  }
2883  }
2884  }
2885  }
2886  }
2887  }
2888 
2889  //4E4A
2890  #ifdef CHEMPS2_MPI_COMPILATION
2891  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4E4A ) == MPIRANK ) && (N1==1)){
2892  #else
2893  if (N1==1){
2894  #endif
2895 
2896  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
2897  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
2898 
2899  int TwoJstart = ((TwoSLdown!=TwoSRdown) || (TwoS2==0)) ? TwoS2+1 : 0;
2900  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS2+1; TwoJdown+=2){
2901  if ((abs(TwoSLdown-TwoSRdown)<=TwoJdown) && (TwoSLdown>=0) && (TwoSRdown>=0)){
2902 
2903  int fase = phase(TwoSL + TwoSR + TwoJdown + TwoSLdown + TwoSRdown + 1 - TwoS2);
2904  const double factor1 = fase * sqrt((TwoJ+1)*(TwoJdown+1)*(TwoSLdown+1)*(TwoSRdown+1.0)) * Wigner::wigner6j(TwoSLdown, TwoSR, TwoS2, TwoJ, 1, TwoSL) * Wigner::wigner6j(TwoJdown, 1, TwoS2, TwoSR, TwoSLdown, TwoSRdown);
2905 
2906  double factor2 = 0.0;
2907  if (TwoJ == TwoJdown){
2908  fase = phase(TwoSLdown+TwoSR+TwoJ+3+2*TwoS2);
2909  factor2 = fase * sqrt((TwoSLdown+1)*(TwoSRdown+1.0)) * Wigner::wigner6j(TwoSL, TwoSR, TwoJ, TwoSRdown, TwoSLdown, 1);
2910  }
2911 
2912  for (int Irrep=0; Irrep < (denBK->getNumberOfIrreps()); Irrep++){
2913 
2914  int ILdown = Irreps::directProd(IL,Irrep);
2915  int IRdown = Irreps::directProd(IR,Irrep);
2916  int dimLdown = denBK->gCurrentDim(theindex, NL+1,TwoSLdown,ILdown);
2917  int dimRdown = denBK->gCurrentDim(theindex+2,NR+1,TwoSRdown,IRdown);
2918 
2919  if ((dimLdown>0) && (dimRdown>0)){
2920  bool isPossibleLeft = false;
2921  for (int l_gamma=0; l_gamma<theindex; l_gamma++){
2922  if (Irrep == denBK->gIrrep(l_gamma)){ isPossibleLeft = true; }
2923  }
2924  bool isPossibleRight = false;
2925  for (int l_beta=theindex+2; l_beta<Prob->gL(); l_beta++){
2926  if (Irrep == denBK->gIrrep(l_beta)){ isPossibleRight = true; }
2927  }
2928  if ( (isPossibleLeft) && (isPossibleRight) ){
2929 
2930  for (int l_gamma=0; l_gamma<theindex; l_gamma++){
2931  if (Irrep == denBK->gIrrep(l_gamma)){
2932 
2933  int size = dimRup * dimRdown;
2934  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
2935  for (int l_beta=theindex+2; l_beta<Prob->gL(); l_beta++){
2936  if (Irrep == denBK->gIrrep(l_beta)){
2937  double * LblockRight = Lright[l_beta-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
2938  double prefact = factor1 * Prob->gMxElement(l_gamma,theindex,theindex,l_beta);
2939  if (TwoJ == TwoJdown){ prefact += factor2 * Prob->gMxElement(l_gamma,theindex,l_beta,theindex); }
2940  daxpy_(&size,&prefact,LblockRight,&inc,temp,&inc);
2941  }
2942  }
2943 
2944  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,1,N2,TwoJdown,NR+1,TwoSRdown,IRdown);
2945  double alpha = 1.0;
2946  double beta = 0.0; //set
2947  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,temp,&dimRup,&beta,temp2,&dimLdown);
2948 
2949  beta = 1.0; //add
2950  double * LblockLeft = Lleft[theindex-1-l_gamma]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
2951  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,LblockLeft,&dimLup,temp2,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
2952  }
2953  }
2954  }
2955  }
2956  }
2957  }
2958  }
2959  }
2960  }
2961  }
2962 
2963  //4E4B
2964  #ifdef CHEMPS2_MPI_COMPILATION
2965  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4E4B ) == MPIRANK ) && (N1==2)){
2966  #else
2967  if (N1==2){
2968  #endif
2969 
2970  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
2971  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
2972  if ((abs(TwoSLdown-TwoSRdown)<=TwoJ) && (TwoSLdown>=0) && (TwoSRdown>=0)){
2973 
2974  int fase = phase(TwoSLdown + TwoSR - TwoS2 + 3);
2975  const double factor = fase * sqrt((TwoSLdown+1)*(TwoSRdown+1.0)) * Wigner::wigner6j(TwoSL, TwoSR, TwoS2, TwoSRdown, TwoSLdown, 1);
2976 
2977  for (int Irrep=0; Irrep < (denBK->getNumberOfIrreps()); Irrep++){
2978 
2979  int ILdown = Irreps::directProd(IL,Irrep);
2980  int IRdown = Irreps::directProd(IR,Irrep);
2981  int dimLdown = denBK->gCurrentDim(theindex, NL+1,TwoSLdown,ILdown);
2982  int dimRdown = denBK->gCurrentDim(theindex+2,NR+1,TwoSRdown,IRdown);
2983 
2984  if ((dimLdown>0) && (dimRdown>0)){
2985  bool isPossibleLeft = false;
2986  for (int l_gamma=0; l_gamma<theindex; l_gamma++){
2987  if (Irrep == denBK->gIrrep(l_gamma)){ isPossibleLeft = true; }
2988  }
2989  bool isPossibleRight = false;
2990  for (int l_beta=theindex+2; l_beta<Prob->gL(); l_beta++){
2991  if (Irrep == denBK->gIrrep(l_beta)){ isPossibleRight = true; }
2992  }
2993  if ( (isPossibleLeft) && (isPossibleRight) ){
2994 
2995  for (int l_gamma=0; l_gamma<theindex; l_gamma++){
2996  if (Irrep == denBK->gIrrep(l_gamma)){
2997 
2998  int size = dimRup * dimRdown;
2999  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
3000  for (int l_beta=theindex+2; l_beta<Prob->gL(); l_beta++){
3001  if (Irrep == denBK->gIrrep(l_beta)){
3002  double * LblockRight = Lright[l_beta-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
3003  double prefact = Prob->gMxElement(l_gamma,theindex,theindex,l_beta) - 2 * Prob->gMxElement(l_gamma,theindex,l_beta,theindex);
3004  daxpy_(&size,&prefact,LblockRight,&inc,temp,&inc);
3005  }
3006  }
3007 
3008  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,2,N2,TwoS2,NR+1,TwoSRdown,IRdown);
3009  double alpha = factor;
3010  double beta = 0.0; //set
3011  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,temp,&dimRup,&beta,temp2,&dimLdown);
3012 
3013  alpha = 1.0;
3014  beta = 1.0; //add
3015  double * LblockLeft = Lleft[theindex-1-l_gamma]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
3016  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,LblockLeft,&dimLup,temp2,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
3017  }
3018  }
3019  }
3020  }
3021  }
3022  }
3023  }
3024  }
3025  }
3026 
3027 }
3028 
3029 void CheMPS2::Heff::addDiagram4F(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorL ** Lright, double * temp) const{
3030 
3031  #ifdef CHEMPS2_MPI_COMPILATION
3032  const int MPIRANK = MPIchemps2::mpi_rank();
3033  #endif
3034 
3035  int NL = denS->gNL(ikappa);
3036  int TwoSL = denS->gTwoSL(ikappa);
3037  int IL = denS->gIL(ikappa);
3038 
3039  int NR = denS->gNR(ikappa);
3040  int TwoSR = denS->gTwoSR(ikappa);
3041  int IR = denS->gIR(ikappa);
3042 
3043  int N1 = denS->gN1(ikappa);
3044  int N2 = denS->gN2(ikappa);
3045  int TwoJ = denS->gTwoJ(ikappa);
3046 
3047  int theindex = denS->gIndex();
3048  int dimL = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
3049  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
3050 
3051  char trans = 'T';
3052  char notrans = 'N';
3053  int inc = 1;
3054  double beta = 1.0; //add
3055  int IRdown = Irreps::directProd(IR, denBK->gIrrep(theindex+1)); //I_{L} must be equal to I_{i+1}
3056 
3057  //4F1A and 4F1B
3058  #ifdef CHEMPS2_MPI_COMPILATION
3059  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4F1AB ) == MPIRANK ) && (N1==2) && (N2<2)){
3060  #else
3061  if ((N1==2) && (N2<2)){
3062  #endif
3063 
3064  int TwoS2down = (N2==1)?0:1;
3065  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
3066  if (abs(TwoSL-TwoSRdown)<=TwoS2down){
3067 
3068  int dimRdown = denBK->gCurrentDim(theindex+2,NR-1,TwoSRdown,IRdown);
3069  if (dimRdown>0){
3070 
3071  int size = dimRup * dimRdown;
3072  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
3073 
3074  int number = 0;
3075  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
3076  if (denBK->gIrrep(l_index) == denBK->gIrrep(theindex+1)){
3077  double alpha = Prob->gMxElement(theindex,theindex,theindex+1,l_index);
3078  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
3079  daxpy_(&size,&alpha,Lblock,&inc,temp,&inc);
3080  number++;
3081  }
3082  }
3083 
3084  if (number>0){
3085 
3086  double factor = 0.0;
3087  if (N2==1){
3088  factor = - sqrt((TwoSR+1.0)/(TwoSRdown+1.0));
3089  } else {
3090  factor = phase(TwoSR+1-TwoSRdown);
3091  }
3092  int memSkappa = denS->gKappa(NL,TwoSL,IL,0,N2+1,TwoS2down,NR-1,TwoSRdown,IRdown);
3093  dgemm_(&notrans,&notrans,&dimL,&dimRup,&dimRdown,&factor,memS+denS->gKappa2index(memSkappa),&dimL,temp,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimL);
3094  }
3095  }
3096  }
3097  }
3098  }
3099 
3100  //4F2A and 4F2B
3101  #ifdef CHEMPS2_MPI_COMPILATION
3102  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4F2AB ) == MPIRANK ) && (N1==0) && (N2>0)){
3103  #else
3104  if ((N1==0) && (N2>0)){
3105  #endif
3106 
3107  int TwoS2down = (N2==1)?0:1;
3108  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
3109  if (abs(TwoSL-TwoSRdown)<=TwoS2down){
3110 
3111  int dimRdown = denBK->gCurrentDim(theindex+2,NR+1,TwoSRdown,IRdown);
3112  if (dimRdown>0){
3113 
3114  int size = dimRup * dimRdown;
3115  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
3116 
3117  int number = 0;
3118  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
3119  if (denBK->gIrrep(l_index) == denBK->gIrrep(theindex+1)){
3120  double alpha = Prob->gMxElement(theindex,theindex,theindex+1,l_index);
3121  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
3122  daxpy_(&size,&alpha,Lblock,&inc,temp,&inc);
3123  number++;
3124  }
3125  }
3126 
3127  if (number>0){
3128 
3129  double factor = 0.0;
3130  if (N2==2){
3131  factor = - sqrt((TwoSRdown+1.0)/(TwoSR+1.0));
3132  } else {
3133  factor = phase(TwoSRdown+1-TwoSR);
3134  }
3135  int memSkappa = denS->gKappa(NL,TwoSL,IL,2,N2-1,TwoS2down,NR+1,TwoSRdown,IRdown);
3136  dgemm_(&notrans,&trans,&dimL,&dimRup,&dimRdown,&factor,memS+denS->gKappa2index(memSkappa),&dimL,temp,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa),&dimL);
3137  }
3138  }
3139  }
3140  }
3141  }
3142 
3143  //4F3A and 4F3B and 4F3C and 4F3D
3144  #ifdef CHEMPS2_MPI_COMPILATION
3145  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4F3ABCD ) == MPIRANK ) && (N1>0) && (N2>0)){
3146  #else
3147  if ((N1>0) && (N2>0)){
3148  #endif
3149 
3150  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
3151 
3152  int dimRdown = denBK->gCurrentDim(theindex+2,NR-1,TwoSRdown,IRdown);
3153  if (dimRdown>0){
3154 
3155  //int N1down = N1;
3156  //int N2down = N2-1;
3157  int TwoSdownSum = ((N1==1)?1:0) + ((N2==2)?1:0);
3158  int TwoJstart = ((TwoSL!=TwoSRdown) || (TwoSdownSum<2)) ? TwoSdownSum : 0;
3159  for (int TwoJdown=TwoJstart ; TwoJdown<=TwoSdownSum ; TwoJdown+=2){
3160  if (abs(TwoSL-TwoSRdown)<=TwoJdown){
3161 
3162  int size = dimRup * dimRdown;
3163  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
3164 
3165  double factor = 0.0;
3166  double factor2 = 0.0;
3167  if ((N1==1) && (N2==1)){ // 4F3A
3168  int fase = phase(TwoSL+TwoSR+2);
3169  factor = fase * sqrt((TwoSR+1.0)*(TwoJ+1)) * Wigner::wigner6j(TwoJ, 1, 1, TwoSRdown, TwoSR, TwoSL);
3170  }
3171  if ((N1==1) && (N2==2)){ // 4F3B
3172  int fase = phase(TwoSL+TwoSR+3);
3173  factor = fase * sqrt((TwoSR+1.0)*(TwoJdown+1)) * Wigner::wigner6j(TwoJdown, 1, 1, TwoSR, TwoSRdown, TwoSL);
3174  factor2 = (TwoJdown==0) ? sqrt(2.0*(TwoSR+1.0)/(TwoSRdown+1.0)) : 0.0;
3175  }
3176  if ((N1==2) && (N2==1)){ // 4F3C
3177  factor = sqrt((TwoSR+1.0)/(TwoSRdown+1.0));
3178  }
3179  if ((N1==2) && (N2==2)){ // 4F3D
3180  factor = phase(TwoSR + 1 - TwoSRdown);
3181  }
3182 
3183  int number = 0;
3184  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
3185  if (denBK->gIrrep(l_index) == denBK->gIrrep(theindex+1)){
3186  double prefact = 0.0;
3187  if ((N1==1) && (N2==1)){ // 4F3A
3188  prefact = factor * ( Prob->gMxElement(theindex,theindex+1,theindex,l_index)
3189  + ((TwoJ==0)?1:-1) * Prob->gMxElement(theindex,theindex+1,l_index,theindex) );
3190  }
3191  if ((N1==1) && (N2==2)){ // 4F3B
3192  prefact = factor * Prob->gMxElement(theindex,theindex+1,theindex,l_index);
3193  if (TwoJdown==0){ prefact += factor2 * Prob->gMxElement(theindex,theindex+1,l_index,theindex); }
3194  }
3195  if (N1==2){ // 4F3C and 4F3D
3196  prefact = factor * ( 2 * Prob->gMxElement(theindex,theindex+1,theindex,l_index)
3197  - Prob->gMxElement(theindex,theindex+1,l_index,theindex) );
3198  }
3199 
3200  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
3201  daxpy_(&size,&prefact,Lblock,&inc,temp,&inc);
3202  number++;
3203  }
3204  }
3205 
3206  if (number>0){
3207 
3208  double alpha = 1.0;
3209  int memSkappa = denS->gKappa(NL,TwoSL,IL,N1,N2-1,TwoJdown,NR-1,TwoSRdown,IRdown);
3210  dgemm_(&notrans,&notrans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,temp,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimL);
3211 
3212  }
3213  }
3214  }
3215  }
3216  }
3217  }
3218 
3219  //4F4A and 4F4B and 4F4C and 4F4D
3220  #ifdef CHEMPS2_MPI_COMPILATION
3221  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4F4ABCD ) == MPIRANK ) && (N1>0) && (N2<2)){
3222  #else
3223  if ((N1>0) && (N2<2)){
3224  #endif
3225 
3226  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
3227 
3228  int dimRdown = denBK->gCurrentDim(theindex+2,NR+1,TwoSRdown,IRdown);
3229  if (dimRdown>0){
3230 
3231  //int N1down = N1;
3232  //int N2down = N2+1;
3233  int TwoSdownSum = ((N1==1)?1:0) + ((N2==0)?1:0);
3234  int TwoJstart = ((TwoSL!=TwoSRdown) || (TwoSdownSum<2)) ? TwoSdownSum : 0;
3235  for (int TwoJdown=TwoJstart; TwoJdown<=TwoSdownSum ; TwoJdown+=2){
3236  if (abs(TwoSL-TwoSRdown)<=TwoJdown){
3237 
3238  int size = dimRup * dimRdown;
3239  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
3240 
3241  double factor = 0.0;
3242  double factor2 = 0.0;
3243  if ((N1==1) && (N2==0)){ // 4F3A
3244  int fase = phase(TwoSL+TwoSRdown+2);
3245  factor = fase * sqrt((TwoSRdown+1.0)*(TwoJdown+1)) * Wigner::wigner6j(TwoJdown, 1, 1, TwoSR, TwoSRdown, TwoSL);
3246  }
3247  if ((N1==1) && (N2==1)){ // 4F3B
3248  int fase = phase(TwoSL+TwoSRdown+3);
3249  factor = fase * sqrt((TwoSRdown+1.0)*(TwoJ+1)) * Wigner::wigner6j(TwoJ, 1, 1, TwoSRdown, TwoSR, TwoSL);
3250  factor2 = (TwoJ==0) ? sqrt(2.0*(TwoSRdown+1.0)/(TwoSR+1.0)) : 0.0;
3251  }
3252  if ((N1==2) && (N2==0)){ // 4F3C
3253  factor = sqrt((TwoSRdown+1.0)/(TwoSR+1.0));
3254  }
3255  if ((N1==2) && (N2==1)){ // 4F3D
3256  factor = phase(TwoSRdown + 1 - TwoSR);
3257  }
3258 
3259  int number = 0;
3260  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
3261  if (denBK->gIrrep(l_index) == denBK->gIrrep(theindex+1)){
3262  double prefact = 0.0;
3263  if ((N1==1) && (N2==0)){ // 4F3A
3264  prefact = factor * ( Prob->gMxElement(theindex,theindex+1,theindex,l_index)
3265  + ((TwoJdown==0)?1:-1) * Prob->gMxElement(theindex,theindex+1,l_index,theindex) );
3266  }
3267  if ((N1==1) && (N2==1)){ // 4F3B
3268  prefact = factor * Prob->gMxElement(theindex,theindex+1,theindex,l_index);
3269  if (TwoJ==0){ prefact += factor2 * Prob->gMxElement(theindex,theindex+1,l_index,theindex); }
3270  }
3271  if (N1==2){ // 4F3C and 4F3D
3272  prefact = factor * ( 2 * Prob->gMxElement(theindex,theindex+1,theindex,l_index)
3273  - Prob->gMxElement(theindex,theindex+1,l_index,theindex) );
3274  }
3275 
3276  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
3277  daxpy_(&size,&prefact,Lblock,&inc,temp,&inc);
3278  number++;
3279  }
3280  }
3281 
3282  if (number>0){
3283 
3284  double alpha = 1.0;
3285  int memSkappa = denS->gKappa(NL,TwoSL,IL,N1,N2+1,TwoJdown,NR+1,TwoSRdown,IRdown);
3286  dgemm_(&notrans,&trans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,temp,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa),&dimL);
3287 
3288  }
3289  }
3290  }
3291  }
3292  }
3293  }
3294 
3295 }
3296 
3297 void CheMPS2::Heff::addDiagram4G(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorL ** Lright, double * temp) const{
3298 
3299  #ifdef CHEMPS2_MPI_COMPILATION
3300  const int MPIRANK = MPIchemps2::mpi_rank();
3301  #endif
3302 
3303  int NL = denS->gNL(ikappa);
3304  int TwoSL = denS->gTwoSL(ikappa);
3305  int IL = denS->gIL(ikappa);
3306 
3307  int NR = denS->gNR(ikappa);
3308  int TwoSR = denS->gTwoSR(ikappa);
3309  int IR = denS->gIR(ikappa);
3310 
3311  int N1 = denS->gN1(ikappa);
3312  int N2 = denS->gN2(ikappa);
3313  int TwoJ = denS->gTwoJ(ikappa);
3314 
3315  int theindex = denS->gIndex();
3316  int dimL = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
3317  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
3318 
3319  char trans = 'T';
3320  char notrans = 'N';
3321  int inc = 1;
3322  double beta = 1.0; //add
3323  int IRdown = Irreps::directProd(IR, denBK->gIrrep(theindex)); //I_{L} must be equal to I_{i+1}
3324 
3325  //4G1A and 4G1B
3326  #ifdef CHEMPS2_MPI_COMPILATION
3327  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4G1AB ) == MPIRANK ) && (N1<2) && (N2==2)){
3328  #else
3329  if ((N1<2) && (N2==2)){
3330  #endif
3331 
3332  int TwoS1down = (N1==1)?0:1;
3333  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
3334  if (abs(TwoSL-TwoSRdown)<=TwoS1down){
3335 
3336  int dimRdown = denBK->gCurrentDim(theindex+2,NR-1,TwoSRdown,IRdown);
3337  if (dimRdown>0){
3338 
3339  int size = dimRup * dimRdown;
3340  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
3341 
3342  int number = 0;
3343  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
3344  if (denBK->gIrrep(l_index) == denBK->gIrrep(theindex)){
3345  double alpha = Prob->gMxElement(theindex,l_index,theindex+1,theindex+1);
3346  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
3347  daxpy_(&size,&alpha,Lblock,&inc,temp,&inc);
3348  number++;
3349  }
3350  }
3351 
3352  if (number>0){
3353 
3354  double factor = 0.0;
3355  if (N1==1){ //4G1B
3356  factor = - sqrt((TwoSR+1.0)/(TwoSRdown+1.0));
3357  } else {
3358  factor = phase(TwoSR+1-TwoSRdown);
3359  }
3360  int memSkappa = denS->gKappa(NL,TwoSL,IL,N1+1,0,TwoS1down,NR-1,TwoSRdown,IRdown);
3361  dgemm_(&notrans,&notrans,&dimL,&dimRup,&dimRdown,&factor,memS+denS->gKappa2index(memSkappa),&dimL,temp,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimL);
3362  }
3363  }
3364  }
3365  }
3366  }
3367 
3368  //4G2A and 4G2B
3369  #ifdef CHEMPS2_MPI_COMPILATION
3370  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4G2AB ) == MPIRANK ) && (N1>0) && (N2==0)){
3371  #else
3372  if ((N1>0) && (N2==0)){
3373  #endif
3374 
3375  int TwoS1down = (N1==1)?0:1;
3376  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
3377  if (abs(TwoSL-TwoSRdown)<=TwoS1down){
3378 
3379  int dimRdown = denBK->gCurrentDim(theindex+2,NR+1,TwoSRdown,IRdown);
3380  if (dimRdown>0){
3381 
3382  int size = dimRup * dimRdown;
3383  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
3384 
3385  int number = 0;
3386  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
3387  if (denBK->gIrrep(l_index) == denBK->gIrrep(theindex)){
3388  double alpha = Prob->gMxElement(theindex,l_index,theindex+1,theindex+1);
3389  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
3390  daxpy_(&size,&alpha,Lblock,&inc,temp,&inc);
3391  number++;
3392  }
3393  }
3394 
3395  if (number>0){
3396 
3397  double factor = 0.0;
3398  if (N1==2){ //4G2B --> bug fixed
3399  factor = - sqrt((TwoSRdown+1.0)/(TwoSR+1.0));
3400  } else { //4G2A --> bug fixed
3401  factor = phase(TwoSRdown+1-TwoSR);
3402  }
3403  int memSkappa = denS->gKappa(NL,TwoSL,IL,N1-1,2,TwoS1down,NR+1,TwoSRdown,IRdown);
3404  dgemm_(&notrans,&trans,&dimL,&dimRup,&dimRdown,&factor,memS+denS->gKappa2index(memSkappa),&dimL,temp,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa),&dimL);
3405 
3406  }
3407  }
3408  }
3409  }
3410  }
3411 
3412  //4G3A and 4G3B and 4G3C and 4G3D
3413  #ifdef CHEMPS2_MPI_COMPILATION
3414  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4G3ABCD ) == MPIRANK ) && (N1<2) && (N2>0)){
3415  #else
3416  if ((N1<2) && (N2>0)){
3417  #endif
3418 
3419  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
3420 
3421  int dimRdown = denBK->gCurrentDim(theindex+2,NR+1,TwoSRdown,IRdown);
3422  if (dimRdown>0){
3423 
3424  //int N1down = N1+1;
3425  //int N2down = N2;
3426  int TwoSdownSum = ((N1==1)?0:1) + ((N2==1)?1:0);
3427  int TwoJstart = ((TwoSL!=TwoSRdown) || (TwoSdownSum<2))? TwoSdownSum : 0;
3428  for (int TwoJdown = TwoJstart; TwoJdown <= TwoSdownSum ; TwoJdown+=2){
3429  if (abs(TwoSL-TwoSRdown)<=TwoJdown){
3430 
3431  int size = dimRup * dimRdown;
3432  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
3433 
3434  double alpha_prefact = 0.0;
3435  double alpha_prefact2 = 0.0;
3436  if ((N1==0) && (N2==1)){
3437  int fase = phase(TwoSL + TwoSRdown + 2);
3438  alpha_prefact = fase * sqrt((TwoJdown+1)*(TwoSRdown+1.0)) * Wigner::wigner6j(TwoJdown, 1, 1, TwoSR, TwoSRdown, TwoSL);
3439  }
3440  if ((N1==1) && (N2==1)){
3441  int fase = phase(TwoSL + TwoSRdown + TwoJ + 3);
3442  alpha_prefact = fase * sqrt((TwoJ+1)*(TwoSRdown+1.0)) * Wigner::wigner6j(TwoJ, 1, 1, TwoSRdown, TwoSR, TwoSL);
3443  alpha_prefact2 = (TwoJ==0)? sqrt(2.0*(TwoSRdown+1.0)/(TwoSR+1.0)) : 0.0;
3444  }
3445  if ((N1==0) && (N2==2)){
3446  alpha_prefact = - sqrt((TwoSRdown+1.0)/(TwoSR+1.0));
3447  }
3448  if ((N1==1) && (N2==2)){
3449  alpha_prefact = phase(TwoSR + 1 - TwoSRdown);
3450  }
3451 
3452  int number = 0;
3453  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
3454  if (denBK->gIrrep(l_index) == denBK->gIrrep(theindex)){
3455 
3456  double alpha = 0.0;
3457  if ((N1==0) && (N2==1)){
3458  alpha = alpha_prefact * ( Prob->gMxElement(theindex,theindex+1,theindex+1,l_index) + ((TwoJdown==0)?1:-1) * Prob->gMxElement(theindex,theindex+1,l_index,theindex+1) );
3459  }
3460  if ((N1==1) && (N2==1)){
3461  alpha = alpha_prefact * Prob->gMxElement(theindex,theindex+1,l_index,theindex+1);
3462  if (TwoJ==0){ alpha += alpha_prefact2 * Prob->gMxElement(theindex,theindex+1,theindex+1,l_index); }
3463  }
3464  if (N2==2){
3465  alpha = alpha_prefact * (Prob->gMxElement(theindex,theindex+1,theindex+1,l_index) - 2 * Prob->gMxElement(theindex,theindex+1,l_index,theindex+1) );
3466  }
3467 
3468  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
3469  daxpy_(&size,&alpha,Lblock,&inc,temp,&inc);
3470  number++;
3471  }
3472  }
3473 
3474  if (number>0){
3475 
3476  double factor = 1.0;
3477  int memSkappa = denS->gKappa(NL,TwoSL,IL,N1+1,N2,TwoJdown,NR+1,TwoSRdown,IRdown);
3478  dgemm_(&notrans,&trans,&dimL,&dimRup,&dimRdown,&factor,memS+denS->gKappa2index(memSkappa),&dimL,temp,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa),&dimL);
3479  }
3480  }
3481  }
3482  }
3483  }
3484  }
3485 
3486  //4G4A and 4G4B and 4G4C and 4G4D
3487  #ifdef CHEMPS2_MPI_COMPILATION
3488  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4G4ABCD ) == MPIRANK ) && (N1>0) && (N2>0)){
3489  #else
3490  if ((N1>0) && (N2>0)){
3491  #endif
3492 
3493  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
3494 
3495  int dimRdown = denBK->gCurrentDim(theindex+2,NR-1,TwoSRdown,IRdown);
3496  if (dimRdown>0){
3497 
3498  //int N1down = N1-1;
3499  //int N2down = N2;
3500  int TwoSdownSum = ((N1==1)?0:1) + ((N2==1)?1:0);
3501  int TwoJstart = ((TwoSL!=TwoSRdown) || (TwoSdownSum < 2)) ? TwoSdownSum : 0;
3502  for (int TwoJdown = TwoJstart ; TwoJdown <= TwoSdownSum ; TwoJdown+=2){
3503  if (abs(TwoSL-TwoSRdown)<=TwoJdown){
3504 
3505  int size = dimRup * dimRdown;
3506  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
3507 
3508  double alpha_prefact = 0.0;
3509  double alpha_prefact2 = 0.0;
3510  if ((N1==1) && (N2==1)){
3511  int fase = phase(TwoSL + TwoSR + 2);
3512  alpha_prefact = fase * sqrt((TwoJ+1)*(TwoSR+1.0)) * Wigner::wigner6j(TwoJ, 1, 1, TwoSRdown, TwoSR, TwoSL);
3513  }
3514  if ((N1==2) && (N2==1)){
3515  int fase = phase(TwoSL + TwoSR + TwoJdown + 3);
3516  alpha_prefact = fase * sqrt((TwoJdown+1)*(TwoSR+1.0)) * Wigner::wigner6j(TwoJdown, 1, 1, TwoSR, TwoSRdown, TwoSL);
3517  alpha_prefact2 = (TwoJdown==0) ? sqrt(2.0*(TwoSR+1.0)/(TwoSRdown+1.0)) : 0.0;
3518  }
3519  if ((N1==1) && (N2==2)){
3520  alpha_prefact = - sqrt((TwoSR+1.0)/(TwoSRdown+1.0));
3521  }
3522  if ((N1==2) && (N2==2)){
3523  alpha_prefact = phase(TwoSRdown + 1 - TwoSR);
3524  }
3525 
3526  int number = 0;
3527  for (int l_index=theindex+2; l_index<Prob->gL(); l_index++){
3528  if (denBK->gIrrep(l_index) == denBK->gIrrep(theindex)){
3529 
3530  double alpha = 0.0;
3531  if ((N1==1) && (N2==1)){
3532  alpha = alpha_prefact * ( Prob->gMxElement(theindex,theindex+1,theindex+1,l_index) + ((TwoJ==0)?1:-1) * Prob->gMxElement(theindex,theindex+1,l_index,theindex+1) );
3533  }
3534  if ((N1==2) && (N2==1)){
3535  alpha = alpha_prefact * Prob->gMxElement(theindex,theindex+1,l_index,theindex+1);
3536  if (TwoJdown==0){ alpha += alpha_prefact2 * Prob->gMxElement(theindex,theindex+1,theindex+1,l_index); }
3537  }
3538  if (N2==2){
3539  alpha = alpha_prefact * (Prob->gMxElement(theindex,theindex+1,theindex+1,l_index) - 2 * Prob->gMxElement(theindex,theindex+1,l_index,theindex+1) );
3540  }
3541 
3542  double * Lblock = Lright[l_index-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
3543  daxpy_(&size,&alpha,Lblock,&inc,temp,&inc);
3544  number++;
3545  }
3546  }
3547 
3548  if (number>0){
3549 
3550  double factor = 1.0;
3551  int memSkappa = denS->gKappa(NL,TwoSL,IL,N1-1,N2,TwoJdown,NR-1,TwoSRdown,IRdown);
3552  dgemm_(&notrans,&notrans,&dimL,&dimRup,&dimRdown,&factor,memS+denS->gKappa2index(memSkappa),&dimL,temp,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimL);
3553 
3554  }
3555  }
3556  }
3557  }
3558  }
3559  }
3560 
3561 }
3562 
3563 void CheMPS2::Heff::addDiagram4H(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorL ** Lleft, TensorL ** Lright, double * temp, double * temp2) const{
3564 
3565  #ifdef CHEMPS2_MPI_COMPILATION
3566  const int MPIRANK = MPIchemps2::mpi_rank();
3567  #endif
3568 
3569  int NL = denS->gNL(ikappa);
3570  int TwoSL = denS->gTwoSL(ikappa);
3571  int IL = denS->gIL(ikappa);
3572 
3573  int NR = denS->gNR(ikappa);
3574  int TwoSR = denS->gTwoSR(ikappa);
3575  int IR = denS->gIR(ikappa);
3576 
3577  int N1 = denS->gN1(ikappa);
3578  int N2 = denS->gN2(ikappa);
3579  int TwoJ = denS->gTwoJ(ikappa);
3580  int TwoS1 = (N1==1)?1:0;
3581 
3582  int theindex = denS->gIndex();
3583  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
3584  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
3585 
3586  char trans = 'T';
3587  char notrans = 'N';
3588 
3589  //4H1
3590  #ifdef CHEMPS2_MPI_COMPILATION
3591  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4H1 ) == MPIRANK ) && (N2==2)){
3592  #else
3593  if (N2==2){
3594  #endif
3595 
3596  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
3597  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
3598  if ((abs(TwoSLdown-TwoSRdown)<=TwoJ) && (TwoSLdown>=0) && (TwoSRdown>=0)){
3599 
3600  int fase = phase(TwoSLdown + TwoSRdown - TwoS1);
3601  const double factor = fase * sqrt((TwoSLdown+1)*(TwoSR+1.0)) * Wigner::wigner6j(TwoSL, TwoSR, TwoS1, TwoSRdown, TwoSLdown, 1);
3602 
3603  for (int Irrep=0; Irrep < (denBK->getNumberOfIrreps()); Irrep++){
3604 
3605  int ILdown = Irreps::directProd(IL,Irrep);
3606  int IRdown = Irreps::directProd(IR,Irrep);
3607  int dimLdown = denBK->gCurrentDim(theindex, NL+1,TwoSLdown,ILdown);
3608  int dimRdown = denBK->gCurrentDim(theindex+2,NR-1,TwoSRdown,IRdown);
3609 
3610  if ((dimLdown>0) && (dimRdown>0)){
3611  bool isPossibleLeft = false;
3612  for (int l_gamma=0; l_gamma<theindex; l_gamma++){
3613  if (Irrep == denBK->gIrrep(l_gamma)){ isPossibleLeft = true; }
3614  }
3615  bool isPossibleRight = false;
3616  for (int l_delta=theindex+2; l_delta<Prob->gL(); l_delta++){
3617  if (Irrep == denBK->gIrrep(l_delta)){ isPossibleRight = true; }
3618  }
3619  if ( (isPossibleLeft) && (isPossibleRight) ){
3620 
3621  for (int l_gamma=0; l_gamma<theindex; l_gamma++){
3622  if (Irrep == denBK->gIrrep(l_gamma)){
3623 
3624  int size = dimRup * dimRdown;
3625  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
3626 
3627  for (int l_delta=theindex+2; l_delta<Prob->gL(); l_delta++){
3628  if (Irrep == denBK->gIrrep(l_delta)){
3629  double fact = factor * Prob->gMxElement(l_gamma,l_delta,theindex+1,theindex+1);
3630  double * LblockR = Lright[l_delta-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
3631  int inc = 1;
3632  daxpy_(&size,&fact,LblockR,&inc,temp,&inc);
3633  }
3634  }
3635 
3636  double alpha = 1.0;
3637  double beta = 0.0; //set
3638  double * LblockL = Lleft[theindex-1-l_gamma]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
3639 
3640  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,N1,0,TwoS1,NR-1,TwoSRdown,IRdown);
3641  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,temp,&dimRdown,&beta, temp2,&dimLdown);
3642 
3643  beta = 1.0; //add
3644  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,LblockL,&dimLup,temp2,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
3645 
3646  }
3647  }
3648  }
3649  }
3650  }
3651  }
3652  }
3653  }
3654  }
3655 
3656  //4H2
3657  #ifdef CHEMPS2_MPI_COMPILATION
3658  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4H2 ) == MPIRANK ) && (N2==0)){
3659  #else
3660  if (N2==0){
3661  #endif
3662 
3663  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
3664  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
3665  if ((abs(TwoSLdown-TwoSRdown)<=TwoJ) && (TwoSLdown>=0) && (TwoSRdown>=0)){
3666 
3667  int fase = phase(TwoSL + TwoSR - TwoS1);
3668  const double factor = fase * sqrt((TwoSL+1)*(TwoSRdown+1.0)) * Wigner::wigner6j(TwoSLdown, TwoSRdown, TwoS1, TwoSR, TwoSL, 1);
3669 
3670  for (int Irrep=0; Irrep < (denBK->getNumberOfIrreps()); Irrep++){
3671 
3672  int ILdown = Irreps::directProd(IL,Irrep);
3673  int IRdown = Irreps::directProd(IR,Irrep);
3674  int dimLdown = denBK->gCurrentDim(theindex, NL-1,TwoSLdown,ILdown);
3675  int dimRdown = denBK->gCurrentDim(theindex+2,NR+1,TwoSRdown,IRdown);
3676 
3677  if ((dimLdown>0) && (dimRdown>0)){
3678  bool isPossibleLeft = false;
3679  for (int l_alpha=0; l_alpha<theindex; l_alpha++){
3680  if (Irrep == denBK->gIrrep(l_alpha)){ isPossibleLeft = true; }
3681  }
3682  bool isPossibleRight = false;
3683  for (int l_beta=theindex+2; l_beta<Prob->gL(); l_beta++){
3684  if (Irrep == denBK->gIrrep(l_beta)){ isPossibleRight = true; }
3685  }
3686  if ( (isPossibleLeft) && (isPossibleRight) ){
3687 
3688  for (int l_alpha=0; l_alpha<theindex; l_alpha++){
3689  if (Irrep == denBK->gIrrep(l_alpha)){
3690 
3691  int size = dimRup * dimRdown;
3692  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
3693 
3694  for (int l_beta=theindex+2; l_beta<Prob->gL(); l_beta++){
3695  if (Irrep == denBK->gIrrep(l_beta)){
3696  double fact = factor * Prob->gMxElement(l_alpha,l_beta,theindex+1,theindex+1);
3697  double * LblockR = Lright[l_beta-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
3698  int inc = 1;
3699  daxpy_(&size,&fact,LblockR,&inc,temp,&inc);
3700  }
3701  }
3702 
3703  double alpha = 1.0;
3704  double beta = 0.0; //set
3705  double * LblockL = Lleft[theindex-1-l_alpha]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
3706 
3707  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,N1,2,TwoS1,NR+1,TwoSRdown,IRdown);
3708  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,temp,&dimRup,&beta, temp2,&dimLdown);
3709 
3710  beta = 1.0; //add
3711  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,LblockL,&dimLdown,temp2,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
3712 
3713  }
3714  }
3715  }
3716  }
3717  }
3718  }
3719  }
3720  }
3721  }
3722 
3723  //4H3A
3724  #ifdef CHEMPS2_MPI_COMPILATION
3725  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4H3A ) == MPIRANK ) && (N2==1)){
3726  #else
3727  if (N2==1){
3728  #endif
3729 
3730  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
3731  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
3732 
3733  int TwoJstart = ((TwoSLdown!=TwoSRdown) || (TwoS1==0)) ? TwoS1+1 : 0;
3734  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS1+1; TwoJdown+=2){
3735  if ((abs(TwoSLdown-TwoSRdown)<=TwoJdown) && (TwoSLdown>=0) && (TwoSRdown>=0)){
3736 
3737  int fase = phase(TwoSL+TwoSR+TwoSLdown+TwoSRdown+TwoJdown+1-TwoS1);
3738  const double factor1 = fase * sqrt((TwoJ+1)*(TwoJdown+1)*(TwoSL+1)*(TwoSR+1.0)) * Wigner::wigner6j(TwoSL, TwoSRdown, TwoS1, TwoJdown, 1, TwoSLdown) * Wigner::wigner6j(TwoJ, 1, TwoS1, TwoSRdown, TwoSL, TwoSR);
3739 
3740  double factor2 = 0.0;
3741  if (TwoJ == TwoJdown){
3742  fase = phase(TwoSL+TwoSRdown+TwoJ+3+2*TwoS1);
3743  factor2 = fase * sqrt((TwoSL+1)*(TwoSR+1.0)) * Wigner::wigner6j(TwoSLdown, TwoSRdown, TwoJ, TwoSR, TwoSL, 1);
3744  }
3745 
3746  for (int Irrep=0; Irrep < (denBK->getNumberOfIrreps()); Irrep++){
3747 
3748  int ILdown = Irreps::directProd(IL,Irrep);
3749  int IRdown = Irreps::directProd(IR,Irrep);
3750  int dimLdown = denBK->gCurrentDim(theindex, NL-1,TwoSLdown,ILdown);
3751  int dimRdown = denBK->gCurrentDim(theindex+2,NR-1,TwoSRdown,IRdown);
3752 
3753  if ((dimLdown>0) && (dimRdown>0)){
3754  bool isPossibleLeft = false;
3755  for (int l_alpha=0; l_alpha<theindex; l_alpha++){
3756  if (Irrep == denBK->gIrrep(l_alpha)){ isPossibleLeft = true; }
3757  }
3758  bool isPossibleRight = false;
3759  for (int l_delta=theindex+2; l_delta<Prob->gL(); l_delta++){
3760  if (Irrep == denBK->gIrrep(l_delta)){ isPossibleRight = true; }
3761  }
3762  if ( (isPossibleLeft) && (isPossibleRight) ){
3763 
3764  for (int l_alpha=0; l_alpha<theindex; l_alpha++){
3765  if (Irrep == denBK->gIrrep(l_alpha)){
3766 
3767  int size = dimRup * dimRdown;
3768  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
3769 
3770  for (int l_delta=theindex+2; l_delta<Prob->gL(); l_delta++){
3771  if (Irrep == denBK->gIrrep(l_delta)){
3772  double fact = factor1 * Prob->gMxElement(l_alpha,theindex+1,theindex+1,l_delta);
3773  if (TwoJ==TwoJdown){ fact += factor2 * Prob->gMxElement(l_alpha,theindex+1,l_delta,theindex+1); }
3774  double * LblockR = Lright[l_delta-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
3775  int inc = 1;
3776  daxpy_(&size,&fact,LblockR,&inc,temp,&inc);
3777  }
3778  }
3779 
3780  double alpha = 1.0;
3781  double beta = 0.0; //set
3782  double * LblockL = Lleft[theindex-1-l_alpha]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
3783 
3784  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,N1,1,TwoJdown,NR-1,TwoSRdown,IRdown);
3785  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,temp,&dimRdown,&beta, temp2,&dimLdown);
3786 
3787  beta = 1.0; //add
3788  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,LblockL,&dimLdown,temp2,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
3789 
3790  }
3791  }
3792  }
3793  }
3794  }
3795  }
3796  }
3797  }
3798  }
3799  }
3800 
3801  //4H3B
3802  #ifdef CHEMPS2_MPI_COMPILATION
3803  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4H3B ) == MPIRANK ) && (N2==2)){
3804  #else
3805  if (N2==2){
3806  #endif
3807 
3808  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
3809  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
3810  if ((abs(TwoSLdown-TwoSRdown)<=TwoJ) && (TwoSLdown>=0) && (TwoSRdown>=0)){
3811 
3812  int fase = phase(TwoSL+TwoSRdown+3-TwoS1);
3813  const double factor = fase * sqrt((TwoSL+1)*(TwoSR+1.0)) * Wigner::wigner6j(TwoSLdown, TwoSRdown, TwoS1, TwoSR, TwoSL, 1);
3814 
3815  for (int Irrep=0; Irrep < (denBK->getNumberOfIrreps()); Irrep++){
3816 
3817  int ILdown = Irreps::directProd(IL,Irrep);
3818  int IRdown = Irreps::directProd(IR,Irrep);
3819  int dimLdown = denBK->gCurrentDim(theindex, NL-1,TwoSLdown,ILdown);
3820  int dimRdown = denBK->gCurrentDim(theindex+2,NR-1,TwoSRdown,IRdown);
3821 
3822  if ((dimLdown>0) && (dimRdown>0)){
3823  bool isPossibleLeft = false;
3824  for (int l_alpha=0; l_alpha<theindex; l_alpha++){
3825  if (Irrep == denBK->gIrrep(l_alpha)){ isPossibleLeft = true; }
3826  }
3827  bool isPossibleRight = false;
3828  for (int l_delta=theindex+2; l_delta<Prob->gL(); l_delta++){
3829  if (Irrep == denBK->gIrrep(l_delta)){ isPossibleRight = true; }
3830  }
3831  if ( (isPossibleLeft) && (isPossibleRight) ){
3832 
3833  for (int l_alpha=0; l_alpha<theindex; l_alpha++){
3834  if (Irrep == denBK->gIrrep(l_alpha)){
3835 
3836  int size = dimRup * dimRdown;
3837  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
3838 
3839  for (int l_delta=theindex+2; l_delta<Prob->gL(); l_delta++){
3840  if (Irrep == denBK->gIrrep(l_delta)){
3841  double fact = factor * ( Prob->gMxElement(l_alpha,theindex+1,theindex+1,l_delta) - 2 * Prob->gMxElement(l_alpha,theindex+1,l_delta,theindex+1) );
3842  double * LblockR = Lright[l_delta-theindex-2]->gStorage(NR-1,TwoSRdown,IRdown,NR,TwoSR,IR);
3843  int inc = 1;
3844  daxpy_(&size,&fact,LblockR,&inc,temp,&inc);
3845  }
3846  }
3847 
3848  double alpha = 1.0;
3849  double beta = 0.0; //set
3850  double * LblockL = Lleft[theindex-1-l_alpha]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
3851 
3852  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,N1,2,TwoS1,NR-1,TwoSRdown,IRdown);
3853  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,temp,&dimRdown,&beta, temp2,&dimLdown);
3854 
3855  beta = 1.0; //add
3856  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,LblockL,&dimLdown,temp2,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
3857 
3858  }
3859  }
3860  }
3861  }
3862  }
3863  }
3864  }
3865  }
3866  }
3867 
3868  //4H4A
3869  #ifdef CHEMPS2_MPI_COMPILATION
3870  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4H4A ) == MPIRANK ) && (N2==1)){
3871  #else
3872  if (N2==1){
3873  #endif
3874 
3875  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
3876  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
3877 
3878  int TwoJstart = ((TwoSLdown!=TwoSRdown) || (TwoS1==0)) ? TwoS1+1 : 0;
3879  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS1+1; TwoJdown+=2){
3880  if ((abs(TwoSLdown-TwoSRdown)<=TwoJdown) && (TwoSLdown>=0) && (TwoSRdown>=0)){
3881 
3882  int fase = phase(TwoSL+TwoSR+TwoSLdown+TwoSRdown+TwoJ+1-TwoS1);
3883  const double factor1 = fase * sqrt((TwoJ+1)*(TwoJdown+1)*(TwoSLdown+1)*(TwoSRdown+1.0)) * Wigner::wigner6j(TwoSLdown, TwoSR, TwoS1, TwoJ, 1, TwoSL) * Wigner::wigner6j(TwoJdown, 1, TwoS1, TwoSR, TwoSLdown, TwoSRdown);
3884 
3885  double factor2 = 0.0;
3886  if (TwoJ == TwoJdown){
3887  fase = phase(TwoSLdown+TwoSR+TwoJ+3+2*TwoS1);
3888  factor2 = fase * sqrt((TwoSLdown+1)*(TwoSRdown+1.0)) * Wigner::wigner6j(TwoSL, TwoSR, TwoJ, TwoSRdown, TwoSLdown, 1);
3889  }
3890 
3891  for (int Irrep=0; Irrep < (denBK->getNumberOfIrreps()); Irrep++){
3892 
3893  int ILdown = Irreps::directProd(IL,Irrep);
3894  int IRdown = Irreps::directProd(IR,Irrep);
3895  int dimLdown = denBK->gCurrentDim(theindex, NL+1,TwoSLdown,ILdown);
3896  int dimRdown = denBK->gCurrentDim(theindex+2,NR+1,TwoSRdown,IRdown);
3897 
3898  if ((dimLdown>0) && (dimRdown>0)){
3899  bool isPossibleLeft = false;
3900  for (int l_gamma=0; l_gamma<theindex; l_gamma++){
3901  if (Irrep == denBK->gIrrep(l_gamma)){ isPossibleLeft = true; }
3902  }
3903  bool isPossibleRight = false;
3904  for (int l_beta=theindex+2; l_beta<Prob->gL(); l_beta++){
3905  if (Irrep == denBK->gIrrep(l_beta)){ isPossibleRight = true; }
3906  }
3907  if ( (isPossibleLeft) && (isPossibleRight) ){
3908 
3909  for (int l_gamma=0; l_gamma<theindex; l_gamma++){
3910  if (Irrep == denBK->gIrrep(l_gamma)){
3911 
3912  int size = dimRup * dimRdown;
3913  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
3914 
3915  for (int l_beta=theindex+2; l_beta<Prob->gL(); l_beta++){
3916  if (Irrep == denBK->gIrrep(l_beta)){
3917  double fact = factor1 * Prob->gMxElement(l_gamma,theindex+1,theindex+1,l_beta);
3918  if (TwoJ==TwoJdown){ fact += factor2 * Prob->gMxElement(l_gamma,theindex+1,l_beta,theindex+1); }
3919  double * LblockR = Lright[l_beta-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
3920  int inc = 1;
3921  daxpy_(&size,&fact,LblockR,&inc,temp,&inc);
3922  }
3923  }
3924 
3925  double alpha = 1.0;
3926  double beta = 0.0; //set
3927  double * LblockL = Lleft[theindex-1-l_gamma]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
3928 
3929  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,N1,1,TwoJdown,NR+1,TwoSRdown,IRdown);
3930  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,temp,&dimRup,&beta, temp2,&dimLdown);
3931 
3932  beta = 1.0; //add
3933  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,LblockL,&dimLup,temp2,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
3934 
3935  }
3936  }
3937  }
3938  }
3939  }
3940  }
3941  }
3942  }
3943  }
3944  }
3945 
3946  //4H4B
3947  #ifdef CHEMPS2_MPI_COMPILATION
3948  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4H4B ) == MPIRANK ) && (N2==2)){
3949  #else
3950  if (N2==2){
3951  #endif
3952 
3953  for (int TwoSRdown=TwoSR-1; TwoSRdown<=TwoSR+1; TwoSRdown+=2){
3954  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
3955  if ((abs(TwoSLdown-TwoSRdown)<=TwoJ) && (TwoSLdown>=0) && (TwoSRdown>=0)){
3956 
3957  int fase = phase(TwoSLdown+TwoSR+3-TwoS1);
3958  const double factor = fase * sqrt((TwoSLdown+1)*(TwoSRdown+1.0)) * Wigner::wigner6j(TwoSL, TwoSR, TwoS1, TwoSRdown, TwoSLdown, 1);
3959 
3960  for (int Irrep=0; Irrep < (denBK->getNumberOfIrreps()); Irrep++){
3961 
3962  int ILdown = Irreps::directProd(IL,Irrep);
3963  int IRdown = Irreps::directProd(IR,Irrep);
3964  int dimLdown = denBK->gCurrentDim(theindex, NL+1,TwoSLdown,ILdown);
3965  int dimRdown = denBK->gCurrentDim(theindex+2,NR+1,TwoSRdown,IRdown);
3966 
3967  if ((dimLdown>0) && (dimRdown>0)){
3968  bool isPossibleLeft = false;
3969  for (int l_gamma=0; l_gamma<theindex; l_gamma++){
3970  if (Irrep == denBK->gIrrep(l_gamma)){ isPossibleLeft = true; }
3971  }
3972  bool isPossibleRight = false;
3973  for (int l_beta=theindex+2; l_beta<Prob->gL(); l_beta++){
3974  if (Irrep == denBK->gIrrep(l_beta)){ isPossibleRight = true; }
3975  }
3976  if ( (isPossibleLeft) && (isPossibleRight) ){
3977 
3978  for (int l_gamma=0; l_gamma<theindex; l_gamma++){
3979  if (Irrep == denBK->gIrrep(l_gamma)){
3980 
3981  int size = dimRup * dimRdown;
3982  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
3983 
3984  for (int l_beta=theindex+2; l_beta<Prob->gL(); l_beta++){
3985  if (Irrep == denBK->gIrrep(l_beta)){
3986  double fact = factor * ( Prob->gMxElement(l_gamma,theindex+1,theindex+1,l_beta) - 2 * Prob->gMxElement(l_gamma,theindex+1,l_beta,theindex+1) );
3987  double * LblockR = Lright[l_beta-theindex-2]->gStorage(NR,TwoSR,IR,NR+1,TwoSRdown,IRdown);
3988  int inc = 1;
3989  daxpy_(&size,&fact,LblockR,&inc,temp,&inc);
3990  }
3991  }
3992 
3993  double alpha = 1.0;
3994  double beta = 0.0; //set
3995  double * LblockL = Lleft[theindex-1-l_gamma]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
3996 
3997  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,N1,2,TwoS1,NR+1,TwoSRdown,IRdown);
3998  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,temp,&dimRup,&beta, temp2,&dimLdown);
3999 
4000  beta = 1.0; //add
4001  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,LblockL,&dimLup,temp2,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
4002 
4003  }
4004  }
4005  }
4006  }
4007  }
4008  }
4009  }
4010  }
4011  }
4012 
4013 }
4014 
4015 void CheMPS2::Heff::addDiagram4I(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorL ** Lleft, double * temp) const{
4016 
4017  #ifdef CHEMPS2_MPI_COMPILATION
4018  const int MPIRANK = MPIchemps2::mpi_rank();
4019  #endif
4020 
4021  int NL = denS->gNL(ikappa);
4022  int TwoSL = denS->gTwoSL(ikappa);
4023  int IL = denS->gIL(ikappa);
4024 
4025  int NR = denS->gNR(ikappa);
4026  int TwoSR = denS->gTwoSR(ikappa);
4027  int IR = denS->gIR(ikappa);
4028 
4029  int N1 = denS->gN1(ikappa);
4030  int N2 = denS->gN2(ikappa);
4031  int TwoJ = denS->gTwoJ(ikappa);
4032 
4033  int theindex = denS->gIndex();
4034  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
4035  int dimR = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
4036 
4037  char trans = 'T';
4038  char notrans = 'N';
4039  int ILdown = Irreps::directProd(IL,denBK->gIrrep(theindex));
4040  int inc = 1;
4041  double beta = 1.0; //add
4042 
4043  //4I1A and 4I1B
4044  #ifdef CHEMPS2_MPI_COMPILATION
4045  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4I1AB ) == MPIRANK ) && (N1>0) && (N2==0)){
4046  #else
4047  if ((N1>0) && (N2==0)){
4048  #endif
4049 
4050  int TwoJdown = ((N1==2)?1:0);
4051  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
4052  if (abs(TwoSLdown-TwoSR)<=TwoJdown){
4053 
4054  int dimLdown = denBK->gCurrentDim(theindex, NL-1, TwoSLdown, ILdown);
4055  if (dimLdown>0){
4056 
4057  int size = dimLdown * dimLup;
4058  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
4059 
4060  int number = 0;
4061  for (int l_index=0; l_index<theindex; l_index++){
4062  if (denBK->gIrrep(l_index) == denBK->gIrrep(theindex)){
4063  number++;
4064  double alpha = Prob->gMxElement(l_index,theindex,theindex+1,theindex+1);
4065  double * Lblock = Lleft[theindex-1-l_index]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
4066  daxpy_(&size,&alpha,Lblock,&inc,temp,&inc);
4067  }
4068  }
4069 
4070  if (number>0){
4071 
4072  double factor = -1.0; //4I1B
4073  if (N1==1){
4074  int fase = phase(TwoSR + 1 - TwoSL);
4075  factor = fase * sqrt((TwoSL+1.0)/(TwoSR+1.0));
4076  }
4077  int memSkappa = denS->gKappa(NL-1, TwoSLdown, ILdown, N1-1, 2, TwoJdown, NR, TwoSR, IR);
4078  dgemm_(&trans, &notrans, &dimLup, &dimR, &dimLdown, &factor, temp, &dimLdown, memS+denS->gKappa2index(memSkappa), &dimLdown, &beta, memHeff+denS->gKappa2index(ikappa), &dimLup);
4079  }
4080  }
4081  }
4082  }
4083  }
4084 
4085  //4I2A and 4I2B
4086  #ifdef CHEMPS2_MPI_COMPILATION
4087  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4I2AB ) == MPIRANK ) && (N1<2) && (N2==2)){
4088  #else
4089  if ((N1<2) && (N2==2)){
4090  #endif
4091 
4092  int TwoJdown = ((N1==0)?1:0);
4093  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
4094  if (abs(TwoSLdown-TwoSR)<=TwoJdown){
4095 
4096  int dimLdown = denBK->gCurrentDim(theindex, NL+1, TwoSLdown, ILdown);
4097  if (dimLdown>0){
4098 
4099  int size = dimLdown * dimLup;
4100  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
4101 
4102  int number = 0;
4103  for (int l_index=0; l_index<theindex; l_index++){
4104  if (denBK->gIrrep(l_index) == denBK->gIrrep(theindex)){
4105  number++;
4106  double alpha = Prob->gMxElement(l_index,theindex,theindex+1,theindex+1);
4107  double * Lblock = Lleft[theindex-1-l_index]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
4108  daxpy_(&size,&alpha,Lblock,&inc,temp,&inc);
4109  }
4110  }
4111 
4112  if (number>0){
4113 
4114  double factor = -1.0; //4I2B
4115  if (N1==0){ //4I2A
4116  int fase = phase(TwoSR + 1 - TwoSLdown);
4117  factor = fase * sqrt((TwoSLdown+1.0)/(TwoSR+1.0));
4118  }
4119  int memSkappa = denS->gKappa(NL+1, TwoSLdown, ILdown, N1+1, 0, TwoJdown, NR, TwoSR, IR);
4120  dgemm_(&notrans, &notrans, &dimLup, &dimR, &dimLdown, &factor, temp, &dimLup, memS+denS->gKappa2index(memSkappa), &dimLdown, &beta, memHeff+denS->gKappa2index(ikappa), &dimLup);
4121  }
4122  }
4123  }
4124  }
4125  }
4126 
4127  //4I3A and 4I3B and 4I3C and 4I3D
4128  #ifdef CHEMPS2_MPI_COMPILATION
4129  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4I3ABCD ) == MPIRANK ) && (N1<2) && (N2>0)){
4130  #else
4131  if ((N1<2) && (N2>0)){
4132  #endif
4133 
4134  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
4135 
4136  int dimLdown = denBK->gCurrentDim(theindex, NL-1, TwoSLdown, ILdown);
4137  if (dimLdown>0){
4138 
4139  //int N1down = N1+1;
4140  //int N2down = N2;
4141  int TwoSdownSum = ((N1==0)?1:0) + ((N2==1)?1:0);
4142  int TwoJstart = ((TwoSR!=TwoSLdown) || (TwoSdownSum<2)) ? TwoSdownSum : 0;
4143  for (int TwoJdown = TwoJstart ; TwoJdown <= TwoSdownSum ; TwoJdown+=2){
4144  if (abs(TwoSLdown-TwoSR)<=TwoJdown){
4145 
4146  int size = dimLdown * dimLup;
4147  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
4148 
4149  double prefact = 0.0;
4150  if ((N1==0)&&(N2==1)){
4151  int fase = phase(TwoSLdown+TwoSR+2);
4152  prefact = fase * sqrt((TwoSL+1.0)*(TwoJdown+1)) * Wigner::wigner6j(TwoJdown,1,1,TwoSL,TwoSLdown,TwoSR);
4153  }
4154  if ((N1==1)&&(N2==1)){
4155  int fase = phase(TwoSLdown+TwoSR+3);
4156  prefact = fase * sqrt((TwoJ+1)*(TwoSL+1.0)) * Wigner::wigner6j(TwoJ, 1, 1, TwoSLdown, TwoSL, TwoSR);
4157  }
4158  if ((N1==0)&&(N2==2)){
4159  prefact = 1.0;
4160  }
4161  if ((N1==1)&&(N2==2)){
4162  int fase = phase(TwoSR+1-TwoSL);
4163  prefact = fase * sqrt((TwoSL+1.0)/(TwoSR+1.0));
4164  }
4165 
4166  int number = 0;
4167  for (int l_index=0; l_index<theindex; l_index++){
4168  if (denBK->gIrrep(l_index) == denBK->gIrrep(theindex)){
4169  number++;
4170  double alpha = 0.0;
4171  if ((N1==0)&&(N2==1)){
4172  alpha = prefact * ( Prob->gMxElement(l_index,theindex+1,theindex,theindex+1)
4173  + ((TwoJdown==0)?1:-1) * Prob->gMxElement(l_index,theindex+1,theindex+1,theindex) );
4174  }
4175  if ((N1==1)&&(N2==1)){
4176  alpha = prefact * Prob->gMxElement(l_index,theindex+1,theindex,theindex+1);
4177  if (TwoJ==0){ alpha += sqrt(2.0) * Prob->gMxElement(l_index,theindex+1,theindex+1,theindex); }
4178  }
4179  if (N2==2){
4180  alpha = prefact * ( 2 * Prob->gMxElement(l_index,theindex+1,theindex,theindex+1)
4181  - Prob->gMxElement(l_index,theindex+1,theindex+1,theindex) );
4182  }
4183 
4184  double * Lblock = Lleft[theindex-1-l_index]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
4185  daxpy_(&size,&alpha,Lblock,&inc,temp,&inc);
4186  }
4187  }
4188 
4189  if (number>0){
4190 
4191  double factor = 1.0;
4192  int memSkappa = denS->gKappa(NL-1, TwoSLdown, ILdown, N1+1, N2, TwoJdown, NR, TwoSR, IR);
4193  dgemm_(&trans, &notrans, &dimLup, &dimR, &dimLdown, &factor, temp, &dimLdown, memS+denS->gKappa2index(memSkappa), &dimLdown, &beta, memHeff+denS->gKappa2index(ikappa), &dimLup);
4194  }
4195  }
4196  }
4197  }
4198  }
4199  }
4200 
4201  //4I4A and 4I4B and 4I4C and 4I4D
4202  #ifdef CHEMPS2_MPI_COMPILATION
4203  if (( MPIchemps2::owner_specific_diagram( Prob->gL(), MPI_CHEMPS2_4I4ABCD ) == MPIRANK ) && (N1>0) && (N2>0)){
4204  #else
4205  if ((N1>0) && (N2>0)){
4206  #endif
4207 
4208  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
4209 
4210  int dimLdown = denBK->gCurrentDim(theindex, NL+1, TwoSLdown, ILdown);
4211  if (dimLdown>0){
4212 
4213  //int N1down = N1-1;
4214  //int N2down = N2;
4215  int TwoSdownSum = ((N1==2)?1:0) + ((N2==1)?1:0);
4216  int TwoJstart = ((TwoSLdown!=TwoSR) || (TwoSdownSum<2)) ? TwoSdownSum : 0;
4217  for (int TwoJdown = TwoJstart ; TwoJdown <= TwoSdownSum ; TwoJdown+=2){
4218  if (abs(TwoSLdown-TwoSR)<=TwoJdown){
4219 
4220  int size = dimLdown * dimLup;
4221  for (int cnt=0; cnt<size; cnt++){ temp[cnt] = 0.0; }
4222 
4223  double prefact = 0.0;
4224  if ((N1==1)&&(N2==1)){
4225  int fase = phase(TwoSL+TwoSR+2);
4226  prefact = fase * sqrt((TwoSLdown+1.0)*(TwoJ+1)) * Wigner::wigner6j(TwoJ,1,1,TwoSLdown,TwoSL,TwoSR);
4227  }
4228  if ((N1==2)&&(N2==1)){
4229  int fase = phase(TwoSL+TwoSR+3);
4230  prefact = fase * sqrt((TwoJdown+1)*(TwoSLdown+1.0)) * Wigner::wigner6j(TwoJdown, 1, 1, TwoSL, TwoSLdown, TwoSR);
4231  }
4232  if ((N1==1)&&(N2==2)){
4233  prefact = 1.0;
4234  }
4235  if ((N1==2)&&(N2==2)){
4236  int fase = phase(TwoSR+1-TwoSLdown);
4237  prefact = fase * sqrt((TwoSLdown+1.0)/(TwoSR+1.0));
4238  }
4239 
4240  int number = 0;
4241  for (int l_index=0; l_index<theindex; l_index++){
4242  if (denBK->gIrrep(l_index) == denBK->gIrrep(theindex)){
4243  number++;
4244  double alpha = 0.0;
4245  if ((N1==1)&&(N2==1)){
4246  alpha = prefact * ( Prob->gMxElement(l_index,theindex+1,theindex,theindex+1)
4247  + ((TwoJ==0)?1:-1) * Prob->gMxElement(l_index,theindex+1,theindex+1,theindex) );
4248  }
4249  if ((N1==2)&&(N2==1)){
4250  alpha = prefact * Prob->gMxElement(l_index,theindex+1,theindex,theindex+1);
4251  if (TwoJdown==0){ alpha += sqrt(2.0) * Prob->gMxElement(l_index,theindex+1,theindex+1,theindex); }
4252  }
4253  if (N2==2){
4254  alpha = prefact * ( 2 * Prob->gMxElement(l_index,theindex+1,theindex,theindex+1)
4255  - Prob->gMxElement(l_index,theindex+1,theindex+1,theindex) );
4256  }
4257 
4258  double * Lblock = Lleft[theindex-1-l_index]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
4259  daxpy_(&size,&alpha,Lblock,&inc,temp,&inc);
4260  }
4261  }
4262 
4263  if (number>0){
4264 
4265  double factor = 1.0;
4266  int memSkappa = denS->gKappa(NL+1, TwoSLdown, ILdown, N1-1, N2, TwoJdown, NR, TwoSR, IR);
4267  dgemm_(&notrans, &notrans, &dimLup, &dimR, &dimLdown, &factor, temp, &dimLup, memS+denS->gKappa2index(memSkappa), &dimLdown, &beta, memHeff+denS->gKappa2index(ikappa), &dimLup);
4268  }
4269  }
4270  }
4271  }
4272  }
4273  }
4274 
4275 }
4276 
4277 void CheMPS2::Heff::addDiagram4J1and4J2spin0(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorOperator * Aright) const{
4278 
4279  int NL = denS->gNL(ikappa);
4280  int TwoSL = denS->gTwoSL(ikappa);
4281  int IL = denS->gIL(ikappa);
4282 
4283  int NR = denS->gNR(ikappa);
4284  int TwoSR = denS->gTwoSR(ikappa);
4285  int IR = denS->gIR(ikappa);
4286 
4287  int N1 = denS->gN1(ikappa);
4288  int N2 = denS->gN2(ikappa);
4289  int TwoJ = denS->gTwoJ(ikappa);
4290 
4291  int theindex = denS->gIndex();
4292  int dimL = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
4293  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
4294 
4295  char trans = 'T';
4296  char notrans = 'N';
4297  int IRdown = Irreps::directProd(IR,Aright->get_irrep());
4298 
4299  //4J1A.spin0
4300  if ((N1==0) && (N2==0)){
4301 
4302  int dimRdown = denBK->gCurrentDim(theindex+2,NR+2,TwoSR,IRdown);
4303  if (dimRdown>0){
4304 
4305  int memSkappa = denS->gKappa(NL,TwoSL,IL,1,1,0,NR+2,TwoSR,IRdown);
4306  double alpha = 1.0;
4307  double beta = 1.0;
4308  double * Ablock = Aright->gStorage(NR,TwoSR,IR,NR+2,TwoSR,IRdown);
4309  dgemm_(&notrans,&trans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,Ablock,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4310 
4311  }
4312  }
4313 
4314  //4J1B.spin0
4315  if ((N1==1) && (N2==0)){
4316 
4317  int dimRdown = denBK->gCurrentDim(theindex+2,NR+2,TwoSR,IRdown);
4318  if (dimRdown>0){
4319 
4320  int memSkappa = denS->gKappa(NL,TwoSL,IL,2,1,1,NR+2,TwoSR,IRdown);
4321  double alpha = - sqrt(0.5);
4322  double beta = 1.0;
4323  double * Ablock = Aright->gStorage(NR,TwoSR,IR,NR+2,TwoSR,IRdown);
4324  dgemm_(&notrans,&trans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,Ablock,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4325 
4326  }
4327  }
4328 
4329  //4J1C.spin0
4330  if ((N1==0) && (N2==1)){
4331 
4332  int dimRdown = denBK->gCurrentDim(theindex+2,NR+2,TwoSR,IRdown);
4333  if (dimRdown>0){
4334 
4335  int memSkappa = denS->gKappa(NL,TwoSL,IL,1,2,1,NR+2,TwoSR,IRdown);
4336  double alpha = - sqrt(0.5);
4337  double beta = 1.0;
4338  double * Ablock = Aright->gStorage(NR,TwoSR,IR,NR+2,TwoSR,IRdown);
4339  dgemm_(&notrans,&trans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,Ablock,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4340 
4341  }
4342  }
4343 
4344  //4J1D.spin0 and 4J2A.spin0
4345  if ((N1==1) && (N2==1) && (TwoJ==0)){
4346 
4347  int dimRdown = denBK->gCurrentDim(theindex+2,NR+2,TwoSR,IRdown);
4348  if (dimRdown>0){
4349 
4350  int memSkappa = denS->gKappa(NL,TwoSL,IL,2,2,0,NR+2,TwoSR,IRdown);
4351  double alpha = -1.0;
4352  double beta = 1.0;
4353  double * Ablock = Aright->gStorage(NR,TwoSR,IR,NR+2,TwoSR,IRdown);
4354  dgemm_(&notrans,&trans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,Ablock,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4355 
4356  }
4357 
4358  dimRdown = denBK->gCurrentDim(theindex+2,NR-2,TwoSR,IRdown);
4359  if (dimRdown>0){
4360 
4361  int memSkappa = denS->gKappa(NL,TwoSL,IL,0,0,0,NR-2,TwoSR,IRdown);
4362  double alpha = 1.0;
4363  double beta = 1.0;
4364  double * Ablock = Aright->gStorage(NR-2,TwoSR,IRdown,NR,TwoSR,IR);
4365  dgemm_(&notrans,&notrans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,Ablock,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4366 
4367  }
4368  }
4369 
4370  //4J2B.spin0
4371  if ((N1==2) && (N2==1)){
4372 
4373  int dimRdown = denBK->gCurrentDim(theindex+2,NR-2,TwoSR,IRdown);
4374  if (dimRdown>0){
4375 
4376  int memSkappa = denS->gKappa(NL,TwoSL,IL,1,0,1,NR-2,TwoSR,IRdown);
4377  double alpha = - sqrt(0.5);
4378  double beta = 1.0;
4379  double * Ablock = Aright->gStorage(NR-2,TwoSR,IRdown,NR,TwoSR,IR);
4380  dgemm_(&notrans,&notrans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,Ablock,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4381 
4382  }
4383  }
4384 
4385  //4J2C.spin0
4386  if ((N1==1) && (N2==2)){
4387 
4388  int dimRdown = denBK->gCurrentDim(theindex+2,NR-2,TwoSR,IRdown);
4389  if (dimRdown>0){
4390 
4391  int memSkappa = denS->gKappa(NL,TwoSL,IL,0,1,1,NR-2,TwoSR,IRdown);
4392  double alpha = - sqrt(0.5);
4393  double beta = 1.0;
4394  double * Ablock = Aright->gStorage(NR-2,TwoSR,IRdown,NR,TwoSR,IR);
4395  dgemm_(&notrans,&notrans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,Ablock,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4396 
4397  }
4398  }
4399 
4400  //4J2D.spin0
4401  if ((N1==2) && (N2==2)){
4402 
4403  int dimRdown = denBK->gCurrentDim(theindex+2,NR-2,TwoSR,IRdown);
4404  if (dimRdown>0){
4405 
4406  int memSkappa = denS->gKappa(NL,TwoSL,IL,1,1,0,NR-2,TwoSR,IRdown);
4407  double alpha = -1.0;
4408  double beta = 1.0;
4409  double * Ablock = Aright->gStorage(NR-2,TwoSR,IRdown,NR,TwoSR,IR);
4410  dgemm_(&notrans,&notrans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,Ablock,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4411 
4412  }
4413  }
4414 
4415 }
4416 
4417 void CheMPS2::Heff::addDiagram4J1and4J2spin1(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorOperator * Bright) const{
4418 
4419  int NL = denS->gNL(ikappa);
4420  int TwoSL = denS->gTwoSL(ikappa);
4421  int IL = denS->gIL(ikappa);
4422 
4423  int NR = denS->gNR(ikappa);
4424  int TwoSR = denS->gTwoSR(ikappa);
4425  int IR = denS->gIR(ikappa);
4426 
4427  int N1 = denS->gN1(ikappa);
4428  int N2 = denS->gN2(ikappa);
4429  int TwoJ = denS->gTwoJ(ikappa);
4430 
4431  int theindex = denS->gIndex();
4432  int dimL = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
4433  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
4434 
4435  char trans = 'T';
4436  char notrans = 'N';
4437  int IRdown = Irreps::directProd(IR,Bright->get_irrep());
4438 
4439  //4J1A.spin1
4440  if ((N1==0) && (N2==0)){ //TwoSL = TwoSR --> TwoSR can be what it wants to be.
4441 
4442  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
4443 
4444  int dimRdown = denBK->gCurrentDim(theindex+2,NR+2,TwoSRdown,IRdown);
4445  if (dimRdown>0){
4446 
4447  int memSkappa = denS->gKappa(NL,TwoSL,IL,1,1,2,NR+2,TwoSRdown,IRdown);
4448  double alpha = sqrt((TwoSRdown+1.0)/(TwoSR+1.0));
4449  double beta = 1.0;
4450  double * Bblock = Bright->gStorage(NR,TwoSR,IR,NR+2,TwoSRdown,IRdown);
4451  dgemm_(&notrans,&trans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,Bblock,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4452 
4453  }
4454  }
4455  }
4456 
4457  //4J1B.spin1
4458  if ((N1==1) && (N2==0)){
4459 
4460  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
4461  if (abs(TwoSL-TwoSRdown)<=1){
4462 
4463  int dimRdown = denBK->gCurrentDim(theindex+2,NR+2,TwoSRdown,IRdown);
4464  if (dimRdown>0){
4465 
4466  int memSkappa = denS->gKappa(NL,TwoSL,IL,2,1,1,NR+2,TwoSRdown,IRdown);
4467  int fase = phase(TwoSL+TwoSRdown+3);
4468  double alpha = fase * sqrt(3.0 * (TwoSRdown+1)) * Wigner::wigner6j(1,1,2,TwoSR,TwoSRdown,TwoSL);
4469  double beta = 1.0;
4470  double * Bblock = Bright->gStorage(NR,TwoSR,IR,NR+2,TwoSRdown,IRdown);
4471  dgemm_(&notrans,&trans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,Bblock,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4472  }
4473  }
4474  }
4475  }
4476 
4477  //4J1C.spin1
4478  if ((N1==0) && (N2==1)){
4479 
4480  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
4481  if (abs(TwoSL-TwoSRdown)<=1){
4482 
4483  int dimRdown = denBK->gCurrentDim(theindex+2,NR+2,TwoSRdown,IRdown);
4484  if (dimRdown>0){
4485 
4486  int memSkappa = denS->gKappa(NL,TwoSL,IL,1,2,1,NR+2,TwoSRdown,IRdown);
4487  int fase = phase(TwoSL+TwoSRdown+1);
4488  double alpha = fase * sqrt(3.0 * (TwoSRdown+1)) * Wigner::wigner6j(1,1,2,TwoSR,TwoSRdown,TwoSL);
4489  double beta = 1.0;
4490  double * Bblock = Bright->gStorage(NR,TwoSR,IR,NR+2,TwoSRdown,IRdown);
4491  dgemm_(&notrans,&trans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,Bblock,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4492  }
4493  }
4494  }
4495  }
4496 
4497  //4J1D.spin1 and 4J2A.spin1
4498  if ((N1==1) && (N2==1) && (TwoJ==2)){
4499 
4500  int TwoSRdown = TwoSL;
4501 
4502  int dimRdown = denBK->gCurrentDim(theindex+2,NR+2,TwoSRdown,IRdown);
4503  if (dimRdown>0){ //4J1D.spin1
4504 
4505  int memSkappa = denS->gKappa(NL,TwoSL,IL,2,2,0,NR+2,TwoSRdown,IRdown);
4506  double alpha = phase(TwoSR-TwoSRdown);
4507  double beta = 1.0;
4508  double * Bblock = Bright->gStorage(NR,TwoSR,IR,NR+2,TwoSRdown,IRdown);
4509  dgemm_(&notrans,&trans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,Bblock,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4510 
4511  }
4512 
4513 
4514  dimRdown = denBK->gCurrentDim(theindex+2,NR-2,TwoSRdown,IRdown);
4515  if (dimRdown>0){ //4J2A.spin1
4516 
4517  int memSkappa = denS->gKappa(NL,TwoSL,IL,0,0,0,NR-2,TwoSRdown,IRdown);
4518  double alpha = sqrt((TwoSR+1.0)/(TwoSRdown+1.0));
4519  double beta = 1.0;
4520  double * Bblock = Bright->gStorage(NR-2,TwoSRdown,IRdown,NR,TwoSR,IR);
4521  dgemm_(&notrans,&notrans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,Bblock,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4522 
4523  }
4524 
4525  }
4526 
4527  //4J2B.spin1
4528  if ((N1==2) && (N2==1)){
4529 
4530  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
4531  if (abs(TwoSL-TwoSRdown)<=1){
4532 
4533  int dimRdown = denBK->gCurrentDim(theindex+2,NR-2,TwoSRdown,IRdown);
4534  if (dimRdown>0){
4535 
4536  int memSkappa = denS->gKappa(NL,TwoSL,IL,1,0,1,NR-2,TwoSRdown,IRdown);
4537  int fase = phase(TwoSL+TwoSR+3);
4538  double alpha = fase * sqrt(3.0 * (TwoSR+1)) * Wigner::wigner6j(1,1,2,TwoSRdown,TwoSR,TwoSL);
4539  double beta = 1.0;
4540  double * Bblock = Bright->gStorage(NR-2,TwoSRdown,IRdown,NR,TwoSR,IR);
4541  dgemm_(&notrans,&notrans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,Bblock,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4542  }
4543  }
4544  }
4545  }
4546 
4547  //4J2C.spin1
4548  if ((N1==1) && (N2==2)){
4549 
4550  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
4551  if (abs(TwoSL-TwoSRdown)<=1){
4552 
4553  int dimRdown = denBK->gCurrentDim(theindex+2,NR-2,TwoSRdown,IRdown);
4554  if (dimRdown>0){
4555 
4556  int memSkappa = denS->gKappa(NL,TwoSL,IL,0,1,1,NR-2,TwoSRdown,IRdown);
4557  int fase = phase(TwoSL+TwoSR+1);
4558  double alpha = fase * sqrt(3.0 * (TwoSR+1)) * Wigner::wigner6j(1,1,2,TwoSRdown,TwoSR,TwoSL);
4559  double beta = 1.0;
4560  double * Bblock = Bright->gStorage(NR-2,TwoSRdown,IRdown,NR,TwoSR,IR);
4561  dgemm_(&notrans,&notrans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,Bblock,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4562 
4563  }
4564  }
4565  }
4566  }
4567 
4568  //4J2D.spin1
4569  if ((N1==2) && (N2==2)){ //TwoSL == TwoSR --> TwoSRdown can be what it wants to be.
4570 
4571  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
4572 
4573  int dimRdown = denBK->gCurrentDim(theindex+2,NR-2,TwoSRdown,IRdown);
4574  if (dimRdown>0){
4575 
4576  int memSkappa = denS->gKappa(NL,TwoSL,IL,1,1,2,NR-2,TwoSRdown,IRdown);
4577  double alpha = phase(TwoSR-TwoSRdown);
4578  double beta = 1.0;
4579  double * Bblock = Bright->gStorage(NR-2,TwoSRdown,IRdown,NR,TwoSR,IR);
4580  dgemm_(&notrans,&notrans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,Bblock,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4581 
4582  }
4583  }
4584  }
4585 
4586 }
4587 
4588 void CheMPS2::Heff::addDiagram4J3and4J4spin0(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorOperator * Cright) const{
4589 
4590  int NR = denS->gNR(ikappa);
4591  int TwoSR = denS->gTwoSR(ikappa);
4592  int IR = denS->gIR(ikappa);
4593 
4594  int IRdown = Irreps::directProd(IR,Cright->get_irrep());
4595  int theindex = denS->gIndex();
4596 
4597  int dimRdown = denBK->gCurrentDim(theindex+2,NR,TwoSR,IRdown);
4598  if (dimRdown>0){
4599 
4600  int NL = denS->gNL(ikappa);
4601  int TwoSL = denS->gTwoSL(ikappa);
4602  int IL = denS->gIL(ikappa);
4603 
4604  int N1 = denS->gN1(ikappa);
4605  int N2 = denS->gN2(ikappa);
4606  int TwoJ = denS->gTwoJ(ikappa);
4607 
4608  int dimL = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
4609  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
4610 
4611  char trans = 'T';
4612  char notrans = 'N';
4613 
4614  //4J3A.spin0
4615  if ((N1==1) && (N2==0)){
4616 
4617  int memSkappa = denS->gKappa(NL,TwoSL,IL,0,1,1,NR,TwoSR,IRdown);
4618  double alpha = sqrt(0.5);
4619  double beta = 1.0;
4620  double * ptr = Cright->gStorage(NR,TwoSR,IRdown,NR,TwoSR,IR);
4621 
4622  dgemm_(&notrans,&notrans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,ptr,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4623 
4624  }
4625 
4626  //4J3B.spin0
4627  if ((N1==2) && (N2==0)){
4628 
4629  int memSkappa = denS->gKappa(NL,TwoSL,IL,1,1,0,NR,TwoSR,IRdown);
4630  double alpha = 1.0;
4631  double beta = 1.0;
4632  double * ptr = Cright->gStorage(NR,TwoSR,IRdown,NR,TwoSR,IR);
4633 
4634  dgemm_(&notrans,&notrans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,ptr,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4635 
4636  }
4637 
4638  //4J3C.spin0
4639  if ((N1==1) && (N2==1) && (TwoJ==0)){
4640 
4641  int memSkappa = denS->gKappa(NL,TwoSL,IL,0,2,0,NR,TwoSR,IRdown);
4642  double alpha = 1.0;
4643  double beta = 1.0;
4644  double * ptr = Cright->gStorage(NR,TwoSR,IRdown,NR,TwoSR,IR);
4645 
4646  dgemm_(&notrans,&notrans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,ptr,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4647 
4648  }
4649 
4650  //4J3D.spin0
4651  if ((N1==2) && (N2==1)){
4652 
4653  int memSkappa = denS->gKappa(NL,TwoSL,IL,1,2,1,NR,TwoSR,IRdown);
4654  double alpha = -sqrt(0.5);
4655  double beta = 1.0;
4656  double * ptr = Cright->gStorage(NR,TwoSR,IRdown,NR,TwoSR,IR);
4657 
4658  dgemm_(&notrans,&notrans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,ptr,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4659 
4660  }
4661 
4662  //4J4A.spin0
4663  if ((N1==0) && (N2==1)){
4664 
4665  int memSkappa = denS->gKappa(NL,TwoSL,IL,1,0,1,NR,TwoSR,IRdown);
4666  double alpha = sqrt(0.5);
4667  double beta = 1.0;
4668  double * ptr = Cright->gStorage(NR,TwoSR,IR,NR,TwoSR,IRdown);
4669 
4670  dgemm_(&notrans,&trans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,ptr,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4671 
4672  }
4673 
4674  //4J4B.spin0
4675  if ((N1==1) && (N2==1) && (TwoJ==0)){
4676 
4677  int memSkappa = denS->gKappa(NL,TwoSL,IL,2,0,0,NR,TwoSR,IRdown);
4678  double alpha = 1.0;
4679  double beta = 1.0;
4680  double * ptr = Cright->gStorage(NR,TwoSR,IR,NR,TwoSR,IRdown);
4681 
4682  dgemm_(&notrans,&trans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,ptr,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4683 
4684  }
4685 
4686  //4J4C.spin0
4687  if ((N1==0) && (N2==2)){
4688 
4689  int memSkappa = denS->gKappa(NL,TwoSL,IL,1,1,0,NR,TwoSR,IRdown);
4690  double alpha = 1.0;
4691  double beta = 1.0;
4692  double * ptr = Cright->gStorage(NR,TwoSR,IR,NR,TwoSR,IRdown);
4693 
4694  dgemm_(&notrans,&trans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,ptr,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4695 
4696  }
4697 
4698  //4J4D.spin0
4699  if ((N1==1) && (N2==2)){
4700 
4701  int memSkappa = denS->gKappa(NL,TwoSL,IL,2,1,1,NR,TwoSR,IRdown);
4702  double alpha = -sqrt(0.5);
4703  double beta = 1.0;
4704  double * ptr = Cright->gStorage(NR,TwoSR,IR,NR,TwoSR,IRdown);
4705 
4706  dgemm_(&notrans,&trans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,ptr,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4707 
4708  }
4709 
4710  }
4711 
4712 }
4713 
4714 void CheMPS2::Heff::addDiagram4J3and4J4spin1(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorOperator * Dright) const{
4715 
4716  int NL = denS->gNL(ikappa);
4717  int TwoSL = denS->gTwoSL(ikappa);
4718  int IL = denS->gIL(ikappa);
4719 
4720  int NR = denS->gNR(ikappa);
4721  int TwoSR = denS->gTwoSR(ikappa);
4722  int IR = denS->gIR(ikappa);
4723 
4724  int N1 = denS->gN1(ikappa);
4725  int N2 = denS->gN2(ikappa);
4726  int TwoJ = denS->gTwoJ(ikappa);
4727 
4728  int theindex = denS->gIndex();
4729  int dimL = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
4730  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
4731 
4732  char trans = 'T';
4733  char notrans = 'N';
4734 
4735  int IRdown = Irreps::directProd(IR,Dright->get_irrep());
4736 
4737  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
4738 
4739  int dimRdown = denBK->gCurrentDim(theindex+2,NR,TwoSRdown,IRdown);
4740  if (dimRdown>0){
4741 
4742  //4J3A.spin1
4743  if ((N1==1) && (N2==0) && (abs(TwoSL-TwoSRdown)<=1)){
4744 
4745  int memSkappa = denS->gKappa(NL,TwoSL,IL,0,1,1,NR,TwoSRdown,IRdown);
4746  int fase = phase(TwoSL+TwoSRdown+3);
4747  double alpha = fase * sqrt(3.0*(TwoSRdown+1)) * Wigner::wigner6j(1,1,2,TwoSR,TwoSRdown,TwoSL);
4748  double beta = 1.0;
4749  double * ptr = Dright->gStorage(NR,TwoSRdown,IRdown,NR,TwoSR,IR);
4750 
4751  dgemm_(&notrans,&notrans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,ptr,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4752 
4753  }
4754 
4755  //4J3C.spin1
4756  if ((N1==2) && (N2==0)){ //TwoSL==TwoSR and hence TwoSRdown can be what it wants
4757 
4758  int memSkappa = denS->gKappa(NL,TwoSL,IL,1,1,2,NR,TwoSRdown,IRdown);
4759  double alpha = - sqrt((TwoSRdown+1.0)/(TwoSR+1.0));
4760  double beta = 1.0;
4761  double * ptr = Dright->gStorage(NR,TwoSRdown,IRdown,NR,TwoSR,IR);
4762 
4763  dgemm_(&notrans,&notrans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,ptr,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4764 
4765  }
4766 
4767  //4J3B.spin1
4768  if ((N1==1) && (N2==1) && (TwoJ==2) && (TwoSL==TwoSRdown)){
4769 
4770  int memSkappa = denS->gKappa(NL,TwoSL,IL,0,2,0,NR,TwoSRdown,IRdown);
4771  double alpha = phase(TwoSR-TwoSRdown);
4772  double beta = 1.0;
4773  double * ptr = Dright->gStorage(NR,TwoSRdown,IRdown,NR,TwoSR,IR);
4774 
4775  dgemm_(&notrans,&notrans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,ptr,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4776 
4777  }
4778 
4779  //4J3D.spin1
4780  if ((N1==2) && (N2==1) && (abs(TwoSL-TwoSRdown)<=1)){
4781 
4782  int memSkappa = denS->gKappa(NL,TwoSL,IL,1,2,1,NR,TwoSRdown,IRdown);
4783  int fase = phase(TwoSL+TwoSRdown+3);
4784  double alpha = fase * sqrt(3.0*(TwoSRdown+1)) * Wigner::wigner6j(1,1,2,TwoSR,TwoSRdown,TwoSL);
4785  double beta = 1.0;
4786  double * ptr = Dright->gStorage(NR,TwoSRdown,IRdown,NR,TwoSR,IR);
4787 
4788  dgemm_(&notrans,&notrans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,ptr,&dimRdown,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4789 
4790  }
4791 
4792  //4J4A.spin1
4793  if ((N1==0) && (N2==1) && (abs(TwoSL-TwoSRdown)<=1)){
4794 
4795  int memSkappa = denS->gKappa(NL,TwoSL,IL,1,0,1,NR,TwoSRdown,IRdown);
4796  int fase = phase(TwoSL+TwoSR+3);
4797  double alpha = fase * sqrt(3.0*(TwoSR+1)) * Wigner::wigner6j(1,1,2,TwoSR,TwoSRdown,TwoSL);
4798  double beta = 1.0;
4799  double * ptr = Dright->gStorage(NR,TwoSR,IR,NR,TwoSRdown,IRdown);
4800 
4801  dgemm_(&notrans,&trans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,ptr,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4802 
4803  }
4804 
4805  //4J4B.spin1
4806  if ((N1==1) && (N2==1) && (TwoJ==2) && (TwoSL==TwoSRdown)){
4807 
4808  int memSkappa = denS->gKappa(NL,TwoSL,IL,2,0,0,NR,TwoSRdown,IRdown);
4809  double alpha = - sqrt((TwoSR+1.0)/(TwoSRdown+1.0));
4810  double beta = 1.0;
4811  double * ptr = Dright->gStorage(NR,TwoSR,IR,NR,TwoSRdown,IRdown);
4812 
4813  dgemm_(&notrans,&trans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,ptr,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4814 
4815  }
4816 
4817  //4J4C.spin1
4818  if ((N1==0) && (N2==2)){ // TwoSL == TwoSR --> TwoSRdown can be what it wants to be.
4819 
4820  int memSkappa = denS->gKappa(NL,TwoSL,IL,1,1,2,NR,TwoSRdown,IRdown);
4821  double alpha = phase(TwoSR-TwoSRdown);
4822  double beta = 1.0;
4823  double * ptr = Dright->gStorage(NR,TwoSR,IR,NR,TwoSRdown,IRdown);
4824 
4825  dgemm_(&notrans,&trans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,ptr,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4826 
4827  }
4828 
4829  //4J4D.spin1
4830  if ((N1==1) && (N2==2) && (abs(TwoSL-TwoSRdown)<=1)){
4831 
4832  int memSkappa = denS->gKappa(NL,TwoSL,IL,2,1,1,NR,TwoSRdown,IRdown);
4833  int fase = phase(TwoSL+TwoSR+3);
4834  double alpha = fase * sqrt(3.0*(TwoSR+1)) * Wigner::wigner6j(1,1,2,TwoSR,TwoSRdown,TwoSL);
4835  double beta = 1.0;
4836  double * ptr = Dright->gStorage(NR,TwoSR,IR,NR,TwoSRdown,IRdown);
4837 
4838  dgemm_(&notrans,&trans,&dimL,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimL,ptr,&dimRup,&beta,memHeff+denS->gKappa2index(ikappa), &dimL);
4839 
4840  }
4841  }
4842  }
4843 
4844 }
4845 
4846 
4847 void CheMPS2::Heff::addDiagram4K1and4K2spin0(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorL ** Lleft, TensorOperator *** Aright, double * temp) const{
4848 
4849  #ifdef CHEMPS2_MPI_COMPILATION
4850  const int MPIRANK = MPIchemps2::mpi_rank();
4851  #endif
4852 
4853  int NL = denS->gNL(ikappa);
4854  int TwoSL = denS->gTwoSL(ikappa);
4855  int IL = denS->gIL(ikappa);
4856 
4857  int NR = denS->gNR(ikappa);
4858  int TwoSR = denS->gTwoSR(ikappa);
4859  int IR = denS->gIR(ikappa);
4860 
4861  int N1 = denS->gN1(ikappa);
4862  int N2 = denS->gN2(ikappa);
4863  int TwoJ = denS->gTwoJ(ikappa);
4864  int TwoS1 = (N1==1)?1:0;
4865 
4866  int theindex = denS->gIndex();
4867  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
4868  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
4869 
4870  char trans = 'T';
4871  char notrans = 'N';
4872 
4873  //4K1A.spin0
4874  if (N2==1){
4875  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
4876  if ((abs(TwoSLdown-TwoSR)<=TwoS1) && (TwoSLdown>=0)){
4877 
4878  int fase = phase(TwoSLdown + TwoSR + TwoJ + 1 + 2*TwoS1);
4879  const double factor = fase * sqrt(0.5 * (TwoSL+1) * (TwoJ+1)) * Wigner::wigner6j(TwoS1,TwoJ,1,TwoSL,TwoSLdown,TwoSR);
4880 
4881  for (int l_index=0; l_index<theindex; l_index++){
4882 
4883  #ifdef CHEMPS2_MPI_COMPILATION
4884  if ( MPIchemps2::owner_absigma( l_index, theindex+1 ) == MPIRANK )
4885  #endif
4886  {
4887  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
4888  int IRdown = Irreps::directProd(IR, Aright[theindex+1-l_index][0]->get_irrep() );
4889 
4890  int dimLdown = denBK->gCurrentDim(theindex, NL-1, TwoSLdown, ILdown);
4891  int dimRdown = denBK->gCurrentDim(theindex+2, NR-2, TwoSR, IRdown);
4892 
4893  if ((dimLdown>0) && (dimRdown>0)){
4894 
4895  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,N1,0,TwoS1,NR-2,TwoSR,IRdown);
4896  double * blockA = Aright[theindex+1-l_index][0]->gStorage(NR-2,TwoSR,IRdown,NR,TwoSR,IR);
4897  double beta = 0.0; //set
4898  double alpha = factor;
4899 
4900  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,blockA,&dimRdown,&beta,temp,&dimLdown);
4901 
4902  beta = 1.0; //add
4903  alpha = 1.0;
4904  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
4905 
4906  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
4907 
4908  }
4909  }
4910  }
4911  }
4912  }
4913  }
4914 
4915  //4K1B.spin0
4916  if (N2==2){
4917  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
4918 
4919  int TwoJstart = ((TwoSLdown!=TwoSR) || (TwoS1==0)) ? TwoS1+1 : 0;
4920  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS1+1; TwoJdown+=2){
4921  if ((abs(TwoSLdown-TwoSR)<=TwoJdown) && (TwoSLdown>=0)){
4922 
4923  int fase = phase(TwoSLdown + TwoSR + TwoJdown + 2 + 2*TwoS1);
4924  const double factor = fase * sqrt(0.5 * (TwoSL+1) * (TwoJdown+1)) * Wigner::wigner6j(TwoJdown,TwoS1,1,TwoSL,TwoSLdown,TwoSR);
4925 
4926  for (int l_index=0; l_index<theindex; l_index++){
4927 
4928  #ifdef CHEMPS2_MPI_COMPILATION
4929  if ( MPIchemps2::owner_absigma( l_index, theindex+1 ) == MPIRANK )
4930  #endif
4931  {
4932  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
4933  int IRdown = Irreps::directProd(IR, Aright[theindex+1-l_index][0]->get_irrep() );
4934 
4935  int dimLdown = denBK->gCurrentDim(theindex, NL-1, TwoSLdown, ILdown);
4936  int dimRdown = denBK->gCurrentDim(theindex+2, NR-2, TwoSR, IRdown);
4937 
4938  if ((dimLdown>0) && (dimRdown>0)){
4939 
4940  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,N1,1,TwoJdown,NR-2,TwoSR,IRdown);
4941  double * blockA = Aright[theindex+1-l_index][0]->gStorage(NR-2,TwoSR,IRdown,NR,TwoSR,IR);
4942  double beta = 0.0; //set
4943  double alpha = factor;
4944 
4945  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,blockA,&dimRdown,&beta,temp,&dimLdown);
4946 
4947  beta = 1.0; //add
4948  alpha = 1.0;
4949  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
4950 
4951  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
4952 
4953  }
4954  }
4955  }
4956  }
4957  }
4958  }
4959  }
4960 
4961  //4K2A.spin0
4962  if (N2==0){
4963  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
4964 
4965  int TwoJstart = ((TwoSLdown!=TwoSR) || (TwoS1==0)) ? TwoS1+1 : 0;
4966  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS1+1; TwoJdown+=2){
4967  if ((abs(TwoSLdown-TwoSR)<=TwoJdown) && (TwoSLdown>=0)){
4968 
4969  int fase = phase(TwoSL + TwoSR + TwoJdown + 1 + 2*TwoS1);
4970  const double factor = fase * sqrt(0.5 * (TwoSLdown+1) * (TwoJdown+1)) * Wigner::wigner6j(TwoJdown,TwoS1,1,TwoSL,TwoSLdown,TwoSR);
4971 
4972  for (int l_index=0; l_index<theindex; l_index++){
4973 
4974  #ifdef CHEMPS2_MPI_COMPILATION
4975  if ( MPIchemps2::owner_absigma( l_index, theindex+1 ) == MPIRANK )
4976  #endif
4977  {
4978  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
4979  int IRdown = Irreps::directProd(IR, Aright[theindex+1-l_index][0]->get_irrep() );
4980 
4981  int dimLdown = denBK->gCurrentDim(theindex, NL+1, TwoSLdown, ILdown);
4982  int dimRdown = denBK->gCurrentDim(theindex+2, NR+2, TwoSR, IRdown);
4983 
4984  if ((dimLdown>0) && (dimRdown>0)){
4985 
4986  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,N1,1,TwoJdown,NR+2,TwoSR,IRdown);
4987  double * blockA = Aright[theindex+1-l_index][0]->gStorage(NR,TwoSR,IR,NR+2,TwoSR,IRdown);
4988  double beta = 0.0; //set
4989  double alpha = factor;
4990 
4991  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,blockA,&dimRup,&beta,temp,&dimLdown);
4992 
4993  beta = 1.0; //add
4994  alpha = 1.0;
4995  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
4996 
4997  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
4998 
4999  }
5000  }
5001  }
5002  }
5003  }
5004  }
5005  }
5006 
5007  //4K2B.spin0
5008  if (N2==1){
5009  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
5010  if ((abs(TwoSLdown-TwoSR)<=TwoS1) && (TwoSLdown>=0)){
5011 
5012  int fase = phase(TwoSL + TwoSR + TwoJ + 2 + 2*TwoS1);
5013  const double factor = fase * sqrt(0.5 * (TwoSLdown+1) * (TwoJ+1)) * Wigner::wigner6j(TwoJ,TwoS1,1,TwoSLdown,TwoSL,TwoSR);
5014 
5015  for (int l_index=0; l_index<theindex; l_index++){
5016 
5017  #ifdef CHEMPS2_MPI_COMPILATION
5018  if ( MPIchemps2::owner_absigma( l_index, theindex+1 ) == MPIRANK )
5019  #endif
5020  {
5021  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
5022  int IRdown = Irreps::directProd(IR, Aright[theindex+1-l_index][0]->get_irrep() );
5023 
5024  int dimLdown = denBK->gCurrentDim(theindex, NL+1, TwoSLdown, ILdown);
5025  int dimRdown = denBK->gCurrentDim(theindex+2, NR+2, TwoSR, IRdown);
5026 
5027  if ((dimLdown>0) && (dimRdown>0)){
5028 
5029  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,N1,2,TwoS1,NR+2,TwoSR,IRdown);
5030  double * blockA = Aright[theindex+1-l_index][0]->gStorage(NR,TwoSR,IR,NR+2,TwoSR,IRdown);
5031  double beta = 0.0; //set
5032  double alpha = factor;
5033 
5034  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,blockA,&dimRup,&beta,temp,&dimLdown);
5035 
5036  beta = 1.0; //add
5037  alpha = 1.0;
5038  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
5039 
5040  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
5041 
5042  }
5043  }
5044  }
5045  }
5046  }
5047  }
5048 
5049 }
5050 
5051 void CheMPS2::Heff::addDiagram4L1and4L2spin0(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorL ** Lleft, TensorOperator *** Aright, double * temp) const{
5052 
5053  #ifdef CHEMPS2_MPI_COMPILATION
5054  const int MPIRANK = MPIchemps2::mpi_rank();
5055  #endif
5056 
5057  int NL = denS->gNL(ikappa);
5058  int TwoSL = denS->gTwoSL(ikappa);
5059  int IL = denS->gIL(ikappa);
5060 
5061  int NR = denS->gNR(ikappa);
5062  int TwoSR = denS->gTwoSR(ikappa);
5063  int IR = denS->gIR(ikappa);
5064 
5065  int N1 = denS->gN1(ikappa);
5066  int N2 = denS->gN2(ikappa);
5067  int TwoJ = denS->gTwoJ(ikappa);
5068  int TwoS2 = (N2==1)?1:0;
5069 
5070  int theindex = denS->gIndex();
5071  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
5072  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
5073 
5074  char trans = 'T';
5075  char notrans = 'N';
5076 
5077  //4L1A.spin0
5078  if (N1==1){
5079  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
5080  if ((abs(TwoSLdown-TwoSR)<=TwoS2) && (TwoSLdown>=0)){
5081 
5082  int fase = phase(TwoSLdown + TwoSR + 2 + TwoS2);
5083  const double factor = fase * sqrt(0.5 * (TwoSL+1) * (TwoJ+1))
5084  * Wigner::wigner6j(TwoS2,TwoJ,1,TwoSL,TwoSLdown,TwoSR);
5085 
5086  for (int l_index=0; l_index<theindex; l_index++){
5087 
5088  #ifdef CHEMPS2_MPI_COMPILATION
5089  if ( MPIchemps2::owner_absigma( l_index, theindex ) == MPIRANK )
5090  #endif
5091  {
5092  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
5093  int IRdown = Irreps::directProd(IR, Aright[theindex-l_index][1]->get_irrep() );
5094 
5095  int dimLdown = denBK->gCurrentDim(theindex, NL-1, TwoSLdown, ILdown);
5096  int dimRdown = denBK->gCurrentDim(theindex+2, NR-2, TwoSR, IRdown);
5097 
5098  if ((dimLdown>0) && (dimRdown>0)){
5099 
5100  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,0,N2,TwoS2,NR-2,TwoSR,IRdown);
5101  double * blockA = Aright[theindex-l_index][1]->gStorage(NR-2,TwoSR,IRdown,NR,TwoSR,IR);
5102  double beta = 0.0; //set
5103  double alpha = factor;
5104 
5105  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,blockA,&dimRdown,&beta,temp,&dimLdown);
5106 
5107  beta = 1.0; //add
5108  alpha = 1.0;
5109  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
5110 
5111  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
5112 
5113  }
5114  }
5115  }
5116  }
5117  }
5118  }
5119 
5120  //4L1B.spin0
5121  if (N1==2){
5122  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
5123 
5124  int TwoJstart = ((TwoSLdown!=TwoSR) || (TwoS2==0)) ? TwoS2+1 : 0;
5125  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS2+1; TwoJdown+=2){
5126  if ((abs(TwoSLdown-TwoSR)<=TwoJdown) && (TwoSLdown>=0)){
5127 
5128  int fase = phase(TwoSLdown + TwoSR + 3 + TwoS2);
5129  const double factor = fase * sqrt(0.5 * (TwoSL+1) * (TwoJdown+1))
5130  * Wigner::wigner6j(TwoJdown,TwoS2,1,TwoSL,TwoSLdown,TwoSR);
5131 
5132  for (int l_index=0; l_index<theindex; l_index++){
5133 
5134  #ifdef CHEMPS2_MPI_COMPILATION
5135  if ( MPIchemps2::owner_absigma( l_index, theindex ) == MPIRANK )
5136  #endif
5137  {
5138  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
5139  int IRdown = Irreps::directProd(IR, Aright[theindex-l_index][1]->get_irrep() );
5140 
5141  int dimLdown = denBK->gCurrentDim(theindex, NL-1, TwoSLdown, ILdown);
5142  int dimRdown = denBK->gCurrentDim(theindex+2, NR-2, TwoSR, IRdown);
5143 
5144  if ((dimLdown>0) && (dimRdown>0)){
5145 
5146  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,1,N2,TwoJdown,NR-2,TwoSR,IRdown);
5147  double * blockA = Aright[theindex-l_index][1]->gStorage(NR-2,TwoSR,IRdown,NR,TwoSR,IR);
5148  double beta = 0.0; //set
5149  double alpha = factor;
5150 
5151  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,blockA,&dimRdown,&beta,temp,&dimLdown);
5152 
5153  beta = 1.0; //add
5154  alpha = 1.0;
5155  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
5156 
5157  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
5158 
5159  }
5160  }
5161  }
5162  }
5163  }
5164  }
5165  }
5166 
5167  //4L2A.spin0
5168  if (N1==0){
5169  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
5170 
5171  int TwoJstart = ((TwoSLdown!=TwoSR) || (TwoS2==0)) ? TwoS2+1 : 0;
5172  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS2+1; TwoJdown+=2){
5173  if ((abs(TwoSLdown-TwoSR)<=TwoJdown) && (TwoSLdown>=0)){
5174 
5175  int fase = phase(TwoSL + TwoSR + 2 + TwoS2);
5176  const double factor = fase * sqrt(0.5 * (TwoSLdown+1) * (TwoJdown+1))
5177  * Wigner::wigner6j(TwoJdown,TwoS2,1,TwoSL,TwoSLdown,TwoSR);
5178 
5179  for (int l_index=0; l_index<theindex; l_index++){
5180 
5181  #ifdef CHEMPS2_MPI_COMPILATION
5182  if ( MPIchemps2::owner_absigma( l_index, theindex ) == MPIRANK )
5183  #endif
5184  {
5185  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
5186  int IRdown = Irreps::directProd(IR, Aright[theindex-l_index][1]->get_irrep() );
5187 
5188  int dimLdown = denBK->gCurrentDim(theindex, NL+1, TwoSLdown, ILdown);
5189  int dimRdown = denBK->gCurrentDim(theindex+2, NR+2, TwoSR, IRdown);
5190 
5191  if ((dimLdown>0) && (dimRdown>0)){
5192 
5193  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,1,N2,TwoJdown,NR+2,TwoSR,IRdown);
5194  double * blockA = Aright[theindex-l_index][1]->gStorage(NR,TwoSR,IR,NR+2,TwoSR,IRdown);
5195  double beta = 0.0; //set
5196  double alpha = factor;
5197 
5198  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,blockA,&dimRup,&beta,temp,&dimLdown);
5199 
5200  beta = 1.0; //add
5201  alpha = 1.0;
5202  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
5203 
5204  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
5205 
5206  }
5207  }
5208  }
5209  }
5210  }
5211  }
5212  }
5213 
5214  //4L2B.spin0
5215  if (N1==1){
5216  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
5217  if ((abs(TwoSLdown-TwoSR)<=TwoS2) && (TwoSLdown>=0)){
5218 
5219  int fase = phase(TwoSL + TwoSR + 3 + TwoS2);
5220  const double factor = fase * sqrt(0.5 * (TwoSLdown+1) * (TwoJ+1))
5221  * Wigner::wigner6j(TwoJ,TwoS2,1,TwoSLdown,TwoSL,TwoSR);
5222 
5223  for (int l_index=0; l_index<theindex; l_index++){
5224 
5225  #ifdef CHEMPS2_MPI_COMPILATION
5226  if ( MPIchemps2::owner_absigma( l_index, theindex ) == MPIRANK )
5227  #endif
5228  {
5229  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
5230  int IRdown = Irreps::directProd(IR, Aright[theindex-l_index][1]->get_irrep() );
5231 
5232  int dimLdown = denBK->gCurrentDim(theindex, NL+1, TwoSLdown, ILdown);
5233  int dimRdown = denBK->gCurrentDim(theindex+2, NR+2, TwoSR, IRdown);
5234 
5235  if ((dimLdown>0) && (dimRdown>0)){
5236 
5237  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,2,N2,TwoS2,NR+2,TwoSR,IRdown);
5238  double * blockA = Aright[theindex-l_index][1]->gStorage(NR,TwoSR,IR,NR+2,TwoSR,IRdown);
5239  double beta = 0.0; //set
5240  double alpha = factor;
5241 
5242  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,blockA,&dimRup,&beta,temp,&dimLdown);
5243 
5244  beta = 1.0; //add
5245  alpha = 1.0;
5246  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
5247 
5248  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
5249 
5250  }
5251  }
5252  }
5253  }
5254  }
5255  }
5256 
5257 }
5258 
5259 void CheMPS2::Heff::addDiagram4K1and4K2spin1(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorL ** Lleft, TensorOperator *** Bright, double * temp) const{
5260 
5261  #ifdef CHEMPS2_MPI_COMPILATION
5262  const int MPIRANK = MPIchemps2::mpi_rank();
5263  #endif
5264 
5265  int NL = denS->gNL(ikappa);
5266  int TwoSL = denS->gTwoSL(ikappa);
5267  int IL = denS->gIL(ikappa);
5268 
5269  int NR = denS->gNR(ikappa);
5270  int TwoSR = denS->gTwoSR(ikappa);
5271  int IR = denS->gIR(ikappa);
5272 
5273  int N1 = denS->gN1(ikappa);
5274  int N2 = denS->gN2(ikappa);
5275  int TwoJ = denS->gTwoJ(ikappa);
5276  int TwoS1 = (N1==1)?1:0;
5277 
5278  int theindex = denS->gIndex();
5279  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
5280  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
5281 
5282  char trans = 'T';
5283  char notrans = 'N';
5284 
5285  //4K1A.spin1
5286  if (N2==1){
5287  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
5288  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
5289  if ((abs(TwoSLdown-TwoSRdown)<=TwoS1) && (TwoSLdown>=0) && (TwoSRdown>=0)){
5290 
5291  int fase = (TwoS1==1)?-1:1;
5292  const double factor = fase * sqrt(3.0 * (TwoSR+1) * (TwoSL+1) * (TwoJ+1))
5293  * Wigner::wigner9j(2, TwoSR, TwoSRdown, 1, TwoSL, TwoSLdown, 1, TwoJ, TwoS1);
5294 
5295  for (int l_index=0; l_index<theindex; l_index++){
5296 
5297  #ifdef CHEMPS2_MPI_COMPILATION
5298  if ( MPIchemps2::owner_absigma( l_index, theindex+1 ) == MPIRANK )
5299  #endif
5300  {
5301  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
5302  int IRdown = Irreps::directProd(IR, Bright[theindex+1-l_index][0]->get_irrep() );
5303 
5304  int dimLdown = denBK->gCurrentDim(theindex, NL-1, TwoSLdown, ILdown);
5305  int dimRdown = denBK->gCurrentDim(theindex+2, NR-2, TwoSRdown, IRdown);
5306 
5307  if ((dimLdown>0) && (dimRdown>0)){
5308 
5309  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,N1,0,TwoS1,NR-2,TwoSRdown,IRdown);
5310  double * blockB = Bright[theindex+1-l_index][0]->gStorage(NR-2,TwoSRdown,IRdown,NR,TwoSR,IR);
5311  double beta = 0.0; //set
5312  double alpha = factor;
5313 
5314  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,blockB,&dimRdown,&beta,temp,&dimLdown);
5315 
5316  beta = 1.0; //add
5317  alpha = 1.0;
5318  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
5319 
5320  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
5321 
5322  }
5323  }
5324  }
5325  }
5326  }
5327  }
5328  }
5329 
5330  //4K1B.spin1
5331  if (N2==2){
5332  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
5333  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
5334 
5335  int TwoJstart = ((TwoSLdown!=TwoSRdown) || (TwoS1==0)) ? TwoS1+1 : 0;
5336  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS1+1; TwoJdown+=2){
5337  if ((abs(TwoSLdown-TwoSRdown)<=TwoJdown) && (TwoSLdown>=0) && (TwoSRdown>=0)){
5338 
5339  int fase = phase(TwoSR-TwoSRdown+TwoSLdown-TwoSL+3+2*TwoS1);
5340  const double factor = fase * sqrt(3.0 * (TwoSR+1) * (TwoSL+1) * (TwoJdown+1))
5341  * Wigner::wigner9j(2, TwoSRdown, TwoSR, 1, TwoSLdown, TwoSL, 1, TwoJdown, TwoS1);
5342 
5343  for (int l_index=0; l_index<theindex; l_index++){
5344 
5345  #ifdef CHEMPS2_MPI_COMPILATION
5346  if ( MPIchemps2::owner_absigma( l_index, theindex+1 ) == MPIRANK )
5347  #endif
5348  {
5349  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
5350  int IRdown = Irreps::directProd(IR, Bright[theindex+1-l_index][0]->get_irrep() );
5351 
5352  int dimLdown = denBK->gCurrentDim(theindex, NL-1, TwoSLdown, ILdown);
5353  int dimRdown = denBK->gCurrentDim(theindex+2, NR-2, TwoSRdown, IRdown);
5354 
5355  if ((dimLdown>0) && (dimRdown>0)){
5356 
5357  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,N1,1,TwoJdown,NR-2,TwoSRdown,IRdown);
5358  double * blockB = Bright[theindex+1-l_index][0]->gStorage(NR-2,TwoSRdown,IRdown,NR,TwoSR,IR);
5359  double beta = 0.0; //set
5360  double alpha = factor;
5361 
5362  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,blockB,&dimRdown,&beta, temp,&dimLdown);
5363 
5364  beta = 1.0; //add
5365  alpha = 1.0;
5366  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
5367 
5368  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
5369 
5370  }
5371  }
5372  }
5373  }
5374  }
5375  }
5376  }
5377  }
5378 
5379  //4K2A.spin1
5380  if (N2==0){
5381  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
5382  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
5383 
5384  int TwoJstart = ((TwoSLdown!=TwoSRdown) || (TwoS1==0)) ? TwoS1+1 : 0;
5385  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS1+1; TwoJdown+=2){
5386  if ((abs(TwoSLdown-TwoSRdown)<=TwoJdown) && (TwoSLdown>=0) && (TwoSRdown>=0)){
5387 
5388  int fase = (TwoS1==1)?-1:1;
5389  const double factor = fase * sqrt(3.0 * (TwoSRdown+1) * (TwoSLdown+1) * (TwoJdown+1))
5390  * Wigner::wigner9j(2, TwoSRdown, TwoSR, 1, TwoSLdown, TwoSL, 1, TwoJdown, TwoS1);
5391 
5392  for (int l_index=0; l_index<theindex; l_index++){
5393 
5394  #ifdef CHEMPS2_MPI_COMPILATION
5395  if ( MPIchemps2::owner_absigma( l_index, theindex+1 ) == MPIRANK )
5396  #endif
5397  {
5398  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
5399  int IRdown = Irreps::directProd(IR, Bright[theindex+1-l_index][0]->get_irrep() );
5400 
5401  int dimLdown = denBK->gCurrentDim(theindex, NL+1, TwoSLdown, ILdown);
5402  int dimRdown = denBK->gCurrentDim(theindex+2, NR+2, TwoSRdown, IRdown);
5403 
5404  if ((dimLdown>0) && (dimRdown>0)){
5405 
5406  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,N1,1,TwoJdown,NR+2,TwoSRdown,IRdown);
5407  double * blockB = Bright[theindex+1-l_index][0]->gStorage(NR,TwoSR,IR,NR+2,TwoSRdown,IRdown);
5408  double beta = 0.0; //set
5409  double alpha = factor;
5410 
5411  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,blockB,&dimRup,&beta,temp,&dimLdown);
5412 
5413  beta = 1.0; //add
5414  alpha = 1.0;
5415  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
5416 
5417  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
5418 
5419  }
5420  }
5421  }
5422  }
5423  }
5424  }
5425  }
5426  }
5427 
5428  //4K2B.spin1
5429  if (N2==1){
5430  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
5431  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
5432  if ((abs(TwoSLdown-TwoSRdown)<=TwoS1) && (TwoSLdown>=0) && (TwoSRdown>=0)){
5433 
5434  int fase = phase(TwoSRdown-TwoSR+TwoSL-TwoSLdown+3+2*TwoS1);
5435  const double factor = fase * sqrt(3.0 * (TwoSRdown+1) * (TwoSLdown+1) * (TwoJ+1))
5436  * Wigner::wigner9j(2, TwoSR, TwoSRdown, 1, TwoSL, TwoSLdown, 1, TwoJ, TwoS1);
5437 
5438  for (int l_index=0; l_index<theindex; l_index++){
5439 
5440  #ifdef CHEMPS2_MPI_COMPILATION
5441  if ( MPIchemps2::owner_absigma( l_index, theindex+1 ) == MPIRANK )
5442  #endif
5443  {
5444  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
5445  int IRdown = Irreps::directProd(IR, Bright[theindex+1-l_index][0]->get_irrep() );
5446 
5447  int dimLdown = denBK->gCurrentDim(theindex, NL+1, TwoSLdown, ILdown);
5448  int dimRdown = denBK->gCurrentDim(theindex+2, NR+2, TwoSRdown, IRdown);
5449 
5450  if ((dimLdown>0) && (dimRdown>0)){
5451 
5452  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,N1,2,TwoS1,NR+2,TwoSRdown,IRdown);
5453  double * blockB = Bright[theindex+1-l_index][0]->gStorage(NR,TwoSR,IR,NR+2,TwoSRdown,IRdown);
5454  double beta = 0.0; //set
5455  double alpha = factor;
5456 
5457  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,blockB,&dimRup,&beta,temp,&dimLdown);
5458 
5459  beta = 1.0; //add
5460  alpha = 1.0;
5461  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
5462 
5463  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
5464  }
5465  }
5466  }
5467  }
5468  }
5469  }
5470  }
5471 
5472 }
5473 
5474 void CheMPS2::Heff::addDiagram4L1and4L2spin1(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorL ** Lleft, TensorOperator *** Bright, double * temp) const{
5475 
5476  #ifdef CHEMPS2_MPI_COMPILATION
5477  const int MPIRANK = MPIchemps2::mpi_rank();
5478  #endif
5479 
5480  int NL = denS->gNL(ikappa);
5481  int TwoSL = denS->gTwoSL(ikappa);
5482  int IL = denS->gIL(ikappa);
5483 
5484  int NR = denS->gNR(ikappa);
5485  int TwoSR = denS->gTwoSR(ikappa);
5486  int IR = denS->gIR(ikappa);
5487 
5488  int N1 = denS->gN1(ikappa);
5489  int N2 = denS->gN2(ikappa);
5490  int TwoJ = denS->gTwoJ(ikappa);
5491  int TwoS2 = (N2==1)?1:0;
5492 
5493  int theindex = denS->gIndex();
5494  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
5495  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
5496 
5497  char trans = 'T';
5498  char notrans = 'N';
5499 
5500  //4L1A.spin1
5501  if (N1==1){
5502  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
5503  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
5504  if ((abs(TwoSLdown-TwoSRdown)<=TwoS2) && (TwoSLdown>=0) && (TwoSRdown>=0)){
5505 
5506  int fase = phase(1+TwoS2-TwoJ);
5507  const double factor = fase * sqrt(3.0 * (TwoSR+1) * (TwoSL+1) * (TwoJ+1))
5508  * Wigner::wigner9j(2, TwoSR, TwoSRdown, 1, TwoSL, TwoSLdown, 1, TwoJ, TwoS2);
5509 
5510  for (int l_index=0; l_index<theindex; l_index++){
5511 
5512  #ifdef CHEMPS2_MPI_COMPILATION
5513  if ( MPIchemps2::owner_absigma( l_index, theindex ) == MPIRANK )
5514  #endif
5515  {
5516  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
5517  int IRdown = Irreps::directProd(IR, Bright[theindex-l_index][1]->get_irrep() );
5518 
5519  int dimLdown = denBK->gCurrentDim(theindex, NL-1, TwoSLdown, ILdown);
5520  int dimRdown = denBK->gCurrentDim(theindex+2, NR-2, TwoSRdown, IRdown);
5521 
5522  if ((dimLdown>0) && (dimRdown>0)){
5523 
5524  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,0,N2,TwoS2,NR-2,TwoSRdown,IRdown);
5525  double * blockB = Bright[theindex-l_index][1]->gStorage(NR-2,TwoSRdown,IRdown,NR,TwoSR,IR);
5526  double beta = 0.0; //set
5527  double alpha = factor;
5528 
5529  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,blockB,&dimRdown,&beta,temp,&dimLdown);
5530 
5531  beta = 1.0; //add
5532  alpha = 1.0;
5533  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
5534 
5535  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
5536  }
5537  }
5538  }
5539  }
5540  }
5541  }
5542  }
5543 
5544  //4L1B.spin1
5545  if (N1==2){
5546  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
5547  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
5548 
5549  int TwoJstart = ((TwoSLdown!=TwoSRdown) || (TwoS2==0)) ? TwoS2+1 : 0;
5550  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS2+1; TwoJdown+=2){
5551  if ((abs(TwoSLdown-TwoSRdown)<=TwoJdown) && (TwoSLdown>=0) && (TwoSRdown>=0)){
5552 
5553  int fase = phase(TwoSR-TwoSRdown+TwoSLdown-TwoSL+TwoS2-TwoJdown); //bug fixed
5554  const double factor = fase * sqrt(3.0 * (TwoSR+1) * (TwoSL+1) * (TwoJdown+1))
5555  * Wigner::wigner9j(2, TwoSRdown, TwoSR, 1, TwoSLdown, TwoSL, 1, TwoJdown, TwoS2);
5556 
5557  for (int l_index=0; l_index<theindex; l_index++){
5558 
5559  #ifdef CHEMPS2_MPI_COMPILATION
5560  if ( MPIchemps2::owner_absigma( l_index, theindex ) == MPIRANK )
5561  #endif
5562  {
5563  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
5564  int IRdown = Irreps::directProd(IR, Bright[theindex-l_index][1]->get_irrep() );
5565 
5566  int dimLdown = denBK->gCurrentDim(theindex, NL-1, TwoSLdown, ILdown);
5567  int dimRdown = denBK->gCurrentDim(theindex+2, NR-2, TwoSRdown, IRdown);
5568 
5569  if ((dimLdown>0) && (dimRdown>0)){
5570 
5571  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,1,N2,TwoJdown,NR-2,TwoSRdown,IRdown);
5572  double * blockB = Bright[theindex-l_index][1]->gStorage(NR-2,TwoSRdown,IRdown,NR,TwoSR,IR);
5573  double beta = 0.0; //set
5574  double alpha = factor;
5575 
5576  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,blockB,&dimRdown,&beta, temp,&dimLdown);
5577 
5578  beta = 1.0; //add
5579  alpha = 1.0;
5580  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
5581 
5582  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
5583  }
5584  }
5585  }
5586  }
5587  }
5588  }
5589  }
5590  }
5591 
5592  //4L2A.spin1
5593  if (N1==0){
5594  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
5595  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
5596 
5597  int TwoJstart = ((TwoSLdown!=TwoSRdown) || (TwoS2==0)) ? TwoS2+1 : 0;
5598  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS2+1; TwoJdown+=2){
5599  if ((abs(TwoSLdown-TwoSRdown)<=TwoJdown) && (TwoSLdown>=0) && (TwoSRdown>=0)){
5600 
5601  int fase = phase(1+TwoS2-TwoJdown);
5602  const double factor = fase * sqrt(3.0 * (TwoSRdown+1) * (TwoSLdown+1) * (TwoJdown+1))
5603  * Wigner::wigner9j(2, TwoSRdown, TwoSR, 1, TwoSLdown, TwoSL, 1, TwoJdown, TwoS2);
5604 
5605  for (int l_index=0; l_index<theindex; l_index++){
5606 
5607  #ifdef CHEMPS2_MPI_COMPILATION
5608  if ( MPIchemps2::owner_absigma( l_index, theindex ) == MPIRANK )
5609  #endif
5610  {
5611  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
5612  int IRdown = Irreps::directProd(IR, Bright[theindex-l_index][1]->get_irrep() );
5613 
5614  int dimLdown = denBK->gCurrentDim(theindex, NL+1, TwoSLdown, ILdown);
5615  int dimRdown = denBK->gCurrentDim(theindex+2, NR+2, TwoSRdown, IRdown);
5616 
5617  if ((dimLdown>0) && (dimRdown>0)){
5618 
5619  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,1,N2,TwoJdown,NR+2,TwoSRdown,IRdown);
5620  double * blockB = Bright[theindex-l_index][1]->gStorage(NR,TwoSR,IR,NR+2,TwoSRdown,IRdown);
5621  double beta = 0.0; //set
5622  double alpha = factor;
5623 
5624  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,blockB,&dimRup,&beta,temp,&dimLdown);
5625 
5626  beta = 1.0; //add
5627  alpha = 1.0;
5628  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
5629 
5630  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
5631  }
5632  }
5633  }
5634  }
5635  }
5636  }
5637  }
5638  }
5639 
5640  //4L2B.spin1
5641  if (N1==1){
5642  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
5643  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
5644  if ((abs(TwoSLdown-TwoSRdown)<=TwoS2) && (TwoSLdown>=0) && (TwoSRdown>=0)){
5645 
5646  int fase = phase(TwoSRdown-TwoSR+TwoSL-TwoSLdown+TwoS2-TwoJ);
5647  const double factor = fase * sqrt(3.0 * (TwoSRdown+1) * (TwoSLdown+1) * (TwoJ+1))
5648  * Wigner::wigner9j(2, TwoSR, TwoSRdown, 1, TwoSL, TwoSLdown, 1, TwoJ, TwoS2);
5649 
5650  for (int l_index=0; l_index<theindex; l_index++){
5651 
5652  #ifdef CHEMPS2_MPI_COMPILATION
5653  if ( MPIchemps2::owner_absigma( l_index, theindex ) == MPIRANK )
5654  #endif
5655  {
5656  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
5657  int IRdown = Irreps::directProd(IR, Bright[theindex-l_index][1]->get_irrep() );
5658 
5659  int dimLdown = denBK->gCurrentDim(theindex, NL+1, TwoSLdown, ILdown);
5660  int dimRdown = denBK->gCurrentDim(theindex+2, NR+2, TwoSRdown, IRdown);
5661 
5662  if ((dimLdown>0) && (dimRdown>0)){
5663 
5664  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,2,N2,TwoS2,NR+2,TwoSRdown,IRdown);
5665  double * blockB = Bright[theindex-l_index][1]->gStorage(NR,TwoSR,IR,NR+2,TwoSRdown,IRdown);
5666  double beta = 0.0; //set
5667  double alpha = factor;
5668 
5669  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,blockB,&dimRup,&beta,temp,&dimLdown);
5670 
5671  beta = 1.0; //add
5672  alpha = 1.0;
5673  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
5674 
5675  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
5676  }
5677  }
5678  }
5679  }
5680  }
5681  }
5682  }
5683 
5684 }
5685 
5686 void CheMPS2::Heff::addDiagram4K3and4K4spin0(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorL ** Lleft, TensorOperator *** Cright, double * temp) const{
5687 
5688  #ifdef CHEMPS2_MPI_COMPILATION
5689  const int MPIRANK = MPIchemps2::mpi_rank();
5690  #endif
5691 
5692  int NL = denS->gNL(ikappa);
5693  int TwoSL = denS->gTwoSL(ikappa);
5694  int IL = denS->gIL(ikappa);
5695 
5696  int NR = denS->gNR(ikappa);
5697  int TwoSR = denS->gTwoSR(ikappa);
5698  int IR = denS->gIR(ikappa);
5699 
5700  int N1 = denS->gN1(ikappa);
5701  int N2 = denS->gN2(ikappa);
5702  int TwoJ = denS->gTwoJ(ikappa);
5703  int TwoS1 = (N1==1)?1:0;
5704 
5705  int theindex = denS->gIndex();
5706  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
5707  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
5708 
5709  char trans = 'T';
5710  char notrans = 'N';
5711 
5712  //4K3A.spin0
5713  if (N2==1){
5714  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
5715  if ((abs(TwoSLdown-TwoSR)<=TwoS1) && (TwoSLdown>=0)){
5716 
5717  int fase = phase(TwoSL + TwoSR + TwoJ + 2*TwoS1);
5718  const double factor = fase * sqrt(0.5 * (TwoSLdown+1) * (TwoJ+1)) * Wigner::wigner6j(TwoJ,TwoS1,1,TwoSLdown,TwoSL,TwoSR);
5719 
5720  for (int l_index=0; l_index<theindex; l_index++){
5721 
5722  #ifdef CHEMPS2_MPI_COMPILATION
5723  if ( MPIchemps2::owner_cdf( Prob->gL(), l_index, theindex+1 ) == MPIRANK )
5724  #endif
5725  {
5726  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
5727  int IRdown = Irreps::directProd(IR, Cright[theindex+1-l_index][0]->get_irrep() );
5728 
5729  int dimLdown = denBK->gCurrentDim(theindex, NL+1, TwoSLdown, ILdown);
5730  int dimRdown = denBK->gCurrentDim(theindex+2, NR, TwoSR, IRdown);
5731 
5732  if ((dimLdown>0) && (dimRdown>0)){
5733 
5734  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,N1,0,TwoS1,NR,TwoSR,IRdown);
5735  double * ptr = Cright[theindex+1-l_index][0]->gStorage(NR,TwoSR,IR,NR,TwoSR,IRdown);
5736 
5737  double beta = 0.0; //set
5738  double alpha = factor;
5739 
5740  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,ptr,&dimRup,&beta,temp,&dimLdown);
5741 
5742  beta = 1.0; //add
5743  alpha = 1.0;
5744  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
5745 
5746  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
5747  }
5748  }
5749  }
5750  }
5751  }
5752  }
5753 
5754  //4K3B.spin0
5755  if (N2==2){
5756  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
5757 
5758  int TwoJstart = ((TwoSLdown!=TwoSR) || (TwoS1==0)) ? TwoS1+1 : 0;
5759  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS1+1; TwoJdown+=2){
5760  if ((abs(TwoSLdown-TwoSR)<=TwoJdown) && (TwoSLdown>=0)){
5761 
5762  int fase = phase(TwoSL + TwoSR + TwoJdown + 1 + 2*TwoS1);
5763  const double factor = fase * sqrt(0.5 * (TwoSLdown+1) * (TwoJdown+1)) * Wigner::wigner6j(TwoJdown,TwoS1,1,TwoSL,TwoSLdown,TwoSR);
5764 
5765  for (int l_index=0; l_index<theindex; l_index++){
5766 
5767  #ifdef CHEMPS2_MPI_COMPILATION
5768  if ( MPIchemps2::owner_cdf( Prob->gL(), l_index, theindex+1 ) == MPIRANK )
5769  #endif
5770  {
5771  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
5772  int IRdown = Irreps::directProd(IR, Cright[theindex+1-l_index][0]->get_irrep() );
5773 
5774  int dimLdown = denBK->gCurrentDim(theindex, NL+1, TwoSLdown, ILdown);
5775  int dimRdown = denBK->gCurrentDim(theindex+2, NR, TwoSR, IRdown);
5776 
5777  if ((dimLdown>0) && (dimRdown>0)){
5778 
5779  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,N1,1,TwoJdown,NR,TwoSR,IRdown);
5780  double * ptr = Cright[theindex+1-l_index][0]->gStorage(NR,TwoSR,IR,NR,TwoSR,IRdown);
5781 
5782  double beta = 0.0; //set
5783  double alpha = factor;
5784 
5785  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,ptr,&dimRup,&beta,temp,&dimLdown);
5786 
5787  beta = 1.0; //add
5788  alpha = 1.0;
5789  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
5790 
5791  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
5792  }
5793  }
5794  }
5795  }
5796  }
5797  }
5798  }
5799 
5800  //4K4A.spin0
5801  if (N2==0){
5802  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
5803 
5804  int TwoJstart = ((TwoSLdown!=TwoSR) || (TwoS1==0)) ? TwoS1+1 : 0;
5805  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS1+1; TwoJdown+=2){
5806  if ((abs(TwoSLdown-TwoSR)<=TwoJdown) && (TwoSLdown>=0)){
5807 
5808  int fase = phase(TwoSLdown + TwoSR + TwoJdown + 2*TwoS1);
5809  const double factor = fase * sqrt(0.5 * (TwoSL+1) * (TwoJdown+1)) * Wigner::wigner6j(TwoJdown,TwoS1,1,TwoSL,TwoSLdown,TwoSR);
5810 
5811  for (int l_index=0; l_index<theindex; l_index++){
5812 
5813  #ifdef CHEMPS2_MPI_COMPILATION
5814  if ( MPIchemps2::owner_cdf( Prob->gL(), l_index, theindex+1 ) == MPIRANK )
5815  #endif
5816  {
5817  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
5818  int IRdown = Irreps::directProd(IR, Cright[theindex+1-l_index][0]->get_irrep() );
5819 
5820  int dimLdown = denBK->gCurrentDim(theindex, NL-1, TwoSLdown, ILdown);
5821  int dimRdown = denBK->gCurrentDim(theindex+2, NR, TwoSR, IRdown);
5822 
5823  if ((dimLdown>0) && (dimRdown>0)){
5824 
5825  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,N1,1,TwoJdown,NR,TwoSR,IRdown);
5826  double * ptr = Cright[theindex+1-l_index][0]->gStorage(NR,TwoSR,IRdown,NR,TwoSR,IR);
5827 
5828  double beta = 0.0; //set
5829  double alpha = factor;
5830 
5831  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,ptr,&dimRdown,&beta,temp,&dimLdown);
5832 
5833  beta = 1.0; //add
5834  alpha = 1.0;
5835  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
5836 
5837  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
5838  }
5839  }
5840  }
5841  }
5842  }
5843  }
5844  }
5845 
5846  //4K4B.spin0
5847  if (N2==1){
5848  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
5849  if ((abs(TwoSLdown-TwoSR)<=TwoS1) && (TwoSLdown>=0)){
5850 
5851  int fase = phase(TwoSLdown + TwoSR + 1 + TwoJ + 2*TwoS1);
5852  const double factor = fase * sqrt(0.5 * (TwoSL+1) * (TwoJ+1)) * Wigner::wigner6j(TwoJ,TwoS1,1,TwoSLdown,TwoSL,TwoSR);
5853 
5854  for (int l_index=0; l_index<theindex; l_index++){
5855 
5856  #ifdef CHEMPS2_MPI_COMPILATION
5857  if ( MPIchemps2::owner_cdf( Prob->gL(), l_index, theindex+1 ) == MPIRANK )
5858  #endif
5859  {
5860  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
5861  int IRdown = Irreps::directProd(IR, Cright[theindex+1-l_index][0]->get_irrep() );
5862 
5863  int dimLdown = denBK->gCurrentDim(theindex, NL-1, TwoSLdown, ILdown);
5864  int dimRdown = denBK->gCurrentDim(theindex+2, NR, TwoSR, IRdown);
5865 
5866  if ((dimLdown>0) && (dimRdown>0)){
5867 
5868  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,N1,2,TwoS1,NR,TwoSR,IRdown);
5869  double * ptr = Cright[theindex+1-l_index][0]->gStorage(NR,TwoSR,IRdown,NR,TwoSR,IR);
5870 
5871  double beta = 0.0; //set
5872  double alpha = factor;
5873 
5874  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,ptr,&dimRdown,&beta,temp,&dimLdown);
5875 
5876  beta = 1.0; //add
5877  alpha = 1.0;
5878  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
5879 
5880  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
5881  }
5882  }
5883  }
5884  }
5885  }
5886  }
5887 
5888 }
5889 
5890 void CheMPS2::Heff::addDiagram4L3and4L4spin0(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorL ** Lleft, TensorOperator *** Cright, double * temp) const{
5891 
5892  #ifdef CHEMPS2_MPI_COMPILATION
5893  const int MPIRANK = MPIchemps2::mpi_rank();
5894  #endif
5895 
5896  int NL = denS->gNL(ikappa);
5897  int TwoSL = denS->gTwoSL(ikappa);
5898  int IL = denS->gIL(ikappa);
5899 
5900  int NR = denS->gNR(ikappa);
5901  int TwoSR = denS->gTwoSR(ikappa);
5902  int IR = denS->gIR(ikappa);
5903 
5904  int N1 = denS->gN1(ikappa);
5905  int N2 = denS->gN2(ikappa);
5906  int TwoJ = denS->gTwoJ(ikappa);
5907  int TwoS2 = (N2==1)?1:0;
5908 
5909  int theindex = denS->gIndex();
5910  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
5911  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
5912 
5913  char trans = 'T';
5914  char notrans = 'N';
5915 
5916  //4L3A.spin0
5917  if (N1==1){
5918  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
5919  if ((abs(TwoSLdown-TwoSR)<=TwoS2) && (TwoSLdown>=0)){
5920 
5921  int fase = phase(TwoSL + TwoSR + 1 + TwoS2);
5922  const double factor = fase * sqrt(0.5 * (TwoSLdown+1) * (TwoJ+1)) * Wigner::wigner6j(TwoJ,TwoS2,1,TwoSLdown,TwoSL,TwoSR);
5923 
5924  for (int l_index=0; l_index<theindex; l_index++){
5925 
5926  #ifdef CHEMPS2_MPI_COMPILATION
5927  if ( MPIchemps2::owner_cdf( Prob->gL(), l_index, theindex ) == MPIRANK )
5928  #endif
5929  {
5930  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
5931  int IRdown = Irreps::directProd(IR, Cright[theindex-l_index][1]->get_irrep() );
5932 
5933  int dimLdown = denBK->gCurrentDim(theindex, NL+1, TwoSLdown, ILdown);
5934  int dimRdown = denBK->gCurrentDim(theindex+2, NR, TwoSR, IRdown);
5935 
5936  if ((dimLdown>0) && (dimRdown>0)){
5937 
5938  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,0,N2,TwoS2,NR,TwoSR,IRdown);
5939  double * ptr = Cright[theindex-l_index][1]->gStorage(NR,TwoSR,IR,NR,TwoSR,IRdown);
5940 
5941  double beta = 0.0; //set
5942  double alpha = factor;
5943 
5944  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,ptr,&dimRup,&beta,temp,&dimLdown);
5945 
5946  beta = 1.0; //add
5947  alpha = 1.0;
5948  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
5949 
5950  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
5951  }
5952  }
5953  }
5954  }
5955  }
5956  }
5957 
5958  //4L3B.spin0
5959  if (N1==2){
5960  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
5961 
5962  int TwoJstart = ((TwoSLdown!=TwoSR) || (TwoS2==0)) ? TwoS2+1 : 0;
5963  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS2+1; TwoJdown+=2){
5964  if ((abs(TwoSLdown-TwoSR)<=TwoJdown) && (TwoSLdown>=0)){
5965 
5966  int fase = phase(TwoSL + TwoSR + 2 + TwoS2);
5967  const double factor = fase * sqrt(0.5 * (TwoSLdown+1) * (TwoJdown+1)) * Wigner::wigner6j(TwoJdown,TwoS2,1,TwoSL,TwoSLdown,TwoSR);
5968 
5969  for (int l_index=0; l_index<theindex; l_index++){
5970 
5971  #ifdef CHEMPS2_MPI_COMPILATION
5972  if ( MPIchemps2::owner_cdf( Prob->gL(), l_index, theindex ) == MPIRANK )
5973  #endif
5974  {
5975  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
5976  int IRdown = Irreps::directProd(IR, Cright[theindex-l_index][1]->get_irrep() );
5977 
5978  int dimLdown = denBK->gCurrentDim(theindex, NL+1, TwoSLdown, ILdown);
5979  int dimRdown = denBK->gCurrentDim(theindex+2, NR, TwoSR, IRdown);
5980 
5981  if ((dimLdown>0) && (dimRdown>0)){
5982 
5983  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,1,N2,TwoJdown,NR,TwoSR,IRdown);
5984  double * ptr = Cright[theindex-l_index][1]->gStorage(NR,TwoSR,IR,NR,TwoSR,IRdown);
5985 
5986  double beta = 0.0; //set
5987  double alpha = factor;
5988 
5989  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,ptr,&dimRup,&beta,temp,&dimLdown);
5990 
5991  beta = 1.0; //add
5992  alpha = 1.0;
5993  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
5994 
5995  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
5996  }
5997  }
5998  }
5999  }
6000  }
6001  }
6002  }
6003 
6004  //4L4A.spin0
6005  if (N1==0){
6006  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
6007 
6008  int TwoJstart = ((TwoSLdown!=TwoSR) || (TwoS2==0)) ? TwoS2+1 : 0;
6009  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS2+1; TwoJdown+=2){
6010  if ((abs(TwoSLdown-TwoSR)<=TwoJdown) && (TwoSLdown>=0)){
6011 
6012  int fase = phase(TwoSLdown + TwoSR + 1 + TwoS2);
6013  const double factor = fase * sqrt(0.5 * (TwoSL+1) * (TwoJdown+1)) * Wigner::wigner6j(TwoJdown,TwoS2,1,TwoSL,TwoSLdown,TwoSR);
6014 
6015  for (int l_index=0; l_index<theindex; l_index++){
6016 
6017  #ifdef CHEMPS2_MPI_COMPILATION
6018  if ( MPIchemps2::owner_cdf( Prob->gL(), l_index, theindex ) == MPIRANK )
6019  #endif
6020  {
6021  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
6022  int IRdown = Irreps::directProd(IR, Cright[theindex-l_index][1]->get_irrep() );
6023 
6024  int dimLdown = denBK->gCurrentDim(theindex, NL-1, TwoSLdown, ILdown);
6025  int dimRdown = denBK->gCurrentDim(theindex+2, NR, TwoSR, IRdown);
6026 
6027  if ((dimLdown>0) && (dimRdown>0)){
6028 
6029  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,1,N2,TwoJdown,NR,TwoSR,IRdown);
6030  double * ptr = Cright[theindex-l_index][1]->gStorage(NR,TwoSR,IRdown,NR,TwoSR,IR);
6031 
6032  double beta = 0.0; //set
6033  double alpha = factor;
6034 
6035  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,ptr,&dimRdown,&beta,temp,&dimLdown);
6036 
6037  beta = 1.0; //add
6038  alpha = 1.0;
6039  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
6040 
6041  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
6042  }
6043  }
6044  }
6045  }
6046  }
6047  }
6048  }
6049 
6050  //4L4B.spin0
6051  if (N1==1){
6052  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
6053  if ((abs(TwoSLdown-TwoSR)<=TwoS2) && (TwoSLdown>=0)){
6054 
6055  int fase = phase(TwoSLdown + TwoSR + 2 + TwoS2);
6056  const double factor = fase * sqrt(0.5 * (TwoSL+1) * (TwoJ+1)) * Wigner::wigner6j(TwoJ,TwoS2,1,TwoSLdown,TwoSL,TwoSR);
6057 
6058  for (int l_index=0; l_index<theindex; l_index++){
6059 
6060  #ifdef CHEMPS2_MPI_COMPILATION
6061  if ( MPIchemps2::owner_cdf( Prob->gL(), l_index, theindex ) == MPIRANK )
6062  #endif
6063  {
6064  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
6065  int IRdown = Irreps::directProd(IR, Cright[theindex-l_index][1]->get_irrep() );
6066 
6067  int dimLdown = denBK->gCurrentDim(theindex, NL-1, TwoSLdown, ILdown);
6068  int dimRdown = denBK->gCurrentDim(theindex+2, NR, TwoSR, IRdown);
6069 
6070  if ((dimLdown>0) && (dimRdown>0)){
6071 
6072  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,2,N2,TwoS2,NR,TwoSR,IRdown);
6073  double * ptr = Cright[theindex-l_index][1]->gStorage(NR,TwoSR,IRdown,NR,TwoSR,IR);
6074 
6075  double beta = 0.0; //set
6076  double alpha = factor;
6077 
6078  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,ptr,&dimRdown,&beta,temp,&dimLdown);
6079 
6080  beta = 1.0; //add
6081  alpha = 1.0;
6082  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
6083 
6084  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
6085  }
6086  }
6087  }
6088  }
6089  }
6090  }
6091 
6092 }
6093 
6094 void CheMPS2::Heff::addDiagram4K3and4K4spin1(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorL ** Lleft, TensorOperator *** Dright, double * temp) const{
6095 
6096  #ifdef CHEMPS2_MPI_COMPILATION
6097  const int MPIRANK = MPIchemps2::mpi_rank();
6098  #endif
6099 
6100  int NL = denS->gNL(ikappa);
6101  int TwoSL = denS->gTwoSL(ikappa);
6102  int IL = denS->gIL(ikappa);
6103 
6104  int NR = denS->gNR(ikappa);
6105  int TwoSR = denS->gTwoSR(ikappa);
6106  int IR = denS->gIR(ikappa);
6107 
6108  int N1 = denS->gN1(ikappa);
6109  int N2 = denS->gN2(ikappa);
6110  int TwoJ = denS->gTwoJ(ikappa);
6111  int TwoS1 = (N1==1)?1:0;
6112 
6113  int theindex = denS->gIndex();
6114  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
6115  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
6116 
6117  char trans = 'T';
6118  char notrans = 'N';
6119 
6120  //4K3A.spin1
6121  if (N2==1){
6122  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
6123  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
6124  if ((abs(TwoSLdown-TwoSRdown)<=TwoS1) && (TwoSLdown>=0) && (TwoSRdown>=0)){
6125 
6126  int fase = phase(TwoSL - TwoSLdown + 1 + 2*TwoS1);
6127  const double factor = fase * sqrt(3.0 * (TwoSR+1) * (TwoSLdown+1) * (TwoJ+1))
6128  * Wigner::wigner9j(2, TwoSR, TwoSRdown, 1, TwoSL, TwoSLdown, 1, TwoJ, TwoS1);
6129 
6130  for (int l_index=0; l_index<theindex; l_index++){
6131 
6132  #ifdef CHEMPS2_MPI_COMPILATION
6133  if ( MPIchemps2::owner_cdf( Prob->gL(), l_index, theindex+1 ) == MPIRANK )
6134  #endif
6135  {
6136  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
6137  int IRdown = Irreps::directProd(IR, Dright[theindex+1-l_index][0]->get_irrep() );
6138 
6139  int dimLdown = denBK->gCurrentDim(theindex, NL+1, TwoSLdown, ILdown);
6140  int dimRdown = denBK->gCurrentDim(theindex+2, NR, TwoSRdown, IRdown);
6141 
6142  if ((dimLdown>0) && (dimRdown>0)){
6143 
6144  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,N1,0,TwoS1,NR,TwoSRdown,IRdown);
6145  double * ptr = Dright[theindex+1-l_index][0]->gStorage(NR,TwoSR,IR,NR,TwoSRdown,IRdown);
6146  double beta = 0.0; //set
6147  double alpha = factor;
6148 
6149  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,ptr,&dimRup,&beta,temp,&dimLdown);
6150 
6151  beta = 1.0; //add
6152  alpha = 1.0;
6153  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
6154 
6155  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
6156  }
6157  }
6158  }
6159  }
6160  }
6161  }
6162  }
6163 
6164  //4K3B.spin1
6165  if (N2==2){
6166  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
6167  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
6168 
6169  int TwoJstart = ((TwoSLdown!=TwoSRdown) || (TwoS1==0)) ? TwoS1+1 : 0;
6170  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS1+1; TwoJdown+=2){
6171  if ((abs(TwoSLdown-TwoSRdown)<=TwoJdown) && (TwoSLdown>=0) && (TwoSRdown>=0)){
6172 
6173  int fase = phase(TwoSR - TwoSRdown + 2*TwoS1);
6174  const double factor = fase * sqrt(3.0 * (TwoSR+1) * (TwoSLdown+1) * (TwoJdown+1))
6175  * Wigner::wigner9j(2, TwoSRdown, TwoSR, 1, TwoSLdown, TwoSL, 1, TwoJdown, TwoS1);
6176 
6177  for (int l_index=0; l_index<theindex; l_index++){
6178 
6179  #ifdef CHEMPS2_MPI_COMPILATION
6180  if ( MPIchemps2::owner_cdf( Prob->gL(), l_index, theindex+1 ) == MPIRANK )
6181  #endif
6182  {
6183  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
6184  int IRdown = Irreps::directProd(IR, Dright[theindex+1-l_index][0]->get_irrep() );
6185 
6186  int dimLdown = denBK->gCurrentDim(theindex, NL+1, TwoSLdown, ILdown);
6187  int dimRdown = denBK->gCurrentDim(theindex+2, NR, TwoSRdown, IRdown);
6188 
6189  if ((dimLdown>0) && (dimRdown>0)){
6190 
6191  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,N1,1,TwoJdown,NR,TwoSRdown,IRdown);
6192  double * ptr = Dright[theindex+1-l_index][0]->gStorage(NR,TwoSR,IR,NR,TwoSRdown,IRdown);
6193  double beta = 0.0; //set
6194  double alpha = factor;
6195 
6196  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,ptr,&dimRup,&beta,temp,&dimLdown);
6197 
6198  beta = 1.0; //add
6199  alpha = 1.0;
6200  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
6201 
6202  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
6203  }
6204  }
6205  }
6206  }
6207  }
6208  }
6209  }
6210  }
6211 
6212  //4K4A.spin1
6213  if (N2==0){
6214  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
6215  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
6216 
6217  int TwoJstart = ((TwoSLdown!=TwoSRdown) || (TwoS1==0)) ? TwoS1+1 : 0;
6218  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS1+1; TwoJdown+=2){
6219  if ((abs(TwoSLdown-TwoSRdown)<=TwoJdown) && (TwoSLdown>=0) && (TwoSRdown>=0)){
6220 
6221  int fase = phase(TwoSLdown + 1 - TwoSL + 2*TwoS1);
6222  const double factor = fase * sqrt(3.0 * (TwoSRdown+1) * (TwoSL+1) * (TwoJdown+1))
6223  * Wigner::wigner9j(2, TwoSRdown, TwoSR, 1, TwoSLdown, TwoSL, 1, TwoJdown, TwoS1);
6224 
6225  for (int l_index=0; l_index<theindex; l_index++){
6226 
6227  #ifdef CHEMPS2_MPI_COMPILATION
6228  if ( MPIchemps2::owner_cdf( Prob->gL(), l_index, theindex+1 ) == MPIRANK )
6229  #endif
6230  {
6231  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
6232  int IRdown = Irreps::directProd(IR, Dright[theindex+1-l_index][0]->get_irrep() );
6233 
6234  int dimLdown = denBK->gCurrentDim(theindex, NL-1, TwoSLdown, ILdown);
6235  int dimRdown = denBK->gCurrentDim(theindex+2, NR, TwoSRdown, IRdown);
6236 
6237  if ((dimLdown>0) && (dimRdown>0)){
6238 
6239  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,N1,1,TwoJdown,NR,TwoSRdown,IRdown);
6240  double * ptr = Dright[theindex+1-l_index][0]->gStorage(NR,TwoSRdown,IRdown,NR,TwoSR,IR);
6241  double beta = 0.0; //set
6242  double alpha = factor;
6243 
6244  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,ptr,&dimRdown,&beta,temp,&dimLdown);
6245 
6246  beta = 1.0; //add
6247  alpha = 1.0;
6248  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
6249 
6250  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
6251  }
6252  }
6253  }
6254  }
6255  }
6256  }
6257  }
6258  }
6259 
6260  //4K4B.spin1
6261  if (N2==1){
6262  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
6263  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
6264  if ((abs(TwoSLdown-TwoSRdown)<=TwoS1) && (TwoSLdown>=0) && (TwoSRdown>=0)){
6265 
6266  int fase = phase(TwoSR - TwoSRdown + 2*TwoS1);
6267  const double factor = fase * sqrt(3.0 * (TwoSRdown+1) * (TwoSL+1) * (TwoJ+1))
6268  * Wigner::wigner9j( 2, TwoSR, TwoSRdown, 1, TwoSL, TwoSLdown, 1, TwoJ, TwoS1 );
6269 
6270  for (int l_index=0; l_index<theindex; l_index++){
6271 
6272  #ifdef CHEMPS2_MPI_COMPILATION
6273  if ( MPIchemps2::owner_cdf( Prob->gL(), l_index, theindex+1 ) == MPIRANK )
6274  #endif
6275  {
6276  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
6277  int IRdown = Irreps::directProd(IR, Dright[theindex+1-l_index][0]->get_irrep() );
6278 
6279  int dimLdown = denBK->gCurrentDim(theindex, NL-1, TwoSLdown, ILdown);
6280  int dimRdown = denBK->gCurrentDim(theindex+2, NR, TwoSRdown, IRdown);
6281 
6282  if ((dimLdown>0) && (dimRdown>0)){
6283 
6284  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,N1,2,TwoS1,NR,TwoSRdown,IRdown);
6285  double * ptr = Dright[theindex+1-l_index][0]->gStorage(NR,TwoSRdown,IRdown,NR,TwoSR,IR);
6286  double beta = 0.0; //set
6287  double alpha = factor;
6288 
6289  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,ptr,&dimRdown,&beta,temp,&dimLdown);
6290 
6291  beta = 1.0; //add
6292  alpha = 1.0;
6293  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
6294 
6295  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
6296  }
6297  }
6298  }
6299  }
6300  }
6301  }
6302  }
6303 
6304 }
6305 
6306 void CheMPS2::Heff::addDiagram4L3and4L4spin1(const int ikappa, double * memS, double * memHeff, const Sobject * denS, TensorL ** Lleft, TensorOperator *** Dright, double * temp) const{
6307 
6308  #ifdef CHEMPS2_MPI_COMPILATION
6309  const int MPIRANK = MPIchemps2::mpi_rank();
6310  #endif
6311 
6312  int NL = denS->gNL(ikappa);
6313  int TwoSL = denS->gTwoSL(ikappa);
6314  int IL = denS->gIL(ikappa);
6315 
6316  int NR = denS->gNR(ikappa);
6317  int TwoSR = denS->gTwoSR(ikappa);
6318  int IR = denS->gIR(ikappa);
6319 
6320  int N1 = denS->gN1(ikappa);
6321  int N2 = denS->gN2(ikappa);
6322  int TwoJ = denS->gTwoJ(ikappa);
6323  int TwoS2 = (N2==1)?1:0;
6324 
6325  int theindex = denS->gIndex();
6326  int dimLup = denBK->gCurrentDim(theindex ,NL,TwoSL,IL);
6327  int dimRup = denBK->gCurrentDim(theindex+2,NR,TwoSR,IR);
6328 
6329  char trans = 'T';
6330  char notrans = 'N';
6331 
6332  //4L3A.spin1
6333  if (N1==1){
6334  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
6335  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
6336  if ((abs(TwoSLdown-TwoSRdown)<=TwoS2) && (TwoSLdown>=0) && (TwoSRdown>=0)){
6337 
6338  int fase = phase(TwoSL - TwoSLdown + 2 + TwoS2 - TwoJ);
6339  const double factor = fase * sqrt(3.0 * (TwoSR+1) * (TwoSLdown+1) * (TwoJ+1))
6340  * Wigner::wigner9j( 2, TwoSR, TwoSRdown, 1, TwoSL, TwoSLdown, 1, TwoJ, TwoS2 );
6341 
6342  for (int l_index=0; l_index<theindex; l_index++){
6343 
6344  #ifdef CHEMPS2_MPI_COMPILATION
6345  if ( MPIchemps2::owner_cdf( Prob->gL(), l_index, theindex ) == MPIRANK )
6346  #endif
6347  {
6348  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
6349  int IRdown = Irreps::directProd(IR, Dright[theindex-l_index][1]->get_irrep() );
6350 
6351  int dimLdown = denBK->gCurrentDim(theindex, NL+1, TwoSLdown, ILdown);
6352  int dimRdown = denBK->gCurrentDim(theindex+2, NR, TwoSRdown, IRdown);
6353 
6354  if ((dimLdown>0) && (dimRdown>0)){
6355 
6356  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,0, N2,TwoS2,NR,TwoSRdown,IRdown);
6357  double * ptr = Dright[theindex-l_index][1]->gStorage(NR,TwoSR,IR,NR,TwoSRdown,IRdown);
6358  double beta = 0.0; //set
6359  double alpha = factor;
6360 
6361  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,ptr,&dimRup,&beta,temp,&dimLdown);
6362 
6363  beta = 1.0; //add
6364  alpha = 1.0;
6365  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
6366 
6367  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
6368  }
6369  }
6370  }
6371  }
6372  }
6373  }
6374  }
6375 
6376  //4L3B.spin1
6377  if (N1==2){
6378  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
6379  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
6380 
6381  int TwoJstart = ((TwoSLdown!=TwoSRdown) || (TwoS2==0)) ? TwoS2+1 : 0;
6382  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS2+1; TwoJdown+=2){
6383  if ((abs(TwoSLdown-TwoSRdown)<=TwoJdown) && (TwoSLdown>=0) && (TwoSRdown>=0)){
6384 
6385  int fase = phase(TwoSR - TwoSRdown + 1 + TwoS2 - TwoJdown);
6386  const double factor = fase * sqrt(3.0 * (TwoSR+1) * (TwoSLdown+1) * (TwoJdown+1))
6387  * Wigner::wigner9j( 2, TwoSRdown, TwoSR, 1, TwoSLdown, TwoSL, 1, TwoJdown, TwoS2 );
6388 
6389  for (int l_index=0; l_index<theindex; l_index++){
6390 
6391  #ifdef CHEMPS2_MPI_COMPILATION
6392  if ( MPIchemps2::owner_cdf( Prob->gL(), l_index, theindex ) == MPIRANK )
6393  #endif
6394  {
6395  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
6396  int IRdown = Irreps::directProd(IR, Dright[theindex-l_index][1]->get_irrep() );
6397 
6398  int dimLdown = denBK->gCurrentDim(theindex, NL+1, TwoSLdown, ILdown);
6399  int dimRdown = denBK->gCurrentDim(theindex+2, NR, TwoSRdown, IRdown);
6400 
6401  if ((dimLdown>0) && (dimRdown>0)){
6402 
6403  int memSkappa = denS->gKappa(NL+1,TwoSLdown,ILdown,1,N2,TwoJdown,NR,TwoSRdown,IRdown);
6404  double * ptr = Dright[theindex-l_index][1]->gStorage(NR,TwoSR,IR,NR,TwoSRdown,IRdown);
6405  double beta = 0.0; //set
6406  double alpha = factor;
6407 
6408  dgemm_(&notrans,&trans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,ptr,&dimRup,&beta,temp,&dimLdown);
6409 
6410  beta = 1.0; //add
6411  alpha = 1.0;
6412  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL,TwoSL,IL,NL+1,TwoSLdown,ILdown);
6413 
6414  dgemm_(&notrans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLup,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
6415  }
6416  }
6417  }
6418  }
6419  }
6420  }
6421  }
6422  }
6423 
6424  //4L4A.spin1
6425  if (N1==0){
6426  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
6427  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
6428 
6429  int TwoJstart = ((TwoSLdown!=TwoSRdown) || (TwoS2==0)) ? TwoS2+1 : 0;
6430  for (int TwoJdown=TwoJstart; TwoJdown<=TwoS2+1; TwoJdown+=2){
6431  if ((abs(TwoSLdown-TwoSRdown)<=TwoJdown) && (TwoSLdown>=0) && (TwoSRdown>=0)){
6432 
6433  int fase = phase(TwoSLdown + 2 - TwoSL + TwoS2 - TwoJdown);
6434  const double factor = fase * sqrt(3.0 * (TwoSRdown+1) * (TwoSL+1) * (TwoJdown+1))
6435  * Wigner::wigner9j( 2, TwoSRdown, TwoSR, 1, TwoSLdown, TwoSL, 1, TwoJdown, TwoS2 );
6436 
6437  for (int l_index=0; l_index<theindex; l_index++){
6438 
6439  #ifdef CHEMPS2_MPI_COMPILATION
6440  if ( MPIchemps2::owner_cdf( Prob->gL(), l_index, theindex ) == MPIRANK )
6441  #endif
6442  {
6443  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
6444  int IRdown = Irreps::directProd(IR, Dright[theindex-l_index][1]->get_irrep() );
6445 
6446  int dimLdown = denBK->gCurrentDim(theindex, NL-1, TwoSLdown, ILdown);
6447  int dimRdown = denBK->gCurrentDim(theindex+2, NR, TwoSRdown, IRdown);
6448 
6449  if ((dimLdown>0) && (dimRdown>0)){
6450 
6451  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,1,N2,TwoJdown,NR,TwoSRdown,IRdown);
6452  double * ptr = Dright[theindex-l_index][1]->gStorage(NR,TwoSRdown,IRdown,NR,TwoSR,IR);
6453  double beta = 0.0; //set
6454  double alpha = factor;
6455 
6456  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,ptr,&dimRdown,&beta,temp,&dimLdown);
6457 
6458  beta = 1.0; //add
6459  alpha = 1.0;
6460  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
6461 
6462  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
6463  }
6464  }
6465  }
6466  }
6467  }
6468  }
6469  }
6470  }
6471 
6472  //4L4B.spin1
6473  if (N1==1){
6474  for (int TwoSLdown=TwoSL-1; TwoSLdown<=TwoSL+1; TwoSLdown+=2){
6475  for (int TwoSRdown=TwoSR-2; TwoSRdown<=TwoSR+2; TwoSRdown+=2){
6476  if ((abs(TwoSLdown-TwoSRdown)<=TwoS2) && (TwoSLdown>=0) && (TwoSRdown>=0)){
6477 
6478  int fase = phase(TwoSR - TwoSRdown + 1 + TwoS2 - TwoJ);
6479  const double factor = fase * sqrt(3.0 * (TwoSRdown+1) * (TwoSL+1) * (TwoJ+1))
6480  * Wigner::wigner9j( 2, TwoSR, TwoSRdown, 1, TwoSL, TwoSLdown, 1, TwoJ, TwoS2 );
6481 
6482  for (int l_index=0; l_index<theindex; l_index++){
6483 
6484  #ifdef CHEMPS2_MPI_COMPILATION
6485  if ( MPIchemps2::owner_cdf( Prob->gL(), l_index, theindex ) == MPIRANK )
6486  #endif
6487  {
6488  int ILdown = Irreps::directProd(IL, denBK->gIrrep(l_index));
6489  int IRdown = Irreps::directProd(IR, Dright[theindex-l_index][1]->get_irrep() );
6490 
6491  int dimLdown = denBK->gCurrentDim(theindex, NL-1, TwoSLdown, ILdown);
6492  int dimRdown = denBK->gCurrentDim(theindex+2, NR, TwoSRdown, IRdown);
6493 
6494  if ((dimLdown>0) && (dimRdown>0)){
6495 
6496  int memSkappa = denS->gKappa(NL-1,TwoSLdown,ILdown,2,N2,TwoS2,NR,TwoSRdown,IRdown);
6497  double * ptr = Dright[theindex-l_index][1]->gStorage(NR,TwoSRdown,IRdown,NR,TwoSR,IR);
6498  double beta = 0.0; //set
6499  double alpha = factor;
6500 
6501  dgemm_(&notrans,&notrans,&dimLdown,&dimRup,&dimRdown,&alpha,memS+denS->gKappa2index(memSkappa),&dimLdown,ptr,&dimRdown,&beta,temp,&dimLdown);
6502 
6503  beta = 1.0; //add
6504  alpha = 1.0;
6505  double * blockL = Lleft[theindex-1-l_index]->gStorage(NL-1,TwoSLdown,ILdown,NL,TwoSL,IL);
6506 
6507  dgemm_(&trans,&notrans,&dimLup,&dimRup,&dimLdown,&alpha,blockL,&dimLdown,temp,&dimLdown,&beta,memHeff+denS->gKappa2index(ikappa),&dimLup);
6508  }
6509  }
6510  }
6511  }
6512  }
6513  }
6514  }
6515 
6516 }
6517 
6518 
CheMPS2::Wigner::wigner6j
static double wigner6j(const int two_ja, const int two_jb, const int two_jc, const int two_jd, const int two_je, const int two_jf)
Wigner-6j symbol (gsl api)
Definition: Wigner.cpp:294
CheMPS2::SyBookkeeper::gCurrentDim
int gCurrentDim(const int boundary, const int N, const int TwoS, const int irrep) const
Get the current virtual dimensions.
Definition: SyBookkeeper.cpp:165
CheMPS2::MPIchemps2::mpi_rank
static int mpi_rank()
Get the rank of this MPI process.
Definition: MPIchemps2.h:131
CheMPS2::Problem::gMxElement
double gMxElement(const int alpha, const int beta, const int gamma, const int delta) const
Get a specific interaction matrix element.
Definition: Problem.cpp:350
CheMPS2::Irreps::directProd
static int directProd(const int Irrep1, const int Irrep2)
Get the direct product of the irreps with numbers Irrep1 and Irrep2: a bitwise XOR for psi4&#39;s convent...
Definition: Irreps.h:123
CheMPS2::Problem::gL
int gL() const
Get the number of orbitals.
Definition: Problem.h:51
CheMPS2::SyBookkeeper::getNumberOfIrreps
int getNumberOfIrreps() const
Get the total number of irreps.
Definition: SyBookkeeper.cpp:153
CheMPS2::Heff::phase
static int phase(const int TwoTimesPower)
Phase function.
Definition: Heff.h:75
CheMPS2::SyBookkeeper::gIrrep
int gIrrep(const int orbital) const
Get an orbital irrep.
Definition: SyBookkeeper.cpp:145
CheMPS2::Wigner::wigner9j
static double wigner9j(const int two_ja, const int two_jb, const int two_jc, const int two_jd, const int two_je, const int two_jf, const int two_jg, const int two_jh, const int two_ji)
Wigner-9j symbol (gsl api)
Definition: Wigner.cpp:341