A Modular Arbitrary-Order Ocean-Atmosphere Model -- Stochastic implementation
tensor.f90
Go to the documentation of this file.
1 
2 ! tensor.f90
3 !
4 !> Tensor utility module
5 !
6 !> @copyright
7 !> 2015-2017 Lesley De Cruz & Jonathan Demaeyer.
8 !> See LICENSE.txt for license information.
9 !
10 !---------------------------------------------------------------------------!
11 !
12 !> @remark
13 !> coolist is a type and also means "coordinate list"
14 !
15 !---------------------------------------------------------------------------!
16 
17 
18 MODULE tensor
19  USE params, only: ndim
20  IMPLICIT NONE
21 
22  PRIVATE
23 
24  !> Coordinate list element type. Elementary elements of the sparse tensors.
25  TYPE :: coolist_elem
26  INTEGER :: j !< Index \f$j\f$ of the element
27  INTEGER :: k !< Index \f$k\f$ of the element
28  REAL(KIND=8) :: v !< Value of the element
29  END TYPE coolist_elem
30 
31  !> 4d coordinate list element type. Elementary elements of the 4d sparse tensors.
32  TYPE :: coolist_elem4
33  INTEGER :: j,k,l
34  REAL(KIND=8) :: v
35  END TYPE coolist_elem4
36 
37  !> Coordinate list. Type used to represent the sparse tensor.
38  TYPE, PUBLIC :: coolist
39  TYPE(coolist_elem), DIMENSION(:), ALLOCATABLE :: elems !< Lists of elements tensor::coolist_elem
40  INTEGER :: nelems = 0 !< Number of elements in the list.
41  END TYPE coolist
42 
43  !> 4d coordinate list. Type used to represent the rank-4 sparse tensor.
44  TYPE, PUBLIC :: coolist4
45  TYPE(coolist_elem4), DIMENSION(:), ALLOCATABLE :: elems
46  INTEGER :: nelems = 0
47  END TYPE coolist4
48 
49  !> Parameter to test the equality with zero.
50  REAL(KIND=8), PARAMETER :: real_eps = 2.2204460492503131e-16
51 
52  PUBLIC :: sparse_mul4,sparse_mul3,sparse_mul2_j,sparse_mul2_k
53  PUBLIC :: mat_to_coo,jsparse_mul,jsparse_mul_mat
54  PUBLIC :: copy_tensor,simplify
55  PUBLIC :: tensor_to_coo,tensor4_to_coo4
56  PUBLIC :: print_tensor,print_tensor4,add_to_tensor
57  PUBLIC :: coo_to_mat_ik,coo_to_mat_ij,coo_to_mat_i,sparse_mul4_with_mat_jl,matc_to_coo,coo_to_mat_j
58  PUBLIC :: add_matc_to_tensor,coo_to_vec_jk,add_vec_jk_to_tensor,add_vec_ikl_to_tensor4_perm!,tensor_ij_perm
59  PUBLIC :: add_matc_to_tensor4,load_tensor4_from_file,write_tensor4_to_file
60  PUBLIC :: tensor_empty,tensor4_empty
61  PUBLIC :: sparse_mul4_mat,sparse_mul3_mat,sparse_mul3_with_mat,add_vec_ikl_to_tensor4
62  PUBLIC :: sparse_mul4_with_mat_kl,add_vec_ijk_to_tensor4,scal_mul_coo
63 
64 CONTAINS
65 
66  !> Routine to copy a rank-3 tensor.
67  !> @param src Source tensor
68  !> @param dst Destination tensor
69  !> @remark The destination tensor have to be an empty tensor, i.e. with unallocated list of elements and nelems set to 0.
70  SUBROUTINE copy_tensor(src,dst)
71  TYPE(coolist), DIMENSION(ndim), INTENT(IN) :: src
72  TYPE(coolist), DIMENSION(ndim), INTENT(OUT) :: dst
73  INTEGER :: i,j,AllocStat
74 
75  DO i=1,ndim
76  IF (dst(i)%nelems/=0) stop "*** copy_tensor : Destination coolist not empty ! ***"
77  ALLOCATE(dst(i)%elems(src(i)%nelems), stat=allocstat)
78  IF (allocstat /= 0) stop "*** Not enough memory ! ***"
79  DO j=1,src(i)%nelems
80  dst(i)%elems(j)%j=src(i)%elems(j)%j
81  dst(i)%elems(j)%k=src(i)%elems(j)%k
82  dst(i)%elems(j)%v=src(i)%elems(j)%v
83  ENDDO
84  dst(i)%nelems=src(i)%nelems
85  ENDDO
86  END SUBROUTINE copy_tensor
87 
88  !> Routine to add a rank-3 tensor to another one.
89  !> @param src Tensor to add
90  !> @param dst Destination tensor
91  SUBROUTINE add_to_tensor(src,dst)
92  TYPE(coolist), DIMENSION(ndim), INTENT(IN) :: src
93  TYPE(coolist), DIMENSION(ndim), INTENT(INOUT) :: dst
94  TYPE(coolist_elem), DIMENSION(:), ALLOCATABLE :: celems
95  INTEGER :: i,j,n,AllocStat
96 
97  DO i=1,ndim
98  IF (src(i)%nelems/=0) THEN
99  IF (dst(i)%nelems==0) THEN
100  IF (ALLOCATED(dst(i)%elems)) THEN
101  DEALLOCATE(dst(i)%elems, stat=allocstat)
102  IF (allocstat /= 0) stop "*** Deallocation problem ! ***"
103  ENDIF
104  ALLOCATE(dst(i)%elems(src(i)%nelems), stat=allocstat)
105  IF (allocstat /= 0) stop "*** Not enough memory ! ***"
106  n=0
107  ELSE
108  n=dst(i)%nelems
109  ALLOCATE(celems(n), stat=allocstat)
110  DO j=1,n
111  celems(j)%j=dst(i)%elems(j)%j
112  celems(j)%k=dst(i)%elems(j)%k
113  celems(j)%v=dst(i)%elems(j)%v
114  ENDDO
115  DEALLOCATE(dst(i)%elems, stat=allocstat)
116  IF (allocstat /= 0) stop "*** Deallocation problem ! ***"
117  ALLOCATE(dst(i)%elems(src(i)%nelems+n), stat=allocstat)
118  IF (allocstat /= 0) stop "*** Not enough memory ! ***"
119  DO j=1,n
120  dst(i)%elems(j)%j=celems(j)%j
121  dst(i)%elems(j)%k=celems(j)%k
122  dst(i)%elems(j)%v=celems(j)%v
123  ENDDO
124  DEALLOCATE(celems, stat=allocstat)
125  IF (allocstat /= 0) stop "*** Deallocation problem ! ***"
126  ENDIF
127  DO j=1,src(i)%nelems
128  dst(i)%elems(n+j)%j=src(i)%elems(j)%j
129  dst(i)%elems(n+j)%k=src(i)%elems(j)%k
130  dst(i)%elems(n+j)%v=src(i)%elems(j)%v
131  ENDDO
132  dst(i)%nelems=src(i)%nelems+n
133  ENDIF
134  ENDDO
135 
136  END SUBROUTINE add_to_tensor
137 
138 
139  !> Routine to add a matrix to a rank-3 tensor.
140  !> @param i Add to tensor component i
141  !> @param src Matrix to add
142  !> @param dst Destination tensor
143  SUBROUTINE add_matc_to_tensor(i,src,dst)
144  INTEGER, INTENT(IN) :: i
145  REAL(KIND=8), DIMENSION(ndim,ndim), INTENT(IN) :: src
146  TYPE(coolist), DIMENSION(ndim), INTENT(INOUT) :: dst
147  TYPE(coolist_elem), DIMENSION(:), ALLOCATABLE :: celems
148  INTEGER :: j,k,r,n,nsrc,AllocStat
149 
150  nsrc=0
151  DO j=1,ndim
152  DO k=1,ndim
153  IF (abs(src(j,k))>real_eps) nsrc=nsrc+1
154  END DO
155  END DO
156 
157  IF (dst(i)%nelems==0) THEN
158  IF (ALLOCATED(dst(i)%elems)) THEN
159  DEALLOCATE(dst(i)%elems, stat=allocstat)
160  IF (allocstat /= 0) stop "*** Deallocation problem ! ***"
161  ENDIF
162  ALLOCATE(dst(i)%elems(nsrc), stat=allocstat)
163  IF (allocstat /= 0) stop "*** Not enough memory ! ***"
164  n=0
165  ELSE
166  n=dst(i)%nelems
167  ALLOCATE(celems(n), stat=allocstat)
168  DO j=1,n
169  celems(j)%j=dst(i)%elems(j)%j
170  celems(j)%k=dst(i)%elems(j)%k
171  celems(j)%v=dst(i)%elems(j)%v
172  ENDDO
173  DEALLOCATE(dst(i)%elems, stat=allocstat)
174  IF (allocstat /= 0) stop "*** Deallocation problem ! ***"
175  ALLOCATE(dst(i)%elems(nsrc+n), stat=allocstat)
176  IF (allocstat /= 0) stop "*** Not enough memory ! ***"
177  DO j=1,n
178  dst(i)%elems(j)%j=celems(j)%j
179  dst(i)%elems(j)%k=celems(j)%k
180  dst(i)%elems(j)%v=celems(j)%v
181  ENDDO
182  DEALLOCATE(celems, stat=allocstat)
183  IF (allocstat /= 0) stop "*** Deallocation problem ! ***"
184  ENDIF
185  r=0
186  DO j=1,ndim
187  DO k=1,ndim
188  IF (abs(src(j,k))>real_eps) THEN
189  r=r+1
190  dst(i)%elems(n+r)%j=j
191  dst(i)%elems(n+r)%k=k
192  dst(i)%elems(n+r)%v=src(j,k)
193  ENDIF
194  ENDDO
195  END DO
196  dst(i)%nelems=nsrc+n
197 
198  END SUBROUTINE add_matc_to_tensor
199 
200  !> Routine to add a matrix to a rank-4 tensor.
201  !> @param i Add to tensor component i,j
202  !> @param j Add to tensor component i,j
203  !> @param src Matrix to add
204  !> @param dst Destination tensor
205  SUBROUTINE add_matc_to_tensor4(i,j,src,dst)
206  INTEGER, INTENT(IN) :: i,j
207  REAL(KIND=8), DIMENSION(ndim,ndim), INTENT(IN) :: src
208  TYPE(coolist4), DIMENSION(ndim), INTENT(INOUT) :: dst
209  TYPE(coolist_elem4), DIMENSION(:), ALLOCATABLE :: celems
210  INTEGER :: k,l,r,n,nsrc,AllocStat
211 
212  nsrc=0
213  DO k=1,ndim
214  DO l=1,ndim
215  IF (abs(src(k,l))>real_eps) nsrc=nsrc+1
216  END DO
217  END DO
218 
219  IF (dst(i)%nelems==0) THEN
220  IF (ALLOCATED(dst(i)%elems)) THEN
221  DEALLOCATE(dst(i)%elems, stat=allocstat)
222  IF (allocstat /= 0) stop "*** Deallocation problem ! ***"
223  ENDIF
224  ALLOCATE(dst(i)%elems(nsrc), stat=allocstat)
225  IF (allocstat /= 0) stop "*** Not enough memory ! ***"
226  n=0
227  ELSE
228  n=dst(i)%nelems
229  ALLOCATE(celems(n), stat=allocstat)
230  DO k=1,n
231  celems(k)%j=dst(i)%elems(k)%j
232  celems(k)%k=dst(i)%elems(k)%k
233  celems(k)%l=dst(i)%elems(k)%l
234  celems(k)%v=dst(i)%elems(k)%v
235  ENDDO
236  DEALLOCATE(dst(i)%elems, stat=allocstat)
237  IF (allocstat /= 0) stop "*** Deallocation problem ! ***"
238  ALLOCATE(dst(i)%elems(nsrc+n), stat=allocstat)
239  IF (allocstat /= 0) stop "*** Not enough memory ! ***"
240  DO k=1,n
241  dst(i)%elems(k)%j=celems(k)%j
242  dst(i)%elems(k)%k=celems(k)%k
243  dst(i)%elems(k)%l=celems(k)%l
244  dst(i)%elems(k)%v=celems(k)%v
245  ENDDO
246  DEALLOCATE(celems, stat=allocstat)
247  IF (allocstat /= 0) stop "*** Deallocation problem ! ***"
248  ENDIF
249  r=0
250  DO k=1,ndim
251  DO l=1,ndim
252  IF (abs(src(k,l))>real_eps) THEN
253  r=r+1
254  dst(i)%elems(n+r)%j=j
255  dst(i)%elems(n+r)%k=k
256  dst(i)%elems(n+r)%l=l
257  dst(i)%elems(n+r)%v=src(k,l)
258  ENDIF
259  ENDDO
260  END DO
261  dst(i)%nelems=nsrc+n
262 
263  END SUBROUTINE add_matc_to_tensor4
264 
265 
266  !> Routine to add a vector to a rank-3 tensor.
267  !> @param j,k Add to tensor component j and k
268  !> @param src Vector to add
269  !> @param dst Destination tensor
270  SUBROUTINE add_vec_jk_to_tensor(j,k,src,dst)
271  INTEGER, INTENT(IN) :: j,k
272  REAL(KIND=8), DIMENSION(ndim), INTENT(IN) :: src
273  TYPE(coolist), DIMENSION(ndim), INTENT(INOUT) :: dst
274  TYPE(coolist_elem), DIMENSION(:), ALLOCATABLE :: celems
275  INTEGER :: i,l,r,n,nsrc,AllocStat
276 
277  DO i=1,ndim
278  nsrc=0
279  IF (abs(src(i))>real_eps) nsrc=1
280  IF (dst(i)%nelems==0) THEN
281  IF (ALLOCATED(dst(i)%elems)) THEN
282  DEALLOCATE(dst(i)%elems, stat=allocstat)
283  IF (allocstat /= 0) stop "*** Deallocation problem ! ***"
284  ENDIF
285  ALLOCATE(dst(i)%elems(nsrc), stat=allocstat)
286  IF (allocstat /= 0) stop "*** Not enough memory ! ***"
287  n=0
288  ELSE
289  n=dst(i)%nelems
290  ALLOCATE(celems(n), stat=allocstat)
291  DO l=1,n
292  celems(l)%j=dst(i)%elems(l)%j
293  celems(l)%k=dst(i)%elems(l)%k
294  celems(l)%v=dst(i)%elems(l)%v
295  ENDDO
296  DEALLOCATE(dst(i)%elems, stat=allocstat)
297  IF (allocstat /= 0) stop "*** Deallocation problem ! ***"
298  ALLOCATE(dst(i)%elems(nsrc+n), stat=allocstat)
299  IF (allocstat /= 0) stop "*** Not enough memory ! ***"
300  DO l=1,n
301  dst(i)%elems(l)%j=celems(l)%j
302  dst(i)%elems(l)%k=celems(l)%k
303  dst(i)%elems(l)%v=celems(l)%v
304  ENDDO
305  DEALLOCATE(celems, stat=allocstat)
306  IF (allocstat /= 0) stop "*** Deallocation problem ! ***"
307  ENDIF
308  r=0
309  IF (abs(src(i))>real_eps) THEN
310  r=r+1
311  dst(i)%elems(n+r)%j=j
312  dst(i)%elems(n+r)%k=k
313  dst(i)%elems(n+r)%v=src(i)
314  ENDIF
315  dst(i)%nelems=nsrc+n
316  END DO
317 
318 
319  END SUBROUTINE add_vec_jk_to_tensor
320 
321  !> Routine to add a vector to a rank-4 tensor plus permutation.
322  !> @param i,k,l Add to tensor component i,k and l
323  !> @param src Vector to add
324  !> @param dst Destination tensor
325  SUBROUTINE add_vec_ikl_to_tensor4_perm(i,k,l,src,dst)
326  INTEGER, INTENT(IN) :: i,k,l
327  REAL(KIND=8), DIMENSION(ndim), INTENT(IN) :: src
328  TYPE(coolist4), DIMENSION(ndim), INTENT(INOUT) :: dst
329  TYPE(coolist_elem4), DIMENSION(:), ALLOCATABLE :: celems
330  INTEGER :: j,ne,r,n,nsrc,AllocStat
331 
332  nsrc=0
333  DO j=1,ndim
334  IF (abs(src(j))>real_eps) nsrc=nsrc+1
335  ENDDO
336  nsrc=nsrc*3
337  IF (dst(i)%nelems==0) THEN
338  IF (ALLOCATED(dst(i)%elems)) THEN
339  DEALLOCATE(dst(i)%elems, stat=allocstat)
340  IF (allocstat /= 0) stop "*** Deallocation problem ! ***"
341  ENDIF
342  ALLOCATE(dst(i)%elems(nsrc), stat=allocstat)
343  IF (allocstat /= 0) stop "*** Not enough memory ! ***"
344  n=0
345  ELSE
346  n=dst(i)%nelems
347  ALLOCATE(celems(n), stat=allocstat)
348  DO ne=1,n
349  celems(ne)%j=dst(i)%elems(ne)%j
350  celems(ne)%k=dst(i)%elems(ne)%k
351  celems(ne)%l=dst(i)%elems(ne)%l
352  celems(ne)%v=dst(i)%elems(ne)%v
353  ENDDO
354  DEALLOCATE(dst(i)%elems, stat=allocstat)
355  IF (allocstat /= 0) stop "*** Deallocation problem ! ***"
356  ALLOCATE(dst(i)%elems(nsrc+n), stat=allocstat)
357  IF (allocstat /= 0) stop "*** Not enough memory ! ***"
358  DO ne=1,n
359  dst(i)%elems(ne)%j=celems(ne)%j
360  dst(i)%elems(ne)%k=celems(ne)%k
361  dst(i)%elems(ne)%l=celems(ne)%l
362  dst(i)%elems(ne)%v=celems(ne)%v
363  ENDDO
364  DEALLOCATE(celems, stat=allocstat)
365  IF (allocstat /= 0) stop "*** Deallocation problem ! ***"
366  ENDIF
367  r=0
368  DO j=1,ndim
369  IF (abs(src(j))>real_eps) THEN
370  r=r+1
371  dst(i)%elems(n+r)%j=j
372  dst(i)%elems(n+r)%k=k
373  dst(i)%elems(n+r)%l=l
374  dst(i)%elems(n+r)%v=src(j)
375  r=r+1
376  dst(i)%elems(n+r)%j=k
377  dst(i)%elems(n+r)%k=l
378  dst(i)%elems(n+r)%l=j
379  dst(i)%elems(n+r)%v=src(j)
380  r=r+1
381  dst(i)%elems(n+r)%j=l
382  dst(i)%elems(n+r)%k=j
383  dst(i)%elems(n+r)%l=k
384  dst(i)%elems(n+r)%v=src(j)
385  ENDIF
386  ENDDO
387  dst(i)%nelems=nsrc+n
388  END SUBROUTINE add_vec_ikl_to_tensor4_perm
389 
390  !> Routine to add a vector to a rank-4 tensor.
391  !> @param i,k,l Add to tensor component i,k and l
392  !> @param src Vector to add
393  !> @param dst Destination tensor
394  SUBROUTINE add_vec_ikl_to_tensor4(i,k,l,src,dst)
395  INTEGER, INTENT(IN) :: i,k,l
396  REAL(KIND=8), DIMENSION(ndim), INTENT(IN) :: src
397  TYPE(coolist4), DIMENSION(ndim), INTENT(INOUT) :: dst
398  TYPE(coolist_elem4), DIMENSION(:), ALLOCATABLE :: celems
399  INTEGER :: j,ne,r,n,nsrc,AllocStat
400 
401  nsrc=0
402  DO j=1,ndim
403  IF (abs(src(j))>real_eps) nsrc=nsrc+1
404  ENDDO
405 
406  IF (dst(i)%nelems==0) THEN
407  IF (ALLOCATED(dst(i)%elems)) THEN
408  DEALLOCATE(dst(i)%elems, stat=allocstat)
409  IF (allocstat /= 0) stop "*** Deallocation problem ! ***"
410  ENDIF
411  ALLOCATE(dst(i)%elems(nsrc), stat=allocstat)
412  IF (allocstat /= 0) stop "*** Not enough memory ! ***"
413  n=0
414  ELSE
415  n=dst(i)%nelems
416  ALLOCATE(celems(n), stat=allocstat)
417  DO ne=1,n
418  celems(ne)%j=dst(i)%elems(ne)%j
419  celems(ne)%k=dst(i)%elems(ne)%k
420  celems(ne)%l=dst(i)%elems(ne)%l
421  celems(ne)%v=dst(i)%elems(ne)%v
422  ENDDO
423  DEALLOCATE(dst(i)%elems, stat=allocstat)
424  IF (allocstat /= 0) stop "*** Deallocation problem ! ***"
425  ALLOCATE(dst(i)%elems(nsrc+n), stat=allocstat)
426  IF (allocstat /= 0) stop "*** Not enough memory ! ***"
427  DO ne=1,n
428  dst(i)%elems(ne)%j=celems(ne)%j
429  dst(i)%elems(ne)%k=celems(ne)%k
430  dst(i)%elems(ne)%l=celems(ne)%l
431  dst(i)%elems(ne)%v=celems(ne)%v
432  ENDDO
433  DEALLOCATE(celems, stat=allocstat)
434  IF (allocstat /= 0) stop "*** Deallocation problem ! ***"
435  ENDIF
436  r=0
437  DO j=1,ndim
438  IF (abs(src(j))>real_eps) THEN
439  r=r+1
440  dst(i)%elems(n+r)%j=j
441  dst(i)%elems(n+r)%k=k
442  dst(i)%elems(n+r)%l=l
443  dst(i)%elems(n+r)%v=src(j)
444  ENDIF
445  ENDDO
446  dst(i)%nelems=nsrc+n
447  END SUBROUTINE add_vec_ikl_to_tensor4
448 
449  !> Routine to add a vector to a rank-4 tensor.
450  !> @param i,j,k Add to tensor component i,j and k
451  !> @param src Vector to add
452  !> @param dst Destination tensor
453  SUBROUTINE add_vec_ijk_to_tensor4(i,j,k,src,dst)
454  INTEGER, INTENT(IN) :: i,j,k
455  REAL(KIND=8), DIMENSION(ndim), INTENT(IN) :: src
456  TYPE(coolist4), DIMENSION(ndim), INTENT(INOUT) :: dst
457  TYPE(coolist_elem4), DIMENSION(:), ALLOCATABLE :: celems
458  INTEGER :: l,ne,r,n,nsrc,AllocStat
459 
460  nsrc=0
461  DO l=1,ndim
462  IF (abs(src(l))>real_eps) nsrc=nsrc+1
463  ENDDO
464 
465  IF (dst(i)%nelems==0) THEN
466  IF (ALLOCATED(dst(i)%elems)) THEN
467  DEALLOCATE(dst(i)%elems, stat=allocstat)
468  IF (allocstat /= 0) stop "*** Deallocation problem ! ***"
469  ENDIF
470  ALLOCATE(dst(i)%elems(nsrc), stat=allocstat)
471  IF (allocstat /= 0) stop "*** Not enough memory ! ***"
472  n=0
473  ELSE
474  n=dst(i)%nelems
475  ALLOCATE(celems(n), stat=allocstat)
476  DO ne=1,n
477  celems(ne)%j=dst(i)%elems(ne)%j
478  celems(ne)%k=dst(i)%elems(ne)%k
479  celems(ne)%l=dst(i)%elems(ne)%l
480  celems(ne)%v=dst(i)%elems(ne)%v
481  ENDDO
482  DEALLOCATE(dst(i)%elems, stat=allocstat)
483  IF (allocstat /= 0) stop "*** Deallocation problem ! ***"
484  ALLOCATE(dst(i)%elems(nsrc+n), stat=allocstat)
485  IF (allocstat /= 0) stop "*** Not enough memory ! ***"
486  DO ne=1,n
487  dst(i)%elems(ne)%j=celems(ne)%j
488  dst(i)%elems(ne)%k=celems(ne)%k
489  dst(i)%elems(ne)%l=celems(ne)%l
490  dst(i)%elems(ne)%v=celems(ne)%v
491  ENDDO
492  DEALLOCATE(celems, stat=allocstat)
493  IF (allocstat /= 0) stop "*** Deallocation problem ! ***"
494  ENDIF
495  r=0
496  DO l=1,ndim
497  IF (abs(src(l))>real_eps) THEN
498  r=r+1
499  dst(i)%elems(n+r)%j=j
500  dst(i)%elems(n+r)%k=k
501  dst(i)%elems(n+r)%l=l
502  dst(i)%elems(n+r)%v=src(l)
503  ENDIF
504  ENDDO
505  dst(i)%nelems=nsrc+n
506  END SUBROUTINE add_vec_ijk_to_tensor4
507 
508 
509  !> Routine to convert a matrix to a rank-3 tensor.
510  !> @param src Source matrix
511  !> @param dst Destination tensor
512  !> @remark The destination tensor have to be an empty tensor, i.e. with unallocated list of elements and nelems set to 0.
513  !> @remark The k component will be set to 0.
514  SUBROUTINE mat_to_coo(src,dst)
515  REAL(KIND=8), DIMENSION(0:ndim,0:ndim), INTENT(IN) :: src
516  TYPE(coolist), DIMENSION(ndim), INTENT(OUT) :: dst
517  INTEGER :: i,j,n,AllocStat
518  DO i=1,ndim
519  n=0
520  DO j=1,ndim
521  IF (abs(src(i,j))>real_eps) n=n+1
522  ENDDO
523  IF (n/=0) THEN
524  IF (dst(i)%nelems/=0) stop "*** mat_to_coo : Destination coolist not empty ! ***"
525  ALLOCATE(dst(i)%elems(n), stat=allocstat)
526  IF (allocstat /= 0) stop "*** Not enough memory ! ***"
527  n=0
528  DO j=1,ndim
529  IF (abs(src(i,j))>real_eps) THEN
530  n=n+1
531  dst(i)%elems(n)%j=j
532  dst(i)%elems(n)%k=0
533  dst(i)%elems(n)%v=src(i,j)
534  ENDIF
535  ENDDO
536  ENDIF
537  dst(i)%nelems=n
538  ENDDO
539  END SUBROUTINE mat_to_coo
540 
541 
542  !> Routine to convert a rank-3 tensor from matrix to coolist representation.
543  !> @param src Source matrix
544  !> @param dst Destination coolist
545  !> @remark The destination coolist have to be an empty one, i.e. with unallocated list of elements and nelems set to 0.
546  SUBROUTINE tensor_to_coo(src,dst)
547  REAL(KIND=8), DIMENSION(ndim,0:ndim,0:ndim), INTENT(IN) :: src
548  TYPE(coolist), DIMENSION(ndim), INTENT(OUT) :: dst
549  INTEGER :: i,j,k,n,AllocStat
550 
551  DO i=1,ndim
552  n=0
553  DO j=0,ndim
554  DO k=0,ndim
555  IF (abs(src(i,j,k))>real_eps) n=n+1
556  ENDDO
557  ENDDO
558  IF (n/=0) THEN
559  IF (dst(i)%nelems/=0) stop "*** tensor_to_coo : Destination coolist not empty ! ***"
560  ALLOCATE(dst(i)%elems(n), stat=allocstat)
561  IF (allocstat /= 0) stop "*** Not enough memory ! ***"
562  n=0
563  DO j=0,ndim
564  DO k=0,ndim
565  IF (abs(src(i,j,k))>real_eps) THEN
566  n=n+1
567  dst(i)%elems(n)%j=j
568  dst(i)%elems(n)%k=k
569  dst(i)%elems(n)%v=src(i,j,k)
570  ENDIF
571  ENDDO
572  ENDDO
573  ENDIF
574  dst(i)%nelems=n
575  ENDDO
576  END SUBROUTINE tensor_to_coo
577 
578  !> Routine to convert a rank-4 tensor from matrix to coolist representation.
579  !> @param src Source matrix
580  !> @param dst Destination coolist
581  !> @remark The destination coolist have to be an empty one, i.e. with unallocated list of elements and nelems set to 0.
582  SUBROUTINE tensor4_to_coo4(src,dst)
583  REAL(KIND=8), DIMENSION(ndim,0:ndim,0:ndim,0:ndim), INTENT(IN) :: src
584  TYPE(coolist4), DIMENSION(ndim), INTENT(OUT) :: dst
585  INTEGER :: i,j,k,l,n,AllocStat
586 
587  DO i=1,ndim
588  n=0
589  DO j=0,ndim
590  DO k=0,ndim
591  DO l=0,ndim
592  IF (abs(src(i,j,k,l))>real_eps) n=n+1
593  ENDDO
594  ENDDO
595  ENDDO
596  IF (n/=0) THEN
597  IF (dst(i)%nelems/=0) stop "*** tensor_to_coo : Destination coolist not empty ! ***"
598  ALLOCATE(dst(i)%elems(n), stat=allocstat)
599  IF (allocstat /= 0) stop "*** Not enough memory ! ***"
600  n=0
601  DO j=0,ndim
602  DO k=0,ndim
603  DO l=0,ndim
604  IF (abs(src(i,j,k,l))>real_eps) THEN
605  n=n+1
606  dst(i)%elems(n)%j=j
607  dst(i)%elems(n)%k=k
608  dst(i)%elems(n)%l=l
609  dst(i)%elems(n)%v=src(i,j,k,l)
610  ENDIF
611  ENDDO
612  ENDDO
613  ENDDO
614  ENDIF
615  dst(i)%nelems=n
616  ENDDO
617  END SUBROUTINE tensor4_to_coo4
618 
619  !> Routine to print a rank 3 tensor coolist.
620  !> @param t coolist to print
621  SUBROUTINE print_tensor(t)
622  USE util, only: str
623  TYPE(coolist), DIMENSION(ndim), INTENT(IN) :: t
624  INTEGER :: i,n,j,k
625  DO i=1,ndim
626  DO n=1,t(i)%nelems
627  j=t(i)%elems(n)%j
628  k=t(i)%elems(n)%k
629  IF( abs(t(i)%elems(n)%v) .GE. real_eps) THEN
630  write(*,"(A,ES12.5)") "tensor["//trim(str(i))//"]["//trim(str(j)) &
631  &//"]["//trim(str(k))//"] = ",t(i)%elems(n)%v
632  END IF
633  END DO
634  END DO
635  END SUBROUTINE print_tensor
636 
637  !> Routine to print a rank-4 tensor coolist.
638  !> @param t coolist to print
639  SUBROUTINE print_tensor4(t)
640  USE util, only: str
641  TYPE(coolist4), DIMENSION(ndim), INTENT(IN) :: t
642  INTEGER :: i,n,j,k,l
643  DO i=1,ndim
644  DO n=1,t(i)%nelems
645  j=t(i)%elems(n)%j
646  k=t(i)%elems(n)%k
647  l=t(i)%elems(n)%l
648  IF( abs(t(i)%elems(n)%v) .GE. real_eps) THEN
649  write(*,"(A,ES12.5)") "tensor["//trim(str(i))//"]["//trim(str(j)) &
650  &//"]["//trim(str(k))//"]["//trim(str(l))//"] = ",t(i)%elems(n)%v
651  END IF
652  END DO
653  END DO
654  END SUBROUTINE print_tensor4
655 
656 
657  !> Sparse multiplication of a rank-3 tensor coolist with two vectors: \f${\displaystyle \sum_{j,k=0}^{ndim}} \mathcal{T}_{i,j,k} \, a_j \,b_k\f$.
658  !> @param coolist_ijk a coolist (sparse tensor) of which index
659  !> 2 and 3 will be contracted.
660  !> @param arr_j the vector to be contracted with index 2 of coolist_ijk
661  !> @param arr_k the vector to be contracted with index 3 of coolist_ijk
662  !> @param res vector (buffer) to store the result of the contraction
663  !> @remark Note that it is NOT safe to pass `arr_j`/`arr_k` as a result buffer,
664  !> as this operation does multiple passes.
665  SUBROUTINE sparse_mul3(coolist_ijk, arr_j, arr_k, res)
666  TYPE(coolist), DIMENSION(ndim), INTENT(IN):: coolist_ijk
667  REAL(KIND=8), DIMENSION(0:ndim), INTENT(IN) :: arr_j, arr_k
668  REAL(KIND=8), DIMENSION(0:ndim), INTENT(OUT) :: res
669  INTEGER :: i,j,k,n
670  res=0.d0
671  DO i=1,ndim
672  DO n=1,coolist_ijk(i)%nelems
673  j=coolist_ijk(i)%elems(n)%j
674  k=coolist_ijk(i)%elems(n)%k
675  res(i) = res(i) + coolist_ijk(i)%elems(n)%v * arr_j(j)*arr_k(k)
676  END DO
677  END DO
678  END SUBROUTINE sparse_mul3
679 
680  !> Sparse multiplication of a rank-3 tensor coolist with a vector:
681  !> \f${\displaystyle \sum_{k=0}^{ndim}} \mathcal{T}_{i,j,k} \, b_k\f$.
682  !> Its output is a matrix.
683  !> @param coolist_ijk a coolist (sparse tensor) of which index k will be contracted.
684  !> @param arr_k the vector to be contracted with index k of coolist_ijk
685  !> @param res matrix (buffer) to store the result of the contraction
686  !> @remark Note that it is NOT safe to pass `arr_k` as a result buffer,
687  !> as this operation does multiple passes.
688  SUBROUTINE sparse_mul3_mat(coolist_ijk, arr_k, res)
689  TYPE(coolist), DIMENSION(ndim), INTENT(IN):: coolist_ijk
690  REAL(KIND=8), DIMENSION(0:ndim), INTENT(IN) :: arr_k
691  REAL(KIND=8), DIMENSION(ndim,ndim), INTENT(OUT) :: res
692  INTEGER :: i,j,k,n
693  res=0.d0
694  DO i=1,ndim
695  DO n=1,coolist_ijk(i)%nelems
696  j=coolist_ijk(i)%elems(n)%j
697  IF (j /= 0) THEN
698  k=coolist_ijk(i)%elems(n)%k
699  res(i,j) = res(i,j) + coolist_ijk(i)%elems(n)%v * arr_k(k)
700  ENDIF
701  END DO
702  END DO
703  END SUBROUTINE sparse_mul3_mat
704 
705 
706  !> Sparse multiplication of a rank-4 tensor coolist with three vectors: \f${\displaystyle \sum_{j,k,l=0}^{ndim}} \mathcal{T}_{i,j,k,l} \, a_j \,b_k \, c_l \f$.
707  !> @param coolist_ijkl a coolist (sparse tensor) of which index j, k and l will be contracted.
708  !> @param arr_j the vector to be contracted with index j of coolist_ijkl
709  !> @param arr_k the vector to be contracted with index k of coolist_ijkl
710  !> @param arr_l the vector to be contracted with index l of coolist_ijkl
711  !> @param res vector (buffer) to store the result of the contraction
712  !> @remark Note that it is NOT safe to pass `arr_j`/`arr_k`/`arr_l` as a result buffer,
713  !> as this operation does multiple passes.
714  SUBROUTINE sparse_mul4(coolist_ijkl, arr_j, arr_k, arr_l, res)
715  TYPE(coolist4), DIMENSION(ndim), INTENT(IN):: coolist_ijkl
716  REAL(KIND=8), DIMENSION(0:ndim), INTENT(IN) :: arr_j, arr_k, arr_l
717  REAL(KIND=8), DIMENSION(0:ndim), INTENT(OUT) :: res
718  INTEGER :: i,j,k,n,l
719  res=0.d0
720  DO i=1,ndim
721  DO n=1,coolist_ijkl(i)%nelems
722  j=coolist_ijkl(i)%elems(n)%j
723  k=coolist_ijkl(i)%elems(n)%k
724  l=coolist_ijkl(i)%elems(n)%l
725  res(i) = res(i) + coolist_ijkl(i)%elems(n)%v * arr_j(j)*arr_k(k)*arr_l(l)
726  END DO
727  END DO
728  END SUBROUTINE sparse_mul4
729 
730  !> Sparse multiplication of a tensor with two vectors: \f${\displaystyle \sum_{k,l=0}^{ndim}} \mathcal{T}_{i,j,k,l} \,b_k \, c_l \f$.
731  !> @param coolist_ijkl a coordinate list (sparse tensor) of which index
732  !> 3 and 4 will be contracted.
733  !> @param arr_k the vector to be contracted with index 3 of coolist_ijkl
734  !> @param arr_l the vector to be contracted with index 4 of coolist_ijkl
735  !> @param res matrix (buffer) to store the result of the contraction
736  !> @remark Note that it is NOT safe to pass `arr_k`/`arr_l` as a result buffer,
737  !> as this operation does multiple passes.
738  SUBROUTINE sparse_mul4_mat(coolist_ijkl, arr_k, arr_l, res)
739  TYPE(coolist4), DIMENSION(ndim), INTENT(IN):: coolist_ijkl
740  REAL(KIND=8), DIMENSION(0:ndim), INTENT(IN) :: arr_k, arr_l
741  REAL(KIND=8), DIMENSION(ndim,ndim), INTENT(OUT) :: res
742  INTEGER :: i,j,k,n,l
743  res=0.d0
744  DO i=1,ndim
745  DO n=1,coolist_ijkl(i)%nelems
746  j=coolist_ijkl(i)%elems(n)%j
747  IF (j /= 0) THEN
748  k=coolist_ijkl(i)%elems(n)%k
749  l=coolist_ijkl(i)%elems(n)%l
750  res(i,j) = res(i,j) + coolist_ijkl(i)%elems(n)%v * arr_k(k) * arr_l(l)
751  ENDIF
752  END DO
753  END DO
754  END SUBROUTINE sparse_mul4_mat
755 
756 
757  !> Sparse multiplication of two tensors to determine the Jacobian:
758  !> \f[J_{i,j} = {\displaystyle \sum_{k=0}^{ndim}} \left( \mathcal{T}_{i,j,k} + \mathcal{T}_{i,k,j} \right) \, a_k.\f]
759  !> It's implemented slightly differently: for every \f$\mathcal{T}_{i,j,k}\f$, we add to \f$J_{i,j}\f$ as follows:
760  !> \f[J_{i,j} = J_{i,j} + \mathcal{T}_{i,j,k} \, a_k \\ J_{i,k} = J_{i,k} + \mathcal{T}_{i,j,k} \, a_j\f]
761  !> This version return a coolist (sparse tensor).
762  !> @param coolist_ijk a coordinate list (sparse tensor) of which index
763  !> 2 or 3 will be contracted.
764  !> @param arr_j the vector to be contracted with index 2 and then index 3 of ffi_coo_ijk
765  !> @param jcoo_ij a coolist (sparse tensor) to store the result of the contraction
766  SUBROUTINE jsparse_mul(coolist_ijk, arr_j, jcoo_ij)
767  TYPE(coolist), DIMENSION(ndim), INTENT(IN):: coolist_ijk
768  TYPE(coolist), DIMENSION(ndim), INTENT(OUT):: jcoo_ij
769  REAL(KIND=8), DIMENSION(0:ndim), INTENT(IN) :: arr_j
770  REAL(KIND=8) :: v
771  INTEGER :: i,j,k,n,nj,AllocStat
772  DO i=1,ndim
773  IF (jcoo_ij(i)%nelems/=0) stop "*** jsparse_mul : Destination coolist not empty ! ***"
774  nj=2*coolist_ijk(i)%nelems
775  ALLOCATE(jcoo_ij(i)%elems(nj), stat=allocstat)
776  IF (allocstat /= 0) stop "*** Not enough memory ! ***"
777  nj=0
778  DO n=1,coolist_ijk(i)%nelems
779  j=coolist_ijk(i)%elems(n)%j
780  k=coolist_ijk(i)%elems(n)%k
781  v=coolist_ijk(i)%elems(n)%v
782  IF (j /=0) THEN
783  nj=nj+1
784  jcoo_ij(i)%elems(nj)%j=j
785  jcoo_ij(i)%elems(nj)%k=0
786  jcoo_ij(i)%elems(nj)%v=v*arr_j(k)
787  END IF
788 
789  IF (k /=0) THEN
790  nj=nj+1
791  jcoo_ij(i)%elems(nj)%j=k
792  jcoo_ij(i)%elems(nj)%k=0
793  jcoo_ij(i)%elems(nj)%v=v*arr_j(j)
794  END IF
795  END DO
796  jcoo_ij(i)%nelems=nj
797  END DO
798  END SUBROUTINE jsparse_mul
799 
800  !> Sparse multiplication of two tensors to determine the Jacobian:
801  !> \f[J_{i,j} = {\displaystyle \sum_{k=0}^{ndim}} \left( \mathcal{T}_{i,j,k} + \mathcal{T}_{i,k,j} \right) \, a_k.\f]
802  !> It's implemented slightly differently: for every \f$\mathcal{T}_{i,j,k}\f$, we add to \f$J_{i,j}\f$ as follows:
803  !> \f[J_{i,j} = J_{i,j} + \mathcal{T}_{i,j,k} \, a_k \\ J_{i,k} = J_{i,k} + \mathcal{T}_{i,j,k} \, a_j\f]
804  !> This version return a matrix.
805  !> @param coolist_ijk a coordinate list (sparse tensor) of which index
806  !> 2 or 3 will be contracted.
807  !> @param arr_j the vector to be contracted with index 2 and then index 3 of ffi_coo_ijk
808  !> @param jcoo_ij a matrix to store the result of the contraction
809  SUBROUTINE jsparse_mul_mat(coolist_ijk, arr_j, jcoo_ij)
810  TYPE(coolist), DIMENSION(ndim), INTENT(IN):: coolist_ijk
811  REAL(KIND=8), DIMENSION(ndim,ndim), INTENT(OUT):: jcoo_ij
812  REAL(KIND=8), DIMENSION(0:ndim), INTENT(IN) :: arr_j
813  REAL(KIND=8) :: v
814  INTEGER :: i,j,k,n
815  jcoo_ij=0.d0
816  DO i=1,ndim
817  DO n=1,coolist_ijk(i)%nelems
818  j=coolist_ijk(i)%elems(n)%j
819  k=coolist_ijk(i)%elems(n)%k
820  v=coolist_ijk(i)%elems(n)%v
821  IF (j /=0) jcoo_ij(i,j)=jcoo_ij(i,j)+v*arr_j(k)
822  IF (k /=0) jcoo_ij(i,k)=jcoo_ij(i,k)+v*arr_j(j)
823  END DO
824  END DO
825  END SUBROUTINE jsparse_mul_mat
826 
827  !> Sparse multiplication of a 3d sparse tensor with a vectors: \f${\displaystyle \sum_{j=0}^{ndim}} \mathcal{T}_{i,j,k} \, a_j \f$.
828  !> @param coolist_ijk a coordinate list (sparse tensor) of which index
829  !> 2 will be contracted.
830  !> @param arr_j the vector to be contracted with index 2 of coolist_ijk
831  !> @param res vector (buffer) to store the result of the contraction
832  !> @remark Note that it is NOT safe to pass `arr_j` as a result buffer,
833  !> as this operation does multiple passes.
834  SUBROUTINE sparse_mul2_j(coolist_ijk, arr_j, res)
835  TYPE(coolist), DIMENSION(ndim), INTENT(IN):: coolist_ijk
836  REAL(KIND=8), DIMENSION(0:ndim), INTENT(IN) :: arr_j
837  REAL(KIND=8), DIMENSION(0:ndim), INTENT(OUT) :: res
838  INTEGER :: i,j,n
839  res=0.d0
840  DO i=1,ndim
841  DO n=1,coolist_ijk(i)%nelems
842  j=coolist_ijk(i)%elems(n)%j
843  res(i) = res(i) + coolist_ijk(i)%elems(n)%v * arr_j(j)
844  END DO
845  END DO
846  END SUBROUTINE sparse_mul2_j
847 
848  !> Sparse multiplication of a rank-3 sparse tensor coolist with a vector: \f${\displaystyle \sum_{k=0}^{ndim}} \mathcal{T}_{i,j,k} \, a_k \f$.
849  !> @param coolist_ijk a coordinate list (sparse tensor) of which index
850  !> k will be contracted.
851  !> @param arr_k the vector to be contracted with index k of coolist_ijk
852  !> @param res vector (buffer) to store the result of the contraction
853  !> @remark Note that it is NOT safe to pass `arr_k` as a result buffer,
854  !> as this operation does multiple passes.
855  SUBROUTINE sparse_mul2_k(coolist_ijk, arr_k, res)
856  TYPE(coolist), DIMENSION(ndim), INTENT(IN):: coolist_ijk
857  REAL(KIND=8), DIMENSION(0:ndim), INTENT(IN) :: arr_k
858  REAL(KIND=8), DIMENSION(0:ndim), INTENT(OUT) :: res
859  INTEGER :: i,k,n
860  res=0.d0
861  DO i=1,ndim
862  DO n=1,coolist_ijk(i)%nelems
863  k=coolist_ijk(i)%elems(n)%k
864  res(i) = res(i) + coolist_ijk(i)%elems(n)%v * arr_k(k)
865  END DO
866  END DO
867  END SUBROUTINE sparse_mul2_k
868 
869 
870  !> Routine to simplify a coolist (sparse tensor). For each index \f$i\f$, it upper triangularize the matrix
871  !> \f[\mathcal{T}_{i,j,k} \qquad 0 \leq j,k \leq ndim.\f]
872  !> @param tensor a coordinate list (sparse tensor) which will be simplified.
873  SUBROUTINE simplify(tensor)
874  TYPE(coolist), DIMENSION(ndim), INTENT(INOUT):: tensor
875  INTEGER :: i,j,k
876  INTEGER :: li,lii,liii,n
877  DO i= 1,ndim
878  n=tensor(i)%nelems
879  DO li=n,2,-1
880  j=tensor(i)%elems(li)%j
881  k=tensor(i)%elems(li)%k
882  DO lii=li-1,1,-1
883  IF ((j==tensor(i)%elems(lii)%j).AND.(k==tensor(i)%elems(lii)%k)) THEN
884  ! Found another entry with the same i,j,k: merge both into
885  ! the one listed first (of those two).
886  tensor(i)%elems(lii)%v=tensor(i)%elems(lii)%v+tensor(i)%elems(li)%v
887  ! Shift the rest of the items one place down.
888  DO liii=li+1,n
889  tensor(i)%elems(liii-1)%j=tensor(i)%elems(liii)%j
890  tensor(i)%elems(liii-1)%k=tensor(i)%elems(liii)%k
891  tensor(i)%elems(liii-1)%v=tensor(i)%elems(liii)%v
892  END DO
893  tensor(i)%nelems=tensor(i)%nelems-1
894  ! Here we should stop because the li no longer points to the
895  ! original i,j,k element
896  EXIT
897  ENDIF
898  ENDDO
899  ENDDO
900  n=tensor(i)%nelems
901  DO li=1,n
902  ! Clear new "almost" zero entries and shift rest of the items one place down.
903  ! Make sure not to skip any entries while shifting!
904  DO WHILE (abs(tensor(i)%elems(li)%v) < real_eps)
905  DO liii=li+1,n
906  tensor(i)%elems(liii-1)%j=tensor(i)%elems(liii)%j
907  tensor(i)%elems(liii-1)%k=tensor(i)%elems(liii)%k
908  tensor(i)%elems(liii-1)%v=tensor(i)%elems(liii)%v
909  ENDDO
910  tensor(i)%nelems=tensor(i)%nelems-1
911  ENDDO
912  ENDDO
913 
914  ENDDO
915  END SUBROUTINE simplify
916 
917 
918  !> Routine to convert a rank-3 tensor coolist component into a matrix with i and k indices.
919  !> @param src Source tensor
920  !> @param dst Destination matrix
921  SUBROUTINE coo_to_mat_ik(src,dst)
922  TYPE(coolist), DIMENSION(ndim), INTENT(IN) :: src
923  REAL(KIND=8), DIMENSION(ndim,ndim), INTENT(OUT) :: dst
924  INTEGER :: i,n
925 
926  dst=0.d0
927  DO i=1,ndim
928  DO n=1,src(i)%nelems
929  dst(i,src(i)%elems(n)%k)=src(i)%elems(n)%v
930  ENDDO
931  ENDDO
932  END SUBROUTINE coo_to_mat_ik
933 
934  !> Routine to convert a rank-3 tensor coolist component into a matrix with i and j indices.
935  !> @param src Source tensor
936  !> @param dst Destination matrix
937  SUBROUTINE coo_to_mat_ij(src,dst)
938  TYPE(coolist), DIMENSION(ndim), INTENT(IN) :: src
939  REAL(KIND=8), DIMENSION(ndim,ndim), INTENT(OUT) :: dst
940  INTEGER :: i,n
941 
942  dst=0.d0
943  DO i=1,ndim
944  DO n=1,src(i)%nelems
945  dst(i,src(i)%elems(n)%j)=src(i)%elems(n)%v
946  ENDDO
947  ENDDO
948  END SUBROUTINE coo_to_mat_ij
949 
950  ! SUBROUTINE tensor_perm_ij(t)
951  ! TYPE(coolist), DIMENSION(ndim), INTENT(INOUT) :: t
952  ! INTEGER :: i,j,k,n
953 
954  ! DO i=1,ndim
955  ! DO n=1,t(i)%nelems
956  ! j=t(i)%elems(n)%j
957  ! k=t(i)%elems(n)%k
958 
959  ! t(i)%elems(n)%v
960  ! ENDDO
961  ! ENDDO
962  ! END SUBROUTINE tensor_perm_ij
963 
964 !!! not so cool
965 
966  !> Routine to convert a rank-3 tensor coolist component into a matrix.
967  !> @param i Component to convert
968  !> @param src Source tensor
969  !> @param dst Destination matrix
970  SUBROUTINE coo_to_mat_i(i,src,dst)
971  INTEGER, INTENT(IN) :: i
972  TYPE(coolist), DIMENSION(ndim), INTENT(IN) :: src
973  REAL(KIND=8), DIMENSION(ndim,ndim), INTENT(OUT) :: dst
974  INTEGER :: n
975 
976  dst=0.d0
977  DO n=1,src(i)%nelems
978  dst(src(i)%elems(n)%j,src(i)%elems(n)%k)=src(i)%elems(n)%v
979  ENDDO
980  END SUBROUTINE coo_to_mat_i
981 
982  !> Routine to convert a rank-3 tensor coolist component into a vector.
983  !> @param j Component j,k to convert
984  !> @param k Component j,k to convert
985  !> @param src Source tensor
986  !> @param dst Destination vector
987  SUBROUTINE coo_to_vec_jk(j,k,src,dst)
988  INTEGER, INTENT(IN) :: j,k
989  TYPE(coolist), DIMENSION(ndim), INTENT(IN) :: src
990  REAL(KIND=8), DIMENSION(ndim), INTENT(OUT) :: dst
991  INTEGER :: i,n
992 
993  dst=0.d0
994  DO i=1,ndim
995  DO n=1,src(i)%nelems
996  IF ((src(i)%elems(n)%j==j).and.(src(i)%elems(n)%k==k)) dst(i)=src(i)%elems(n)%v
997  END DO
998  ENDDO
999  END SUBROUTINE coo_to_vec_jk
1000 
1001 
1002  !> Routine to convert a rank-3 tensor coolist component into a matrix.
1003  !> @param j Component to convert
1004  !> @param src Source tensor
1005  !> @param dst Destination matrix
1006  SUBROUTINE coo_to_mat_j(j,src,dst)
1007  INTEGER, INTENT(IN) :: j
1008  TYPE(coolist), DIMENSION(ndim), INTENT(IN) :: src
1009  REAL(KIND=8), DIMENSION(ndim,ndim), INTENT(OUT) :: dst
1010  INTEGER :: i,n
1011 
1012  dst=0.d0
1013  DO i=1,ndim
1014  DO n=1,src(i)%nelems
1015  IF (src(i)%elems(n)%j==j) dst(i,src(i)%elems(n)%k)=src(i)%elems(n)%v
1016  ENDDO
1017  END DO
1018  END SUBROUTINE coo_to_mat_j
1019 
1020 
1021  !> Sparse multiplication of a rank-4 tensor coolist with a matrix : \f${\displaystyle \sum_{j,l=0}^{ndim}} \mathcal{T}_{i,j,k,l} \, m_{j,l} \f$.
1022  !> @param coolist_ijkl a coolist (sparse tensor) of which index j and l will be contracted.
1023  !> @param mat_jl the matrix to be contracted with indices j and l of coolist_ijkl
1024  !> @param res matrix (buffer) to store the result of the contraction
1025  !> @remark Note that it is NOT safe to pass `mat_jl` as a result buffer,
1026  !> as this operation does multiple passes.
1027  SUBROUTINE sparse_mul4_with_mat_jl(coolist_ijkl,mat_jl,res)
1028  TYPE(coolist4), DIMENSION(ndim), INTENT(IN):: coolist_ijkl
1029  REAL(KIND=8), DIMENSION(ndim,ndim), INTENT(IN) :: mat_jl
1030  REAL(KIND=8), DIMENSION(ndim,ndim), INTENT(OUT) :: res
1031  INTEGER i,j,k,l,n
1032 
1033  res=0.d0
1034  DO i=1,ndim
1035  DO n=1,coolist_ijkl(i)%nelems
1036  j=coolist_ijkl(i)%elems(n)%j
1037  k=coolist_ijkl(i)%elems(n)%k
1038  l=coolist_ijkl(i)%elems(n)%l
1039 
1040  res(i,k) = res(i,k) + coolist_ijkl(i)%elems(n)%v * mat_jl(j,l)
1041  ENDDO
1042  END DO
1043 
1044  END SUBROUTINE sparse_mul4_with_mat_jl
1045 
1046  !> Sparse multiplication of a rank-4 tensor coolist with a matrix : \f${\displaystyle \sum_{j,l=0}^{ndim}} \mathcal{T}_{i,j,k,l} \, m_{k,l} \f$.
1047  !> @param coolist_ijkl a coolist (sparse tensor) of which index k and l will be contracted.
1048  !> @param mat_kl the matrix to be contracted with indices k and l of coolist_ijkl
1049  !> @param res matrix (buffer) to store the result of the contraction
1050  !> @remark Note that it is NOT safe to pass `mat_kl` as a result buffer,
1051  !> as this operation does multiple passes.
1052  SUBROUTINE sparse_mul4_with_mat_kl(coolist_ijkl,mat_kl,res)
1053  TYPE(coolist4), DIMENSION(ndim), INTENT(IN):: coolist_ijkl
1054  REAL(KIND=8), DIMENSION(ndim,ndim), INTENT(IN) :: mat_kl
1055  REAL(KIND=8), DIMENSION(ndim,ndim), INTENT(OUT) :: res
1056  INTEGER i,j,k,l,n
1057 
1058  res=0.d0
1059  DO i=1,ndim
1060  DO n=1,coolist_ijkl(i)%nelems
1061  j=coolist_ijkl(i)%elems(n)%j
1062  k=coolist_ijkl(i)%elems(n)%k
1063  l=coolist_ijkl(i)%elems(n)%l
1064 
1065  res(i,j) = res(i,j) + coolist_ijkl(i)%elems(n)%v * mat_kl(k,l)
1066  ENDDO
1067  END DO
1068 
1069  END SUBROUTINE sparse_mul4_with_mat_kl
1070 
1071  !> Sparse multiplication of a rank-3 tensor coolist with a matrix: \f${\displaystyle \sum_{j,k=0}^{ndim}} \mathcal{T}_{i,j,k} \, m_{j,k}\f$.
1072  !> @param coolist_ijk a coolist (sparse tensor) of which index
1073  !> j and k will be contracted.
1074  !> @param mat_jk the matrix to be contracted with index j and k of coolist_ijk
1075  !> @param res vector (buffer) to store the result of the contraction
1076  !> @remark Note that it is NOT safe to pass `mat_jk` as a result buffer,
1077  !> as this operation does multiple passes.
1078  SUBROUTINE sparse_mul3_with_mat(coolist_ijk,mat_jk,res)
1079  TYPE(coolist), DIMENSION(ndim), INTENT(IN):: coolist_ijk
1080  REAL(KIND=8), DIMENSION(ndim,ndim), INTENT(IN) :: mat_jk
1081  REAL(KIND=8), DIMENSION(0:ndim), INTENT(OUT) :: res
1082  INTEGER i,j,k,n
1083 
1084  res=0.d0
1085  DO i=1,ndim
1086  DO n=1,coolist_ijk(i)%nelems
1087  j=coolist_ijk(i)%elems(n)%j
1088  k=coolist_ijk(i)%elems(n)%k
1089 
1090  res(i) = res(i) + coolist_ijk(i)%elems(n)%v * mat_jk(j,k)
1091  ENDDO
1092  END DO
1093 
1094  END SUBROUTINE sparse_mul3_with_mat
1095 
1096 
1097  !> Routine to convert a matrix to a rank-3 tensor.
1098  !> @param src Source matrix
1099  !> @param dst Destination tensor
1100  !> @remark The destination tensor have to be an empty tensor, i.e. with unallocated list of elements and nelems set to 0.
1101  !> @remark The j component will be set to 0.
1102  SUBROUTINE matc_to_coo(src,dst)
1103  REAL(KIND=8), DIMENSION(ndim,ndim), INTENT(IN) :: src
1104  TYPE(coolist), DIMENSION(ndim), INTENT(OUT) :: dst
1105  INTEGER :: i,j,n,AllocStat
1106  DO i=1,ndim
1107  n=0
1108  DO j=1,ndim
1109  IF (abs(src(i,j))>real_eps) n=n+1
1110  ENDDO
1111  IF (n/=0) THEN
1112  IF (dst(i)%nelems/=0) stop "*** mat_to_coo : Destination coolist not empty ! ***"
1113  ALLOCATE(dst(i)%elems(n), stat=allocstat)
1114  IF (allocstat /= 0) stop "*** Not enough memory ! ***"
1115  n=0
1116  DO j=1,ndim
1117  IF (abs(src(i,j))>real_eps) THEN
1118  n=n+1
1119  dst(i)%elems(n)%j=0
1120  dst(i)%elems(n)%k=j
1121  dst(i)%elems(n)%v=src(i,j)
1122  ENDIF
1123  ENDDO
1124  ENDIF
1125  dst(i)%nelems=n
1126  ENDDO
1127  END SUBROUTINE matc_to_coo
1128 
1129  !> Routine to multiply a rank-3 tensor by a scalar
1130  !> @param s The scalar
1131  !> @param t The tensor
1132  SUBROUTINE scal_mul_coo(s,t)
1133  REAL(KIND=8), INTENT(IN) :: s
1134  TYPE(coolist), DIMENSION(ndim), INTENT(INOUT) :: t
1135  INTEGER :: i,li,n
1136  DO i=1,ndim
1137  n=t(i)%nelems
1138  DO li=1,n
1139  t(i)%elems(li)%v=s*t(i)%elems(li)%v
1140  ENDDO
1141  ENDDO
1142  END SUBROUTINE scal_mul_coo
1143 
1144  !> Test if a rank-3 tensor coolist is empty
1145  !> @param t rank-3 tensor coolist to be tested
1146  FUNCTION tensor_empty(t)
1147  TYPE(coolist), DIMENSION(ndim), INTENT(IN) :: t
1148  LOGICAL :: tensor_empty
1149  INTEGER :: i
1150  tensor_empty=.true.
1151  DO i=1,ndim
1152  IF (t(i)%nelems /= 0) THEN
1153  tensor_empty=.false.
1154  RETURN
1155  ENDIF
1156  END DO
1157  RETURN
1158  END FUNCTION tensor_empty
1159 
1160  !> Test if a rank-4 tensor coolist is empty
1161  !> @param t rank-4 tensor coolist to be tested
1162  FUNCTION tensor4_empty(t)
1163  TYPE(coolist4), DIMENSION(ndim), INTENT(IN) :: t
1164  LOGICAL :: tensor4_empty
1165  INTEGER :: i
1166  tensor4_empty=.true.
1167  DO i=1,ndim
1168  IF (t(i)%nelems /= 0) THEN
1169  tensor4_empty=.false.
1170  RETURN
1171  ENDIF
1172  END DO
1173  RETURN
1174  END FUNCTION tensor4_empty
1175 
1176  !> Load a rank-4 tensor coolist from a file definition
1177  !> @param s Filename of the tensor definition file
1178  !> @param t The loaded coolist
1179  !> @remark The destination tensor have to be an empty tensor, i.e. with unallocated list of elements and nelems set to 0.
1180  SUBROUTINE load_tensor4_from_file(s,t)
1181  CHARACTER (LEN=*), INTENT(IN) :: s
1182  TYPE(coolist4), DIMENSION(ndim), INTENT(OUT) :: t
1183  INTEGER :: i,ir,j,k,l,n,AllocStat
1184  REAL(KIND=8) :: v
1185  OPEN(30,file=s,status='old')
1186  DO i=1,ndim
1187  READ(30,*) ir,n
1188  IF (n /= 0) THEN
1189  ALLOCATE(t(i)%elems(n), stat=allocstat)
1190  IF (allocstat /= 0) stop "*** Not enough memory ! ***"
1191  t(i)%nelems=n
1192  ENDIF
1193  DO n=1,t(i)%nelems
1194  READ(30,*) ir,j,k,l,v
1195  t(i)%elems(n)%j=j
1196  t(i)%elems(n)%k=k
1197  t(i)%elems(n)%l=l
1198  t(i)%elems(n)%v=v
1199  ENDDO
1200  END DO
1201  CLOSE(30)
1202  END SUBROUTINE load_tensor4_from_file
1203 
1204  !> Load a rank-4 tensor coolist from a file definition
1205  !> @param s Destination filename
1206  !> @param t The coolist to write
1207  SUBROUTINE write_tensor4_to_file(s,t)
1208  CHARACTER (LEN=*), INTENT(IN) :: s
1209  TYPE(coolist4), DIMENSION(ndim), INTENT(IN) :: t
1210  INTEGER :: i,j,k,l,n
1211  OPEN(30,file=s)
1212  DO i=1,ndim
1213  WRITE(30,*) i,t(i)%nelems
1214  DO n=1,t(i)%nelems
1215  j=t(i)%elems(n)%j
1216  k=t(i)%elems(n)%k
1217  l=t(i)%elems(n)%l
1218  WRITE(30,*) i,j,k,l,t(i)%elems(n)%v
1219  END DO
1220  END DO
1221  CLOSE(30)
1222  END SUBROUTINE write_tensor4_to_file
1223 
1224 END MODULE tensor
1225 
params::ndim
integer ndim
Number of variables (dimension of the model)
Definition: params.f90:79
tensor::add_matc_to_tensor4
subroutine, public add_matc_to_tensor4(i, j, src, dst)
Routine to add a matrix to a rank-4 tensor.
Definition: tensor.f90:206
util
Utility module.
Definition: util.f90:12
tensor::add_vec_ijk_to_tensor4
subroutine, public add_vec_ijk_to_tensor4(i, j, k, src, dst)
Routine to add a vector to a rank-4 tensor.
Definition: tensor.f90:454
stat
Statistics accumulators.
Definition: stat.f90:14
tensor::add_vec_jk_to_tensor
subroutine, public add_vec_jk_to_tensor(j, k, src, dst)
Routine to add a vector to a rank-3 tensor.
Definition: tensor.f90:271
tensor::load_tensor4_from_file
subroutine, public load_tensor4_from_file(s, t)
Load a rank-4 tensor coolist from a file definition.
Definition: tensor.f90:1181
tensor::tensor4_to_coo4
subroutine, public tensor4_to_coo4(src, dst)
Routine to convert a rank-4 tensor from matrix to coolist representation.
Definition: tensor.f90:583
tensor::simplify
subroutine, public simplify(tensor)
Routine to simplify a coolist (sparse tensor). For each index , it upper triangularize the matrix ...
Definition: tensor.f90:874
tensor::copy_tensor
subroutine, public copy_tensor(src, dst)
Routine to copy a rank-3 tensor.
Definition: tensor.f90:71
tensor::sparse_mul4_with_mat_jl
subroutine, public sparse_mul4_with_mat_jl(coolist_ijkl, mat_jl, res)
Sparse multiplication of a rank-4 tensor coolist with a matrix : .
Definition: tensor.f90:1028
tensor::mat_to_coo
subroutine, public mat_to_coo(src, dst)
Routine to convert a matrix to a rank-3 tensor.
Definition: tensor.f90:515
tensor::scal_mul_coo
subroutine, public scal_mul_coo(s, t)
Routine to multiply a rank-3 tensor by a scalar.
Definition: tensor.f90:1133
tensor::coo_to_mat_i
subroutine, public coo_to_mat_i(i, src, dst)
Routine to convert a rank-3 tensor coolist component into a matrix.
Definition: tensor.f90:971
tensor::sparse_mul3
subroutine, public sparse_mul3(coolist_ijk, arr_j, arr_k, res)
Sparse multiplication of a rank-3 tensor coolist with two vectors: .
Definition: tensor.f90:666
tensor::coo_to_mat_j
subroutine, public coo_to_mat_j(j, src, dst)
Routine to convert a rank-3 tensor coolist component into a matrix.
Definition: tensor.f90:1007
tensor
Tensor utility module.
Definition: tensor.f90:18
tensor::tensor_to_coo
subroutine, public tensor_to_coo(src, dst)
Routine to convert a rank-3 tensor from matrix to coolist representation.
Definition: tensor.f90:547
tensor::coo_to_mat_ij
subroutine, public coo_to_mat_ij(src, dst)
Routine to convert a rank-3 tensor coolist component into a matrix with i and j indices.
Definition: tensor.f90:938
util::str
character(len=20) function, public str(k)
Convert an integer to string.
Definition: util.f90:30
tensor::add_vec_ikl_to_tensor4_perm
subroutine, public add_vec_ikl_to_tensor4_perm(i, k, l, src, dst)
Routine to add a vector to a rank-4 tensor plus permutation.
Definition: tensor.f90:326
tensor::jsparse_mul
subroutine, public jsparse_mul(coolist_ijk, arr_j, jcoo_ij)
Sparse multiplication of two tensors to determine the Jacobian: It&#39;s implemented slightly differentl...
Definition: tensor.f90:767
tensor::add_matc_to_tensor
subroutine, public add_matc_to_tensor(i, src, dst)
Routine to add a matrix to a rank-3 tensor.
Definition: tensor.f90:144
tensor::coolist
Coordinate list. Type used to represent the sparse tensor.
Definition: tensor.f90:38
tensor::tensor_empty
logical function, public tensor_empty(t)
Test if a rank-3 tensor coolist is empty.
Definition: tensor.f90:1147
tensor::sparse_mul4_with_mat_kl
subroutine, public sparse_mul4_with_mat_kl(coolist_ijkl, mat_kl, res)
Sparse multiplication of a rank-4 tensor coolist with a matrix : .
Definition: tensor.f90:1053
tensor::write_tensor4_to_file
subroutine, public write_tensor4_to_file(s, t)
Load a rank-4 tensor coolist from a file definition.
Definition: tensor.f90:1208
tensor::jsparse_mul_mat
subroutine, public jsparse_mul_mat(coolist_ijk, arr_j, jcoo_ij)
Sparse multiplication of two tensors to determine the Jacobian: It&#39;s implemented slightly differentl...
Definition: tensor.f90:810
tensor::sparse_mul3_mat
subroutine, public sparse_mul3_mat(coolist_ijk, arr_k, res)
Sparse multiplication of a rank-3 tensor coolist with a vector: . Its output is a matrix...
Definition: tensor.f90:689
tensor::coo_to_mat_ik
subroutine, public coo_to_mat_ik(src, dst)
Routine to convert a rank-3 tensor coolist component into a matrix with i and k indices.
Definition: tensor.f90:922
tensor::add_to_tensor
subroutine, public add_to_tensor(src, dst)
Routine to add a rank-3 tensor to another one.
Definition: tensor.f90:92
tensor::print_tensor4
subroutine, public print_tensor4(t)
Routine to print a rank-4 tensor coolist.
Definition: tensor.f90:640
tensor::sparse_mul2_j
subroutine, public sparse_mul2_j(coolist_ijk, arr_j, res)
Sparse multiplication of a 3d sparse tensor with a vectors: .
Definition: tensor.f90:835
tensor::coolist4
4d coordinate list. Type used to represent the rank-4 sparse tensor.
Definition: tensor.f90:44
tensor::matc_to_coo
subroutine, public matc_to_coo(src, dst)
Routine to convert a matrix to a rank-3 tensor.
Definition: tensor.f90:1103
tensor::sparse_mul3_with_mat
subroutine, public sparse_mul3_with_mat(coolist_ijk, mat_jk, res)
Sparse multiplication of a rank-3 tensor coolist with a matrix: .
Definition: tensor.f90:1079
tensor::add_vec_ikl_to_tensor4
subroutine, public add_vec_ikl_to_tensor4(i, k, l, src, dst)
Routine to add a vector to a rank-4 tensor.
Definition: tensor.f90:395
tensor::sparse_mul2_k
subroutine, public sparse_mul2_k(coolist_ijk, arr_k, res)
Sparse multiplication of a rank-3 sparse tensor coolist with a vector: .
Definition: tensor.f90:856
params
The model parameters module.
Definition: params.f90:18
tensor::coolist_elem
Coordinate list element type. Elementary elements of the sparse tensors.
Definition: tensor.f90:25
tensor::tensor4_empty
logical function, public tensor4_empty(t)
Test if a rank-4 tensor coolist is empty.
Definition: tensor.f90:1163
tensor::coolist_elem4
4d coordinate list element type. Elementary elements of the 4d sparse tensors.
Definition: tensor.f90:32
tensor::sparse_mul4
subroutine, public sparse_mul4(coolist_ijkl, arr_j, arr_k, arr_l, res)
Sparse multiplication of a rank-4 tensor coolist with three vectors: .
Definition: tensor.f90:715
tensor::real_eps
real(kind=8), parameter real_eps
Parameter to test the equality with zero.
Definition: tensor.f90:50
tensor::sparse_mul4_mat
subroutine, public sparse_mul4_mat(coolist_ijkl, arr_k, arr_l, res)
Sparse multiplication of a tensor with two vectors: .
Definition: tensor.f90:739
tensor::coo_to_vec_jk
subroutine, public coo_to_vec_jk(j, k, src, dst)
Routine to convert a rank-3 tensor coolist component into a vector.
Definition: tensor.f90:988
tensor::print_tensor
subroutine, public print_tensor(t)
Routine to print a rank 3 tensor coolist.
Definition: tensor.f90:622
Generated on Tue Dec 19 2017 15:41:18 by   doxygen 1.8.11