File: initulr.f90

package info (click to toggle)
elkcode 5.4.24-2
  • links: PTS, VCS
  • area: main
  • in suites: buster, sid
  • size: 12,840 kB
  • sloc: f90: 48,415; fortran: 22,457; perl: 965; makefile: 384; sh: 369; python: 105; ansic: 67
file content (129 lines) | stat: -rw-r--r-- 4,243 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129

! Copyright (C) 2018 T. Mueller, J. K. Dewhurst, S. Sharma and E. K. U. Gross.
! This file is distributed under the terms of the GNU General Public License.
! See the file COPYING for license details.

subroutine initulr
use modmain
use modulr
use modomp
implicit none
! local variables
integer ik0,ik,ist,jst
integer iq,ig,i,nthd
real(8) tp(2)
! allocatable arrays
integer, allocatable :: idx(:)
real(8), allocatable :: jlgqr(:,:)
! allocate long-range density and magnetisation arrays
if (allocated(rhormt)) deallocate(rhormt)
allocate(rhormt(npcmtmax,natmtot,nqpt))
if (allocated(rhorir)) deallocate(rhorir)
allocate(rhorir(ngtot,nqpt))
if (allocated(magrmt)) deallocate(magrmt)
if (allocated(magrir)) deallocate(magrir)
if (spinpol) then
  allocate(magrmt(npcmtmax,natmtot,ndmag,nqpt))
  allocate(magrir(ngtot,ndmag,nqpt))
end if
if (allocated(rhoqmt)) deallocate(rhoqmt)
allocate(rhoqmt(npcmtmax,natmtot,nqpt))
if (allocated(rhoqir)) deallocate(rhoqir)
allocate(rhoqir(ngtot,nqpt))
if (allocated(magqmt)) deallocate(magqmt)
if (allocated(magqir)) deallocate(magqir)
if (spinpol) then
  allocate(magqmt(npcmtmax,natmtot,ndmag,nqpt))
  allocate(magqir(ngtot,ndmag,nqpt))
  allocate(mommtu(ndmag,natmtot))
  allocate(mommtru(ndmag,natmtot,nqpt))
end if
! allocate potential and magnetic field arrays
if (allocated(vclru)) deallocate(vclru)
allocate(vclru(nqpt))
if (allocated(vsqmt)) deallocate(vsqmt)
allocate(vsqmt(npcmtmax,natmtot,nqpt))
if (allocated(vsqir)) deallocate(vsqir)
allocate(vsqir(ngtot,nqpt))
if (allocated(bfcru)) deallocate(bfcru)
if (allocated(bsqmt)) deallocate(bsqmt)
if (allocated(bsqir)) deallocate(bsqir)
if (spinpol) then
  allocate(bfcru(nqpt,ndmag))
  allocate(bfcmtru(nqpt,natmtot,ndmag))
  allocate(bsqmt(npcmtmax,natmtot,ndmag,nqpt))
  allocate(bsqir(ngtot,ndmag,nqpt))
end if
! G+Q-vector arrays
if (allocated(vgqc)) deallocate(vgqc)
allocate(vgqc(3,ngvec,nqpt))
if (allocated(gqc)) deallocate(gqc)
allocate(gqc(ngvec,nqpt))
if (allocated(ylmgq)) deallocate(ylmgq)
allocate(ylmgq(lmmaxo,ngvec,nqpt))
if (allocated(sfacgq)) deallocate(sfacgq)
allocate(sfacgq(ngvec,natmtot,nqpt))
if (allocated(expqmt)) deallocate(expqmt)
allocate(expqmt(npcmtmax,natmtot,nqpt))
if (allocated(gclgq)) deallocate(gclgq)
allocate(gclgq(ngvec,nqpt))
if (allocated(jlgqrmt)) deallocate(jlgqrmt)
allocate(jlgqrmt(0:lnpsd,ngvec,nspecies,nqpt))
! find the maximum size of the spherical Bessel function array over all species
call findnjcmax
call omp_hold(nqpt,nthd)
!$OMP PARALLEL DEFAULT(SHARED) &
!$OMP PRIVATE(jlgqr,ig,tp) &
!$OMP NUM_THREADS(nthd)
!$OMP DO
do iq=1,nqpt
  allocate(jlgqr(njcmax,nspecies))
  do ig=1,ngvec
! determine the G+Q-vectors
    vgqc(:,ig,iq)=vgc(:,ig)+vqc(:,iq)
! G+Q-vector length and (theta, phi) coordinates
    call sphcrd(vgqc(:,ig,iq),gqc(ig,iq),tp)
! spherical harmonics for G+Q-vectors
    call genylm(lmaxo,tp,ylmgq(:,ig,iq))
  end do
! generate the spherical Bessel functions j_l(|G+Q|r)
  call genjlgpr(1,gqc(1,iq),jlgqr)
! structure factors for G+Q-vectors
  call gensfacgp(ngvec,vgqc(:,:,iq),ngvec,sfacgq(:,:,iq))
! generate phase factor functions exp(iQ.r) in each muffin-tin
  call genexpmt(1,jlgqr,ylmgq(:,:,iq),ngvec,sfacgq(:,:,iq),expqmt(:,:,iq))
! generate the Coulomb Green's function in G+Q-space
  call gengclgq(.false.,iq,ngvec,gqc(:,iq),gclgq(:,iq))
! compute the spherical Bessel functions j_l(|G+Q|R_mt)
  call genjlgprmt(lnpsd,ngvec,gqc(:,iq),ngvec,jlgqrmt(:,:,:,iq))
  deallocate(jlgqr)
end do
!$OMP END DO
!$OMP END PARALLEL
call omp_free(nthd)
! number of long-range states
nstulr=nstsv*nkpa
! ultracell effective valence charge (this is not necessarily the same as the
! unit cell valence charge times the number of unit cells in the ultracell)
chgvalu=chgval*dble(nkpa)
! allocate eigenvalue array
if (allocated(evalu)) deallocate(evalu)
allocate(evalu(nstulr,nkpt0))
! allocate and initialise occupation number array
if (allocated(occulr)) deallocate(occulr)
allocate(occulr(nstulr,nkpt0))
allocate(idx(nstulr))
do ik0=1,nkpt0
  ik=(ik0-1)*nkpa+1
  call sortidx(nstulr,occsv(1,ik),idx)
  do ist=1,nstulr
    i=idx(nstulr-ist+1)-1
    ik=(ik0-1)*nkpa+i/nstsv+1
    jst=mod(i,nstsv)+1
    occulr(ist,ik0)=occsv(jst,ik)
  end do
end do
deallocate(idx)
return
end subroutine