Line data Source code
1 : MODULE m_lhglptg
2 : !.....------------------------------------------------------------------
3 : ! calculates lattice harmonics and their gradients on the
4 : ! gauss-legendre angular mesh - r.p. and t.a.
5 : ! for gradient. t.a. 1996.
6 : !.....------------------------------------------------------------------
7 : CONTAINS
8 322 : SUBROUTINE lhglptg(&
9 : & sphhar,atoms,&
10 322 : & rx,nsp,xcpot,sym,&
11 322 : & ylh,thet,ylht1,ylht2,ylhf1,ylhf2,ylhtf)
12 : !
13 : USE m_polangle
14 : USE m_ylm
15 : USE m_dylm
16 : USE m_types
17 : IMPLICIT NONE
18 :
19 : CLASS(t_xcpot),INTENT(IN) :: xcpot
20 : TYPE(t_sym),INTENT(IN) :: sym
21 : TYPE(t_sphhar),INTENT(IN) :: sphhar
22 : TYPE(t_atoms),INTENT(IN) :: atoms
23 : ! ..
24 : ! .. Scalar Arguments ..
25 : INTEGER, INTENT (IN) :: nsp
26 : ! ..
27 : ! .. Array Arguments ..
28 : REAL, INTENT (IN) :: rx(:,:)!(3,dimension%nspd)
29 : REAL, INTENT (OUT):: thet(:) !nspd
30 : REAL, INTENT (OUT):: ylh(:,0:,:)!(dimension%nspd,0:sphhar%nlhd,sphhar%ntypsd),thet(nspd)
31 : REAL, INTENT (OUT):: ylht1(:,0:,:)!(dimension%nspd,0:sphhar%nlhd,sphhar%ntypsd)
32 : REAL, INTENT (OUT):: ylht2(:,0:,:)!(dimension%nspd,0:sphhar%nlhd,sphhar%ntypsd)
33 : REAL, INTENT (OUT):: ylhtf(:,0:,:)!(dimension%nspd,0:sphhar%nlhd,sphhar%ntypsd)
34 : REAL, INTENT (OUT):: ylhf1(:,0:,:)!(dimension%nspd,0:sphhar%nlhd,sphhar%ntypsd)
35 : REAL, INTENT (OUT):: ylhf2(:,0:,:)!(dimension%nspd,0:sphhar%nlhd,sphhar%ntypsd)
36 : ! ..
37 : ! .. Local Scalars ..
38 : REAL s,st1,st2,sf1,sf2,stf,phi
39 : INTEGER k,lh,mem,nd,lm,ll1
40 : ! ..
41 : ! .. Local Arrays ..
42 644 : COMPLEX ylm( (atoms%lmaxd+1)**2 )
43 644 : COMPLEX dylmt1( (atoms%lmaxd+1)**2 ), dylmt2( (atoms%lmaxd+1)**2 )
44 644 : COMPLEX dylmf1( (atoms%lmaxd+1)**2 ), dylmf2( (atoms%lmaxd+1)**2 )
45 644 : COMPLEX dylmtf( (atoms%lmaxd+1)**2 )
46 : ! ..
47 :
48 : !.....------------------------------------------------------------------
49 : ! ..
50 674 : DO nd = 1,sym%nsymt
51 :
52 66766 : DO k = 1,nsp
53 :
54 : CALL ylm4(&
55 : & atoms%lmaxd,rx(:,k),&
56 66092 : & ylm)
57 : CALL pol_angle(&
58 : & rx(1,k),rx(2,k),rx(3,k),&
59 66092 : & thet(k),phi)
60 :
61 66092 : IF (xcpot%needs_grad()) THEN
62 : CALL dylm3(&
63 : & atoms%lmaxd,atoms%lmaxd,rx(:,k),ylm,&
64 66092 : & dylmt1,dylmt2,dylmf1,dylmf2,dylmtf)
65 : ENDIF
66 :
67 1412076 : DO lh = 0,sphhar%nlh(nd)
68 1345632 : s = 0
69 1345632 : st1 = 0
70 1345632 : st2 = 0
71 1345632 : sf1 = 0
72 1345632 : sf2 = 0
73 1345632 : stf = 0
74 1345632 : ll1 = sphhar%llh(lh,nd) * ( sphhar%llh(lh,nd) + 1 ) + 1
75 :
76 4050104 : DO mem = 1,sphhar%nmem(lh,nd)
77 2704472 : lm = ll1 + sphhar%mlh(mem,lh,nd)
78 4050104 : s = s + REAL( sphhar%clnu(mem,lh,nd) * ylm(lm) )
79 : ENDDO
80 :
81 1345632 : ylh(k,lh,nd) = s
82 :
83 1411724 : IF (xcpot%needs_grad()) THEN
84 :
85 4050104 : DO mem = 1,sphhar%nmem(lh,nd)
86 2704472 : lm = ll1 + sphhar%mlh(mem,lh,nd)
87 2704472 : s = s + REAL( sphhar%clnu(mem,lh,nd)* ylm(lm) )
88 2704472 : st1 = st1 + REAL( sphhar%clnu(mem,lh,nd)*dylmt1(lm) )
89 2704472 : st2 = st2 + REAL( sphhar%clnu(mem,lh,nd)*dylmt2(lm) )
90 2704472 : sf1 = sf1 + REAL( sphhar%clnu(mem,lh,nd)*dylmf1(lm) )
91 2704472 : sf2 = sf2 + REAL( sphhar%clnu(mem,lh,nd)*dylmf2(lm) )
92 4050104 : stf = stf + REAL( sphhar%clnu(mem,lh,nd)*dylmtf(lm) )
93 : ENDDO
94 :
95 1345632 : ylht1(k,lh,nd) = st1
96 1345632 : ylht2(k,lh,nd) = st2
97 1345632 : ylhf1(k,lh,nd) = sf1
98 1345632 : ylhf2(k,lh,nd) = sf2
99 1345632 : ylhtf(k,lh,nd) = stf
100 :
101 : ENDIF
102 :
103 : ENDDO
104 : ENDDO
105 : ENDDO
106 :
107 322 : RETURN
108 : END SUBROUTINE lhglptg
109 : END MODULE m_lhglptg
|
