metric.f90 7.82 KB
Newer Older
 Markus Betzinger committed Apr 26, 2016 1 2 3 4 5 6 7 ``````MODULE m_metric USE m_juDFT !********************************************************* ! multiplicates the vector s_in with the metric G ! output vector sout !********************************************************* CONTAINS `````` Gregor Michalicek committed Nov 08, 2017 8 9 `````` SUBROUTINE metric(cell,atoms,vacuum,sphhar,input,noco,stars,sym,oneD,& mmap,nmaph,mapmt,mapvac2,s_in,sout,lpot) `````` Markus Betzinger committed Apr 26, 2016 10 11 12 `````` USE m_metrz0 USE m_convol USE m_types `````` Gregor Michalicek committed Nov 08, 2017 13 `````` `````` Markus Betzinger committed Apr 26, 2016 14 `````` IMPLICIT NONE `````` Gregor Michalicek committed Nov 08, 2017 15 `````` `````` Markus Betzinger committed Apr 26, 2016 16 `````` TYPE(t_oneD),INTENT(IN) :: oneD `````` Gregor Michalicek committed Nov 08, 2017 17 18 `````` TYPE(t_input),INTENT(IN) :: input TYPE(t_vacuum),INTENT(IN) :: vacuum `````` Markus Betzinger committed Apr 26, 2016 19 `````` TYPE(t_noco),INTENT(IN) :: noco `````` Gregor Michalicek committed Nov 08, 2017 20 21 `````` TYPE(t_sym),INTENT(IN) :: sym TYPE(t_stars),INTENT(IN) :: stars `````` Markus Betzinger committed Apr 26, 2016 22 `````` TYPE(t_cell),INTENT(IN) :: cell `````` Gregor Michalicek committed Nov 08, 2017 23 24 25 26 27 28 29 `````` TYPE(t_sphhar),INTENT(IN) :: sphhar TYPE(t_atoms),INTENT(IN) :: atoms ! Scalar Arguments INTEGER, INTENT (IN) :: mmap INTEGER, INTENT (IN) :: mapmt,mapvac2 INTEGER, INTENT (IN) :: nmaph `````` Markus Betzinger committed Apr 26, 2016 30 `````` LOGICAL, OPTIONAL,INTENT (IN) :: lpot !do we mix a potential?? `````` Gregor Michalicek committed Nov 08, 2017 31 32 33 34 35 36 `````` ! Array Arguments REAL, INTENT (IN) :: s_in(mmap) REAL, INTENT (OUT) :: sout(mmap) ! Local Scalars `````` Daniel Wortmann committed Dec 07, 2018 37 `````` INTEGER :: imap,ivac,iz,j,js,k2,l,n,iv2c,iv2,na,ioff,i `````` Gregor Michalicek committed Nov 08, 2017 38 39 40 41 `````` REAL :: dvol,dxn,dxn2,dxn4,volnstr2 LOGICAL :: l_pot ! Local Arrays `````` Markus Betzinger committed Apr 26, 2016 42 43 `````` REAL, ALLOCATABLE :: g(:),wght(:) COMPLEX, ALLOCATABLE :: ag3(:),fg3(:) `````` Gregor Michalicek committed Nov 08, 2017 44 45 46 47 48 49 50 `````` ! calculate the coefficients of the g-matrix ! for the m.t. and vacuum region l_pot = .FALSE. IF (PRESENT(lpot)) l_pot = lpot ! for potential mixing `````` Daniel Wortmann committed Feb 13, 2017 51 `````` ALLOCATE (g(mmap),wght(vacuum%nmzd),ag3(stars%ng3),fg3(stars%ng3)) `````` Gregor Michalicek committed Nov 08, 2017 52 53 54 55 56 57 58 `````` g = 0.0 imap = 2 * stars%ng3 ! complex values without invs IF (sym%invs) imap = stars%ng3 ! only real values with invs iv2 = 2 IF (sym%invs2) iv2 = 1 `````` Markus Betzinger committed Apr 26, 2016 59 60 61 62 63 `````` ! metric for MT is r^2 dr/di di = r^3 dx ; divided by r^4 to ! compensate use of n(r) * r^2 in array rho ! simpson integration used, weights for first and last point: 1 ! weights forthe rest alternating: 2 or 4 na = 1 `````` Gregor Michalicek committed Nov 08, 2017 64 65 66 67 68 69 `````` DO n = 1, atoms%ntype dxn = atoms%neq(n) * atoms%dx(n) / 3.0e0 dxn2 =2.0e0 * dxn dxn4 =4.0e0 * dxn DO l = 0, sphhar%nlh(atoms%ntypsy(na)) `````` Markus Betzinger committed Apr 26, 2016 70 `````` imap = imap + 1 `````` Gregor Michalicek committed Nov 08, 2017 71 `````` g(imap) = dxn / atoms%rmsh(1,n) `````` Markus Betzinger committed Apr 26, 2016 72 `````` IF (.NOT.l_pot) THEN `````` Gregor Michalicek committed Nov 08, 2017 73 `````` DO j = 2, atoms%jri(n) - 1, 2 `````` Markus Betzinger committed Apr 26, 2016 74 `````` imap = imap + 2 `````` Gregor Michalicek committed Nov 08, 2017 75 76 77 `````` g(imap-1) = dxn4 / atoms%rmsh(j,n) g(imap) = dxn2 / atoms%rmsh(j+1,n) END DO `````` Markus Betzinger committed Apr 26, 2016 78 79 `````` ! CHANGE JR 96/12/01 ! take care when jri(n) is even `````` Gregor Michalicek committed Nov 08, 2017 80 81 `````` imap = imap + 1 - MOD(atoms%jri(n),2) g(imap) = dxn / atoms%rmsh(atoms%jri(n),n) `````` Markus Betzinger committed Apr 26, 2016 82 `````` ELSE `````` Gregor Michalicek committed Nov 08, 2017 83 84 `````` ! for the potential multiply by r^4 DO j = 2, atoms%jri(n) - 1, 2 `````` Markus Betzinger committed Apr 26, 2016 85 `````` imap = imap + 2 `````` Gregor Michalicek committed Nov 08, 2017 86 87 88 89 90 91 92 `````` g(imap-1) = dxn4 * atoms%rmsh(j,n)**3 g(imap) = dxn2 * atoms%rmsh(j+1,n)**3 END DO imap = imap + 1 - MOD(atoms%jri(n),2) g(imap) = dxn * atoms%rmsh(atoms%jri(n),n)**3 END IF END DO `````` Markus Betzinger committed Apr 26, 2016 93 `````` na = na + atoms%neq(n) `````` Gregor Michalicek committed Nov 08, 2017 94 95 `````` END DO `````` Markus Betzinger committed Apr 26, 2016 96 97 98 `````` ! vacuum contribution IF (input%film) THEN dvol = cell%area*vacuum%delz `````` Gregor Michalicek committed Nov 08, 2017 99 100 101 102 103 `````` ! nvac=1 if (zrfs.or.invs) IF (vacuum%nvac.EQ.1) dvol = dvol + dvol IF (oneD%odi%d1) dvol = cell%area*vacuum%delz DO ivac = 1, vacuum%nvac ! G||=0 components `````` Markus Betzinger committed Apr 26, 2016 104 `````` ! `````` Gregor Michalicek committed Nov 08, 2017 105 106 `````` ! use 7-point simpson integration in accordance to intgz0.f ! calculate weights for integration `````` Markus Betzinger committed Apr 26, 2016 107 `````` CALL metr_z0(vacuum%nmz,wght) `````` Gregor Michalicek committed Nov 08, 2017 108 `````` DO iz = 1, vacuum%nmz `````` Markus Betzinger committed Apr 26, 2016 109 110 `````` imap = imap + 1 IF (oneD%odi%d1) THEN `````` Gregor Michalicek committed Nov 08, 2017 111 `````` g(imap) = wght(iz) * dvol * (cell%z1+(iz-1)*vacuum%delz) `````` Markus Betzinger committed Apr 26, 2016 112 `````` ELSE `````` Gregor Michalicek committed Nov 08, 2017 113 114 115 116 117 118 `````` g(imap) = wght(iz) * dvol END IF END DO ! G||.ne.0 components ! ! calculate weights for integration `````` Markus Betzinger committed Apr 26, 2016 119 `````` CALL metr_z0(vacuum%nmzxy,wght) `````` Gregor Michalicek committed Nov 08, 2017 120 121 `````` DO iv2c = 1, iv2 DO k2 = 1, oneD%odi%nq2 - 1 `````` Markus Betzinger committed Apr 26, 2016 122 123 124 `````` IF (oneD%odi%d1) THEN DO iz = 1,vacuum%nmzxy imap = imap + 1 `````` Gregor Michalicek committed Nov 08, 2017 125 126 `````` g(imap) = wght(iz) * oneD%odi%nst2(k2) * dvol * (cell%z1+(iz-1)*vacuum%delz) END DO `````` Markus Betzinger committed Apr 26, 2016 127 `````` ELSE `````` Gregor Michalicek committed Nov 08, 2017 128 129 `````` volnstr2 = dvol * stars%nstr2(k2) DO iz = 1, vacuum%nmzxy `````` Markus Betzinger committed Apr 26, 2016 130 `````` imap = imap + 1 `````` Gregor Michalicek committed Nov 08, 2017 131 132 `````` g(imap) = wght(iz) * volnstr2 END DO `````` Markus Betzinger committed Apr 26, 2016 133 `````` END IF `````` Gregor Michalicek committed Nov 08, 2017 134 135 136 `````` END DO END DO END DO `````` Markus Betzinger committed Apr 26, 2016 137 `````` END IF `````` Gregor Michalicek committed Nov 08, 2017 138 `````` `````` Gregor Michalicek committed Nov 10, 2017 139 140 `````` ! Apply metric to interstitial region (metric here = step function) ! + multiply metric g with s_in for MT and vacuum contributions (store in sout) `````` Gregor Michalicek committed Nov 08, 2017 141 142 `````` DO js = 1, input%jspins ! map s_in on a complex help array ag3 `````` Markus Betzinger committed Apr 26, 2016 143 `````` IF (sym%invs) THEN `````` Gregor Michalicek committed Nov 08, 2017 144 `````` DO imap = 1, stars%ng3 `````` Markus Betzinger committed Apr 26, 2016 145 `````` ag3(imap) = CMPLX(s_in(imap+nmaph*(js-1)),0.0) `````` Gregor Michalicek committed Nov 08, 2017 146 `````` END DO `````` Markus Betzinger committed Apr 26, 2016 147 `````` ELSE `````` Gregor Michalicek committed Nov 08, 2017 148 149 150 `````` DO imap = 1, stars%ng3 ag3(imap) = CMPLX(s_in(imap+nmaph*(js-1)),s_in(imap+stars%ng3+nmaph*(js-1))) END DO `````` Markus Betzinger committed Apr 26, 2016 151 `````` ENDIF `````` Gregor Michalicek committed Nov 08, 2017 152 153 154 `````` CALL convol(stars,fg3,ag3,stars%ufft) `````` Markus Betzinger committed Apr 26, 2016 155 `````` IF (sym%invs) THEN `````` Gregor Michalicek committed Nov 10, 2017 156 `````` ! interstitial `````` Gregor Michalicek committed Nov 08, 2017 157 158 159 `````` DO imap = 1, stars%ng3 sout(imap+nmaph*(js-1)) = cell%omtil * REAL(fg3(imap)) END DO `````` Gregor Michalicek committed Nov 10, 2017 160 `````` ! MT + vacuum `````` Gregor Michalicek committed Nov 08, 2017 161 162 163 `````` DO imap = stars%ng3+1, nmaph sout(imap+nmaph*(js-1)) = g(imap) * s_in(imap+nmaph*(js-1)) END DO `````` Markus Betzinger committed Apr 26, 2016 164 `````` ELSE `````` Gregor Michalicek committed Nov 10, 2017 165 `````` ! interstitial `````` Gregor Michalicek committed Nov 08, 2017 166 167 168 169 `````` DO imap = 1, stars%ng3 sout(imap+nmaph*(js-1)) = cell%omtil * REAL(fg3(imap)) sout(imap+stars%ng3+nmaph*(js-1)) = cell%omtil * AIMAG(fg3(imap)) END DO `````` Gregor Michalicek committed Nov 10, 2017 170 `````` ! MT + vacuum `````` Gregor Michalicek committed Nov 08, 2017 171 172 173 174 175 `````` DO imap = 2 * stars%ng3 + 1, nmaph sout(imap+nmaph*(js-1)) = g(imap) * s_in(imap+nmaph*(js-1)) END DO END IF END DO `````` Markus Betzinger committed Apr 26, 2016 176 177 `````` IF (noco%l_noco) THEN `````` Gregor Michalicek committed Nov 08, 2017 178 179 180 181 182 183 184 185 186 187 `````` DO imap = 1, stars%ng3 ag3(imap) = CMPLX(s_in(2*nmaph + imap),s_in(2*nmaph + stars%ng3 + imap)) END DO CALL convol(stars,fg3,ag3,stars%ufft) DO imap = 1, stars%ng3 sout(2*nmaph + imap) = cell%omtil * REAL(fg3(imap)) sout(2*nmaph + stars%ng3 + imap) = cell%omtil * AIMAG(fg3(imap)) END DO `````` Markus Betzinger committed Apr 26, 2016 188 `````` IF (input%film) THEN `````` Gregor Michalicek committed Nov 08, 2017 189 190 191 192 193 194 195 `````` ! js runs over the real and imaginary part of the vacuum density ! coefficients (not the spin). ioff = 2*stars%ng3 + mapmt ! (for complex values) IF (sym%invs) ioff = stars%ng3 + mapmt ! (real values if sym%invs) DO js = 1, 2 DO imap = 1, mapvac2 / 2 `````` Markus Betzinger committed Apr 26, 2016 196 `````` sout(2*nmaph + 2*stars%ng3 + mapvac2/2*(js-1) + imap) = & `````` Gregor Michalicek committed Nov 08, 2017 197 198 199 200 `````` g(ioff + imap) * s_in(2*nmaph + 2*stars%ng3 + mapvac2/2*(js-1) + imap) END DO END DO END IF `````` Daniel Wortmann committed Dec 07, 2018 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 `````` !mt offdiagonal part imap=2*nmaph + 2*stars%ng3 + mapvac2/2*(js-1) + imap-1 ioff=MERGE(stars%ng3,2*stars%ng2,sym%invs)+1 j=0 IF (noco%l_mtnocopot) THEN na = 1 DO n = 1,atoms%ntype DO l = 0,sphhar%nlh(atoms%ntypsy(na)) DO i = 1,atoms%jri(n) j = j + 1 sout(imap+j) = g(ioff+(j-1)/2)*s_in(imap+j) j = j + 1 sout(imap+j) = g(ioff+(j-1)/2)*s_in(imap+j) END DO END DO na = na + atoms%neq(n) END DO END IF `````` Gregor Michalicek committed Nov 08, 2017 219 `````` END IF `````` Markus Betzinger committed Apr 26, 2016 220 `````` `````` Gregor Michalicek committed Nov 08, 2017 221 222 223 `````` ! density matrix IF (atoms%n_u > 0) THEN j = input%jspins * nmaph `````` Markus Betzinger committed Apr 26, 2016 224 `````` IF (noco%l_noco) THEN `````` Gregor Michalicek committed Nov 08, 2017 225 `````` j = j + 2 * stars%ng3 `````` Markus Betzinger committed Apr 26, 2016 226 227 `````` IF (input%film) THEN j = j + mapvac2 `````` Gregor Michalicek committed Nov 08, 2017 228 229 `````` END IF END IF `````` Markus Betzinger committed Apr 26, 2016 230 231 `````` DO imap = j+1, j+49*2*input%jspins*atoms%n_u sout(imap) = s_in(imap) `````` Gregor Michalicek committed Nov 08, 2017 232 233 234 `````` END DO END IF `````` Markus Betzinger committed Apr 26, 2016 235 236 237 238 `````` DEALLOCATE (g,wght,ag3,fg3) END SUBROUTINE metric END MODULE m_metric``````