Subroutine to initialise the WL tensor.
94 INTEGER :: allocstat,i,j,k,m
96 print*,
'Initializing the decompostion tensors...' 98 print*,
"Initializing the correlation matrices and tensors..." 102 print*,
"Computing the M1 terms..." 105 IF (allocstat /= 0) stop
"*** Not enough memory ! ***" 108 IF (allocstat /= 0) stop
"*** Not enough memory ! ***" 111 IF (allocstat /= 0) stop
"*** Not enough memory ! ***" 113 ALLOCATE(dumb_vec(
ndim),
stat=allocstat)
114 IF (allocstat /= 0) stop
"*** Not enough memory ! ***" 129 m12def=.not.tensor_empty(m12)
133 CALL sparse_mul3_with_mat(bxyy,corr_i_full,m13)
139 print*,
"Computing the M2 terms..." 141 IF (allocstat /= 0) stop
"*** Not enough memory ! ***" 147 m21def=.not.tensor_empty(m21)
152 m22def=.not.tensor_empty(m22)
155 print*,
"Computing the M3 terms..." 157 print*,
"Computing the L subterms..." 159 IF (allocstat /= 0) stop
"*** Not enough memory ! ***" 162 CALL coo_to_mat_ik(lyx,dumb_mat1)
163 CALL coo_to_mat_ik(lxy,dumb_mat2)
165 CALL coo_to_mat_ik(dy(:,m),dumb_mat3)
166 dumb_mat4=matmul(dumb_mat2,matmul(transpose(dumb_mat3),dumb_mat1))
167 CALL matc_to_coo(dumb_mat4,l1(:,m))
174 CALL coo_to_mat_i(i,bxyy,dumb_mat1)
175 CALL sparse_mul4_with_mat_kl(ydyy(:,m),dumb_mat1,dumb_mat2)
177 CALL coo_to_mat_j(j,byxy,dumb_mat1)
178 dumb_mat4(i,j)=mat_trace(matmul(dumb_mat1,dumb_mat2))
181 CALL matc_to_coo(dumb_mat4,l2(:,m))
213 ALLOCATE(ltot(
ndim,mems),
stat=allocstat)
214 IF (allocstat /= 0) stop
"*** Not enough memory ! ***" 223 ldef=.not.tensor_empty(ltot)
225 print*,
"Computing the B terms..." 227 IF (allocstat /= 0) stop
"*** Not enough memory ! ***" 230 CALL coo_to_mat_ik(lxy,dumb_mat1)
231 dumb_mat1=transpose(dumb_mat1)
233 CALL coo_to_mat_ik(dy(:,m),dumb_mat2)
234 dumb_mat2=matmul(dumb_mat2,dumb_mat1)
237 CALL coo_to_vec_jk(j,k,byxx,dumb_vec)
238 dumb_vec=matmul(dumb_vec,dumb_mat2)
239 CALL add_vec_jk_to_tensor(j,k,dumb_vec,b1(:,m))
245 CALL coo_to_mat_ik(lyx,dumb_mat3)
246 dumb_mat3=transpose(dumb_mat3)
249 CALL coo_to_mat_i(i,bxxy,dumb_mat1)
250 CALL coo_to_mat_ik(dy(:,m),dumb_mat2)
251 dumb_mat1=matmul(dumb_mat2,transpose(dumb_mat1))
252 dumb_mat1=matmul(dumb_mat3,dumb_mat1)
253 CALL add_matc_to_tensor(i,dumb_mat1,b2(:,m))
286 ALLOCATE(b14(
ndim,mems), b23(
ndim,mems),
stat=allocstat)
287 IF (allocstat /= 0) stop
"*** Not enough memory ! ***" 296 b14def=.not.tensor_empty(b14)
297 b23def=.not.tensor_empty(b23)
301 print*,
"Computing the M term..." 303 ALLOCATE(mtot(
ndim,mems),
stat=allocstat)
304 IF (allocstat /= 0) stop
"*** Not enough memory ! ***" 308 CALL coo_to_mat_i(i,bxxy,dumb_mat1)
309 CALL coo_to_mat_ik(dy(:,m),dumb_mat2)
310 dumb_mat1=matmul(dumb_mat2,transpose(dumb_mat1))
313 CALL coo_to_vec_jk(j,k,byxx,dumb_vec)
314 dumb_vec=matmul(dumb_vec,dumb_mat1)
315 CALL add_vec_ijk_to_tensor4(i,j,k,dumb_vec,mtot(:,m))
321 mdef=.not.tensor4_empty(mtot)
324 DEALLOCATE(dumb_mat1, dumb_mat2,
stat=allocstat)
325 IF (allocstat /= 0) stop
"*** Problem to deallocate ! ***" 327 DEALLOCATE(dumb_mat3, dumb_mat4,
stat=allocstat)
328 IF (allocstat /= 0) stop
"*** Problem to deallocate ! ***" 330 DEALLOCATE(dumb_vec,
stat=allocstat)
331 IF (allocstat /= 0) stop
"*** Problem to deallocate ! ***" integer ndim
Number of variables (dimension of the model)
subroutine, public copy_coo(src, dst)
Routine to copy a coolist.
subroutine, public add_to_tensor(src, dst)
Routine to add a rank-3 tensor to another one.