Line data Source code
1 : !--------------------------------------------------------------------------------
2 : ! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
3 : ! This file is part of FLEUR and available as free software under the conditions
4 : ! of the MIT license as expressed in the LICENSE file in more detail.
5 : !--------------------------------------------------------------------------------
6 :
7 : MODULE m_setabc1locdn1
8 : !***********************************************************************
9 : ! calculates the (lower case) a, b and c coefficients for the local
10 : ! orbitals. The radial function of the local orbital is a linear
11 : ! combination of the apw radial function and its derivative and the
12 : ! extra radial funtion (a*u + b*udot + c*ulo). This function is zero
13 : ! and has zero derivative at the muffin tin boundary.
14 : ! In addition the the total number of basisfuntions (apw + lo) nbasf and
15 : ! the number of the first basisfunction of each local orbital nbasf0 is
16 : ! determined.
17 : ! Philipp Kurz 99/04
18 : !***********************************************************************
19 : CONTAINS
20 0 : SUBROUTINE setabc1locdn1(jsp,atoms,lapw,sym,usdus,&
21 0 : enough,nkvec,kvec,nbasf0, alo1,blo1,clo1)
22 : !
23 : !*************** ABBREVIATIONS *****************************************
24 : ! nbasf : total number of basisfunctions (apw + lo)
25 : ! nbasf0 : number of the first basisfunction of each local orbital
26 : ! nkvec : stores the number of G-vectors that have been found and
27 : ! accepted during the construction of the local orbitals.
28 : !***********************************************************************
29 : USE m_types
30 : IMPLICIT NONE
31 : TYPE(t_sym),INTENT(IN) :: sym
32 : TYPE(t_atoms),INTENT(IN) :: atoms
33 : TYPE(t_usdus),INTENT(IN) :: usdus
34 : TYPE(t_lapw),INTENT(IN) :: lapw
35 : ! ..
36 : ! .. Scalar Arguments ..
37 : ! ..
38 : INTEGER,INTENT(IN) :: jsp
39 : ! .. Array Arguments ..
40 : INTEGER, INTENT (OUT) :: nbasf0(atoms%nlod,atoms%nat),nkvec(atoms%nlod,atoms%nat)
41 : INTEGER, INTENT (OUT) :: kvec(2*(2*atoms%llod+1),atoms%nlod,atoms%nat )
42 : REAL, INTENT (OUT) :: alo1(atoms%nlod,atoms%ntype),blo1(atoms%nlod,atoms%ntype)
43 : REAL, INTENT (OUT) :: clo1(atoms%nlod,atoms%ntype)
44 : LOGICAL, INTENT (OUT) :: enough(atoms%nat)
45 : ! ..
46 : ! .. Local Scalars ..
47 : REAL ka,kb,ws
48 : INTEGER i,l,lo ,natom,nbasf,nn,ntyp,lm,m
49 : LOGICAL apw_at
50 : ! ..
51 0 : enough(:) = .true.
52 0 : DO ntyp = 1,atoms%ntype
53 : ! ..
54 : ! look, whether 'ntyp' is a APW atom; then set apw_at=.true.
55 : !
56 0 : apw_at = .false.
57 0 : DO lo = 1,atoms%nlo(ntyp)
58 0 : IF (atoms%l_dulo(lo,ntyp)) apw_at = .true.
59 : ENDDO
60 :
61 0 : DO lo = 1,atoms%nlo(ntyp)
62 0 : l = atoms%llo(lo,ntyp)
63 0 : IF (apw_at) THEN
64 0 : IF (atoms%l_dulo(lo,ntyp)) THEN
65 : ! udot lo
66 0 : ka = sqrt( 1+(usdus%us(l,ntyp,jsp)/usdus%uds(l,ntyp,jsp))**2 * usdus%ddn(l,ntyp,jsp))
67 0 : alo1(lo,ntyp)=1.00 / ka
68 0 : blo1(lo,ntyp)=-usdus%us(l,ntyp,jsp)/ (usdus%uds(l,ntyp,jsp) * ka)
69 0 : clo1(lo,ntyp)=0.00
70 : ELSE
71 : ! u2 lo
72 0 : alo1(lo,ntyp)=1.00
73 0 : blo1(lo,ntyp)=0.00
74 0 : clo1(lo,ntyp)=-usdus%us(l,ntyp,jsp)/usdus%ulos(lo,ntyp,jsp)
75 : ENDIF
76 : ELSE
77 0 : ws = usdus%uds(l,ntyp,jsp)*usdus%dus(l,ntyp,jsp) - usdus%us(l,ntyp,jsp)*usdus%duds(l,ntyp,jsp)
78 0 : ka = 1.0/ws* (usdus%duds(l,ntyp,jsp)*usdus%ulos(lo,ntyp,jsp)- usdus%uds(l,ntyp,jsp)*usdus%dulos(lo,ntyp,jsp))
79 0 : kb = 1.0/ws* (usdus%us(l,ntyp,jsp)*usdus%dulos(lo,ntyp,jsp)- usdus%dus(l,ntyp,jsp)*usdus%ulos(lo,ntyp,jsp))
80 : clo1(lo,ntyp) = 1.0/sqrt(ka**2+ (kb**2)*usdus%ddn(l,ntyp,jsp)+1.0+&
81 0 : 2.0*ka*usdus%uulon(lo,ntyp,jsp)+2.0*kb*usdus%dulon(lo,ntyp,jsp))
82 0 : alo1(lo,ntyp) = ka*clo1(lo,ntyp)
83 0 : blo1(lo,ntyp) = kb*clo1(lo,ntyp)
84 : ENDIF
85 : END DO
86 : END DO
87 : !---> set up enough, nbasf0 and initialize nkvec
88 0 : natom = 0
89 0 : nbasf = lapw%nv(jsp)
90 0 : DO ntyp = 1,atoms%ntype
91 0 : DO nn = 1,atoms%neq(ntyp)
92 0 : natom = natom + 1
93 0 : DO lo = 1,atoms%nlo(ntyp)
94 0 : enough(natom) = .false.
95 0 : nkvec(lo,natom) = 0
96 0 : l = atoms%llo(lo,ntyp)
97 0 : IF (sym%invsat(natom).EQ.0) THEN
98 0 : nbasf0(lo,natom) = nbasf
99 0 : nbasf = nbasf + 2*l + 1
100 : END IF
101 0 : IF (sym%invsat(natom).EQ.1) THEN
102 0 : nbasf0(lo,natom) = nbasf
103 0 : nbasf0(lo,sym%invsatnr(natom)) = nbasf
104 0 : nbasf = nbasf + 2* (2*l+1)
105 : END IF
106 : END DO
107 : END DO
108 : END DO
109 :
110 :
111 : ! write (*,*) 'in setabc1locdn: nmat = ',nmat,' nbasf = ',nbasf
112 : ! write (*,*) 'array nbasf0 :'
113 : ! do natom = 1,natd
114 : ! write (*,fmt='(15i4)') (nbasf0(lo,natom),lo=1,nlod)
115 : ! enddo
116 : ! write (*,*)
117 0 : IF ((lapw%nmat).NE.nbasf) THEN
118 0 : write (*,*) 'in setabc1locdn: lapw%nmat = ',lapw%nmat,' nbasf = ',nbasf
119 0 : STOP 'setabc1locdn: number of bas.-fcn.'
120 : ENDIF
121 : !
122 : !--> sort the k-vectors used for the LO's according to atom & lo:
123 : !
124 : natom = 0
125 : lm = 0
126 0 : DO ntyp = 1, atoms%ntype
127 0 : DO nn = 1, atoms%neq(ntyp)
128 0 : natom = natom + 1
129 0 : IF ((sym%invsat(natom).EQ.0) .OR. (sym%invsat(natom).EQ.1)) THEN
130 0 : DO lo = 1,atoms%nlo(ntyp)
131 0 : m = ( sym%invsat(natom) +1 ) * ( 2 * atoms%llo(lo,ntyp) + 1 )
132 0 : DO l = 1, m
133 : lm = lm + 1
134 0 : kvec(l,lo,natom) = lapw%kvec(l,lo,natom)
135 : ENDDO
136 : ENDDO
137 : ENDIF
138 : ENDDO
139 : ENDDO
140 :
141 0 : END SUBROUTINE setabc1locdn1
142 : END MODULE m_setabc1locdn1
|
