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 566 : SUBROUTINE lhglptg(&
9 : & sphhar,atoms,&
10 566 : & rx,nsp,dograds,sym,&
11 566 : & ylh,thet,phi,ylht1,ylht2,ylhf1,ylhf2,ylhtf)
12 : !
13 : USE m_polangle
14 : USE m_ylm
15 : USE m_dylm
16 : USE m_types_sym
17 : USE m_types_sphhar
18 : USE m_types_atoms
19 :
20 : IMPLICIT NONE
21 :
22 : LOGICAL, INTENT(IN) :: dograds
23 : TYPE(t_sym),INTENT(IN) :: sym
24 : TYPE(t_sphhar),INTENT(IN) :: sphhar
25 : TYPE(t_atoms),INTENT(IN) :: atoms
26 : ! ..
27 : ! .. Scalar Arguments ..
28 : INTEGER, INTENT (IN) :: nsp
29 : ! ..
30 : ! .. Array Arguments ..
31 : REAL, INTENT (IN) :: rx(:,:)!(3,dimension%nspd)
32 : REAL, INTENT (OUT):: thet(:) !nspd
33 : REAL, INTENT (OUT):: phi(:) !nspd
34 : REAL, INTENT (OUT):: ylh(:,0:,:)!(dimension%nspd,0:sphhar%nlhd,sphhar%ntypsd),thet(nspd)
35 : REAL, INTENT (OUT):: ylht1(:,0:,:)!(dimension%nspd,0:sphhar%nlhd,sphhar%ntypsd)
36 : REAL, INTENT (OUT):: ylht2(:,0:,:)!(dimension%nspd,0:sphhar%nlhd,sphhar%ntypsd)
37 : REAL, INTENT (OUT):: ylhtf(:,0:,:)!(dimension%nspd,0:sphhar%nlhd,sphhar%ntypsd)
38 : REAL, INTENT (OUT):: ylhf1(:,0:,:)!(dimension%nspd,0:sphhar%nlhd,sphhar%ntypsd)
39 : REAL, INTENT (OUT):: ylhf2(:,0:,:)!(dimension%nspd,0:sphhar%nlhd,sphhar%ntypsd)
40 : ! ..
41 : ! .. Local Scalars ..
42 : REAL s,st1,st2,sf1,sf2,stf
43 : INTEGER k,lh,mem,nd,lm,ll1
44 : ! ..
45 : ! .. Local Arrays ..
46 566 : COMPLEX ylm( (atoms%lmaxd+1)**2 )
47 566 : COMPLEX dylmt1( (atoms%lmaxd+1)**2 ), dylmt2( (atoms%lmaxd+1)**2 )
48 566 : COMPLEX dylmf1( (atoms%lmaxd+1)**2 ), dylmf2( (atoms%lmaxd+1)**2 )
49 566 : COMPLEX dylmtf( (atoms%lmaxd+1)**2 )
50 : ! ..
51 :
52 : !.....------------------------------------------------------------------
53 : ! ..
54 1232 : DO nd = 1,sym%nsymt
55 :
56 123912 : DO k = 1,nsp
57 :
58 : CALL ylm4(&
59 : & atoms%lmaxd,rx(:,k),&
60 122680 : & ylm)
61 : CALL pol_angle(&
62 : & rx(1,k),rx(2,k),rx(3,k),&
63 122680 : & thet(k),phi(k))
64 :
65 122680 : IF (dograds) THEN
66 : CALL dylm3(&
67 : & atoms%lmaxd,atoms%lmaxd,rx(:,k),ylm,&
68 122680 : & dylmt1,dylmt2,dylmf1,dylmf2,dylmtf)
69 : ENDIF
70 :
71 3349806 : DO lh = 0,sphhar%nlh(nd)
72 3226460 : s = 0
73 3226460 : st1 = 0
74 3226460 : st2 = 0
75 3226460 : sf1 = 0
76 3226460 : sf2 = 0
77 3226460 : stf = 0
78 3226460 : ll1 = sphhar%llh(lh,nd) * ( sphhar%llh(lh,nd) + 1 ) + 1
79 :
80 9790512 : DO mem = 1,sphhar%nmem(lh,nd)
81 6564052 : lm = ll1 + sphhar%mlh(mem,lh,nd)
82 9790512 : s = s + REAL( sphhar%clnu(mem,lh,nd) * ylm(lm) )
83 : ENDDO
84 :
85 3226460 : ylh(k,lh,nd) = s
86 :
87 3349140 : IF (dograds) THEN
88 :
89 9790512 : DO mem = 1,sphhar%nmem(lh,nd)
90 6564052 : lm = ll1 + sphhar%mlh(mem,lh,nd)
91 6564052 : s = s + REAL( sphhar%clnu(mem,lh,nd)* ylm(lm) )
92 6564052 : st1 = st1 + REAL( sphhar%clnu(mem,lh,nd)*dylmt1(lm) )
93 6564052 : st2 = st2 + REAL( sphhar%clnu(mem,lh,nd)*dylmt2(lm) )
94 6564052 : sf1 = sf1 + REAL( sphhar%clnu(mem,lh,nd)*dylmf1(lm) )
95 6564052 : sf2 = sf2 + REAL( sphhar%clnu(mem,lh,nd)*dylmf2(lm) )
96 9790512 : stf = stf + REAL( sphhar%clnu(mem,lh,nd)*dylmtf(lm) )
97 : ENDDO
98 :
99 3226460 : ylht1(k,lh,nd) = st1
100 3226460 : ylht2(k,lh,nd) = st2
101 3226460 : ylhf1(k,lh,nd) = sf1
102 3226460 : ylhf2(k,lh,nd) = sf2
103 3226460 : ylhtf(k,lh,nd) = stf
104 :
105 : ENDIF
106 :
107 : ENDDO
108 : ENDDO
109 : ENDDO
110 :
111 566 : RETURN
112 : END SUBROUTINE lhglptg
113 : END MODULE m_lhglptg
|
