Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2025 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 : ! **************************************************************************************************
8 : MODULE qs_harmonics_atom
9 :
10 : USE basis_set_types, ONLY: get_gto_basis_set,&
11 : gto_basis_set_type
12 : USE kinds, ONLY: dp
13 : USE lebedev, ONLY: lebedev_grid
14 : USE memory_utilities, ONLY: reallocate
15 : USE orbital_pointers, ONLY: indco,&
16 : indso,&
17 : nco,&
18 : ncoset,&
19 : nso,&
20 : nsoset
21 : USE orbital_transformation_matrices, ONLY: orbtramat
22 : USE spherical_harmonics, ONLY: dy_lm,&
23 : y_lm
24 : #include "./base/base_uses.f90"
25 :
26 : IMPLICIT NONE
27 :
28 : PRIVATE
29 :
30 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'qs_harmonics_atom'
31 :
32 : TYPE harmonics_atom_type
33 : INTEGER :: max_s_harm = -1, llmax = -1, &
34 : max_iso_not0 = -1, &
35 : dmax_iso_not0 = -1, &
36 : damax_iso_not0 = -1, &
37 : ngrid = -1
38 : REAL(dp), DIMENSION(:, :), POINTER :: a => NULL(), slm => NULL()
39 : REAL(dp), DIMENSION(:, :, :), POINTER :: dslm => NULL(), dslm_dxyz => NULL()
40 : REAL(dp), DIMENSION(:, :, :), POINTER :: my_CG => NULL()
41 : REAL(dp), DIMENSION(:, :, :, :), POINTER :: my_CG_dxyz => NULL()
42 : REAL(dp), DIMENSION(:, :, :, :), POINTER :: my_CG_dxyz_asym => NULL()
43 : REAL(dp), DIMENSION(:), POINTER :: slm_int => NULL()
44 :
45 : END TYPE harmonics_atom_type
46 :
47 : PUBLIC :: allocate_harmonics_atom, &
48 : create_harmonics_atom, &
49 : deallocate_harmonics_atom, &
50 : get_none0_cg_list
51 :
52 : PUBLIC :: harmonics_atom_type, get_maxl_CG
53 :
54 : INTERFACE get_none0_cg_list
55 : MODULE PROCEDURE get_none0_cg_list3, get_none0_cg_list4
56 : END INTERFACE
57 :
58 : CONTAINS
59 :
60 : ! **************************************************************************************************
61 : !> \brief Allocate a spherical harmonics set for the atom grid.
62 : !> \param harmonics ...
63 : !> \version 1.0
64 : ! **************************************************************************************************
65 2190 : SUBROUTINE allocate_harmonics_atom(harmonics)
66 :
67 : TYPE(harmonics_atom_type), POINTER :: harmonics
68 :
69 2190 : IF (ASSOCIATED(harmonics)) CALL deallocate_harmonics_atom(harmonics)
70 :
71 2190 : ALLOCATE (harmonics)
72 :
73 2190 : harmonics%max_s_harm = 0
74 2190 : harmonics%llmax = 0
75 2190 : harmonics%max_iso_not0 = 0
76 2190 : harmonics%dmax_iso_not0 = 0
77 2190 : harmonics%damax_iso_not0 = 0
78 2190 : harmonics%ngrid = 0
79 :
80 : NULLIFY (harmonics%slm)
81 : NULLIFY (harmonics%dslm)
82 : NULLIFY (harmonics%dslm_dxyz)
83 : NULLIFY (harmonics%slm_int)
84 : NULLIFY (harmonics%my_CG)
85 : NULLIFY (harmonics%my_CG_dxyz)
86 : NULLIFY (harmonics%my_CG_dxyz_asym)
87 : NULLIFY (harmonics%a)
88 :
89 2190 : END SUBROUTINE allocate_harmonics_atom
90 :
91 : ! **************************************************************************************************
92 : !> \brief Deallocate the spherical harmonics set for the atom grid.
93 : !> \param harmonics ...
94 : !> \version 1.0
95 : ! **************************************************************************************************
96 2190 : SUBROUTINE deallocate_harmonics_atom(harmonics)
97 :
98 : TYPE(harmonics_atom_type), POINTER :: harmonics
99 :
100 2190 : IF (ASSOCIATED(harmonics)) THEN
101 :
102 2190 : IF (ASSOCIATED(harmonics%slm)) THEN
103 2182 : DEALLOCATE (harmonics%slm)
104 : END IF
105 :
106 2190 : IF (ASSOCIATED(harmonics%dslm)) THEN
107 2182 : DEALLOCATE (harmonics%dslm)
108 : END IF
109 :
110 2190 : IF (ASSOCIATED(harmonics%dslm_dxyz)) THEN
111 2182 : DEALLOCATE (harmonics%dslm_dxyz)
112 : END IF
113 :
114 2190 : IF (ASSOCIATED(harmonics%slm_int)) THEN
115 2182 : DEALLOCATE (harmonics%slm_int)
116 : END IF
117 :
118 2190 : IF (ASSOCIATED(harmonics%my_CG)) THEN
119 2190 : DEALLOCATE (harmonics%my_CG)
120 : END IF
121 :
122 2190 : IF (ASSOCIATED(harmonics%my_CG_dxyz)) THEN
123 2182 : DEALLOCATE (harmonics%my_CG_dxyz)
124 : END IF
125 :
126 2190 : IF (ASSOCIATED(harmonics%my_CG_dxyz_asym)) THEN
127 2182 : DEALLOCATE (harmonics%my_CG_dxyz_asym)
128 : END IF
129 :
130 2190 : IF (ASSOCIATED(harmonics%a)) THEN
131 2182 : DEALLOCATE (harmonics%a)
132 : END IF
133 :
134 2190 : DEALLOCATE (harmonics)
135 : ELSE
136 : CALL cp_abort(__LOCATION__, &
137 : "The pointer harmonics is not associated and "// &
138 0 : "cannot be deallocated")
139 : END IF
140 :
141 2190 : END SUBROUTINE deallocate_harmonics_atom
142 :
143 : ! **************************************************************************************************
144 : !> \brief ...
145 : !> \param harmonics ...
146 : !> \param my_CG ...
147 : !> \param na ...
148 : !> \param llmax ...
149 : !> \param maxs ...
150 : !> \param max_s_harm ...
151 : !> \param ll ...
152 : !> \param wa ...
153 : !> \param azi ...
154 : !> \param pol ...
155 : !> \note Slight refactoring + OMP parallelized (03.2020 A. Bussy)
156 : ! **************************************************************************************************
157 2182 : SUBROUTINE create_harmonics_atom(harmonics, my_CG, na, llmax, maxs, max_s_harm, ll, wa, azi, pol)
158 :
159 : TYPE(harmonics_atom_type), POINTER :: harmonics
160 : REAL(dp), DIMENSION(:, :, :), POINTER :: my_CG
161 : INTEGER, INTENT(IN) :: na, llmax, maxs, max_s_harm, ll
162 : REAL(dp), DIMENSION(:), INTENT(IN) :: wa, azi, pol
163 :
164 : CHARACTER(len=*), PARAMETER :: routineN = 'create_harmonics_atom'
165 :
166 : INTEGER :: handle, i, ia, ic, is, is1, is2, iso, &
167 : iso1, iso2, l, l1, l2, lx, ly, lz, m, &
168 : m1, m2, n
169 : REAL(dp) :: drx, dry, drz, rx, ry, rz
170 : REAL(dp), DIMENSION(2) :: cin, dylm
171 2182 : REAL(dp), DIMENSION(:), POINTER :: slm_int, y
172 2182 : REAL(dp), DIMENSION(:, :), POINTER :: dc, slm
173 2182 : REAL(dp), DIMENSION(:, :, :), POINTER :: dslm_dxyz
174 :
175 2182 : CALL timeset(routineN, handle)
176 :
177 2182 : NULLIFY (y, slm, dslm_dxyz, dc)
178 :
179 2182 : CPASSERT(ASSOCIATED(harmonics))
180 :
181 2182 : harmonics%max_s_harm = max_s_harm
182 2182 : harmonics%llmax = llmax
183 2182 : harmonics%ngrid = na
184 :
185 2182 : NULLIFY (harmonics%my_CG, harmonics%my_CG_dxyz, harmonics%my_CG_dxyz_asym)
186 2182 : CALL reallocate(harmonics%my_CG, 1, maxs, 1, maxs, 1, max_s_harm)
187 2182 : CALL reallocate(harmonics%my_CG_dxyz, 1, 3, 1, maxs, 1, maxs, 1, max_s_harm)
188 2182 : CALL reallocate(harmonics%my_CG_dxyz_asym, 1, 3, 1, maxs, 1, maxs, 1, max_s_harm)
189 :
190 50684 : DO i = 1, max_s_harm
191 425244 : DO is1 = 1, maxs
192 10374662 : harmonics%my_CG(1:maxs, is1, i) = my_CG(1:maxs, is1, i)
193 : END DO
194 : END DO
195 :
196 : ! allocate and calculate the spherical harmonics LM for this grid
197 : ! and their derivatives
198 2182 : NULLIFY (harmonics%slm, harmonics%dslm, harmonics%dslm_dxyz, harmonics%a, harmonics%slm_int)
199 2182 : CALL reallocate(harmonics%slm, 1, na, 1, max_s_harm)
200 2182 : CALL reallocate(harmonics%dslm, 1, 2, 1, na, 1, maxs)
201 2182 : CALL reallocate(harmonics%dslm_dxyz, 1, 3, 1, na, 1, max_s_harm)
202 2182 : CALL reallocate(harmonics%a, 1, 3, 1, na)
203 2182 : CALL reallocate(harmonics%slm_int, 1, max_s_harm)
204 :
205 : NULLIFY (slm, dslm_dxyz, slm_int)
206 2182 : slm => harmonics%slm
207 2182 : dslm_dxyz => harmonics%dslm_dxyz
208 11618860 : dslm_dxyz = 0.0_dp
209 2182 : slm_int => harmonics%slm_int
210 50684 : slm_int = 0.0_dp
211 :
212 : !$OMP PARALLEL DEFAULT(NONE), &
213 : !$OMP SHARED (slm,dslm_dxyz,slm_int,max_s_harm,ll,lebedev_grid,na,harmonics,wa,indco,orbtramat) &
214 : !$OMP SHARED (nso,nsoset,nco,maxs,indso,ncoset,pol,azi,llmax) &
215 : !$OMP PRIVATE(ia,iso,l,m,i,lx,ly,lz,rx,ry,rz,drx,dry,drz,ic,dc,iso1,iso2,cin,dylm) &
216 2182 : !$OMP PRIVATE(is1,l1,m1,is2,l2,m2,is,n,y)
217 :
218 : ALLOCATE (y(na))
219 : !$OMP DO
220 : DO iso = 1, max_s_harm
221 : l = indso(1, iso)
222 : m = indso(2, iso)
223 : CALL y_lm(lebedev_grid(ll)%r, y, l, m)
224 :
225 : DO ia = 1, na
226 : slm(ia, iso) = y(ia)
227 : slm_int(iso) = slm_int(iso) + slm(ia, iso)*wa(ia)
228 : END DO ! ia
229 : END DO ! iso
230 : !$OMP END DO
231 : DEALLOCATE (y)
232 :
233 : !$OMP DO
234 : DO ia = 1, na
235 : harmonics%a(:, ia) = lebedev_grid(ll)%r(:, ia)
236 : END DO
237 : !$OMP END DO
238 :
239 : !
240 : ! The derivatives dslm_dxyz and its expansions my_CG_dxyz and my_CG_dxyz_asymm
241 : ! are NOT the dSlm/dx but the scaled by r**(l-1) derivatives of the monomial
242 : ! terms x^n1 y^n2 z^n3 transformed by spherical harmonics expansion coefficients
243 : !
244 :
245 : ALLOCATE (dc(nco(llmax), 3))
246 : !$OMP DO
247 : DO ia = 1, na
248 : DO l = 0, indso(1, max_s_harm)
249 : DO ic = 1, nco(l)
250 : lx = indco(1, ic + ncoset(l - 1))
251 : ly = indco(2, ic + ncoset(l - 1))
252 : lz = indco(3, ic + ncoset(l - 1))
253 :
254 : IF (lx == 0) THEN
255 : rx = 1.0_dp
256 : drx = 0.0_dp
257 : ELSE IF (lx == 1) THEN
258 : rx = lebedev_grid(ll)%r(1, ia)
259 : drx = 1.0_dp
260 : ELSE
261 : rx = lebedev_grid(ll)%r(1, ia)**lx
262 : drx = REAL(lx, dp)*lebedev_grid(ll)%r(1, ia)**(lx - 1)
263 : END IF
264 : IF (ly == 0) THEN
265 : ry = 1.0_dp
266 : dry = 0.0_dp
267 : ELSE IF (ly == 1) THEN
268 : ry = lebedev_grid(ll)%r(2, ia)
269 : dry = 1.0_dp
270 : ELSE
271 : ry = lebedev_grid(ll)%r(2, ia)**ly
272 : dry = REAL(ly, dp)*lebedev_grid(ll)%r(2, ia)**(ly - 1)
273 : END IF
274 : IF (lz == 0) THEN
275 : rz = 1.0_dp
276 : drz = 0.0_dp
277 : ELSE IF (lz == 1) THEN
278 : rz = lebedev_grid(ll)%r(3, ia)
279 : drz = 1.0_dp
280 : ELSE
281 : rz = lebedev_grid(ll)%r(3, ia)**lz
282 : drz = REAL(lz, dp)*lebedev_grid(ll)%r(3, ia)**(lz - 1)
283 : END IF
284 : dc(ic, 1) = drx*ry*rz
285 : dc(ic, 2) = rx*dry*rz
286 : dc(ic, 3) = rx*ry*drz
287 : END DO
288 : n = nsoset(l - 1)
289 : DO is = 1, nso(l)
290 : iso = is + n
291 : DO ic = 1, nco(l)
292 : dslm_dxyz(:, ia, iso) = dslm_dxyz(:, ia, iso) + &
293 : orbtramat(l)%slm(is, ic)*dc(ic, :)
294 : END DO
295 : END DO
296 : END DO ! l
297 : END DO !ia
298 : !$OMP END DO
299 : DEALLOCATE (dc)
300 :
301 : ! Expansion coefficients of the cartesian derivatives
302 : ! of the product of two harmonics :
303 : ! d(Y(l1m1) * Y(l2m2))/dx ; d(Y(l1m1) * Y(l2m2))/dy ; d(Y(l1m1) * Y(l2m2))/dz
304 :
305 : !$OMP DO COLLAPSE(3)
306 : DO iso1 = 1, maxs
307 : DO iso2 = 1, maxs
308 : DO iso = 1, max_s_harm
309 : rx = 0.0_dp
310 : ry = 0.0_dp
311 : rz = 0.0_dp
312 :
313 : DO ia = 1, na
314 : rx = rx + wa(ia)*slm(ia, iso)* &
315 : (dslm_dxyz(1, ia, iso1)*slm(ia, iso2) + slm(ia, iso1)*dslm_dxyz(1, ia, iso2))
316 : ry = ry + wa(ia)*slm(ia, iso)* &
317 : (dslm_dxyz(2, ia, iso1)*slm(ia, iso2) + slm(ia, iso1)*dslm_dxyz(2, ia, iso2))
318 : rz = rz + wa(ia)*slm(ia, iso)* &
319 : (dslm_dxyz(3, ia, iso1)*slm(ia, iso2) + slm(ia, iso1)*dslm_dxyz(3, ia, iso2))
320 : END DO
321 :
322 : harmonics%my_CG_dxyz(1, iso1, iso2, iso) = rx
323 : harmonics%my_CG_dxyz(2, iso1, iso2, iso) = ry
324 : harmonics%my_CG_dxyz(3, iso1, iso2, iso) = rz
325 :
326 : END DO
327 : END DO
328 : END DO
329 : !$OMP END DO
330 :
331 : ! Expansion coefficients of the cartesian of the combinations
332 : ! Y(l1m1) * d(Y(l2m2))/dx - d(Y(l1m1))/dx * Y(l2m2)
333 : ! Y(l1m1) * d(Y(l2m2))/dy - d(Y(l1m1))/dy * Y(l2m2)
334 : ! Y(l1m1) * d(Y(l2m2))/dz - d(Y(l1m1))/dz * Y(l2m2)
335 :
336 : !$OMP DO COLLAPSE(3)
337 : DO iso1 = 1, maxs
338 : DO iso2 = 1, maxs
339 : DO iso = 1, max_s_harm
340 : drx = 0.0_dp
341 : dry = 0.0_dp
342 : drz = 0.0_dp
343 :
344 : DO ia = 1, na
345 : drx = drx + wa(ia)*slm(ia, iso)* &
346 : (-dslm_dxyz(1, ia, iso1)*slm(ia, iso2) + &
347 : slm(ia, iso1)*dslm_dxyz(1, ia, iso2))
348 : dry = dry + wa(ia)*slm(ia, iso)* &
349 : (-dslm_dxyz(2, ia, iso1)*slm(ia, iso2) + &
350 : slm(ia, iso1)*dslm_dxyz(2, ia, iso2))
351 : drz = drz + wa(ia)*slm(ia, iso)* &
352 : (-dslm_dxyz(3, ia, iso1)*slm(ia, iso2) + &
353 : slm(ia, iso1)*dslm_dxyz(3, ia, iso2))
354 : END DO
355 :
356 : harmonics%my_CG_dxyz_asym(1, iso1, iso2, iso) = drx
357 : harmonics%my_CG_dxyz_asym(2, iso1, iso2, iso) = dry
358 : harmonics%my_CG_dxyz_asym(3, iso1, iso2, iso) = drz
359 :
360 : END DO ! iso
361 : END DO ! iso2
362 : END DO ! iso1
363 : !$OMP END DO
364 :
365 : ! Calculate the derivatives of the harmonics with respect of the 2 angles
366 : ! the first angle (polar) is acos(lebedev_grid(ll)%r(3))
367 : ! the second angle (azimutal) is atan(lebedev_grid(ll)%r(2)/lebedev_grid(ll)%r(1))
368 : !$OMP DO
369 : DO iso = 1, maxs
370 : l = indso(1, iso)
371 : m = indso(2, iso)
372 : DO ia = 1, na
373 : cin(1) = pol(ia)
374 : cin(2) = azi(ia)
375 : CALL dy_lm(cin, dylm, l, m)
376 : harmonics%dslm(:, ia, iso) = dylm(:)
377 : END DO
378 : END DO
379 : !$OMP END DO
380 :
381 : ! expansion coefficients of product of polar angle derivatives (dslm(1...)) in
382 : ! spherical harmonics (used for tau functionals)
383 : !$OMP END PARALLEL
384 :
385 2182 : CALL timestop(handle)
386 :
387 2182 : END SUBROUTINE create_harmonics_atom
388 :
389 : ! **************************************************************************************************
390 : !> \brief ...
391 : !> \param harmonics ...
392 : !> \param orb_basis ...
393 : !> \param llmax ...
394 : !> \param max_s_harm ...
395 : ! **************************************************************************************************
396 4364 : SUBROUTINE get_maxl_CG(harmonics, orb_basis, llmax, max_s_harm)
397 :
398 : TYPE(harmonics_atom_type), POINTER :: harmonics
399 : TYPE(gto_basis_set_type), POINTER :: orb_basis
400 : INTEGER, INTENT(IN) :: llmax, max_s_harm
401 :
402 : CHARACTER(len=*), PARAMETER :: routineN = 'get_maxl_CG'
403 :
404 : INTEGER :: damax_iso_not0, dmax_iso_not0, handle, &
405 : is1, is2, itmp, max_iso_not0, nset
406 2182 : INTEGER, DIMENSION(:), POINTER :: lmax, lmin
407 :
408 2182 : CALL timeset(routineN, handle)
409 :
410 2182 : CPASSERT(ASSOCIATED(harmonics))
411 :
412 2182 : CALL get_gto_basis_set(gto_basis_set=orb_basis, lmax=lmax, lmin=lmin, nset=nset)
413 :
414 : ! *** Assign indexes for the non null CG coefficients ***
415 2182 : max_iso_not0 = 0
416 2182 : dmax_iso_not0 = 0
417 2182 : damax_iso_not0 = 0
418 8726 : DO is1 = 1, nset
419 37414 : DO is2 = 1, nset
420 : CALL get_none0_cg_list(harmonics%my_CG, &
421 : lmin(is1), lmax(is1), lmin(is2), lmax(is2), &
422 28688 : max_s_harm, llmax, max_iso_not0=itmp)
423 28688 : max_iso_not0 = MAX(max_iso_not0, itmp)
424 : CALL get_none0_cg_list(harmonics%my_CG_dxyz, &
425 : lmin(is1), lmax(is1), lmin(is2), lmax(is2), &
426 28688 : max_s_harm, llmax, max_iso_not0=itmp)
427 28688 : dmax_iso_not0 = MAX(dmax_iso_not0, itmp)
428 : CALL get_none0_cg_list(harmonics%my_CG_dxyz_asym, &
429 : lmin(is1), lmax(is1), lmin(is2), lmax(is2), &
430 28688 : max_s_harm, llmax, max_iso_not0=itmp)
431 35232 : damax_iso_not0 = MAX(damax_iso_not0, itmp)
432 : END DO ! is2
433 : END DO ! is1
434 2182 : harmonics%max_iso_not0 = max_iso_not0
435 2182 : harmonics%dmax_iso_not0 = dmax_iso_not0
436 2182 : harmonics%damax_iso_not0 = damax_iso_not0
437 :
438 2182 : CALL timestop(handle)
439 :
440 2182 : END SUBROUTINE get_maxl_CG
441 :
442 : ! **************************************************************************************************
443 : !> \brief ...
444 : !> \param cgc ...
445 : !> \param lmin1 ...
446 : !> \param lmax1 ...
447 : !> \param lmin2 ...
448 : !> \param lmax2 ...
449 : !> \param max_s_harm ...
450 : !> \param llmax ...
451 : !> \param list ...
452 : !> \param n_list ...
453 : !> \param max_iso_not0 ...
454 : ! **************************************************************************************************
455 715713 : SUBROUTINE get_none0_cg_list4(cgc, lmin1, lmax1, lmin2, lmax2, max_s_harm, llmax, &
456 715713 : list, n_list, max_iso_not0)
457 :
458 : REAL(dp), DIMENSION(:, :, :, :), INTENT(IN) :: cgc
459 : INTEGER, INTENT(IN) :: lmin1, lmax1, lmin2, lmax2, max_s_harm, &
460 : llmax
461 : INTEGER, DIMENSION(:, :, :), INTENT(OUT), OPTIONAL :: list
462 : INTEGER, DIMENSION(:), INTENT(OUT), OPTIONAL :: n_list
463 : INTEGER, INTENT(OUT) :: max_iso_not0
464 :
465 : INTEGER :: iso, iso1, iso2, l1, l2, nlist
466 :
467 715713 : CPASSERT(nsoset(lmax1) <= SIZE(cgc, 2))
468 715713 : CPASSERT(nsoset(lmax2) <= SIZE(cgc, 3))
469 715713 : CPASSERT(max_s_harm <= SIZE(cgc, 4))
470 715713 : IF (PRESENT(n_list) .AND. PRESENT(list)) THEN
471 658337 : CPASSERT(max_s_harm <= SIZE(list, 3))
472 : END IF
473 715713 : max_iso_not0 = 0
474 16576811 : IF (PRESENT(n_list) .AND. PRESENT(list)) n_list = 0
475 17913034 : DO iso = 1, max_s_harm
476 17197321 : nlist = 0
477 37574541 : DO l1 = lmin1, lmax1
478 88870427 : DO iso1 = nsoset(l1 - 1) + 1, nsoset(l1)
479 135754484 : DO l2 = lmin2, lmax2
480 64081378 : IF (l1 + l2 > llmax) CYCLE
481 288698382 : DO iso2 = nsoset(l2 - 1) + 1, nsoset(l2)
482 173361568 : IF (ABS(cgc(1, iso1, iso2, iso)) + &
483 : ABS(cgc(2, iso1, iso2, iso)) + &
484 64081378 : ABS(cgc(3, iso1, iso2, iso)) > 1.E-8_dp) THEN
485 21971810 : nlist = nlist + 1
486 21971810 : IF (PRESENT(n_list) .AND. PRESENT(list)) THEN
487 18031106 : list(1, nlist, iso) = iso1
488 18031106 : list(2, nlist, iso) = iso2
489 : END IF
490 21971810 : max_iso_not0 = MAX(max_iso_not0, iso)
491 : END IF
492 : END DO
493 : END DO
494 : END DO
495 : END DO
496 17913034 : IF (PRESENT(n_list) .AND. PRESENT(list)) n_list(iso) = nlist
497 : END DO
498 715713 : END SUBROUTINE get_none0_cg_list4
499 :
500 : ! **************************************************************************************************
501 : !> \brief ...
502 : !> \param cgc ...
503 : !> \param lmin1 ...
504 : !> \param lmax1 ...
505 : !> \param lmin2 ...
506 : !> \param lmax2 ...
507 : !> \param max_s_harm ...
508 : !> \param llmax ...
509 : !> \param list ...
510 : !> \param n_list ...
511 : !> \param max_iso_not0 ...
512 : ! **************************************************************************************************
513 1265566 : SUBROUTINE get_none0_cg_list3(cgc, lmin1, lmax1, lmin2, lmax2, max_s_harm, llmax, &
514 1265566 : list, n_list, max_iso_not0)
515 :
516 : REAL(dp), DIMENSION(:, :, :), INTENT(IN) :: cgc
517 : INTEGER, INTENT(IN) :: lmin1, lmax1, lmin2, lmax2, max_s_harm, &
518 : llmax
519 : INTEGER, DIMENSION(:, :, :), INTENT(OUT), OPTIONAL :: list
520 : INTEGER, DIMENSION(:), INTENT(OUT), OPTIONAL :: n_list
521 : INTEGER, INTENT(OUT) :: max_iso_not0
522 :
523 : INTEGER :: iso, iso1, iso2, l1, l2, nlist
524 :
525 1265566 : CPASSERT(nsoset(lmax1) <= SIZE(cgc, 1))
526 1265566 : CPASSERT(nsoset(lmax2) <= SIZE(cgc, 2))
527 1265566 : CPASSERT(max_s_harm <= SIZE(cgc, 3))
528 1265566 : IF (PRESENT(n_list) .AND. PRESENT(list)) THEN
529 1236230 : CPASSERT(max_s_harm <= SIZE(list, 3))
530 : END IF
531 1265566 : max_iso_not0 = 0
532 32652586 : IF (PRESENT(n_list) .AND. PRESENT(list)) n_list = 0
533 32429260 : DO iso = 1, max_s_harm
534 31163694 : nlist = 0
535 68120346 : DO l1 = lmin1, lmax1
536 159384214 : DO iso1 = nsoset(l1 - 1) + 1, nsoset(l1)
537 242542545 : DO l2 = lmin2, lmax2
538 114322025 : IF (l1 + l2 > llmax) CYCLE
539 508608254 : DO iso2 = nsoset(l2 - 1) + 1, nsoset(l2)
540 417406411 : IF (ABS(cgc(iso1, iso2, iso)) > 1.E-8_dp) THEN
541 19559513 : nlist = nlist + 1
542 19559513 : IF (PRESENT(n_list) .AND. PRESENT(list)) THEN
543 18888217 : list(1, nlist, iso) = iso1
544 18888217 : list(2, nlist, iso) = iso2
545 : END IF
546 19559513 : max_iso_not0 = MAX(max_iso_not0, iso)
547 : END IF
548 : END DO
549 : END DO
550 : END DO
551 : END DO
552 32429260 : IF (PRESENT(n_list) .AND. PRESENT(list)) n_list(iso) = nlist
553 : END DO
554 1265566 : END SUBROUTINE get_none0_cg_list3
555 :
556 0 : END MODULE qs_harmonics_atom
|
