mirror of https://gitlab.com/QEF/q-e.git
O-sesame
git-svn-id: http://qeforge.qe-forge.org/svn/q-e/trunk/espresso@2 c92efa57-630b-4861-b058-cf58834340f0
This commit is contained in:
giannozz
commit
ac9f2144c0
|
|
@ -0,0 +1,36 @@
|
|||
|
||||
include ../make.sys
|
||||
|
||||
|
||||
all: cp90
|
||||
|
||||
# Name of the program
|
||||
PROGNAME= cp.x
|
||||
|
||||
######################################################################
|
||||
|
||||
WRAPPERS= wrapper.o
|
||||
|
||||
# Fortran objects
|
||||
FOBJS= modules.o $(FFT) para.o \
|
||||
read_pseudo.o cplib.o cpr.o input.o sort.o \
|
||||
macdep.o which_dft.o $(WRAPPERS) \
|
||||
restart.o cpr_mod.o cell_module.o cprsub.o cpflush.o
|
||||
|
||||
######################################################################
|
||||
|
||||
default:
|
||||
make $(PROGNAME)
|
||||
|
||||
cp90 : $(FOBJS)
|
||||
$(LNK) -o $(PROGNAME) $(LNKFLAGS) $(FOBJS) ../Modules/*.o cpflush.o \
|
||||
../flib/eispack.o $(LIB)
|
||||
chmod a+r $(PROGNAME)
|
||||
chmod a+x $(PROGNAME)
|
||||
|
||||
|
||||
clean :
|
||||
- rm -f *.o *.i core* fort* *.mod *.s *.d work.pc
|
||||
|
||||
include .dependencies
|
||||
include ../make.rules
|
||||
|
|
@ -0,0 +1,430 @@
|
|||
MODULE cell_module
|
||||
!------------------------------------------------------------------------------!
|
||||
USE kinds, ONLY : dbl
|
||||
!
|
||||
IMPLICIT NONE
|
||||
SAVE
|
||||
!
|
||||
PRIVATE
|
||||
PUBLIC :: boxdimensions, r_to_s, s_to_r, cell_init
|
||||
|
||||
|
||||
!! ... periodicity box
|
||||
!! ... In the matrix "a" every row is the vector of each side of the cell in the real
|
||||
!! ... space
|
||||
TYPE boxdimensions
|
||||
REAL(dbl) a(3,3) ! direct lattice generators
|
||||
REAL(dbl) m1(3,3) ! reciprocal lattice generators
|
||||
REAL(dbl) omega ! cell volume = determinant of a
|
||||
REAL(dbl) g(3,3) ! metric tensor
|
||||
REAL (dbl), DIMENSION (3,3) :: hmat
|
||||
REAL (dbl), DIMENSION (3,3) :: h_inv
|
||||
REAL (dbl) :: deth
|
||||
INTEGER :: perd(3)
|
||||
END TYPE boxdimensions
|
||||
|
||||
INTERFACE cell_init
|
||||
MODULE PROCEDURE cell_init_ht, cell_init_a
|
||||
END INTERFACE
|
||||
!
|
||||
! Cell variables read from stdin
|
||||
! They should never be changed.
|
||||
|
||||
REAL(KIND=8), PUBLIC :: h(3,3), deth, hold(3,3), wmass
|
||||
!
|
||||
REAL(dbl), PRIVATE :: A1(3)
|
||||
REAL(dbl), PRIVATE :: A2(3)
|
||||
REAL(dbl), PRIVATE :: A3(3)
|
||||
|
||||
REAL(dbl), PRIVATE :: celldm(6)
|
||||
INTEGER, PRIVATE :: IBRAV
|
||||
|
||||
REAL(dbl), PRIVATE :: PRESS
|
||||
REAL(dbl), PRIVATE :: WC
|
||||
|
||||
LOGICAL, PRIVATE :: taxis(3) = (/ .FALSE., .FALSE., .FALSE. /)
|
||||
|
||||
DATA IBRAV/-1/
|
||||
DATA WC/0.0d0/
|
||||
|
||||
|
||||
contains
|
||||
|
||||
!------------------------------------------------------------------------------!
|
||||
|
||||
SUBROUTINE UPDATECELL(box_tm2,box_tm1,box_t0,box_tp1)
|
||||
type (boxdimensions) :: box_tm2,box_tm1,box_t0,box_tp1
|
||||
box_tm2 = box_tm1
|
||||
box_tm1 = box_t0
|
||||
box_t0 = box_tp1
|
||||
box_t0%g = MATMUL(box_t0%a(:,:),TRANSPOSE(box_t0%a(:,:)))
|
||||
call gethinv(box_t0)
|
||||
RETURN
|
||||
END SUBROUTINE UPDATECELL
|
||||
|
||||
!------------------------------------------------------------------------------!
|
||||
|
||||
SUBROUTINE get_lattice_vectors(a1_out,a2_out,a3_out)
|
||||
REAL(dbl), intent(out) :: a1_out(3), a2_out(3), a3_out(3)
|
||||
a1_out = a1
|
||||
a2_out = a2
|
||||
a3_out = a3
|
||||
RETURN
|
||||
END SUBROUTINE get_lattice_vectors
|
||||
|
||||
!------------------------------------------------------------------------------!
|
||||
|
||||
SUBROUTINE get_celldm( ibrav_out, celldm_out)
|
||||
REAL(dbl), intent(out) :: celldm_out(6)
|
||||
INTEGER, intent(out) :: ibrav_out
|
||||
ibrav_out = ibrav
|
||||
celldm_out = celldm
|
||||
RETURN
|
||||
END SUBROUTINE get_celldm
|
||||
|
||||
!------------------------------------------------------------------------------!
|
||||
|
||||
|
||||
!------------------------------------------------------------------------------!
|
||||
! ... set box
|
||||
! ... box%m1(i,1) == b1(i)
|
||||
! ... box%a(1,i) == a1(i)
|
||||
! ... box%omega == volume
|
||||
! ... box%g(i,j) == metric tensor G
|
||||
!------------------------------------------------------------------------------!
|
||||
|
||||
SUBROUTINE cell_init_ht( box, ht )
|
||||
TYPE (boxdimensions) :: box
|
||||
REAL(dbl) :: ht(3,3)
|
||||
box%a = ht
|
||||
box%hmat = TRANSPOSE(ht)
|
||||
CALL gethinv(box)
|
||||
box%g = MATMUL(box%a(:,:),TRANSPOSE(box%a(:,:)))
|
||||
RETURN
|
||||
END SUBROUTINE
|
||||
|
||||
!------------------------------------------------------------------------------!
|
||||
|
||||
SUBROUTINE cell_init_a( box, a1, a2, a3 )
|
||||
TYPE (boxdimensions) :: box
|
||||
REAL(dbl) :: a1(3), a2(3), a3(3)
|
||||
INTEGER :: i
|
||||
DO i=1,3
|
||||
box%a(1,I) = A1(I)
|
||||
box%a(2,I) = A2(I)
|
||||
box%a(3,I) = A3(I)
|
||||
box%hmat(I,1) = A1(I)
|
||||
box%hmat(I,2) = A2(I)
|
||||
box%hmat(I,3) = A3(I)
|
||||
END DO
|
||||
CALL gethinv(box)
|
||||
box%g = MATMUL(box%a(:,:),TRANSPOSE(box%a(:,:)))
|
||||
RETURN
|
||||
END SUBROUTINE
|
||||
|
||||
!------------------------------------------------------------------------------!
|
||||
|
||||
SUBROUTINE R_TO_S (R,S,box)
|
||||
REAL(dbl), intent(out) :: S(3)
|
||||
REAL(dbl), intent(in) :: R(3)
|
||||
type (boxdimensions), intent(in) :: box
|
||||
integer i,j
|
||||
DO I=1,3
|
||||
S(I) = 0.D0
|
||||
DO J=1,3
|
||||
S(I) = S(I) + R(J)*box%m1(J,I)
|
||||
END DO
|
||||
END DO
|
||||
RETURN
|
||||
END SUBROUTINE R_TO_S
|
||||
|
||||
!------------------------------------------------------------------------------!
|
||||
|
||||
SUBROUTINE S_TO_R (S,R,box)
|
||||
REAL(dbl), intent(in) :: S(3)
|
||||
REAL(dbl), intent(out) :: R(3)
|
||||
type (boxdimensions), intent(in) :: box
|
||||
integer i,j
|
||||
DO I=1,3
|
||||
R(I) = 0.D0
|
||||
DO J=1,3
|
||||
R(I) = R(I) + S(J)*box%a(J,I)
|
||||
END DO
|
||||
END DO
|
||||
RETURN
|
||||
END SUBROUTINE S_TO_R
|
||||
|
||||
!------------------------------------------------------------------------------!
|
||||
! ----------------------------------------------
|
||||
! BEGIN manual
|
||||
|
||||
SUBROUTINE RECIPS(alat,a1,a2,a3,b1,b2,b3,den)
|
||||
|
||||
! this routine computes:
|
||||
! b1, b2, b3 the reciprocal lattice base vectors
|
||||
! in units of [2pi / alat]
|
||||
!
|
||||
! a2 x a3
|
||||
! b1 = alat -------------- [ 2pi / alat ]
|
||||
! a1 ( a2 x a3 )
|
||||
!
|
||||
! ----------------------------------------------
|
||||
! END manual
|
||||
|
||||
REAL(dbl), intent(in) :: alat
|
||||
REAL(dbl), intent(in) :: a1(3), a2(3), a3(3)
|
||||
REAL(dbl), intent(out) :: b1(3), b2(3), b3(3)
|
||||
REAL(dbl), intent(out) :: den
|
||||
INTEGER I,J,K,IPERM,IR,L
|
||||
REAL(dbl) S
|
||||
DEN=0.D0
|
||||
I=1; J=2; K=3; S=1.D0
|
||||
SIG: DO
|
||||
DO IPERM=1,3
|
||||
DEN=DEN+S*A1(I)*A2(J)*A3(K)
|
||||
L=I; I=J; J=K; K=L
|
||||
END DO
|
||||
I=2; J=1; K=3; S=-S
|
||||
IF(S.LT.0.D0) CYCLE SIG
|
||||
EXIT SIG
|
||||
END DO SIG
|
||||
I=1; J=2; K=3
|
||||
DEN=ALAT/ABS(DEN)
|
||||
DO IR=1,3
|
||||
B1(IR)=DEN*(A2(J)*A3(K)-A2(K)*A3(J))
|
||||
B2(IR)=DEN*(A3(J)*A1(K)-A3(K)*A1(J))
|
||||
B3(IR)=DEN*(A1(J)*A2(K)-A1(K)*A2(J))
|
||||
L=I; I=J; J=K; K=L
|
||||
END DO
|
||||
RETURN
|
||||
END SUBROUTINE RECIPS
|
||||
|
||||
!
|
||||
!=======================================================================
|
||||
!
|
||||
|
||||
SUBROUTINE LATGEN(IBRAV,CELLDM,A1,A2,A3,OMEGA)
|
||||
|
||||
!.........SETS UP THE CRYSTALLOGRAPHIC VECTORS A1,A2, AND A3.
|
||||
!.........IBRAV AND CELLDM ARE DEFINED IN THE TABLE AT THE BEGINNING
|
||||
!.........OF SUBROUTINE KSUM
|
||||
|
||||
IMPLICIT NONE
|
||||
|
||||
integer, intent(in) :: ibrav
|
||||
REAL(dbl), intent(in) :: celldm(6)
|
||||
REAL(dbl), intent(out) :: a1(3), a2(3), a3(3)
|
||||
REAL(dbl), intent(out) :: omega
|
||||
|
||||
INTEGER IR,I,J,K,L,IPERM
|
||||
REAL(dbl) TERM,CBYA,SR3,TERM1,TERM2,SIN,S,SINGAM
|
||||
DATA SR3/1.732051D0/
|
||||
DO IR=1,3
|
||||
A1(IR)=0.D0
|
||||
A2(IR)=0.D0
|
||||
A3(IR)=0.D0
|
||||
END DO
|
||||
IF(IBRAV.LT.0 .OR. IBRAV.GT.14) GO TO 110
|
||||
GO TO (2,4,6,8,10,12,14,16,18,20,22,24,26,28),IBRAV
|
||||
2 A1(1)=CELLDM(1)
|
||||
A2(2)=CELLDM(1)
|
||||
A3(3)=CELLDM(1)
|
||||
GO TO 100
|
||||
4 TERM=CELLDM(1)/2.D0
|
||||
A1(1)=-TERM
|
||||
A1(3)=TERM
|
||||
A2(2)=TERM
|
||||
A2(3)=TERM
|
||||
A3(1)=-TERM
|
||||
A3(2)=TERM
|
||||
GO TO 100
|
||||
6 TERM=CELLDM(1)/2.D0
|
||||
DO IR=1,3
|
||||
A1(IR)=TERM
|
||||
A2(IR)=TERM
|
||||
A3(IR)=TERM
|
||||
END DO
|
||||
A2(1)=-TERM
|
||||
A3(1)=-TERM
|
||||
A3(2)=-TERM
|
||||
GO TO 100
|
||||
8 CBYA=CELLDM(3)
|
||||
A1(1)=CELLDM(1)
|
||||
A2(1)=-CELLDM(1)/2.D0
|
||||
A2(2)=CELLDM(1)*SR3/2.D0
|
||||
A3(3)=CELLDM(1)*CBYA
|
||||
GO TO 100
|
||||
10 TERM1=SQRT(1.D0+2.D0*CELLDM(4))
|
||||
TERM2=SQRT(1.D0-CELLDM(4))
|
||||
A1(2)=1.414214D0*CELLDM(1)*TERM2/SR3
|
||||
A1(3)=CELLDM(1)*TERM1/SR3
|
||||
A2(1)=CELLDM(1)*TERM2/1.414214D0
|
||||
A2(2)=-A2(1)/SR3
|
||||
A2(3)=A1(3)
|
||||
A3(1)=-A2(1)
|
||||
A3(2)=A2(2)
|
||||
A3(3)=A1(3)
|
||||
GO TO 100
|
||||
12 CBYA=CELLDM(3)
|
||||
A1(1)=CELLDM(1)
|
||||
A2(2)=CELLDM(1)
|
||||
A3(3)=CELLDM(1)*CBYA
|
||||
GO TO 100
|
||||
14 CBYA=CELLDM(3)
|
||||
A1(1)=CELLDM(1)/2.D0
|
||||
A1(2)=A1(1)
|
||||
A1(3)=CBYA*CELLDM(1)/2.D0
|
||||
A2(1)=A1(1)
|
||||
A2(2)=-A1(1)
|
||||
A2(3)=A1(3)
|
||||
A3(1)=-A1(1)
|
||||
A3(2)=-A1(1)
|
||||
A3(3)=A1(3)
|
||||
GO TO 100
|
||||
16 A1(1)=CELLDM(1)
|
||||
A2(2)=CELLDM(1)*CELLDM(2)
|
||||
A3(3)=CELLDM(1)*CELLDM(3)
|
||||
GO TO 100
|
||||
18 GO TO 110
|
||||
20 GO TO 110
|
||||
22 GO TO 110
|
||||
24 SIN=SQRT(1.D0-CELLDM(4)**2)
|
||||
A1(1)=CELLDM(1)
|
||||
A2(1)=CELLDM(1)*CELLDM(2)*CELLDM(4)
|
||||
A2(2)=CELLDM(1)*CELLDM(2)*SIN
|
||||
A3(3)=CELLDM(1)*CELLDM(3)
|
||||
GO TO 100
|
||||
26 GO TO 110
|
||||
28 SINGAM=SQRT(1.D0-CELLDM(6)**2)
|
||||
TERM=SQRT((1.D0+2.D0*CELLDM(4)*CELLDM(5)*CELLDM(6) &
|
||||
-CELLDM(4)**2-CELLDM(5)**2-CELLDM(6)**2)/ (1.D0-CELLDM(6)**2))
|
||||
A1(1)=CELLDM(1)
|
||||
A2(1)=CELLDM(1)*CELLDM(2)*CELLDM(6)
|
||||
A2(2)=CELLDM(1)*CELLDM(2)*SINGAM
|
||||
A3(1)=CELLDM(1)*CELLDM(3)*CELLDM(5)
|
||||
A3(2)=CELLDM(1)*CELLDM(3)* (CELLDM(4)-CELLDM(5)*CELLDM(6))/SINGAM
|
||||
A3(3)=CELLDM(1)*CELLDM(3)*TERM
|
||||
100 OMEGA=0.D0
|
||||
S=1.D0; I=1; J=2; K=3
|
||||
101 DO 102 IPERM=1,3
|
||||
OMEGA=OMEGA+S*A1(I)*A2(J)*A3(K)
|
||||
L=I; I=J; J=K; K=L
|
||||
102 CONTINUE
|
||||
I=2; J=1; K=3; S=-S
|
||||
IF(S.LT.0.D0) GO TO 101
|
||||
OMEGA=ABS(OMEGA)
|
||||
RETURN
|
||||
110 WRITE(6,120) IBRAV
|
||||
120 FORMAT(' BRAVAIS LATTICE',I3,' NOT PROGRAMMED. STOPPING')
|
||||
STOP
|
||||
END SUBROUTINE LATGEN
|
||||
|
||||
!
|
||||
!------------------------------------------------------------------------------!
|
||||
SUBROUTINE gethinv(box)
|
||||
IMPLICIT NONE
|
||||
TYPE (boxdimensions), INTENT (INOUT) :: box
|
||||
REAL (dbl), DIMENSION (3,3) :: hmat, hmati
|
||||
REAL (dbl) :: odet
|
||||
|
||||
hmat = box%hmat
|
||||
box%deth = hmat(1,1)*(hmat(2,2)*hmat(3,3)-hmat(2,3)*hmat(3,2)) + &
|
||||
hmat(1,2)*(hmat(2,3)*hmat(3,1)-hmat(2,1)*hmat(3,3)) + &
|
||||
hmat(1,3)*(hmat(2,1)*hmat(3,2)-hmat(2,2)*hmat(3,1))
|
||||
IF (box%deth<1.E-10) CALL error('gethinv', &
|
||||
'box determinant too small',1)
|
||||
odet = 1._dbl/box%deth
|
||||
hmati(1,1) = (hmat(2,2)*hmat(3,3)-hmat(2,3)*hmat(3,2))*odet
|
||||
hmati(2,2) = (hmat(1,1)*hmat(3,3)-hmat(1,3)*hmat(3,1))*odet
|
||||
hmati(3,3) = (hmat(1,1)*hmat(2,2)-hmat(1,2)*hmat(2,1))*odet
|
||||
hmati(1,2) = (hmat(1,3)*hmat(3,2)-hmat(1,2)*hmat(3,3))*odet
|
||||
hmati(2,1) = (hmat(3,1)*hmat(2,3)-hmat(2,1)*hmat(3,3))*odet
|
||||
hmati(1,3) = (hmat(1,2)*hmat(2,3)-hmat(1,3)*hmat(2,2))*odet
|
||||
hmati(3,1) = (hmat(2,1)*hmat(3,2)-hmat(3,1)*hmat(2,2))*odet
|
||||
hmati(2,3) = (hmat(1,3)*hmat(2,1)-hmat(2,3)*hmat(1,1))*odet
|
||||
hmati(3,2) = (hmat(3,1)*hmat(1,2)-hmat(3,2)*hmat(1,1))*odet
|
||||
box%h_inv = hmati
|
||||
|
||||
CALL INV3(box%a,box%m1,box%omega)
|
||||
|
||||
IF(abs(box%omega-box%deth)/abs(box%omega+box%deth).gt.1.0d-12) THEN
|
||||
CALL error('gethinv', 'box determinants are different',1)
|
||||
END IF
|
||||
|
||||
END SUBROUTINE gethinv
|
||||
!
|
||||
!------------------------------------------------------------------------------!
|
||||
!
|
||||
FUNCTION pbc(rin,box,nl) RESULT (rout)
|
||||
IMPLICIT NONE
|
||||
TYPE (boxdimensions) :: box
|
||||
REAL (dbl) :: rin(3)
|
||||
REAL (dbl) :: rout(3), s(3)
|
||||
INTEGER, OPTIONAL :: nl(3)
|
||||
|
||||
s = matmul(box%h_inv(:,:),rin)
|
||||
s = s - box%perd*nint(s)
|
||||
rout = matmul(box%hmat(:,:),s)
|
||||
IF (present(nl)) THEN
|
||||
s = float(nl)
|
||||
rout = rout + matmul(box%hmat(:,:),s)
|
||||
END IF
|
||||
END FUNCTION pbc
|
||||
!
|
||||
!------------------------------------------------------------------------------!
|
||||
!
|
||||
SUBROUTINE get_cell_param(box,cell,ang)
|
||||
IMPLICIT NONE
|
||||
TYPE(boxdimensions), INTENT(in) :: box
|
||||
REAL(dbl), INTENT(out), DIMENSION(3) :: cell
|
||||
REAL(dbl), INTENT(out), DIMENSION(3), OPTIONAL :: ang
|
||||
! This code gets the cell parameters given the h-matrix:
|
||||
! a
|
||||
cell(1)=sqrt(box%hmat(1,1)*box%hmat(1,1)+box%hmat(2,1)*box%hmat(2,1) &
|
||||
+box%hmat(3,1)*box%hmat(3,1))
|
||||
! b
|
||||
cell(2)=sqrt(box%hmat(1,2)*box%hmat(1,2)+box%hmat(2,2)*box%hmat(2,2) &
|
||||
+box%hmat(3,2)*box%hmat(3,2))
|
||||
! c
|
||||
cell(3)=sqrt(box%hmat(1,3)*box%hmat(1,3)+box%hmat(2,3)*box%hmat(2,3) &
|
||||
+box%hmat(3,3)*box%hmat(3,3))
|
||||
IF (PRESENT(ang)) THEN
|
||||
! gamma
|
||||
ang(1)=acos((box%hmat(1,1)*box%hmat(1,2)+ &
|
||||
box%hmat(2,1)*box%hmat(2,2) &
|
||||
+box%hmat(3,1)*box%hmat(3,2))/(cell(1)*cell(2)))
|
||||
! beta
|
||||
ang(2)=acos((box%hmat(1,1)*box%hmat(1,3)+ &
|
||||
box%hmat(2,1)*box%hmat(2,3) &
|
||||
+box%hmat(3,1)*box%hmat(3,3))/(cell(1)*cell(3)))
|
||||
! alpha
|
||||
ang(3)=acos((box%hmat(1,2)*box%hmat(1,3)+ &
|
||||
box%hmat(2,2)*box%hmat(2,3) &
|
||||
+box%hmat(3,2)*box%hmat(3,3))/(cell(2)*cell(3)))
|
||||
! ang=ang*180.0_dbl/pi
|
||||
|
||||
ENDIF
|
||||
END SUBROUTINE get_cell_param
|
||||
|
||||
!=======================================================================
|
||||
!== COMPUTES THE PERIODIC BOUNDARY CONDITIONS IN THE SCALED ==
|
||||
!== VARIABLES SYSTEM ==
|
||||
!=======================================================================
|
||||
|
||||
SUBROUTINE PBCS(X1,Y1,Z1, X2,Y2,Z2, M)
|
||||
USE kinds
|
||||
INTEGER, INTENT(IN) :: M
|
||||
REAL(dbl), INTENT(IN) :: X1,Y1,Z1
|
||||
REAL(dbl), INTENT(OUT) :: X2,Y2,Z2
|
||||
REAL(dbl) MIC
|
||||
MIC = REAL(M)
|
||||
X2 = X1 - DNINT(X1/MIC)*MIC
|
||||
Y2 = Y1 - DNINT(Y1/MIC)*MIC
|
||||
Z2 = Z1 - DNINT(Z1/MIC)*MIC
|
||||
RETURN
|
||||
END SUBROUTINE
|
||||
|
||||
!
|
||||
!------------------------------------------------------------------------------!
|
||||
END MODULE cell_module
|
||||
!------------------------------------------------------------------------------!
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
subroutine cpflush()
|
||||
return
|
||||
end subroutine
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,30 @@
|
|||
!
|
||||
! Copyright (C) 2002 CP90 group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
|
||||
module stre
|
||||
implicit none
|
||||
save
|
||||
real(kind=8) stress(3,3)
|
||||
end module stre
|
||||
|
||||
module dqrad_mod
|
||||
implicit none
|
||||
save
|
||||
real(kind=8),allocatable:: dqrad(:,:,:,:,:,:,:)
|
||||
end module dqrad_mod
|
||||
|
||||
module betax
|
||||
implicit none
|
||||
save
|
||||
integer, parameter:: mmx=5001
|
||||
real(kind=8) :: refg
|
||||
real(kind=8),allocatable:: betagx(:,:,:), dbetagx(:,:,:), &
|
||||
qradx(:,:,:,:,:), dqradx(:,:,:,:,:)
|
||||
end module betax
|
||||
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,224 @@
|
|||
!
|
||||
! Copyright (C) 2002 CP90 group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-------------------------------------------------------------------------
|
||||
subroutine cfft3(f,nr1,nr2,nr3,nr1x,nr2x,nr3x,isign)
|
||||
!-----------------------------------------------------------------------
|
||||
! driver routine for 3d fft using cray's fft routine (by kl)
|
||||
!
|
||||
implicit none
|
||||
integer nr1, nr2, nr3, nr1x, nr2x, nr3x, isign
|
||||
real(kind=8) f(2,nr1x*nr2x*nr3x)
|
||||
!
|
||||
! initialization variables
|
||||
!
|
||||
logical first
|
||||
data first/.true./
|
||||
integer ifax1(19), ifax2(19), ifax3(19)
|
||||
real(kind=8), allocatable :: trig1(:), trig2(:), trig3(:)
|
||||
!
|
||||
! work variables
|
||||
!
|
||||
real(kind=8), allocatable:: work(:)
|
||||
real(kind=8) fac
|
||||
integer inc, jump, lot, i, istart
|
||||
!
|
||||
save first, ifax1, ifax2, ifax3, trig1, trig2, trig3, work
|
||||
!
|
||||
!
|
||||
if (first) then
|
||||
allocate(work(4*nr1x*nr2x*nr3x))
|
||||
allocate(trig1(2*nr1))
|
||||
allocate(trig2(2*nr2))
|
||||
allocate(trig3(2*nr3))
|
||||
call cftfax(nr1,ifax1,trig1)
|
||||
call cftfax(nr2,ifax2,trig2)
|
||||
call cftfax(nr3,ifax3,trig3)
|
||||
first=.false.
|
||||
end if
|
||||
! x - direction
|
||||
inc=2
|
||||
jump=2*nr1x
|
||||
lot=nr3x*nr2x
|
||||
call cfftmlt(f(1,1),f(2,1),work,trig1,ifax1,inc, &
|
||||
& jump,nr1,lot,isign)
|
||||
!
|
||||
! y - direction
|
||||
! inc=2*nr1x
|
||||
! jump=2
|
||||
! lot=nr1x
|
||||
! do i=1,nr3
|
||||
! istart=1+(i-1)*nr2x*nr1x
|
||||
! call cfftmlt(f(1,istart),f(2,istart),work,trig2,
|
||||
! c ifax2,inc,jump,nr2,lot,isign)
|
||||
! end do
|
||||
!
|
||||
inc=2*nr1x
|
||||
jump=2*nr1x*nr2x
|
||||
lot=nr3x
|
||||
do i=1,nr1
|
||||
istart=i
|
||||
call cfftmlt(f(1,istart),f(2,istart),work,trig2, &
|
||||
& ifax2,inc,jump,nr2,lot,isign)
|
||||
end do
|
||||
!
|
||||
! z - direction
|
||||
inc=2*nr1x*nr2x
|
||||
jump=2
|
||||
lot=nr1x*nr2x
|
||||
call cfftmlt(f(1,1),f(2,1),work,trig3,ifax3,inc, &
|
||||
& jump,nr3,lot,isign)
|
||||
!
|
||||
if (isign.eq.-1) then
|
||||
fac=1.d0/dfloat(nr1*nr2*nr3)
|
||||
call SSCAL(2*nr1x*nr2x*nr3x,fac,f,1)
|
||||
end if
|
||||
!
|
||||
return
|
||||
end
|
||||
!-------------------------------------------------------------------------
|
||||
subroutine cfft3b(f,nr1b,nr2b,nr3b,nr1bx,nr2bx,nr3bx,isign)
|
||||
!-----------------------------------------------------------------------
|
||||
! driver routine for 3d fft using cray's fft routine (by kl)
|
||||
!
|
||||
implicit none
|
||||
integer nr1b,nr2b,nr3b,nr1bx,nr2bx,nr3bx,isign
|
||||
real(kind=8) f(2,nr1bx*nr2bx*nr3bx)
|
||||
!
|
||||
! initialization variables
|
||||
!
|
||||
logical first
|
||||
data first/.true./
|
||||
integer ifax1(19), ifax2(19), ifax3(19)
|
||||
real(kind=8), allocatable :: trig1(:), trig2(:), trig3(:)
|
||||
!
|
||||
! work variables
|
||||
!
|
||||
real(kind=8), allocatable:: work(:)
|
||||
real(kind=8) fac
|
||||
integer inc, jump, lot, i, istart
|
||||
save first, ifax1, ifax2,ifax3, trig1, trig2, trig3, work
|
||||
!
|
||||
!
|
||||
if (first) then
|
||||
allocate(work(4*nr1bx*nr2bx*nr3bx))
|
||||
allocate(trig1(2*nr1b))
|
||||
allocate(trig2(2*nr2b))
|
||||
allocate(trig3(2*nr3b))
|
||||
call cftfax(nr1b,ifax1,trig1)
|
||||
call cftfax(nr2b,ifax2,trig2)
|
||||
call cftfax(nr3b,ifax3,trig3)
|
||||
first=.false.
|
||||
end if
|
||||
! x - direction
|
||||
inc=2
|
||||
jump=2*nr1bx
|
||||
lot=nr3bx*nr2bx
|
||||
call cfftmlt(f(1,1),f(2,1),work,trig1,ifax1,inc, &
|
||||
& jump,nr1b,lot,isign)
|
||||
!
|
||||
! y - direction
|
||||
inc=2*nr1bx
|
||||
jump=2
|
||||
lot=nr1bx
|
||||
do i=1,nr3b
|
||||
istart=1+(i-1)*nr2bx*nr1bx
|
||||
call cfftmlt(f(1,istart),f(2,istart),work,trig2, &
|
||||
& ifax2,inc,jump,nr2b,lot,isign)
|
||||
end do
|
||||
!
|
||||
! z - direction
|
||||
inc=2*nr1bx*nr2bx
|
||||
jump=2
|
||||
lot=nr1bx*nr2bx
|
||||
call cfftmlt(f(1,1),f(2,1),work,trig3,ifax3,inc, &
|
||||
& jump,nr3b,lot,isign)
|
||||
!
|
||||
if (isign.eq.-1) then
|
||||
fac=1.d0/dfloat(nr1b*nr2b*nr3b)
|
||||
call SSCAL(2*nr1bx*nr2bx*nr3bx,fac,f,1)
|
||||
end if
|
||||
!
|
||||
return
|
||||
end
|
||||
!-------------------------------------------------------------------------
|
||||
subroutine cfft3s(f,nr1s,nr2s,nr3s,nr1sx,nr2sx,nr3sx,isign)
|
||||
!-----------------------------------------------------------------------
|
||||
! driver routine for 3d fft using cray's fft routine (by kl)
|
||||
!
|
||||
implicit none
|
||||
integer nr1s, nr2s, nr3s, nr1sx, nr2sx, nr3sx, isign
|
||||
real(kind=8) f(2,nr1sx*nr2sx*nr3sx)
|
||||
!
|
||||
! initialization variables
|
||||
!
|
||||
logical first
|
||||
data first/.true./
|
||||
integer ifax1(19), ifax2(19), ifax3(19)
|
||||
real(kind=8), allocatable :: trig1(:), trig2(:), trig3(:)
|
||||
!
|
||||
! work variables
|
||||
!
|
||||
real(kind=8), allocatable:: work(:)
|
||||
real(kind=8) fac
|
||||
integer inc, jump, lot, i, istart
|
||||
!
|
||||
save first, ifax1, ifax2, ifax3, trig1, trig2, trig3, work
|
||||
!
|
||||
!
|
||||
if (first) then
|
||||
allocate(work(4*nr1sx*nr2sx*nr3sx))
|
||||
allocate(trig1(2*nr1s))
|
||||
allocate(trig2(2*nr2s))
|
||||
allocate(trig3(2*nr3s))
|
||||
call cftfax(nr1s,ifax1,trig1)
|
||||
call cftfax(nr2s,ifax2,trig2)
|
||||
call cftfax(nr3s,ifax3,trig3)
|
||||
first=.false.
|
||||
end if
|
||||
!
|
||||
! x - direction
|
||||
inc=2
|
||||
jump=2*nr1sx
|
||||
lot=nr3sx*nr2sx
|
||||
call cfftmlt(f(1,1),f(2,1),work,trig1,ifax1,inc, &
|
||||
& jump,nr1s,lot,isign)
|
||||
!
|
||||
! y - direction
|
||||
! inc=2*nr1sx
|
||||
! jump=2
|
||||
! lot=nr1sx
|
||||
! do i=1,nr3s
|
||||
! istart=1+(i-1)*nr2sx*nr1sx
|
||||
! call cfftmlt(f(1,istart),f(2,istart),work,trig2,
|
||||
! c ifax2,inc,jump,nr2s,lot,isign)
|
||||
! end do
|
||||
!
|
||||
inc=2*nr1sx
|
||||
jump=2*nr1sx*nr2sx
|
||||
lot=nr3sx
|
||||
do i=1,nr1s
|
||||
istart=i
|
||||
call cfftmlt(f(1,istart),f(2,istart),work,trig2, &
|
||||
& ifax2,inc,jump,nr2s,lot,isign)
|
||||
end do
|
||||
!
|
||||
! z - direction
|
||||
inc=2*nr1sx*nr2sx
|
||||
jump=2
|
||||
lot=nr1sx*nr2sx
|
||||
call cfftmlt(f(1,1),f(2,1),work,trig3,ifax3,inc, &
|
||||
& jump,nr3s,lot,isign)
|
||||
!
|
||||
if (isign.eq.-1) then
|
||||
fac=1.d0/dfloat(nr1s*nr2s*nr3s)
|
||||
call SSCAL(2*nr1sx*nr2sx*nr3sx,fac,f,1)
|
||||
end if
|
||||
!
|
||||
return
|
||||
end
|
||||
|
|
@ -0,0 +1,469 @@
|
|||
!
|
||||
! Copyright (C) 2002 CP90 group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
|
||||
module fftw_mod
|
||||
|
||||
integer FFTW_FORWARD,FFTW_BACKWARD
|
||||
parameter (FFTW_FORWARD=-1,FFTW_BACKWARD=1)
|
||||
integer FFTW_ESTIMATE,FFTW_MEASURE
|
||||
parameter (FFTW_ESTIMATE=0,FFTW_MEASURE=1)
|
||||
integer FFTW_OUT_OF_PLACE,FFTW_IN_PLACE,FFTW_USE_WISDOM
|
||||
parameter (FFTW_OUT_OF_PLACE=0)
|
||||
parameter (FFTW_IN_PLACE=8,FFTW_USE_WISDOM=16)
|
||||
|
||||
end module fftw_mod
|
||||
!
|
||||
! Driver routines for fft using fftw libraries (PG). Note that:
|
||||
!
|
||||
! isign=-1 => FFTW_FORWARD
|
||||
! isign= 1 => FFTW_BACKWARD
|
||||
!
|
||||
! a separate initialization ("plan") is needed for each direction
|
||||
!
|
||||
! the one-dimensional fortran routines need an output array
|
||||
! even if the fft is done in-place!
|
||||
!
|
||||
!
|
||||
! The variables "plan" contain C-style pointers. For Origin machines
|
||||
! compiled with "-64" and for Compaq Alpha machines, 64-bit integers
|
||||
! must be used
|
||||
!
|
||||
#if defined(__SGI64) || defined(__COMPAQ)
|
||||
#define POINTER integer(kind=8)
|
||||
#else
|
||||
#define POINTER integer
|
||||
#endif
|
||||
!
|
||||
!-------------------------------------------------------------------------
|
||||
subroutine cfft3(f,nr1,nr2,nr3,nr1x,nr2x,nr3x,isign)
|
||||
!-----------------------------------------------------------------------
|
||||
! driver routine for 3d fft using fftw libraries (PG)
|
||||
!
|
||||
use fftw_mod
|
||||
implicit none
|
||||
!
|
||||
integer nr1, nr2, nr3, nr1x, nr2x, nr3x, isign
|
||||
complex(kind=8) f(nr1x*nr2x*nr3x)
|
||||
!
|
||||
real(kind=8) fac
|
||||
integer ibid
|
||||
!
|
||||
! initialization variables
|
||||
!
|
||||
POINTER plan(2)
|
||||
save plan
|
||||
data plan/0,0/
|
||||
!
|
||||
!
|
||||
if (nr1.ne.nr1x .or. nr2.ne.nr2x .or. nr3.ne.nr3x ) &
|
||||
& call error('cfft3','not implemented',1)
|
||||
if (isign.eq.1) then
|
||||
ibid=1
|
||||
else if (isign.eq.-1) then
|
||||
ibid=2
|
||||
else
|
||||
call error('cfft3','isign unexpected',isign)
|
||||
end if
|
||||
!
|
||||
if (plan(ibid).eq.0) &
|
||||
& call fftw3d_f77_create_plan &
|
||||
& (plan(ibid),nr1,nr2,nr3,isign,FFTW_ESTIMATE+FFTW_IN_PLACE)
|
||||
!
|
||||
call fftwnd_f77_one(plan(ibid), f, 0)
|
||||
!
|
||||
if (isign.eq.-1) then
|
||||
fac=1.0/float(nr1*nr2*nr3)
|
||||
call SCAL(2*nr1*nr2*nr3, fac, f, 1)
|
||||
end if
|
||||
!
|
||||
return
|
||||
end
|
||||
!
|
||||
!-------------------------------------------------------------------------
|
||||
subroutine cfft3s(f,nr1,nr2,nr3,nr1x,nr2x,nr3x,isign)
|
||||
!-----------------------------------------------------------------------
|
||||
! driver routine for 3d fft using fftw libraries (PG)
|
||||
!
|
||||
use fftw_mod
|
||||
implicit none
|
||||
!
|
||||
integer nr1, nr2, nr3, nr1x, nr2x, nr3x, isign
|
||||
complex(kind=8) f(nr1x*nr2x*nr3x)
|
||||
!
|
||||
real(kind=8) fac
|
||||
integer ibid
|
||||
!
|
||||
! initialization variables
|
||||
!
|
||||
POINTER plan(2)
|
||||
save plan
|
||||
data plan/0,0/
|
||||
!
|
||||
!
|
||||
if (nr1.ne.nr1x .or. nr2.ne.nr2x .or. nr3.ne.nr3x ) &
|
||||
& call error('cfft3s','not implemented',1)
|
||||
if (isign.eq.1) then
|
||||
ibid=1
|
||||
else if (isign.eq.-1) then
|
||||
ibid=2
|
||||
else
|
||||
call error('cfft3s','isign unexpected',isign)
|
||||
end if
|
||||
!
|
||||
if (plan(ibid).eq.0) &
|
||||
& call fftw3d_f77_create_plan &
|
||||
& (plan(ibid),nr1,nr2,nr3,isign,FFTW_ESTIMATE+FFTW_IN_PLACE)
|
||||
!
|
||||
call fftwnd_f77_one(plan(ibid), f, 0)
|
||||
!
|
||||
if (isign.eq.-1) then
|
||||
fac=1.0/dfloat(nr1*nr2*nr3)
|
||||
call SCAL(2*nr1*nr2*nr3, fac, f, 1)
|
||||
end if
|
||||
!
|
||||
return
|
||||
end
|
||||
!
|
||||
!-------------------------------------------------------------------------
|
||||
subroutine cfft3b(f,nr1,nr2,nr3,nr1x,nr2x,nr3x,isign)
|
||||
!-----------------------------------------------------------------------
|
||||
! driver routine for 3d fft using fftw libraries (PG)
|
||||
!
|
||||
use fftw_mod
|
||||
implicit none
|
||||
!
|
||||
integer nr1, nr2, nr3, nr1x, nr2x, nr3x, isign
|
||||
complex(kind=8) f(nr1x*nr2x*nr3x)
|
||||
!
|
||||
real(kind=8) fac
|
||||
integer ibid
|
||||
!
|
||||
! initialization variables
|
||||
!
|
||||
POINTER plan(2)
|
||||
save plan
|
||||
data plan/0,0/
|
||||
!
|
||||
!
|
||||
if (nr1.ne.nr1x .or. nr2.ne.nr2x .or. nr3.ne.nr3x ) &
|
||||
& call error('cfft3b','not implemented',1)
|
||||
if (isign.eq.1) then
|
||||
ibid=1
|
||||
else if (isign.eq.-1) then
|
||||
ibid=2
|
||||
else
|
||||
call error('cfft3b','isign unexpected',isign)
|
||||
end if
|
||||
!
|
||||
if (plan(ibid).eq.0) &
|
||||
& call fftw3d_f77_create_plan &
|
||||
& (plan(ibid),nr1,nr2,nr3,isign,FFTW_ESTIMATE+FFTW_IN_PLACE)
|
||||
!
|
||||
call fftwnd_f77_one(plan(ibid), f, 0)
|
||||
!
|
||||
if (isign.eq.-1) then
|
||||
fac=1.0/dfloat(nr1*nr2*nr3)
|
||||
call SCAL(2*nr1*nr2*nr3, fac, f, 1)
|
||||
end if
|
||||
!
|
||||
return
|
||||
end
|
||||
!
|
||||
!----------------------------------------------------------------------
|
||||
subroutine cft_1 (f,m,n,nx,isign,fout)
|
||||
! ===============
|
||||
! driver routine for m 1d complex fft's (dense grid) - fftw
|
||||
! NOTA BENE: not in-place! output in fout
|
||||
!----------------------------------------------------------------------
|
||||
!
|
||||
use fftw_mod
|
||||
implicit none
|
||||
integer m, n, nx, isign
|
||||
complex(kind=8) f(nx*m), fout(nx*m)
|
||||
#ifdef __PARA
|
||||
real(kind=8) fac
|
||||
integer ibid
|
||||
!
|
||||
! initialization variables
|
||||
!
|
||||
POINTER plan(2)
|
||||
save plan
|
||||
data plan/0,0/
|
||||
!
|
||||
!
|
||||
if (isign.eq.1) then
|
||||
ibid =1
|
||||
else if (isign.eq.-1) then
|
||||
ibid =2
|
||||
else
|
||||
call error('cft_1','wrong call',isign)
|
||||
end if
|
||||
!
|
||||
if (plan(ibid).eq.0) &
|
||||
& call fftw_f77_create_plan &
|
||||
& (plan(ibid),n,isign,FFTW_ESTIMATE)
|
||||
!
|
||||
call fftw_f77 (plan(ibid),m,f,1,nx,fout,1,nx)
|
||||
!
|
||||
if (isign.eq.-1) then
|
||||
fac=1.0/float(n)
|
||||
call SCAL(2*nx*m, fac, fout, 1)
|
||||
end if
|
||||
#endif
|
||||
return
|
||||
end
|
||||
!
|
||||
!----------------------------------------------------------------------
|
||||
subroutine cft_2 (f,mplane,n1,n2,nx1,nx2,isign)
|
||||
! ===============
|
||||
! driver routine for mplane 2d complex fft's of lengths n1 and n2
|
||||
! (dense grid) - fftw
|
||||
!----------------------------------------------------------------------
|
||||
!
|
||||
use fftw_mod
|
||||
implicit none
|
||||
integer n1, n2, mplane, nx1, nx2, isign
|
||||
complex(kind=8) f(nx1*nx2*mplane)
|
||||
#ifdef __PARA
|
||||
!
|
||||
real(kind=8) fac
|
||||
integer ibid
|
||||
!
|
||||
! initialization variables
|
||||
!
|
||||
POINTER plan(2)
|
||||
save plan
|
||||
data plan/0,0/
|
||||
!
|
||||
!
|
||||
if (n1.ne.nx1 .or. n2.ne.nx2) &
|
||||
& call error('cft_2','not implemented',1)
|
||||
if (isign.eq.1) then
|
||||
ibid =1
|
||||
else if (isign.eq.-1) then
|
||||
ibid =2
|
||||
else
|
||||
call error('cft_2','wrong call',isign)
|
||||
end if
|
||||
!
|
||||
if (plan(ibid).eq.0) &
|
||||
& call fftw2d_f77_create_plan &
|
||||
& (plan(ibid),n1,n2,isign,FFTW_ESTIMATE+FFTW_IN_PLACE)
|
||||
!
|
||||
call fftwnd_f77 (plan(ibid),mplane,f,1,nx1*nx2,f,1,nx1*nx2)
|
||||
!
|
||||
if (isign.eq.-1) then
|
||||
fac=1.0/float(n1*n2)
|
||||
call SCAL(2*nx1*nx2*mplane, fac, f, 1)
|
||||
end if
|
||||
#endif
|
||||
return
|
||||
end
|
||||
!
|
||||
!----------------------------------------------------------------------
|
||||
subroutine cft_1s (f,m,n,nx,isign,fout)
|
||||
! ===============
|
||||
! driver routine for m 1d complex fft's (sparse grid) - fftw
|
||||
! NOTA BENE: not in-place! output in fout
|
||||
!----------------------------------------------------------------------
|
||||
!
|
||||
use fftw_mod
|
||||
implicit none
|
||||
integer m, n, nx, isign
|
||||
complex(kind=8) f(nx*m), fout(nx*m)
|
||||
#ifdef __PARA
|
||||
real(kind=8) fac
|
||||
integer ibid, isign1
|
||||
!
|
||||
! initialization variables
|
||||
!
|
||||
POINTER plan(2)
|
||||
save plan
|
||||
data plan/0,0/
|
||||
!
|
||||
!
|
||||
if (isign.eq.1.or.isign.eq.2) then
|
||||
isign1=1
|
||||
ibid =1
|
||||
else if (isign.eq.-1.or.isign.eq.-2) then
|
||||
isign1=-1
|
||||
ibid =2
|
||||
else
|
||||
call error('cft_1s','wrong call',isign)
|
||||
end if
|
||||
!
|
||||
if (plan(ibid).eq.0) &
|
||||
& call fftw_f77_create_plan &
|
||||
& (plan(ibid),n,isign1,FFTW_ESTIMATE)
|
||||
!
|
||||
call fftw_f77 (plan(ibid),m,f,1,nx,fout,1,nx)
|
||||
!
|
||||
if (isign.eq.-1.or.isign.eq.-2) then
|
||||
fac=1.0/float(n)
|
||||
call SCAL(2*nx*m, fac, fout, 1)
|
||||
end if
|
||||
#endif
|
||||
return
|
||||
end
|
||||
!
|
||||
!----------------------------------------------------------------------
|
||||
subroutine cft_2s (f,mplane,n1,n2,nx1,nx2,isign,planes)
|
||||
! ===============
|
||||
! driver routine for mplane 2d complex fft's of lengths n1 and n2
|
||||
! (sparse and wavefunction grid) - fftw
|
||||
!----------------------------------------------------------------------
|
||||
!
|
||||
use fftw_mod
|
||||
implicit none
|
||||
integer n1, n2, mplane, nx1, nx2, isign, planes(nx1)
|
||||
complex(kind=8) f(nx1*nx2*mplane)
|
||||
#ifdef __PARA
|
||||
integer nmax
|
||||
parameter (nmax=256)
|
||||
complex(kind=8) fout(nmax)
|
||||
real(kind=8) fac
|
||||
integer ibid, isign1, i, k, m, istrt
|
||||
!
|
||||
! initialization variables
|
||||
!
|
||||
POINTER plan1(2), plan2(2)
|
||||
save plan1, plan2
|
||||
data plan1/0,0/, plan2/0,0/
|
||||
!
|
||||
!
|
||||
if (n1.gt.nmax.or.n2.gt.nmax) &
|
||||
& call error('cft_2s','increase nmax',max(n1,n2))
|
||||
if (n1.ne.nx1 .or. n2.ne.nx2) &
|
||||
& call error('cft_2s','not implemented',1)
|
||||
if (isign.eq.1.or.isign.eq.2) then
|
||||
isign1=1
|
||||
ibid =1
|
||||
else if (isign.eq.-1.or.isign.eq.-2) then
|
||||
isign1=-1
|
||||
ibid =2
|
||||
else
|
||||
call error('cft_2s','wrong call',isign)
|
||||
end if
|
||||
! check how many columns along x are nonzero
|
||||
m=0
|
||||
do i=1,n1
|
||||
m=m+planes(i)
|
||||
end do
|
||||
if (m.gt.n1.or.m.le.0) &
|
||||
& call error('cft_2s','something wrong with planes',1)
|
||||
!
|
||||
if (isign1.eq.1) then
|
||||
! j-direction
|
||||
if (plan2(ibid).eq.0) &
|
||||
& call fftw_f77_create_plan &
|
||||
& (plan2(ibid),n2,isign1,FFTW_ESTIMATE+FFTW_IN_PLACE)
|
||||
!
|
||||
do i=1,n1
|
||||
!
|
||||
! do only ffts on columns (i,*,k) resulting in nonzero components
|
||||
!
|
||||
if (planes(i).eq.1) then
|
||||
call fftw_f77 &
|
||||
& (plan2(ibid),mplane,f(i),nx1,nx1*nx2,fout,0,0)
|
||||
end if
|
||||
end do
|
||||
! i-direction
|
||||
if (plan1(ibid).eq.0) &
|
||||
& call fftw_f77_create_plan &
|
||||
& (plan1(ibid),n1,isign1,FFTW_ESTIMATE+FFTW_IN_PLACE)
|
||||
!
|
||||
call fftw_f77 (plan1(ibid),n2*mplane,f,1,nx1,fout,1,nx1)
|
||||
else
|
||||
! i-direction
|
||||
if (plan1(ibid).eq.0) &
|
||||
& call fftw_f77_create_plan &
|
||||
& (plan1(ibid),n1,isign1,FFTW_ESTIMATE+FFTW_IN_PLACE)
|
||||
!
|
||||
call fftw_f77 (plan1(ibid),n2*mplane,f,1,nx1,fout,1,nx1)
|
||||
! j-direction
|
||||
if (plan2(ibid).eq.0) &
|
||||
& call fftw_f77_create_plan &
|
||||
& (plan2(ibid),n2,isign1,FFTW_ESTIMATE+FFTW_IN_PLACE)
|
||||
!
|
||||
do i=1,n1
|
||||
!
|
||||
! do only ffts on columns (i,*,k) resulting in nonzero components
|
||||
!
|
||||
if (planes(i).eq.1) then
|
||||
call fftw_f77 &
|
||||
& (plan2(ibid),mplane,f(i),nx1,nx1*nx2,fout,0,0)
|
||||
end if
|
||||
end do
|
||||
!
|
||||
fac=1.0/float(n1*n2)
|
||||
call SCAL(2*nx1*nx2*mplane, fac, f, 1)
|
||||
!
|
||||
end if
|
||||
#endif
|
||||
return
|
||||
end
|
||||
!
|
||||
!----------------------------------------------------------------------
|
||||
subroutine cft_b (f,n1,n2,n3,n1x,n2x,n3x,imin3,imax3,isign)
|
||||
! ===============
|
||||
! driver routine for 3d complex fft's on box grid - fftw
|
||||
! fft along xy is done only on planes that correspond to
|
||||
! dense grid planes on the current processor, i.e. planes
|
||||
! with imin3 .le. n3 .le. imax3
|
||||
!----------------------------------------------------------------------
|
||||
!
|
||||
use fftw_mod
|
||||
implicit none
|
||||
integer n1,n2,n3,n1x,n2x,n3x,imin3,imax3, isign
|
||||
complex(kind=8) f(n1x*n2x*n3x)
|
||||
#ifdef __PARA
|
||||
complex(kind=8), allocatable:: faux(:)
|
||||
integer ibid, nplanes, nstart
|
||||
!
|
||||
! initialization variables
|
||||
!
|
||||
integer planz(2), planxy(2)
|
||||
save planz, planxy
|
||||
data planz/0,0/, planxy/0,0/
|
||||
!
|
||||
!
|
||||
if (isign.eq.1) then
|
||||
ibid =1
|
||||
else if (isign.eq.-1) then
|
||||
call error('cft_b','not implemented',isign)
|
||||
end if
|
||||
!
|
||||
if (planz(ibid).eq.0) &
|
||||
& call fftw_f77_create_plan &
|
||||
& (planz(ibid),n3,isign,FFTW_ESTIMATE)
|
||||
!
|
||||
! the fortran fftw routine for 1d fft cannot do fft in-place
|
||||
!
|
||||
if (planxy(ibid).eq.0) &
|
||||
& call fftw2d_f77_create_plan &
|
||||
& (planxy(ibid),n1,n2,isign,FFTW_ESTIMATE)
|
||||
!
|
||||
! for 2d fft it could be done, but it is not convenient
|
||||
!
|
||||
allocate(faux(n1x*n2x*n3x))
|
||||
!
|
||||
! 1d fft along z, output in faux
|
||||
!
|
||||
call fftw_f77(planz(ibid),n1x*n2x,f,n1x*n2x,1,faux,n1x*n2x,1)
|
||||
!
|
||||
! 2d fft on xy planes - only needed planes are transformed
|
||||
! note that all others are left in an unusable state
|
||||
!
|
||||
nplanes=imax3-imin3+1
|
||||
nstart =(imin3-1)*n1x*n2x+1
|
||||
call fftwnd_f77 (planxy(ibid),nplanes,faux(nstart),1,n1x*n2x, &
|
||||
& f(nstart),1,n1x*n2x)
|
||||
deallocate(faux)
|
||||
#endif
|
||||
return
|
||||
end
|
||||
|
|
@ -0,0 +1,512 @@
|
|||
!
|
||||
! Copyright (C) 2002 CP90 group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
! cfft3, cfft3s, cfft3b are the 3d fft for ibm rs6000 essl library
|
||||
! Note that the three routines are equal, and that no initialization
|
||||
! is needed (the initialization arrays are recalculated every time).
|
||||
!
|
||||
!
|
||||
!----------------------------------------------------------------------
|
||||
subroutine cfft3 (f,nr1,nr2,nr3,nr1x,nr2x,nr3x,sign)
|
||||
!----------------------------------------------------------------------
|
||||
!
|
||||
implicit none
|
||||
integer nr1, nr2, nr3, nr1x, nr2x, nr3x, sign
|
||||
complex(kind=8) f(nr1x*nr2x*nr3x)
|
||||
! work variables
|
||||
integer naux, isign
|
||||
parameter (naux=60000)
|
||||
real(kind=8) aux(naux), scale
|
||||
external dscal, dcft
|
||||
!
|
||||
!
|
||||
if (sign.ne.-1 .and. sign.ne.1) &
|
||||
& call error('cfft3','which fft ?', 1)
|
||||
!
|
||||
! IBM uses a different sign convention from the "traditional" one
|
||||
!
|
||||
isign = -sign
|
||||
!
|
||||
if (isign.gt.0) then
|
||||
scale=1.0d0/(nr1*nr2*nr3)
|
||||
else
|
||||
scale=1.0d0
|
||||
end if
|
||||
!
|
||||
call dcft3(f,nr1x,nr1x*nr2x,f,nr1x,nr1x*nr2x,nr1,nr2,nr3, &
|
||||
& isign, scale,aux,naux)
|
||||
!
|
||||
return
|
||||
end
|
||||
!----------------------------------------------------------------------
|
||||
subroutine cfft3s(f,nr1,nr2,nr3,nr1x,nr2x,nr3x,sign)
|
||||
!----------------------------------------------------------------------
|
||||
!
|
||||
implicit none
|
||||
integer nr1, nr2, nr3, nr1x, nr2x, nr3x, sign
|
||||
complex(kind=8) f(nr1x*nr2x*nr3x)
|
||||
! work variables
|
||||
integer naux, isign
|
||||
parameter (naux=60000)
|
||||
real(kind=8) aux(naux), scale
|
||||
external dscal, dcft
|
||||
!
|
||||
!
|
||||
if (sign.ne.-1 .and. sign.ne.1) &
|
||||
& call error('cfft3s','which fft ?', 1)
|
||||
!
|
||||
! IBM uses a different sign convention from the "traditional" one
|
||||
!
|
||||
isign = -sign
|
||||
!
|
||||
if (isign.gt.0) then
|
||||
scale=1.0d0/(nr1*nr2*nr3)
|
||||
else
|
||||
scale=1.0d0
|
||||
end if
|
||||
!
|
||||
call dcft3(f,nr1x,nr1x*nr2x,f,nr1x,nr1x*nr2x,nr1,nr2,nr3, &
|
||||
& isign, scale,aux,naux)
|
||||
!
|
||||
return
|
||||
end
|
||||
!----------------------------------------------------------------------
|
||||
subroutine cfft3b(f,nr1,nr2,nr3,nr1x,nr2x,nr3x,sign)
|
||||
!----------------------------------------------------------------------
|
||||
!
|
||||
implicit none
|
||||
integer nr1, nr2, nr3, nr1x, nr2x, nr3x, sign
|
||||
complex(kind=8) f(nr1x*nr2x*nr3x)
|
||||
! work variables
|
||||
integer naux, isign
|
||||
parameter (naux=60000)
|
||||
real(kind=8) aux(naux), scale
|
||||
external dscal, dcft
|
||||
!
|
||||
!
|
||||
if (sign.ne.-1 .and. sign.ne.1) &
|
||||
& call error('cfft3b','which fft ?', 1)
|
||||
!
|
||||
! IBM uses a different sign convention from the "traditional" one
|
||||
!
|
||||
isign = -sign
|
||||
!
|
||||
if (isign.gt.0) then
|
||||
scale=1.0d0/(nr1*nr2*nr3)
|
||||
else
|
||||
scale=1.0d0
|
||||
end if
|
||||
!
|
||||
call dcft3(f,nr1x,nr1x*nr2x,f,nr1x,nr1x*nr2x,nr1,nr2,nr3, &
|
||||
& isign, scale,aux,naux)
|
||||
!
|
||||
return
|
||||
end
|
||||
!
|
||||
!----------------------------------------------------------------------
|
||||
subroutine cft_1 (f,m,n,nx,sgn,fout)
|
||||
! ===============
|
||||
! driver routine for m 1d complex fft's (dense grid)
|
||||
! nx=n+1 is allowed (in order to avoid memory conflicts)
|
||||
! A separate initialization is stored for sgn=-1 and sgn=+1
|
||||
! NOTA BENE: the output in fout !
|
||||
!----------------------------------------------------------------------
|
||||
!
|
||||
implicit none
|
||||
integer m, n, nx, sgn
|
||||
complex(kind=8) f(nx*m), fout(nx*m)
|
||||
#ifdef __PARA
|
||||
!
|
||||
! initialization variables
|
||||
!
|
||||
logical first(2)
|
||||
data first /.true., .true./
|
||||
integer naux1
|
||||
parameter (naux1=20000)
|
||||
real(kind=8) aux3(naux1,2)
|
||||
save first, aux3
|
||||
!
|
||||
! work variables
|
||||
!
|
||||
integer isign, naux, ibid
|
||||
parameter (naux=15000)
|
||||
real(kind=8) aux(naux), scale
|
||||
external DSCAL
|
||||
!
|
||||
!
|
||||
isign = -sgn
|
||||
!
|
||||
if (isign.eq.1) then
|
||||
ibid =1
|
||||
scale=1.d0/n
|
||||
else if (isign.eq.-1) then
|
||||
ibid =2
|
||||
scale=1.d0
|
||||
else
|
||||
call error('cft_1','wrong call',isign)
|
||||
end if
|
||||
!
|
||||
if (first(ibid)) then
|
||||
call dcft(1,f,1,nx,fout,1,nx,n,m,isign, &
|
||||
& scale,aux3(1,ibid),naux1,aux,naux)
|
||||
first(ibid)=.false.
|
||||
end if
|
||||
!
|
||||
call dcft(0,f,1,nx,fout,1,nx,n,m,isign, &
|
||||
& scale,aux3(1,ibid),naux1,aux,naux)
|
||||
#endif
|
||||
return
|
||||
end
|
||||
!
|
||||
!----------------------------------------------------------------------
|
||||
subroutine cft_2 (f,mplane,n1,n2,nx1,nx2,sgn)
|
||||
! ===============
|
||||
! driver routine for mplane 2d complex fft's of lenghts n1 and n2
|
||||
! (dense grid) nx1 is the actual dimension of f (may differ from n)
|
||||
! for compatibility: nx2=n2, nx2 is not used - uses ESSL
|
||||
! A separate initialization is stored for sgn=-1 and sgn=+1
|
||||
!
|
||||
!----------------------------------------------------------------------
|
||||
implicit none
|
||||
integer n1, n2, mplane, nx1, nx2, sgn
|
||||
complex(kind=8) f(nx1*nx2*mplane)
|
||||
#ifdef __PARA
|
||||
!
|
||||
! initialization variables
|
||||
!
|
||||
logical first(2)
|
||||
data first /.true., .true./
|
||||
integer naux1
|
||||
parameter (naux1=20000)
|
||||
real(kind=8) aux1(naux1,2), aux2(naux1,2)
|
||||
save first, aux1, aux2
|
||||
!
|
||||
integer isign, ibid, m, incx1, incx2, k, istrt, naux
|
||||
parameter (naux=15000)
|
||||
real(kind=8) aux(naux), scale
|
||||
external DSCAL
|
||||
!
|
||||
!
|
||||
isign = -sign(1,sgn)
|
||||
!
|
||||
if(n2.ne.nx2) &
|
||||
& call error('cft_2','no longer implemented',1)
|
||||
!
|
||||
if (isign.eq.1) then
|
||||
ibid=1
|
||||
else if (isign.eq.-1) then
|
||||
ibid=2
|
||||
else
|
||||
call error('cft_2','wrong call',ibid)
|
||||
end if
|
||||
!
|
||||
scale=1.d0
|
||||
!
|
||||
! i - direction ...
|
||||
!
|
||||
incx1=1
|
||||
incx2=nx1
|
||||
m =n2*mplane
|
||||
if (first(ibid)) then
|
||||
call dcft(1,f,incx1,incx2,f,incx1,incx2,n1,m,isign, &
|
||||
& scale,aux1(1,ibid),naux1,aux,naux)
|
||||
end if
|
||||
call dcft(0,f,incx1,incx2,f,incx1,incx2,n1,m,isign, &
|
||||
& scale,aux1(1,ibid),naux1,aux,naux)
|
||||
!
|
||||
! ... j-direction ...
|
||||
!
|
||||
incx1 = nx1
|
||||
incx2 = 1
|
||||
m = n1
|
||||
if (first(ibid)) then
|
||||
call dcft(1,f,incx1,incx2,f,incx1,incx2,n2, &
|
||||
& m,isign,scale,aux2(1,ibid),naux1,aux,naux)
|
||||
first(ibid)=.false.
|
||||
end if
|
||||
!
|
||||
do k= 1,mplane
|
||||
istrt = 1 + (k-1)*nx1*n2
|
||||
call dcft(0,f(istrt),incx1,incx2,f(istrt),incx1,incx2,n2, &
|
||||
& m,isign,scale,aux2(1,ibid),naux1,aux,naux)
|
||||
end do
|
||||
!
|
||||
if (isign.eq.1) call DSCAL(2*nx1*n2*mplane,1d0/(n1*n2),f,1)
|
||||
!
|
||||
#endif
|
||||
return
|
||||
end
|
||||
!
|
||||
!----------------------------------------------------------------------
|
||||
subroutine cft_1s (f,m,n,nx,sgn,fout)
|
||||
! ===============
|
||||
! driver routine for m 1d complex fft's (sparse grid)
|
||||
! nx=n+1 is allowed (in order to avoid memory conflicts)
|
||||
! On input, sgn=+/-1 for charge density, sgn=+/-2 for wavefunctions
|
||||
! A separate initialization is stored for each of the cases:
|
||||
! sgn=-1, sgn=-2, sgn=+1, and sgn=+2 !!!
|
||||
! NOTA BENE: the output is in fout
|
||||
!----------------------------------------------------------------------
|
||||
!
|
||||
implicit none
|
||||
integer m, n, nx, sgn
|
||||
complex(kind=8) f(nx*m), fout(nx*m)
|
||||
#ifdef __PARA
|
||||
!
|
||||
! initialization variables
|
||||
!
|
||||
logical first(2,2)
|
||||
data first /.true., .true., .true., .true./
|
||||
integer naux1
|
||||
parameter (naux1=20000)
|
||||
real(kind=8) aux3(naux1,2,2)
|
||||
save first, aux3
|
||||
!
|
||||
! work variables
|
||||
!
|
||||
integer isign, sign, naux, itype, ibid
|
||||
parameter (naux=15000)
|
||||
real(kind=8) aux(naux), scale
|
||||
external DSCAL
|
||||
!
|
||||
!
|
||||
isign = -sign(1,sgn)
|
||||
itype = abs(sgn)
|
||||
if (itype.le.0.or.itype.gt.2) &
|
||||
& call error('cft_1s','wrong call',sgn)
|
||||
!
|
||||
if (isign.eq.1) then
|
||||
ibid =1
|
||||
scale=1.d0/n
|
||||
else if (isign.eq.-1) then
|
||||
ibid =2
|
||||
scale=1.d0
|
||||
end if
|
||||
!
|
||||
if (first(ibid,itype)) then
|
||||
call dcft(1,f,1,nx,fout,1,nx,n,m,isign, &
|
||||
& scale,aux3(1,ibid,itype),naux1,aux,naux)
|
||||
first(ibid,itype)=.false.
|
||||
end if
|
||||
!
|
||||
call dcft(0,f,1,nx,fout,1,nx,n,m,isign, &
|
||||
& scale,aux3(1,ibid,itype),naux1,aux,naux)
|
||||
#endif
|
||||
return
|
||||
end
|
||||
!
|
||||
!----------------------------------------------------------------------
|
||||
subroutine cft_2s (f,mplane,n1,n2,nx1,nx2,sgn,planes)
|
||||
! ===============
|
||||
! driver routine for mplane 2d complex fft's of lengths n1 and n2
|
||||
! (sparse grid, both charge and wavefunctions) - uses ESSL
|
||||
! on input, sgn=+/-1 for charge density, sgn=+/-2 for wavefunctions
|
||||
! nx1 is the actual dimension of f (may differ from n)
|
||||
! for compatibility: nx2=n2, nx2 is not used
|
||||
! A separate initialization is stored for sgn=-1 and sgn=+1
|
||||
!
|
||||
!----------------------------------------------------------------------
|
||||
!
|
||||
implicit none
|
||||
integer n1, n2, mplane, nx1, nx2, sgn, planes(nx1)
|
||||
complex(kind=8) f(nx1*nx2*mplane)
|
||||
#ifdef __PARA
|
||||
!
|
||||
! initialization variables
|
||||
!
|
||||
logical first(2)
|
||||
data first /.true., .true./
|
||||
integer naux1
|
||||
parameter (naux1=20000)
|
||||
real(kind=8) aux1(naux1,2), aux2(naux1,2)
|
||||
save first, aux1, aux2
|
||||
!
|
||||
! work variables
|
||||
!
|
||||
integer isign, itype, ibid, m, incx1, incx2, k, i, istrt, naux
|
||||
parameter (naux=15000)
|
||||
real(kind=8) aux(naux), scale
|
||||
external DSCAL
|
||||
!
|
||||
!
|
||||
isign = -sign(1,sgn)
|
||||
itype = abs(sgn)
|
||||
if (itype.le.0.or.itype.gt.2) call error('cft_2','wrong call',1)
|
||||
!
|
||||
if(n2.ne.nx2) &
|
||||
& call error('cft_2','no longer implemented',1)
|
||||
!
|
||||
scale=1.d0
|
||||
!
|
||||
! check how many columns along x are nonzero
|
||||
!
|
||||
m=0
|
||||
do i=1,n1
|
||||
m=m+planes(i)
|
||||
end do
|
||||
if (m.gt.n1.or.m.le.0) &
|
||||
& call error('cft_2s','something wrong with planes',1)
|
||||
!
|
||||
if (isign.eq.1) then
|
||||
!
|
||||
! ... i - direction
|
||||
!
|
||||
incx1=1
|
||||
incx2=nx1
|
||||
m=n2*mplane
|
||||
if (first(1)) then
|
||||
call dcft(1,f,incx1,incx2,f,incx1,incx2,n1,m,isign, &
|
||||
& scale,aux1(1,1),naux1,aux,naux)
|
||||
end if
|
||||
call dcft(0,f,incx1,incx2,f,incx1,incx2,n1,m,isign, &
|
||||
& scale,aux1(1,1),naux1,aux,naux)
|
||||
!
|
||||
! j-direction ...
|
||||
!
|
||||
incx1 = nx1
|
||||
incx2 = nx1*nx2
|
||||
m=mplane
|
||||
if (first(1)) then
|
||||
call dcft &
|
||||
& (1,f,incx1,incx2,f,incx1,incx2, &
|
||||
& n2,m,isign,scale,aux2(1,1),naux1,aux,naux)
|
||||
first(1)=.false.
|
||||
end if
|
||||
do i= 1,n1
|
||||
!
|
||||
! do only ffts on columns (i,*,k) resulting in nonzero components
|
||||
!
|
||||
if (planes(i).eq.1) then
|
||||
call dcft &
|
||||
& (0,f(i),incx1,incx2,f(i),incx1,incx2, &
|
||||
& n2,m,isign,scale,aux2(1,1),naux1,aux,naux)
|
||||
end if
|
||||
end do
|
||||
!
|
||||
call DSCAL(2*nx1*n2*mplane,1d0/(n1*n2),f,1)
|
||||
!
|
||||
else if (isign.eq.-1) then
|
||||
!
|
||||
! ... j-direction
|
||||
!
|
||||
incx1 = nx1
|
||||
incx2 = nx1*nx2
|
||||
m=mplane
|
||||
if (first(2)) then
|
||||
call dcft &
|
||||
& (1,f,incx1,incx2,f,incx1,incx2, &
|
||||
& n2,m,isign,scale,aux2(1,2),naux1,aux,naux)
|
||||
end if
|
||||
do i = 1,n1
|
||||
!
|
||||
! do only ffts for columns (i,*,k) having nonzero components
|
||||
!
|
||||
if (planes(i).eq.1.or.itype.eq.1) then
|
||||
call dcft &
|
||||
& (0,f(i),incx1,incx2,f(i),incx1,incx2, &
|
||||
& n2,m,isign,scale,aux2(1,2),naux1,aux,naux)
|
||||
end if
|
||||
end do
|
||||
!
|
||||
! i - direction ...
|
||||
!
|
||||
incx1= 1
|
||||
incx2=nx1
|
||||
m=n2*mplane
|
||||
if (first(2)) then
|
||||
call dcft(1,f,incx1,incx2,f,incx1,incx2,n1,m,isign,scale, &
|
||||
& aux1(1,2),naux1,aux,naux)
|
||||
first(2)=.false.
|
||||
end if
|
||||
call dcft(0,f,incx1,incx2,f,incx1,incx2,n1,m,isign,scale, &
|
||||
& aux1(1,2),naux1,aux,naux)
|
||||
!
|
||||
endif
|
||||
#endif
|
||||
return
|
||||
end
|
||||
!
|
||||
!----------------------------------------------------------------------
|
||||
subroutine cft_b (f,n1,n2,n3,n1x,n2x,n3x,imin3,imax3,sgn)
|
||||
! ===============
|
||||
! driver routine for 3d complex fft's on box grid - ibm essl
|
||||
! fft along xy is done only on planes that correspond to
|
||||
! dense grid planes on the current processor, i.e. planes
|
||||
! with imin3 .le. n3 .le. imax3
|
||||
!----------------------------------------------------------------------
|
||||
!
|
||||
implicit none
|
||||
integer n1,n2,n3,n1x,n2x,n3x,imin3,imax3,sgn
|
||||
complex(kind=8) f(n1x*n2x*n3x)
|
||||
#ifdef __PARA
|
||||
!
|
||||
! initialization variables
|
||||
!
|
||||
logical first(2)
|
||||
data first /.true., .true./
|
||||
integer naux1
|
||||
parameter (naux1=20000)
|
||||
real(kind=8) aux3(naux1,2), aux2(naux1,2), aux1(naux1,2)
|
||||
save first, aux1, aux2, aux3
|
||||
!
|
||||
! work variables
|
||||
!
|
||||
integer isign, naux, ibid, nplanes, nstart, k
|
||||
parameter (naux=15000)
|
||||
real(kind=8) aux(naux), scale
|
||||
!
|
||||
!
|
||||
isign = -sgn
|
||||
if (isign.eq.-1) then
|
||||
ibid =1
|
||||
scale=1.d0
|
||||
else if (isign.eq.1) then
|
||||
call error('cft_b','not implemented',isign)
|
||||
end if
|
||||
!
|
||||
if (first(ibid)) then
|
||||
!
|
||||
! initialization for the z-direction...
|
||||
!
|
||||
call dcft(1,f,n1x*n2x,1,f,n1x*n2x,1,n3,n1x*n2x,isign, &
|
||||
& scale,aux3(1,ibid),naux1,aux,naux)
|
||||
first(ibid)=.false.
|
||||
end if
|
||||
!
|
||||
! fft in the z-direction...
|
||||
!
|
||||
call dcft(0,f,n1x*n2x,1,f,n1x*n2x,1,n3,n1x*n2x,isign, &
|
||||
& scale,aux3(1,ibid),naux1,aux,naux)
|
||||
!
|
||||
! 2d fft on xy planes - only needed planes are transformed
|
||||
! note that all others are left in an unusable state
|
||||
!
|
||||
nplanes=imax3-imin3+1
|
||||
nstart =(imin3-1)*n1x*n2x+1
|
||||
!
|
||||
! x-direction - Inizialization must be done every time because it depends
|
||||
! on nplanes that may vary from call to call !!!! sigh
|
||||
!
|
||||
call dcft(1,f,1,n1x,f,1,n1x,n1,n2x*nplanes,isign, &
|
||||
& scale,aux1(1,ibid),naux1,aux,naux)
|
||||
call dcft(0,f(nstart),1,n1x,f(nstart),1,n1x,n1,n2x*nplanes,isign, &
|
||||
& scale,aux1(1,ibid),naux1,aux,naux)
|
||||
!
|
||||
! y-direction
|
||||
!
|
||||
call dcft(1,f,n1x,1,f,n1x,1,n2,n1x,isign, &
|
||||
& scale,aux2(1,ibid),naux1,aux,naux)
|
||||
!
|
||||
do k= imin3,imax3
|
||||
nstart=(k-1)*n1x*n2x+1
|
||||
call dcft(0,f(nstart),n1x,1,f(nstart),n1x,1,n2,n1x,isign, &
|
||||
& scale,aux2(1,ibid),naux1,aux,naux)
|
||||
end do
|
||||
#endif
|
||||
return
|
||||
end
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,453 @@
|
|||
!
|
||||
! Copyright (C) 2002 CP90 group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
! Machine-dependent routines for:
|
||||
! cpu-time and ram measurement
|
||||
! random number generation
|
||||
! fft dimensions
|
||||
! erf, erfc, freq functions
|
||||
!
|
||||
! 1) cpu-time and ram measurement
|
||||
! =======================
|
||||
!
|
||||
!-------------------------------------------------------------------------
|
||||
subroutine tictac(i,j)
|
||||
!-------------------------------------------------------------------------
|
||||
!
|
||||
! measure cpu time, elapsed time, and number of calls
|
||||
! i index of subroutine
|
||||
! j j=0 start, j=1 stop the clock and add 1 to number of calls
|
||||
!
|
||||
! WARNING: the accuracy of time-measuring routines may vary
|
||||
! the resolution for elapsed time may be as low as 1 s
|
||||
!
|
||||
use timex_mod
|
||||
|
||||
implicit none
|
||||
integer i, j
|
||||
real(kind=8) time1(maxclock),time2(maxclock), tcpu, telaps
|
||||
integer count, count_rate, count_max
|
||||
integer k
|
||||
logical first
|
||||
save first, time1, time2
|
||||
data first/.true./
|
||||
!
|
||||
! The machine dependent declaration of the timing function
|
||||
!
|
||||
#ifdef __CRAYY
|
||||
real*8 &
|
||||
& second ! system function, returns the CPU time in sec.
|
||||
#endif
|
||||
#ifdef __AIX
|
||||
integer &
|
||||
& mclock ! system function, returns the time in sec./100.
|
||||
real*8 &
|
||||
& timef ! system function, returns elapsed time in msec.
|
||||
#endif
|
||||
#ifdef __T3E
|
||||
real*8 &
|
||||
& tsecnd, &! system function, returns the CPU time in sec.
|
||||
& timef ! system function, returns elapsed time in msec.
|
||||
#endif
|
||||
#if defined(__PGI) || defined(__INTEL)
|
||||
real*4 &
|
||||
& etime, &! system function, returns the CPU time in sec.
|
||||
& tarry(2) ! user and system times (not used)
|
||||
#endif
|
||||
!
|
||||
!
|
||||
if (i.lt.1.or.i.gt.maxclock) &
|
||||
& call error('tictac','wrong number of clocks',i)
|
||||
if (j.ne.0.and.j.ne.1) call error('tictac','wrong call',j)
|
||||
!
|
||||
! initialization
|
||||
!
|
||||
if (first) then
|
||||
do k=1,maxclock
|
||||
cputime(k)=0.0
|
||||
elapsed(k)=0.0
|
||||
ntimes(k)=0
|
||||
end do
|
||||
first=.false.
|
||||
end if
|
||||
count_max =0
|
||||
count_rate=1
|
||||
!
|
||||
! call cpu- and elapsed-time machine-specific routines
|
||||
!
|
||||
#ifdef __CRAYY
|
||||
#define __USE_SYSTEM_TIMER
|
||||
tcpu = second()
|
||||
call system_clock(count, count_rate, count_max)
|
||||
telaps=float(count)/count_rate
|
||||
#endif
|
||||
#ifdef __NEC
|
||||
#define __USE_SYSTEM_TIMER
|
||||
call clock(tcpu)
|
||||
call system_clock(count, count_rate, count_max)
|
||||
telaps=float(count)/count_rate
|
||||
#endif
|
||||
#ifdef __AIX
|
||||
#define __USE_SYSTEM_TIMER
|
||||
tcpu = mclock() / 100.d0
|
||||
telaps=timef()/1000.
|
||||
#endif
|
||||
#ifdef __T3E
|
||||
#define __USE_SYSTEM_TIMER
|
||||
tcpu = tsecnd()
|
||||
telaps=timef()/1000.
|
||||
#endif
|
||||
#if defined(__PGI) || defined(__INTEL)
|
||||
#define __USE_SYSTEM_TIMER
|
||||
tcpu = etime( tarry )
|
||||
call system_clock(count, count_rate, count_max)
|
||||
telaps=float(count)/count_rate
|
||||
#endif
|
||||
#ifndef __USE_SYSTEM_TIMER
|
||||
!
|
||||
! call intrinsic f90 cpu- and elapsed-time routines
|
||||
!
|
||||
call cpu_time (tcpu)
|
||||
call system_clock(count, count_rate, count_max)
|
||||
telaps=float(count)/count_rate
|
||||
#endif
|
||||
if (j.eq.0) then
|
||||
time1(i)=tcpu
|
||||
time2(i)=telaps
|
||||
else if (j.eq.1) then
|
||||
cputime(i)=cputime(i) + ( tcpu-time1(i))
|
||||
elapsed(i)=elapsed(i) + (telaps-time2(i))
|
||||
!
|
||||
! The following workaround is needed because system_clock resets "count"
|
||||
! every time it reaches "count_max" (usually the largest integer), and
|
||||
! on some compilers (Absoft, Intel) this happens way too frequently.
|
||||
! Will not work if elapsed t between two calls > count_max/count_rate .
|
||||
!
|
||||
if (telaps-time2(i).lt.0.d0) &
|
||||
& elapsed(i)=elapsed(i) + (count_max+1.d0)/count_rate
|
||||
! BEWARE: (count_max+1) may give integer overflow !!!
|
||||
ntimes(i) =ntimes(i)+1
|
||||
endif
|
||||
return
|
||||
end
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine memory
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! Prints what is hopefully the size of occupied memory
|
||||
! Implemented only for SGI Origin and AIX SP3.
|
||||
! Extremely machine- and operating-system dependent
|
||||
!
|
||||
#ifdef __PARA
|
||||
use para_mod, only: me
|
||||
#endif
|
||||
implicit none
|
||||
character(len=80) command
|
||||
integer pid
|
||||
#ifdef __AIX
|
||||
integer getpid_
|
||||
|
||||
pid=getpid_()
|
||||
write(command,10) pid
|
||||
10 format('ps -lp ',i8,' | grep -v SZ | awk ''{print $10}'' ')
|
||||
write(6,'(''Estimated size (kB) of each process: '',$)')
|
||||
call system(command)
|
||||
#endif
|
||||
|
||||
#ifdef __ORIGIN
|
||||
integer getpid
|
||||
pid=getpid()
|
||||
write(command,10) pid
|
||||
10 format('ps -lp ',i8,'|grep -v SZ|awk ''{print $10}''|cut -f1 -d:')
|
||||
write(6,'(''Total estimated size (pages) of each process: '',$)')
|
||||
#ifdef __PARA
|
||||
if(me.eq.1) &
|
||||
#endif
|
||||
call system(command)
|
||||
#endif
|
||||
return
|
||||
end
|
||||
!
|
||||
! 2) random number generation
|
||||
! ===========================
|
||||
!
|
||||
!-------------------------------------------------------------------------
|
||||
real(kind=8) function randy()
|
||||
!-------------------------------------------------------------------------
|
||||
!
|
||||
! Use machine-specific random-number generator when available
|
||||
!
|
||||
#ifdef __CRAYY
|
||||
#define __USE_SYSTEM_RAND
|
||||
randy = ranf()
|
||||
#endif
|
||||
#ifdef __NEC
|
||||
#define __USE_SYSTEM_RAND
|
||||
randy=random(0)
|
||||
#endif
|
||||
#ifdef __AIX
|
||||
#define __USE_SYSTEM_RAND
|
||||
randy=rand()
|
||||
#endif
|
||||
!
|
||||
! Use fortran random-number generator in all other cases
|
||||
!
|
||||
#ifndef __USE_SYSTEM_RAND
|
||||
integer m, ia, ic, ntab
|
||||
real(kind=8) rm
|
||||
parameter (ntab=97,m=714025,ia=1366,ic=150889,rm=1.0/m)
|
||||
integer ir(ntab), iff, idum, j, iy
|
||||
data iff /0/, idum/0/
|
||||
save iff, idum, iy, ir
|
||||
!
|
||||
!
|
||||
if(idum.lt.0.or.iff.eq.0) then
|
||||
iff=1
|
||||
idum=mod(ic-idum,m)
|
||||
do j=1,ntab
|
||||
idum=mod(ia*idum+ic,m)
|
||||
ir(j)=idum
|
||||
end do
|
||||
idum=mod(ia*idum+ic,m)
|
||||
iy=idum
|
||||
endif
|
||||
j=1+(ntab*iy)/m
|
||||
if(j.gt.ntab.or.j.lt.1) call error('randy','j out of range',j)
|
||||
iy=ir(j)
|
||||
randy=iy*rm
|
||||
idum=mod(ia*idum+ic,m)
|
||||
ir(j)=idum
|
||||
#endif
|
||||
return
|
||||
end
|
||||
!
|
||||
! 3) utilities for fft dimensions
|
||||
! ================
|
||||
!
|
||||
integer function good_fft_dimension(n)
|
||||
!
|
||||
! Determines the optimal maximum dimensions of fft arrays
|
||||
! Useful on some machines to avoid memory conflicts
|
||||
!
|
||||
integer n, nx
|
||||
!
|
||||
! this is the default: max dimension = fft dimension
|
||||
nx=n
|
||||
#if defined(__ESSL)
|
||||
if ( n.eq. 8 .or. n.eq.16 .or. n.eq.32 .or. &
|
||||
& n.eq.64 .or. n.eq.128 .or. n.eq.256 ) nx=n+1
|
||||
#endif
|
||||
#if defined(__CRAYY) || defined(__NEC)
|
||||
if ( mod(n,2).eq.0) nx=n+1
|
||||
#endif
|
||||
good_fft_dimension=nx
|
||||
return
|
||||
end
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
integer function good_fft_order(nr)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! Input : tentative order n of a fft
|
||||
! Output: the same if n is a good number
|
||||
! the closest higher number that is good
|
||||
! an fft order is not good if not implemented (as on IBM with ESSL)
|
||||
! or implemented but with awful performances (most other cases)
|
||||
!
|
||||
implicit none
|
||||
integer nr
|
||||
!
|
||||
integer factors(5), pwr(5), mr, i, fac, p, maxpwr, maxn
|
||||
parameter (maxn=1000)
|
||||
logical good
|
||||
data factors /2, 3, 5, 7, 11/
|
||||
!
|
||||
! find the factors of the fft dimension
|
||||
!
|
||||
10 mr=nr
|
||||
do i=1,5
|
||||
pwr(i)=0
|
||||
end do
|
||||
do i=1,5
|
||||
fac=factors(i)
|
||||
maxpwr = nint(log(float(mr))/log(float(fac)))+1
|
||||
do p=1,maxpwr
|
||||
if (mr.eq.1) goto 20
|
||||
if (mod (mr,fac).eq.0) then
|
||||
mr=mr/fac
|
||||
pwr(i)=pwr(i)+1
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
!
|
||||
20 if (nr .ne. mr * 2**pwr(1) * 3**pwr(2) * 5**pwr(3) * &
|
||||
& 7**pwr(4) *11**pwr(5) ) &
|
||||
& call error('good_fft_order','what ?!?',1)
|
||||
if (mr.ne.1) then
|
||||
! fft dimension contains factors > 11 : no good in any case
|
||||
good=.false.
|
||||
else
|
||||
! specific (machine- and library-dependent cases)
|
||||
#ifdef __ESSL
|
||||
!
|
||||
! IBM machines with essl libraries
|
||||
!
|
||||
good=pwr(1).ge.1 .and. &
|
||||
& pwr(2).le.2 .and. &
|
||||
& pwr(3).le.1 .and. &
|
||||
& pwr(4).le.1 .and. &
|
||||
& pwr(5).le.1 .and. &
|
||||
& ((pwr(2).eq.0 .and. pwr(3)+pwr(4)+pwr(5).le.2) .or. &
|
||||
& (pwr(2).ne.0 .and. pwr(3)+pwr(4)+pwr(5).le.1) )
|
||||
#endif
|
||||
!
|
||||
#if defined(__CRAYY) || defined(__NEC)
|
||||
!
|
||||
! Cray and t3d machines with scilib libraries
|
||||
!
|
||||
good=pwr(4).eq.0 .and. pwr(5).eq.0
|
||||
#endif
|
||||
!
|
||||
#ifdef __FFTW
|
||||
good=pwr(5).eq.0
|
||||
#endif
|
||||
end if
|
||||
if (.not.good) then
|
||||
nr=nr+1
|
||||
if (nr.gt.maxn) &
|
||||
& call error('good_fft_order','too large',maxn)
|
||||
go to 10
|
||||
else
|
||||
good_fft_order=nr
|
||||
end if
|
||||
!
|
||||
end
|
||||
!
|
||||
! 4) erf, erfc, freq functions
|
||||
! ================
|
||||
! for machines that do not have these routines in the math libraries
|
||||
!
|
||||
#if defined __INTEL || defined __PGI
|
||||
!
|
||||
! Copyright (C) 2002 CP90 group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!---------------------------------------------------------------------
|
||||
real(kind=8) function erf (x)
|
||||
!---------------------------------------------------------------------
|
||||
!
|
||||
! Error function - computed from the rational approximations of
|
||||
! W. J. Cody, Math. Comp. 22 (1969), pages 631-637.
|
||||
!
|
||||
! for abs(x) le 0.47 erf is calculated directly
|
||||
! for abs(x) gt 0.47 erf is calculated via erf(x)=1-erfc(x)
|
||||
!
|
||||
implicit none
|
||||
real(kind=8) :: x, x2, p1 (4), q1 (4), erfc
|
||||
external erfc
|
||||
data p1 / 2.42667955230532d2, 2.19792616182942d1, &
|
||||
6.99638348861914d0, - 3.56098437018154d-2 /
|
||||
data q1 / 2.15058875869861d2, 9.11649054045149d1, &
|
||||
1.50827976304078d1, 1.00000000000000d0 /
|
||||
!
|
||||
if (abs (x) .gt.6.d0) then
|
||||
!
|
||||
! erf(6)=1-10^(-17) cannot be distinguished from 1 with 16-byte words
|
||||
!
|
||||
erf = sign (1.d0, x)
|
||||
else
|
||||
if (abs (x) .le.0.47d0) then
|
||||
x2 = x**2
|
||||
erf = x * (p1 (1) + x2 * (p1 (2) + x2 * (p1 (3) + x2 * p1 ( &
|
||||
4) ) ) ) / (q1 (1) + x2 * (q1 (2) + x2 * (q1 (3) + x2 * q1 ( &
|
||||
4) ) ) )
|
||||
else
|
||||
erf = 1.d0 - erfc (x)
|
||||
endif
|
||||
endif
|
||||
!
|
||||
return
|
||||
end function erf
|
||||
!
|
||||
!---------------------------------------------------------------------
|
||||
real(kind=8) function erfc (x)
|
||||
!---------------------------------------------------------------------
|
||||
!
|
||||
! erfc(x) = 1-erf(x) - See comments in erf
|
||||
!
|
||||
implicit none
|
||||
real(kind=8) :: x, ax, x2, xm2, erf, p2 (8), q2 (8), p3 (5), q3 (5), &
|
||||
pim1
|
||||
external erf
|
||||
data p2 / 3.00459261020162d2, 4.51918953711873d2, &
|
||||
3.39320816734344d2, 1.52989285046940d2, 4.31622272220567d1, &
|
||||
7.21175825088309d0, 5.64195517478974d-1, - 1.36864857382717d-7 /
|
||||
data q2 / 3.00459260956983d2, 7.90950925327898d2, &
|
||||
9.31354094850610d2, 6.38980264465631d2, 2.77585444743988d2, &
|
||||
7.70001529352295d1, 1.27827273196294d1, 1.00000000000000d0 /
|
||||
data p3 / - 2.99610707703542d-3, - 4.94730910623251d-2, - &
|
||||
2.26956593539687d-1, - 2.78661308609648d-1, - 2.23192459734185d-2 &
|
||||
/
|
||||
data q3 / 1.06209230528468d-2, 1.91308926107830d-1, &
|
||||
1.05167510706793d0, 1.98733201817135d0, 1.00000000000000d0 /
|
||||
|
||||
data pim1 / 0.564189583547756d0 /
|
||||
! ( pim1= sqrt(1/pi) )
|
||||
ax = abs (x)
|
||||
if (ax.gt.26.d0) then
|
||||
!
|
||||
! erfc(26.0)=10^(-296); erfc( 9.0)=10^(-37);
|
||||
!
|
||||
erfc = 0.d0
|
||||
elseif (ax.gt.4.d0) then
|
||||
x2 = x**2
|
||||
xm2 = (1.d0 / ax) **2
|
||||
erfc = (1.d0 / ax) * exp ( - x2) * (pim1 + xm2 * (p3 (1) &
|
||||
+ xm2 * (p3 (2) + xm2 * (p3 (3) + xm2 * (p3 (4) + xm2 * p3 (5) &
|
||||
) ) ) ) / (q3 (1) + xm2 * (q3 (2) + xm2 * (q3 (3) + xm2 * &
|
||||
(q3 (4) + xm2 * q3 (5) ) ) ) ) )
|
||||
elseif (ax.gt.0.47d0) then
|
||||
x2 = x**2
|
||||
erfc = exp ( - x2) * (p2 (1) + ax * (p2 (2) + ax * (p2 (3) &
|
||||
+ ax * (p2 (4) + ax * (p2 (5) + ax * (p2 (6) + ax * (p2 (7) &
|
||||
+ ax * p2 (8) ) ) ) ) ) ) ) / (q2 (1) + ax * (q2 (2) + ax * &
|
||||
(q2 (3) + ax * (q2 (4) + ax * (q2 (5) + ax * (q2 (6) + ax * &
|
||||
(q2 (7) + ax * q2 (8) ) ) ) ) ) ) )
|
||||
else
|
||||
erfc = 1.d0 - erf (ax)
|
||||
endif
|
||||
!
|
||||
! erf(-x)=-erf(x) => erfc(-x) = 2-erfc(x)
|
||||
!
|
||||
if (x.lt.0.d0) erfc = 2.d0 - erfc
|
||||
!
|
||||
return
|
||||
end function erfc
|
||||
!---------------------------------------------------------------------
|
||||
real(kind=8) function freq (x)
|
||||
!---------------------------------------------------------------------
|
||||
!
|
||||
! freq(x) = (1+erf(x/sqrt(2)))/2 = erfc(-x/sqrt(2))/2
|
||||
! - See comments in erf
|
||||
!
|
||||
real(kind=8) :: x, c, erf, erfc
|
||||
external erf
|
||||
|
||||
data c / 0.707106781186548d0 /
|
||||
! ( c= sqrt(1/2) )
|
||||
freq = 0.5d0 * erfc ( - x * c)
|
||||
!
|
||||
return
|
||||
end function freq
|
||||
|
||||
#endif
|
||||
|
|
@ -0,0 +1,383 @@
|
|||
!
|
||||
! Copyright (C) 2002 CP90 group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
|
||||
module ion_parameters
|
||||
! nsx = max number of different species
|
||||
! nax = max number of atoms in one particular species
|
||||
integer, parameter:: nsx=5, nax=300
|
||||
end module ion_parameters
|
||||
|
||||
module van_parameters
|
||||
! nlx = combined angular momentum (for s,p,d states: nlx=9)
|
||||
! lix = max angular momentum l+1 (lix=3 if s,p,d are included)
|
||||
! lx = max 2*l+1
|
||||
! mx = 2*lx-1
|
||||
integer, parameter:: lix=3, nlx=9, lx=2*lix-1, mx=2*lx-1
|
||||
end module van_parameters
|
||||
|
||||
module bhs
|
||||
! analytical BHS pseudopotential parameters
|
||||
use ion_parameters
|
||||
real(kind=8) rc1(nsx), rc2(nsx), wrc1(nsx), wrc2(nsx), &
|
||||
rcl(3,nsx,3), al(3,nsx,3), bl(3,nsx,3)
|
||||
integer lloc(nsx)
|
||||
end module bhs
|
||||
|
||||
module control_module
|
||||
! iprsta = output verbosity (increasing from 0 to infinity)
|
||||
! iprint = print output every iprint step
|
||||
! if true, do this:
|
||||
! tfor = ion dynamics (calculate forces)
|
||||
! tpre = calculate pressure
|
||||
! thdyn = variable-cell dynamics
|
||||
! tvlocw = write potential to unit 46 (seldom used)
|
||||
! trhor = read rho from unit 47 (seldom used)
|
||||
! trhow = write rho to unit 47 (seldom used)
|
||||
! tbuff = save wfc on unit 21 (never used)
|
||||
integer iprsta, iprint
|
||||
logical tfor, tpre, thdyn, tbuff, tvlocw, trhor, trhow
|
||||
end module control_module
|
||||
|
||||
module core
|
||||
! nlcc = 0 no core correction on any atom
|
||||
! rhocb = core charge in G space (box grid)
|
||||
integer nlcc
|
||||
real(kind=8), allocatable:: rhocb(:,:)
|
||||
end module core
|
||||
|
||||
module cnst
|
||||
! scmass = 1822.89d0 = mass of a proton, in a.u.
|
||||
real(kind=8), parameter:: pi=3.14159265358979d0, fpi=4.d0*pi
|
||||
real(kind=8) scmass
|
||||
end module cnst
|
||||
|
||||
module cvan
|
||||
! ionic pseudo-potential variables
|
||||
use ion_parameters
|
||||
use van_parameters
|
||||
! ap = Clebsch-Gordan coefficients (?)
|
||||
! lpx = max number of allowed Y_lm
|
||||
! lpl = composite lm index of Y_lm
|
||||
real(kind=8) ap(25,nlx,nlx)
|
||||
integer lpx(nlx,nlx),lpl(nlx,nlx,mx)
|
||||
! nvb = number of species with Vanderbilt PPs
|
||||
! nh(is) = number of beta functions, including Y_lm, for species is
|
||||
! ish(is)= used for indexing the nonlocal projectors betae
|
||||
! with contiguous indices inl=ish(is)+(iv-1)*na(is)+1
|
||||
! where "is" is the species and iv=1,nh(is)
|
||||
! nhx = max value of nh(np)
|
||||
! nhsavb = total number of Vanderbilt nonlocal projectors
|
||||
! nhsa = total number of nonlocal projectors for all atoms
|
||||
integer nvb, nhsavb, ish(nsx), nh(nsx), nhsa, nhx
|
||||
! nhtol: nhtol(ind,is)=value of l for projector ind of species is
|
||||
! indv : indv(ind,is) =beta function (without Y_lm) for projector ind
|
||||
! indlm: indlm(ind,is)=Y_lm for projector ind
|
||||
integer, allocatable:: nhtol(:,:), indv(:,:), indlm(:,:)
|
||||
! beta = nonlocal projectors in g space without e^(-ig.r) factor
|
||||
! qq = ionic Q_ij for each species (Vanderbilt only)
|
||||
! dvan = ionic D_ij for each species (Vanderbilt only)
|
||||
real(kind=8), allocatable:: beta(:,:,:), qq(:,:,:), dvan(:,:,:)
|
||||
end module cvan
|
||||
|
||||
module dft_mod
|
||||
integer lda, blyp, becke, bp88, pw91, pbe
|
||||
parameter (lda=0, blyp=1, becke=2, bp88=3, pw91=4, pbe=5)
|
||||
integer dft
|
||||
end module dft_mod
|
||||
|
||||
module elct
|
||||
implicit none
|
||||
save
|
||||
! f = occupation numbers
|
||||
! qbac = background neutralizing charge
|
||||
real(kind=8), allocatable:: f(:)
|
||||
real(kind=8) qbac
|
||||
! nspin = number of spins (1=no spin, 2=LSDA)
|
||||
! nel(nspin) = number of electrons (up, down)
|
||||
! nupdwn= number of states with spin up (1) and down (2)
|
||||
! iupdwn= first state with spin (1) and down (2)
|
||||
! n = total number of electronic states
|
||||
! nx = if n is even, nx=n ; if it is odd, nx=n+1
|
||||
! nx is used only to dimension arrays
|
||||
! ngw = number of plane waves for wavefunctions
|
||||
! ngwl = number of G-vector shells up to ngw
|
||||
! ng0 = first G-vector with nonzero modulus
|
||||
! needed in the parallel case (G=0 is on one node only!)
|
||||
! ngw_g = in a parallel execution global number of plane waves for wavefunctions
|
||||
integer nel(2), nspin, nupdwn(2), iupdwn(2), n, nx
|
||||
integer ngw, ngwl, ng0, ngw_g
|
||||
! ispin = spin of each state
|
||||
integer, allocatable:: ispin(:)
|
||||
end module elct
|
||||
|
||||
module ener
|
||||
real(kind=8) etot,ekin,eht,epseu,enl,exc,esr,eself
|
||||
end module ener
|
||||
|
||||
module gvec
|
||||
! G-vector quantities for the thick grid - see also doc in ggen
|
||||
! g = G^2 in increasing order (in units of tpiba2=(2pi/a)^2)
|
||||
! gl = shells of G^2 ( " " " " " )
|
||||
! gx = G-vectors ( " " " tpiba =(2pi/a) )
|
||||
real(kind=8), allocatable:: gl(:), g(:), gx(:,:)
|
||||
!
|
||||
real(kind=8), allocatable:: g2_g(:)
|
||||
! g2_g = all G^2 in increasing order, replicated on all procs
|
||||
integer, allocatable :: mill_g(:,:)
|
||||
! mill_g = miller index of G vecs (increasing order), replicated on all procs
|
||||
integer, allocatable :: mill_l(:,:)
|
||||
! mill_l = miller index of G vecs local to the processors
|
||||
integer, allocatable :: ig_l2g(:)
|
||||
! ig_l2g = "l2g" means local to global, this array convert a local
|
||||
! G-vector index into the global index, in other words
|
||||
! the index of the G-v. in the overall array of G-vectors
|
||||
integer :: ng_g
|
||||
!
|
||||
! tpiba = 2*pi/alat
|
||||
! tpiba2 = (2*pi/alat)**2
|
||||
real(kind=8) tpiba, tpiba2
|
||||
! np = fft index for G>
|
||||
! nm = fft index for G<
|
||||
! in1p,in2p,in3p = G components in crystal axis
|
||||
integer,allocatable:: np(:), nm(:), in1p(:),in2p(:),in3p(:), igl(:)
|
||||
! ng = number of G vectors for density and potential
|
||||
! ngl = number of shells of G
|
||||
integer ng, ngl
|
||||
real(kind=8) :: bi1(3), bi2(3), bi3(3)
|
||||
! bi? = base vector used to generate the reciprocal space
|
||||
end module gvec
|
||||
|
||||
module gvecb
|
||||
! As above, for the box grid
|
||||
real(kind=8), allocatable:: gb(:), gxb(:,:),gxnb(:,:), glb(:)
|
||||
integer, allocatable:: npb(:),nmb(:),iglb(:),in1pb(:),in2pb(:),in3pb(:)
|
||||
integer ngb, nglb
|
||||
end module gvecb
|
||||
|
||||
module gvecs
|
||||
! As above, for the smooth grid
|
||||
integer ngs, ngsl
|
||||
integer, allocatable:: nps(:), nms(:)
|
||||
end module gvecs
|
||||
|
||||
module ions_module
|
||||
use ion_parameters
|
||||
! nsp = number of species
|
||||
! na(is) = number of atoms of species is
|
||||
! nas = max number of atoms of a given species
|
||||
! nat = total number of atoms of all species
|
||||
! ipp(is) = PP type for species is (see INPUT)
|
||||
integer nat, nas, nsp, na(nsx), ipp(nsx)
|
||||
! zv(is) = (pseudo-)atomic charge
|
||||
! pmass(is) = mass (converted to a.u.) of ions
|
||||
! rcmax(is) = Ewald radius (for ion-ion interactions)
|
||||
real(kind=8) zv(nsx), pmass(nsx), rcmax(nsx)
|
||||
end module ions_module
|
||||
|
||||
module ncprm
|
||||
|
||||
use ion_parameters
|
||||
use van_parameters
|
||||
!
|
||||
! lqx : maximum angular momentum of Q (Vanderbilt augmentation charges)
|
||||
! nqfx : maximum number of coefficients in Q smoothing
|
||||
! nbrx : maximum number of distinct radial beta functions
|
||||
! mmaxx: maximum number of points in the radial grid
|
||||
!
|
||||
integer nqfx, lqx, nbrx, mmaxx
|
||||
parameter (lqx=5, nqfx=8, nbrx=6, mmaxx=921)
|
||||
|
||||
! ifpcor 1 if "partial core correction" of louie, froyen,
|
||||
! & cohen to be used; 0 otherwise
|
||||
! nbeta number of beta functions (sum over all l)
|
||||
! kkbeta last radial mesh point used to describe functions
|
||||
! which vanish outside core
|
||||
! nqf coefficients in Q smoothing
|
||||
! nqlc angular momenta present in Q smoothing
|
||||
! lll lll(j) is l quantum number of j'th beta function
|
||||
|
||||
integer ifpcor(nsx), nbeta(nsx), kkbeta(nsx), &
|
||||
nqf(nsx), nqlc(nsx), lll(nbrx,nsx)
|
||||
|
||||
! rscore partial core charge (Louie, Froyen, Cohen)
|
||||
! dion bare pseudopotential D_{\mu,\nu} parameters
|
||||
! (ionic and screening parts subtracted out)
|
||||
! betar the beta function on a r grid (actually, r*beta)
|
||||
! qqq Q_ij matrix
|
||||
! qfunc Q_ij(r) function (for r>rinner)
|
||||
! rinner radius at which to cut off partial core or Q_ij
|
||||
!
|
||||
! qfcoef coefficients to pseudize qfunc for different total
|
||||
! angular momentum (for r<rinner)
|
||||
! rucore bare local potential
|
||||
|
||||
real(kind=8) rscore(mmaxx,nsx), dion(nbrx,nbrx,nsx), &
|
||||
betar(mmaxx,nbrx,nsx), qqq(nbrx,nbrx,nsx), &
|
||||
qfunc(mmaxx,nbrx,nbrx,nsx), rucore(mmaxx,nbrx,nsx), &
|
||||
qfcoef(nqfx,lqx,nbrx,nbrx,nsx), rinner(lqx,nsx)
|
||||
!
|
||||
! qrl q(r) functions
|
||||
!
|
||||
real(kind=8) qrl(mmaxx,nbrx,nbrx,lx,nsx)
|
||||
|
||||
! mesh number of radial mesh points
|
||||
! r logarithmic radial mesh
|
||||
! rab derivative of r(i) (used in numerical integration)
|
||||
! cmesh used only for Herman-Skillman mesh (old format)
|
||||
|
||||
integer mesh(nsx)
|
||||
real(kind=8) r(mmaxx,nsx), rab(mmaxx,nsx), cmesh(nsx)
|
||||
end module ncprm
|
||||
|
||||
module parm
|
||||
! alat = lattice parameter
|
||||
! omega = unit cell volume
|
||||
real(kind=8) alat, omega
|
||||
! nr1 ,nr2 ,nr3 = dense grid in real space (fft)
|
||||
! nr1x,nr2x,nr3x = fft dimensions - may differ from fft transform
|
||||
! lengths nr1,nr2,nr3 for efficiency reasons
|
||||
! nnr,nnrs,nnrb = data size of fft arrays the for dense grid
|
||||
! NOTA BENE: nnr .ne. nr1*nr2*nr3
|
||||
! nnr = nr1x*nr2x*nr3x only for scalar case
|
||||
integer nr1, nr2, nr3, nr1x, nr2x, nr3x, nnr
|
||||
!
|
||||
! direct and reciprocal lattice vectors
|
||||
!
|
||||
real(kind=8) a1(3),a2(3),a3(3), ainv(3,3)
|
||||
end module parm
|
||||
|
||||
module parmb
|
||||
! as in module "parm", for the box grid
|
||||
real(kind=8) tpibab, omegab
|
||||
integer nr1b,nr2b,nr3b,nnrb,nr1bx,nr2bx,nr3bx
|
||||
real(kind=8) a1b(3),a2b(3),a3b(3), ainvb(3,3)
|
||||
end module parmb
|
||||
|
||||
module parms
|
||||
! as in module "parm", for the smooth grid
|
||||
integer nr1s, nr2s, nr3s, nr1sx, nr2sx, nr3sx, nnrs
|
||||
end module parms
|
||||
|
||||
module pseu
|
||||
! rhops = ionic pseudocharges (for Ewald term)
|
||||
! vps = local pseudopotential in G space for each species
|
||||
real(kind=8), allocatable:: rhops(:,:), vps(:,:)
|
||||
end module pseu
|
||||
|
||||
module psfiles
|
||||
use ion_parameters
|
||||
! psfile = name of files containing pseudopotential
|
||||
character(len=80) :: psfile(nsx)
|
||||
end module psfiles
|
||||
|
||||
module qgb_mod
|
||||
complex(kind=8), allocatable:: qgb(:,:,:)
|
||||
end module qgb_mod
|
||||
|
||||
module qradb_mod
|
||||
real(kind=8), allocatable:: qradb(:,:,:,:,:)
|
||||
end module qradb_mod
|
||||
|
||||
module timex_mod
|
||||
integer maxclock
|
||||
parameter (maxclock=32)
|
||||
real(kind=8) cputime(maxclock), elapsed(maxclock)
|
||||
integer ntimes(maxclock)
|
||||
character(len=10) routine
|
||||
dimension routine(maxclock)
|
||||
data routine / 'total time', &
|
||||
'initialize', &
|
||||
' formf ', &
|
||||
' rhoofr ', &
|
||||
' vofrho ', &
|
||||
' dforce ', &
|
||||
' calphi ', &
|
||||
' ortho ', &
|
||||
' updatc ', &
|
||||
' graham ', &
|
||||
' newd ', &
|
||||
' calbec ', &
|
||||
' prefor ', &
|
||||
' strucf ', &
|
||||
' nlfl ', &
|
||||
' nlfq ', &
|
||||
' set_cc ', &
|
||||
' rhov ', &
|
||||
' nlsm1 ', &
|
||||
' nlsm2 ', &
|
||||
' forcecc', &
|
||||
' fft ', &
|
||||
' ffts ', &
|
||||
' fftw ', &
|
||||
' fftb ', &
|
||||
' rsg ', &
|
||||
'setfftpara', &
|
||||
'fftscatter', &
|
||||
'reduce ', &
|
||||
'test1 ','test2 ','test3 ' /
|
||||
|
||||
end module timex_mod
|
||||
|
||||
module wfc_atomic
|
||||
use ion_parameters, only:nsx
|
||||
use ncprm, only:mmaxx
|
||||
! nchix= maximum number of pseudo wavefunctions
|
||||
! nchi = number of atomic (pseudo-)wavefunctions
|
||||
! lchi = angular momentum of chi
|
||||
! chi = atomic (pseudo-)wavefunctions
|
||||
integer nchix
|
||||
parameter (nchix=6)
|
||||
real(kind=8) chi(mmaxx,nchix,nsx)
|
||||
integer lchi(nchix,nsx), nchi(nsx)
|
||||
end module wfc_atomic
|
||||
|
||||
module work1
|
||||
complex(kind=8), allocatable, target:: wrk1(:)
|
||||
end module work1
|
||||
|
||||
module work_box
|
||||
complex(kind=8), allocatable, target:: qv(:)
|
||||
end module work_box
|
||||
|
||||
module work_fft
|
||||
complex(kind=8), allocatable:: aux(:)
|
||||
end module work_fft
|
||||
|
||||
module work2
|
||||
complex(kind=8), allocatable, target:: wrk2(:,:)
|
||||
end module work2
|
||||
|
||||
! Variable cell
|
||||
module derho
|
||||
complex(kind=8),allocatable:: drhog(:,:,:,:)
|
||||
real(kind=8),allocatable:: drhor(:,:,:,:)
|
||||
end module derho
|
||||
|
||||
module dener
|
||||
real(kind=8) detot(3,3), dekin(3,3), dh(3,3), dps(3,3), &
|
||||
& denl(3,3), dxc(3,3), dsr(3,3)
|
||||
end module dener
|
||||
|
||||
module dqgb_mod
|
||||
complex(kind=8),allocatable:: dqgb(:,:,:,:,:)
|
||||
end module dqgb_mod
|
||||
|
||||
module dpseu
|
||||
real(kind=8),allocatable:: dvps(:,:), drhops(:,:)
|
||||
end module dpseu
|
||||
|
||||
module cdvan
|
||||
real(kind=8),allocatable:: dbeta(:,:,:,:,:), dbec(:,:,:,:), &
|
||||
drhovan(:,:,:,:,:)
|
||||
end module cdvan
|
||||
|
||||
module pres_mod
|
||||
real(kind=8) agg, sgg, e0gg
|
||||
real(kind=8),allocatable:: ggp(:)
|
||||
end module pres_mod
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,713 @@
|
|||
!
|
||||
! Copyright (C) 2002 CP90 group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
|
||||
module ncpp
|
||||
character(len=50) dft
|
||||
integer lmax, lloc
|
||||
logical nlcc
|
||||
real(kind=8) zp
|
||||
real(kind=8), allocatable:: vnl(:,:), rho_atc(:), rho_at(:)
|
||||
integer, allocatable:: lchi(:)
|
||||
character(len=2) psd
|
||||
end module ncpp
|
||||
|
||||
module bhs
|
||||
integer nlc, nnl
|
||||
logical bhstype
|
||||
real(kind=8) alpc(2), cc(2), alps(3,0:3), aps(6,0:3)
|
||||
real(kind=8) a_nlcc, b_nlcc, alpha_nlcc
|
||||
end module bhs
|
||||
|
||||
module grid
|
||||
real(kind=8) zmesh, xmin, dx
|
||||
real(kind=8), allocatable:: r(:), rab(:)
|
||||
integer mesh
|
||||
end module grid
|
||||
|
||||
module wavefunctions
|
||||
integer nchi
|
||||
real(kind=8), allocatable:: chi(:,:), oc(:)
|
||||
end module wavefunctions
|
||||
|
||||
module ultrasoft
|
||||
integer nvales, nang, nbeta, kkbeta, ifpcor, keyps
|
||||
real(kind=8) z, exfact
|
||||
real(kind=8) ,allocatable:: betar(:), dion(:,:), ddd(:,:), &
|
||||
qqq(:,:), qfunc(:,:,:), vloc0(:)
|
||||
integer nnlz, ifqopt, nqf, irel, iptype, npf
|
||||
real(kind=8) etotpseu, wwnl, ee, rinner, eloc, dummy, rc, rcloc, eee
|
||||
character(len=20) title
|
||||
end module ultrasoft
|
||||
|
||||
|
||||
program pw2us
|
||||
|
||||
implicit none
|
||||
character(len=32) file_pw, file_us
|
||||
logical pwformat, bhsformat
|
||||
|
||||
5 print '(''Input PP file in PW format > '',$)'
|
||||
read '(a)', file_pw
|
||||
pwformat=file_pw.ne.' '
|
||||
if (.not. pwformat) then
|
||||
print '(''Input PP file in BHS format > '',$)'
|
||||
read '(a)', file_pw
|
||||
bhsformat=file_pw.ne.' '
|
||||
if (.not.bhsformat) stop
|
||||
else
|
||||
inquire (file=file_pw,exist=pwformat)
|
||||
if (.not. pwformat) go to 5
|
||||
end if
|
||||
|
||||
open(unit=1,file=file_pw,status='old',form='formatted')
|
||||
if (pwformat) then
|
||||
call read_ncpp
|
||||
else
|
||||
call read_bhs
|
||||
end if
|
||||
|
||||
close (unit=1)
|
||||
|
||||
file_us=trim(file_pw)//'.van'
|
||||
print '(''Output PP file in US format : '',a)', file_us
|
||||
|
||||
open(unit=2,file=file_us,status='unknown',form='formatted')
|
||||
call write_us
|
||||
close (unit=2)
|
||||
|
||||
end program pw2us
|
||||
|
||||
subroutine read_ncpp
|
||||
|
||||
use ncpp
|
||||
use bhs
|
||||
use grid
|
||||
use wavefunctions
|
||||
|
||||
implicit none
|
||||
real(kind=8) x, erf
|
||||
integer nb, ios, i, l, n, ir
|
||||
logical numeric
|
||||
external erf
|
||||
|
||||
read( 1, '(a)', end=300, err=300, iostat=ios ) dft
|
||||
if (dft(1:2).eq.'**') dft='PZ'
|
||||
|
||||
read ( 1, *, err=300, iostat=ios ) psd, zp, lmax, nlc, nnl, nlcc, &
|
||||
lloc, bhstype
|
||||
if ( nlc.gt.2 .or. nnl.gt.3) &
|
||||
call error( 'read_ncpp','Wrong nlc or nnl',1 )
|
||||
if ( nlc* nnl .lt. 0 ) &
|
||||
call error( 'read_ncpp','nlc*nnl < 0 ? ',1 )
|
||||
if ( zp.le.0d0 ) &
|
||||
call error( 'read_ncpp','Wrong zp ',1 )
|
||||
if ( lmax.gt.3.or.lmax.lt.0 ) &
|
||||
call error( 'read_ncpp','Wrong lmax ',1 )
|
||||
|
||||
if (lloc.eq.-1000) lloc=lmax
|
||||
!
|
||||
! In numeric pseudopotentials both nlc and nnl are zero.
|
||||
!
|
||||
numeric = nlc.le.0 .and. nnl.le.0
|
||||
|
||||
if (.not.numeric) then
|
||||
!
|
||||
! read here pseudopotentials in analytic form
|
||||
!
|
||||
read( 1, *, err=300, iostat=ios ) &
|
||||
( alpc(i), i=1, 2 ), ( cc(i), i=1,2 )
|
||||
if ( abs(cc(1)+cc(2)-1.d0).gt.1.0d-6) &
|
||||
call error ('read_ncpp','wrong pseudopotential coefficients',1)
|
||||
do l = 0, lmax
|
||||
read ( 1, *, err=300, iostat=ios ) &
|
||||
( alps(i,l),i=1,3 ), (aps(i,l),i=1,6)
|
||||
enddo
|
||||
|
||||
if (nlcc) then
|
||||
read( 1, *, err=300, iostat=ios ) &
|
||||
a_nlcc, b_nlcc, alpha_nlcc
|
||||
if (alpha_nlcc.le.0.d0) &
|
||||
call error('read_ncpp','nlcc but alpha=0',1)
|
||||
end if
|
||||
|
||||
if (bhstype) call bachel(alps,aps,1,lmax)
|
||||
|
||||
end if
|
||||
read( 1, *, err=300, iostat=ios ) zmesh, xmin, dx, mesh, nchi
|
||||
if ( mesh.le.0) call error( 'read_ncpp', 'mesh too small', 1)
|
||||
if ( (nchi.lt.lmax .and. lloc.eq.lmax).or. &
|
||||
(nchi.lt.lmax+1 .and. lloc.ne.lmax) ) &
|
||||
call error( 'read_ncpp', 'wrong no. of wfcts', 1 )
|
||||
!
|
||||
! compute the radial mesh
|
||||
!
|
||||
allocate( r(mesh))
|
||||
allocate(rab(mesh))
|
||||
! r (0) = 0.d0
|
||||
! rab(0) = 0.d0
|
||||
do ir = 1, mesh
|
||||
x = xmin + float(ir-1) * dx
|
||||
r (ir) = exp(x) / zmesh
|
||||
rab(ir) = dx * r(ir)
|
||||
end do
|
||||
|
||||
allocate(vnl(mesh,0:lmax))
|
||||
|
||||
if (numeric) then
|
||||
!
|
||||
! Here pseudopotentials in numeric form are read
|
||||
!
|
||||
do l = 0, lmax
|
||||
read( 1, '(a)', err=300, iostat=ios )
|
||||
read( 1, *, err=300, iostat=ios ) (vnl(ir,l),ir=1,mesh)
|
||||
! vnl(0,l) = (r(2)*vnl(1,l)-r(1)*vnl(2,l))/(r(2)-r(1))
|
||||
enddo
|
||||
|
||||
if(nlcc) then
|
||||
allocate(rho_atc(mesh))
|
||||
read( 1, *, err=300, iostat=ios ) ( rho_atc(ir), ir=1,mesh )
|
||||
endif
|
||||
|
||||
else
|
||||
!
|
||||
! convert analytic to numeric form
|
||||
!
|
||||
do l=0,lmax
|
||||
! vnl(0,l) = - ( cc(1)*sqrt(alpc(1))+cc(2)*sqrt(alpc(2)))*zp
|
||||
do ir=1,mesh
|
||||
vnl(ir,l)= - ( cc(1)*erf(sqrt(alpc(1))*r(ir)) + &
|
||||
cc(2)*erf(sqrt(alpc(2))*r(ir)) ) * zp/r(ir)
|
||||
end do
|
||||
|
||||
do n=1,nnl
|
||||
vnl(:,l)= vnl(:,l)+ (aps(n,l)+ aps(n+3,l)*r(:)**2 )* &
|
||||
exp(-alps(n,l)*r(:)**2)
|
||||
end do
|
||||
!
|
||||
! convert to Rydberg
|
||||
!
|
||||
vnl(:,l) = vnl(:,l)*2.0
|
||||
end do
|
||||
|
||||
if (nlcc) then
|
||||
allocate(rho_atc(mesh))
|
||||
rho_atc(:) =(a_nlcc+b_nlcc*r(:)**2)*exp(-alpha_nlcc*r(:)**2)
|
||||
end if
|
||||
endif
|
||||
!
|
||||
! subract the local part
|
||||
!
|
||||
do l = 0, lmax
|
||||
if ( l.ne.lloc ) vnl(:,l) = vnl(:,l) - vnl(:,lloc)
|
||||
enddo
|
||||
!
|
||||
! Here pseudowavefunctions in numeric form are read
|
||||
!
|
||||
allocate(lchi(nchi))
|
||||
allocate(oc(nchi))
|
||||
allocate(chi(mesh,nchi))
|
||||
do nb = 1, nchi
|
||||
read( 1, '(a)', err=300, iostat=ios )
|
||||
read( 1, *, err=300, iostat=ios ) lchi( nb), oc( nb )
|
||||
!
|
||||
! Test lchi and occupation numbers
|
||||
!
|
||||
if ( nb.le.lmax.and.lchi(nb)+1.ne.nb) &
|
||||
call error('read_ncpp','order of wavefunctions',nb)
|
||||
if (lchi(nb).gt.lmax .or. lchi(nb).lt.0) &
|
||||
call error('read_ncpp','wrong lchi',nb)
|
||||
if ( oc(nb).lt.0.d0 .or. &
|
||||
oc(nb).gt.2.d0*(2*lchi(nb)+1)) &
|
||||
call error('read_ncpp','wrong oc',nb)
|
||||
read( 1, *, err=300, iostat=ios ) &
|
||||
(chi(ir,nb),ir=1,mesh)
|
||||
enddo
|
||||
!
|
||||
! compute the atomic charges
|
||||
!
|
||||
allocate(rho_at(mesh))
|
||||
rho_at(:)=0.d0
|
||||
do nb = 1, nchi
|
||||
if( oc(nb).ne.0.d0) &
|
||||
rho_at(:) = rho_at(:) + oc(nb)*chi(:,nb)**2
|
||||
end do
|
||||
return
|
||||
|
||||
300 call error('read_ncpp','pseudo file is empty or wrong',1)
|
||||
|
||||
end subroutine read_ncpp
|
||||
|
||||
subroutine read_bhs
|
||||
|
||||
use ncpp
|
||||
use bhs
|
||||
use grid
|
||||
use wavefunctions
|
||||
|
||||
implicit none
|
||||
real(kind=8) erf
|
||||
integer nb, ios, is, i, n, l, ir
|
||||
external erf
|
||||
|
||||
read ( 1, *, err=300, iostat=ios ) zmesh, zp, lmax, lloc
|
||||
if ( zmesh.le.0.or.zmesh.gt.120.0 ) &
|
||||
call error( 'read_bhs','Wrong z ',1 )
|
||||
if ( zp.le.0.or.zp.gt.25.0 ) &
|
||||
call error( 'read_bhs','Wrong zp ',1 )
|
||||
if ( lloc.gt.3.or.lloc.lt.0 ) &
|
||||
call error( 'read_bhs','Wrong lloc ',1 )
|
||||
|
||||
read( 1, *, err=300, iostat=ios ) &
|
||||
( cc(i), alpc(i), i=1,2 )
|
||||
if ( abs(cc(1)+cc(2)-1.d0).gt.1.0d-6) &
|
||||
call error ('read_bhs','wrong pseudopotential coefficients',1)
|
||||
do l = 0, lmax
|
||||
read ( 1, *, err=300, iostat=ios ) &
|
||||
( alps(i,l), aps(i,l), aps(i+3,l), i=1,3)
|
||||
enddo
|
||||
|
||||
read(1, *, err=300, iostat=ios) mesh, dx
|
||||
|
||||
allocate( r(mesh))
|
||||
allocate(rab(mesh))
|
||||
!
|
||||
! Here pseudowavefunctions in numeric form are read
|
||||
!
|
||||
nchi=lmax
|
||||
allocate(chi(mesh,nchi))
|
||||
allocate(lchi(nchi))
|
||||
allocate(oc(nchi))
|
||||
do nb = 1, nchi
|
||||
lchi(nb)=nb
|
||||
oc(nb)=0.0
|
||||
if (nb.ne.1) read(1, *, err=300, iostat=ios) mesh, dx
|
||||
do ir=1,mesh
|
||||
read( 1, *, err=300, iostat=ios ) is, r(ir), chi(ir,nb)
|
||||
if (is.ne.ir) &
|
||||
call error('read_bhs','error 1 at line',ir)
|
||||
end do
|
||||
enddo
|
||||
|
||||
allocate(rho_at(mesh))
|
||||
rho_at(:)=0.d0
|
||||
!
|
||||
! compute the radial mesh derivative
|
||||
!
|
||||
do ir = 1, mesh
|
||||
rab(ir) = log(dx) * r(ir)
|
||||
end do
|
||||
!
|
||||
allocate(vnl(mesh,0:lmax))
|
||||
!
|
||||
! convert analytic to numeric form
|
||||
!
|
||||
do l=0,lmax
|
||||
! vnl(0,l) = - ( cc(1)*sqrt(alpc(1))+cc(2)*sqrt(alpc(2)))*zp
|
||||
do ir=1,mesh
|
||||
vnl(ir,l)= - ( cc(1)*erf(sqrt(alpc(1))*r(ir)) + &
|
||||
cc(2)*erf(sqrt(alpc(2))*r(ir)) ) * zp/r(ir)
|
||||
end do
|
||||
do n=1,3
|
||||
vnl(:,l)= vnl(:,l)+ (aps(n,l)+ aps(n+3,l)*r(:)**2 )* &
|
||||
exp(-alps(n,l)*r(:)**2)
|
||||
end do
|
||||
!
|
||||
! convert to Rydberg
|
||||
!
|
||||
vnl(:,l) = vnl(:,l)*2.0
|
||||
end do
|
||||
!
|
||||
! subract the local part
|
||||
!
|
||||
do l = 0, lmax
|
||||
if ( l.ne.lloc ) vnl(:,l) = vnl(:,l) - vnl(:,lloc)
|
||||
enddo
|
||||
|
||||
return
|
||||
|
||||
300 call error('read_bhs','pseudo file is empty or wrong',1)
|
||||
|
||||
end subroutine read_bhs
|
||||
|
||||
subroutine write_us
|
||||
|
||||
use ncpp
|
||||
use grid
|
||||
use wavefunctions
|
||||
use ultrasoft
|
||||
|
||||
implicit none
|
||||
real(kind=8), parameter:: pi=3.141592653589793d0
|
||||
integer iv, jv, l, lp, ir, convert_dft
|
||||
external convert_dft
|
||||
|
||||
write(2,'(6i5)') 7,3,2,0,0,0
|
||||
! iver, idmy
|
||||
|
||||
|
||||
title=psd//' '
|
||||
print '(''assumed title: '',a)',psd
|
||||
|
||||
z=zmesh
|
||||
exfact=convert_dft(dft)
|
||||
write(2, '(a20,3f15.9)' ) title, z, zp, exfact
|
||||
|
||||
nvales=nchi
|
||||
etotpseu=0
|
||||
write(2, '(2i5,1pe19.11)' ) nvales,mesh,etotpseu
|
||||
|
||||
ee =0.0
|
||||
do iv=1,nchi
|
||||
nnlz=10*lchi(iv)
|
||||
wwnl=oc(iv)
|
||||
write(2, '(i5,2f15.9)') nnlz, wwnl, ee
|
||||
end do
|
||||
|
||||
keyps=0
|
||||
if (nlcc) then
|
||||
ifpcor=1
|
||||
else
|
||||
ifpcor=0
|
||||
end if
|
||||
rinner=0.0
|
||||
write(2, '(2i5,f15.9)' ) keyps, ifpcor, rinner
|
||||
|
||||
! note that in the Vanderbilt program l runs from 1 to lmax+1
|
||||
if (lloc.eq.lmax) then
|
||||
nang=lmax
|
||||
else
|
||||
nang=lmax+1
|
||||
end if
|
||||
eloc=0.0
|
||||
ifqopt=0
|
||||
nqf=0
|
||||
dummy=0.0
|
||||
write(2, '(2i5,f9.5,2i5,f9.5)' ) nang, lloc, eloc, ifqopt, nqf, dummy
|
||||
|
||||
write(2, * ) (rinner, lp=1,2*nang-1)
|
||||
|
||||
if (z.ge.19) then
|
||||
irel=1
|
||||
else
|
||||
irel=0
|
||||
end if
|
||||
write(2,'(i5)') irel
|
||||
|
||||
rc=0.0
|
||||
write(2,'(1p4e19.11)') ( rc, l=1,nang )
|
||||
|
||||
nbeta=lmax
|
||||
! the definition of nbeta takes into account the absence of l=lloc
|
||||
! from the projectors
|
||||
kkbeta=mesh
|
||||
write (2,'(2i5)' ) nbeta, kkbeta
|
||||
|
||||
allocate(betar(kkbeta))
|
||||
allocate(qfunc(kkbeta,nbeta,nbeta))
|
||||
allocate(dion(nbeta,nbeta))
|
||||
allocate(ddd (nbeta,nbeta))
|
||||
allocate(qqq (nbeta,nbeta))
|
||||
iv=0
|
||||
do l=0,lmax
|
||||
if (l.ne.lloc) then
|
||||
iv=iv+1
|
||||
write(2, '(i5)') l
|
||||
|
||||
eee=0.0
|
||||
betar(:)=chi(:,l+1)*vnl(:,l)
|
||||
write(2, '(1p4e19.11)') eee, ( betar(ir), ir=1,kkbeta )
|
||||
|
||||
do jv=iv,nbeta
|
||||
if (jv.eq.iv) then
|
||||
betar(:)=chi(:,l+1)*betar(:)
|
||||
call simpson(mesh,betar,rab,dion(iv,jv))
|
||||
dion(iv,jv)=1.0/dion(iv,jv)
|
||||
else
|
||||
dion(iv,jv)= 0.0
|
||||
end if
|
||||
ddd(iv,jv)= 0.0
|
||||
qqq(iv,jv)= 0.0
|
||||
qfunc(:,iv,jv)=0.0
|
||||
write(2, '(1p4e19.11)' ) dion(iv,jv), &
|
||||
ddd(iv,jv), qqq(iv,jv), &
|
||||
(qfunc(ir,iv,jv),ir=1,kkbeta)
|
||||
enddo
|
||||
end if
|
||||
enddo
|
||||
|
||||
iptype=0
|
||||
write(2, '(6i5)' ) (iptype, iv=1,nbeta)
|
||||
|
||||
npf=0
|
||||
write(2, '(i5,f15.9)') npf, dummy
|
||||
|
||||
rcloc=0.0
|
||||
allocate(vloc0(mesh))
|
||||
vloc0(:)=r(:)*vnl(:,lloc)
|
||||
write(2, '(1p4e19.11)' ) rcloc, ( vloc0(ir), ir=1,mesh )
|
||||
|
||||
if ( ifpcor.eq.1 ) then
|
||||
write(2, '(1p4e19.11)') dummy
|
||||
! Vanderbilt rho_atc(r) = 4pi*r^2*rho_atc(r) PWSCF
|
||||
write(2, '(1p4e19.11)') ( rho_atc(ir)*r(ir)**2*4.d0*pi, ir=1,mesh )
|
||||
endif
|
||||
|
||||
vloc0(:)=0.0
|
||||
write(2, '(1p4e19.11)') (vloc0(ir), ir=1,mesh)
|
||||
|
||||
write(2, '(1p4e19.11)') (rho_at(ir), ir=1,mesh)
|
||||
|
||||
write(2, '(1p4e19.11)') (r(ir),ir=1,mesh)
|
||||
write(2, '(1p4e19.11)') (rab(ir),ir=1,mesh)
|
||||
|
||||
write(2, '(i5)') nvales
|
||||
|
||||
write(2, '(1p4e19.11)') ((chi(ir,iv),ir=1,mesh),iv=1,nvales)
|
||||
|
||||
return
|
||||
end subroutine write_us
|
||||
|
||||
|
||||
subroutine simpson( mesh, func, rab, intg )
|
||||
|
||||
implicit none
|
||||
integer mesh
|
||||
real(kind=8) func(mesh), rab(mesh), intg
|
||||
|
||||
real(kind=8) c(4)
|
||||
integer I
|
||||
|
||||
if ( mesh .lt. 8 ) call error('simpson','few mesh points',8)
|
||||
|
||||
c(1) = 109.0 / 48.d0
|
||||
c(2) = -5.d0 / 48.d0
|
||||
c(3) = 63.d0 / 48.d0
|
||||
c(4) = 49.d0 / 48.d0
|
||||
|
||||
intg = ( func(1)*rab(1) + func(mesh )*rab(mesh ) )*c(1) &
|
||||
+ ( func(2)*rab(2) + func(mesh-1)*rab(mesh-1) )*c(2) &
|
||||
+ ( func(3)*rab(3) + func(mesh-2)*rab(mesh-2) )*c(3) &
|
||||
+ ( func(4)*rab(4) + func(mesh-3)*rab(mesh-3) )*c(4)
|
||||
do i=5,mesh-4
|
||||
intg = intg + func(i)*rab(i)
|
||||
end do
|
||||
|
||||
return
|
||||
end subroutine simpson
|
||||
|
||||
subroutine error(a,b,n)
|
||||
character(len=*) a,b
|
||||
|
||||
write(6,'(//'' program '',a,'':'',a,''.'',8x,i8,8x,''stop'')') a,b,n
|
||||
stop
|
||||
end subroutine error
|
||||
|
||||
!
|
||||
! Copyright (C) 2002 CP90 group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!---------------------------------------------------------------------
|
||||
real(kind=8) function erf (x)
|
||||
!---------------------------------------------------------------------
|
||||
!
|
||||
! Error function - computed from the rational approximations of
|
||||
! W. J. Cody, Math. Comp. 22 (1969), pages 631-637.
|
||||
!
|
||||
! for abs(x) le 0.47 erf is calculated directly
|
||||
! for abs(x) gt 0.47 erf is calculated via erf(x)=1-erfc(x)
|
||||
!
|
||||
implicit none
|
||||
real(kind=8) :: x, x2, p1 (4), q1 (4), erfc
|
||||
external erfc
|
||||
data p1 / 2.42667955230532d2, 2.19792616182942d1, &
|
||||
6.99638348861914d0, - 3.56098437018154d-2 /
|
||||
data q1 / 2.15058875869861d2, 9.11649054045149d1, &
|
||||
1.50827976304078d1, 1.00000000000000d0 /
|
||||
!
|
||||
if (abs (x) .gt.6.d0) then
|
||||
!
|
||||
! erf(6)=1-10^(-17) cannot be distinguished from 1 with 16-byte words
|
||||
!
|
||||
erf = sign (1.d0, x)
|
||||
else
|
||||
if (abs (x) .le.0.47d0) then
|
||||
x2 = x**2
|
||||
erf = x * (p1 (1) + x2 * (p1 (2) + x2 * (p1 (3) + x2 * p1 ( &
|
||||
4) ) ) ) / (q1 (1) + x2 * (q1 (2) + x2 * (q1 (3) + x2 * q1 ( &
|
||||
4) ) ) )
|
||||
else
|
||||
erf = 1.d0 - erfc (x)
|
||||
endif
|
||||
endif
|
||||
!
|
||||
return
|
||||
end function erf
|
||||
!
|
||||
!---------------------------------------------------------------------
|
||||
real(kind=8) function erfc (x)
|
||||
!---------------------------------------------------------------------
|
||||
!
|
||||
! erfc(x) = 1-erf(x) - See comments in erf
|
||||
!
|
||||
implicit none
|
||||
real(kind=8) :: x, ax, x2, xm2, erf, p2 (8), q2 (8), p3 (5), q3 (5), &
|
||||
pim1
|
||||
external erf
|
||||
data p2 / 3.00459261020162d2, 4.51918953711873d2, &
|
||||
3.39320816734344d2, 1.52989285046940d2, 4.31622272220567d1, &
|
||||
7.21175825088309d0, 5.64195517478974d-1, - 1.36864857382717d-7 /
|
||||
data q2 / 3.00459260956983d2, 7.90950925327898d2, &
|
||||
9.31354094850610d2, 6.38980264465631d2, 2.77585444743988d2, &
|
||||
7.70001529352295d1, 1.27827273196294d1, 1.00000000000000d0 /
|
||||
data p3 / - 2.99610707703542d-3, - 4.94730910623251d-2, - &
|
||||
2.26956593539687d-1, - 2.78661308609648d-1, - 2.23192459734185d-2 &
|
||||
/
|
||||
data q3 / 1.06209230528468d-2, 1.91308926107830d-1, &
|
||||
1.05167510706793d0, 1.98733201817135d0, 1.00000000000000d0 /
|
||||
|
||||
data pim1 / 0.564189583547756d0 /
|
||||
! ( pim1= sqrt(1/pi) )
|
||||
ax = abs (x)
|
||||
if (ax.gt.26.d0) then
|
||||
!
|
||||
! erfc(26.0)=10^(-296); erfc( 9.0)=10^(-37);
|
||||
!
|
||||
erfc = 0.d0
|
||||
elseif (ax.gt.4.d0) then
|
||||
x2 = x**2
|
||||
xm2 = (1.d0 / ax) **2
|
||||
erfc = (1.d0 / ax) * exp ( - x2) * (pim1 + xm2 * (p3 (1) &
|
||||
+ xm2 * (p3 (2) + xm2 * (p3 (3) + xm2 * (p3 (4) + xm2 * p3 (5) &
|
||||
) ) ) ) / (q3 (1) + xm2 * (q3 (2) + xm2 * (q3 (3) + xm2 * &
|
||||
(q3 (4) + xm2 * q3 (5) ) ) ) ) )
|
||||
elseif (ax.gt.0.47d0) then
|
||||
x2 = x**2
|
||||
erfc = exp ( - x2) * (p2 (1) + ax * (p2 (2) + ax * (p2 (3) &
|
||||
+ ax * (p2 (4) + ax * (p2 (5) + ax * (p2 (6) + ax * (p2 (7) &
|
||||
+ ax * p2 (8) ) ) ) ) ) ) ) / (q2 (1) + ax * (q2 (2) + ax * &
|
||||
(q2 (3) + ax * (q2 (4) + ax * (q2 (5) + ax * (q2 (6) + ax * &
|
||||
(q2 (7) + ax * q2 (8) ) ) ) ) ) ) )
|
||||
else
|
||||
erfc = 1.d0 - erf (ax)
|
||||
endif
|
||||
!
|
||||
! erf(-x)=-erf(x) => erfc(-x) = 2-erfc(x)
|
||||
!
|
||||
if (x.lt.0.d0) erfc = 2.d0 - erfc
|
||||
!
|
||||
return
|
||||
end function erfc
|
||||
!---------------------------------------------------------------------
|
||||
real(kind=8) function freq (x)
|
||||
!---------------------------------------------------------------------
|
||||
!
|
||||
! freq(x) = (1+erf(x/sqrt(2)))/2 = erfc(-x/sqrt(2))/2
|
||||
! - See comments in erf
|
||||
!
|
||||
real(kind=8) :: x, c, erf, erfc
|
||||
external erf
|
||||
|
||||
data c / 0.707106781186548d0 /
|
||||
! ( c= sqrt(1/2) )
|
||||
freq = 0.5d0 * erfc ( - x * c)
|
||||
!
|
||||
return
|
||||
end function freq
|
||||
|
||||
subroutine bachel(alps,aps,npseu,lmax)
|
||||
|
||||
implicit none
|
||||
|
||||
integer npseu, lmax(npseu)
|
||||
real(kind=8) alps(3,0:3,npseu), aps(6,0:3,npseu)
|
||||
|
||||
integer np, lmx, l, i, j, k, ia, ka, nik
|
||||
real(kind=8), parameter:: pi=3.141592653589793d0
|
||||
real(kind=8) s(6,6), alpl, alpi, ail
|
||||
|
||||
do np=1,npseu
|
||||
lmx=lmax(np)
|
||||
do l=0,lmx
|
||||
do k=1,6
|
||||
ka= mod(k-1,3)+1
|
||||
alpl= alps(ka,l,np)
|
||||
do i=1,k
|
||||
ia= mod(i-1,3)+1
|
||||
alpi= alps(ia,l,np)
|
||||
ail=alpi+alpl
|
||||
s(i,k)= sqrt(pi/ail)/4.d0/ail
|
||||
nik=int((k-1)/3)+int((i-1)/3)+1
|
||||
do j=2, nik
|
||||
s(i,k)= s(i,k)/2.d0/ail*(2*j-1)
|
||||
end do
|
||||
end do
|
||||
end do
|
||||
|
||||
do i=1,6
|
||||
do j=i,6
|
||||
do k=1,i-1
|
||||
s(i,j)=s(i,j)-s(k,i)*s(k,j)
|
||||
end do
|
||||
if(i.eq.j) then
|
||||
s(i,i)=sqrt(s(i,i))
|
||||
else
|
||||
s(i,j)=s(i,j)/s(i,i)
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
|
||||
aps(6,l,np)=-aps(6,l,np)/s(6,6)
|
||||
do i=5,1,-1
|
||||
aps(i,l,np)=-aps(i,l,np)
|
||||
do k=i+1,6
|
||||
aps(i,l,np)=aps(i,l,np)-aps(k,l,np)*s(i,k)
|
||||
end do
|
||||
aps(i,l,np)=aps(i,l,np)/s(i,i)
|
||||
end do
|
||||
end do
|
||||
end do
|
||||
|
||||
return
|
||||
end subroutine bachel
|
||||
|
||||
integer function convert_dft (dft)
|
||||
character(len=*) dft
|
||||
integer i, index, ichar, len
|
||||
character(len=1) char
|
||||
!
|
||||
! convert to lowercase
|
||||
!
|
||||
do i=1,len(trim(dft))
|
||||
index = ichar(dft(i:i))
|
||||
if (index.ge.65 .and. index.le.90) dft(i:i) = char(index+32)
|
||||
end do
|
||||
!
|
||||
if (trim(dft).eq.'pz'.or.trim(dft).eq."'pz'") then
|
||||
convert_dft=0
|
||||
else if (trim(dft).eq.'blyp'.or.trim(dft).eq."'blyp'") then
|
||||
convert_dft=1
|
||||
else if (trim(dft).eq.'b88'.or.trim(dft).eq."'b88'") then
|
||||
convert_dft=2
|
||||
else if (trim(dft).eq.'bp'.or.trim(dft).eq."'bp'") then
|
||||
convert_dft=3
|
||||
else if (trim(dft).eq.'pw91'.or.trim(dft).eq."'pw91'") then
|
||||
convert_dft=4
|
||||
else if (trim(dft).eq.'pbe'.or.trim(dft).eq."'pbe'") then
|
||||
convert_dft=5
|
||||
else
|
||||
print *, '***dft unknown: ',dft,'***'
|
||||
print *, '***exfact is set to bogus value -9, change by hand!***'
|
||||
convert_dft=-9
|
||||
end if
|
||||
!
|
||||
return
|
||||
end function convert_dft
|
||||
|
|
@ -0,0 +1,99 @@
|
|||
!
|
||||
!---------------------------------------------------------------------
|
||||
subroutine read_pseudo (is, iunps, ierr)
|
||||
!---------------------------------------------------------------------
|
||||
!
|
||||
! read "is"-th pseudopotential in the Unified Pseudopotential Format
|
||||
! from unit "iunps" - convert and copy to internal PWscf variables
|
||||
! return error code in "ierr" (success: ierr=0)
|
||||
!
|
||||
! CP90 modules
|
||||
!
|
||||
use ncprm
|
||||
use dft_mod
|
||||
use wfc_atomic
|
||||
use ions_module, only: zv
|
||||
!
|
||||
use pseudo_types
|
||||
use read_pseudo_module
|
||||
!
|
||||
implicit none
|
||||
!
|
||||
integer :: is, iunps, ierr
|
||||
!
|
||||
! Local variables
|
||||
!
|
||||
integer :: nb, iexch, icorr, igcx, igcc
|
||||
TYPE (pseudo_upf) :: upf
|
||||
!
|
||||
!
|
||||
call read_pseudo_upf(iunps, upf, ierr)
|
||||
!
|
||||
if (ierr .ne. 0) return
|
||||
!
|
||||
zv(is) = upf%zp
|
||||
! psd (is)= upf%psd
|
||||
! tvanp(is)=upf%tvanp
|
||||
if (upf%nlcc) then
|
||||
ifpcor(is) = 1
|
||||
else
|
||||
ifpcor(is) = 0
|
||||
end if
|
||||
!
|
||||
call which_dft (upf%dft, iexch, icorr, igcx, igcc)
|
||||
if (iexch==1.and.icorr==1.and.igcx==0.and.igcc==0) then
|
||||
dft = lda
|
||||
else if (iexch==1.and.icorr==3.and.igcx==1.and.igcc==3) then
|
||||
dft = blyp
|
||||
else if (iexch==1.and.icorr==1.and.igcx==1.and.igcc==1) then
|
||||
dft = bp88
|
||||
else if (iexch==1.and.icorr==4.and.igcx==2.and.igcc==2) then
|
||||
dft = pw91
|
||||
else if (iexch==1.and.icorr==4.and.igcx==3.and.igcc==4) then
|
||||
dft = pbe
|
||||
else
|
||||
dft = -9
|
||||
end if
|
||||
!
|
||||
mesh(is) = upf%mesh
|
||||
!
|
||||
nchi(is) = upf%nwfc
|
||||
lchi(1:upf%nwfc, is) = upf%lchi(1:upf%nwfc)
|
||||
! oc(1:upf%nwfc, is) = upf%oc(1:upf%nwfc)
|
||||
chi(1:upf%mesh, 1:upf%nwfc, is) = upf%chi(1:upf%mesh, 1:upf%nwfc)
|
||||
!
|
||||
nbeta(is)= upf%nbeta
|
||||
kkbeta(is)=0
|
||||
do nb=1,upf%nbeta
|
||||
kkbeta(is)=max(upf%kkbeta(nb),kkbeta(is))
|
||||
end do
|
||||
betar(1:upf%mesh, 1:upf%nbeta, is) = upf%beta(1:upf%mesh, 1:upf%nbeta)
|
||||
dion(1:upf%nbeta, 1:upf%nbeta, is) = upf%dion(1:upf%nbeta, 1:upf%nbeta)
|
||||
!
|
||||
! lmax(is) = upf%lmax
|
||||
nqlc(is) = upf%nqlc
|
||||
nqf (is) = upf%nqf
|
||||
lll(1:upf%nbeta,is) = upf%lll(1:upf%nbeta)
|
||||
rinner(1:upf%nqlc,is) = upf%rinner(1:upf%nqlc)
|
||||
qqq(1:upf%nbeta,1:upf%nbeta,is) = upf%qqq(1:upf%nbeta,1:upf%nbeta)
|
||||
qfunc (1:upf%mesh, 1:upf%nbeta, 1:upf%nbeta, is) = &
|
||||
upf%qfunc(1:upf%mesh,1:upf%nbeta,1:upf%nbeta)
|
||||
qfcoef(1:upf%nqf, 1:upf%nqlc, 1:upf%nbeta, 1:upf%nbeta, is ) = &
|
||||
upf%qfcoef( 1:upf%nqf, 1:upf%nqlc, 1:upf%nbeta, 1:upf%nbeta )
|
||||
!
|
||||
r (1:upf%mesh, is) = upf%r (1:upf%mesh)
|
||||
rab(1:upf%mesh, is) = upf%rab(1:upf%mesh)
|
||||
!
|
||||
if ( upf%nlcc) then
|
||||
rscore (1:upf%mesh, is) = upf%rho_atc(1:upf%mesh)
|
||||
else
|
||||
rscore (:,is) = 0.d0
|
||||
end if
|
||||
! rsatom (1:upf%mesh, is) = upf%rho_at (1:upf%mesh)
|
||||
! lloc(is) = 1
|
||||
!!! TEMP: compatibility with Vanderbilt, Vloc => r*Vloc
|
||||
rucore(1:upf%mesh, 1,is) = upf%vloc(1:upf%mesh) * upf%r (1:upf%mesh)
|
||||
!!!
|
||||
CALL deallocate_pseudo_upf( upf )
|
||||
|
||||
end subroutine read_pseudo
|
||||
|
|
@ -0,0 +1,660 @@
|
|||
MODULE restart
|
||||
IMPLICIT NONE
|
||||
SAVE
|
||||
|
||||
CONTAINS
|
||||
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine writefile_new &
|
||||
& ( ndw,h,hold,nfi,c0,cm,taus,tausm,vels,velsm,acc, &
|
||||
& lambda,lambdam,xnhe0,xnhem,vnhe,xnhp0,xnhpm,vnhp,ekincm, &
|
||||
& xnhh0,xnhhm,vnhh,velh,ecut,ecutw,delt,pmass,ibrav,celldm,fion)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! read from file and distribute data calculated in preceding iterations
|
||||
!
|
||||
use elct, only: n, nx, ngw, ng0, nspin, nel, ngw_g
|
||||
use ions_module, only: nsp, na, nax
|
||||
use parm, ONLY: nr1, nr2, nr3
|
||||
use gvec, ONLY: ng, ngl, mill_g, ng_g, mill_l, bi1, bi2, bi3, ig_l2g
|
||||
use io_base, only: write_restart_header, write_restart_ions, &
|
||||
write_restart_cell, write_restart_electrons, &
|
||||
write_restart_gvec, write_restart_gkvec, write_restart_charge, &
|
||||
write_restart_wfc, write_restart_symmetry, &
|
||||
write_restart_xdim, write_restart_pseudo
|
||||
use mp, only: mp_sum
|
||||
use mp_global
|
||||
use io_global
|
||||
use cell_module, only: boxdimensions, s_to_r, cell_init
|
||||
USE ncprm, ONLY: r, rab
|
||||
!
|
||||
implicit none
|
||||
integer :: ndw, nfi
|
||||
real(kind=8) :: h(3,3), hold(3,3)
|
||||
complex(kind=8) :: c0(:,:), cm(:,:)
|
||||
real(kind=8) :: tausm(:,:,:),taus(:,:,:), fion(:,:,:)
|
||||
real(kind=8) :: vels(:,:,:), velsm(:,:,:)
|
||||
real(kind=8) :: acc(:),lambda(:,:), lambdam(:,:)
|
||||
real(kind=8) :: xnhe0,xnhem,vnhe,xnhp0,xnhpm,vnhp,ekincm
|
||||
real(kind=8) :: xnhh0(3,3),xnhhm(3,3),vnhh(3,3),velh(3,3)
|
||||
real(kind=8), INTENT(in) :: ecut, ecutw, delt
|
||||
real(kind=8), INTENT(in) :: pmass(:)
|
||||
real(kind=8), INTENT(in) :: celldm(:)
|
||||
integer, INTENT(in) :: ibrav
|
||||
integer :: nbeg = 0
|
||||
integer :: nk = 1
|
||||
integer :: ngwkl(1), ngwkg(1), nbnd, nelt, nelu, neld, ntyp, nb_g
|
||||
integer :: nat = 0
|
||||
integer :: nacx = 10
|
||||
real(kind=8) :: trutime = 0.0d0
|
||||
real(kind=8) :: ecutwfc, ecutrho
|
||||
|
||||
REAL(dbl), ALLOCATABLE :: stau0(:,:), staum(:,:), svel0(:,:), svelm(:,:), tautmp(:,:)
|
||||
REAL(dbl), ALLOCATABLE :: fiontmp(:,:)
|
||||
type (boxdimensions) :: box
|
||||
real(dbl) :: ht(3,3), htvel(3,3), ht0(3,3), htm(3,3), htm2(3,3)
|
||||
real(dbl) :: xdum
|
||||
real(dbl) :: hdum(3,3)
|
||||
real(dbl) :: cdmi(3)
|
||||
real(dbl) :: mass(nsp)
|
||||
real(dbl), allocatable :: occ(:), occm(:), lamtmp(:,:), lamtmpm(:,:), eigtmp(:)
|
||||
LOGICAL :: tocc, tlam, trho, tv, tw0, twm
|
||||
integer, allocatable :: mill(:,:), igk(:)
|
||||
real(dbl) :: xk(3), wk
|
||||
complex(kind=8), allocatable :: rhog(:), vg(:)
|
||||
|
||||
LOGICAL :: lstres, lforce
|
||||
character(len=80) :: title, crystal, tmp_dir
|
||||
!
|
||||
integer i, ia, is, j, ispin, ik
|
||||
integer :: strlen
|
||||
character(len=80) :: filename
|
||||
|
||||
LOGICAL :: tovrw = .FALSE.
|
||||
INTEGER :: k1, k2, k3, nk1, nk2, nk3
|
||||
REAL(dbl) :: dgauss
|
||||
INTEGER :: ngauss
|
||||
INTEGER :: ntetra
|
||||
INTEGER :: natomwfc
|
||||
LOGICAL :: doublegrid, tupf
|
||||
REAL(dbl) :: gcutm, gcuts, dual
|
||||
INTEGER :: modenum, kunit
|
||||
REAL(dbl) :: alat
|
||||
REAL(dbl) :: ef, rnel, wfc_scal_cp90
|
||||
character(len=4) :: atom_label(nsp)
|
||||
|
||||
LOGICAL :: twrite
|
||||
LOGICAL :: tscal
|
||||
LOGICAL :: teig
|
||||
LOGICAL :: tmill
|
||||
LOGICAL :: lgauss
|
||||
LOGICAL :: ltetra
|
||||
INTEGER, ALLOCATABLE :: ityp(:)
|
||||
INTEGER :: isk, tetra(4)
|
||||
REAL(dbl) :: zmesh_, xmin_, dx_
|
||||
|
||||
!
|
||||
! Only the first node writes
|
||||
!
|
||||
if (ionode) then
|
||||
! open (unit=ndw,status='unknown',form='unformatted')
|
||||
CALL cpitoa(ndw, filename)
|
||||
filename = 'fort.'//filename
|
||||
strlen = index(filename,' ') - 1
|
||||
OPEN(unit=ndw, file=filename(1:strlen), form='unformatted', status='unknown')
|
||||
REWIND ndw
|
||||
end if
|
||||
|
||||
ht = TRANSPOSE(h)
|
||||
call cell_init(box,ht)
|
||||
|
||||
! ==--------------------------------------------------------------==
|
||||
! == WRITE HEADER INFORMATIONS ==
|
||||
! ==--------------------------------------------------------------==
|
||||
|
||||
ngwkg(1) = ngw_g
|
||||
ngwkl(1) = ngw
|
||||
nbnd = n
|
||||
IF( nspin > 1 ) THEN
|
||||
nelu = nel(1)
|
||||
neld = nel(2)
|
||||
ELSE
|
||||
nelu = 0
|
||||
neld = 0
|
||||
END IF
|
||||
nelt = nel(1)+nel(2)
|
||||
rnel = REAL(nelt)
|
||||
ntyp = nsp
|
||||
nat = SUM( na(1:ntyp) )
|
||||
ecutwfc = ecutw
|
||||
ecutrho = ecut
|
||||
title = ''
|
||||
crystal = ''
|
||||
tmp_dir = ''
|
||||
kunit = 1
|
||||
lgauss = .FALSE.
|
||||
ltetra = .FALSE.
|
||||
twrite = .TRUE.
|
||||
tupf = .TRUE.
|
||||
CALL write_restart_header(ndw, twrite, nfi, trutime, nbeg, nr1, nr2, nr3, &
|
||||
nr1, nr2, nr3, ng, ng_g, nk, nk, ngwkl, ngwkg, nspin, nbnd, rnel, nelu, &
|
||||
neld, nat, ntyp, na, acc, nacx, ecutwfc, ecutrho, alat, ekincm, &
|
||||
kunit, k1, k2, k3, nk1, nk2, nk3, dgauss, ngauss, lgauss, ntetra, ltetra, &
|
||||
natomwfc, gcutm, gcuts, dual, doublegrid, modenum, lstres, lforce, &
|
||||
title, crystal, tmp_dir, tupf)
|
||||
|
||||
! ==--------------------------------------------------------------==
|
||||
! == MAX DIMENSIONS ==
|
||||
! ==--------------------------------------------------------------==
|
||||
|
||||
CALL write_restart_xdim( ndw )
|
||||
|
||||
! ==--------------------------------------------------------------==
|
||||
! == CELL & METRIC ==
|
||||
! ==--------------------------------------------------------------==
|
||||
|
||||
hdum = 0.0d0
|
||||
ht = TRANSPOSE(h)
|
||||
htm = TRANSPOSE(hold)
|
||||
htvel = TRANSPOSE(velh)
|
||||
htm2 = 0.0d0
|
||||
twrite = .TRUE.
|
||||
CALL write_restart_cell( ndw, twrite, ibrav, celldm, ht, htm, &
|
||||
htm2, htvel, vnhh, xnhh0, xnhhm, hdum)
|
||||
|
||||
! ==--------------------------------------------------------------==
|
||||
! == IONS ==
|
||||
! ==--------------------------------------------------------------==
|
||||
|
||||
ALLOCATE( stau0(3, nat) )
|
||||
ALLOCATE( staum(3, nat) )
|
||||
ALLOCATE( svel0(3, nat) )
|
||||
ALLOCATE( svelm(3, nat) )
|
||||
ALLOCATE( tautmp(3, nat) )
|
||||
ALLOCATE( fiontmp(3, nat) )
|
||||
ALLOCATE( ityp(nat) )
|
||||
|
||||
ia = 0
|
||||
DO i = 1, nsp
|
||||
DO j = 1, na(i)
|
||||
ia = ia + 1
|
||||
stau0(:,ia) = taus(:,j,i)
|
||||
staum(:,ia) = tausm(:,j,i)
|
||||
svel0(:,ia) = vels(:,j,i)
|
||||
svelm(:,ia) = velsm(:,j,i)
|
||||
CALL s_to_r( taus(:,j,i), tautmp(:,ia), box )
|
||||
fiontmp(:,ia) = fion(:,j,i)
|
||||
ityp(ia) = i
|
||||
END DO
|
||||
mass(i) = pmass(i)
|
||||
END DO
|
||||
|
||||
xdum = 0.0d0
|
||||
cdmi = 0.0d0
|
||||
tscal = .TRUE.
|
||||
twrite = .TRUE.
|
||||
CALL write_restart_ions(ndw, twrite, atom_label, tscal, stau0, svel0, &
|
||||
staum, svelm, tautmp, fiontmp, cdmi, nat, ntyp, ityp, na, mass, &
|
||||
vnhp, xnhp0, xnhpm, xdum)
|
||||
|
||||
DEALLOCATE( stau0, staum, svel0, svelm, tautmp, fiontmp, ityp )
|
||||
|
||||
! ==--------------------------------------------------------------==
|
||||
! == SYMMETRIES ==
|
||||
! ==--------------------------------------------------------------==
|
||||
|
||||
CALL write_restart_symmetry( ndw )
|
||||
|
||||
! ==--------------------------------------------------------------==
|
||||
! == PSEUDOPOTENTIALS ==
|
||||
! ==--------------------------------------------------------------==
|
||||
|
||||
DO i = 1, nsp
|
||||
! CALL write_restart_pseudo( ndw, twrite, &
|
||||
! zmesh_, xmin_, dx_, r(:,i), rab(:,i), vnl(:,:,i), chi(:,:,i), oc(:,i), &
|
||||
! rho_at(:,i), rho_atc(:,i), mesh(i), msh(i), nchi(i), lchi(:,i), &
|
||||
! numeric(i), cc(:,i), alpc(:,i), zp(i), aps(:,:,i), alps(:,:,i), &
|
||||
! zv(i), nlc(i), nnl(i), lmax(i), lloc(i), bhstype(i), dion(:,:,i), &
|
||||
! betar(:,:,i), qqq(:,:,i), qfunc(:,:,:,i), qfcoef(:,:,:,:,i), &
|
||||
! rinner(:,i), nh(i), nbeta(i), kkbeta(i), nqf(i), nqlc(i), ifqopt(i), &
|
||||
! lll(:,i), iver(:,i), tvanp(i), okvan, newpseudo(i), iexch, icorr, &
|
||||
! igcx, igcc, lsda, a_nlcc(i), b_nlcc(i), alpha_nlcc(i), nlcc(i), psd(i) )
|
||||
CALL write_restart_pseudo( ndw )
|
||||
END DO
|
||||
|
||||
|
||||
! ==--------------------------------------------------------------==
|
||||
! == OCCUPATION NUMBER ==
|
||||
! ==--------------------------------------------------------------==
|
||||
|
||||
ALLOCATE( occ(nbnd), eigtmp(nbnd) )
|
||||
|
||||
occ = 0.0d0
|
||||
ik = 1
|
||||
ispin = 1
|
||||
rnel = REAL(nelt)
|
||||
tocc = .FALSE.
|
||||
tlam = .TRUE.
|
||||
teig = .FALSE.
|
||||
twrite = .TRUE.
|
||||
CALL write_restart_electrons( ndw, twrite, occ, occ, tocc, lambda, lambdam, &
|
||||
nx, tlam, nbnd, ispin, nspin, ik, nk, rnel, nelu, neld, vnhe, xnhe0, xnhem, xdum, &
|
||||
ef, teig, eigtmp, eigtmp)
|
||||
|
||||
DEALLOCATE( occ, eigtmp )
|
||||
|
||||
|
||||
! ==--------------------------------------------------------------==
|
||||
! == G-Vectors ==
|
||||
! ==--------------------------------------------------------------==
|
||||
|
||||
ALLOCATE( mill(3,ng_g) )
|
||||
mill = 0
|
||||
DO i = 1, ng
|
||||
mill(:,ig_l2g(i)) = mill_l(:,i)
|
||||
END DO
|
||||
CALL mp_sum( mill )
|
||||
tmill = .TRUE.
|
||||
twrite = .TRUE.
|
||||
CALL write_restart_gvec( ndw, twrite, ng_g, bi1, bi2, bi3, &
|
||||
bi1, bi2, bi3, tmill, mill )
|
||||
DEALLOCATE( mill )
|
||||
|
||||
|
||||
! ==--------------------------------------------------------------==
|
||||
! == (G+k)-Vectors ==
|
||||
! ==--------------------------------------------------------------==
|
||||
|
||||
DO i = 1, nk
|
||||
xk(1) = 0.0d0
|
||||
xk(2) = 0.0d0
|
||||
xk(3) = 0.0d0
|
||||
wk = 1.0d0
|
||||
tetra = 0.0d0
|
||||
isk = 1
|
||||
twrite = .TRUE.
|
||||
CALL write_restart_gkvec(ndw, twrite, i, nk, ngwkg(i), xk, wk, tetra, isk)
|
||||
END DO
|
||||
|
||||
! ==--------------------------------------------------------------==
|
||||
! == CHARGE DENSITY AND POTENTIALS ==
|
||||
! ==--------------------------------------------------------------==
|
||||
|
||||
trho = .FALSE.
|
||||
tv = .FALSE.
|
||||
twrite = .TRUE.
|
||||
DO j = 1, nspin
|
||||
ALLOCATE( rhog(ng), vg(ng) )
|
||||
! CALL fft_initialize
|
||||
! CALL pfwfft( rhog(:,i), rho(i)%r(:,:,:) )
|
||||
! CALL pfwfft( vg(:,i) , vpot(:,:,:,i) )
|
||||
CALL write_restart_charge(ndw, twrite, rhog, trho, vg, tv, ng_g, &
|
||||
j, nspin, ig_l2g, ng )
|
||||
DEALLOCATE( rhog, vg )
|
||||
END DO
|
||||
|
||||
|
||||
! ==--------------------------------------------------------------==
|
||||
! == WAVEFUNCTIONS ==
|
||||
! ==--------------------------------------------------------------==
|
||||
|
||||
tw0 = .TRUE.
|
||||
twm = .TRUE.
|
||||
twrite = .TRUE.
|
||||
|
||||
wfc_scal_cp90 = 1.0d0
|
||||
DO j = 1, nspin
|
||||
DO i = 1, nk
|
||||
nb_g = nx
|
||||
CALL write_restart_wfc(ndw, twrite, i, nk, kunit, j, nspin, &
|
||||
wfc_scal_cp90, c0, tw0, cm, twm, ngw_g, nb_g, ig_l2g, ngw )
|
||||
END DO
|
||||
END DO
|
||||
|
||||
if(ionode) then
|
||||
close (unit=ndw)
|
||||
end if
|
||||
|
||||
return
|
||||
end subroutine
|
||||
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine readfile_new &
|
||||
& ( flag, ndr,h,hold,nfi,c0,cm,taus,tausm,vels,velsm,acc, &
|
||||
& lambda,lambdam,xnhe0,xnhem,vnhe,xnhp0,xnhpm,vnhp,ekincm, &
|
||||
& xnhh0,xnhhm,vnhh,velh,ecut,ecutw,delt,pmass,ibrav,celldm,fion)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! read from file and distribute data calculated in preceding iterations
|
||||
!
|
||||
use elct, only: n, nx, ngw, ng0, nspin, nel, ngw_g
|
||||
use ions_module, only: nsp, na, nax
|
||||
use parm, ONLY: nr1, nr2, nr3
|
||||
use gvec, ONLY: ng, ngl, mill_g, ng_g, mill_l, bi1, bi2, bi3, ig_l2g
|
||||
use io_base, only: read_restart_header, read_restart_ions, &
|
||||
read_restart_cell, read_restart_electrons, &
|
||||
read_restart_gvec, read_restart_gkvec, read_restart_charge, &
|
||||
read_restart_wfc, read_restart_xdim, &
|
||||
read_restart_symmetry, read_restart_pseudo
|
||||
use mp, only: mp_sum
|
||||
use mp_global
|
||||
use io_global
|
||||
use cell_module, only: boxdimensions, s_to_r, cell_init, r_to_s
|
||||
!
|
||||
implicit none
|
||||
integer :: ndr, nfi, flag
|
||||
real(kind=8) :: h(3,3), hold(3,3)
|
||||
complex(kind=8) :: c0(:,:), cm(:,:)
|
||||
real(kind=8) :: tausm(:,:,:),taus(:,:,:), fion(:,:,:)
|
||||
real(kind=8) :: vels(:,:,:), velsm(:,:,:)
|
||||
real(kind=8) :: acc(:),lambda(:,:), lambdam(:,:)
|
||||
real(kind=8) :: xnhe0,xnhem,vnhe,xnhp0,xnhpm,vnhp,ekincm
|
||||
real(kind=8) :: xnhh0(3,3),xnhhm(3,3),vnhh(3,3),velh(3,3)
|
||||
real(kind=8), INTENT(in) :: ecut, ecutw, delt
|
||||
real(kind=8), INTENT(in) :: pmass(:)
|
||||
real(kind=8), INTENT(in) :: celldm(6)
|
||||
integer, INTENT(in) :: ibrav
|
||||
integer :: nbeg = 0
|
||||
integer :: nk = 1
|
||||
integer :: ngwkg(1), ngwkl(1), nbnd, nelt, nelu, neld, ntyp, nb_g
|
||||
integer :: nat = 0
|
||||
integer :: nacx = 10
|
||||
real(kind=8) :: trutime = 0.0d0
|
||||
real(kind=8) :: ecutwfc, ecutrho
|
||||
|
||||
REAL(dbl), ALLOCATABLE :: stau0(:,:), staum(:,:), svel0(:,:), svelm(:,:), tautmp(:,:)
|
||||
REAL(dbl), ALLOCATABLE :: fiontmp(:,:)
|
||||
type (boxdimensions) :: box, boxm
|
||||
real(dbl) :: ht(3,3), htvel(3,3), ht0(3,3), htm(3,3), htm2(3,3)
|
||||
real(dbl) :: xdum
|
||||
real(dbl) :: hdum(3,3)
|
||||
real(dbl) :: cdmi(3)
|
||||
real(dbl) :: mass(nsp)
|
||||
real(dbl), allocatable :: occ(:), eigtmp(:)
|
||||
LOGICAL :: tocc, tlam, trho, tv, tw0, twm
|
||||
integer, allocatable :: mill(:,:), igk(:)
|
||||
real(dbl) :: xk(3), wk
|
||||
complex(kind=8), allocatable :: rhog(:), vg(:)
|
||||
|
||||
LOGICAL :: tovrw = .FALSE.
|
||||
INTEGER :: k1, k2, k3, nk1, nk2, nk3
|
||||
REAL(dbl) :: dgauss
|
||||
INTEGER :: ngauss
|
||||
LOGICAL :: lgauss
|
||||
INTEGER :: ntetra
|
||||
LOGICAL :: ltetra
|
||||
INTEGER :: natomwfc
|
||||
LOGICAL :: doublegrid
|
||||
REAL(dbl) :: gcutm, gcuts, dual
|
||||
INTEGER :: modenum
|
||||
REAL(dbl) :: alat
|
||||
REAL(dbl) :: ef, rnel
|
||||
LOGICAL :: lstres, lforce
|
||||
character(len=80) :: title, crystal, tmp_dir
|
||||
character(len=4) :: atom_label(nsp)
|
||||
!
|
||||
integer :: i, ia, is, j
|
||||
integer :: nfi_, ik_, nk_, ispin_, nspin_, isk_, tetra_(4)
|
||||
real(kind=8) :: acc_(10), celldm_(6)
|
||||
real(kind=8) :: vnhp_, xnhp0_, xnhpm_
|
||||
integer :: strlen, ibrav_, kunit
|
||||
character(len=80) :: filename
|
||||
LOGICAL :: tread
|
||||
LOGICAL :: tscal
|
||||
LOGICAL :: tmill, tigl
|
||||
LOGICAL :: teig, tupf
|
||||
INTEGER, ALLOCATABLE :: ityp(:)
|
||||
REAL(dbl) :: wfc_scal, wfc_scal_cp90
|
||||
!
|
||||
! Only the first node read
|
||||
!
|
||||
if (ionode) then
|
||||
! open (unit=ndr, status='old', form='unformatted')
|
||||
CALL cpitoa(ndr, filename)
|
||||
filename = 'fort.'//filename
|
||||
strlen = index(filename,' ') - 1
|
||||
OPEN(unit=ndr, file=filename(1:strlen), form='unformatted', status='old')
|
||||
REWIND (ndr)
|
||||
WRITE(6,10)
|
||||
10 FORMAT(/,3X,'READING FROM RESTART FILE ...')
|
||||
end if
|
||||
|
||||
if (flag.eq.-1) then
|
||||
write(6,'((a,i3,a))') ' ### reading from file ',ndr,' only h ##'
|
||||
else if (flag.eq.0) then
|
||||
write(6,'((a,i3,a))') ' ## reading from file ',ndr,' only c0 ##'
|
||||
else
|
||||
write(6,'((a,i3))') ' ## reading from file ',ndr
|
||||
end if
|
||||
|
||||
! ==--------------------------------------------------------------==
|
||||
! == READ HEADER INFORMATIONS ==
|
||||
! ==--------------------------------------------------------------==
|
||||
|
||||
ngwkl(1) = ngw
|
||||
ngwkg(1) = ngw_g
|
||||
nbnd = n
|
||||
IF( nspin > 1 ) THEN
|
||||
nelu = nel(1)
|
||||
neld = nel(2)
|
||||
ELSE
|
||||
nelu = 0
|
||||
neld = 0
|
||||
END IF
|
||||
nelt = nel(1)+nel(2)
|
||||
rnel = REAL(nelt)
|
||||
ntyp = nsp
|
||||
nat = SUM( na(1:ntyp) )
|
||||
kunit = nk
|
||||
ecutwfc = ecutw
|
||||
ecutrho = ecut
|
||||
tread = .TRUE.
|
||||
tovrw = .FALSE.
|
||||
CALL read_restart_header(ndr, tovrw, tread, nfi_, trutime, nbeg, nr1, nr2, nr3, &
|
||||
nr1, nr2, nr3, ng, ng_g, nk, nk, ngwkl, ngwkg, nspin, nbnd, rnel, nelu, neld, &
|
||||
nat, ntyp, na, acc_, nacx, ecutwfc, ecutrho, alat, ekincm, &
|
||||
kunit, k1, k2, k3, nk1, nk2, nk3, dgauss, ngauss, lgauss, ntetra, ltetra, &
|
||||
natomwfc, gcutm, gcuts, dual, doublegrid, modenum, lstres, lforce, &
|
||||
title, crystal, tmp_dir, tupf)
|
||||
|
||||
if (flag > -1) then
|
||||
nfi = nfi_
|
||||
acc = acc_
|
||||
end if
|
||||
|
||||
! ==--------------------------------------------------------------==
|
||||
! == MAX DIMENSIONS ==
|
||||
! ==--------------------------------------------------------------==
|
||||
|
||||
CALL read_restart_xdim( ndr )
|
||||
|
||||
! ==--------------------------------------------------------------==
|
||||
! == CELL & METRIC ==
|
||||
! ==--------------------------------------------------------------==
|
||||
|
||||
hdum = 0.0d0
|
||||
htm2 = 0.0d0
|
||||
|
||||
tovrw = .FALSE.
|
||||
tread = .TRUE.
|
||||
celldm_ = celldm
|
||||
CALL read_restart_cell( ndr, tovrw, tread, ibrav_, celldm_, ht, htm, &
|
||||
htm2, htvel, vnhh, xnhh0, xnhhm, hdum)
|
||||
|
||||
h = TRANSPOSE(ht)
|
||||
hold = TRANSPOSE(htm)
|
||||
velh = TRANSPOSE(htvel)
|
||||
|
||||
CALL cell_init(box, ht)
|
||||
CALL cell_init(boxm, htm)
|
||||
|
||||
! ==--------------------------------------------------------------==
|
||||
! == IONS ==
|
||||
! ==--------------------------------------------------------------==
|
||||
|
||||
ALLOCATE( stau0(3, nat) )
|
||||
ALLOCATE( staum(3, nat) )
|
||||
ALLOCATE( svel0(3, nat) )
|
||||
ALLOCATE( svelm(3, nat) )
|
||||
ALLOCATE( tautmp(3, nat) )
|
||||
ALLOCATE( fiontmp(3, nat) )
|
||||
ALLOCATE( ityp(nat) )
|
||||
|
||||
DO i = 1, nsp
|
||||
mass(i) = pmass(i)
|
||||
END DO
|
||||
xdum = 0.0d0
|
||||
cdmi = 0.0d0
|
||||
tovrw = .FALSE.
|
||||
tread = .TRUE.
|
||||
CALL read_restart_ions(ndr, tovrw, tread, atom_label, tscal, stau0, svel0, &
|
||||
staum, svelm, tautmp, fiontmp, cdmi, nat, ntyp, ityp, na, mass, vnhp_, &
|
||||
xnhp0_, xnhpm_, xdum)
|
||||
|
||||
IF( flag > 0 ) THEN
|
||||
ia = 0
|
||||
DO i = 1, nsp
|
||||
DO j = 1, na(i)
|
||||
ia = ia + 1
|
||||
IF( tscal ) THEN
|
||||
taus(:,j,i) = stau0(:,ia)
|
||||
tausm(:,j,i) = staum(:,ia)
|
||||
vels(:,j,i) = svel0(:,ia)
|
||||
velsm(:,j,i) = svelm(:,ia)
|
||||
ELSE
|
||||
CALL r_to_s( stau0(:,ia), taus(:,j,i), box )
|
||||
CALL r_to_s( staum(:,ia), tausm(:,j,i), boxm )
|
||||
CALL r_to_s( svel0(:,ia), vels(:,j,i), box )
|
||||
CALL r_to_s( svelm(:,ia), velsm(:,j,i), boxm )
|
||||
END IF
|
||||
END DO
|
||||
END DO
|
||||
xnhp0 = xnhp0_
|
||||
xnhpm = xnhpm_
|
||||
vnhp = vnhp_
|
||||
END IF
|
||||
|
||||
DEALLOCATE( stau0, staum, svel0, svelm, tautmp, ityp, fiontmp )
|
||||
|
||||
|
||||
! ==--------------------------------------------------------------==
|
||||
! == SYMMETRIES ==
|
||||
! ==--------------------------------------------------------------==
|
||||
|
||||
CALL read_restart_symmetry( ndr )
|
||||
|
||||
! ==--------------------------------------------------------------==
|
||||
! == PSEUDOPOTENTIALS ==
|
||||
! ==--------------------------------------------------------------==
|
||||
|
||||
DO i = 1, nsp
|
||||
CALL read_restart_pseudo( ndr )
|
||||
END DO
|
||||
|
||||
! ==--------------------------------------------------------------==
|
||||
! == OCCUPATION NUMBER ==
|
||||
! ==--------------------------------------------------------------==
|
||||
|
||||
ALLOCATE( occ(nbnd), eigtmp(nbnd) )
|
||||
|
||||
occ = 0.0d0
|
||||
IF( flag > 0 ) THEN
|
||||
tocc = .FALSE.
|
||||
tlam = .TRUE.
|
||||
ELSE
|
||||
tocc = .FALSE.
|
||||
tlam = .FALSE.
|
||||
END IF
|
||||
tovrw = .FALSE.
|
||||
teig = .FALSE.
|
||||
tread = .TRUE.
|
||||
CALL read_restart_electrons( ndr, tovrw, tread, occ, occ, tocc, lambda, &
|
||||
lambdam, nx, tlam, nbnd, ispin_, nspin, ik_, nk, rnel, nelu, neld, &
|
||||
vnhe, xnhe0, xnhem, xdum, ef, teig, eigtmp, eigtmp)
|
||||
|
||||
DEALLOCATE( occ, eigtmp )
|
||||
|
||||
! ==--------------------------------------------------------------==
|
||||
! == G-Vectors ==
|
||||
! ==--------------------------------------------------------------==
|
||||
|
||||
ALLOCATE( mill(3,ng_g) )
|
||||
mill = 0
|
||||
DO i = 1, ng
|
||||
mill(:,ig_l2g(i)) = mill_l(:,i)
|
||||
END DO
|
||||
CALL mp_sum( mill )
|
||||
tread = .TRUE.
|
||||
tovrw = .FALSE.
|
||||
tmill = .FALSE.
|
||||
CALL read_restart_gvec( ndr, tovrw, tread, ng_g, bi1, bi2, bi3, &
|
||||
bi1, bi2, bi3, tmill, mill )
|
||||
DEALLOCATE( mill )
|
||||
|
||||
! ==--------------------------------------------------------------==
|
||||
! == (G+k)-Vectors ==
|
||||
! ==--------------------------------------------------------------==
|
||||
|
||||
DO i = 1, nk
|
||||
xk(1) = 0.0d0
|
||||
xk(2) = 0.0d0
|
||||
xk(3) = 0.0d0
|
||||
wk = 1.0d0
|
||||
tread = .TRUE.
|
||||
tovrw = .FALSE.
|
||||
CALL read_restart_gkvec(ndr, tovrw, tread, ik_, nk_, ngwkg(i), &
|
||||
xk, wk, tetra_, isk_)
|
||||
END DO
|
||||
|
||||
! ==--------------------------------------------------------------==
|
||||
! == CHARGE DENSITY AND POTENTIALS ==
|
||||
! ==--------------------------------------------------------------==
|
||||
|
||||
trho = .FALSE.
|
||||
tv = .FALSE.
|
||||
DO j = 1, nspin
|
||||
ALLOCATE( rhog(ng), vg(ng) )
|
||||
tread = .TRUE.
|
||||
tovrw = .FALSE.
|
||||
CALL read_restart_charge(ndr, tovrw, tread, rhog, trho, vg, tv, ng_g, &
|
||||
ispin_, nspin, ig_l2g, ng )
|
||||
! CALL fft_initialize
|
||||
! CALL pinvfft( vpot(:,:,:,i), rhog(:,i) )
|
||||
! CALL pinvfft( rho(i)%r(:,:,:), vg(:,i) )
|
||||
DEALLOCATE( rhog, vg )
|
||||
END DO
|
||||
|
||||
! ==--------------------------------------------------------------==
|
||||
! == WAVEFUNCTIONS ==
|
||||
! ==--------------------------------------------------------------==
|
||||
|
||||
tigl = .FALSE.
|
||||
IF( flag == -1 ) THEN
|
||||
tw0 = .FALSE.
|
||||
twm = .FALSE.
|
||||
ELSE IF( flag == 0 ) THEN
|
||||
tw0 = .TRUE.
|
||||
twm = .FALSE.
|
||||
ELSE
|
||||
tw0 = .TRUE.
|
||||
twm = .TRUE.
|
||||
END IF
|
||||
DO j = 1, nspin
|
||||
DO i = 1, nk
|
||||
nb_g = nx
|
||||
tread = .TRUE.
|
||||
tovrw = .FALSE.
|
||||
CALL read_restart_wfc(ndr, tovrw, tread, ik_, nk_, kunit, ispin_, nspin_, &
|
||||
wfc_scal, c0, tw0, cm, twm, ngw_g, nb_g, ig_l2g, tigl, ngw )
|
||||
END DO
|
||||
END DO
|
||||
|
||||
|
||||
if(ionode) then
|
||||
close (unit=ndr)
|
||||
end if
|
||||
|
||||
return
|
||||
end subroutine
|
||||
|
||||
END MODULE restart
|
||||
|
|
@ -0,0 +1,848 @@
|
|||
!
|
||||
! Copyright (C) 2002 CP90 group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
logical function cpgt(a,b)
|
||||
USE kinds
|
||||
implicit none
|
||||
REAL(dbl) EPS
|
||||
parameter ( eps = 1.0d-10 )
|
||||
REAL(dbl) a,b,r
|
||||
r = abs(a-b)
|
||||
if(r .lt. EPS) then
|
||||
cpgt = .false.
|
||||
else
|
||||
cpgt = (a.gt.b)
|
||||
end if
|
||||
end
|
||||
|
||||
logical function cplt(a,b)
|
||||
USE kinds
|
||||
implicit none
|
||||
REAL(dbl) EPS
|
||||
parameter ( eps = 1.0d-10 )
|
||||
REAL(dbl) a,b,r
|
||||
r = abs(a-b)
|
||||
if(r .lt. EPS) then
|
||||
cplt = .false.
|
||||
else
|
||||
cplt = (a.lt.b)
|
||||
end if
|
||||
end
|
||||
!
|
||||
! Copyright (C) 2002 CP90 group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!---------------------------------------------------------------------
|
||||
subroutine hpsort (n, ra, ind)
|
||||
!---------------------------------------------------------------------
|
||||
! sort an array ra(1:n) into ascending order using heapsort algorithm.
|
||||
! n is input, ra is replaced on output by its sorted rearrangement.
|
||||
! create an index table (ind) by making an exchange in the index array
|
||||
! whenever an exchange is made on the sorted data array (ra).
|
||||
! in case of equal values in the data array (ra) the values in the
|
||||
! index array (ind) are used to order the entries.
|
||||
! if on input ind(1) = 0 then indices are initialized in the routine,
|
||||
! if on input ind(1) != 0 then indices are assumed to have been
|
||||
! initialized before entering the routine and these
|
||||
! indices are carried around during the sorting process
|
||||
!
|
||||
! no work space needed !
|
||||
! free us from machine-dependent sorting-routines !
|
||||
!
|
||||
! adapted from Numerical Recipes pg. 329 (new edition)
|
||||
!
|
||||
use kinds
|
||||
implicit none
|
||||
!-input/output variables
|
||||
integer :: n
|
||||
integer :: ind (n)
|
||||
real(dbl) :: ra (n)
|
||||
!-local variables
|
||||
integer :: i, ir, j, l, iind
|
||||
real(dbl) :: rra
|
||||
! initialize index array
|
||||
if (ind (1) .eq.0) then
|
||||
do i = 1, n
|
||||
ind (i) = i
|
||||
enddo
|
||||
endif
|
||||
! nothing to order
|
||||
if (n.lt.2) return
|
||||
! initialize indices for hiring and retirement-promotion phase
|
||||
l = n / 2 + 1
|
||||
ir = n
|
||||
10 continue
|
||||
! still in hiring phase
|
||||
if (l.gt.1) then
|
||||
l = l - 1
|
||||
rra = ra (l)
|
||||
iind = ind (l)
|
||||
! in retirement-promotion phase.
|
||||
else
|
||||
! clear a space at the end of the array
|
||||
rra = ra (ir)
|
||||
!
|
||||
iind = ind (ir)
|
||||
! retire the top of the heap into it
|
||||
ra (ir) = ra (1)
|
||||
!
|
||||
ind (ir) = ind (1)
|
||||
! decrease the size of the corporation
|
||||
ir = ir - 1
|
||||
! done with the last promotion
|
||||
if (ir.eq.1) then
|
||||
! the least competent worker at all !
|
||||
ra (1) = rra
|
||||
!
|
||||
ind (1) = iind
|
||||
return
|
||||
endif
|
||||
endif
|
||||
! wheter in hiring or promotion phase, we
|
||||
i = l
|
||||
! set up to place rra in its proper level
|
||||
j = l + l
|
||||
!
|
||||
do while (j.le.ir)
|
||||
if (j.lt.ir) then
|
||||
! compare to better underling
|
||||
if (ra (j) .lt.ra (j + 1) ) then
|
||||
j = j + 1
|
||||
elseif (ra (j) .eq.ra (j + 1) ) then
|
||||
if (ind (j) .lt.ind (j + 1) ) j = j + 1
|
||||
endif
|
||||
endif
|
||||
! demote rra
|
||||
if (rra.lt.ra (j) ) then
|
||||
ra (i) = ra (j)
|
||||
ind (i) = ind (j)
|
||||
i = j
|
||||
j = j + j
|
||||
elseif (rra.eq.ra (j) ) then
|
||||
! demote rra
|
||||
if (iind.lt.ind (j) ) then
|
||||
ra (i) = ra (j)
|
||||
ind (i) = ind (j)
|
||||
i = j
|
||||
j = j + j
|
||||
else
|
||||
! set j to terminate do-while loop
|
||||
j = ir + 1
|
||||
endif
|
||||
! this is the right place for rra
|
||||
else
|
||||
! set j to terminate do-while loop
|
||||
j = ir + 1
|
||||
endif
|
||||
enddo
|
||||
ra (i) = rra
|
||||
ind (i) = iind
|
||||
goto 10
|
||||
!
|
||||
end subroutine hpsort
|
||||
|
||||
!
|
||||
! Copyright (C) 2002 CP90 group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!---------------------------------------------------------------------
|
||||
subroutine ihpsort (n, ia, ind)
|
||||
!---------------------------------------------------------------------
|
||||
! sort an integer array ia(1:n) into ascending order using heapsort algorithm.
|
||||
! n is input, ia is replaced on output by its sorted rearrangement.
|
||||
! create an index table (ind) by making an exchange in the index array
|
||||
! whenever an exchange is made on the sorted data array (ia).
|
||||
! in case of equal values in the data array (ia) the values in the
|
||||
! index array (ind) are used to order the entries.
|
||||
! if on input ind(1) = 0 then indices are initialized in the routine,
|
||||
! if on input ind(1) != 0 then indices are assumed to have been
|
||||
! initialized before entering the routine and these
|
||||
! indices are carried around during the sorting process
|
||||
!
|
||||
! no work space needed !
|
||||
! free us from machine-dependent sorting-routines !
|
||||
!
|
||||
! adapted from Numerical Recipes pg. 329 (new edition)
|
||||
!
|
||||
implicit none
|
||||
!-input/output variables
|
||||
integer :: n
|
||||
integer :: ind (n)
|
||||
integer :: ia (n)
|
||||
!-local variables
|
||||
integer :: i, ir, j, l, iind
|
||||
integer :: iia
|
||||
! initialize index array
|
||||
if (ind (1) .eq.0) then
|
||||
do i = 1, n
|
||||
ind (i) = i
|
||||
enddo
|
||||
endif
|
||||
! nothing to order
|
||||
if (n.lt.2) return
|
||||
! initialize indices for hiring and retirement-promotion phase
|
||||
l = n / 2 + 1
|
||||
ir = n
|
||||
10 continue
|
||||
! still in hiring phase
|
||||
if (l.gt.1) then
|
||||
l = l - 1
|
||||
iia = ia (l)
|
||||
iind = ind (l)
|
||||
! in retirement-promotion phase.
|
||||
else
|
||||
! clear a space at the end of the array
|
||||
iia = ia (ir)
|
||||
!
|
||||
iind = ind (ir)
|
||||
! retire the top of the heap into it
|
||||
ia (ir) = ia (1)
|
||||
!
|
||||
ind (ir) = ind (1)
|
||||
! decrease the size of the corporation
|
||||
ir = ir - 1
|
||||
! done with the last promotion
|
||||
if (ir.eq.1) then
|
||||
! the least competent worker at all !
|
||||
ia (1) = iia
|
||||
!
|
||||
ind (1) = iind
|
||||
return
|
||||
endif
|
||||
endif
|
||||
! wheter in hiring or promotion phase, we
|
||||
i = l
|
||||
! set up to place iia in its proper level
|
||||
j = l + l
|
||||
!
|
||||
do while (j.le.ir)
|
||||
if (j.lt.ir) then
|
||||
! compare to better underling
|
||||
if (ia (j) .lt.ia (j + 1) ) then
|
||||
j = j + 1
|
||||
elseif (ia (j) .eq.ia (j + 1) ) then
|
||||
if (ind (j) .lt.ind (j + 1) ) j = j + 1
|
||||
endif
|
||||
endif
|
||||
! demote iia
|
||||
if (iia.lt.ia (j) ) then
|
||||
ia (i) = ia (j)
|
||||
ind (i) = ind (j)
|
||||
i = j
|
||||
j = j + j
|
||||
elseif (iia.eq.ia (j) ) then
|
||||
! demote iia
|
||||
if (iind.lt.ind (j) ) then
|
||||
ia (i) = ia (j)
|
||||
ind (i) = ind (j)
|
||||
i = j
|
||||
j = j + j
|
||||
else
|
||||
! set j to terminate do-while loop
|
||||
j = ir + 1
|
||||
endif
|
||||
! this is the right place for iia
|
||||
else
|
||||
! set j to terminate do-while loop
|
||||
j = ir + 1
|
||||
endif
|
||||
enddo
|
||||
ia (i) = iia
|
||||
ind (i) = iind
|
||||
goto 10
|
||||
!
|
||||
end subroutine ihpsort
|
||||
|
||||
! ==================================================================
|
||||
SUBROUTINE gqsort(COUNT,N,INDEX)
|
||||
! ==--------------------------------------------------------------==
|
||||
! == Sorting routine for the reciprocal space vectors (g) ==
|
||||
! == Warning, this is not an exact SORT!! This routine has been ==
|
||||
! == designed to give always the same order for the G vectors of ==
|
||||
! == a given shell, independently of the processor ==
|
||||
! == THE WORK-SPACE 'MARK' OF LENGTH 50 PERMITS UP TO 2**(50/2) ==
|
||||
! ==--------------------------------------------------------------==
|
||||
USE kinds
|
||||
logical :: cpgt,cplt
|
||||
REAL(dbl) :: COUNT(N),AV,X
|
||||
|
||||
INTEGER :: INDEX(N)
|
||||
DIMENSION :: MARK(50)
|
||||
! ==--------------------------------------------------------------==
|
||||
! == SET INDEX ARRAY TO ORIGINAL ORDER . ==
|
||||
! ==--------------------------------------------------------------==
|
||||
DO I=1,N
|
||||
INDEX(I)=I
|
||||
ENDDO
|
||||
! ==--------------------------------------------------------------==
|
||||
! == CHECK THAT A TRIVIAL CASE HAS NOT BEEN ENTERED. ==
|
||||
! ==--------------------------------------------------------------==
|
||||
IF(N.EQ.1)GOTO 200
|
||||
IF(N.GE.1)GOTO 30
|
||||
GOTO 200
|
||||
! ==--------------------------------------------------------------==
|
||||
! == 'M' IS THE LENGTH OF SEGMENT WHICH IS SHORT ENOUGH TO ENTER ==
|
||||
! == THE FINAL SORTING ROUTINE. IT MAY BE EASILY CHANGED. ==
|
||||
! ==--------------------------------------------------------------==
|
||||
30 M=12
|
||||
! ==--------------------------------------------------------------==
|
||||
! == SET UP INITIAL VALUES. ==
|
||||
! ==--------------------------------------------------------------==
|
||||
LA=2
|
||||
IS=1
|
||||
IF=N
|
||||
DO 190 MLOOP=1,N
|
||||
! ==--------------------------------------------------------------==
|
||||
! == IF SEGMENT IS SHORT ENOUGH SORT WITH FINAL SORTING ROUTINE. ==
|
||||
! ==--------------------------------------------------------------==
|
||||
IFKA=IF-IS
|
||||
IF((IFKA+1).GT.M)GOTO 70
|
||||
! ==--------------------------------------------------------------==
|
||||
! == FINAL SORTING ( A SIMPLE BUBBLE SORT ) ==
|
||||
! ==--------------------------------------------------------------==
|
||||
IS1=IS+1
|
||||
DO 60 J=IS1,IF
|
||||
I=J
|
||||
40 IF(cplt(COUNT(I-1),COUNT(I)) )GOTO 60
|
||||
IF(cpgt(COUNT(I-1),COUNT(I)) )GOTO 50
|
||||
IF(INDEX(I-1).LT.INDEX(I))GOTO 60
|
||||
50 AV=COUNT(I-1)
|
||||
COUNT(I-1)=COUNT(I)
|
||||
COUNT(I)=AV
|
||||
INT=INDEX(I-1)
|
||||
INDEX(I-1)=INDEX(I)
|
||||
INDEX(I)=INT
|
||||
I=I-1
|
||||
IF(I.GT.IS)GOTO 40
|
||||
60 CONTINUE
|
||||
LA=LA-2
|
||||
GOTO 170
|
||||
! ==--------------------------------------------------------------==
|
||||
! == ******* QUICKSORT ******** ==
|
||||
! == SELECT THE NUMBER IN THE CENTRAL POSITION IN THE SEGMENT AS ==
|
||||
! == THE TEST NUMBER.REPLACE IT WITH THE NUMBER FROM THE SEGMENT'S==
|
||||
! == HIGHEST ADDRESS. ==
|
||||
! ==--------------------------------------------------------------==
|
||||
70 IY=(IS+IF)/2
|
||||
X=COUNT(IY)
|
||||
INTEST=INDEX(IY)
|
||||
COUNT(IY)=COUNT(IF)
|
||||
INDEX(IY)=INDEX(IF)
|
||||
! ==--------------------------------------------------------------==
|
||||
! == THE MARKERS 'I' AND 'IFK' ARE USED FOR THE BEGINNING AND END ==
|
||||
! == OF THE SECTION NOT SO FAR TESTED AGAINST THE PRESENT VALUE ==
|
||||
! == OF X . ==
|
||||
! ==--------------------------------------------------------------==
|
||||
K=1
|
||||
IFK=IF
|
||||
! ==--------------------------------------------------------------==
|
||||
! == WE ALTERNATE BETWEEN THE OUTER LOOP THAT INCREASES I AND THE ==
|
||||
! == INNER LOOP THAT REDUCES IFK, MOVING NUMBERS AND INDICES AS ==
|
||||
! == NECESSARY, UNTIL THEY MEET . ==
|
||||
! ==--------------------------------------------------------------==
|
||||
DO 110 I=IS,IF
|
||||
IF(cpgt(X,COUNT(I)))GOTO 110
|
||||
IF(cplt(X,COUNT(I)))GOTO 80
|
||||
IF(INTEST.GT.INDEX(I))GOTO 110
|
||||
80 IF(I.GE.IFK)GOTO 120
|
||||
COUNT(IFK)=COUNT(I)
|
||||
INDEX(IFK)=INDEX(I)
|
||||
K1=K
|
||||
DO 100 K=K1,IFKA
|
||||
IFK=IF-K
|
||||
IF(cpgt(COUNT(IFK),X))GOTO 100
|
||||
IF(cplt(COUNT(IFK),X))GOTO 90
|
||||
IF(INTEST.LE.INDEX(IFK))GOTO 100
|
||||
90 IF(I.GE.IFK)GOTO 130
|
||||
COUNT(I)=COUNT(IFK)
|
||||
INDEX(I)=INDEX(IFK)
|
||||
GO TO 110
|
||||
100 CONTINUE
|
||||
GOTO 120
|
||||
110 CONTINUE
|
||||
! ==--------------------------------------------------------------==
|
||||
! == RETURN THE TEST NUMBER TO THE POSITION MARKED BY THE MARKER ==
|
||||
! == WHICH DID NOT MOVE LAST. IT DIVIDES THE INITIAL SEGMENT INTO ==
|
||||
! == 2 PARTS. ANY ELEMENT IN THE FIRST PART IS LESS THAN OR EQUAL ==
|
||||
! == TO ANY ELEMENT IN THE SECOND PART, AND THEY MAY NOW BE SORTED==
|
||||
! == INDEPENDENTLY . ==
|
||||
! ==--------------------------------------------------------------==
|
||||
120 COUNT(IFK)=X
|
||||
INDEX(IFK)=INTEST
|
||||
IP=IFK
|
||||
GOTO 140
|
||||
130 COUNT(I)=X
|
||||
INDEX(I)=INTEST
|
||||
IP=I
|
||||
! ==--------------------------------------------------------------==
|
||||
! == STORE THE LONGER SUBDIVISION IN WORKSPACE. ==
|
||||
! ==--------------------------------------------------------------==
|
||||
140 IF((IP-IS).GT.(IF-IP))GOTO 150
|
||||
MARK(LA)=IF
|
||||
MARK(LA-1)=IP+1
|
||||
IF=IP-1
|
||||
GOTO 160
|
||||
150 MARK(LA)=IP-1
|
||||
MARK(LA-1)=IS
|
||||
IS=IP+1
|
||||
! ==--------------------------------------------------------------==
|
||||
! == FIND THE LENGTH OF THE SHORTER SUBDIVISION. ==
|
||||
! ==--------------------------------------------------------------==
|
||||
160 LNGTH=IF-IS
|
||||
IF(LNGTH.LE.0)GOTO 180
|
||||
! ==--------------------------------------------------------------==
|
||||
! == IF IT CONTAINS MORE THAN ONE ELEMENT SUPPLY IT WITH WORKSPACE==
|
||||
! ==--------------------------------------------------------------==
|
||||
LA=LA+2
|
||||
GOTO 190
|
||||
170 IF(LA.LE.0)GOTO 200
|
||||
! ==--------------------------------------------------------------==
|
||||
! == OBTAIN THE ADDRESS OF THE SHORTEST SEGMENT AWAITING QUICKSORT==
|
||||
! ==--------------------------------------------------------------==
|
||||
180 IF=MARK(LA)
|
||||
IS=MARK(LA-1)
|
||||
190 CONTINUE
|
||||
! ==--------------------------------------------------------------==
|
||||
200 RETURN
|
||||
END
|
||||
! ==================================================================
|
||||
|
||||
|
||||
! ==================================================================
|
||||
SUBROUTINE iqsort(COUNT,N,INDEX)
|
||||
! ==--------------------------------------------------------------==
|
||||
! == same as rqsort but for array of integers ==
|
||||
! ==--------------------------------------------------------------==
|
||||
USE kinds
|
||||
INTEGER :: COUNT(N),AV,X
|
||||
|
||||
INTEGER INDEX(N)
|
||||
INTEGER MARK(50)
|
||||
! ==--------------------------------------------------------------==
|
||||
! == SET INDEX ARRAY TO ORIGINAL ORDER . ==
|
||||
! ==--------------------------------------------------------------==
|
||||
DO I=1,N
|
||||
INDEX(I)=I
|
||||
ENDDO
|
||||
! ==--------------------------------------------------------------==
|
||||
! == CHECK THAT A TRIVIAL CASE HAS NOT BEEN ENTERED. ==
|
||||
! ==--------------------------------------------------------------==
|
||||
IF(N.EQ.1)GOTO 200
|
||||
IF(N.GE.1)GOTO 30
|
||||
GOTO 200
|
||||
! ==--------------------------------------------------------------==
|
||||
! == 'M' IS THE LENGTH OF SEGMENT WHICH IS SHORT ENOUGH TO ENTER ==
|
||||
! == THE FINAL SORTING ROUTINE. IT MAY BE EASILY CHANGED. ==
|
||||
! ==--------------------------------------------------------------==
|
||||
30 M=12
|
||||
! ==--------------------------------------------------------------==
|
||||
! == SET UP INITIAL VALUES. ==
|
||||
! ==--------------------------------------------------------------==
|
||||
LA=2
|
||||
IS=1
|
||||
IF=N
|
||||
DO 190 MLOOP=1,N
|
||||
! ==--------------------------------------------------------------==
|
||||
! == IF SEGMENT IS SHORT ENOUGH SORT WITH FINAL SORTING ROUTINE. ==
|
||||
! ==--------------------------------------------------------------==
|
||||
IFKA=IF-IS
|
||||
IF((IFKA+1).GT.M)GOTO 70
|
||||
! ==--------------------------------------------------------------==
|
||||
! == FINAL SORTING ( A SIMPLE BUBBLE SORT ) ==
|
||||
! ==--------------------------------------------------------------==
|
||||
IS1=IS+1
|
||||
DO 60 J=IS1,IF
|
||||
I=J
|
||||
40 IF((COUNT(I-1).LT.COUNT(I)) )GOTO 60
|
||||
IF((COUNT(I-1).GT.COUNT(I)) )GOTO 50
|
||||
IF(INDEX(I-1).LT.INDEX(I))GOTO 60
|
||||
50 AV=COUNT(I-1)
|
||||
COUNT(I-1)=COUNT(I)
|
||||
COUNT(I)=AV
|
||||
INT=INDEX(I-1)
|
||||
INDEX(I-1)=INDEX(I)
|
||||
INDEX(I)=INT
|
||||
I=I-1
|
||||
IF(I.GT.IS)GOTO 40
|
||||
60 CONTINUE
|
||||
LA=LA-2
|
||||
GOTO 170
|
||||
! ==--------------------------------------------------------------==
|
||||
! == ******* QUICKSORT ******** ==
|
||||
! == SELECT THE NUMBER IN THE CENTRAL POSITION IN THE SEGMENT AS ==
|
||||
! == THE TEST NUMBER.REPLACE IT WITH THE NUMBER FROM THE SEGMENT'S==
|
||||
! == HIGHEST ADDRESS. ==
|
||||
! ==--------------------------------------------------------------==
|
||||
70 IY=(IS+IF)/2
|
||||
X=COUNT(IY)
|
||||
INTEST=INDEX(IY)
|
||||
COUNT(IY)=COUNT(IF)
|
||||
INDEX(IY)=INDEX(IF)
|
||||
! ==--------------------------------------------------------------==
|
||||
! == THE MARKERS 'I' AND 'IFK' ARE USED FOR THE BEGINNING AND END ==
|
||||
! == OF THE SECTION NOT SO FAR TESTED AGAINST THE PRESENT VALUE ==
|
||||
! == OF X . ==
|
||||
! ==--------------------------------------------------------------==
|
||||
K=1
|
||||
IFK=IF
|
||||
! ==--------------------------------------------------------------==
|
||||
! == WE ALTERNATE BETWEEN THE OUTER LOOP THAT INCREASES I AND THE ==
|
||||
! == INNER LOOP THAT REDUCES IFK, MOVING NUMBERS AND INDICES AS ==
|
||||
! == NECESSARY, UNTIL THEY MEET . ==
|
||||
! ==--------------------------------------------------------------==
|
||||
DO 110 I=IS,IF
|
||||
IF((X.GT.COUNT(I)))GOTO 110
|
||||
IF((X.LT.COUNT(I)))GOTO 80
|
||||
IF(INTEST.GT.INDEX(I))GOTO 110
|
||||
80 IF(I.GE.IFK)GOTO 120
|
||||
COUNT(IFK)=COUNT(I)
|
||||
INDEX(IFK)=INDEX(I)
|
||||
K1=K
|
||||
DO 100 K=K1,IFKA
|
||||
IFK=IF-K
|
||||
IF((COUNT(IFK).GT.X))GOTO 100
|
||||
IF((COUNT(IFK).LT.X))GOTO 90
|
||||
IF(INTEST.LE.INDEX(IFK))GOTO 100
|
||||
90 IF(I.GE.IFK)GOTO 130
|
||||
COUNT(I)=COUNT(IFK)
|
||||
INDEX(I)=INDEX(IFK)
|
||||
GO TO 110
|
||||
100 CONTINUE
|
||||
GOTO 120
|
||||
110 CONTINUE
|
||||
! ==--------------------------------------------------------------==
|
||||
! == RETURN THE TEST NUMBER TO THE POSITION MARKED BY THE MARKER ==
|
||||
! == WHICH DID NOT MOVE LAST. IT DIVIDES THE INITIAL SEGMENT INTO ==
|
||||
! == 2 PARTS. ANY ELEMENT IN THE FIRST PART IS LESS THAN OR EQUAL ==
|
||||
! == TO ANY ELEMENT IN THE SECOND PART, AND THEY MAY NOW BE SORTED==
|
||||
! == INDEPENDENTLY . ==
|
||||
! ==--------------------------------------------------------------==
|
||||
120 COUNT(IFK)=X
|
||||
INDEX(IFK)=INTEST
|
||||
IP=IFK
|
||||
GOTO 140
|
||||
130 COUNT(I)=X
|
||||
INDEX(I)=INTEST
|
||||
IP=I
|
||||
! ==--------------------------------------------------------------==
|
||||
! == STORE THE LONGER SUBDIVISION IN WORKSPACE. ==
|
||||
! ==--------------------------------------------------------------==
|
||||
140 IF((IP-IS).GT.(IF-IP))GOTO 150
|
||||
MARK(LA)=IF
|
||||
MARK(LA-1)=IP+1
|
||||
IF=IP-1
|
||||
GOTO 160
|
||||
150 MARK(LA)=IP-1
|
||||
MARK(LA-1)=IS
|
||||
IS=IP+1
|
||||
! ==--------------------------------------------------------------==
|
||||
! == FIND THE LENGTH OF THE SHORTER SUBDIVISION. ==
|
||||
! ==--------------------------------------------------------------==
|
||||
160 LNGTH=IF-IS
|
||||
IF(LNGTH.LE.0)GOTO 180
|
||||
! ==--------------------------------------------------------------==
|
||||
! == IF IT CONTAINS MORE THAN ONE ELEMENT SUPPLY IT WITH WORKSPACE==
|
||||
! ==--------------------------------------------------------------==
|
||||
LA=LA+2
|
||||
GOTO 190
|
||||
170 IF(LA.LE.0)GOTO 200
|
||||
! ==--------------------------------------------------------------==
|
||||
! == OBTAIN THE ADDRESS OF THE SHORTEST SEGMENT AWAITING QUICKSORT==
|
||||
! ==--------------------------------------------------------------==
|
||||
180 IF=MARK(LA)
|
||||
IS=MARK(LA-1)
|
||||
190 CONTINUE
|
||||
! ==--------------------------------------------------------------==
|
||||
200 RETURN
|
||||
END
|
||||
! ==================================================================
|
||||
|
||||
|
||||
|
||||
! ==================================================================
|
||||
SUBROUTINE rqsort(COUNT,N,INDEX)
|
||||
! ==--------------------------------------------------------------==
|
||||
! == Sorting routine for the double precison arrayis ==
|
||||
! == THE WORK-SPACE 'MARK' OF LENGTH 50 PERMITS UP TO 2**(50/2) ==
|
||||
! ==--------------------------------------------------------------==
|
||||
USE kinds
|
||||
REAL(dbl) COUNT(N),AV,X
|
||||
|
||||
INTEGER INDEX(N)
|
||||
DIMENSION MARK(50)
|
||||
! ==--------------------------------------------------------------==
|
||||
! == SET INDEX ARRAY TO ORIGINAL ORDER . ==
|
||||
! ==--------------------------------------------------------------==
|
||||
DO I=1,N
|
||||
INDEX(I)=I
|
||||
ENDDO
|
||||
! ==--------------------------------------------------------------==
|
||||
! == CHECK THAT A TRIVIAL CASE HAS NOT BEEN ENTERED. ==
|
||||
! ==--------------------------------------------------------------==
|
||||
IF(N.EQ.1)GOTO 200
|
||||
IF(N.GE.1)GOTO 30
|
||||
GOTO 200
|
||||
! ==--------------------------------------------------------------==
|
||||
! == 'M' IS THE LENGTH OF SEGMENT WHICH IS SHORT ENOUGH TO ENTER ==
|
||||
! == THE FINAL SORTING ROUTINE. IT MAY BE EASILY CHANGED. ==
|
||||
! ==--------------------------------------------------------------==
|
||||
30 M=12
|
||||
! ==--------------------------------------------------------------==
|
||||
! == SET UP INITIAL VALUES. ==
|
||||
! ==--------------------------------------------------------------==
|
||||
LA=2
|
||||
IS=1
|
||||
IF=N
|
||||
DO 190 MLOOP=1,N
|
||||
! ==--------------------------------------------------------------==
|
||||
! == IF SEGMENT IS SHORT ENOUGH SORT WITH FINAL SORTING ROUTINE. ==
|
||||
! ==--------------------------------------------------------------==
|
||||
IFKA=IF-IS
|
||||
IF((IFKA+1).GT.M)GOTO 70
|
||||
! ==--------------------------------------------------------------==
|
||||
! == FINAL SORTING ( A SIMPLE BUBBLE SORT ) ==
|
||||
! ==--------------------------------------------------------------==
|
||||
IS1=IS+1
|
||||
DO 60 J=IS1,IF
|
||||
I=J
|
||||
40 IF( (COUNT(I-1) .LT. COUNT(I)) )GOTO 60
|
||||
IF( (COUNT(I-1) .GT. COUNT(I)) )GOTO 50
|
||||
IF(INDEX(I-1).LT.INDEX(I))GOTO 60
|
||||
50 AV=COUNT(I-1)
|
||||
COUNT(I-1)=COUNT(I)
|
||||
COUNT(I)=AV
|
||||
INT=INDEX(I-1)
|
||||
INDEX(I-1)=INDEX(I)
|
||||
INDEX(I)=INT
|
||||
I=I-1
|
||||
IF(I.GT.IS)GOTO 40
|
||||
60 CONTINUE
|
||||
LA=LA-2
|
||||
GOTO 170
|
||||
! ==--------------------------------------------------------------==
|
||||
! == ******* QUICKSORT ******** ==
|
||||
! == SELECT THE NUMBER IN THE CENTRAL POSITION IN THE SEGMENT AS ==
|
||||
! == THE TEST NUMBER.REPLACE IT WITH THE NUMBER FROM THE SEGMENT'S==
|
||||
! == HIGHEST ADDRESS. ==
|
||||
! ==--------------------------------------------------------------==
|
||||
70 IY=(IS+IF)/2
|
||||
X=COUNT(IY)
|
||||
INTEST=INDEX(IY)
|
||||
COUNT(IY)=COUNT(IF)
|
||||
INDEX(IY)=INDEX(IF)
|
||||
! ==--------------------------------------------------------------==
|
||||
! == THE MARKERS 'I' AND 'IFK' ARE USED FOR THE BEGINNING AND END ==
|
||||
! == OF THE SECTION NOT SO FAR TESTED AGAINST THE PRESENT VALUE ==
|
||||
! == OF X . ==
|
||||
! ==--------------------------------------------------------------==
|
||||
K=1
|
||||
IFK=IF
|
||||
! ==--------------------------------------------------------------==
|
||||
! == WE ALTERNATE BETWEEN THE OUTER LOOP THAT INCREASES I AND THE ==
|
||||
! == INNER LOOP THAT REDUCES IFK, MOVING NUMBERS AND INDICES AS ==
|
||||
! == NECESSARY, UNTIL THEY MEET . ==
|
||||
! ==--------------------------------------------------------------==
|
||||
DO 110 I=IS,IF
|
||||
IF((X .GT. COUNT(I)))GOTO 110
|
||||
IF((X .LT. COUNT(I)))GOTO 80
|
||||
IF(INTEST.GT.INDEX(I))GOTO 110
|
||||
80 IF(I.GE.IFK)GOTO 120
|
||||
COUNT(IFK)=COUNT(I)
|
||||
INDEX(IFK)=INDEX(I)
|
||||
K1=K
|
||||
DO 100 K=K1,IFKA
|
||||
IFK=IF-K
|
||||
IF((COUNT(IFK) .GT. X))GOTO 100
|
||||
IF((COUNT(IFK) .LT. X))GOTO 90
|
||||
IF(INTEST.LE.INDEX(IFK))GOTO 100
|
||||
90 IF(I.GE.IFK)GOTO 130
|
||||
COUNT(I)=COUNT(IFK)
|
||||
INDEX(I)=INDEX(IFK)
|
||||
GO TO 110
|
||||
100 CONTINUE
|
||||
GOTO 120
|
||||
110 CONTINUE
|
||||
! ==--------------------------------------------------------------==
|
||||
! == RETURN THE TEST NUMBER TO THE POSITION MARKED BY THE MARKER ==
|
||||
! == WHICH DID NOT MOVE LAST. IT DIVIDES THE INITIAL SEGMENT INTO ==
|
||||
! == 2 PARTS. ANY ELEMENT IN THE FIRST PART IS LESS THAN OR EQUAL ==
|
||||
! == TO ANY ELEMENT IN THE SECOND PART, AND THEY MAY NOW BE SORTED==
|
||||
! == INDEPENDENTLY . ==
|
||||
! ==--------------------------------------------------------------==
|
||||
120 COUNT(IFK)=X
|
||||
INDEX(IFK)=INTEST
|
||||
IP=IFK
|
||||
GOTO 140
|
||||
130 COUNT(I)=X
|
||||
INDEX(I)=INTEST
|
||||
IP=I
|
||||
! ==--------------------------------------------------------------==
|
||||
! == STORE THE LONGER SUBDIVISION IN WORKSPACE. ==
|
||||
! ==--------------------------------------------------------------==
|
||||
140 IF((IP-IS).GT.(IF-IP))GOTO 150
|
||||
MARK(LA)=IF
|
||||
MARK(LA-1)=IP+1
|
||||
IF=IP-1
|
||||
GOTO 160
|
||||
150 MARK(LA)=IP-1
|
||||
MARK(LA-1)=IS
|
||||
IS=IP+1
|
||||
! ==--------------------------------------------------------------==
|
||||
! == FIND THE LENGTH OF THE SHORTER SUBDIVISION. ==
|
||||
! ==--------------------------------------------------------------==
|
||||
160 LNGTH=IF-IS
|
||||
IF(LNGTH.LE.0)GOTO 180
|
||||
! ==--------------------------------------------------------------==
|
||||
! == IF IT CONTAINS MORE THAN ONE ELEMENT SUPPLY IT WITH WORKSPACE==
|
||||
! ==--------------------------------------------------------------==
|
||||
LA=LA+2
|
||||
GOTO 190
|
||||
170 IF(LA.LE.0)GOTO 200
|
||||
! ==--------------------------------------------------------------==
|
||||
! == OBTAIN THE ADDRESS OF THE SHORTEST SEGMENT AWAITING QUICKSORT==
|
||||
! ==--------------------------------------------------------------==
|
||||
180 IF=MARK(LA)
|
||||
IS=MARK(LA-1)
|
||||
190 CONTINUE
|
||||
! ==--------------------------------------------------------------==
|
||||
200 RETURN
|
||||
END
|
||||
! ==================================================================
|
||||
|
||||
!-------------------------------------------------------------------------
|
||||
subroutine kb07ad_cp90(count,n,index)
|
||||
!-------------------------------------------------------------------------
|
||||
!
|
||||
! kb07ad handles double precision variables
|
||||
! standard fortran 66 (a verified pfort subroutine)
|
||||
! the work-space 'mark' of length 50 permits up to 2**(50/2) numbers
|
||||
! to be sorted.
|
||||
implicit none
|
||||
integer n, index(n)
|
||||
real(kind=8) count(n)
|
||||
real(kind=8) av, x
|
||||
integer k1, ifk, lngth, ip, k, int, ifka, intest, iy
|
||||
integer i, m, la, is, if, mloop, ifca, is1, j, mark(50)
|
||||
! set index array to original order .
|
||||
do i=1,n
|
||||
index(i)=i
|
||||
end do
|
||||
! check that a trivial case has not been entered .
|
||||
if(n.eq.1) go to 10
|
||||
if(n.gt.1) go to 30
|
||||
write(6,20)
|
||||
20 format(///20x,'***kb07ad***no numbers to be sorted ** return to', &
|
||||
& ' calling program' )
|
||||
goto 10
|
||||
! 'm' is the length of segment which is short enough to enter
|
||||
! the final sorting routine. it may be easily changed.
|
||||
30 m=12
|
||||
! set up initial values.
|
||||
la=2
|
||||
is=1
|
||||
if=n
|
||||
do 190 mloop=1,n
|
||||
! if segment is short enough sort with final sorting routine .
|
||||
ifka=if-is
|
||||
if((ifka+1).gt.m)goto 70
|
||||
!********* final sorting ***
|
||||
! ( a simple bubble sort )
|
||||
is1=is+1
|
||||
do 60 j=is1,if
|
||||
i=j
|
||||
40 if(count(i-1).lt.count(i))goto 60
|
||||
if(count(i-1).gt.count(i))goto 50
|
||||
if(index(i-1).lt.index(i))goto 60
|
||||
50 av=count(i-1)
|
||||
count(i-1)=count(i)
|
||||
count(i)=av
|
||||
int=index(i-1)
|
||||
index(i-1)=index(i)
|
||||
index(i)=int
|
||||
i=i-1
|
||||
if(i.gt.is)goto 40
|
||||
60 continue
|
||||
la=la-2
|
||||
goto 170
|
||||
! ******* quicksort ********
|
||||
! select the number in the central position in the segment as
|
||||
! the test number.replace it with the number from the segment's
|
||||
! highest address.
|
||||
70 iy=(is+if)/2
|
||||
x=count(iy)
|
||||
intest=index(iy)
|
||||
count(iy)=count(if)
|
||||
index(iy)=index(if)
|
||||
! the markers 'i' and 'ifk' are used for the beginning and end
|
||||
! of the section not so far tested against the present value
|
||||
! of x .
|
||||
k=1
|
||||
ifk=if
|
||||
! we alternate between the outer loop that increases i and the
|
||||
! inner loop that reduces ifk, moving numbers and indices as
|
||||
! necessary, until they meet .
|
||||
do 110 i=is,if
|
||||
if(x.gt.count(i))goto 110
|
||||
if(x.lt.count(i))goto 80
|
||||
if(intest.gt.index(i))goto 110
|
||||
80 if(i.ge.ifk)goto 120
|
||||
count(ifk)=count(i)
|
||||
index(ifk)=index(i)
|
||||
k1=k
|
||||
do 100 k=k1,ifka
|
||||
ifk=if-k
|
||||
if(count(ifk).gt.x)goto 100
|
||||
if(count(ifk).lt.x)goto 90
|
||||
if(intest.le.index(ifk))goto 100
|
||||
90 if(i.ge.ifk)goto 130
|
||||
count(i)=count(ifk)
|
||||
index(i)=index(ifk)
|
||||
go to 110
|
||||
100 continue
|
||||
goto 120
|
||||
110 continue
|
||||
! return the test number to the position marked by the marker
|
||||
! which did not move last. it divides the initial segment into
|
||||
! 2 parts. any element in the first part is less than or equal
|
||||
! to any element in the second part, and they may now be sorted
|
||||
! independently .
|
||||
120 count(ifk)=x
|
||||
index(ifk)=intest
|
||||
ip=ifk
|
||||
goto 140
|
||||
130 count(i)=x
|
||||
index(i)=intest
|
||||
ip=i
|
||||
! store the longer subdivision in workspace.
|
||||
140 if((ip-is).gt.(if-ip))goto 150
|
||||
mark(la)=if
|
||||
mark(la-1)=ip+1
|
||||
if=ip-1
|
||||
goto 160
|
||||
150 mark(la)=ip-1
|
||||
mark(la-1)=is
|
||||
is=ip+1
|
||||
! find the length of the shorter subdivision.
|
||||
160 lngth=if-is
|
||||
if(lngth.le.0)goto 180
|
||||
! if it contains more than one element supply it with workspace .
|
||||
la=la+2
|
||||
goto 190
|
||||
170 if(la.le.0)goto 10
|
||||
! obtain the address of the shortest segment awaiting quicksort
|
||||
180 if=mark(la)
|
||||
is=mark(la-1)
|
||||
190 continue
|
||||
10 return
|
||||
end
|
||||
|
||||
|
|
@ -0,0 +1,171 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine which_dft (dft, iexch, icorr, igcx, igcc)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
use parser
|
||||
implicit none
|
||||
! input
|
||||
character (len=*) :: dft
|
||||
! output
|
||||
integer :: iexch, icorr, igcx, igcc
|
||||
! data
|
||||
integer :: nxc, ncc, ngcx, ngcc
|
||||
parameter (nxc = 1, ncc = 9, ngcx = 3, ngcc = 4)
|
||||
character (len=3) :: exc, corr
|
||||
character (len=4) :: gradx, gradc
|
||||
dimension exc (0:nxc), corr (0:ncc), gradx (0:ngcx), gradc (0: ngcc)
|
||||
! local
|
||||
integer :: len, l, i, notset
|
||||
character (len=50):: dftout * 50
|
||||
data notset / - 1 /
|
||||
data exc / 'NOX', 'SLA' /
|
||||
data corr / 'NOC', 'PZ', 'VWN', 'LYP', 'PW', 'WIG', 'HL', 'OBZ', &
|
||||
'OBW', 'GL' /
|
||||
data gradx / 'NOGX', 'B88', 'GGX', 'PBE' /
|
||||
|
||||
|
||||
data gradc / 'NOGC', 'P86', 'GGC', 'BLYP', 'PBE' /
|
||||
! convert to uppercase
|
||||
len = len_trim(dft)
|
||||
dftout = ' '
|
||||
do l = 1, len
|
||||
dftout (l:l) = capital (dft (l:l) )
|
||||
enddo
|
||||
! exchange
|
||||
|
||||
iexch = notset
|
||||
do i = 0, nxc
|
||||
if (matches (exc (i), dftout) ) call set_dft_value (iexch, i)
|
||||
enddo
|
||||
! correlation
|
||||
|
||||
icorr = notset
|
||||
do i = 0, ncc
|
||||
if (matches (corr (i), dftout) ) call set_dft_value (icorr, i)
|
||||
enddo
|
||||
! gradient correction, exchange
|
||||
|
||||
igcx = notset
|
||||
do i = 0, ngcx
|
||||
if (matches (gradx (i), dftout) ) call set_dft_value (igcx, i)
|
||||
enddo
|
||||
! gradient correction, correlation
|
||||
|
||||
igcc = notset
|
||||
do i = 0, ngcc
|
||||
if (matches (gradc (i), dftout) ) call set_dft_value (igcc, i)
|
||||
enddo
|
||||
! special case : BLYP => B88 for gradient correction on exchange
|
||||
|
||||
|
||||
if (matches ('BLYP', dftout) ) call set_dft_value (igcx, 1)
|
||||
! special case : PBE
|
||||
if (matches ('PBE', dftout) ) then
|
||||
call set_dft_value (iexch, 1)
|
||||
call set_dft_value (icorr, 4)
|
||||
endif
|
||||
! special case : BP = B88 + P86
|
||||
if (matches ('BP', dftout) ) then
|
||||
call set_dft_value (igcx, 1)
|
||||
call set_dft_value (igcc, 1)
|
||||
endif
|
||||
! special case : PW91 = GGX + GGC
|
||||
if (matches ('PW91', dftout) ) then
|
||||
call set_dft_value (igcx, 2)
|
||||
call set_dft_value (igcc, 2)
|
||||
endif
|
||||
! Default value: Slater exchange
|
||||
|
||||
|
||||
if (iexch.eq.notset) call set_dft_value (iexch, 1)
|
||||
! Default value: Perdew-Zunger correlation
|
||||
|
||||
if (icorr.eq.notset) call set_dft_value (icorr, 1)
|
||||
! Default value: no gradient correction on exchange
|
||||
|
||||
if (igcx.eq.notset) call set_dft_value (igcx, 0)
|
||||
! Default value: no gradient correction on correlation
|
||||
|
||||
if (igcc.eq.notset) call set_dft_value (igcc, 0)
|
||||
!
|
||||
|
||||
dftout = exc (iexch) //'-'//corr (icorr) //'-'//gradx (igcx) //'-' &
|
||||
&//gradc (igcc)
|
||||
!cc write (6,'(a)') dftout
|
||||
return
|
||||
end subroutine which_dft
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine set_dft_value (m, i)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
implicit none
|
||||
! input / output
|
||||
integer :: m, i
|
||||
! local
|
||||
integer :: notset
|
||||
|
||||
parameter (notset = - 1)
|
||||
|
||||
if (m.ne.notset.and.m.ne.i) call error ('decifra', 'two conflictin &
|
||||
&g matching values', 1)
|
||||
|
||||
m = i
|
||||
return
|
||||
|
||||
end subroutine set_dft_value
|
||||
!-----------------------------------------------------------------------
|
||||
logical function matches (string1, string2)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
implicit none
|
||||
character (len=*) :: string1, string2
|
||||
integer :: len1, len2, l
|
||||
|
||||
|
||||
len1 = len_trim(string1)
|
||||
len2 = len_trim(string2)
|
||||
do l = 1, len2 - len1 + 1
|
||||
if (string1 (1:len1) .eq.string2 (l:l + len1 - 1) ) then
|
||||
matches = .true.
|
||||
return
|
||||
endif
|
||||
|
||||
enddo
|
||||
|
||||
matches = .false.
|
||||
return
|
||||
end function matches
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
function capital (character)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! converts character to capital if lowercase
|
||||
! copy character to output in all other cases
|
||||
!
|
||||
implicit none
|
||||
character (len=1) :: capital, character
|
||||
!
|
||||
character(len=26) :: minuscole='abcdefghijklmnopqrstuvwxyz', &
|
||||
maiuscole='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
|
||||
integer :: i
|
||||
!
|
||||
do i=1,26
|
||||
if (character.eq.minuscole(i:i)) then
|
||||
capital=maiuscole(i:i)
|
||||
return
|
||||
end if
|
||||
end do
|
||||
capital = character
|
||||
!
|
||||
return
|
||||
end function capital
|
||||
|
|
@ -0,0 +1,105 @@
|
|||
!
|
||||
! Copyright (C) 2002 CP90 group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
complex(kind=8) function csum(n,a,nstride)
|
||||
!
|
||||
! wrapper routine for cray scilib function csum
|
||||
!
|
||||
implicit none
|
||||
integer n, nstride
|
||||
complex(kind=8) a(*)
|
||||
integer i
|
||||
!
|
||||
csum=(0.d0,0.d0)
|
||||
do i=1,n,nstride
|
||||
csum=csum+a(i)
|
||||
end do
|
||||
!
|
||||
return
|
||||
end
|
||||
!
|
||||
real(kind=8) function ssum(n,a,nstride)
|
||||
!
|
||||
! wrapper routine for cray scilib function ssum
|
||||
!
|
||||
implicit none
|
||||
integer n, nstride
|
||||
real(kind=8) a(*)
|
||||
integer i
|
||||
!
|
||||
ssum=0.d0
|
||||
do i=1,n,nstride
|
||||
ssum=ssum+a(i)
|
||||
end do
|
||||
!
|
||||
return
|
||||
end
|
||||
!
|
||||
subroutine mxma (a,na,iad,b,nb,ibd,c,nc,icd,nar,nac,nbc)
|
||||
!
|
||||
! wrapper routine for cray scilib matrix-matrix multiplication
|
||||
! routine mxma: c=a*b . Uses blas routine dgemm
|
||||
! na, nb, nc = spacing between column elements of a, b ,c resp.
|
||||
! iad,ibd,icd = spacing between row elements of a, b ,c resp.
|
||||
! nar=number of rows of a and c
|
||||
! nac=number of columns of a, number of rows of b
|
||||
! nbc=number of columns of b and c
|
||||
!
|
||||
implicit none
|
||||
integer na, iad, nb, ibd, nc, icd, nar, nac, nbc
|
||||
real(kind=8) a(iad,nac), b(ibd,nbc), c(icd,nbc)
|
||||
character(len=1) mode1, mode2
|
||||
integer lda, ldb
|
||||
!
|
||||
! fortran equivalent (a,b,c are one-dimensional arrays)
|
||||
!
|
||||
! real(kind=8) a(iad*nac), b(ibd*nbc), c(icd*nbc)
|
||||
! integer i,j,k
|
||||
!
|
||||
! do j=1,nbc
|
||||
! do i=1,nar
|
||||
! c((i-1)*nc+(j-1)*icd+1)=0.d0
|
||||
! do k=1,nac
|
||||
! c((i-1)*nc+(j-1)*icd+1) = c((i-1)*nc+(j-1)*icd+1) &
|
||||
! & + a((i-1)*na+(k-1)*iad+1) &
|
||||
! & * b((k-1)*nb+(j-1)*ibd+1)
|
||||
! end do
|
||||
! end do
|
||||
! end do
|
||||
!
|
||||
if ( na.ne.1.and.iad.ne.1 .or. &
|
||||
& nb.ne.1.and.ibd.ne.1 .or. nc.ne.1 ) then
|
||||
write (6,'(''MXMA : na,nb,nc,iad,ibd,icd,nar,nac,nbc =''/ &
|
||||
& 9i8)') na,nb,nc,iad,ibd,icd,nar,nac,nbc
|
||||
write (6,'(''MXMA : not implemented'')')
|
||||
stop
|
||||
end if
|
||||
!
|
||||
if (na.eq.1) then
|
||||
mode1='N'
|
||||
lda=iad
|
||||
else if (na.ne.1.and.iad.eq.1) then
|
||||
mode1='T'
|
||||
lda=na
|
||||
end if
|
||||
!
|
||||
if (nb.eq.1) then
|
||||
mode2='N'
|
||||
ldb=ibd
|
||||
else if (nb.ne.1.and.ibd.eq.1) then
|
||||
mode2='T'
|
||||
ldb=nb
|
||||
end if
|
||||
!
|
||||
! call to BLAS3 routine GEMM
|
||||
!
|
||||
call GEMM &
|
||||
& (mode1,mode2,nar,nbc,nac,1.d0,a,lda,b,ldb,0.d0,c,icd)
|
||||
!
|
||||
return
|
||||
end
|
||||
|
|
@ -0,0 +1,417 @@
|
|||
#
|
||||
# Makefile for 3rd derivative calculations - D3
|
||||
#
|
||||
include ../make.rules
|
||||
include ../make.sys
|
||||
#
|
||||
D3OBJS = d3com.o \
|
||||
allocate_d3.o \
|
||||
bcast_d3_input.o \
|
||||
ch_psi_all2.o \
|
||||
close_open.o \
|
||||
d0rhod2v.o \
|
||||
d2mxc.o \
|
||||
d3dyn_cc.o \
|
||||
d3_exc.o \
|
||||
d3_init.o \
|
||||
d3ionq.o \
|
||||
d3matrix.o \
|
||||
d3_readin.o \
|
||||
d3_recover.o \
|
||||
d3_setup.o \
|
||||
d3_summary.o \
|
||||
d3_symdyn.o \
|
||||
d3_symdynph.o \
|
||||
d3toten.o \
|
||||
d3_valence.o \
|
||||
d3vrho.o \
|
||||
davcio_drho2.o \
|
||||
dpsi_corr.o \
|
||||
dpsidpsidv.o \
|
||||
dpsidvdpsi.o \
|
||||
dqrhod2v.o \
|
||||
drho_cc.o \
|
||||
drhod2v.o \
|
||||
drho_drc.o \
|
||||
dvdpsi.o \
|
||||
dvscf.o \
|
||||
gen_dpdvp.o \
|
||||
gen_dwfc.o \
|
||||
incdrhoscf2.o \
|
||||
openfild3.o \
|
||||
print_clock_d3.o \
|
||||
psymd0rho.o \
|
||||
qstar_d3.o \
|
||||
read_ef.o \
|
||||
rotate_and_add_d3.o \
|
||||
set_d3irr.o \
|
||||
set_efsh.o \
|
||||
set_sym_irr.o \
|
||||
sgama_d3.o \
|
||||
solve_linter_d3.o \
|
||||
stop_d3.o \
|
||||
symd0rho.o \
|
||||
sym_def1.o \
|
||||
trntnsc_3.o \
|
||||
w_1gauss.o \
|
||||
write_aux.o \
|
||||
writed3dyn_5.o \
|
||||
write_d3dyn.o \
|
||||
write_igk.o
|
||||
|
||||
PHOBJS = ../PH/phcom.o \
|
||||
../PH/addcore.o \
|
||||
../PH/adddvscf.o \
|
||||
../PH/addnlcc.o \
|
||||
../PH/addusdbec.o \
|
||||
../PH/addusddens.o \
|
||||
../PH/addusdynmat.o \
|
||||
../PH/addusldos.o \
|
||||
../PH/add_zstar_ue.o \
|
||||
../PH/allocate_part.o \
|
||||
../PH/allocate_phq.o \
|
||||
../PH/bcast_ph_input1.o \
|
||||
../PH/bcast_ph_input.o \
|
||||
../PH/cg_psi.o \
|
||||
../PH/cgsolve_all.o \
|
||||
../PH/ch_psi_all.o \
|
||||
../PH/cinterpolate.o \
|
||||
../PH/compute_alphasum.o \
|
||||
../PH/compute_becalp.o \
|
||||
../PH/compute_becsum.o \
|
||||
../PH/compute_drhous.o \
|
||||
../PH/compute_dvloc.o \
|
||||
../PH/compute_nldyn.o \
|
||||
../PH/compute_weight.o \
|
||||
../PH/d2ionq.o \
|
||||
../PH/davcio_drho.o \
|
||||
../PH/dgcxc.o \
|
||||
../PH/dgcxc_spin.o \
|
||||
../PH/dgradcorr.o \
|
||||
../PH/dielec.o \
|
||||
../PH/dmxc.o \
|
||||
../PH/dmxc_spin.o \
|
||||
../PH/drhodv.o \
|
||||
../PH/drhodvloc.o \
|
||||
../PH/drhodvnl.o \
|
||||
../PH/drhodvus.o \
|
||||
../PH/drho.o \
|
||||
../PH/dvanqq.o \
|
||||
../PH/dv_of_drho.o \
|
||||
../PH/dvpsi_e.o \
|
||||
../PH/dvqpsi_us.o \
|
||||
../PH/dvqpsi_us_only.o \
|
||||
../PH/dyndia.o \
|
||||
../PH/dynmat0.o \
|
||||
../PH/dynmatcc.o \
|
||||
../PH/dynmatrix.o \
|
||||
../PH/dynmat_us.o \
|
||||
../PH/ef_shift.o \
|
||||
../PH/elphon.o \
|
||||
../PH/elph.o \
|
||||
../PH/h_psiq.o \
|
||||
../PH/incdrhoscf.o \
|
||||
../PH/incdrhous.o \
|
||||
../PH/io_pattern.o \
|
||||
../PH/localdos.o \
|
||||
../PH/newdq.o \
|
||||
../PH/openfilq.o \
|
||||
../PH/phq_init.o \
|
||||
../PH/phq_readin.o \
|
||||
../PH/phq_recover.o \
|
||||
../PH/phqscf.o \
|
||||
../PH/phq_setup.o \
|
||||
../PH/phq_summary.o \
|
||||
../PH/print_clock_ph.o \
|
||||
../PH/psymdvscf.o \
|
||||
../PH/psyme.o \
|
||||
../PH/punch_plot_e.o \
|
||||
../PH/punch_plot_ph.o \
|
||||
../PH/q2qstar_ph.o \
|
||||
../PH/random_matrix.o \
|
||||
../PH/rotate_and_add_dyn.o \
|
||||
../PH/set_drhoc.o \
|
||||
../PH/set_irr.o \
|
||||
../PH/set_irr_mode.o \
|
||||
../PH/set_irr_nosym.o \
|
||||
../PH/setlocq.o \
|
||||
../PH/setqmod.o \
|
||||
../PH/setup_dgc.o \
|
||||
../PH/smallgq.o \
|
||||
../PH/solve_e.o \
|
||||
../PH/solve_linter.o \
|
||||
../PH/star_q.o \
|
||||
../PH/stop_ph.o \
|
||||
../PH/sym_and_write_zue.o \
|
||||
../PH/sym_def.o \
|
||||
../PH/symdvscf.o \
|
||||
../PH/symdyn_munu.o \
|
||||
../PH/symdynph_gq.o \
|
||||
../PH/syme.o \
|
||||
../PH/symz.o \
|
||||
../PH/tra_write_matrix.o \
|
||||
../PH/trntnsc.o \
|
||||
../PH/write_dyn_on_file.o \
|
||||
../PH/write_epsilon_and_zeu.o \
|
||||
../PH/write_matrix.o \
|
||||
../PH/zstar_eu.o
|
||||
|
||||
MODULES = ../Modules/*.o
|
||||
|
||||
PWOBJS = ../PW/pwcom.o \
|
||||
../PW/aainit.o \
|
||||
../PW/addusdens.o \
|
||||
../PW/addusforce.o \
|
||||
../PW/addusstress.o \
|
||||
../PW/add_vuspsi.o \
|
||||
../PW/allocate.o \
|
||||
../PW/allocate_fft.o \
|
||||
../PW/allocate_locpot.o \
|
||||
../PW/allocate_nlpot.o \
|
||||
../PW/allocate_wfc.o \
|
||||
../PW/allowed.o \
|
||||
../PW/atomic_rho.o \
|
||||
../PW/atomic_wfc.o \
|
||||
../PW/bachel.o \
|
||||
../PW/becmod.o \
|
||||
../PW/bfgs.o \
|
||||
../PW/broadcast.o \
|
||||
../PW/c_bands.o \
|
||||
../PW/ccalbec.o \
|
||||
../PW/ccgdiagg.o \
|
||||
../PW/cdiagh.o \
|
||||
../PW/cdiaghg.o \
|
||||
../PW/cdiisg.o \
|
||||
../PW/cegterg.o \
|
||||
../PW/cft_3.o \
|
||||
../PW/cft3.o \
|
||||
../PW/cft3s.o \
|
||||
../PW/cft.o \
|
||||
../PW/cft_fftw.o \
|
||||
../PW/cfts_3.o \
|
||||
../PW/cft_sgi.o \
|
||||
../PW/cft_sp.o \
|
||||
../PW/cft_sun.o \
|
||||
../PW/cft_t3e.o \
|
||||
../PW/cgather_sym.o \
|
||||
../PW/c_gemm.o \
|
||||
../PW/cgramg1.o \
|
||||
../PW/checkallsym.o \
|
||||
../PW/check.o \
|
||||
../PW/checksym.o \
|
||||
../PW/cinitcgg.o \
|
||||
../PW/clocks.o \
|
||||
../PW/constrain.o \
|
||||
../PW/conv_to_num.o \
|
||||
../PW/coset.o \
|
||||
../PW/cryst_to_car.o \
|
||||
../PW/cubicsym.o \
|
||||
../PW/data_structure.o \
|
||||
../PW/date_and_tim.o \
|
||||
../PW/davcio.o \
|
||||
../PW/delta_e.o \
|
||||
../PW/deriv_drhoc.o \
|
||||
../PW/diropn.o \
|
||||
../PW/divide_et_impera.o \
|
||||
../PW/divide.o \
|
||||
../PW/d_matrix.o \
|
||||
../PW/dndepsilon.o \
|
||||
../PW/dndtau.o \
|
||||
../PW/dprojdepsilon.o \
|
||||
../PW/dprojdtau.o \
|
||||
../PW/dqvan2.o \
|
||||
../PW/drhoc.o \
|
||||
../PW/dsum.o \
|
||||
../PW/dvloc_of_g.o \
|
||||
../PW/dylmr2.o \
|
||||
../PW/dynamics.o \
|
||||
../PW/efermig.o \
|
||||
../PW/efermit.o \
|
||||
../PW/electrons.o \
|
||||
../PW/eqvect.o \
|
||||
../PW/erf.o \
|
||||
../PW/error.o \
|
||||
../PW/error_handler.o \
|
||||
../PW/estimate.o \
|
||||
../PW/ewald.o \
|
||||
../PW/fft_scatter.o \
|
||||
../PW/fftw.o \
|
||||
../PW/force_cc.o \
|
||||
../PW/force_corr.o \
|
||||
../PW/force_ew.o \
|
||||
../PW/force_hub.o \
|
||||
../PW/force_lc.o \
|
||||
../PW/forces.o \
|
||||
../PW/force_us.o \
|
||||
../PW/funct.o \
|
||||
../PW/functionals.o \
|
||||
../PW/gather.o \
|
||||
../PW/gen_at_dj.o \
|
||||
../PW/gen_at_dy.o \
|
||||
../PW/gen_us_dj.o \
|
||||
../PW/gen_us_dy.o \
|
||||
../PW/ggen.o \
|
||||
../PW/gk_sort.o \
|
||||
../PW/good_fft_dimension.o \
|
||||
../PW/g_psi.o \
|
||||
../PW/g_psi_mod.o \
|
||||
../PW/gradcorr.o \
|
||||
../PW/gweights.o \
|
||||
../PW/h_1psi.o \
|
||||
../PW/hexsym.o \
|
||||
../PW/hinit0.o \
|
||||
../PW/hinit1.o \
|
||||
../PW/h_psi.o \
|
||||
../PW/hpsort.o \
|
||||
../PW/init_ns.o \
|
||||
../PW/init_pool.o \
|
||||
../PW/init_run.o \
|
||||
../PW/init_us_1.o \
|
||||
../PW/init_us_2.o \
|
||||
../PW/init_vloc.o \
|
||||
../PW/input.o \
|
||||
../PW/interpolate.o \
|
||||
../PW/invmat.o \
|
||||
../PW/io.o \
|
||||
../PW/ions.o \
|
||||
../PW/io_pot.o \
|
||||
../PW/irrek.o \
|
||||
../PW/iweights.o \
|
||||
../PW/kpoint_grid.o \
|
||||
../PW/latgen.o \
|
||||
../PW/lchk_tauxk.o \
|
||||
../PW/linmin.o \
|
||||
../PW/lsda_functionals.o \
|
||||
../PW/maximum.o \
|
||||
../PW/mix_pot.o \
|
||||
../PW/mix_rho.o \
|
||||
../PW/mode_group.o \
|
||||
../PW/move_ions.o \
|
||||
../PW/multable.o \
|
||||
../PW/newd.o \
|
||||
../PW/new_ns.o \
|
||||
../PW/n_plane_waves.o \
|
||||
../PW/openfil.o \
|
||||
../PW/orthoatwfc.o \
|
||||
../PW/ortho.o \
|
||||
../PW/para.o \
|
||||
../PW/pencils.o \
|
||||
../PW/poolbcast.o \
|
||||
../PW/poolextreme.o \
|
||||
../PW/poolrecover.o \
|
||||
../PW/poolreduce.o \
|
||||
../PW/poolscatter.o \
|
||||
../PW/potinit.o \
|
||||
../PW/print_clock_pw.o \
|
||||
../PW/psymrho.o \
|
||||
../PW/punch.o \
|
||||
../PW/qvan2.o \
|
||||
../PW/random.o \
|
||||
../PW/read_conf_from_file.o \
|
||||
../PW/read_file.o \
|
||||
../PW/readin.o \
|
||||
../PW/read_ncpp.o \
|
||||
../PW/readnewvan.o \
|
||||
../PW/read_pseudo.o \
|
||||
../PW/readvan.o \
|
||||
../PW/recips.o \
|
||||
../PW/reduce.o \
|
||||
../PW/remove_atomic_rho.o \
|
||||
../PW/restart.o \
|
||||
../PW/restart_from_file.o \
|
||||
../PW/restart_in_electrons.o \
|
||||
../PW/restart_in_ions.o \
|
||||
../PW/rgen.o \
|
||||
../PW/rho2zeta.o \
|
||||
../PW/rotate_wfc.o \
|
||||
../PW/ruotaijk.o \
|
||||
../PW/s_1psi.o \
|
||||
../PW/saveall.o \
|
||||
../PW/save_in_cbands.o \
|
||||
../PW/save_in_electrons.o \
|
||||
../PW/save_in_ions.o \
|
||||
../PW/s_axis_to_ca.o \
|
||||
../PW/scala_cdiag.o \
|
||||
../PW/scala_cdiaghg.o \
|
||||
../PW/scala_utils.o \
|
||||
../PW/scale_h.o \
|
||||
../PW/scatter.o \
|
||||
../PW/scnds.o \
|
||||
../PW/scopy_t3e.o \
|
||||
../PW/seqopn.o \
|
||||
../PW/set_fft_dim.o \
|
||||
../PW/set_kplusq.o \
|
||||
../PW/set_kup_and_kdw.o \
|
||||
../PW/setlocal.o \
|
||||
../PW/set_pencils.o \
|
||||
../PW/setqf.o \
|
||||
../PW/set_rhoc.o \
|
||||
../PW/setup.o \
|
||||
../PW/setupkpt.o \
|
||||
../PW/setv.o \
|
||||
../PW/set_vrs.o \
|
||||
../PW/sgama.o \
|
||||
../PW/sgam_at.o \
|
||||
../PW/sgam_ph.o \
|
||||
../PW/s_gemm.o \
|
||||
../PW/show_memory.o \
|
||||
../PW/simpson.o \
|
||||
../PW/smallg_q.o \
|
||||
../PW/sph_bes.o \
|
||||
../PW/s_psi.o \
|
||||
../PW/startup.o \
|
||||
../PW/stop_pw.o \
|
||||
../PW/stres_cc.o \
|
||||
../PW/stres_ewa.o \
|
||||
../PW/stres_gradcorr.o \
|
||||
../PW/stres_har.o \
|
||||
../PW/stres_hub.o \
|
||||
../PW/stres_knl.o \
|
||||
../PW/stres_loc.o \
|
||||
../PW/stress.o \
|
||||
../PW/stres_us.o \
|
||||
../PW/struct_fact.o \
|
||||
../PW/sum_band.o \
|
||||
../PW/sumkg.o \
|
||||
../PW/sumkt.o \
|
||||
../PW/summary.o \
|
||||
../PW/swap.o \
|
||||
../PW/symrho.o \
|
||||
../PW/symtns.o \
|
||||
../PW/symvect.o \
|
||||
../PW/tabd.o \
|
||||
../PW/trntns.o \
|
||||
../PW/trnvecc.o \
|
||||
../PW/trnvect.o \
|
||||
../PW/tweights.o \
|
||||
../PW/update_pot.o \
|
||||
../PW/updathes.o \
|
||||
../PW/upf_to_internal.o \
|
||||
../PW/usnldiag.o \
|
||||
../PW/vcsmd.o \
|
||||
../PW/vcsubs.o \
|
||||
../PW/vhpsi.o \
|
||||
../PW/vloc_of_g.o \
|
||||
../PW/v_of_rho.o \
|
||||
../PW/volume.o \
|
||||
../PW/vpack.o \
|
||||
../PW/w0gauss.o \
|
||||
../PW/w1gauss.o \
|
||||
../PW/wfcinit.o \
|
||||
../PW/wgauss.o \
|
||||
../PW/which_dft.o \
|
||||
../PW/write_config_to_file.o \
|
||||
../PW/write_ns.o \
|
||||
../PW/ylmr2.o
|
||||
#
|
||||
# targets
|
||||
#
|
||||
include .dependencies
|
||||
|
||||
all: $(D3OBJS)
|
||||
$(LD) -o d3.x $(D3OBJS) $(PHOBJS) $(PWOBJS) $(MODULES) $(LFLAGS)
|
||||
clean:
|
||||
-/bin/rm -f d3.x *.o *.d *~ *.F90 *.mod
|
||||
veryclean: clean
|
||||
-/bin/rm .dependencies intel.pcl work.pc
|
||||
#
|
||||
|
|
@ -0,0 +1,61 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine allocate_d3
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! dynamical allocation of arrays: quantities needed for the third
|
||||
! derivative of the total energy
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
use allocate
|
||||
implicit none
|
||||
|
||||
call allocate_phq
|
||||
if (lgamma) then
|
||||
vlocg0 => vlocq
|
||||
npertg0=> npert
|
||||
vkb0 => vkb
|
||||
ug0 => u
|
||||
tg0 => t
|
||||
else
|
||||
call mallocate(vlocg0, ngm, ntyp)
|
||||
call mallocate(ug0, 3*nat, 3*nat)
|
||||
call mallocate(tg0, 3, 3, 48, 3*nat)
|
||||
call mallocate(npertg0, 3*nat)
|
||||
call mallocate(vkb0, npwx , nkb)
|
||||
endif
|
||||
call mallocate(psidqvpsi, nbnd, nbnd)
|
||||
call mallocate(d3dyn, 3 * nat, 3 * nat, 3 * nat)
|
||||
|
||||
if (degauss.ne.0.d0) call mallocate(ef_sh, 3 * nat)
|
||||
call mallocate(d3dyn_aux1 , 3 * nat, 3 * nat, 3 * nat)
|
||||
call mallocate(d3dyn_aux2 , 3 * nat, 3 * nat, 3 * nat)
|
||||
call mallocate(d3dyn_aux3 , 3 * nat, 3 * nat, 3 * nat)
|
||||
call mallocate(d3dyn_aux4 , 3 * nat, 3 * nat, 3 * nat)
|
||||
call mallocate(d3dyn_aux5 , 3 * nat, 3 * nat, 3 * nat)
|
||||
call mallocate(d3dyn_aux6 , 3 * nat, 3 * nat, 3 * nat)
|
||||
call mallocate(d3dyn_aux7 , 3 * nat, 3 * nat, 3 * nat)
|
||||
call mallocate(d3dyn_aux8 , 3 * nat, 3 * nat, 3 * nat)
|
||||
call mallocate(d3dyn_aux9 , 3 * nat, 3 * nat, 3 * nat)
|
||||
call setv (54 * nat * nat * nat, 0.d0, d3dyn_aux1, 1)
|
||||
call setv (54 * nat * nat * nat, 0.d0, d3dyn_aux2, 1)
|
||||
call setv (54 * nat * nat * nat, 0.d0, d3dyn_aux3, 1)
|
||||
call setv (54 * nat * nat * nat, 0.d0, d3dyn_aux4, 1)
|
||||
call setv (54 * nat * nat * nat, 0.d0, d3dyn_aux5, 1)
|
||||
call setv (54 * nat * nat * nat, 0.d0, d3dyn_aux6, 1)
|
||||
call setv (54 * nat * nat * nat, 0.d0, d3dyn_aux7, 1)
|
||||
call setv (54 * nat * nat * nat, 0.d0, d3dyn_aux8, 1)
|
||||
call setv (54 * nat * nat * nat, 0.d0, d3dyn_aux9, 1)
|
||||
|
||||
return
|
||||
end subroutine allocate_d3
|
||||
|
|
@ -0,0 +1,88 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine bcast_d3_input
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! In this routine the first processor send the input to all
|
||||
! the other processors
|
||||
!
|
||||
!
|
||||
#ifdef PARA
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
use para
|
||||
use io
|
||||
|
||||
implicit none
|
||||
include 'mpif.h'
|
||||
integer :: root, errcode
|
||||
character (len=512) :: buffer
|
||||
integer :: buffer_t3d (64)
|
||||
|
||||
equivalence (buffer, buffer_t3d)
|
||||
root = 0
|
||||
call MPI_barrier (MPI_COMM_WORLD, errcode)
|
||||
call error ('bcast_ph_input', 'at barrier', errcode)
|
||||
! logicals
|
||||
call MPI_bcast (lgamma, 1, MPI_LOGICAL, root, MPI_COMM_WORLD, &
|
||||
errcode)
|
||||
call error ('bcast_ph_input', 'at bcast1', errcode)
|
||||
call MPI_bcast (wraux, 1, MPI_LOGICAL, root, MPI_COMM_WORLD, &
|
||||
errcode)
|
||||
call error ('bcast_d3_input', 'at bcast51', errcode)
|
||||
call MPI_bcast (recv, 1, MPI_LOGICAL, root, MPI_COMM_WORLD, &
|
||||
errcode)
|
||||
call error ('bcast_d3_input', 'at bcast52', errcode)
|
||||
call MPI_bcast (testflag, 50, MPI_LOGICAL, root, MPI_COMM_WORLD, &
|
||||
errcode)
|
||||
call error ('bcast_d3_input', 'at bcast53', errcode)
|
||||
!
|
||||
! integers
|
||||
!
|
||||
call MPI_bcast (iverbosity, 1, MPI_INTEGER, root, MPI_COMM_WORLD, &
|
||||
errcode)
|
||||
call error ('bcast_ph_input', 'at bcast9', errcode)
|
||||
call MPI_bcast (testint, 50, MPI_INTEGER, root, MPI_COMM_WORLD, &
|
||||
errcode)
|
||||
call error ('bcast_d3_input', 'at bcast91', errcode)
|
||||
call MPI_bcast (q0mode_todo, 300, MPI_INTEGER, root, &
|
||||
MPI_COMM_WORLD, errcode)
|
||||
call error ('bcast_d3_input', 'at bcast92', errcode)
|
||||
call MPI_bcast (istop, 1, MPI_INTEGER, root, MPI_COMM_WORLD, &
|
||||
errcode)
|
||||
call error ('bcast_d3_input', 'at bcast93', errcode)
|
||||
!
|
||||
! real*8
|
||||
!
|
||||
call MPI_bcast (amass, ntypx, MPI_REAL8, root, MPI_COMM_WORLD, &
|
||||
errcode)
|
||||
call error ('bcast_ph_input', 'at bcast12', errcode)
|
||||
call MPI_bcast (xq, 3, MPI_REAL8, root, MPI_COMM_WORLD, errcode)
|
||||
call error ('bcast_ph_input', 'at bcast14', errcode)
|
||||
call MPI_bcast (ethr_ph, 1, MPI_REAL8, root, MPI_COMM_WORLD, &
|
||||
errcode)
|
||||
call error ('bcast_d3_input', 'at bcast16', errcode)
|
||||
call MPI_bcast (testreal, 50, MPI_REAL8, root, MPI_COMM_WORLD, &
|
||||
errcode)
|
||||
call error ('bcast_d3_input', 'at bcast17', errcode)
|
||||
!
|
||||
! characters
|
||||
!
|
||||
if (me.eq.1) write (buffer, '(a75,a14,3a50,a35)') title_ph, &
|
||||
filpun, fildyn, fildrho, fild0rho, tmp_dir
|
||||
call MPI_bcast (buffer_t3d, 512, MPI_CHARACTER, root, &
|
||||
MPI_COMM_WORLD, errcode)
|
||||
call error ('bcast_ph_input', 'at bcast character', errcode)
|
||||
if (me.ne.1) read (buffer, '(a75,a14,3a50,a35)') title_ph, filpun, &
|
||||
fildyn, fildrho, fild0rho, tmp_dir
|
||||
#endif
|
||||
return
|
||||
end subroutine bcast_d3_input
|
||||
|
|
@ -0,0 +1,110 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
|
||||
!-----------------------------------------------------------------------
|
||||
|
||||
subroutine ch_psi_all2 (n, h, ah, e, ik, m)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! This routine applies the operator ( H - \epsilon S + alpha_pv P_v)
|
||||
! to a vector h. The result is given in Ah.
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use becmod
|
||||
use phcom
|
||||
use allocate
|
||||
|
||||
implicit none
|
||||
integer :: n, m, ik
|
||||
! input: the dimension of h
|
||||
! input: the number of bands
|
||||
! input: the k point
|
||||
|
||||
real (8) :: e (m)
|
||||
! input: the eigenvalue
|
||||
|
||||
complex (8) :: h (npwx, m), ah (npwx, m)
|
||||
! input: the vector
|
||||
! output: the operator applied to the vector
|
||||
!
|
||||
! local variables
|
||||
!
|
||||
|
||||
integer :: ibnd, ikq, ig
|
||||
! counter on bands
|
||||
! the point k+q
|
||||
! counter on G vetors
|
||||
|
||||
complex (8), pointer :: ps (:,:), hpsi (:,:), spsi (:,:)
|
||||
! scalar products
|
||||
! the product of the Hamiltonian and h
|
||||
! the product of the S matrix and h
|
||||
|
||||
|
||||
call start_clock ('ch_psi')
|
||||
call mallocate(ps, nbnd, m)
|
||||
call mallocate(hpsi, npwx, m)
|
||||
call mallocate(spsi, npwx, m)
|
||||
|
||||
call setv (2 * npwx * m, 0.d0, hpsi, 1)
|
||||
call setv (2 * npwx * m, 0.d0, spsi, 1)
|
||||
!
|
||||
! compute the product of the hamiltonian with the h vector
|
||||
!
|
||||
call h_psiq (npwx, n, m, h, hpsi, spsi)
|
||||
|
||||
call start_clock ('last')
|
||||
!
|
||||
! then we compute the operator H-epsilon S
|
||||
!
|
||||
do ibnd = 1, m
|
||||
do ig = 1, n
|
||||
ah (ig, ibnd) = hpsi (ig, ibnd) - e (ibnd) * spsi (ig, ibnd)
|
||||
enddo
|
||||
enddo
|
||||
!
|
||||
! Here we compute the projector in the valence band
|
||||
!
|
||||
call setv (2 * npwx * m, 0.d0, hpsi, 1)
|
||||
if (lgamma) then
|
||||
ikq = ik
|
||||
else
|
||||
ikq = 2 * ik
|
||||
endif
|
||||
call setv (2 * nbnd * m, 0.d0, ps, 1)
|
||||
|
||||
call ZGEMM ('C', 'N', nbnd, m, n, (1.d0, 0.d0) , evq, npwx, spsi, &
|
||||
npwx, (0.d0, 0.d0) , ps, nbnd)
|
||||
call DSCAL (2 * nbnd * m, alpha_pv, ps, 1)
|
||||
#ifdef PARA
|
||||
call reduce (2 * nbnd * m, ps)
|
||||
#endif
|
||||
|
||||
call ZGEMM ('N', 'N', n, m, nbnd, (1.d0, 0.d0) , evq, npwx, ps, &
|
||||
nbnd, (1.d0, 0.d0) , hpsi, npwx)
|
||||
call ZCOPY (npwx * m, hpsi, 1, spsi, 1)
|
||||
!
|
||||
! And apply S again
|
||||
!
|
||||
call ccalbec (nkb, npwx, n, m, becp, vkb, hpsi)
|
||||
|
||||
call s_psi (npwx, n, m, hpsi, spsi)
|
||||
do ibnd = 1, m
|
||||
do ig = 1, n
|
||||
ah (ig, ibnd) = ah (ig, ibnd) + spsi (ig, ibnd)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call mfree (spsi)
|
||||
call mfree (hpsi)
|
||||
call mfree (ps)
|
||||
call stop_clock ('last')
|
||||
call stop_clock ('ch_psi')
|
||||
return
|
||||
end subroutine ch_psi_all2
|
||||
|
|
@ -0,0 +1,100 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine close_open (isw)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! Close and open some units. It is useful in case of interrupted run
|
||||
!
|
||||
!
|
||||
#include"machine.h"
|
||||
use pwcom, only: filpun, degauss
|
||||
use phcom, only: iudwf, lrdwf, lgamma
|
||||
use d3com
|
||||
#ifdef PARA
|
||||
use para
|
||||
#endif
|
||||
implicit none
|
||||
integer :: isw
|
||||
character (len=20) :: filint * 42
|
||||
! the name of the file
|
||||
logical :: exst
|
||||
! logical variable to check file existenc
|
||||
|
||||
if (len_trim(filpun).eq.0) call error ('recv', 'wrong filpun name', 1)
|
||||
if (isw.eq.3) then
|
||||
!
|
||||
! This is to be used after gen_dwf(3)
|
||||
!
|
||||
#ifdef PARA
|
||||
if (me.ne.1.or.mypool.ne.1) goto 210
|
||||
#endif
|
||||
if (degauss.ne.0.d0) then
|
||||
close (unit = iuef, status = 'keep')
|
||||
filint = trim(filpun) //'.efs'
|
||||
call seqopn (iuef, filint, 'unformatted', exst)
|
||||
endif
|
||||
#ifdef PARA
|
||||
|
||||
210 continue
|
||||
#endif
|
||||
close (unit = iupd0vp, status = 'keep')
|
||||
filint = trim(filpun) //'.p0p'
|
||||
if (lgamma) filint = trim(filpun) //'.pdp'
|
||||
|
||||
call diropn (iupd0vp, filint, lrpdqvp, exst)
|
||||
close (unit = iudwf, status = 'keep')
|
||||
filint = trim(filpun) //'.dwf'
|
||||
|
||||
call diropn (iudwf, filint, lrdwf, exst)
|
||||
elseif (isw.eq.1) then
|
||||
!
|
||||
! This is to be used after gen_dwf(1)
|
||||
!
|
||||
|
||||
if (lgamma) call error (' close_open ', ' isw=1 ; lgamma', 1)
|
||||
close (unit = iupdqvp, status = 'keep')
|
||||
filint = trim(filpun) //'.pdp'
|
||||
|
||||
call diropn (iupdqvp, filint, lrpdqvp, exst)
|
||||
close (unit = iudqwf, status = 'keep')
|
||||
filint = trim(filpun) //'.dqwf'
|
||||
|
||||
call diropn (iudqwf, filint, lrdwf, exst)
|
||||
elseif (isw.eq.2) then
|
||||
!
|
||||
! This is to be used after gen_dwf(2)
|
||||
!
|
||||
if (lgamma) call error (' close_open ', ' isw=2 ; lgamma', 1)
|
||||
close (unit = iud0qwf, status = 'keep')
|
||||
filint = trim(filpun) //'.d0wf'
|
||||
call diropn (iud0qwf, filint, lrdwf, exst)
|
||||
elseif (isw.eq.4) then
|
||||
!
|
||||
! This is to be used after gen_dpdvp
|
||||
!
|
||||
|
||||
if (degauss.eq.0.d0) return
|
||||
close (unit = iudpdvp_1, status = 'keep')
|
||||
filint = trim(filpun) //'.pv1'
|
||||
|
||||
call diropn (iudpdvp_1, filint, lrdpdvp, exst)
|
||||
if (.not.lgamma) then
|
||||
close (unit = iudpdvp_2, status = 'keep')
|
||||
filint = trim(filpun) //'.pv2'
|
||||
|
||||
call diropn (iudpdvp_2, filint, lrdpdvp, exst)
|
||||
close (unit = iudpdvp_3, status = 'keep')
|
||||
filint = trim(filpun) //'.pv3'
|
||||
call diropn (iudpdvp_3, filint, lrdpdvp, exst)
|
||||
endif
|
||||
|
||||
endif
|
||||
return
|
||||
end subroutine close_open
|
||||
|
|
@ -0,0 +1,222 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!----------------------------------------------------------------------
|
||||
subroutine d0rhod2v (ipert, drhoscf)
|
||||
!-----------------------------------------------------------------------
|
||||
! calculates the term containing the second variation of the potential
|
||||
! and the first variation of the charge density with respect to a
|
||||
! perturbation at q=0
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
use allocate
|
||||
#ifdef PARA
|
||||
use para
|
||||
#endif
|
||||
implicit none
|
||||
integer :: ipert ! index of the perturbation associated with drho
|
||||
complex (8) :: drhoscf (nrxx) ! the variation of the charge density
|
||||
!
|
||||
integer :: icart, & ! counter on polarizations
|
||||
jcart, & ! counter on polarizations
|
||||
na_icart, & ! counter on modes
|
||||
na_jcart, & ! counter on modes
|
||||
na, & ! counter on atoms
|
||||
ng, & ! counter on G vectors
|
||||
nt, & ! counter on atomic types
|
||||
ik, & ! counter on k points
|
||||
ikk, & ! counter on k points
|
||||
ig, & ! counter on G vectors
|
||||
ibnd, & ! counter on bands
|
||||
nu_i, & ! counter on modes
|
||||
nu_j, & ! counter on modes
|
||||
nu_k, & ! counter on modes
|
||||
ikb, jkb, & ! counter on beta functions
|
||||
nrec, & ! record position of dwfc
|
||||
ios ! integer variable for I/O control
|
||||
|
||||
real (8) :: gtau, & ! the product G*\tau_s
|
||||
wgg ! the weight of a K point
|
||||
|
||||
complex (8) :: ZDOTC, d3dywrk (3*nat,3*nat), fac, alpha(8), work
|
||||
complex (8), pointer :: work0 (:), work1 (:), work2 (:), work3 (:), &
|
||||
work4 (:), work5 (:), work6 (:)
|
||||
! auxiliary space
|
||||
|
||||
call mallocate(work0,nrxx)
|
||||
call mallocate(work1,npwx)
|
||||
call mallocate(work2,npwx)
|
||||
call mallocate(work3,npwx)
|
||||
call mallocate(work4,npwx)
|
||||
call mallocate(work5,npwx)
|
||||
call mallocate(work6,npwx)
|
||||
|
||||
call setv (2*9*nat*nat,0.0d0,d3dywrk,1)
|
||||
!
|
||||
! Here the contribution deriving from the local part of the potential
|
||||
#ifdef PARA
|
||||
! ... computed only by the first pool (no sum over k needed)
|
||||
!
|
||||
if (mypool.ne.1) goto 100
|
||||
#endif
|
||||
!
|
||||
call ZCOPY (nrxx, drhoscf, 1, work0, 1)
|
||||
call cft3 (work0, nr1, nr2, nr3, nrx1, nrx2, nrx3, -1)
|
||||
do na = 1, nat
|
||||
do icart = 1,3
|
||||
na_icart = 3*(na-1)+icart
|
||||
do jcart = 1,3
|
||||
na_jcart = 3*(na-1)+jcart
|
||||
do ng = 1, ngm
|
||||
gtau = tpi * ( g(1,ng)*tau(1,na) + &
|
||||
g(2,ng)*tau(2,na) + &
|
||||
g(3,ng)*tau(3,na) )
|
||||
|
||||
fac = DCMPLX(cos(gtau),sin(gtau))
|
||||
|
||||
d3dywrk(na_icart,na_jcart) = &
|
||||
d3dywrk(na_icart,na_jcart) - &
|
||||
tpiba2 * g(icart,ng) * g(jcart,ng) * &
|
||||
omega * vloc(igtongl(ng),ityp(na)) * &
|
||||
fac*work0(nl(ng))
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
write (*,*) na
|
||||
write (*,'(3(2f10.6,2x))') &
|
||||
((d3dywrk(3*(na-1)+icart,3*(na-1)+jcart), &
|
||||
jcart=1,3),icart=1,3)
|
||||
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call reduce(2*9*nat*nat,d3dywrk)
|
||||
!
|
||||
! each pool contributes to next term
|
||||
!
|
||||
100 continue
|
||||
#endif
|
||||
!
|
||||
! Here we compute the nonlocal (Kleinman-Bylander) contribution.
|
||||
!
|
||||
rewind (unit=iunigk)
|
||||
|
||||
do ik = 1, nksq
|
||||
read (iunigk, err = 200, iostat = ios) npw, igk
|
||||
200 call error ('d0rhod2v', 'reading igk', abs (ios) )
|
||||
if (lgamma) then
|
||||
ikk = ik
|
||||
npwq = npw
|
||||
else
|
||||
ikk = 2 * ik - 1
|
||||
read (iunigk, err = 300, iostat = ios) npwq, igkq
|
||||
300 call error ('d0rhod2v', 'reading igkq', abs (ios) )
|
||||
npwq = npw
|
||||
endif
|
||||
wgg = wk (ikk)
|
||||
call davcio (evc, lrwfc, iuwfc, ikk, - 1)
|
||||
|
||||
call init_us_2 (npw, igk, xk (1, ikk), vkb0)
|
||||
!
|
||||
! Reads the first variation of the wavefunction projected on conduction
|
||||
!
|
||||
nrec = (ipert - 1) * nksq + ik
|
||||
call davcio (dpsi, lrdwf, iudwf, nrec, - 1)
|
||||
!
|
||||
! In the metallic case corrects dpsi so as that the density matrix
|
||||
! will be: Sum_{k,nu} 2 * | dpsi > < psi |
|
||||
!
|
||||
if (degauss.ne.0.d0) then
|
||||
nrec = ipert + (ik - 1) * 3 * nat
|
||||
call davcio (psidqvpsi, lrpdqvp, iupd0vp, nrec, - 1)
|
||||
call dpsi_corr (evc, psidqvpsi, ikk, ikk, ipert)
|
||||
endif
|
||||
do icart = 1, 3
|
||||
do jcart = 1, 3
|
||||
do ibnd = 1, nbnd
|
||||
do ig = 1, npw
|
||||
work1(ig)= evc(ig,ibnd)*tpiba*(xk(icart,ikk)+g(icart,igk(ig)))
|
||||
work2(ig)= evc(ig,ibnd)*tpiba*(xk(jcart,ikk)+g(jcart,igk(ig)))
|
||||
work3(ig)=dpsi(ig,ibnd)*tpiba*(xk(icart,ikk)+g(icart,igk(ig)))
|
||||
work4(ig)=dpsi(ig,ibnd)*tpiba*(xk(jcart,ikk)+g(jcart,igk(ig)))
|
||||
work5(ig)= work1(ig)*tpiba*(xk(jcart,ikk)+g(jcart,igk(ig)))
|
||||
work6(ig)= work3(ig)*tpiba*(xk(jcart,ikk)+g(jcart,igk(ig)))
|
||||
enddo
|
||||
jkb=0
|
||||
do nt = 1, ntyp
|
||||
do na = 1, nat
|
||||
if (ityp (na).eq.nt) then
|
||||
na_icart = 3 * (na - 1) + icart
|
||||
na_jcart = 3 * (na - 1) + jcart
|
||||
do ikb = 1, nh (nt)
|
||||
jkb=jkb+1
|
||||
alpha (1) = ZDOTC (npw, work1, 1, vkb0(1,jkb), 1)
|
||||
alpha (2) = ZDOTC (npw, vkb0(1,jkb), 1, work4, 1)
|
||||
alpha (3) = ZDOTC (npw, work2, 1, vkb0(1,jkb), 1)
|
||||
alpha (4) = ZDOTC (npw, vkb0(1,jkb), 1, work3, 1)
|
||||
alpha (5) = ZDOTC (npw, work5, 1, vkb0(1,jkb), 1)
|
||||
alpha (6) = ZDOTC (npw, vkb0(1,jkb), 1, dpsi (1,ibnd), 1)
|
||||
alpha (7) = ZDOTC (npw, evc (1,ibnd), 1, vkb0(1,jkb), 1)
|
||||
alpha (8) = ZDOTC (npw, vkb0(1,jkb), 1, work6, 1)
|
||||
#ifdef PARA
|
||||
call reduce (16, alpha)
|
||||
#endif
|
||||
d3dywrk (na_icart, na_jcart) = d3dywrk (na_icart, na_jcart) &
|
||||
+ (alpha(1)*alpha(2) + alpha(3)*alpha(4) &
|
||||
- alpha(5)*alpha(6) - alpha(7)*alpha(8)) * &
|
||||
dvan (ikb,ikb,nt) * wgg * 2.0d0
|
||||
enddo
|
||||
end if
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call poolreduce (2*9*nat*nat, d3dywrk)
|
||||
#endif
|
||||
!
|
||||
! Rotate the dynamical matrix on the basis of patterns
|
||||
! first index does not need to be rotated
|
||||
!
|
||||
nu_k = ipert
|
||||
do nu_i = 1, 3 * nat
|
||||
do nu_j = 1, 3 * nat
|
||||
work = (0.0d0, 0.0d0)
|
||||
do na = 1, nat
|
||||
do icart = 1, 3
|
||||
na_icart = 3 * (na-1) + icart
|
||||
do jcart = 1, 3
|
||||
na_jcart = 3 * (na-1) + jcart
|
||||
work = work + conjg(u(na_icart,nu_i)) * &
|
||||
d3dywrk(na_icart,na_jcart) * &
|
||||
u(na_jcart,nu_j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
d3dyn(nu_k,nu_i,nu_j) = d3dyn(nu_k,nu_i,nu_j) + work
|
||||
if (allmodes) then
|
||||
d3dyn(nu_j,nu_k,nu_i) = d3dyn(nu_j,nu_k,nu_i) + work
|
||||
d3dyn(nu_i,nu_j,nu_k) = d3dyn(nu_i,nu_j,nu_k) + work
|
||||
endif
|
||||
enddo
|
||||
|
||||
enddo
|
||||
call mfree (work6)
|
||||
call mfree (work5)
|
||||
call mfree (work4)
|
||||
call mfree (work3)
|
||||
call mfree (work2)
|
||||
call mfree (work1)
|
||||
call mfree (work0)
|
||||
|
||||
return
|
||||
end subroutine d0rhod2v
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
function d2mxc (rho)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! second derivative of the xc potential with respect to the local densi
|
||||
! Perdew and Zunger parameterization of the C.A. functional
|
||||
!
|
||||
|
||||
implicit none
|
||||
|
||||
real (8) :: rho, d2mxc
|
||||
! input: the charge density ( positive )
|
||||
! output: the second derivative of the xc potent
|
||||
|
||||
real (8) :: b1, b2, gc, a, b, c, d, pi, thofpi_3, fpioth_3, &
|
||||
thopi_3, tm1, tm2, tm3, tm4, tm5, tm6
|
||||
! _ parameters defining the functionals
|
||||
! /
|
||||
! pi
|
||||
! (3/4/pi)^0.333
|
||||
! (4*pi/3)^0.333
|
||||
! (3/pi)^0.333
|
||||
! 35.d0*b1,
|
||||
! 76.d0*b1*b1 + 64.d0*b2
|
||||
! 35.d0*b1*b1*b1 + 234.d0*b1*b2
|
||||
! 140.d0*b2*b1*b1 + 176.d0*b2*b2
|
||||
! 175.d0*b1*b2*b2
|
||||
! 64.d0*b2*b2*b2
|
||||
|
||||
parameter (b1 = 1.0529d0, b2 = 0.3334d0, gc = - 0.1423d0, a = &
|
||||
0.0311d0, b = - 0.0480d0, c = 0.0020d0, d = - 0.0116d0, pi = &
|
||||
3.14159265358979d0, fpioth_3 = 1.61199195401647d0, thofpi_3 = &
|
||||
0.620350490899400d0, thopi_3 = 0.98474502184270d0, tm1 = &
|
||||
36.85150d0, tm2 = 105.59107916d0, tm3 = 122.996139546115d0, tm4 = &
|
||||
71.30831794516d0, tm5 = 20.4812455967d0, tm6 = 2.371792877056d0)
|
||||
|
||||
real (8) :: rs, x, den
|
||||
|
||||
rs = thofpi_3 * (1.d0 / rho) **0.3333333333333333d0
|
||||
if (rs.ge.1.d0) then
|
||||
x = sqrt (rs)
|
||||
den = 1.d0 + x * b1 + b2 * x**2
|
||||
d2mxc = - gc * (tm1 * x + tm2 * x**2 + tm3 * x**3 + tm4 * x**4 &
|
||||
+ tm5 * x**5 + tm6 * x**6) / ( (rho**2) * (den**4) * 216.d0)
|
||||
else
|
||||
d2mxc = (9.d0 * a + (6.d0 * c + 8.d0 * d) * rs + 8.d0 * c * rs &
|
||||
* log (rs) ) / (rho**2) / 27.d0
|
||||
|
||||
endif
|
||||
|
||||
rs = rs * fpioth_3
|
||||
d2mxc = d2mxc + (2.d0 / 9.d0 * thopi_3 * rs**5)
|
||||
|
||||
d2mxc = 2.d0 * d2mxc
|
||||
return
|
||||
end function d2mxc
|
||||
|
|
@ -0,0 +1,88 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine d3_exc
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! Calculates the contribution to the derivative of the dynamical
|
||||
! matrix due to the third derivative of the exchange and correlation
|
||||
! energy
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
use allocate
|
||||
#ifdef PARA
|
||||
use para
|
||||
#endif
|
||||
implicit none
|
||||
integer :: errcode, ir, ipert, jpert, kpert, npert1, npert2
|
||||
real (8) :: d2mxc, rhotot, xq0 (3)
|
||||
real (8), pointer :: d2muxc (:)
|
||||
complex (8) :: aux
|
||||
complex (8), pointer :: work1 (:), work2 (:), work3 (:), d3dyn1 (:,:,:)
|
||||
|
||||
call mallocate(d2muxc, nrxx)
|
||||
call mallocate(work1 , nrxx)
|
||||
call mallocate(work2 , nrxx)
|
||||
call mallocate(work3 , nrxx)
|
||||
call mallocate(d3dyn1, 3*nat, 3*nat, 3*nat)
|
||||
#ifdef PARA
|
||||
if (mypool.ne.1) goto 100
|
||||
#endif
|
||||
!
|
||||
! Calculates third derivative of Exc
|
||||
!
|
||||
call setv (nrxx, 0.d0, d2muxc, 1)
|
||||
do ir = 1, nrxx
|
||||
rhotot = rho (ir, 1) + rho_core (ir)
|
||||
if (rhotot.gt.1.d-30) d2muxc (ir) = d2mxc (rhotot)
|
||||
if (rhotot.lt. - 1.d-30) d2muxc (ir) = - d2mxc ( - rhotot)
|
||||
enddo
|
||||
!
|
||||
! Calculates the contribution to d3dyn
|
||||
!
|
||||
call setv (2 * 27 * nat * nat * nat, 0.d0, d3dyn1, 1)
|
||||
do ipert = 1, 3 * nat
|
||||
if (q0mode (ipert) ) then
|
||||
call davcio_drho (work1, lrdrho, iud0rho, ipert, - 1)
|
||||
do jpert = 1, 3 * nat
|
||||
call davcio_drho (work2, lrdrho, iudrho, jpert, - 1)
|
||||
do kpert = 1, 3 * nat
|
||||
call davcio_drho (work3, lrdrho, iudrho, kpert, - 1)
|
||||
aux = DCMPLX (0.d0, 0.d0)
|
||||
do ir = 1, nrxx
|
||||
aux = aux + d2muxc (ir) * work1 (ir) * conjg (work2 (ir) ) &
|
||||
* work3 (ir)
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call reduce (2, aux)
|
||||
#endif
|
||||
d3dyn1 (ipert, jpert, kpert) = omega * aux / (nr1 * nr2 * nr3)
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
|
||||
enddo
|
||||
#ifdef PARA
|
||||
100 continue
|
||||
call poolbcast (2 * 27 * nat * nat * nat, d3dyn1)
|
||||
#endif
|
||||
|
||||
call DAXPY (2 * 27 * nat * nat * nat, 1.d0, d3dyn1, 1, d3dyn, 1)
|
||||
call ZCOPY (27 * nat * nat * nat, d3dyn1, 1, d3dyn_aux9, 1)
|
||||
|
||||
call mfree (d2muxc)
|
||||
call mfree (work1)
|
||||
call mfree (work2)
|
||||
call mfree (work3)
|
||||
call mfree (d3dyn1)
|
||||
|
||||
return
|
||||
end subroutine d3_exc
|
||||
|
|
@ -0,0 +1,129 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine d3_init
|
||||
!-----------------------------------------------------------------------
|
||||
#include"machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
use allocate
|
||||
#ifdef PARA
|
||||
use para
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef PARA
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer :: nt, irr, irr1, ipert, imode0, errcode
|
||||
! counter on atom types
|
||||
real (8) :: work (3) ! working area
|
||||
|
||||
complex (8), pointer :: drhoscf (:,:)
|
||||
|
||||
call mallocate(drhoscf, nrxx, 3)
|
||||
!
|
||||
! the fourier trasform of the core charge both for q=0 and q.ne.0
|
||||
!
|
||||
if (nlcc_any) then
|
||||
!
|
||||
! drc is allocated in phq_setup
|
||||
!
|
||||
if (.not.lgamma) then
|
||||
|
||||
call mallocate(d0rc, ngm, ntyp)
|
||||
call setv (3, 0.d0, work, 1)
|
||||
call set_drhoc (work)
|
||||
call ZCOPY (ngm * ntyp, drc, 1, d0rc, 1)
|
||||
else
|
||||
d0rc => drc
|
||||
endif
|
||||
!
|
||||
! drc is calculated in phq_init
|
||||
! call set_drhoc(xq)
|
||||
endif
|
||||
!
|
||||
! uses the same initialization routines as the phonon program
|
||||
!
|
||||
call phq_init
|
||||
call write_igk
|
||||
!
|
||||
! the fourier components of the local potential at q+G for q=0
|
||||
!
|
||||
if (.not.lgamma) then
|
||||
call setv (ngm * ntyp, 0.d0, vlocg0, 1)
|
||||
call setv (3, 0.d0, work, 1)
|
||||
do nt = 1, ntyp
|
||||
call setlocq (work, lloc(nt), lmax(nt), numeric(nt), &
|
||||
mesh(nt), msh(nt), rab(1,nt), r(1,nt), vnl(1,lloc(nt),nt), &
|
||||
cc(1,nt), alpc(1,nt), nlc(nt), nnl(nt), zp(nt), aps(1,0,nt), &
|
||||
alps(1,0,nt), tpiba2, ngm, g, omega, vlocg0(1,nt) )
|
||||
enddo
|
||||
endif
|
||||
!
|
||||
! Reads the q=0 variation of the charge --d0rho-- and symmetrizes it
|
||||
!
|
||||
#ifdef PARA
|
||||
! if (mypool.ne.1) goto 100
|
||||
#endif
|
||||
do irr = 1, nirrg0
|
||||
imode0 = 0
|
||||
do irr1 = 1, irr - 1
|
||||
imode0 = imode0 + npertg0 (irr1)
|
||||
enddo
|
||||
do ipert = 1, npertg0 (irr)
|
||||
call davcio_drho2 (drhoscf(1,ipert), lrdrho, iud0rho, &
|
||||
imode0+ipert, - 1)
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call psymd0rho (npertg0(irr), irr, drhoscf)
|
||||
#else
|
||||
call symd0rho (npertg0(irr), irr, drhoscf, s, ftau, nsymg0, &
|
||||
irgq, tg0, nat, nr1, nr2, nr3, nrx1, nrx2, nrx3)
|
||||
#endif
|
||||
do ipert = 1, npertg0 (irr)
|
||||
call davcio_drho2 (drhoscf(1,ipert), lrdrho, iud0rho, &
|
||||
imode0+ipert, +1)
|
||||
enddo
|
||||
enddo
|
||||
!
|
||||
! Reads the variation of the charge --drho-- and symmetrizes it
|
||||
!
|
||||
if (.not.lgamma) then
|
||||
do irr = 1, nirr
|
||||
imode0 = 0
|
||||
do irr1 = 1, irr - 1
|
||||
imode0 = imode0 + npert (irr1)
|
||||
enddo
|
||||
do ipert = 1, npert (irr)
|
||||
call davcio_drho2 (drhoscf(1,ipert), lrdrho, iudrho, &
|
||||
imode0+ipert, -1)
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call psymdvscf (npert(irr), irr, drhoscf)
|
||||
#else
|
||||
call symdvscf (npert(irr), irr, drhoscf)
|
||||
#endif
|
||||
do ipert = 1, npert(irr)
|
||||
call davcio_drho2 (drhoscf(1,ipert), lrdrho, iudrho, &
|
||||
imode0+ipert, +1)
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
#ifdef PARA
|
||||
100 continue
|
||||
call MPI_barrier (MPI_COMM_WORLD, errcode)
|
||||
|
||||
call error ('d3_init', 'at barrier', errcode)
|
||||
#endif
|
||||
|
||||
call mfree(drhoscf)
|
||||
return
|
||||
|
||||
end subroutine d3_init
|
||||
|
|
@ -0,0 +1,177 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine d3_readin
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! This routine reads the control variables for the program phononq. T
|
||||
! input is read from unit 5. A namelist is used on the machine which
|
||||
! allows it. A second routine readfile reads the variables saved
|
||||
! on the filpun file by the self-consistent program.
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
use io
|
||||
#ifdef PARA
|
||||
use para
|
||||
#endif
|
||||
implicit none
|
||||
integer :: ios, ipol, iter, na, it, ii
|
||||
! integer variable for I/O control
|
||||
! counter on polarizations
|
||||
! counter on iterations
|
||||
! counter on atoms
|
||||
! counter on types
|
||||
! counter
|
||||
! eigenvalues convergence thresho
|
||||
|
||||
namelist / inputph / ethr_ph, amass, iverbosity, tmp_dir, filpun, &
|
||||
fildyn, fildrho, fild0rho, q0mode_todo, wraux, recv, istop, &
|
||||
testflag, testint, testreal
|
||||
! atomic masses
|
||||
! write control
|
||||
! directory for temporary files
|
||||
! computed
|
||||
! the punch file produced by pwsc
|
||||
! the file with the dynamical mat
|
||||
! the file with the deltarho
|
||||
! the file with q=0 deltarho
|
||||
! list of the q=0 modes to be com
|
||||
! .true.==> writes some auxiliary
|
||||
! .true.==> this is a recover run
|
||||
! to stop the program at a given
|
||||
! variables used for testing purp
|
||||
! variables used for testing purp
|
||||
! variables used for testing purp
|
||||
#ifdef PARA
|
||||
|
||||
if (me.ne.1) goto 400
|
||||
#endif
|
||||
!
|
||||
! Read the first line of the input file
|
||||
!
|
||||
read (5, '(a)', err = 100, iostat = ios) title_ph
|
||||
100 call error ('d3_readin', 'reading title ', abs (ios) )
|
||||
!
|
||||
! set default values for variables in namelist
|
||||
!
|
||||
ethr_ph = 1.d-5
|
||||
iverbosity = 0
|
||||
tmp_dir = './'
|
||||
filpun = ' '
|
||||
fildyn = 'd3dyn'
|
||||
fildrho = ' '
|
||||
fild0rho = ' '
|
||||
do ii = 1, 300
|
||||
q0mode_todo (ii) = 0
|
||||
enddo
|
||||
wraux = .false.
|
||||
recv = .false.
|
||||
istop = 0
|
||||
do ii = 1, 50
|
||||
testflag (ii) = .false.
|
||||
|
||||
|
||||
enddo
|
||||
!
|
||||
! reading the namelist inputph
|
||||
!
|
||||
#ifdef CRAYY
|
||||
! The Cray does not accept "err" and "iostat" together with a namelist
|
||||
read (5, inputph)
|
||||
ios = 0
|
||||
#else
|
||||
!
|
||||
! Note: for AIX machine (xlf compiler version 3.0 or higher):
|
||||
! The variable XLFRTEOPTS must be set to "namelist=old"
|
||||
! in order to have "&end" to end the namelist
|
||||
!
|
||||
read (5, inputph, err = 200, iostat = ios)
|
||||
#endif
|
||||
|
||||
200 call error ('d3_readin', 'reading inputph namelist', abs (ios) )
|
||||
!
|
||||
! Check all namelist variables
|
||||
!
|
||||
if (ethr_ph.le.0.d0) call error (' d3_readin', ' Wrong ethr_ph ', &
|
||||
1)
|
||||
if (iverbosity.ne.0.and.iverbosity.ne.1) call error ('d3_readin', ' Wrong &
|
||||
&iverbosity ', 1)
|
||||
if (fildyn.eq.' ') call error ('d3_readin', ' Wrong fildyn ', 1)
|
||||
if (filpun.eq.' ') call error ('d3_readin', ' Wrong filpun ', 1)
|
||||
if (fildrho.eq.' ') call error ('d3_readin', ' Wrong fildrho ', 1)
|
||||
if (fild0rho.eq.' ') call error ('d3_readin', ' Wrong fild0rho ', &
|
||||
1)
|
||||
!
|
||||
! reads the q point
|
||||
!
|
||||
read (5, *, err = 300, iostat = ios) (xq (ipol), ipol = 1, 3)
|
||||
300 call error ('d3_readin', 'reading xq', abs (ios) )
|
||||
|
||||
lgamma = xq (1) .eq.0.d0.and.xq (2) .eq.0.d0.and.xq (3) .eq.0.d0
|
||||
#ifdef PARA
|
||||
400 continue
|
||||
|
||||
call bcast_d3_input
|
||||
call init_pool
|
||||
#endif
|
||||
call DCOPY (3, xq, 1, xqq, 1)
|
||||
!
|
||||
! Here we finished the reading of the input file.
|
||||
! Now allocate space for pwscf variables, read and check them.
|
||||
!
|
||||
call read_file
|
||||
!
|
||||
if (lgamma) then
|
||||
nksq = nks
|
||||
else
|
||||
nksq = nks / 2
|
||||
endif
|
||||
!
|
||||
if (lsda) call error ('d3_readin', 'lsda not implemented', 1)
|
||||
if (okvan) call error ('d3_readin', 'US not implemented', 1)
|
||||
!
|
||||
! There might be other variables in the input file which describe
|
||||
! partial computation of the dynamical matrix. Read them here
|
||||
!
|
||||
call allocate_part
|
||||
#ifdef PARA
|
||||
|
||||
if (me.ne.1.or.mypool.ne.1) goto 800
|
||||
#endif
|
||||
#ifdef PARA
|
||||
|
||||
800 continue
|
||||
#endif
|
||||
|
||||
if (iswitch.ne. - 2.and.iswitch.ne. - 3.and.iswitch.ne. - &
|
||||
4.and..not.lgamma) call error ('d3_readin', ' Wrong iswitch ', 1 + &
|
||||
abs (iswitch) )
|
||||
do it = 1, ntyp
|
||||
if (amass (it) .le.0.d0) call error ('d3_readin', 'Wrong masses', &
|
||||
it)
|
||||
|
||||
enddo
|
||||
if (mod (nks, 2) .ne.0.and..not.lgamma) call error ('d3_readin', &
|
||||
'k-points are odd', nks)
|
||||
!
|
||||
! q0mode, and q0mode_todo are not allocated dynamically. Their
|
||||
! dimension is fixed to 300
|
||||
!
|
||||
|
||||
if (3 * nat.gt.300) call error ('d3_readin', 'wrong dimension of q &
|
||||
&0mode variable', 1)
|
||||
do ii = 1, 3 * nat
|
||||
if (q0mode_todo (ii) .gt.3 * nat) call error ('d3_readin', ' wrong &
|
||||
& q0mode_todo ', 1)
|
||||
|
||||
enddo
|
||||
return
|
||||
end subroutine d3_readin
|
||||
|
|
@ -0,0 +1,81 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine d3_recover (ilab, isw)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! isw = +1 Writes d3dyn in a file for possible recover
|
||||
! isw = -1 Starts a recover run
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
#ifdef PARA
|
||||
use para
|
||||
#endif
|
||||
implicit none
|
||||
|
||||
#ifdef PARA
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer :: ilab, isw, root, iaux, errcode
|
||||
logical :: exst
|
||||
|
||||
iunrec = 98
|
||||
if (isw.eq.1) then
|
||||
#ifdef PARA
|
||||
call MPI_barrier (MPI_COMM_WORLD, errcode)
|
||||
call error ('d3_recover', 'at barrier', errcode)
|
||||
if (me.ne.1.or.mypool.ne.1) return
|
||||
#endif
|
||||
|
||||
call seqopn (iunrec, 'recv_d3', 'unformatted', exst)
|
||||
if (ilab.le.4) then
|
||||
write (iunrec) ilab
|
||||
else
|
||||
write (iunrec) ilab, d3dyn
|
||||
|
||||
endif
|
||||
|
||||
close (unit = iunrec, status = 'keep')
|
||||
elseif (isw.eq. - 1) then
|
||||
#ifdef PARA
|
||||
call MPI_barrier (MPI_COMM_WORLD, errcode)
|
||||
call error ('d3_recover', 'at barrier', errcode)
|
||||
if (me.ne.1.or.mypool.ne.1) goto 100
|
||||
#endif
|
||||
|
||||
call seqopn (iunrec, 'recv_d3', 'unformatted', exst)
|
||||
read (iunrec) ilab
|
||||
if (ilab.ge.5) then
|
||||
rewind (iunrec)
|
||||
read (iunrec) ilab, d3dyn
|
||||
|
||||
endif
|
||||
|
||||
close (unit = iunrec, status = 'keep')
|
||||
#ifdef PARA
|
||||
|
||||
100 continue
|
||||
root = 0
|
||||
call MPI_barrier (MPI_COMM_WORLD, errcode)
|
||||
|
||||
call error ('d3_recover', 'at barrier2', errcode)
|
||||
iaux = 2 * 27 * nat * nat * nat
|
||||
call MPI_bcast (d3dyn, iaux, MPI_REAL8, root, MPI_COMM_WORLD, &
|
||||
errcode)
|
||||
call error ('d3_recover', 'at bcast1', errcode)
|
||||
call MPI_bcast (ilab, 1, MPI_INTEGER, root, MPI_COMM_WORLD, &
|
||||
errcode)
|
||||
|
||||
call error ('d3_recover', 'at bcast2', errcode)
|
||||
#endif
|
||||
|
||||
endif
|
||||
return
|
||||
end subroutine d3_recover
|
||||
|
|
@ -0,0 +1,332 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine d3_setup
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! This subroutine prepares several variables which are needed in the
|
||||
! d3toten program:
|
||||
! 1) computes the total local potential (external+scf) on the smoot
|
||||
! grid to be used in h_psi and similia
|
||||
! 2) computes dmuxc 3.1) with GC if needed
|
||||
! 3) for metals sets the occupated bands
|
||||
! 4) computes alpha_pv
|
||||
! 5.1) computes the variables needed to pass to the pattern representat
|
||||
! of the small group of q
|
||||
! u the patterns
|
||||
! t the matrices of the small group of q on the pattern basis
|
||||
! tmq the matrix of the symmetry which sends q -> -q + G
|
||||
! gi the G associated to each symmetry operation
|
||||
! gimq the G of the q -> -q+G symmetry
|
||||
! irgq the small group indices
|
||||
! nsymq the order of the small group of q
|
||||
! irotmq the index of the q->-q+G symmetry
|
||||
! nirr the number of irreducible representation
|
||||
! npert the dimension of each irreducible representation
|
||||
! nmodes the number of modes
|
||||
! minus_q true if there is a symmetry sending q -> -q+G
|
||||
! 5.2) computes the variables needed to pass to the pattern representat
|
||||
! of the group of the crystal
|
||||
! ug0 the patterns
|
||||
! tg0 the matrices of the group on the pattern basis
|
||||
! nsymg0 the order of the group of the crystal
|
||||
! nirrg0 the number of irreducible representation
|
||||
! npertg0 the dimension of each irreducible representation
|
||||
! 6) set the variables needed to deal with nlcc
|
||||
! 7) set the variables needed to distribute one loop between pools
|
||||
! 8) set the variables needed to calculate only selected q=0 modes
|
||||
!
|
||||
#include "machine.h"
|
||||
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
use allocate
|
||||
#ifdef PARA
|
||||
use para
|
||||
#endif
|
||||
implicit none
|
||||
real (8) :: rhotot, rhoup, rhodw, target, small, fac, xmax, emin, &
|
||||
emax, dmxc, wrk
|
||||
! total charge
|
||||
! total up charge
|
||||
! total down charge
|
||||
! auxiliary variables used
|
||||
! to set nbnd_occ in the metallic case
|
||||
! minimum band energy
|
||||
! maximum band energy
|
||||
! computes derivative of xc potential
|
||||
! working array
|
||||
|
||||
integer :: ir, table (48, 48), isym, jsym, iinv, irot, jrot, ik, &
|
||||
ibnd, ipol, mu, nu, imode0, irr, ipert, nt, ii, nu_i
|
||||
! counter on mesh points
|
||||
! the multiplication table of the point g
|
||||
! counter on symmetries
|
||||
! counter on symmetries
|
||||
! the index of the inverse
|
||||
! counter on rotations
|
||||
! counter on rotations
|
||||
! counter on k points
|
||||
! counter on bands
|
||||
! counter on polarizations
|
||||
! counter on modes
|
||||
! the starting mode
|
||||
! counter on representation and perturbat
|
||||
! counter on atomic type
|
||||
|
||||
logical :: sym (48)
|
||||
! the symmetry operations
|
||||
|
||||
#ifdef PARA
|
||||
integer :: nlength_w, nlength (npool), nresto
|
||||
#endif
|
||||
call start_clock ('d3_setup')
|
||||
!
|
||||
! 1) Computes the total local potential (external+scf) on the smoot grid
|
||||
!
|
||||
call set_vrs (vrs, vltot, vr, nrxx, nspin, doublegrid)
|
||||
!
|
||||
! 2) Computes the derivative of the xc potential
|
||||
!
|
||||
call setv (nrxx * nspin * nspin, 0.d0, dmuxc, 1)
|
||||
if (lsda) then
|
||||
do ir = 1, nrxx
|
||||
rhoup = rho (ir, 1) + 0.5d0 * rho_core (ir)
|
||||
rhodw = rho (ir, 2) + 0.5d0 * rho_core (ir)
|
||||
call dmxc_spin (rhoup, rhodw, dmuxc (ir, 1, 1), dmuxc (ir, 2, &
|
||||
1), dmuxc (ir, 1, 2), dmuxc (ir, 2, 2) )
|
||||
enddo
|
||||
else
|
||||
do ir = 1, nrxx
|
||||
rhotot = rho (ir, nspin) + rho_core (ir)
|
||||
if (rhotot.gt.1.d-30) dmuxc (ir, 1, 1) = dmxc (rhotot)
|
||||
if (rhotot.lt. - 1.d-30) dmuxc (ir, 1, 1) = - dmxc ( - rhotot)
|
||||
enddo
|
||||
endif
|
||||
!
|
||||
! 3) Computes the number of occupated bands for each k point
|
||||
!
|
||||
if (degauss.ne.0.d0) then
|
||||
!
|
||||
! discard conduction bands such that w0gauss(x,n) < small
|
||||
!
|
||||
! hint:
|
||||
! small = 1.0333492677046d-2 ! corresponds to 2 gaussian sigma
|
||||
! small = 6.9626525973374d-5 ! corresponds to 3 gaussian sigma
|
||||
! small = 6.3491173359333d-8 ! corresponds to 4 gaussian sigma
|
||||
!
|
||||
small = 6.9626525973374d-5
|
||||
!
|
||||
! - limit appropriated for gaussian broadening (used for all ngauss)
|
||||
!
|
||||
xmax = sqrt ( - log (sqrt (pi) * small) )
|
||||
!
|
||||
! - limit appropriated for Fermi-Dirac
|
||||
!
|
||||
if (ngauss.eq. - 99) then
|
||||
fac = 1.d0 / sqrt (small)
|
||||
xmax = 2.d0 * log (0.5 * (fac + sqrt (fac * fac - 4.0) ) )
|
||||
|
||||
endif
|
||||
target = ef + xmax * degauss
|
||||
do ik = 1, nks
|
||||
do ibnd = 1, nbnd
|
||||
if (et (ibnd, ik) .lt.target) nbnd_occ (ik) = ibnd
|
||||
enddo
|
||||
if (nbnd_occ (ik) .eq.nbnd) &
|
||||
write (6, '(5x,/,"Possibly too few bands at point ", &
|
||||
& i4,3f10.5)') ik, (xk (ipol, ik) , ipol = 1, 3)
|
||||
enddo
|
||||
else
|
||||
if (lsda) call error ('d3_setup', 'occupation numbers probably wro &
|
||||
&ng', - 1)
|
||||
do ik = 1, nks
|
||||
nbnd_occ (ik) = nint (nelec) / degspin
|
||||
enddo
|
||||
endif
|
||||
!
|
||||
! 4) Computes alpha_pv
|
||||
!
|
||||
emin = et (1, 1)
|
||||
do ik = 1, nks
|
||||
do ibnd = 1, nbnd
|
||||
emin = min (emin, et (ibnd, ik) )
|
||||
enddo
|
||||
enddo
|
||||
! find the minimum across pools
|
||||
|
||||
call poolextreme (emin, - 1)
|
||||
emax = et (1, 1)
|
||||
do ik = 1, nks
|
||||
do ibnd = 1, nbnd
|
||||
emax = max (emax, et (ibnd, ik) )
|
||||
enddo
|
||||
enddo
|
||||
! find the maximum across pools
|
||||
|
||||
call poolextreme (emax, + 1)
|
||||
alpha_pv = 2.d0 * (emax - emin)
|
||||
! avoid zero value for alpha_pv
|
||||
alpha_pv = max (alpha_pv, 1.0d-2)
|
||||
!
|
||||
! 5) set all the variables needed to use the pattern representation
|
||||
!
|
||||
!
|
||||
! 5.0) Computes the inverse of each matrix
|
||||
!
|
||||
call multable (nsym, s, table)
|
||||
do isym = 1, nsym
|
||||
do jsym = 1, nsym
|
||||
if (table (isym, jsym) .eq.1) invs (isym) = jsym
|
||||
enddo
|
||||
enddo
|
||||
!
|
||||
! 5.1) Finds the variables needeed for the pattern representation
|
||||
! of the small group of q
|
||||
!
|
||||
do isym = 1, nsym
|
||||
sym (isym) = .true.
|
||||
enddo
|
||||
|
||||
call sgam_ph (at, bg, nsym, s, irt, tau, rtau, nat, sym)
|
||||
nmodes = 3 * nat
|
||||
! if minus_q=.t. set_irr will search for
|
||||
minus_q = (iswitch.gt. - 3)
|
||||
! Sq=-q+G symmetry. On output minus_q=.t.
|
||||
! if such a symmetry has been found
|
||||
if (iswitch.eq. - 4) then
|
||||
call set_irr_mode (nat, at, bg, xq, s, invs, nsym, rtau, irt, &
|
||||
irgq, nsymq, minus_q, irotmq, t, tmq, u, npert, nirr, gi, gimq, &
|
||||
iverbosity, modenum)
|
||||
else
|
||||
if (nsym.gt.1) then
|
||||
call io_pattern(fildrho,nirr,npert,u,-1)
|
||||
call set_sym_irr (nat, at, bg, xq, s, invs, nsym, rtau, irt, &
|
||||
irgq, nsymq, minus_q, irotmq, t, tmq, u, npert, nirr, gi, &
|
||||
gimq, iverbosity)
|
||||
else
|
||||
call set_irr_nosym (nat, at, bg, xq, s, invs, nsym, rtau, &
|
||||
irt, irgq, nsymq, minus_q, irotmq, t, tmq, u, npert, nirr, &
|
||||
gi, gimq, iverbosity)
|
||||
endif
|
||||
endif
|
||||
!
|
||||
! 5.2) Finds the variables needeed for the pattern representation
|
||||
! of the small group of the crystal
|
||||
!
|
||||
if (lgamma) then
|
||||
nsymg0 = nsymq
|
||||
nirrg0 = nirr
|
||||
else
|
||||
!
|
||||
! It finds which symmetries of the lattice are symmetries of the crystal
|
||||
! it calculates the order of the crystal group: nsymg0
|
||||
! and reorder the s matrices in this way:
|
||||
! a) the first nsymg0 matrices are symmetries of the crystal
|
||||
! b) the first nsymq matrices are symmetries for the small group of q
|
||||
!
|
||||
call sgama_d3 (nsymq, nat, s, ityp, nr1, nr2, nr3, nsymg0, irt, &
|
||||
ftau, at, bg, tau)
|
||||
!
|
||||
! Recalculates the inverse of each rotation
|
||||
!
|
||||
call multable (nsymg0, s, table)
|
||||
do irot = 1, nsymg0
|
||||
do jrot = 1, nsymg0
|
||||
if (table (irot, jrot) .eq.1) invs (irot) = jrot
|
||||
enddo
|
||||
enddo
|
||||
!
|
||||
! Calculates rtau
|
||||
!
|
||||
do isym = 1, nsymg0
|
||||
sym (isym) = .true.
|
||||
enddo
|
||||
call sgam_ph (at, bg, nsymg0, s, irt, tau, rtau, nat, sym)
|
||||
!
|
||||
! Calculates the variables need for the pattern representation
|
||||
! for the q=0 symmetries
|
||||
!
|
||||
call set_d3irr
|
||||
endif
|
||||
!
|
||||
! 6) Set non linear core correction stuff
|
||||
!
|
||||
nlcc_any = .false.
|
||||
do nt = 1, ntyp
|
||||
nlcc_any = nlcc_any.or.nlcc (nt)
|
||||
|
||||
enddo
|
||||
|
||||
if (nlcc_any) call mallocate(drc, ngm, ntyp)
|
||||
!
|
||||
! 7) Sets up variables needed to distribute one loop between pools
|
||||
!
|
||||
npert_i = 1
|
||||
npert_f = 3 * nat
|
||||
#ifdef PARA
|
||||
nlength_w = (3 * nat) / npool
|
||||
nresto = 3 * nat - nlength_w * npool
|
||||
do ii = 1, npool
|
||||
if (ii.le.nresto) then
|
||||
nlength (ii) = nlength_w + 1
|
||||
else
|
||||
nlength (ii) = nlength_w
|
||||
endif
|
||||
enddo
|
||||
npert_i = 1
|
||||
do ii = 1, mypool - 1
|
||||
npert_i = npert_i + nlength (ii)
|
||||
enddo
|
||||
|
||||
npert_f = npert_i - 1 + nlength (mypool)
|
||||
#endif
|
||||
!
|
||||
! 8) Sets up variables needed to calculate only selected
|
||||
! modes at q=0 --the first index of the third order matrix--
|
||||
!
|
||||
if (q0mode_todo (1) .le.0) then
|
||||
do ii = 1, 3 * nat
|
||||
q0mode (ii) = .true.
|
||||
enddo
|
||||
else
|
||||
do ii = 1, 3 * nat
|
||||
q0mode (ii) = .false.
|
||||
enddo
|
||||
ii = 1
|
||||
do while (q0mode_todo (ii) .gt.0)
|
||||
q0mode (q0mode_todo (ii) ) = .true.
|
||||
ii = ii + 1
|
||||
enddo
|
||||
endif
|
||||
!
|
||||
! if you want to compute all the modes; and lgamma=.true.
|
||||
! the calculation can be simplyfied, in this case allmodes
|
||||
! is set .true.
|
||||
!
|
||||
allmodes = lgamma.and.q0mode_todo (1) .le.0
|
||||
!
|
||||
! Sets up variables needed to write only selected
|
||||
! modes at q=0 --the first index of the third order matrix--
|
||||
!
|
||||
do ii = 1, 3 * nat
|
||||
wrk = 0.d0
|
||||
do nu_i = 1, 3 * nat
|
||||
if (q0mode (nu_i) ) then
|
||||
wrk = wrk + ug0 (ii, nu_i) * conjg (ug0 (ii, nu_i) )
|
||||
endif
|
||||
enddo
|
||||
wrmode (ii) = .false.
|
||||
if (wrk.gt.1.d-8) wrmode (ii) = .true.
|
||||
|
||||
enddo
|
||||
call stop_clock ('d3_setup')
|
||||
return
|
||||
end subroutine d3_setup
|
||||
|
|
@ -0,0 +1,364 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine d3_summary
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! This routine writes on output the quantities which have been read
|
||||
! from the punch file, and the quantities computed in the d3_setup
|
||||
! file.
|
||||
!
|
||||
! if iverbosity = 0 only a partial summary is done.
|
||||
!
|
||||
#include"machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
!
|
||||
implicit none
|
||||
integer :: i, l, nt, mu, nu, ipol, apol, na, isymq, isym, nsymtot, &
|
||||
ik, ib, irr, imode0, iaux
|
||||
! generic counter
|
||||
! counter on angular momenta
|
||||
! counter on atomic types
|
||||
! counter on modes
|
||||
! counter on modes
|
||||
! counter on polarizations
|
||||
! counter on polarizations
|
||||
! counter on atoms
|
||||
! counter on symmetries
|
||||
! counter on symmetries
|
||||
! counter on symmetries
|
||||
! counter on k points
|
||||
! counter on beta functions
|
||||
! counter on irreducible representation
|
||||
! the first mode
|
||||
|
||||
real (8) :: ft1, ft2, ft3, sr (3, 3), xkg (3)
|
||||
! fractionary translation
|
||||
! fractionary translation
|
||||
! fractionary translation
|
||||
! the symmetry matrix in cartesian coord
|
||||
! k point in crystal coordinates
|
||||
|
||||
character :: ps * 5
|
||||
! the name of the pseudo
|
||||
write (6, 100) title_ph, crystal, ibrav, alat, omega, nat, ntyp, &
|
||||
ecutwfc, ecutwfc * dual
|
||||
100 format (/,5x,a75,/,/,5x, 'crystal is ',a20,/,/,5x, &
|
||||
& 'bravais-lattice index = ',i12,/,5x, &
|
||||
& 'lattice parameter (a_0) = ',f12.4,' a.u.',/,5x, &
|
||||
& 'unit-cell volume = ',f12.4,' (a.u.)^3',/,5x, &
|
||||
& 'number of atoms/cell = ',i12,/,5x, &
|
||||
& 'number of atomic types = ',i12,/,5x, &
|
||||
& 'kinetic-energy cut-off = ',f12.4,' Ry',/,5x, &
|
||||
& 'charge densisty cut-off = ',f12.4,' Ry',/,5x,/)
|
||||
!
|
||||
! and here more detailed informations. Description of the unit cell
|
||||
!
|
||||
write (6, '(2(3x,3(2x,"celldm(",i1,")=",f11.5),/))') (i, &
|
||||
celldm (i) , i = 1, 6)
|
||||
write (6, '(5x, &
|
||||
& "crystal axes: (cart. coord. in units of a_0)",/, &
|
||||
& 3(15x,"a(",i1,") = (",3f8.4," ) ",/ ) )') (apol, &
|
||||
& (at (ipol, apol) , ipol = 1, 3) , apol = 1, 3)
|
||||
write (6, '(5x, &
|
||||
&"reciprocal axes: (cart. coord. in units 2 pi/a_0)",/, &
|
||||
& 3(15x,"b(",i1,") = (",3f8.4," ) ",/ ) )') (apol, &
|
||||
& (bg (ipol, apol) , ipol = 1, 3) , apol = 1, 3)
|
||||
!
|
||||
! description of the atoms inside the unit cell
|
||||
!
|
||||
write (6, '(/, 5x,"Atoms inside the unit cell: ")')
|
||||
write (6, '(/,3x,"Cartesian axes")')
|
||||
write (6, '(/,5x,"site n. atom mass ", &
|
||||
& " positions (a_0 units)")')
|
||||
|
||||
write (6, '(7x,i2,5x,a6,f8.4," tau(",i2, ") = (",3f11.5," )")') &
|
||||
(na, atm (ityp (na) ) , amass (ityp (na) ) / amconv, na, &
|
||||
(tau (ipol, na ) , ipol = 1, 3) , na = 1, nat)
|
||||
write (6, '(/,5x,"Computing dynamical matrix for ")')
|
||||
write (6, '(20x,"q = (",3f11.5," )")') (xq (ipol) , ipol = 1, 3)
|
||||
if (q0mode_todo (1) .le.0) then
|
||||
write (6, '(/,5x,"Computing all the modes ")')
|
||||
else
|
||||
write (6, '(/,5x,"Computing only selected modes: ")')
|
||||
do i = 1, 3 * nat
|
||||
if (q0mode (i) ) write (6, '(5x,"Mode to be computed: ",i5)') i
|
||||
enddo
|
||||
endif
|
||||
!
|
||||
! description of symmetries
|
||||
!
|
||||
write (6, * )
|
||||
if (nsymg0.le.1) then
|
||||
write (6, '(5x,"No symmetry! for q=0 ")')
|
||||
else
|
||||
write (6, '(5x,i2," + 1 = ",i2," q=0 Sym.Ops. ",/)') &
|
||||
nsymg0, nsymg0 + 1
|
||||
endif
|
||||
if (.not.lgamma) then
|
||||
write (6, * )
|
||||
if (nsymq.le.1.and..not.minus_q) then
|
||||
write (6, '(5x,"No symmetry!")')
|
||||
else
|
||||
if (minus_q) then
|
||||
write (6, '(5x,i2," Sym.Ops. (with q -> -q+G )",/)') &
|
||||
nsymq + 1
|
||||
else
|
||||
write (6, '(5x,i2," Sym.Ops. (no q -> -q+G )",/)') &
|
||||
nsymq
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
if (iverbosity.eq.1) then
|
||||
|
||||
write (6, '(36x,"s",24x,"frac. trans.")')
|
||||
if (minus_q) then
|
||||
iaux = 0
|
||||
else
|
||||
iaux = 1
|
||||
endif
|
||||
do isymq = iaux, nsymg0
|
||||
if (isymq.eq.0) then
|
||||
isym = irotmq
|
||||
write (6, '(/,5x,"This transformation sends q -> -q+G")')
|
||||
else
|
||||
!
|
||||
! It seems to me variable irgq is useless !
|
||||
! isym = irgq(isymq)
|
||||
isym = isymq
|
||||
endif
|
||||
if (isymq.eq.nsymq + 1) then
|
||||
write (6, '(//,5x,&
|
||||
&"In the following are listed symmetries of the crystal")')
|
||||
write (6, '(5x,"not belonging to the small group of q")')
|
||||
endif
|
||||
write (6, '(/6x,"isym = ",i2,5x,a45/)') isymq, sname (isym)
|
||||
call s_axis_to_cart (s (1, 1, isym), sr, at, bg)
|
||||
if (ftau (1, isym) .ne.0.or.ftau (2, isym) .ne.0.or.ftau (3, &
|
||||
isym) .ne.0) then
|
||||
ft1 = at (1, 1) * ftau (1, isym) / nr1 + at (1, 2) * ftau ( &
|
||||
2, isym) / nr2 + at (1, 3) * ftau (3, isym) / nr3
|
||||
ft2 = at (2, 1) * ftau (1, isym) / nr1 + at (2, 2) * ftau ( &
|
||||
2, isym) / nr2 + at (2, 3) * ftau (3, isym) / nr3
|
||||
ft3 = at (3, 1) * ftau (1, isym) / nr1 + at (3, 2) * ftau ( &
|
||||
2, isym) / nr2 + at (3, 3) * ftau (3, isym) / nr3
|
||||
write (6, '(1x,"cryst.",3x,"s(",i2,") = (",3(i6,5x), &
|
||||
&" ) f =( ",f10.7," )")') isymq, (s (1, ipol, isym),&
|
||||
ipol = 1, 3) , float (ftau (1, isym) ) / float (nr1)
|
||||
write (6, '(17x," (",3(i6,5x), &
|
||||
& " ) ( ",f10.7," )")') &
|
||||
(s (2, ipol, &
|
||||
&isym) , ipol = 1, 3) , float (ftau (2, isym) ) / float (nr2)
|
||||
write (6, '(17x," (",3(i6,5x), &
|
||||
& " ) ( ",f10.7," )"/)') (s (3, ipol, &
|
||||
& isym) , ipol = 1, 3) , float (ftau (3, isym) ) / float (nr3)
|
||||
write (6, '(1x,"cart.",3x,"s(",i2,") = (",3f11.7, &
|
||||
& " ) f =( ",f10.7," )")') isymq, (sr (1 &
|
||||
&, ipol) , ipol = 1, 3) , ft1
|
||||
write (6, '(17x," (",3f11.7, &
|
||||
& " ) ( ",f10.7," )")') (sr (2, ipol) &
|
||||
& , ipol = 1, 3) , ft2
|
||||
write (6, '(17x," (",3f11.7, &
|
||||
& " ) ( ",f10.7," )"/)') (sr (3, ipol &
|
||||
&) , ipol = 1, 3) , ft3
|
||||
else
|
||||
write (6, '(1x,"cryst.",3x,"s(",i2,") = (",3(i6,5x), &
|
||||
& " )")') isymq, (s (1, ipol, isym) , ipol = &
|
||||
&1, 3)
|
||||
write (6, '(17x," (",3(i6,5x)," )")') (s (2, ipol, isym) &
|
||||
, ipol = 1, 3)
|
||||
write (6, '(17x," (",3(i6,5x)," )"/)') (s (3, ipol, &
|
||||
isym) , ipol = 1, 3)
|
||||
write (6, '(1x,"cart.",3x,"s(",i2,") = (",3f11.7, &
|
||||
& " )")') isymq, (sr (1, ipol) , ipol = 1, 3)
|
||||
write (6, '(17x," (",3f11.7," )")') (sr (2, ipol) , &
|
||||
ipol = 1, 3)
|
||||
write (6, '(17x," (",3f11.7," )"/)') (sr (3, ipol) , &
|
||||
ipol = 1, 3)
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
!
|
||||
! Description of the reciprocal lattice vectors
|
||||
!
|
||||
write (6, '(/5x,"G cutoff =",f10.4," (", &
|
||||
& i7," G-vectors)"," FFT grid: (",i3, &
|
||||
& ",",i3,",",i3,")")') gcutm, ngm, nr1, nr2, nr3
|
||||
|
||||
if (doublegrid) write (6, '(5x,"G cutoff =",f10.4," (", &
|
||||
& i7," G-vectors)"," smooth grid: (",i3, &
|
||||
& ",",i3,",",i3,")")') gcutms, ngms, &
|
||||
&nr1s, nr2s, nr3s
|
||||
if (degauss.eq.0.d0) then
|
||||
write (6, '(5x,"number of k points=",i5)') nkstot
|
||||
else
|
||||
write (6, '(5x,"number of k points=",i5, &
|
||||
& " gaussian broad. (ryd)=",f8.4,5x, &
|
||||
& "ngauss = ",i3)') nkstot, degauss, ngauss
|
||||
endif
|
||||
write (6, '(23x,"cart. coord. in units 2pi/a_0")')
|
||||
do ik = 1, nkstot
|
||||
write (6, '(8x,"k(",i5,") = (",3f12.7,"), wk =",f12.7)') ik, &
|
||||
(xk (ipol, ik) , ipol = 1, 3) , wk (ik)
|
||||
enddo
|
||||
if (iverbosity.eq.1) then
|
||||
write (6, '(/23x,"cryst. coord.")')
|
||||
do ik = 1, nkstot
|
||||
do ipol = 1, 3
|
||||
! xkg are the compone
|
||||
xkg (ipol) = at (1, ipol) * xk (1, ik) + at (2, ipol) * xk (2, &
|
||||
ik) + at (3, ipol) * xk (3, ik)
|
||||
! of xk in the crysta
|
||||
! rec. lattice basis
|
||||
enddo
|
||||
write (6, '(8x,"k(",i5,") = (",3f12.7,"), wk =",f12.7)') &
|
||||
ik, (xkg (ipol) , ipol = 1, 3) , wk (ik)
|
||||
enddo
|
||||
|
||||
endif
|
||||
do nt = 1, ntyp
|
||||
if (tvanp (nt) ) then
|
||||
ps = '(US)'
|
||||
write (6, '(/5x,"pseudo",i2," is ",a2, &
|
||||
& 1x,a5," zval =",f5.1," lmax=",i2, &
|
||||
& " lloc=",i2)') nt, psd (nt) , ps, zp (nt) , lmax (nt) &
|
||||
&, lloc (nt)
|
||||
write (6, '(5x,"Version ", 3i3, " of US pseudo code")') &
|
||||
(iver (i, nt) , i = 1, 3)
|
||||
write (6, '(/,5x,"Using log mesh of ", i3, " points",/)') &
|
||||
mesh (nt)
|
||||
write (6, '(5x,"The pseudopotential has ",i2, &
|
||||
& " beta functions with: ",/)') nbeta (nt)
|
||||
do ib = 1, nbeta (nt)
|
||||
write (6, '(15x," l(",i1,") = ",i3)') ib, lll (ib, nt)
|
||||
|
||||
enddo
|
||||
write (6, '(/,5x,"Q(r) pseudized with ", &
|
||||
& i2," coefficients, rinner = ",3f8.3, /, &
|
||||
& 58x,2f8.3)') nqf (nt) , (rinner (i, nt) , i = 1, nqlc ( &
|
||||
&nt) )
|
||||
else
|
||||
if (nlc (nt) .eq.1.and.nnl (nt) .eq.1) then
|
||||
ps = '(vbc)'
|
||||
elseif (nlc (nt) .eq.2.and.nnl (nt) .eq.3) then
|
||||
ps = '(bhs)'
|
||||
elseif (nlc (nt) .eq.1.and.nnl (nt) .eq.3) then
|
||||
ps = '(our)'
|
||||
else
|
||||
ps = ' '
|
||||
|
||||
endif
|
||||
|
||||
write (6, '(/5x,"pseudo",i2," is ",a2, &
|
||||
& 1x,a5," zval =",f5.1," lmax=",i2, &
|
||||
& " lloc=",i2)') nt, psd (nt) , ps, zp (nt) , lmax (nt) &
|
||||
&, lloc (nt)
|
||||
if (numeric (nt) ) then
|
||||
write (6, '(5x,"(in numerical form: ",i3, &
|
||||
&" grid points",", xmin = ",f5.2,", dx = ", &
|
||||
&f6.4,")")') mesh (nt) , xmin (nt) , dx (nt)
|
||||
else
|
||||
write (6, '(/14x,"i=",7x,"1",13x,"2",10x,"3")')
|
||||
write (6, '(/5x,"core")')
|
||||
write (6, '(5x,"alpha =",4x,3g13.5)') (alpc (i, nt) , i = &
|
||||
1, 2)
|
||||
write (6, '(5x,"a(i) =",4x,3g13.5)') (cc (i, nt) , i = 1, 2)
|
||||
do l = 0, lmax (nt)
|
||||
write (6, '(/5x,"l = ",i2)') l
|
||||
write (6, '(5x,"alpha =",4x,3g13.5)') (alps (i, l, nt) , &
|
||||
i = 1, 3)
|
||||
write (6, '(5x,"a(i) =",4x,3g13.5)') (aps (i, l, nt) , i = 1, &
|
||||
&3)
|
||||
write (6, '(5x,"a(i+3)=",4x,3g13.5)') (aps (i, l, nt) , i &
|
||||
= 4, 6)
|
||||
enddo
|
||||
if (nlcc (nt) ) write (6, 200) a_nlcc (nt), b_nlcc (nt), &
|
||||
alpha_nlcc (nt)
|
||||
200 format(/5x,'nonlinear core correction: ', &
|
||||
& 'rho(r) = ( a + b r^2) exp(-alpha r^2)', &
|
||||
& /,5x,'a =',4x,g11.5, &
|
||||
& /,5x,'b =',4x,g11.5, &
|
||||
& /,5x,'alpha=',4x,g11.5)
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
!
|
||||
! Representation for q=0
|
||||
!
|
||||
if (.not.lgamma) then
|
||||
write (6, '(//5x,"Atomic displacements (q=0 Repr):")')
|
||||
write (6, '(5x,"There are ",i5, &
|
||||
& " irreducible representations")') nirrg0
|
||||
imode0 = 0
|
||||
do irr = 1, nirrg0
|
||||
write (6, '(/, 5x,"Representation ",i5,i7, &
|
||||
& " modes - To be done")') irr, npertg0 (irr)
|
||||
if (iverbosity.eq.1) then
|
||||
|
||||
write (6, '(5x,"Phonon polarizations are as follows:",/)')
|
||||
if (npertg0 (irr) .eq.1) then
|
||||
write (6, '(20x," mode # ",i3)') imode0 + 1
|
||||
write (6, '(20x," (",2f10.5," ) ")') ( (ug0 (mu, nu) , nu = &
|
||||
& imode0 + 1, imode0 + npertg0 (irr) ) , mu = 1, 3 * nat)
|
||||
elseif (npertg0 (irr) .eq.2) then
|
||||
write (6, '(2(10x," mode # ",i3,16x))') imode0 + 1, &
|
||||
imode0 + 2
|
||||
write (6, '(2(10x," (",2f10.5," ) "))') ( (ug0 (mu, nu),&
|
||||
nu = imode0 + 1, imode0 + npertg0 (irr) ) , mu = 1, 3 * nat)
|
||||
else
|
||||
write (6, '(4x,3(" mode # ",i3,13x))') imode0 + 1, &
|
||||
imode0 + 2, imode0 + 3
|
||||
write (6, '((5x,3("(",2f10.5," ) ")))') ( (ug0 (mu, &
|
||||
nu) , nu = imode0 + 1, imode0 + npertg0 (irr) ) , mu = 1, &
|
||||
3 * nat)
|
||||
endif
|
||||
imode0 = imode0 + npertg0 (irr)
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
!
|
||||
! Representation for a generic q
|
||||
!
|
||||
write (6, '(//5x,"Atomic displacements:")')
|
||||
write (6, '(5x,"There are ",i5," irreducible representations") &
|
||||
&') nirr
|
||||
imode0 = 0
|
||||
do irr = 1, nirr
|
||||
write (6, '(/, 5x,"Representation ",i5,i7, &
|
||||
& " modes - To be done")') irr, npert (irr)
|
||||
if (iverbosity.eq.1) then
|
||||
|
||||
write (6, '(5x,"Phonon polarizations are as follows:",/)')
|
||||
if (npert (irr) .eq.1) then
|
||||
write (6, '(20x," mode # ",i3)') imode0 + 1
|
||||
write (6, '(20x," (",2f10.5," ) ")') ( (u (mu, nu) , nu = &
|
||||
imode0 + 1, imode0 + npert (irr) ) , mu = 1, 3 * nat)
|
||||
elseif (npert (irr) .eq.2) then
|
||||
write (6, '(2(10x," mode # ",i3,16x))') imode0 + 1, &
|
||||
imode0 + 2
|
||||
write (6, '(2(10x," (",2f10.5," ) "))') ( (u (mu, nu) , &
|
||||
nu = imode0 + 1, imode0 + npert (irr) ) , mu = 1, 3 * nat)
|
||||
else
|
||||
write (6, '(4x,3(" mode # ",i3,13x))') imode0 + 1, imode0 &
|
||||
+ 2, imode0 + 3
|
||||
write (6, '((5x,3("(",2f10.5," ) ")))') ( (u (mu, nu) , &
|
||||
nu = imode0 + 1, imode0 + npert (irr) ) , mu = 1, 3 * nat)
|
||||
endif
|
||||
imode0 = imode0 + npert (irr)
|
||||
endif
|
||||
|
||||
enddo
|
||||
write (6, '(/20x,"** Complex Version **")')
|
||||
#ifdef FLUSH
|
||||
call flush (6)
|
||||
#endif
|
||||
return
|
||||
end subroutine d3_summary
|
||||
|
|
@ -0,0 +1,140 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine d3_symdyn (d3dyn, u, ug0, xq, s, invs, rtau, irt, irgq, &
|
||||
at, bg, nsymq, nat, irotmq, minus_q, npert_i, npert_f)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! This routine symmetrize the dynamical matrix written in the basis
|
||||
! of the modes
|
||||
!
|
||||
!
|
||||
#include "machine.h"
|
||||
use allocate
|
||||
implicit none
|
||||
integer :: nat, s (3, 3, 48), irt (48, nat), irgq (48), invs (48), &
|
||||
nsymq, npert_i, npert_f, irotmq
|
||||
! input: the number of atoms
|
||||
! input: the symmetry matrices
|
||||
! input: the rotated of each atom
|
||||
! input: the small group of q
|
||||
! input: the inverse of each matrix
|
||||
! input: the order of the small gro
|
||||
! input: the symmetry q -> -q+G
|
||||
|
||||
real (8) :: xq (3), rtau (3, 48, nat), at (3, 3), bg (3, 3)
|
||||
! input: the coordinates of q
|
||||
! input: the R associated at each r
|
||||
! input: direct lattice vectors
|
||||
! input: reciprocal lattice vectors
|
||||
|
||||
logical :: minus_q
|
||||
! input: if true symmetry sends q->
|
||||
|
||||
complex (8) :: d3dyn (3 * nat, 3 * nat, 3 * nat), &
|
||||
ug0 (3 * nat, 3 * nat), u (3 * nat, 3 * nat)
|
||||
! inp/out: matrix to symmetr
|
||||
! input: the q=0 patterns
|
||||
! input: the patterns
|
||||
|
||||
integer :: i, j, i1, icart, jcart, kcart, na, nb, nc, mu, nu, om
|
||||
! counter on modes
|
||||
! counter on modes
|
||||
! counter on modes
|
||||
! counter on cartesian coordinates
|
||||
! counter on cartesian coordinates
|
||||
! counter on cartesian coordinates
|
||||
! counter on atoms
|
||||
! counter on atoms
|
||||
! counter on atoms
|
||||
! counter on modes
|
||||
! counter on modes
|
||||
! counter on modes
|
||||
|
||||
complex (8) :: work, wrk (3, 3)
|
||||
! auxiliary variables
|
||||
complex (8), pointer :: phi (:,:,:,:,:,:)
|
||||
! the dynamical matrix
|
||||
|
||||
call mallocate (phi, 3, 3, 3, nat, nat, nat)
|
||||
!
|
||||
! First we transform in the cartesian coordinates
|
||||
!
|
||||
call setv (2 * 27 * nat * nat * nat, 0.d0, phi, 1)
|
||||
do i1 = npert_i, npert_f
|
||||
nc = (i1 - 1) / 3 + 1
|
||||
kcart = i1 - 3 * (nc - 1)
|
||||
do i = 1, 3 * nat
|
||||
na = (i - 1) / 3 + 1
|
||||
icart = i - 3 * (na - 1)
|
||||
do j = 1, 3 * nat
|
||||
nb = (j - 1) / 3 + 1
|
||||
jcart = j - 3 * (nb - 1)
|
||||
work = (0.d0, 0.d0)
|
||||
do om = 1, 3 * nat
|
||||
do mu = 1, 3 * nat
|
||||
do nu = 1, 3 * nat
|
||||
work = work + conjg (ug0 (i1, om) ) * u (i, mu) * d3dyn (om, mu, &
|
||||
nu) * conjg (u (j, nu) )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
phi (kcart, icart, jcart, nc, na, nb) = work
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call poolreduce (2 * 27 * nat * nat * nat, phi)
|
||||
#endif
|
||||
!
|
||||
! Then we transform to the crystal axis
|
||||
!
|
||||
do nc = 1, nat
|
||||
do na = 1, nat
|
||||
do nb = 1, nat
|
||||
call trntnsc_3 (phi (1, 1, 1, nc, na, nb), at, bg, - 1)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!
|
||||
! And we symmetrize in this basis
|
||||
!
|
||||
call d3_symdynph (xq, phi, s, invs, rtau, irt, irgq, nsymq, nat, &
|
||||
irotmq, minus_q)
|
||||
!
|
||||
! Back to cartesian coordinates
|
||||
!
|
||||
do nc = 1, nat
|
||||
do na = 1, nat
|
||||
do nb = 1, nat
|
||||
call trntnsc_3 (phi (1, 1, 1, nc, na, nb), at, bg, + 1)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!
|
||||
! rewrite the dynamical matrix on the array dyn with dimension 3nat x 3
|
||||
!
|
||||
do i1 = 1, 3 * nat
|
||||
nc = (i1 - 1) / 3 + 1
|
||||
kcart = i1 - 3 * (nc - 1)
|
||||
do i = 1, 3 * nat
|
||||
na = (i - 1) / 3 + 1
|
||||
icart = i - 3 * (na - 1)
|
||||
do j = 1, 3 * nat
|
||||
nb = (j - 1) / 3 + 1
|
||||
jcart = j - 3 * (nb - 1)
|
||||
d3dyn (i1, i, j) = phi (kcart, icart, jcart, nc, na, nb)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
call mfree (phi)
|
||||
|
||||
return
|
||||
|
||||
end subroutine d3_symdyn
|
||||
|
|
@ -0,0 +1,224 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine d3_symdynph (xq, phi, s, invs, rtau, irt, irgq, nsymq, &
|
||||
nat, irotmq, minus_q)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! This routine receives as input an unsymmetrized dynamical
|
||||
! matrix expressed on the crystal axes and imposes the symmetry
|
||||
! of the small group of q. Furthermore it imposes also the symmetry
|
||||
! q -> -q+G if present.
|
||||
!
|
||||
!
|
||||
#include "machine.h"
|
||||
use allocate
|
||||
implicit none
|
||||
!
|
||||
! The dummy variables
|
||||
!
|
||||
integer :: nat, s (3, 3, 48), irt (48, nat), irgq (48), invs (48), &
|
||||
nsymq, irotmq
|
||||
! input: the number of atoms
|
||||
! input: the symmetry matrices
|
||||
! input: the rotated of each vector
|
||||
! input: the small group of q
|
||||
! input: the inverse of each matrix
|
||||
! input: the order of the small gro
|
||||
! input: the rotation sending q ->
|
||||
real (8) :: xq (3), rtau (3, 48, nat)
|
||||
! input: the q point
|
||||
! input: the R associated at each t
|
||||
|
||||
logical :: minus_q
|
||||
! input: true if a symmetry q->-q+G
|
||||
complex (8) :: phi (3, 3, 3, nat, nat, nat)
|
||||
! inp/out: the matrix to symmetr
|
||||
!
|
||||
! One parameter
|
||||
!
|
||||
real (8) :: tpi
|
||||
parameter (tpi = 2.0d0 * 3.14159265358979d0)
|
||||
!
|
||||
! and the local variables
|
||||
!
|
||||
|
||||
integer :: isymq, sna, snb, snc, irot, na, nb, nc, ipol, jpol, &
|
||||
lpol, kpol, mpol, npol
|
||||
! counter on symmetries
|
||||
! the rotated of the a atom
|
||||
! the rotated of the b atom
|
||||
! the rotated of the b atom
|
||||
! counter on rotations
|
||||
! counter on atoms
|
||||
! counter on atoms
|
||||
! counter on atoms
|
||||
! counter on polarizations
|
||||
! counter on polarizations
|
||||
! counter on polarizations
|
||||
! counter on polarizations
|
||||
! counter on polarizations
|
||||
! counter on polarizations
|
||||
integer, pointer:: iflb (:,:,:)
|
||||
! used to account for symmetrized elements
|
||||
|
||||
real (8) :: arg
|
||||
! the argument of the phase
|
||||
|
||||
complex (8), pointer :: phip (:,:,:,:,:,:)
|
||||
complex (8) :: work (3, 3, 3), fase, faseq (48)
|
||||
! working space
|
||||
! the phase factor
|
||||
! the phases for each symmetry
|
||||
|
||||
!
|
||||
! We start by imposing hermiticity
|
||||
!
|
||||
do nc = 1, nat
|
||||
do na = 1, nat
|
||||
do nb = 1, nat
|
||||
do kpol = 1, 3
|
||||
do ipol = 1, 3
|
||||
do jpol = 1, 3
|
||||
phi (kpol, ipol, jpol, nc, na, nb) = 0.5d0 * (phi (kpol, ipol, &
|
||||
jpol, nc, na, nb) + conjg (phi (kpol, jpol, ipol, nc, nb, na) ) )
|
||||
phi (kpol, jpol, ipol, nc, nb, na) = conjg (phi (kpol, ipol, jpol, &
|
||||
nc, na, nb) )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!
|
||||
! If no other symmetry is present we quit here
|
||||
!
|
||||
|
||||
if ( (nsymq.eq.1) .and. (.not.minus_q) ) return
|
||||
call mallocate (phip, 3, 3, 3, nat, nat, nat)
|
||||
!
|
||||
! Then we impose the symmetry q -> -q+G if present
|
||||
!
|
||||
if (minus_q) then
|
||||
do nc = 1, nat
|
||||
do na = 1, nat
|
||||
do nb = 1, nat
|
||||
do mpol = 1, 3
|
||||
do ipol = 1, 3
|
||||
do jpol = 1, 3
|
||||
call setv (54, 0.d0, work, 1)
|
||||
snc = irt (irotmq, nc)
|
||||
sna = irt (irotmq, na)
|
||||
snb = irt (irotmq, nb)
|
||||
arg = 0.d0
|
||||
do kpol = 1, 3
|
||||
arg = arg + (xq (kpol) * (rtau (kpol, irotmq, na) - rtau (kpol, &
|
||||
irotmq, nb) ) )
|
||||
enddo
|
||||
arg = arg * tpi
|
||||
fase = DCMPLX (cos (arg), sin (arg) )
|
||||
do npol = 1, 3
|
||||
do kpol = 1, 3
|
||||
do lpol = 1, 3
|
||||
work (mpol, ipol, jpol) = work (mpol, ipol, jpol) + fase * s ( &
|
||||
ipol, kpol, irotmq) * s (jpol, lpol, irotmq) * s (mpol, npol, &
|
||||
irotmq) * phi (npol, kpol, lpol, snc, sna, snb)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
phip (mpol, ipol, jpol, nc, na, nb) = (phi (mpol, ipol, jpol, &
|
||||
nc, na, nb) + conjg (work (mpol, ipol, jpol) ) ) * 0.5d0
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
call ZCOPY (27 * nat * nat * nat, phip, 1, phi, 1)
|
||||
endif
|
||||
|
||||
call mfree (phip)
|
||||
!
|
||||
! Here we symmetrize with respect to the small group of q
|
||||
!
|
||||
if (nsymq.eq.1) return
|
||||
|
||||
call mallocate (iflb, nat, nat, nat)
|
||||
do na = 1, nat
|
||||
do nb = 1, nat
|
||||
do nc = 1, nat
|
||||
iflb (nc, na, nb) = 0
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
do nc = 1, nat
|
||||
do na = 1, nat
|
||||
do nb = 1, nat
|
||||
if (iflb (nc, na, nb) .eq.0) then
|
||||
call setv (54, 0.d0, work, 1)
|
||||
do isymq = 1, nsymq
|
||||
irot = irgq (isymq)
|
||||
snc = irt (irot, nc)
|
||||
sna = irt (irot, na)
|
||||
snb = irt (irot, nb)
|
||||
arg = 0.d0
|
||||
do ipol = 1, 3
|
||||
arg = arg + (xq (ipol) * (rtau (ipol, irot, na) - rtau (ipol, &
|
||||
irot, nb) ) )
|
||||
enddo
|
||||
arg = arg * tpi
|
||||
faseq (isymq) = DCMPLX (cos (arg), sin (arg) )
|
||||
do mpol = 1, 3
|
||||
do ipol = 1, 3
|
||||
do jpol = 1, 3
|
||||
do npol = 1, 3
|
||||
do kpol = 1, 3
|
||||
do lpol = 1, 3
|
||||
work (mpol, ipol, jpol) = work (mpol, ipol, jpol) + s (ipol, &
|
||||
kpol, irot) * s (jpol, lpol, irot) * s (mpol, npol, irot) &
|
||||
* phi (npol, kpol, lpol, snc, sna, snb) * faseq (isymq)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
do isymq = 1, nsymq
|
||||
irot = irgq (isymq)
|
||||
snc = irt (irot, nc)
|
||||
sna = irt (irot, na)
|
||||
snb = irt (irot, nb)
|
||||
do mpol = 1, 3
|
||||
do ipol = 1, 3
|
||||
do jpol = 1, 3
|
||||
phi (mpol, ipol, jpol, snc, sna, snb) = (0.d0, 0.d0)
|
||||
do npol = 1, 3
|
||||
do kpol = 1, 3
|
||||
do lpol = 1, 3
|
||||
phi (mpol, ipol, jpol, snc, sna, snb) = phi (mpol, ipol, jpol, &
|
||||
snc, sna, snb) + s (mpol, npol, invs (irot) ) * s (ipol, kpol, &
|
||||
invs (irot) ) * s (jpol, lpol, invs (irot) ) * work (npol, &
|
||||
kpol, lpol) * conjg (faseq (isymq) )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
iflb (snc, sna, snb) = 1
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
call DSCAL (54 * nat * nat * nat, 1.d0 / nsymq, phi, 1)
|
||||
call mfree (iflb)
|
||||
return
|
||||
end subroutine d3_symdynph
|
||||
|
|
@ -0,0 +1,266 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine d3_valence
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
use allocate
|
||||
implicit none
|
||||
integer :: ik, ikk, ikq, nu_i, nu_j, nu_k, ibnd, jbnd, kbnd, nrec
|
||||
|
||||
real (8) :: de1, de2, de3, wg1, wg2, wg3, wwg1, wwg2, d_dos, wrk, &
|
||||
wgauss, wga (nbnd), wgq (nbnd), w0gauss, w0g (nbnd), w1g (nbnd), &
|
||||
w_1gauss
|
||||
|
||||
complex (8) :: wrk1, aux (3 * nat)
|
||||
complex (8), pointer :: pdvp_i (:,:), pdvp_j (:,:), dpsidvpsi (:,:), &
|
||||
pdvp_k (:,:), aux1 (:,:,:), aux2 (:,:,:), aux3 (:,:,:), aux4 (:,:,:)
|
||||
|
||||
if (degauss.eq.0.d0) return
|
||||
call mallocate (pdvp_i, nbnd, nbnd)
|
||||
call mallocate (pdvp_j, nbnd, nbnd)
|
||||
call mallocate (pdvp_k, nbnd, nbnd)
|
||||
call mallocate (aux1 , 3 * nat, 3 * nat, 3 * nat)
|
||||
call mallocate (aux2 , 3 * nat, 3 * nat, 3 * nat)
|
||||
call mallocate (aux3 , 3 * nat, 3 * nat, 3 * nat)
|
||||
call mallocate (aux4 , 3 * nat, 3 * nat, 3 * nat)
|
||||
call mallocate (dpsidvpsi, nbnd, nbnd)
|
||||
|
||||
call setv (2 * 27 * nat * nat * nat, 0.d0, aux1, 1)
|
||||
call setv (2 * 27 * nat * nat * nat, 0.d0, aux2, 1)
|
||||
call setv (2 * 27 * nat * nat * nat, 0.d0, aux3, 1)
|
||||
call setv (2 * 27 * nat * nat * nat, 0.d0, aux4, 1)
|
||||
|
||||
call read_ef
|
||||
do ik = 1, nksq
|
||||
if (lgamma) then
|
||||
ikk = ik
|
||||
ikq = ik
|
||||
else
|
||||
ikk = 2 * ik - 1
|
||||
ikq = 2 * ik
|
||||
|
||||
endif
|
||||
do ibnd = 1, nbnd
|
||||
wga (ibnd) = wgauss ( (ef - et (ibnd, ikk) ) / degauss, ngauss)
|
||||
wgq (ibnd) = wgauss ( (ef - et (ibnd, ikq) ) / degauss, ngauss)
|
||||
w0g (ibnd) = w0gauss ( (ef - et (ibnd, ikk) ) / degauss, ngauss) &
|
||||
/ degauss
|
||||
w1g (ibnd) = w_1gauss ( (ef - et (ibnd, ikk) ) / degauss, ngauss) &
|
||||
/ (degauss**2)
|
||||
|
||||
enddo
|
||||
do nu_i = 1, 3 * nat
|
||||
if (q0mode (nu_i) ) then
|
||||
nrec = nu_i + (ik - 1) * 3 * nat
|
||||
|
||||
call davcio (pdvp_i, lrpdqvp, iupd0vp, nrec, - 1)
|
||||
do nu_j = 1, 3 * nat
|
||||
nrec = nu_j + (ik - 1) * 3 * nat
|
||||
|
||||
call davcio (pdvp_j, lrpdqvp, iupdqvp, nrec, - 1)
|
||||
do nu_k = 1, 3 * nat
|
||||
nrec = nu_k + (ik - 1) * 3 * nat
|
||||
|
||||
call davcio (pdvp_k, lrpdqvp, iupdqvp, nrec, - 1)
|
||||
do ibnd = 1, nbnd
|
||||
wg1 = wga (ibnd)
|
||||
|
||||
wwg1 = w0g (ibnd)
|
||||
do jbnd = 1, nbnd
|
||||
wg2 = wga (jbnd)
|
||||
|
||||
wwg2 = w0g (jbnd)
|
||||
de1 = et (ibnd, ikk) - et (jbnd, ikk)
|
||||
do kbnd = 1, nbnd
|
||||
wg3 = wgq (kbnd)
|
||||
de2 = et (jbnd, ikk) - et (kbnd, ikq)
|
||||
|
||||
de3 = et (kbnd, ikq) - et (ibnd, ikk)
|
||||
if (abs (de1) .lt.2.0d-5.and.abs (de2) .lt.2.0d-5.and.abs (de3) &
|
||||
.lt.2.0d-5) then
|
||||
wrk = 0.5d0 * w1g (ibnd)
|
||||
elseif (abs (de1) .lt.1.0d-5) then
|
||||
wrk = ( (wg1 - wg3) / de2 + wwg1) / de3
|
||||
elseif (abs (de2) .lt.1.0d-5) then
|
||||
wrk = ( (wg2 - wg1) / de3 + wwg2) / de1
|
||||
elseif (abs (de3) .lt.1.0d-5) then
|
||||
wrk = ( (wg3 - wg2) / de1 + wwg1) / de2
|
||||
else
|
||||
wrk = - (wg1 * de2 + wg2 * de3 + wg3 * de1) / (de1 * de2 * &
|
||||
de3)
|
||||
|
||||
endif
|
||||
aux1 (nu_i, nu_j, nu_k) = aux1 (nu_i, nu_j, nu_k) + 2.d0 * wrk &
|
||||
* wk (ikk) * pdvp_i (ibnd, jbnd) * conjg (pdvp_j (kbnd, jbnd) ) &
|
||||
* pdvp_k (kbnd, ibnd)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
|
||||
enddo
|
||||
do ik = 1, nksq
|
||||
if (lgamma) then
|
||||
ikk = ik
|
||||
ikq = ik
|
||||
else
|
||||
ikk = 2 * ik - 1
|
||||
ikq = 2 * ik
|
||||
|
||||
endif
|
||||
do nu_j = 1, 3 * nat
|
||||
nrec = nu_j + (ik - 1) * 3 * nat
|
||||
|
||||
call davcio (pdvp_j, lrpdqvp, iupdqvp, nrec, - 1)
|
||||
do nu_k = 1, 3 * nat
|
||||
nrec = nu_k + (ik - 1) * 3 * nat
|
||||
|
||||
call davcio (pdvp_k, lrpdqvp, iupdqvp, nrec, - 1)
|
||||
nrec = nu_j + (nu_k - 1) * 3 * nat + (ik - 1) * 9 * nat * nat
|
||||
|
||||
call davcio (dpsidvpsi, lrdpdvp, iudpdvp_1, nrec, - 1)
|
||||
do nu_i = 1, 3 * nat
|
||||
|
||||
if (q0mode (nu_i) .or.lgamma) then
|
||||
wrk1 = DCMPLX (0.d0, 0.d0)
|
||||
do ibnd = 1, nbnd
|
||||
do jbnd = 1, nbnd
|
||||
de1 = et (ibnd, ikk) - et (jbnd, ikq)
|
||||
if (abs (de1) .gt.1.0d-5) then
|
||||
wrk = (w0gauss ( (ef - et (ibnd, ikk) ) / degauss, ngauss) &
|
||||
/ degauss - w0gauss ( (ef - et (jbnd, ikq) ) / degauss, &
|
||||
ngauss) / degauss) / de1
|
||||
else
|
||||
wrk = - w_1gauss ( (ef - et (ibnd, ikk) ) / degauss, ngauss) &
|
||||
/ (degauss**2)
|
||||
endif
|
||||
wrk1 = wrk1 + wk (ikk) * wrk * ef_sh (nu_i) * conjg (pdvp_j ( &
|
||||
jbnd, ibnd) ) * pdvp_k (jbnd, ibnd)
|
||||
enddo
|
||||
|
||||
enddo
|
||||
aux2 (nu_i, nu_j, nu_k) = aux2 (nu_i, nu_j, nu_k) + wrk1
|
||||
if (lgamma) then
|
||||
aux2 (nu_k, nu_i, nu_j) = aux2 (nu_k, nu_i, nu_j) + wrk1
|
||||
aux2 (nu_j, nu_k, nu_i) = aux2 (nu_j, nu_k, nu_i) + wrk1
|
||||
|
||||
endif
|
||||
wrk1 = DCMPLX (0.d0, 0.d0)
|
||||
do ibnd = 1, nbnd
|
||||
wrk1 = wrk1 + wk (ikk) * ef_sh (nu_i) * dpsidvpsi (ibnd, ibnd) &
|
||||
* w0gauss ( (ef - et (ibnd, ikk) ) / degauss, ngauss) / &
|
||||
degauss
|
||||
enddo
|
||||
aux2 (nu_i, nu_j, nu_k) = aux2 (nu_i, nu_j, nu_k) + wrk1
|
||||
aux2 (nu_i, nu_k, nu_j) = aux2 (nu_i, nu_k, nu_j) + conjg ( &
|
||||
wrk1)
|
||||
if (lgamma) then
|
||||
aux2 (nu_k, nu_i, nu_j) = aux2 (nu_k, nu_i, nu_j) + wrk1
|
||||
aux2 (nu_j, nu_i, nu_k) = aux2 (nu_j, nu_i, nu_k) + conjg ( &
|
||||
wrk1)
|
||||
aux2 (nu_j, nu_k, nu_i) = aux2 (nu_j, nu_k, nu_i) + wrk1
|
||||
aux2 (nu_k, nu_j, nu_i) = aux2 (nu_k, nu_j, nu_i) + conjg ( &
|
||||
wrk1)
|
||||
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
if (lgamma) then
|
||||
do nu_i = 1, 3 * nat
|
||||
if (.not.q0mode (nu_i) ) then
|
||||
do nu_j = 1, 3 * nat
|
||||
do nu_k = 1, 3 * nat
|
||||
aux2 (nu_i, nu_j, nu_k) = DCMPLX (0.d0, 0.d0)
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
|
||||
endif
|
||||
if (lgamma) then
|
||||
d_dos = 0.d0
|
||||
call setv (6 * nat, 0.d0, aux, 1)
|
||||
do ik = 1, nksq
|
||||
ikk = ik
|
||||
do ibnd = 1, nbnd
|
||||
d_dos = d_dos + wk (ikk) * w_1gauss ( (ef - et (ibnd, ikk) ) &
|
||||
/ degauss, ngauss) / (degauss**2)
|
||||
enddo
|
||||
do nu_i = 1, 3 * nat
|
||||
nrec = nu_i + (ik - 1) * 3 * nat
|
||||
call davcio (pdvp_i, lrpdqvp, iupd0vp, nrec, - 1)
|
||||
do ibnd = 1, nbnd
|
||||
aux (nu_i) = aux (nu_i) + pdvp_i (ibnd, ibnd) * wk (ikk) &
|
||||
* w_1gauss ( (ef - et (ibnd, ikk) ) / degauss, ngauss) / &
|
||||
(degauss**2)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
do nu_i = 1, 3 * nat
|
||||
if (q0mode (nu_i) ) then
|
||||
do nu_j = 1, 3 * nat
|
||||
do nu_k = 1, 3 * nat
|
||||
aux3 (nu_i, nu_j, nu_k) = aux3 (nu_i, nu_j, nu_k) + ef_sh ( &
|
||||
nu_i) * ef_sh (nu_j) * aux (nu_k) + ef_sh (nu_j) * ef_sh ( &
|
||||
nu_k) * aux (nu_i) + ef_sh (nu_k) * ef_sh (nu_i) * aux ( &
|
||||
nu_j)
|
||||
aux4 (nu_i, nu_j, nu_k) = aux4 (nu_i, nu_j, nu_k) - ef_sh ( &
|
||||
nu_i) * ef_sh (nu_j) * ef_sh (nu_k) * d_dos
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
#ifdef PARA
|
||||
call poolreduce (2 * 27 * nat * nat * nat, aux1)
|
||||
call poolreduce (2 * 27 * nat * nat * nat, aux2)
|
||||
if (lgamma) then
|
||||
call poolreduce (2 * 27 * nat * nat * nat, aux3)
|
||||
call poolreduce (2 * 27 * nat * nat * nat, aux4)
|
||||
|
||||
endif
|
||||
#endif
|
||||
call DAXPY (2 * 27 * nat * nat * nat, 1.d0, aux1, 1, d3dyn, 1)
|
||||
call DAXPY (2 * 27 * nat * nat * nat, 1.d0, aux2, 1, d3dyn, 1)
|
||||
call DAXPY (2 * 27 * nat * nat * nat, 1.d0, aux3, 1, d3dyn, 1)
|
||||
|
||||
call DAXPY (2 * 27 * nat * nat * nat, 1.d0, aux4, 1, d3dyn, 1)
|
||||
call DAXPY (2 * 27 * nat * nat * nat, 1.d0, aux1, 1, d3dyn_aux7, &
|
||||
1)
|
||||
call DAXPY (2 * 27 * nat * nat * nat, 1.d0, aux2, 1, d3dyn_aux7, &
|
||||
1)
|
||||
call DAXPY (2 * 27 * nat * nat * nat, 1.d0, aux3, 1, d3dyn_aux7, &
|
||||
1)
|
||||
|
||||
call DAXPY (2 * 27 * nat * nat * nat, 1.d0, aux4, 1, d3dyn_aux7, &
|
||||
1)
|
||||
call mfree (pdvp_i)
|
||||
call mfree (pdvp_j)
|
||||
call mfree (pdvp_k)
|
||||
call mfree (aux1)
|
||||
call mfree (aux2)
|
||||
call mfree (aux3)
|
||||
call mfree (aux4)
|
||||
call mfree (dpsidvpsi)
|
||||
|
||||
return
|
||||
end subroutine d3_valence
|
||||
|
|
@ -0,0 +1,126 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
! Common for d3toten
|
||||
!
|
||||
module g0aux
|
||||
use parameters, only: DP
|
||||
real(kind=DP), pointer:: vlocg0(:,:) ! local potential at q+G for q=0
|
||||
complex(kind=DP), pointer:: d0rc(:,:)! contain the rhoc for q=0
|
||||
complex(kind=DP), pointer:: vkb0 (:,:) ! contains beta functions at q=0
|
||||
end module g0aux
|
||||
!
|
||||
! the units of the files and the record lengths
|
||||
!
|
||||
module units_d3
|
||||
integer:: iudqwf, &! the unit with | Pc d/du(q) psi_{k+q} >
|
||||
iud0qwf, &! the unit with | Pc d/du(0) psi_{k+q} >
|
||||
iud0rho ! the unit where q=0 delta rho is written
|
||||
end module units_d3
|
||||
!
|
||||
! the name of the files
|
||||
!
|
||||
module d0rho
|
||||
character(len=30) :: fild0rho
|
||||
end module d0rho
|
||||
!
|
||||
! the variable needed to describe the patterns when q=0
|
||||
!
|
||||
module modesg0
|
||||
use parameters, only: DP
|
||||
integer :: nsymg0, &! the number of symmetries of the crystal
|
||||
nirrg0 ! the number of irreducible representation
|
||||
!
|
||||
integer, pointer:: npertg0(:) ! the number of perturbations per IR
|
||||
complex(kind=DP), pointer:: ug0(:,:), tg0(:,:,:,:)
|
||||
! ug0: transformation modes patterns
|
||||
! tg0: the symmetry in the base of pattern (q=0)
|
||||
end module modesg0
|
||||
!
|
||||
! third order dynamical matrices (auxiliary)
|
||||
!
|
||||
module d3aux
|
||||
use parameters, only: DP
|
||||
complex(kind=DP), pointer :: &
|
||||
d3dyn_aux1(:,:,:), d3dyn_aux2(:,:,:), d3dyn_aux3(:,:,:), &
|
||||
d3dyn_aux4(:,:,:), d3dyn_aux5(:,:,:), d3dyn_aux6(:,:,:), &
|
||||
d3dyn_aux7(:,:,:), d3dyn_aux8(:,:,:), d3dyn_aux9(:,:,:)
|
||||
end module d3aux
|
||||
!
|
||||
! third order dynamical matrix
|
||||
!
|
||||
module thirdorder
|
||||
use parameters, only: DP
|
||||
complex(kind=DP), pointer :: d3dyn(:,:,:)
|
||||
! third order dynamical matrix
|
||||
complex(kind=DP), pointer :: psidqvpsi(:,:)
|
||||
! <psi| dqV |psi>
|
||||
real(kind=DP) :: ethr_ph ! eigenvalues convergence threshold
|
||||
real(kind=DP), pointer :: ef_sh(:) ! E_Fermi shift
|
||||
integer :: istop
|
||||
logical :: wraux, recv
|
||||
end module thirdorder
|
||||
!
|
||||
! test variables
|
||||
!
|
||||
module testvar
|
||||
use parameters, only: DP
|
||||
real(kind=DP) :: testreal(50)
|
||||
integer :: testint(50)
|
||||
logical :: testflag(50)
|
||||
end module testvar
|
||||
!
|
||||
! the units of the files and the record lengths
|
||||
!
|
||||
module units_d3ph
|
||||
integer :: &
|
||||
iuef, &! unit with ef_sh
|
||||
iupdqvp, &! unit with <psi| dqV |psi>
|
||||
iupd0vp, &! unit with <psi| d0V |psi>
|
||||
lrpdqvp, &! length of <psi| dV |psi>
|
||||
iudpdvp_1, &! unit with <dqpsi| dqV |psi>
|
||||
iudpdvp_2, &! unit with <dqpsi| d0V |psi>
|
||||
iudpdvp_3, &! unit with <d0psi| dqV |psi>
|
||||
lrdpdvp ! length of <dpsi | dV |psi> records
|
||||
end module units_d3ph
|
||||
!
|
||||
! In the parallel version of the program some loop on perturbations
|
||||
! may be split betweem pools. npert_i and npert_f are the initial
|
||||
! and final value for a counter on the modes to be split among pools
|
||||
!
|
||||
module npert
|
||||
integer :: &
|
||||
npert_i, &! starting value for the mode counter
|
||||
npert_f ! final value for the mode counter
|
||||
end module npert
|
||||
!
|
||||
! Variables used for computing and writing only selected modes at q=0
|
||||
! --the first index of the dthird matrix--
|
||||
!
|
||||
module q0modes
|
||||
integer :: q0mode_todo(300) ! list of the q=0 modes to be computed
|
||||
!
|
||||
logical :: &
|
||||
q0mode(300), &! if .true. this mode is to be computed
|
||||
wrmode(300), &! if .true. this mode is to be written
|
||||
allmodes ! it is .true. if you are at gamma and you
|
||||
! want to compute all the modes
|
||||
end module q0modes
|
||||
|
||||
module d3com
|
||||
use g0aux
|
||||
use units_d3
|
||||
use units_d3ph
|
||||
use d0rho
|
||||
use d3aux
|
||||
use thirdorder
|
||||
use testvar
|
||||
use modesg0
|
||||
use npert
|
||||
use q0modes
|
||||
end module d3com
|
||||
|
|
@ -0,0 +1,265 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
|
||||
subroutine d3dyn_cc
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! It calculates contribution due to non-linear-core-correction
|
||||
! The variation of the density with respect to the perturbation must
|
||||
! be corrected before calling this routine:
|
||||
! while reading the variation of the density on unit iudrho and iud0rho
|
||||
! it assumes it is the total density, i.e. sum of valence + core.
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
use allocate
|
||||
implicit none
|
||||
integer :: na, nta, ig, ir, i_cart, j_cart, k_cart, na_i, na_j, &
|
||||
na_k, nu_i, nu_j, nu_k, na_icart, nb_jcart, nc_kcart
|
||||
|
||||
real (8) :: rhox, arhox, ex, ec, vx, vc, arg
|
||||
! the total charge in each point
|
||||
! the absolute value of the charge
|
||||
! local exchange energy
|
||||
! local correlation energy
|
||||
! local exchange potential
|
||||
! local correlation potential
|
||||
! argument of the phase factor
|
||||
|
||||
complex (8) :: exc, work, work0, work1, work2, work3
|
||||
complex (8), pointer :: drc_exp (:,:), aux (:), d3dyn0 (:,:,:), &
|
||||
d3dyn1 (:,:,:), d3dyn2 (:,:,:), d3dyn3 (:,:,:), d3dyn4 (:,:,:)
|
||||
|
||||
if (.not.nlcc_any) return
|
||||
call mallocate (aux , nrxx)
|
||||
call mallocate (drc_exp , ngm, nat)
|
||||
call mallocate (d3dyn0 , 3 * nat, 3 * nat, 3 * nat)
|
||||
call mallocate (d3dyn1 , 3 * nat, 3 * nat, 3 * nat)
|
||||
call mallocate (d3dyn2 , 3 * nat, 3 * nat, 3 * nat)
|
||||
call mallocate (d3dyn3 , 3 * nat, 3 * nat, 3 * nat)
|
||||
call mallocate (d3dyn4 , 3 * nat, 3 * nat, 3 * nat)
|
||||
|
||||
call setv (2 * 27 * nat * nat * nat, 0.d0, d3dyn0, 1)
|
||||
call setv (2 * 27 * nat * nat * nat, 0.d0, d3dyn1, 1)
|
||||
call setv (2 * 27 * nat * nat * nat, 0.d0, d3dyn2, 1)
|
||||
call setv (2 * 27 * nat * nat * nat, 0.d0, d3dyn3, 1)
|
||||
call setv (2 * ngm * nat, 0.d0, drc_exp, 1)
|
||||
|
||||
do na = 1, nat
|
||||
nta = ityp (na)
|
||||
do ig = 1, ngm
|
||||
arg = - tpi * (g (1, ig) * tau (1, na) + g (2, ig) * tau (2, na) &
|
||||
+ g (3, ig) * tau (3, na) )
|
||||
exc = DCMPLX (cos (arg), sin (arg) )
|
||||
drc_exp (ig, na) = d0rc (ig, nta) * exc
|
||||
enddo
|
||||
enddo
|
||||
call setv (2 * nrxx, 0.d0, aux, 1)
|
||||
do ir = 1, nrxx
|
||||
rhox = rho (ir, 1) + rho_core (ir)
|
||||
arhox = abs (rhox)
|
||||
if (arhox.gt.1.0e-30) then
|
||||
call xc (arhox, ex, ec, vx, vc)
|
||||
aux (ir) = DCMPLX (e2 * (vx + vc), 0.d0)
|
||||
endif
|
||||
enddo
|
||||
|
||||
call cft3 (aux, nr1, nr2, nr3, nrx1, nrx2, nrx3, - 1)
|
||||
do na_i = npert_i, npert_f
|
||||
na = (na_i - 1) / 3 + 1
|
||||
i_cart = na_i - 3 * (na - 1)
|
||||
do j_cart = 1, 3
|
||||
na_j = j_cart + 3 * (na - 1)
|
||||
do k_cart = 1, 3
|
||||
|
||||
na_k = k_cart + 3 * (na - 1)
|
||||
work = DCMPLX (0.d0, 0.d0)
|
||||
do ig = 1, ngm
|
||||
work = work + DCMPLX (0.d0, 1.d0) * g (i_cart, ig) * g (j_cart, ig) &
|
||||
* g (k_cart, ig) * conjg (aux (nl (ig) ) ) * drc_exp (ig, na)
|
||||
|
||||
enddo
|
||||
|
||||
d3dyn0 (na_i, na_j, na_k) = work * omega * tpiba2 * tpiba
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
#ifdef PARA
|
||||
do nu_i = 1, 3 * nat
|
||||
call davcio_drho (aux, lrdrho, iud0rho, nu_i, - 1)
|
||||
|
||||
enddo
|
||||
do nu_i = 1, npert_i - 1
|
||||
call davcio_drho (aux, lrdrho, iud0rho, nu_i, - 1)
|
||||
enddo
|
||||
#endif
|
||||
do nu_i = npert_i, npert_f
|
||||
call davcio_drho (aux, lrdrho, iud0rho, nu_i, - 1)
|
||||
do ir = 1, nrxx
|
||||
aux (ir) = aux (ir) * dmuxc (ir, 1, 1)
|
||||
enddo
|
||||
|
||||
call cft3 (aux, nr1, nr2, nr3, nrx1, nrx2, nrx3, - 1)
|
||||
do na = 1, nat
|
||||
do i_cart = 1, 3
|
||||
na_i = i_cart + 3 * (na - 1)
|
||||
do j_cart = 1, 3
|
||||
|
||||
na_j = j_cart + 3 * (na - 1)
|
||||
work = DCMPLX (0.d0, 0.d0)
|
||||
do ig = 1, ngm
|
||||
work = work - conjg (aux (nl (ig) ) ) * g (i_cart, ig) * g ( &
|
||||
j_cart, ig) * drc_exp (ig, na)
|
||||
|
||||
enddo
|
||||
|
||||
d3dyn1 (nu_i, na_i, na_j) = work * tpiba2 * omega
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
#ifdef PARA
|
||||
do nu_i = npert_f + 1, 3 * nat
|
||||
call davcio_drho (aux, lrdrho, iud0rho, nu_i, - 1)
|
||||
|
||||
enddo
|
||||
#endif
|
||||
call setv (2 * ngm * nat, 0.d0, drc_exp, 1)
|
||||
do na = 1, nat
|
||||
nta = ityp (na)
|
||||
do ig = 1, ngm
|
||||
arg = - tpi * ( (g (1, ig) + xq (1) ) * tau (1, na) + (g (2, ig) &
|
||||
+ xq (2) ) * tau (2, na) + (g (3, ig) + xq (3) ) * tau (3, na) )
|
||||
exc = DCMPLX (cos (arg), sin (arg) )
|
||||
drc_exp (ig, na) = drc (ig, nta) * exc
|
||||
enddo
|
||||
|
||||
enddo
|
||||
#ifdef PARA
|
||||
do nu_i = 1, 3 * nat
|
||||
call davcio_drho (aux, lrdrho, iudrho, nu_i, - 1)
|
||||
|
||||
enddo
|
||||
do nu_i = 1, npert_i - 1
|
||||
call davcio_drho (aux, lrdrho, iudrho, nu_i, - 1)
|
||||
enddo
|
||||
#endif
|
||||
do nu_i = npert_i, npert_f
|
||||
call davcio_drho (aux, lrdrho, iudrho, nu_i, - 1)
|
||||
do ir = 1, nrxx
|
||||
aux (ir) = aux (ir) * dmuxc (ir, 1, 1)
|
||||
enddo
|
||||
|
||||
call cft3 (aux, nr1, nr2, nr3, nrx1, nrx2, nrx3, - 1)
|
||||
do na = 1, nat
|
||||
do i_cart = 1, 3
|
||||
na_i = i_cart + 3 * (na - 1)
|
||||
do j_cart = 1, 3
|
||||
|
||||
na_j = j_cart + 3 * (na - 1)
|
||||
work = DCMPLX (0.d0, 0.d0)
|
||||
do ig = 1, ngm
|
||||
work = work - conjg (aux (nl (ig) ) ) * drc_exp (ig, na) * &
|
||||
(g (i_cart, ig) + xq (i_cart) ) * (g (j_cart, ig) + xq (j_cart) )
|
||||
|
||||
enddo
|
||||
d3dyn2 (na_i, nu_i, na_j) = work * omega * tpiba2
|
||||
d3dyn3 (na_i, na_j, nu_i) = conjg (work) * omega * tpiba2
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
#ifdef PARA
|
||||
do nu_i = npert_f + 1, 3 * nat
|
||||
call davcio_drho (aux, lrdrho, iudrho, nu_i, - 1)
|
||||
|
||||
enddo
|
||||
call reduce (2 * 27 * nat * nat * nat, d3dyn0)
|
||||
call reduce (2 * 27 * nat * nat * nat, d3dyn1)
|
||||
call reduce (2 * 27 * nat * nat * nat, d3dyn2)
|
||||
|
||||
call reduce (2 * 27 * nat * nat * nat, d3dyn3)
|
||||
call poolreduce (2 * 27 * nat * nat * nat, d3dyn0)
|
||||
call poolreduce (2 * 27 * nat * nat * nat, d3dyn1)
|
||||
call poolreduce (2 * 27 * nat * nat * nat, d3dyn2)
|
||||
call poolreduce (2 * 27 * nat * nat * nat, d3dyn3)
|
||||
#endif
|
||||
!
|
||||
! The dynamical matrix was computed in cartesian axis and now we put
|
||||
! it on the basis of the modes
|
||||
!
|
||||
call setv (2 * 27 * nat * nat * nat, 0.d0, d3dyn4, 1)
|
||||
do nu_k = npert_i, npert_f
|
||||
if (q0mode (nu_k) ) then
|
||||
do nu_i = 1, 3 * nat
|
||||
|
||||
do nu_j = 1, 3 * nat
|
||||
work0 = (0.d0, 0.d0)
|
||||
do nc_kcart = 1, 3 * nat
|
||||
do na_icart = 1, 3 * nat
|
||||
do nb_jcart = 1, 3 * nat
|
||||
work0 = work0 + ug0 (nc_kcart, nu_k) * conjg (u (na_icart, &
|
||||
nu_i) ) * d3dyn0 (nc_kcart, na_icart, nb_jcart) * u (nb_jcart, &
|
||||
nu_j)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
work1 = (0.d0, 0.d0)
|
||||
do na_icart = 1, 3 * nat
|
||||
do nb_jcart = 1, 3 * nat
|
||||
work1 = work1 + conjg (u (na_icart, nu_i) ) * d3dyn1 (nu_k, &
|
||||
na_icart, nb_jcart) * u (nb_jcart, nu_j)
|
||||
enddo
|
||||
|
||||
enddo
|
||||
work2 = (0.d0, 0.d0)
|
||||
do nc_kcart = 1, 3 * nat
|
||||
do nb_jcart = 1, 3 * nat
|
||||
work2 = work2 + ug0 (nc_kcart, nu_k) * d3dyn2 (nc_kcart, nu_i, &
|
||||
nb_jcart) * u (nb_jcart, nu_j)
|
||||
enddo
|
||||
|
||||
enddo
|
||||
work3 = (0.d0, 0.d0)
|
||||
do nc_kcart = 1, 3 * nat
|
||||
do na_icart = 1, 3 * nat
|
||||
work3 = work3 + ug0 (nc_kcart, nu_k) * conjg (u (na_icart, &
|
||||
nu_i) ) * d3dyn3 (nc_kcart, na_icart, nu_j)
|
||||
enddo
|
||||
|
||||
enddo
|
||||
|
||||
d3dyn4 (nu_k, nu_i, nu_j) = work0 + work1 + work2 + work3
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call poolreduce (2 * 27 * nat * nat * nat, d3dyn4)
|
||||
#endif
|
||||
call DAXPY (2 * 27 * nat * nat * nat, 1.d0, d3dyn4, 1, d3dyn, 1)
|
||||
call ZCOPY (27 * nat * nat * nat, d3dyn4, 1, d3dyn_aux8, 1)
|
||||
|
||||
call mfree (aux)
|
||||
call mfree (drc_exp)
|
||||
call mfree (d3dyn0)
|
||||
call mfree (d3dyn1)
|
||||
call mfree (d3dyn2)
|
||||
call mfree (d3dyn3)
|
||||
call mfree (d3dyn4)
|
||||
|
||||
return
|
||||
end subroutine d3dyn_cc
|
||||
|
|
@ -0,0 +1,410 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
|
||||
subroutine d3ionq (nat, ntyp, ityp, zv, tau, alat, omega, q, at, &
|
||||
bg, g, gg, ngm, gcutm, nmodes, u, ug0, npert_i, npert_f, q0mode, &
|
||||
d3dyn)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! This routine computes the contribution of the ions to the
|
||||
! third order derivative of the total energy.
|
||||
! Both the real and reciprocal space terms
|
||||
! are included.
|
||||
!
|
||||
#include "machine.h"
|
||||
use allocate
|
||||
implicit none
|
||||
!
|
||||
! first the I/O variables
|
||||
!
|
||||
|
||||
integer :: nat, ntyp, ngm, ityp (nat), nmodes, npert_i, npert_f
|
||||
! input: the number of atoms
|
||||
! input: the number of types of atoms
|
||||
! input: the number of G vectors
|
||||
! input: the type of each atom
|
||||
! input: the number of modes
|
||||
|
||||
real (8) :: tau (3, nat), g (3, ngm), gg (ngm), zv (ntyp), &
|
||||
at (3, 3), bg (3, 3), omega, alat, gcutm, q (3)
|
||||
! input: the positions of the atoms
|
||||
! input: the coordinates of g vectors
|
||||
! input: the modulus of g vectors
|
||||
! input: the charge of each type
|
||||
! input: the direct lattice vectors
|
||||
! input: the reciprocal lattice vectors
|
||||
! input: the volume of the unit cell
|
||||
! input: the length scale
|
||||
! input: cut-off of g vectors
|
||||
! input: the q vector
|
||||
|
||||
complex (8) :: d3dyn (3 * nat, nmodes, 3 * nat), &
|
||||
u (3 * nat, nmodes), ug0 (3 * nat, nmodes)
|
||||
! output: derivative of the dyn. matrix
|
||||
! input: the pattern of the modes
|
||||
! input: the pattern of the modes (q=0)
|
||||
logical :: q0mode (300)
|
||||
! input: if .true. this mode is to be co
|
||||
!
|
||||
! three parameters
|
||||
!
|
||||
|
||||
integer :: mxr
|
||||
! the maximum number of r shells
|
||||
|
||||
real (8) :: e2, tpi
|
||||
! the electron charge
|
||||
! twp times pi
|
||||
|
||||
parameter (mxr = 100, e2 = 2.d0, tpi = 2.d0 * 3.14159265358979d0)
|
||||
|
||||
integer :: nu_i, nu_j, nu_k, na, nb, nta, ntb, ng, nrm, nr, icart, &
|
||||
jcart, kcart, na_icart, nb_jcart, nc_kcart
|
||||
! counter on the modes
|
||||
! counter on the modes
|
||||
! counter on the modes
|
||||
! counter on atoms
|
||||
! counter on atoms
|
||||
! the type of atom na
|
||||
! the type of atom nb
|
||||
! counter on G vectors
|
||||
! the real number of R shells
|
||||
! counter on r shells
|
||||
! counters on cartesian coordinates
|
||||
|
||||
real (8) :: arg, fpi, argq, tpiba2, tpiba3, alpha, erfc, &
|
||||
upperbound, charge, fac, gtq2, gt2, facq, d2f, d3f, rmax, r (3, &
|
||||
mxr), r2 (mxr), dtau (3), rr, ar, qrg
|
||||
! the argument of the phase
|
||||
! 4 times pi
|
||||
! the argument of the phase
|
||||
! two pi / alat
|
||||
! two pi / alat
|
||||
! the parameter alpha used to converge the summ
|
||||
! the erfc function
|
||||
! an estimate of the error in the real term
|
||||
! the total charge
|
||||
! the phase factor
|
||||
! the modulus of |q+G|
|
||||
! the modulus of G
|
||||
! a phase factor
|
||||
! derivatives for the real-space term
|
||||
! cutoff for real space term
|
||||
! the R_i-\tau_s-\tau_s' parameter
|
||||
! the square of this parameter
|
||||
|
||||
complex (8), pointer :: d3dy1 (:,:,:), d3dy2 (:,:,:), d3dy3 (:,:,:)
|
||||
! first term dynamical matrix
|
||||
! second term dynamical matrix
|
||||
! third term dynamical matrix
|
||||
complex (8) :: facg, fnat, work
|
||||
! a phase with g
|
||||
! a phase with the atoms
|
||||
! working space
|
||||
|
||||
call mallocate (d3dy1, 3 * nat, nmodes, 3 * nat)
|
||||
call mallocate (d3dy2, 3 * nat, nmodes, 3 * nat)
|
||||
call mallocate (d3dy3, 3 * nat, nmodes, 3 * nat)
|
||||
tpiba2 = (tpi / alat) **2
|
||||
tpiba3 = (tpi / alat) **3
|
||||
|
||||
fpi = 2.d0 * tpi
|
||||
charge = 0.d0
|
||||
do na = 1, nat
|
||||
charge = charge+zv (ityp (na) )
|
||||
enddo
|
||||
!
|
||||
! choose alpha in order to have convergence in the sum over G
|
||||
! upperbound is an upper bound for the error in the sum over G
|
||||
! estimated for the energy (empirical trust!)
|
||||
! (PG: appropriate for c60 = 0.2)
|
||||
!
|
||||
alpha = 2.9d0
|
||||
|
||||
11 alpha = alpha - 0.1d0
|
||||
|
||||
if (alpha.eq.0.d0) call error ('d3ion', 'optimal alpha not found', &
|
||||
1)
|
||||
|
||||
upperbound = 2.d0 * charge**2 * sqrt (2.d0 * alpha / tpi) * erfc ( &
|
||||
sqrt (tpiba2 * gcutm / 4.d0 / alpha) )
|
||||
|
||||
if (upperbound.gt.1.d-9) goto 11
|
||||
|
||||
write (6, '(/5x,"Alpha used in Ewald sum = ",f8.4)') alpha
|
||||
call setv (2 * 9 * nat * nat * nmodes, 0.d0, d3dy1, 1)
|
||||
call setv (2 * 9 * nat * nat * nmodes, 0.d0, d3dy2, 1)
|
||||
|
||||
call setv (2 * 9 * nat * nat * nmodes, 0.d0, d3dy3, 1)
|
||||
do ng = 1, ngm
|
||||
|
||||
gt2 = gg (ng) * tpiba2
|
||||
if (abs (gt2) .gt.1.d-8) then
|
||||
fac = e2 * fpi * tpiba3 / omega * exp ( - gt2 / alpha / 4.d0) &
|
||||
/ gt2
|
||||
else
|
||||
fac = 0.d0
|
||||
|
||||
endif
|
||||
do nu_i = npert_i, npert_f
|
||||
na = (nu_i - 1) / 3 + 1
|
||||
icart = nu_i - 3 * (na - 1)
|
||||
|
||||
nta = ityp (na)
|
||||
if (nu_i.eq.npert_i.or.icart.eq.1) then
|
||||
fnat = (0.d0, 0.d0)
|
||||
do nb = 1, nat
|
||||
ntb = ityp (nb)
|
||||
arg = tpi * ( (g (1, ng) ) * (tau (1, na) - tau (1, nb) ) &
|
||||
+ (g (2, ng) ) * (tau (2, na) - tau (2, nb) ) + (g (3, ng) ) &
|
||||
* (tau (3, na) - tau (3, nb) ) )
|
||||
facg = fac * zv (nta) * zv (ntb) * cmplx (sin (arg), 0.d0)
|
||||
fnat = fnat + facg
|
||||
enddo
|
||||
|
||||
endif
|
||||
do jcart = 1, 3
|
||||
nu_j = 3 * (na - 1) + jcart
|
||||
do kcart = 1, 3
|
||||
nu_k = 3 * (na - 1) + kcart
|
||||
d3dy1 (nu_i, nu_j, nu_k) = d3dy1 (nu_i, nu_j, nu_k) + fnat * g ( &
|
||||
icart, ng) * g (jcart, ng) * g (kcart, ng)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
do nu_i = npert_i, npert_f
|
||||
na = (nu_i - 1) / 3 + 1
|
||||
icart = nu_i - 3 * (na - 1)
|
||||
|
||||
nta = ityp (na)
|
||||
do nb = 1, nat
|
||||
ntb = ityp (nb)
|
||||
arg = tpi * ( (g (1, ng) ) * (tau (1, na) - tau (1, nb) ) + &
|
||||
(g (2, ng) ) * (tau (2, na) - tau (2, nb) ) + (g (3, ng) ) &
|
||||
* (tau (3, na) - tau (3, nb) ) )
|
||||
fnat = fac * zv (nta) * zv (ntb) * cmplx (sin (arg), 0.d0)
|
||||
do jcart = 1, 3
|
||||
nu_j = 3 * (nb - 1) + jcart
|
||||
do kcart = 1, 3
|
||||
nu_k = 3 * (nb - 1) + kcart
|
||||
d3dy1 (nu_i, nu_j, nu_k) = d3dy1 (nu_i, nu_j, nu_k) + fnat * g ( &
|
||||
icart, ng) * g (jcart, ng) * g (kcart, ng)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
gtq2 = ( (g (1, ng) + q (1) ) **2 + (g (2, ng) + q (2) ) **2 + &
|
||||
(g (3, ng) + q (3) ) **2) * tpiba2
|
||||
if (abs (gtq2) .gt.1.d-8) then
|
||||
facq = e2 * fpi * tpiba3 / omega * exp ( - gtq2 / alpha / 4.d0) &
|
||||
/ gtq2
|
||||
else
|
||||
facq = 0.d0
|
||||
|
||||
endif
|
||||
do nu_i = npert_i, npert_f
|
||||
na = (nu_i - 1) / 3 + 1
|
||||
icart = nu_i - 3 * (na - 1)
|
||||
|
||||
nta = ityp (na)
|
||||
do nb = 1, nat
|
||||
ntb = ityp (nb)
|
||||
argq = tpi * ( (g (1, ng) + q (1) ) * (tau (1, nb) - tau (1, na) ) &
|
||||
+ (g (2, ng) + q (2) ) * (tau (2, nb) - tau (2, na) ) + (g (3, ng) &
|
||||
+ q (3) ) * (tau (3, nb) - tau (3, na) ) )
|
||||
facg = facq * zv (nta) * zv (ntb) * cmplx ( - sin (argq), - cos ( &
|
||||
argq) )
|
||||
do jcart = 1, 3
|
||||
nu_j = 3 * (nb - 1) + jcart
|
||||
do kcart = 1, 3
|
||||
nu_k = 3 * (nb - 1) + kcart
|
||||
d3dy2 (nu_j, nu_i, nu_k) = d3dy2 (nu_j, nu_i, nu_k) + facg * &
|
||||
(q (icart) + g (icart, ng) ) * (q (jcart) + g (jcart, ng) ) &
|
||||
* (q (kcart) + g (kcart, ng) )
|
||||
d3dy3 (nu_j, nu_k, nu_i) = d3dy3 (nu_j, nu_k, nu_i) - conjg (facg) &
|
||||
* (q (icart) + g (icart, ng) ) * (q (jcart) + g (jcart, ng) ) &
|
||||
* (q (kcart) + g (kcart, ng) )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
enddo
|
||||
call DAXPY (2 * 27 * nat * nat * nat, 1.d0, d3dy2, 1, d3dy1, 1)
|
||||
call DAXPY (2 * 27 * nat * nat * nat, - 1.d0, d3dy3, 1, d3dy1, 1)
|
||||
!
|
||||
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
||||
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
||||
! uncomment next line if you want to skip real space term for testing pu
|
||||
! if (.true.) goto 100
|
||||
!
|
||||
! Then there is also a part in real space which is computed here.
|
||||
#ifdef PARA
|
||||
! ... only by the node that contains G=0
|
||||
!
|
||||
if (gg (1) .gt.1.d-8) goto 100
|
||||
#endif
|
||||
call setv (2 * 27 * nat * nat * nat, 0.d0, d3dy2, 1)
|
||||
!
|
||||
rmax = 5.d0 / sqrt (alpha) / alat
|
||||
!
|
||||
! with this choice terms up to ZiZj*erfc(5) are counted (erfc(5)=2x10^-1
|
||||
!
|
||||
do nu_i = npert_i, npert_f
|
||||
na = (nu_i - 1) / 3 + 1
|
||||
icart = nu_i - (na - 1) * 3
|
||||
nta = ityp (na)
|
||||
do nb = 1, nat
|
||||
ntb = ityp (nb)
|
||||
do jcart = 1, 3
|
||||
dtau (jcart) = tau (jcart, na) - tau (jcart, nb)
|
||||
enddo
|
||||
!
|
||||
! generates nearest-neighbors shells r(i)=R(i)-dtau(i)
|
||||
!
|
||||
call rgen (dtau, rmax, mxr, at, bg, r, r2, nrm)
|
||||
do nr = 1, nrm
|
||||
rr = sqrt (r2 (nr) ) * alat
|
||||
ar = sqrt (alpha) * rr
|
||||
qrg = tpi * (q (1) * (r (1, nr) + dtau (1) ) + q (2) * (r (2, nr) &
|
||||
+ dtau (2) ) + q (3) * (r (3, nr) + dtau (3) ) )
|
||||
d2f = (3.d0 * erfc (ar) + sqrt (8.d0 / tpi) * exp ( - ar**2) &
|
||||
* ar * (3.d0 + 2.d0 * ar**2) ) / rr**5
|
||||
|
||||
d3f = ( - 15.d0 * erfc (ar) - sqrt (8.d0 / tpi) * exp ( - ar**2) &
|
||||
* ar * (15.d0 + 10.d0 * ar**2 + 4.d0 * ar**4) ) / rr**7
|
||||
do jcart = 1, 3
|
||||
nu_j = (nb - 1) * 3 + jcart
|
||||
!
|
||||
! nc = nb case
|
||||
!
|
||||
do kcart = 1, 3
|
||||
nu_k = (nb - 1) * 3 + kcart
|
||||
d3dy2 (nu_i, nu_j, nu_k) = d3dy2 (nu_i, nu_j, nu_k) - e2 * zv ( &
|
||||
nta) * zv (ntb) * DCMPLX (cos (qrg), sin (qrg) ) * d3f * alat**3 * &
|
||||
r (icart, nr) * r (jcart, nr) * r (kcart, nr)
|
||||
if (icart.eq.jcart) d3dy2 (nu_i, nu_j, nu_k) = d3dy2 (nu_i, nu_j, &
|
||||
nu_k) - e2 * zv (nta) * zv (ntb) * DCMPLX (cos (qrg), sin (qrg) ) &
|
||||
* d2f * alat * r (kcart, nr)
|
||||
enddo
|
||||
nu_k = (nb - 1) * 3 + icart
|
||||
d3dy2 (nu_i, nu_j, nu_k) = d3dy2 (nu_i, nu_j, nu_k) - e2 * zv ( &
|
||||
nta) * zv (ntb) * DCMPLX (cos (qrg), sin (qrg) ) * d2f * alat * r &
|
||||
(jcart, nr)
|
||||
nu_k = (nb - 1) * 3 + jcart
|
||||
d3dy2 (nu_i, nu_j, nu_k) = d3dy2 (nu_i, nu_j, nu_k) - e2 * zv ( &
|
||||
nta) * zv (ntb) * DCMPLX (cos (qrg), sin (qrg) ) * d2f * alat * r &
|
||||
(icart, nr)
|
||||
!
|
||||
! nc = na case
|
||||
!
|
||||
do kcart = 1, 3
|
||||
nu_k = (na - 1) * 3 + kcart
|
||||
d3dy2 (nu_i, nu_j, nu_k) = d3dy2 (nu_i, nu_j, nu_k) + e2 * zv ( &
|
||||
nta) * zv (ntb) * DCMPLX (cos (qrg), sin (qrg) ) * d3f * alat**3 * &
|
||||
r (icart, nr) * r (jcart, nr) * r (kcart, nr)
|
||||
if (icart.eq.jcart) d3dy2 (nu_i, nu_j, nu_k) = d3dy2 (nu_i, nu_j, &
|
||||
nu_k) + e2 * zv (nta) * zv (ntb) * DCMPLX (cos (qrg), sin (qrg) ) &
|
||||
* d2f * alat * r (kcart, nr)
|
||||
enddo
|
||||
nu_k = (na - 1) * 3 + icart
|
||||
d3dy2 (nu_i, nu_j, nu_k) = d3dy2 (nu_i, nu_j, nu_k) + e2 * zv ( &
|
||||
nta) * zv (ntb) * DCMPLX (cos (qrg), sin (qrg) ) * d2f * alat * r &
|
||||
(jcart, nr)
|
||||
nu_k = (na - 1) * 3 + jcart
|
||||
d3dy2 (nu_i, nu_j, nu_k) = d3dy2 (nu_i, nu_j, nu_k) + e2 * zv ( &
|
||||
nta) * zv (ntb) * DCMPLX (cos (qrg), sin (qrg) ) * d2f * alat * r &
|
||||
(icart, nr)
|
||||
!
|
||||
! na = nb case (NB: role of nu_k and nu_j are interchanged)
|
||||
!
|
||||
do kcart = 1, 3
|
||||
nu_k = (na - 1) * 3 + kcart
|
||||
d3dy2 (nu_i, nu_k, nu_j) = d3dy2 (nu_i, nu_k, nu_j) + e2 * zv ( &
|
||||
nta) * zv (ntb) * d3f * alat**3 * r (icart, nr) * r (jcart, nr) &
|
||||
* r (kcart, nr)
|
||||
if (icart.eq.jcart) d3dy2 (nu_i, nu_k, nu_j) = d3dy2 (nu_i, nu_k, &
|
||||
nu_j) + e2 * zv (nta) * zv (ntb) * d2f * alat * r (kcart, nr)
|
||||
enddo
|
||||
nu_k = (na - 1) * 3 + icart
|
||||
d3dy2 (nu_i, nu_k, nu_j) = d3dy2 (nu_i, nu_k, nu_j) + e2 * zv ( &
|
||||
nta) * zv (ntb) * d2f * alat * r (jcart, nr)
|
||||
nu_k = (na - 1) * 3 + jcart
|
||||
d3dy2 (nu_i, nu_k, nu_j) = d3dy2 (nu_i, nu_k, nu_j) + e2 * zv ( &
|
||||
nta) * zv (ntb) * d2f * alat * r (icart, nr)
|
||||
!
|
||||
! case na=nb=nc
|
||||
!
|
||||
nu_j = (na - 1) * 3 + jcart
|
||||
do kcart = 1, 3
|
||||
nu_k = (na - 1) * 3 + kcart
|
||||
d3dy2 (nu_i, nu_j, nu_k) = d3dy2 (nu_i, nu_j, nu_k) - e2 * zv ( &
|
||||
nta) * zv (ntb) * d3f * alat**3 * r (icart, nr) * r (jcart, nr) &
|
||||
* r (kcart, nr)
|
||||
if (icart.eq.jcart) d3dy2 (nu_i, nu_j, nu_k) = d3dy2 (nu_i, nu_j, &
|
||||
nu_k) - e2 * zv (nta) * zv (ntb) * d2f * alat * r (kcart, nr)
|
||||
enddo
|
||||
nu_k = (na - 1) * 3 + icart
|
||||
d3dy2 (nu_i, nu_j, nu_k) = d3dy2 (nu_i, nu_j, nu_k) - e2 * zv ( &
|
||||
nta) * zv (ntb) * d2f * alat * r (jcart, nr)
|
||||
nu_k = (na - 1) * 3 + jcart
|
||||
d3dy2 (nu_i, nu_j, nu_k) = d3dy2 (nu_i, nu_j, nu_k) - e2 * zv ( &
|
||||
nta) * zv (ntb) * d2f * alat * r (icart, nr)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call DAXPY (2 * 27 * nat * nat * nat, 1.d0, d3dy2, 1, d3dy1, 1)
|
||||
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
||||
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
||||
|
||||
100 continue
|
||||
#ifdef PARA
|
||||
call reduce (2 * 27 * nat * nat * nat, d3dy1)
|
||||
call poolreduce (2 * 27 * nat * nat * nat, d3dy1)
|
||||
#endif
|
||||
!
|
||||
! The dynamical matrix was computed in cartesian axis and now we put
|
||||
! it on the basis of the modes; d3dy2 used as working array
|
||||
!
|
||||
call setv (2 * 27 * nat * nat * nat, 0.d0, d3dy2, 1)
|
||||
do nu_k = npert_i, npert_f
|
||||
if (q0mode (nu_k) ) then
|
||||
do nu_i = 1, 3 * nat
|
||||
do nu_j = 1, 3 * nat
|
||||
work = (0.d0, 0.d0)
|
||||
do nc_kcart = 1, 3 * nat
|
||||
do na_icart = 1, 3 * nat
|
||||
do nb_jcart = 1, 3 * nat
|
||||
work = work + ug0 (nc_kcart, nu_k) * conjg (u (na_icart, nu_i) &
|
||||
) * d3dy1 (nc_kcart, na_icart, nb_jcart) * u (nb_jcart, nu_j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
d3dy2 (nu_k, nu_i, nu_j) = work
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call poolreduce (2 * 27 * nat * nat * nat, d3dy2)
|
||||
#endif
|
||||
|
||||
|
||||
call DAXPY (2 * 27 * nat * nat * nat, 1.d0, d3dy2, 1, d3dyn, 1)
|
||||
! call writed3dyn_5(d3dy2,'d3ewald',-1)
|
||||
call mfree (d3dy3)
|
||||
call mfree (d3dy2)
|
||||
call mfree (d3dy1)
|
||||
return
|
||||
end subroutine d3ionq
|
||||
|
|
@ -0,0 +1,63 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine d3matrix
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! This routine is driver which computes the symmetrized derivative
|
||||
! of the dynamical matrix at q and in the star of q.
|
||||
! The result is written on a iudyn file
|
||||
!
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
implicit none
|
||||
|
||||
integer :: nq, isq (48), imq, na, nt, j
|
||||
! degeneracy of the star of q
|
||||
! index of q in the star of a given sym.op.
|
||||
! index of -q in the star of q (0 if not present)
|
||||
! counter on atoms
|
||||
! counter on atomic type
|
||||
! generic counter
|
||||
|
||||
real (8) :: sxq (3, 48)
|
||||
! list of vectors in the star of q
|
||||
!
|
||||
! Symmetrizes the dynamical matrix w.r.t. the small group of q
|
||||
!
|
||||
call d3_symdyn (d3dyn, u, ug0, xq, s, invs, rtau, irt, irgq, at, &
|
||||
bg, nsymq, nat, irotmq, minus_q, npert_i, npert_f)
|
||||
!
|
||||
! Generates the star of q
|
||||
!
|
||||
call star_q (xq, at, bg, ibrav, symm_type, nat, tau, ityp, nr1, &
|
||||
nr2, nr3, nsym, s, invs, irt, rtau, nq, sxq, isq, imq, noinv, &
|
||||
modenum)
|
||||
!
|
||||
! Write on file information on the system
|
||||
!
|
||||
write (iudyn, '(a)') title
|
||||
write (iudyn, '(a)') title_ph
|
||||
write (iudyn, '(i3,i5,i3,6f11.7)') ntyp, nat, ibrav, celldm
|
||||
do nt = 1, ntyp
|
||||
write (iudyn, * ) nt, ' ''', atm (nt) , ' '' ', amass (nt)
|
||||
enddo
|
||||
do na = 1, nat
|
||||
write (iudyn, '(2i5,3f15.7)') na, ityp (na) , (tau (j, na) , j = &
|
||||
1, 3)
|
||||
enddo
|
||||
!
|
||||
! Rotates and writes on iudyn the dyn.matrix derivative of the star of q
|
||||
!
|
||||
|
||||
call qstar_d3 (d3dyn, at, bg, nat, nsym, s, invs, irt, rtau, nq, &
|
||||
sxq, isq, imq, iudyn, wrmode)
|
||||
return
|
||||
end subroutine d3matrix
|
||||
|
|
@ -0,0 +1,281 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
program d3toten
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
use io
|
||||
implicit none
|
||||
#ifdef PARA
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
character :: cdate * 9, ctime * 9, version * 12
|
||||
integer :: nu_i, nu_i0, irecv
|
||||
real (8) :: t0, t1, get_clock
|
||||
|
||||
external date_and_tim
|
||||
! call sigcatch( )
|
||||
! use ".false." to disable all clocks except the total cpu time clock
|
||||
! use ".true." to enable clocks
|
||||
! call init_clocks (.false.)
|
||||
|
||||
call init_clocks (.true.)
|
||||
call start_clock ('D3TOTEN')
|
||||
version = 'D3TOTEN1.2.-'
|
||||
#ifdef PARA
|
||||
call startup (nd_nmbr, version)
|
||||
#else
|
||||
nd_nmbr = ' '
|
||||
call date_and_tim (cdate, ctime)
|
||||
write (6, 9000) version, cdate, ctime
|
||||
|
||||
9000 format (/5x,'Program ',a12,' starts ...',/5x, &
|
||||
& 'Today is ',a9,' at ',a9)
|
||||
#endif
|
||||
write (6, '(/5x,"UltraSoft (Vanderbilt) ", &
|
||||
& "Pseudopotentials")')
|
||||
!
|
||||
! Initialization routines
|
||||
!
|
||||
call d3_readin
|
||||
call allocate_d3
|
||||
call d3_setup
|
||||
call d3_summary
|
||||
call openfild3
|
||||
call d3_init
|
||||
call show_memory ()
|
||||
call print_clock ('D3TOTEN')
|
||||
!
|
||||
! Used for testing purposes: if wraux=.true. it writes
|
||||
! different terms of the third derivative matrix in different files.
|
||||
!
|
||||
if (wraux) call write_aux (1)
|
||||
|
||||
call setv (54 * nat * nat * nat, 0.d0, d3dyn, 1)
|
||||
!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
||||
nu_i0 = 1
|
||||
if (recv) then
|
||||
!
|
||||
! If recv.eq.true. this is a recover run
|
||||
!
|
||||
call d3_recover (irecv, - 1)
|
||||
|
||||
write (6, * ) ' Recover Run index:', irecv
|
||||
if (irecv.ge.401.and.irecv.lt.499) then
|
||||
nu_i0 = irecv - 400
|
||||
goto 304
|
||||
else
|
||||
goto (301, 302, 303, 304, 305, 306, 307, 308, 309, 310, 311, &
|
||||
312, 313) irecv
|
||||
endif
|
||||
endif
|
||||
!
|
||||
! It calculates the variation of wavefunctions | d/du(q) psi(k) >
|
||||
!
|
||||
t0 = get_clock ('D3TOTEN')
|
||||
if (.not.lgamma) then
|
||||
write (6, '(/,5x,"calling gen_dwfc(1)")')
|
||||
call gen_dwfc (1)
|
||||
call d3_recover (1, + 1)
|
||||
t1 = get_clock ('D3TOTEN') - t0
|
||||
t0 = get_clock ('D3TOTEN')
|
||||
write (6, '(5x,"gen_dwfc(1) time: ",f12.2, &
|
||||
& " sec Total time:",f12.2," sec")') t1, t0
|
||||
endif
|
||||
if (istop.eq.1) stop
|
||||
!
|
||||
! It calculates the variation of wavefunctions | d/du(q=0) psi(k) >
|
||||
!
|
||||
301 continue
|
||||
write (6, '(/,5x,"calling gen_dwfc(3)")')
|
||||
call gen_dwfc (3)
|
||||
call d3_recover (2, + 1)
|
||||
t1 = get_clock ('D3TOTEN') - t0
|
||||
t0 = get_clock ('D3TOTEN')
|
||||
write (6, '(5x,"gen_dwfc(3) time: ",f12.2, &
|
||||
& " sec Total time:",f12.2," sec")') t1, t0
|
||||
if (istop.eq.2) stop
|
||||
!
|
||||
! It calculates the variation of wavefunctions | d/du(q=0) psi(k+q) >
|
||||
! to be used for the terms < dpsi | dpsi ><psi| dH |psi>
|
||||
!
|
||||
302 continue
|
||||
if (.not.lgamma) then
|
||||
write (6, '(/,5x,"calling gen_dwfc(2)")')
|
||||
call gen_dwfc (2)
|
||||
call d3_recover (3, + 1)
|
||||
t1 = get_clock ('D3TOTEN') - t0
|
||||
t0 = get_clock ('D3TOTEN')
|
||||
write (6, '(5x,"gen_dwfc(2) time: ",f12.2, &
|
||||
& " sec Total time:",f12.2," sec")') t1, t0
|
||||
endif
|
||||
if (istop.eq.3) stop
|
||||
!
|
||||
! It writes on files terms of the type: <dpsi| dH | psi>, that
|
||||
! will be used for the metallic case
|
||||
!
|
||||
303 continue
|
||||
write (6, '(/,5x,"calling gen_dpdvp")')
|
||||
call gen_dpdvp
|
||||
call d3_recover (4, + 1)
|
||||
t1 = get_clock ('D3TOTEN') - t0
|
||||
t0 = get_clock ('D3TOTEN')
|
||||
write (6, '(5x,"gen_dpdvp time: ",f12.2, &
|
||||
& " sec Total time:",f12.2," sec")') t1, t0
|
||||
if (istop.eq.4) stop
|
||||
!
|
||||
! It calculates the term < dpsi| dH | dpsi >
|
||||
!
|
||||
304 continue
|
||||
do nu_i = nu_i0, 3 * nat
|
||||
if (q0mode (nu_i) ) then
|
||||
write (6, '(/,5x,"calling dpsidvdpsi:",i3)') nu_i
|
||||
call dpsidvdpsi (nu_i)
|
||||
call d3_recover (401 + nu_i, + 1)
|
||||
t1 = get_clock ('D3TOTEN') - t0
|
||||
t0 = get_clock ('D3TOTEN')
|
||||
|
||||
write (6, '(5x,"dpsidvdpsi",i3," time: ",f12.2, &
|
||||
& " sec Total time:",f12.2," sec")') nu_i, t1, t0
|
||||
|
||||
if (istop.gt.400.and.nu_i.eq. (istop - 400) ) stop
|
||||
endif
|
||||
enddo
|
||||
call d3_recover (5, + 1)
|
||||
if (istop.eq.5) stop
|
||||
!
|
||||
! It calculates the term < dpsi| dpsi > < psi | dH | psi>
|
||||
!
|
||||
305 continue
|
||||
write (6, '(/,5x,"calling dpsidpsidv")')
|
||||
call dpsidpsidv
|
||||
call d3_recover (6, + 1)
|
||||
t1 = get_clock ('D3TOTEN') - t0
|
||||
t0 = get_clock ('D3TOTEN')
|
||||
write (6, '(5x,"dpsidpsidv time: ",f12.2, &
|
||||
& " sec Total time:",f12.2," sec")') t1, t0
|
||||
if (istop.eq.6) stop
|
||||
!
|
||||
! It calculates the term drho * d2V
|
||||
!
|
||||
306 continue
|
||||
write (6, '(/,5x,"calling drhod2v")')
|
||||
call drhod2v
|
||||
call d3_recover (7, + 1)
|
||||
t1 = get_clock ('D3TOTEN') - t0
|
||||
t0 = get_clock ('D3TOTEN')
|
||||
write (6, '(5x,"drhod2v time: ",f12.2, &
|
||||
& " sec Total time:",f12.2," sec")') t1, t0
|
||||
if (istop.eq.7) stop
|
||||
!
|
||||
! It calculates the term rho * d3V
|
||||
!
|
||||
307 continue
|
||||
write (6, '(/,5x,"calling d3vrho")')
|
||||
call d3vrho
|
||||
call d3_recover (8, + 1)
|
||||
t1 = get_clock ('D3TOTEN') - t0
|
||||
t0 = get_clock ('D3TOTEN')
|
||||
write (6, '(5x,"d3vrho time: ",f12.2, &
|
||||
& " sec Total time:",f12.2," sec")') t1, t0
|
||||
if (istop.eq.8) stop
|
||||
!
|
||||
! It calculates the contribution due to ionic term
|
||||
!
|
||||
308 continue
|
||||
write (6, '(/,5x,"calling d3ionq")')
|
||||
call d3ionq (nat, ntyp, ityp, zv, tau, alat, omega, xq, at, bg, g, &
|
||||
gg, ngm, gcutm, nmodes, u, ug0, npert_i, npert_f, q0mode, d3dyn)
|
||||
call d3_recover (9, + 1)
|
||||
t1 = get_clock ('D3TOTEN') - t0
|
||||
t0 = get_clock ('D3TOTEN')
|
||||
write (6, '(5x,"d3ionq time: ",f12.2, &
|
||||
& " sec Total time:",f12.2," sec")') t1, t0
|
||||
if (istop.eq.9) stop
|
||||
!
|
||||
! In the metallic case some additional terms are needed
|
||||
!
|
||||
309 continue
|
||||
write (6, '(/,5x,"calling d3_valence")')
|
||||
call d3_valence
|
||||
call d3_recover (10, + 1)
|
||||
t1 = get_clock ('D3TOTEN') - t0
|
||||
t0 = get_clock ('D3TOTEN')
|
||||
write (6, '(5x,"d3_valence time: ",f12.2, &
|
||||
& " sec Total time:",f12.2," sec")') t1, t0
|
||||
if (istop.eq.10) stop
|
||||
!
|
||||
! drho_cc(+1) adds to the variation or the charge -written on a file-
|
||||
! the variation of the core charge. The variation of the charge,
|
||||
! modified this way is used by the routines d3_exc and d3dyn_cc.
|
||||
! drho_cc(-1) restores drho as it was before (useless)
|
||||
!
|
||||
310 continue
|
||||
write (6, '(/,5x,"calling drho_cc(+1)")')
|
||||
call drho_cc ( + 1)
|
||||
call d3_recover (11, + 1)
|
||||
t1 = get_clock ('D3TOTEN') - t0
|
||||
t0 = get_clock ('D3TOTEN')
|
||||
write (6, '(5x,"drho_cc(+1) time: ",f12.2, &
|
||||
& " sec Total time:",f12.2," sec")') t1, t0
|
||||
!
|
||||
! It calculates d3Ei * drho * drho * drho, where drho is the variation
|
||||
! of the charge and d3Ei is the third derivative of the
|
||||
! Kohn-Sham-Energy term depending on the charge density.
|
||||
!
|
||||
311 continue
|
||||
write (6, '(/,5x,"calling d3_exc")')
|
||||
call d3_exc
|
||||
call d3_recover (12, + 1)
|
||||
t1 = get_clock ('D3TOTEN') - t0
|
||||
t0 = get_clock ('D3TOTEN')
|
||||
write (6, '(5x,"d3_exc time: ",f12.2, &
|
||||
& " sec Total time:",f12.2," sec")') t1, t0
|
||||
!
|
||||
! It calculates additional terms due to non_linear-core-corrections
|
||||
!
|
||||
312 continue
|
||||
write (6, '(/,5x,"calling d3dyn_cc")')
|
||||
call d3dyn_cc
|
||||
call d3_recover (13, + 1)
|
||||
t1 = get_clock ('D3TOTEN') - t0
|
||||
t0 = get_clock ('D3TOTEN')
|
||||
|
||||
write (6, '(5x,"d3dyn_cc time: ",f12.2, &
|
||||
& " sec Total time:",f12.2," sec")') t1, t0
|
||||
!
|
||||
! drho is restored as it was before
|
||||
!
|
||||
! write(6,'(/,5x,"calling drho_cc(-1)")')
|
||||
! call drho_cc(-1)
|
||||
! t1 = get_clock('D3TOTEN') - t0
|
||||
! t0 = get_clock('D3TOTEN')
|
||||
! write(6,'(5x,"drho_cc(-1) time: ",f12.2,
|
||||
! + " sec Total time:",f12.2," sec")') t1,t0
|
||||
if (wraux) call write_aux (2)
|
||||
!
|
||||
! Symmetrizes d3dyn, calculates the q in the star and writes the result
|
||||
! for every q on a file.
|
||||
!
|
||||
313 continue
|
||||
write (6, '(/,5x,"calling d3matrix")')
|
||||
call d3matrix
|
||||
t1 = get_clock ('D3TOTEN') - t0
|
||||
t0 = get_clock ('D3TOTEN')
|
||||
|
||||
write (6, '(5x,"d3matrix time: ",f12.2, &
|
||||
& " sec Total time:",f12.2," sec")') t1, t0
|
||||
if (wraux) call write_aux (3)
|
||||
|
||||
call stop_d3 (.true.)
|
||||
end program d3toten
|
||||
|
|
@ -0,0 +1,200 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!----------------------------------------------------------------------
|
||||
|
||||
subroutine d3vrho
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! This routine calculates the electronic term: <psi|V"'|psi>
|
||||
! of the third order dynamical matrix.
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
use allocate
|
||||
!
|
||||
implicit none
|
||||
integer :: icart, jcart, kcart, na_i, na_j, na_k, na, ng, ir, nt, &
|
||||
ik, ikk, ig, ibnd, ikb, jkb, ios, igg, ia
|
||||
! counter on polarizations
|
||||
! counter on polarizations
|
||||
! counter on polarizations
|
||||
! counter on modes
|
||||
! counter on modes
|
||||
! counter on modes
|
||||
! counter on atoms
|
||||
! counter on G vectors
|
||||
! counter on real space mesh
|
||||
! counter on atomic types
|
||||
! counter on k points
|
||||
! counter on k points
|
||||
! counter on G vectors
|
||||
! counter on bands
|
||||
! counters on beta functions
|
||||
! integer variable for I/O control
|
||||
! counter on g
|
||||
! counter on index permutation
|
||||
|
||||
real (8) :: gtau, fac, wgg
|
||||
! the product G*\tau_s
|
||||
! auxiliary variable
|
||||
! the true weight of a K point
|
||||
|
||||
complex (8) :: alpha (8), ZDOTC, work
|
||||
complex (8), pointer :: d3dynwrk (:,:,:), d3dynwrk2 (:,:,:), rhog (:), &
|
||||
work1 (:,:), work2 (:,:), work3 (:)
|
||||
|
||||
call mallocate (rhog, nrxx)
|
||||
call mallocate (d3dynwrk, 3 * nat, 3 * nat, 3 * nat)
|
||||
call mallocate (d3dynwrk2,3 * nat, 3 * nat, 3 * nat)
|
||||
call mallocate (work1, npwx, 3)
|
||||
call mallocate (work2, npwx, 3)
|
||||
call mallocate (work3, npwx)
|
||||
|
||||
call setv (2 * 27 * nat * nat * nat, 0.d0, d3dynwrk, 1)
|
||||
do ir = 1, nrxx
|
||||
rhog (ir) = cmplx (rho (ir, 1), 0.d0)
|
||||
enddo
|
||||
call cft3 (rhog, nr1, nr2, nr3, nrx1, nrx2, nrx3, - 1)
|
||||
!
|
||||
! Contribution deriving from the local part of the potential
|
||||
!
|
||||
do na_i = npert_i, npert_f
|
||||
na = (na_i - 1) / 3 + 1
|
||||
icart = na_i - 3 * (na - 1)
|
||||
do jcart = 1, 3
|
||||
na_j = 3 * (na - 1) + jcart
|
||||
do kcart = 1, 3
|
||||
na_k = 3 * (na - 1) + kcart
|
||||
do ng = 1, ngm
|
||||
gtau = tpi * (g (1, ng) * tau (1, na) + g (2, ng) * tau (2, na) &
|
||||
+ g (3, ng) * tau (3, na) )
|
||||
fac = vloc (igtongl (ng), ityp (na) ) * tpiba2 * tpiba * omega * &
|
||||
(real (rhog (nl (ng) ) ) * sin (gtau) + DIMAG (rhog (nl (ng) ) ) &
|
||||
* cos (gtau) )
|
||||
d3dynwrk (na_i, na_j, na_k) = d3dynwrk (na_i, na_j, na_k) + fac * &
|
||||
g (icart, ng) * g (jcart, ng) * g (kcart, ng)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call reduce (2 * 27 * nat * nat * nat, d3dynwrk)
|
||||
#endif
|
||||
!
|
||||
! Non local Kleinman-Bylander potential contribution
|
||||
!
|
||||
rewind (unit = iunigk)
|
||||
|
||||
do ik = 1, nksq
|
||||
read (iunigk, err = 100, iostat = ios) npw, igk
|
||||
if (lgamma) then
|
||||
ikk = ik
|
||||
else
|
||||
read (iunigk, err = 200, iostat = ios) npwq, igkq
|
||||
ikk = 2 * ik - 1
|
||||
endif
|
||||
100 call error ('d3vrho', 'reading igk', abs (ios) )
|
||||
200 call error ('d3vrho', 'reading igkq', abs (ios) )
|
||||
call davcio (evc, lrwfc, iuwfc, ikk, - 1)
|
||||
call init_us_2 (npw, igk, xk (1, ikk), vkb0)
|
||||
|
||||
do kcart = 1, 3
|
||||
do icart = 1, 3
|
||||
do jcart = 1, 3
|
||||
do ibnd = 1, nbnd_occ (ikk)
|
||||
wgg = wg (ibnd, ikk)
|
||||
do ig = 1, npw
|
||||
work3 (ig) = evc (ig, ibnd) * tpiba * g (icart, igk (ig) ) &
|
||||
* tpiba * g (jcart, igk (ig) ) * tpiba * g (kcart, igk (ig) )
|
||||
work2 (ig, 1) = evc (ig, ibnd) * tpiba * g (icart, igk (ig) ) &
|
||||
* tpiba * g (jcart, igk (ig) )
|
||||
work2 (ig, 2) = evc (ig, ibnd) * tpiba * g (jcart, igk (ig) ) &
|
||||
* tpiba * g (kcart, igk (ig) )
|
||||
work2 (ig, 3) = evc (ig, ibnd) * tpiba * g (kcart, igk (ig) ) &
|
||||
* tpiba * g (icart, igk (ig) )
|
||||
work1 (ig, 1) = evc (ig, ibnd) * tpiba * g (kcart, igk (ig) )
|
||||
work1 (ig, 2) = evc (ig, ibnd) * tpiba * g (icart, igk (ig) )
|
||||
work1 (ig, 3) = evc (ig, ibnd) * tpiba * g (jcart, igk (ig) )
|
||||
enddo
|
||||
jkb=0
|
||||
do nt = 1, ntyp
|
||||
do na = 1, nat
|
||||
if (ityp (na).eq.nt) then
|
||||
na_k = 3 * (na - 1) + kcart
|
||||
na_i = 3 * (na - 1) + icart
|
||||
na_j = 3 * (na - 1) + jcart
|
||||
do ikb = 1, nh (nt)
|
||||
jkb=jkb+1
|
||||
alpha (1) = ZDOTC (npw, work3, 1, vkb0(1,jkb), 1)
|
||||
alpha (2) = ZDOTC (npw, vkb0(1,jkb), 1, evc (1, ibnd), 1)
|
||||
alpha (3) = ZDOTC (npw,work1(1, 1),1,vkb0(1,jkb),1)
|
||||
alpha (4) = ZDOTC (npw,vkb0(1,jkb),1,work2(1, 1),1)
|
||||
alpha (5) = ZDOTC (npw,work1(1, 2),1,vkb0(1,jkb),1)
|
||||
alpha (6) = ZDOTC (npw,vkb0(1,jkb),1,work2(1, 2),1)
|
||||
alpha (7) = ZDOTC (npw,work1(1, 3),1,vkb0(1,jkb),1)
|
||||
alpha (8) = ZDOTC (npw,vkb0(1,jkb),1,work2(1, 3),1)
|
||||
#ifdef PARA
|
||||
call reduce (16, alpha)
|
||||
#endif
|
||||
d3dynwrk (na_k, na_i, na_j) = d3dynwrk (na_k, na_i, na_j) - &
|
||||
2.0d0 * dvan(ikb,ikb,nt) * wgg * &
|
||||
DIMAG(alpha(1)*alpha(2) + alpha(3)*alpha(4) + &
|
||||
alpha(5)*alpha(6) + alpha(7)*alpha(8))
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call poolreduce (2 * 27 * nat * nat * nat, d3dynwrk)
|
||||
#endif
|
||||
!
|
||||
! The dynamical matrix was computed in cartesian axis and now we put
|
||||
! it on the basis of the modes
|
||||
!
|
||||
call setv (2 * 27 * nat * nat * nat, 0.d0, d3dynwrk2, 1)
|
||||
do na_k = npert_i, npert_f
|
||||
if (q0mode (na_k) ) then
|
||||
do na_i = 1, 3 * nat
|
||||
do na_j = 1, 3 * nat
|
||||
work = (0.d0, 0.d0)
|
||||
do kcart = 1, 3 * nat
|
||||
do icart = 1, 3 * nat
|
||||
do jcart = 1, 3 * nat
|
||||
work = work + ug0 (kcart, na_k) * conjg (u (icart, na_i) ) &
|
||||
* d3dynwrk (kcart, icart, jcart) * u (jcart, na_j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
d3dynwrk2 (na_k, na_i, na_j) = work
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call poolreduce (2 * 27 * nat * nat * nat, d3dynwrk2)
|
||||
#endif
|
||||
call DAXPY (2 * 27 * nat * nat * nat, 1.d0, d3dynwrk2, 1, d3dyn, 1)
|
||||
|
||||
call ZCOPY (27 * nat * nat * nat, d3dynwrk2, 1, d3dyn_aux1, 1)
|
||||
call mfree (work1)
|
||||
call mfree (work2)
|
||||
call mfree (work3)
|
||||
call mfree (d3dynwrk2)
|
||||
call mfree (d3dynwrk)
|
||||
call mfree (rhog)
|
||||
|
||||
return
|
||||
end subroutine d3vrho
|
||||
|
|
@ -0,0 +1,78 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
|
||||
subroutine davcio_drho2 (drho, lrec, iunit, nrec, isw)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! reads/writes variation of the charge with respect to a perturbation
|
||||
! on a file.
|
||||
! isw = +1 : gathers data from the nodes and writes on a single file
|
||||
! isw = -1 : reads data from a single file and distributes them
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use allocate
|
||||
use parameters, only : DP
|
||||
use phcom
|
||||
#ifdef PARA
|
||||
use para
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef PARA
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer :: iunit, lrec, nrec, isw
|
||||
complex(kind=DP) :: drho (nrxx)
|
||||
#ifdef PARA
|
||||
!
|
||||
! local variables
|
||||
!
|
||||
|
||||
integer :: root, errcode, itmp, proc
|
||||
|
||||
complex(kind=DP), pointer :: ddrho (:)
|
||||
|
||||
call mallocate(ddrho, nrx1 * nrx2 * nrx3 )
|
||||
|
||||
if (isw.eq.1) then
|
||||
!
|
||||
! First task of the pool gathers and writes in the file
|
||||
!
|
||||
call cgather_sym (drho, ddrho)
|
||||
root = 0
|
||||
call MPI_barrier (MPI_COMM_POOL, errcode)
|
||||
call error ('davcio_drho2', 'at barrier', errcode)
|
||||
|
||||
if (me.eq.1) call davcio (ddrho, lrec, iunit, nrec, + 1)
|
||||
elseif (isw.lt.0) then
|
||||
!
|
||||
! First task of the pool reads ddrho, and broadcasts to all the
|
||||
! processors of the pool
|
||||
!
|
||||
if (me.eq.1) call davcio (ddrho, lrec, iunit, nrec, - 1)
|
||||
call broadcast (2 * nrx1 * nrx2 * nrx3, ddrho)
|
||||
!
|
||||
! Distributes ddrho between between the tasks of the pool
|
||||
!
|
||||
itmp = 1
|
||||
do proc = 1, me-1
|
||||
itmp = itmp + ncplane * npp (proc)
|
||||
enddo
|
||||
call setv (2 * nrxx, 0.d0, drho, 1)
|
||||
|
||||
call ZCOPY (ncplane * npp (me), ddrho (itmp), 1, drho, 1)
|
||||
|
||||
endif
|
||||
call mfree(ddrho)
|
||||
#else
|
||||
call davcio (drho, lrec, iunit, nrec, isw)
|
||||
#endif
|
||||
return
|
||||
end subroutine davcio_drho2
|
||||
|
|
@ -0,0 +1,85 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!----------------------------------------------------------------------
|
||||
|
||||
subroutine dpsi_corr (evcq, psidvpsi_x, ik, ikq, nu)
|
||||
!-----------------------------------------------------------------------
|
||||
! Used in the metallic case.
|
||||
! If dpsi common variable contains the projection on the conduction
|
||||
! states of the first variation of a wavefunction at a given k-point,
|
||||
! this routine corrects dpsi in such a way that the density matrix
|
||||
! is given by: Sum_{k,nu} 2 * | dpsi > < psi |
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
|
||||
implicit none
|
||||
integer :: ik, ikq, nu, ibnd, jbnd
|
||||
! index of the k-point under consideration
|
||||
! index of the corresponding k+q point
|
||||
! mode under consideration
|
||||
! counter on bands
|
||||
! counter on bands
|
||||
|
||||
real (8) :: wfshift, wgauss, w0gauss, deltae, wg1, wg2, wwg
|
||||
! the shift coefficent for the wave function
|
||||
! function computing the theta function
|
||||
! function computing the derivative of theta
|
||||
! difference of energy
|
||||
! weight for metals
|
||||
! weight for metals
|
||||
! weight for metals
|
||||
|
||||
complex (8) :: evcq (npwx, nbnd), psidvpsi_x (nbnd, nbnd), &
|
||||
psidvpsi
|
||||
! k+q point wavefunction
|
||||
! < psi_{k+q} | V(q) | psi_k >
|
||||
!
|
||||
! Multiplies dpsi by the theta function
|
||||
!
|
||||
do ibnd = 1, nbnd
|
||||
wg1 = wgauss ( (ef - et (ibnd, ik) ) / degauss, ngauss)
|
||||
call DSCAL (2 * npwq, wg1, dpsi (1, ibnd), 1)
|
||||
enddo
|
||||
!
|
||||
! Adds to dpsi the term containing the valence wavefunctions
|
||||
!
|
||||
do ibnd = 1, nbnd
|
||||
do jbnd = 1, nbnd
|
||||
deltae = et (ibnd, ik) - et (jbnd, ikq)
|
||||
if (abs (deltae) .gt.1.0d-5) then
|
||||
wg1 = wgauss ( (ef - et (ibnd, ik) ) / degauss, ngauss)
|
||||
wg2 = wgauss ( (ef - et (jbnd, ikq) ) / degauss, ngauss)
|
||||
wwg = (wg1 - wg2) / deltae
|
||||
else
|
||||
wwg = - w0gauss ( (ef - et (ibnd, ik) ) / degauss, ngauss) &
|
||||
/ degauss
|
||||
endif
|
||||
psidvpsi = 0.5d0 * wwg * psidvpsi_x (jbnd, ibnd)
|
||||
call ZAXPY (npwq, psidvpsi, evcq (1, jbnd), 1, dpsi (1, ibnd), &
|
||||
1)
|
||||
enddo
|
||||
enddo
|
||||
!
|
||||
! If necessary corrects dpsi with a term depending on FermiEnergy shift
|
||||
!
|
||||
if (ik.eq.ikq) then
|
||||
do ibnd = 1, nbnd_occ (ik)
|
||||
wfshift = 0.5d0 * ef_sh (nu) * w0gauss ( (ef - et (ibnd, ik) ) &
|
||||
/ degauss, ngauss) / degauss
|
||||
call DAXPY (2 * npw, wfshift, evcq (1, ibnd), 1, dpsi (1, ibnd) &
|
||||
, 1)
|
||||
enddo
|
||||
|
||||
endif
|
||||
return
|
||||
|
||||
end subroutine dpsi_corr
|
||||
|
|
@ -0,0 +1,235 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine dpsidpsidv
|
||||
!-----------------------------------------------------------------------
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
use allocate
|
||||
|
||||
implicit none
|
||||
integer :: ik, ikk, ikq, ibnd, jbnd, nu_i, nu_j, nu_z, nrec
|
||||
real (8) :: wgauss, wga (nbnd), wgq (nbnd), w0gauss, w0g (nbnd), &
|
||||
deltae, wg1, wg2, wwg
|
||||
complex (8) :: wrk, wrk0, ZDOTC
|
||||
complex (8), pointer :: dqpsi (:,:), ps1_ij (:,:), ps1_ji (:,:), &
|
||||
ps3_ij (:,:), ps2_ji (:,:), d3dyn1 (:,:,:), d3dyn2 (:,:,:),&
|
||||
d3dyn3 (:,:,:)
|
||||
|
||||
|
||||
call mallocate (dqpsi, npwx, nbnd)
|
||||
if (degauss.ne.0.d0) then
|
||||
call mallocate (ps1_ij, nbnd, nbnd)
|
||||
call mallocate (ps1_ji, nbnd, nbnd)
|
||||
call mallocate (ps3_ij, nbnd, nbnd)
|
||||
call mallocate (ps2_ji, nbnd, nbnd)
|
||||
endif
|
||||
call mallocate (d3dyn1, 3 * nat, 3 * nat, 3 * nat)
|
||||
if (.not.allmodes) then
|
||||
call mallocate (d3dyn2, 3 * nat, 3 * nat, 3 * nat)
|
||||
call mallocate (d3dyn3, 3 * nat, 3 * nat, 3 * nat)
|
||||
endif
|
||||
call setv (2 * 27 * nat * nat * nat, 0.d0, d3dyn1, 1)
|
||||
if (.not.allmodes) then
|
||||
call setv (2 * 27 * nat * nat * nat, 0.d0, d3dyn2, 1)
|
||||
call setv (2 * 27 * nat * nat * nat, 0.d0, d3dyn3, 1)
|
||||
|
||||
endif
|
||||
|
||||
do ik = 1, nksq
|
||||
if (lgamma) then
|
||||
ikk = ik
|
||||
ikq = ik
|
||||
else
|
||||
ikk = 2 * ik - 1
|
||||
ikq = 2 * ik
|
||||
|
||||
endif
|
||||
if (degauss.ne.0.d0) then
|
||||
do ibnd = 1, nbnd
|
||||
wga (ibnd) = wgauss ( (ef - et (ibnd, ikk) ) / degauss, ngauss)
|
||||
wgq (ibnd) = wgauss ( (ef - et (ibnd, ikq) ) / degauss, ngauss)
|
||||
w0g (ibnd) = w0gauss ( (ef - et (ibnd, ikk) ) / degauss, &
|
||||
ngauss) / degauss
|
||||
enddo
|
||||
|
||||
endif
|
||||
do nu_i = 1, 3 * nat
|
||||
nrec = (nu_i - 1) * nksq + ik
|
||||
|
||||
call davcio (dpsi, lrdwf, iudqwf, nrec, - 1)
|
||||
do nu_j = 1, 3 * nat
|
||||
nrec = (nu_j - 1) * nksq + ik
|
||||
|
||||
call davcio (dqpsi, lrdwf, iudqwf, nrec, - 1)
|
||||
if (degauss.ne.0.d0) then
|
||||
nrec = nu_i + (nu_j - 1) * 3 * nat + (ik - 1) * 9 * nat * nat
|
||||
call davcio (ps1_ij, lrdpdvp, iudpdvp_1, nrec, - 1)
|
||||
nrec = nu_j + (nu_i - 1) * 3 * nat + (ik - 1) * 9 * nat * nat
|
||||
call davcio (ps1_ji, lrdpdvp, iudpdvp_1, nrec, - 1)
|
||||
|
||||
endif
|
||||
do nu_z = 1, 3 * nat
|
||||
if (q0mode (nu_z) ) then
|
||||
nrec = nu_z + (ik - 1) * 3 * nat
|
||||
|
||||
call davcio (psidqvpsi, lrpdqvp, iupd0vp, nrec, - 1)
|
||||
wrk0 = DCMPLX (0.d0, 0.d0)
|
||||
wrk = DCMPLX (0.d0, 0.d0)
|
||||
do ibnd = 1, nbnd
|
||||
do jbnd = 1, nbnd
|
||||
if (degauss.ne.0.d0) then
|
||||
deltae = et (ibnd, ikk) - et (jbnd, ikk)
|
||||
if (abs (deltae) .gt.1.0d-5) then
|
||||
wg1 = wga (ibnd) / deltae
|
||||
|
||||
wg2 = wga (jbnd) / deltae
|
||||
|
||||
wrk0 = wrk0 + psidqvpsi (jbnd, ibnd) * (wg1 * ps1_ij ( &
|
||||
ibnd, jbnd) - wg2 * conjg (ps1_ji (jbnd, ibnd) ) )
|
||||
else
|
||||
wg1 = wga (ibnd)
|
||||
|
||||
wwg = w0g (ibnd)
|
||||
wrk0 = wrk0 - psidqvpsi (jbnd, ibnd) * wwg * ps1_ij ( &
|
||||
ibnd, jbnd)
|
||||
wrk = wrk - psidqvpsi (jbnd, ibnd) * wg1 * ZDOTC (npwq, &
|
||||
dpsi (1, ibnd), 1, dqpsi (1, jbnd), 1)
|
||||
endif
|
||||
else
|
||||
wrk = wrk - psidqvpsi (jbnd, ibnd) * ZDOTC (npwq, dpsi (1, &
|
||||
ibnd), 1, dqpsi (1, jbnd), 1)
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call reduce (2, wrk)
|
||||
#endif
|
||||
wrk = wrk + wrk0
|
||||
wrk = 2.d0 * wk (ikk) * wrk
|
||||
|
||||
d3dyn1 (nu_z, nu_i, nu_j) = d3dyn1 (nu_z, nu_i, nu_j) + wrk
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
if (.not.allmodes) then
|
||||
do nu_j = 1, 3 * nat
|
||||
nrec = (nu_j - 1) * nksq + ik
|
||||
|
||||
call davcio (dqpsi, lrdwf, iudqwf, nrec, - 1)
|
||||
do nu_i = 1, 3 * nat
|
||||
if (q0mode (nu_i) ) then
|
||||
nrec = (nu_i - 1) * nksq + ik
|
||||
|
||||
call davcio (dpsi, lrdwf, iud0qwf, nrec, - 1)
|
||||
if (degauss.ne.0.d0) then
|
||||
nrec = nu_i + (nu_j - 1) * 3 * nat + (ik - 1) * 9 * nat * &
|
||||
nat
|
||||
call davcio (ps3_ij, lrdpdvp, iudpdvp_3, nrec, - 1)
|
||||
nrec = nu_j + (nu_i - 1) * 3 * nat + (ik - 1) * 9 * nat * &
|
||||
nat
|
||||
call davcio (ps2_ji, lrdpdvp, iudpdvp_2, nrec, - 1)
|
||||
|
||||
endif
|
||||
do nu_z = 1, 3 * nat
|
||||
nrec = nu_z + (ik - 1) * 3 * nat
|
||||
|
||||
call davcio (psidqvpsi, lrpdqvp, iupdqvp, nrec, - 1)
|
||||
wrk0 = DCMPLX (0.d0, 0.d0)
|
||||
wrk = DCMPLX (0.d0, 0.d0)
|
||||
do ibnd = 1, nbnd
|
||||
do jbnd = 1, nbnd
|
||||
if (degauss.ne.0.d0) then
|
||||
deltae = et (ibnd, ikk) - et (jbnd, ikq)
|
||||
if (abs (deltae) .gt.1.0d-5) then
|
||||
wg1 = wga (ibnd) / deltae
|
||||
|
||||
wg2 = wgq (jbnd) / deltae
|
||||
wrk0 = wrk0 + psidqvpsi (jbnd, ibnd) * (wg1 * ps2_ji ( &
|
||||
ibnd, jbnd) - wg2 * conjg (ps3_ij (jbnd, ibnd) ) )
|
||||
else
|
||||
wg1 = wga (ibnd)
|
||||
|
||||
wwg = w0g (ibnd)
|
||||
wrk0 = wrk0 - psidqvpsi (jbnd, ibnd) * wwg * ps2_ji ( &
|
||||
ibnd, jbnd)
|
||||
wrk = wrk - psidqvpsi (jbnd, ibnd) * wg1 * ZDOTC ( &
|
||||
npwq, dqpsi (1, ibnd), 1, dpsi (1, jbnd), 1)
|
||||
endif
|
||||
else
|
||||
wrk = wrk - psidqvpsi (jbnd, ibnd) * ZDOTC (npwq, dqpsi ( &
|
||||
1, ibnd), 1, dpsi (1, jbnd), 1)
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call reduce (2, wrk)
|
||||
#endif
|
||||
wrk = wrk + wrk0
|
||||
wrk = 2.d0 * wk (ikk) * wrk
|
||||
d3dyn2 (nu_i, nu_j, nu_z) = d3dyn2 (nu_i, nu_j, nu_z) &
|
||||
+ wrk
|
||||
|
||||
d3dyn3 (nu_i, nu_z, nu_j) = d3dyn3 (nu_i, nu_z, nu_j) &
|
||||
+ conjg (wrk)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
endif
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call poolreduce (2 * 27 * nat * nat * nat, d3dyn1)
|
||||
if (.not.allmodes) then
|
||||
call poolreduce (2 * 27 * nat * nat * nat, d3dyn2)
|
||||
call poolreduce (2 * 27 * nat * nat * nat, d3dyn3)
|
||||
endif
|
||||
#endif
|
||||
do nu_i = 1, 3 * nat
|
||||
do nu_j = 1, 3 * nat
|
||||
do nu_z = 1, 3 * nat
|
||||
if (allmodes) then
|
||||
d3dyn (nu_i, nu_j, nu_z) = d3dyn (nu_i, nu_j, nu_z) + d3dyn1 ( &
|
||||
nu_i, nu_j, nu_z) + d3dyn1 (nu_j, nu_z, nu_i) + d3dyn1 (nu_z, &
|
||||
nu_i, nu_j)
|
||||
d3dyn_aux6 (nu_i, nu_j, nu_z) = d3dyn_aux6 (nu_i, nu_j, nu_z) &
|
||||
+ d3dyn1 (nu_i, nu_j, nu_z) + d3dyn1 (nu_j, nu_z, nu_i) &
|
||||
+ d3dyn1 (nu_z, nu_i, nu_j)
|
||||
else
|
||||
d3dyn (nu_i, nu_j, nu_z) = d3dyn (nu_i, nu_j, nu_z) + d3dyn1 ( &
|
||||
nu_i, nu_j, nu_z) + d3dyn2 (nu_i, nu_j, nu_z) + d3dyn3 (nu_i, &
|
||||
nu_j, nu_z)
|
||||
d3dyn_aux6 (nu_i, nu_j, nu_z) = d3dyn_aux6 (nu_i, nu_j, nu_z) &
|
||||
+ d3dyn1 (nu_i, nu_j, nu_z) + d3dyn2 (nu_i, nu_j, nu_z) &
|
||||
+ d3dyn3 (nu_i, nu_j, nu_z)
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
call mfree (dqpsi)
|
||||
if (degauss.ne.0.d0) then
|
||||
call mfree (ps1_ij)
|
||||
call mfree (ps1_ji)
|
||||
call mfree (ps3_ij)
|
||||
call mfree (ps2_ji)
|
||||
endif
|
||||
call mfree (d3dyn1)
|
||||
if (.not.allmodes) then
|
||||
call mfree (d3dyn2)
|
||||
call mfree (d3dyn3)
|
||||
|
||||
endif
|
||||
return
|
||||
end subroutine dpsidpsidv
|
||||
|
|
@ -0,0 +1,192 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine dpsidvdpsi (nu_q0)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
use allocate
|
||||
|
||||
implicit none
|
||||
integer :: nu_q0
|
||||
!
|
||||
integer :: ik, ikk, ikq, ig, ibnd, nu_i, nu_j, nu_z, nrec, ios
|
||||
real (8) :: zero (3), wgauss, wga (nbnd), wg1
|
||||
complex (8) :: wrk, ZDOTC
|
||||
complex (8), pointer :: dqpsi (:,:), dvloc (:), d3dyn1 (:,:,:), &
|
||||
d3dyn2 (:,:,:), d3dyn3 (:,:,:)
|
||||
|
||||
|
||||
call mallocate (dqpsi, npwx, nbnd)
|
||||
call mallocate (dvloc, nrxx)
|
||||
call mallocate (d3dyn1, 3 * nat, 3 * nat, 3 * nat)
|
||||
if (.not.allmodes) then
|
||||
call mallocate (d3dyn2, 3 * nat, 3 * nat, 3 * nat)
|
||||
call mallocate (d3dyn3, 3 * nat, 3 * nat,3 * nat)
|
||||
endif
|
||||
|
||||
call setv (3, 0.d0, zero, 1)
|
||||
call setv (2 * 27 * nat * nat * nat, 0.d0, d3dyn1, 1)
|
||||
if (.not.allmodes) then
|
||||
call setv (2 * 27 * nat * nat * nat, 0.d0, d3dyn2, 1)
|
||||
call setv (2 * 27 * nat * nat * nat, 0.d0, d3dyn3, 1)
|
||||
endif
|
||||
nu_z = nu_q0
|
||||
|
||||
call dvscf (nu_z, dvloc, zero)
|
||||
|
||||
rewind (unit = iunigk)
|
||||
|
||||
do ik = 1, nksq
|
||||
if (.not.lgamma) read (iunigk, err = 100, iostat = ios) npwq, &
|
||||
igkq
|
||||
read (iunigk, err = 100, iostat = ios) npwq, igkq
|
||||
100 call error ('dpsidvdpsi', 'reading iunigk-iunigkq', abs (ios) )
|
||||
npw = npwq
|
||||
do ig = 1, npwx
|
||||
igk (ig) = igkq (ig)
|
||||
enddo
|
||||
if (lgamma) then
|
||||
ikk = ik
|
||||
ikq = ik
|
||||
else
|
||||
ikk = 2 * ik - 1
|
||||
ikq = 2 * ik
|
||||
endif
|
||||
call init_us_2 (npwq, igkq, xk (1, ikq), vkb)
|
||||
|
||||
wg1 = wk (ikk)
|
||||
if (degauss.ne.0.d0) then
|
||||
do ibnd = 1, nbnd
|
||||
wga (ibnd) = wgauss ( (ef - et (ibnd, ikk) ) / degauss, ngauss)
|
||||
enddo
|
||||
endif
|
||||
do nu_i = 1, 3 * nat
|
||||
nrec = (nu_i - 1) * nksq + ik
|
||||
call davcio (dpsi, lrdwf, iudqwf, nrec, - 1)
|
||||
|
||||
call dvdpsi (nu_z, zero, dvloc, vkb, vkb, dpsi, dvpsi)
|
||||
do nu_j = 1, 3 * nat
|
||||
nrec = (nu_j - 1) * nksq + ik
|
||||
|
||||
call davcio (dqpsi, lrdwf, iudqwf, nrec, - 1)
|
||||
wrk = DCMPLX (0.d0, 0.d0)
|
||||
do ibnd = 1, nbnd
|
||||
if (degauss.ne.0.d0) wg1 = wk (ikk) * wga (ibnd)
|
||||
wrk = wrk + 2.d0 * wg1 * ZDOTC (npwq, dqpsi (1, ibnd), 1, dvpsi ( &
|
||||
1, ibnd), 1)
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call reduce (2, wrk)
|
||||
#endif
|
||||
d3dyn1 (nu_z, nu_j, nu_i) = d3dyn1 (nu_z, nu_j, nu_i) + wrk
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
if (.not.allmodes) then
|
||||
|
||||
rewind (unit = iunigk)
|
||||
|
||||
do ik = 1, nksq
|
||||
read (iunigk, err = 110, iostat = ios) npw, igk
|
||||
if (.not.lgamma) read (iunigk, err = 110, iostat = ios) npwq, &
|
||||
igkq
|
||||
|
||||
110 call error ('dpsidvdpsi', 'reading iunigk-iunigkq', abs (ios) )
|
||||
if (lgamma) then
|
||||
npwq = npw
|
||||
ikk = ik
|
||||
ikq = ik
|
||||
else
|
||||
ikk = 2 * ik - 1
|
||||
ikq = 2 * ik
|
||||
endif
|
||||
|
||||
call init_us_2 (npw, igk, xk (1, ikk), vkb0)
|
||||
call init_us_2 (npwq, igkq, xk (1, ikq), vkb)
|
||||
|
||||
wg1 = wk (ikk)
|
||||
if (degauss.ne.0.d0) then
|
||||
do ibnd = 1, nbnd
|
||||
wga (ibnd) = wgauss ( (ef - et (ibnd, ikk) ) / degauss, &
|
||||
ngauss)
|
||||
enddo
|
||||
endif
|
||||
|
||||
nu_i = nu_q0
|
||||
do nu_z = 1, 3 * nat
|
||||
call dvscf (nu_z, dvloc, xq)
|
||||
nrec = (nu_i - 1) * nksq + ik
|
||||
call davcio (dpsi, lrdwf, iudwf, nrec, - 1)
|
||||
|
||||
call dvdpsi (nu_z, xq, dvloc, vkb0, vkb, dpsi, dvpsi)
|
||||
|
||||
do nu_j = 1, 3 * nat
|
||||
nrec = (nu_j - 1) * nksq + ik
|
||||
call davcio (dqpsi, lrdwf, iudqwf, nrec, - 1)
|
||||
wrk = DCMPLX (0.d0, 0.d0)
|
||||
do ibnd = 1, nbnd
|
||||
if (degauss.ne.0.d0) wg1 = wk (ikk) * wga (ibnd)
|
||||
wrk = wrk + 2.d0 * wg1 * ZDOTC (npwq, dvpsi (1, ibnd), 1, &
|
||||
dqpsi (1, ibnd), 1)
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call reduce (2, wrk)
|
||||
#endif
|
||||
d3dyn2 (nu_i, nu_z, nu_j) = d3dyn2 (nu_i, nu_z, nu_j) + wrk
|
||||
d3dyn3 (nu_i, nu_j, nu_z) = d3dyn3 (nu_i, nu_j, nu_z) + conjg(wrk)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
endif
|
||||
#ifdef PARA
|
||||
call poolreduce (2 * 27 * nat * nat * nat, d3dyn1)
|
||||
if (.not.allmodes) then
|
||||
call poolreduce (2 * 27 * nat * nat * nat, d3dyn2)
|
||||
call poolreduce (2 * 27 * nat * nat * nat, d3dyn3)
|
||||
endif
|
||||
#endif
|
||||
do nu_i = 1, 3 * nat
|
||||
do nu_j = 1, 3 * nat
|
||||
do nu_z = 1, 3 * nat
|
||||
if (allmodes) then
|
||||
d3dyn (nu_i, nu_j, nu_z) = d3dyn (nu_i, nu_j, nu_z) + &
|
||||
d3dyn1(nu_i, nu_j, nu_z) + &
|
||||
d3dyn1(nu_j, nu_z, nu_i) + &
|
||||
d3dyn1(nu_z, nu_i, nu_j)
|
||||
d3dyn_aux5 (nu_i, nu_j, nu_z) = d3dyn_aux5 (nu_i, nu_j, nu_z) &
|
||||
+ d3dyn1 (nu_i, nu_j, nu_z) + d3dyn1 (nu_j, nu_z, nu_i) &
|
||||
+ d3dyn1 (nu_z, nu_i, nu_j)
|
||||
else
|
||||
d3dyn (nu_i, nu_j, nu_z) = d3dyn (nu_i, nu_j, nu_z) + &
|
||||
d3dyn1(nu_i, nu_j, nu_z) + &
|
||||
d3dyn2(nu_i, nu_j, nu_z) + &
|
||||
d3dyn3(nu_i, nu_j, nu_z)
|
||||
d3dyn_aux5 (nu_i, nu_j, nu_z) = d3dyn_aux5 (nu_i, nu_j, nu_z) &
|
||||
+ d3dyn1 (nu_i, nu_j, nu_z) + d3dyn2 (nu_i, nu_j, nu_z) &
|
||||
+ d3dyn3 (nu_i, nu_j, nu_z)
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
if (.not.allmodes) then
|
||||
call mfree (d3dyn3)
|
||||
call mfree (d3dyn2)
|
||||
endif
|
||||
call mfree (d3dyn1)
|
||||
call mfree (dqpsi)
|
||||
call mfree (dvloc)
|
||||
return
|
||||
end subroutine dpsidvdpsi
|
||||
|
|
@ -0,0 +1,232 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!----------------------------------------------------------------------
|
||||
|
||||
subroutine dqrhod2v (ipert, drhoscf)
|
||||
!-----------------------------------------------------------------------
|
||||
! calculates the term containing the second variation of the potential
|
||||
! and the first variation of the charge density with respect to a
|
||||
! perturbation at a generic q
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
use allocate
|
||||
#ifdef PARA
|
||||
use para
|
||||
#endif
|
||||
implicit none
|
||||
integer :: ipert
|
||||
complex (8) :: drhoscf (nrxx)
|
||||
! the variation of the charge density
|
||||
!
|
||||
! local variables
|
||||
!
|
||||
integer :: icart, jcart, na_icart, na_jcart, na, ng, nt, &
|
||||
ik, ikk, ikq, ig, ibnd, nu_i, nu_j, nu_k, ikb, jkb, nrec, ios
|
||||
! index of the perturbation associated with drho
|
||||
! counter on polarizations
|
||||
! counter on polarizations
|
||||
! counter on modes
|
||||
! counter on modes
|
||||
! counter on atoms
|
||||
! counter on G vectors
|
||||
! counter on atomic types
|
||||
! counter on k points
|
||||
! counter on k points
|
||||
! counter on k+q points
|
||||
! counter on G vectors
|
||||
! counter on bands
|
||||
! counter on modes
|
||||
! counter on modes
|
||||
! counter on modes
|
||||
! counters on beta functions
|
||||
! record position of dwfc
|
||||
! integer variable for I/O control
|
||||
|
||||
real (8) :: gtau, wgg
|
||||
! the product G*\tau_s
|
||||
! the weight of a K point
|
||||
|
||||
complex (8) :: ZDOTC, fac, alpha (8), work
|
||||
complex (8), pointer :: d3dywrk (:,:), work0 (:), &
|
||||
work1 (:), work2 (:), work3 (:), work4 (:), work5 (:), work6 (:)
|
||||
! work space
|
||||
|
||||
call mallocate (d3dywrk, 3 * nat, 3 * nat)
|
||||
call mallocate (work0, nrxx)
|
||||
call mallocate (work1, npwx)
|
||||
call mallocate (work2, npwx)
|
||||
call mallocate (work3, npwx)
|
||||
call mallocate (work4, npwx)
|
||||
call mallocate (work5, npwx)
|
||||
call mallocate (work6, npwx)
|
||||
|
||||
call setv (2 * 9 * nat * nat, 0.0d0, d3dywrk, 1)
|
||||
!
|
||||
! Here the contribution deriving from the local part of the potential
|
||||
#ifdef PARA
|
||||
! ... computed only by the first pool (no sum over k needed)
|
||||
!
|
||||
if (mypool.ne.1) goto 100
|
||||
#endif
|
||||
!
|
||||
call ZCOPY (nrxx, drhoscf, 1, work0, 1)
|
||||
call cft3 (work0, nr1, nr2, nr3, nrx1, nrx2, nrx3, - 1)
|
||||
do na = 1, nat
|
||||
do icart = 1, 3
|
||||
na_icart = 3 * (na - 1) + icart
|
||||
do jcart = 1, 3
|
||||
na_jcart = 3 * (na - 1) + jcart
|
||||
do ng = 1, ngm
|
||||
gtau = tpi * ( (xq (1) + g (1, ng) ) * tau (1, na) + &
|
||||
(xq (2) + g (2, ng) ) * tau (2, na) + &
|
||||
(xq (3) + g (3, ng) ) * tau (3, na) )
|
||||
fac = DCMPLX (cos (gtau), - sin (gtau) )
|
||||
d3dywrk (na_icart, na_jcart) = d3dywrk (na_icart, na_jcart) &
|
||||
- tpiba2 * omega * (xq (icart) + g (icart, ng) ) * &
|
||||
(xq (jcart) + g (jcart, ng) ) * &
|
||||
vlocq (ng, ityp (na) ) * fac * conjg (work0 (nl (ng) ) )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call reduce (2 * 9 * nat * nat, d3dywrk)
|
||||
!
|
||||
! each pool contributes to next term
|
||||
!
|
||||
100 continue
|
||||
#endif
|
||||
!
|
||||
! Here we compute the nonlocal (Kleinman-Bylander) contribution.
|
||||
!
|
||||
rewind (unit = iunigk)
|
||||
|
||||
do ik = 1, nksq
|
||||
read (iunigk, err = 200, iostat = ios) npw, igk
|
||||
200 call error ('dqrhod2v', 'reading igk', abs (ios) )
|
||||
if (lgamma) then
|
||||
ikk = ik
|
||||
ikq = ik
|
||||
npwq = npw
|
||||
else
|
||||
ikk = 2 * ik - 1
|
||||
ikq = 2 * ik
|
||||
read (iunigk, err = 300, iostat = ios) npwq, igkq
|
||||
300 call error ('dqrhod2v', 'reading igkq', abs (ios) )
|
||||
endif
|
||||
wgg = wk (ikk)
|
||||
call davcio (evc, lrwfc, iuwfc, ikk, - 1)
|
||||
!
|
||||
! In metallic case it necessary to know the wave function at k+q point
|
||||
! so as to correct dpsi. dvpsi is used as working array
|
||||
!
|
||||
if (degauss.ne.0.d0) call davcio (dvpsi, lrwfc, iuwfc, ikq, -1)
|
||||
call init_us_2 (npwq, igkq, xk (1, ikq), vkb)
|
||||
call init_us_2 (npw, igk, xk (1, ikk), vkb0)
|
||||
!
|
||||
! Reads the first variation of the wavefunction projected on conduction
|
||||
!
|
||||
nrec = (ipert - 1) * nksq + ik
|
||||
call davcio (dpsi, lrdwf, iudqwf, nrec, - 1)
|
||||
!
|
||||
! In the metallic case corrects dpsi so as that the density matrix
|
||||
! will be: Sum_{k,nu} 2 * | dpsi > < psi |
|
||||
!
|
||||
if (degauss.ne.0.d0) then
|
||||
nrec = ipert + (ik - 1) * 3 * nat
|
||||
call davcio (psidqvpsi, lrpdqvp, iupdqvp, nrec, - 1)
|
||||
call dpsi_corr (dvpsi, psidqvpsi, ikk, ikq, ipert)
|
||||
endif
|
||||
!
|
||||
do icart = 1, 3
|
||||
do jcart = 1, 3
|
||||
do ibnd = 1, nbnd
|
||||
do ig = 1, npw
|
||||
work1(ig)=evc(ig,ibnd)*tpiba*(xk(icart,ikk)+g(icart,igk(ig)))
|
||||
work2(ig)=evc(ig,ibnd)*tpiba*(xk(jcart,ikk)+g(jcart,igk(ig)))
|
||||
work5(ig)= work1(ig)*tpiba*(xk(jcart,ikk)+g(jcart,igk(ig)))
|
||||
enddo
|
||||
do ig = 1, npwq
|
||||
work3(ig)=dpsi(ig,ibnd)*tpiba*(xk(icart,ikq)+g(icart,igkq(ig)))
|
||||
work4(ig)=dpsi(ig,ibnd)*tpiba*(xk(jcart,ikq)+g(jcart,igkq(ig)))
|
||||
work6(ig)= work3(ig)*tpiba*(xk(jcart,ikq)+g(jcart,igkq(ig)))
|
||||
enddo
|
||||
jkb=0
|
||||
do nt = 1, ntyp
|
||||
do na = 1, nat
|
||||
if (ityp (na).eq.nt) then
|
||||
na_icart = 3 * (na - 1) + icart
|
||||
na_jcart = 3 * (na - 1) + jcart
|
||||
do ikb = 1, nh (nt)
|
||||
jkb = jkb+1
|
||||
alpha(1) = ZDOTC(npw, work1, 1,vkb0(1,jkb), 1)
|
||||
alpha(2) = ZDOTC(npwq,vkb(1,jkb), 1, work4, 1)
|
||||
alpha(3) = ZDOTC(npw, work2, 1,vkb0(1,jkb), 1)
|
||||
alpha(4) = ZDOTC(npwq,vkb(1,jkb), 1, work3, 1)
|
||||
alpha(5) = ZDOTC(npw, work5, 1,vkb0(1,jkb), 1)
|
||||
alpha(6) = ZDOTC(npwq,vkb(1,jkb),1,dpsi(1,ibnd),1)
|
||||
alpha(7) = ZDOTC(npw, evc(1,ibnd),1,vkb0(1,jkb),1)
|
||||
alpha(8) = ZDOTC(npwq,vkb(1,jkb),1,work6, 1)
|
||||
#ifdef PARA
|
||||
call reduce(16, alpha)
|
||||
#endif
|
||||
d3dywrk(na_icart,na_jcart) = d3dywrk(na_icart,na_jcart) &
|
||||
+ conjg(alpha(1) * alpha(2) + alpha(3) * alpha(4) - &
|
||||
alpha(5) * alpha(6) - alpha(7) * alpha(8) ) &
|
||||
* dvan (ikb, ikb, nt) * wgg * 2.0d0
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
end do
|
||||
end do
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call poolreduce (2 * 9 * nat * nat, d3dywrk)
|
||||
#endif
|
||||
!
|
||||
! Rotate the dynamical matrix on the basis of patterns
|
||||
! some indices do not need to be rotated
|
||||
!
|
||||
nu_k = ipert
|
||||
do nu_i = 1, 3 * nat
|
||||
if (q0mode (nu_i) ) then
|
||||
do nu_j = 1, 3 * nat
|
||||
work = (0.0d0, 0.0d0)
|
||||
do na = 1, nat
|
||||
do icart = 1, 3
|
||||
na_icart = 3 * (na - 1) + icart
|
||||
do jcart = 1, 3
|
||||
na_jcart = 3 * (na - 1) + jcart
|
||||
work = work + ug0 (na_icart, nu_i) * &
|
||||
d3dywrk (na_icart,na_jcart) * u (na_jcart, nu_j)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
d3dyn (nu_i, nu_k, nu_j) = d3dyn (nu_i, nu_k, nu_j) + work
|
||||
d3dyn (nu_i, nu_j, nu_k) = d3dyn (nu_i, nu_j, nu_k) + conjg(work)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
|
||||
call mfree (work6)
|
||||
call mfree (work5)
|
||||
call mfree (work4)
|
||||
call mfree (work3)
|
||||
call mfree (work2)
|
||||
call mfree (work1)
|
||||
call mfree (work0)
|
||||
call mfree (d3dywrk)
|
||||
|
||||
return
|
||||
end subroutine dqrhod2v
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine drho_cc (iflag)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! Used when non_linear_core_correction are present to change the files
|
||||
! containing the variation of the charge
|
||||
! iflag = +1 :
|
||||
! adds the variation of the core charge to the variation of the
|
||||
! valence charge ( both for xq.eq.0 and xq.ne.0 )
|
||||
!
|
||||
! iflag = -1 :
|
||||
! subtracts the variation of the core charge to the variation of
|
||||
! the total charge --used to set drho and d0rho as they were
|
||||
! before the first call of drho_cc--
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
|
||||
implicit none
|
||||
integer :: iflag
|
||||
real (8) :: xq0 (3), scale
|
||||
|
||||
if (.not.nlcc_any) return
|
||||
scale = 1.d0
|
||||
|
||||
if (iflag.eq. - 1) scale = - 1.d0
|
||||
call setv (3, 0.d0, xq0, 1)
|
||||
call drho_drc (iud0rho, ug0, xq0, d0rc, scale)
|
||||
|
||||
if (.not.lgamma) call drho_drc (iudrho, u, xq, drc, scale)
|
||||
return
|
||||
end subroutine drho_cc
|
||||
|
|
@ -0,0 +1,92 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine drho_drc (iudrho_x, u_x, xq_x, drc_x, scale)
|
||||
!-----------------------------------------------------------------------
|
||||
! Reads the variation of the charge saved on a file and changes
|
||||
! it according to the variation of the core_charge
|
||||
! It is used by drho_cc. Have a look there for more explanation
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
use allocate
|
||||
#ifdef PARA
|
||||
use para
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef PARA
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
|
||||
integer :: iudrho_x
|
||||
!input: the unit containing the charge variation
|
||||
real (8) :: xq_x (3), scale
|
||||
!input: q point
|
||||
!input: drhocore will be added to the valence charge scaled by this factor
|
||||
complex (8) :: u_x (3 * nat, 3 * nat), drc_x (ngm, ntyp)
|
||||
!input: the transformation modes patterns
|
||||
!input: contain the rhoc (without structu
|
||||
|
||||
integer :: ipert, na, mu, nt, ig, errcode
|
||||
real (8) :: gtau
|
||||
complex (8) :: guexp
|
||||
complex (8), pointer :: drhoc (:), drhov (:), uact (:)
|
||||
|
||||
|
||||
call mallocate (drhoc, nrxx)
|
||||
call mallocate (drhov, nrxx)
|
||||
call mallocate (uact, 3 * nat)
|
||||
#ifdef PARA
|
||||
! if (mypool.ne.1) goto 100
|
||||
#endif
|
||||
|
||||
do ipert = 1, 3 * nat
|
||||
call setv (2 * nrxx, 0.d0, drhoc, 1)
|
||||
|
||||
call ZCOPY (3 * nat, u_x (1, ipert), 1, uact, 1)
|
||||
do na = 1, nat
|
||||
mu = 3 * (na - 1)
|
||||
if (abs (uact (mu + 1) ) + abs (uact (mu + 2) ) + abs (uact (mu + &
|
||||
3) ) .gt.1.0d-12) then
|
||||
nt = ityp (na)
|
||||
if (nlcc (nt) ) then
|
||||
do ig = 1, ngm
|
||||
gtau = tpi * ( (g (1, ig) + xq_x (1) ) * tau (1, na) &
|
||||
+ (g (2, ig) + xq_x (2) ) * tau (2, na) + (g (3, ig) &
|
||||
+ xq_x (3) ) * tau (3, na) )
|
||||
guexp = tpiba * ( (g (1, ig) + xq_x (1) ) * uact (mu + 1) &
|
||||
+ (g (2, ig) + xq_x (2) ) * uact (mu + 2) + (g (3, ig) &
|
||||
+ xq_x (3) ) * uact (mu + 3) ) * DCMPLX (0.d0, - 1.d0) &
|
||||
* DCMPLX (cos (gtau), - sin (gtau) )
|
||||
drhoc (nl (ig) ) = drhoc (nl (ig) ) + drc_x (ig, nt) &
|
||||
* guexp
|
||||
enddo
|
||||
endif
|
||||
endif
|
||||
|
||||
enddo
|
||||
call cft3 (drhoc, nr1, nr2, nr3, nrx1, nrx2, nrx3, + 1)
|
||||
call davcio_drho2 (drhov, lrdrho, iudrho_x, ipert, - 1)
|
||||
call DAXPY (2 * nrxx, scale, drhoc, 1, drhov, 1)
|
||||
|
||||
call davcio_drho2 (drhov, lrdrho, iudrho_x, ipert, + 1)
|
||||
enddo
|
||||
#ifdef PARA
|
||||
100 continue
|
||||
call MPI_barrier (MPI_COMM_WORLD, errcode)
|
||||
|
||||
call error ('drho_drc', 'at barrier', errcode)
|
||||
#endif
|
||||
call mfree (drhoc)
|
||||
call mfree (drhov)
|
||||
call mfree (uact)
|
||||
return
|
||||
end subroutine drho_drc
|
||||
|
|
@ -0,0 +1,55 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine drhod2v
|
||||
!-----------------------------------------------------------------------
|
||||
! It calls the routines which calculate the term containing the first
|
||||
! variation of the charge and the secon variation of the potential with
|
||||
! respect to the perturbation.
|
||||
! d0rhod2v: contains the terms depending on the first variation of the c
|
||||
! with respect to a perturbaation at q=0
|
||||
! dqrhod2v: contains the terms depending on the first variation of the c
|
||||
! with respect to a perturbaation at a generic q
|
||||
! The variation of the charge can be read from a file or calculated dire
|
||||
! --this last option is to be used for testing pourposes--
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
use allocate
|
||||
!
|
||||
implicit none
|
||||
integer :: irr, irr1, imode0, ipert, ir
|
||||
real (8) :: xq0 (3)
|
||||
complex (8), pointer :: drhoscf (:)
|
||||
! the change of density due to perturbations
|
||||
|
||||
call mallocate (drhoscf, nrxx)
|
||||
|
||||
call read_ef
|
||||
if (.not.allmodes) then
|
||||
do ipert = 1, 3 * nat
|
||||
call davcio_drho (drhoscf, lrdrho, iudrho, ipert, - 1)
|
||||
call dqrhod2v (ipert, drhoscf)
|
||||
enddo
|
||||
|
||||
endif
|
||||
do ipert = 1, 3 * nat
|
||||
if (q0mode (ipert) ) then
|
||||
call davcio_drho (drhoscf, lrdrho, iud0rho, ipert, - 1)
|
||||
call d0rhod2v (ipert, drhoscf)
|
||||
endif
|
||||
|
||||
enddo
|
||||
|
||||
call mfree (drhoscf)
|
||||
return
|
||||
|
||||
end subroutine drhod2v
|
||||
|
|
@ -0,0 +1,126 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine dvdpsi (nu_i, xq_, dvloc, vkb_, vkbq_, psi_, dvpsi_)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! Receives in input the variation of the local part of the KS-potential
|
||||
! and calculates dV(xq_)_KS*psi_ in G_space, for all bands
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
use allocate
|
||||
!
|
||||
implicit none
|
||||
integer :: nu_i
|
||||
! input: the mode under consideration
|
||||
real (8) :: xq_ (3)
|
||||
! input: coordinates of the q point describing the perturbation
|
||||
complex (8) :: dvloc (nrxx), psi_ (npwx, nbnd), dvpsi_ (npwx, nbnd)
|
||||
! input: local part of the KS potential
|
||||
! input: wavefunction
|
||||
! output: variation of the KS potential applied to psi_
|
||||
complex(8) :: vkb_(npwx,nkb), vkbq_(npwx,nkb)
|
||||
!
|
||||
! Local variables
|
||||
!
|
||||
integer :: na, mu, ig, igg, ir, ibnd, nt, ikb, jkb
|
||||
! counter on atoms
|
||||
! counter on modes
|
||||
! counter on G vectors
|
||||
! counter on G vectors
|
||||
! counter on real space points
|
||||
! counter on bands
|
||||
! counter on atomic types
|
||||
! counters on beta functions
|
||||
complex (8), pointer :: u_x (:,:), aux (:), ps (:,:), wrk2 (:)
|
||||
! the transformation modes patterns
|
||||
! work space
|
||||
complex (8) :: ZDOTC
|
||||
logical :: q_eq_zero
|
||||
!
|
||||
call mallocate (aux, nrxx)
|
||||
call mallocate (ps, 2, nbnd)
|
||||
call mallocate (wrk2, npwx)
|
||||
q_eq_zero = xq_ (1) .eq.0.d0.and.xq_ (2) .eq.0.d0.and.xq_ (3) .eq.0.d0
|
||||
if (q_eq_zero) then
|
||||
u_x => ug0
|
||||
else
|
||||
u_x => u
|
||||
endif
|
||||
!
|
||||
do ibnd = 1, nbnd
|
||||
call setv (2 * nrxxs, 0.d0, aux, 1)
|
||||
do ig = 1, npw
|
||||
aux (nls (igk (ig) ) ) = psi_ (ig, ibnd)
|
||||
enddo
|
||||
call cft3s (aux, nr1s, nr2s, nr3s, nrx1s, nrx2s, nrx3s, + 2)
|
||||
do ir = 1, nrxxs
|
||||
aux (ir) = aux (ir) * dvloc (ir)
|
||||
enddo
|
||||
call cft3s (aux, nr1s, nr2s, nr3s, nrx1s, nrx2s, nrx3s, - 2)
|
||||
do ig = 1, npwq
|
||||
dvpsi_ (ig, ibnd) = aux (nls (igkq (ig) ) )
|
||||
enddo
|
||||
enddo
|
||||
!
|
||||
! Now the contribution of the non local part in the KB form
|
||||
!
|
||||
jkb=0
|
||||
do nt = 1, ntyp
|
||||
do na = 1, nat
|
||||
if (ityp (na).eq.nt) then
|
||||
mu = 3 * (na - 1)
|
||||
do ikb = 1, nh (nt)
|
||||
jkb = jkb+1
|
||||
if (abs (u_x (mu + 1, nu_i) ) + abs (u_x (mu + 2, nu_i) ) + &
|
||||
abs (u_x (mu + 3, nu_i) ) .gt.1.0d-12) then
|
||||
!
|
||||
! first term: sum_l v_l beta_l(k+q+G) \sum_G' beta^*_l(k+G') (iG'*u) psi
|
||||
! second term: sum_l E_l(-i(q+G)*u) beta_l(k+q+G)\sum_G'beta^*_l(k+G')ps
|
||||
!
|
||||
do ig = 1, npw
|
||||
wrk2 (ig) = vkb_(ig,jkb) * &
|
||||
conjg(DCMPLX(0.d0,1.d0) *tpiba * &
|
||||
(g (1, igk (ig) ) * u_x (mu + 1, nu_i) + &
|
||||
g (2, igk (ig) ) * u_x (mu + 2, nu_i) + &
|
||||
g (3, igk (ig) ) * u_x (mu + 3, nu_i) ) )
|
||||
enddo
|
||||
do ibnd = 1, nbnd
|
||||
ps(1,ibnd) = dvan(ikb,ikb,nt) * &
|
||||
ZDOTC(npw, wrk2, 1, psi_(1,ibnd), 1)
|
||||
ps(2,ibnd) = dvan(ikb,ikb,nt) * &
|
||||
ZDOTC(npw,vkb_(1,jkb),1,psi_(1,ibnd),1)
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call reduce (4 * nbnd, ps)
|
||||
#endif
|
||||
do ig = 1, npwq
|
||||
wrk2 (ig) = vkbq_(ig,jkb) * DCMPLX(0.d0,-1.d0) * tpiba * &
|
||||
( (g (1, igkq (ig) ) + xq_ (1) ) * u_x (mu+1, nu_i) +&
|
||||
(g (2, igkq (ig) ) + xq_ (2) ) * u_x (mu+2, nu_i) +&
|
||||
(g (3, igkq (ig) ) + xq_ (3) ) * u_x (mu+3, nu_i) )
|
||||
enddo
|
||||
|
||||
do ibnd = 1, nbnd
|
||||
call ZAXPY(npwq,ps(1,ibnd),vkbq_(1,jkb),1,dvpsi_(1,ibnd),1)
|
||||
call ZAXPY(npwq,ps(2,ibnd), wrk2, 1,dvpsi_(1,ibnd),1)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
call mfree (wrk2)
|
||||
call mfree (ps)
|
||||
call mfree (aux)
|
||||
return
|
||||
end subroutine dvdpsi
|
||||
|
|
@ -0,0 +1,127 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine dvscf (nu_i, dvloc, xq_x)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! It reads the variation of the charge density from a file and
|
||||
! calculates the variation of the local part of the variation of the
|
||||
! K-S potential.
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
use allocate
|
||||
!
|
||||
implicit none
|
||||
integer :: nu_i
|
||||
! input: mode under consideration
|
||||
real (8) :: xq_x (3)
|
||||
! input: coordinates of the q point
|
||||
complex (8) :: dvloc (nrxx)
|
||||
! output: local part of the variation
|
||||
! of the K_S potential
|
||||
!
|
||||
! Local variables
|
||||
!
|
||||
|
||||
integer :: iudrho_x, ig, ir, mu, na, nt
|
||||
! unit containing the charge variation
|
||||
! counter on G points
|
||||
! counter on real mesh
|
||||
! counter on modes
|
||||
! counter on atoms
|
||||
! the type of atom
|
||||
|
||||
real (8) :: qg2, gtau
|
||||
! the modulus of (q+G)^2
|
||||
! auxiliary variable: g*tau
|
||||
|
||||
complex (8) :: guexp
|
||||
! auxiliary variable: g*u*exp(gtau)
|
||||
|
||||
real (8), pointer :: vloc_x (:,:)
|
||||
! the local potential at G+q
|
||||
complex (8), pointer :: u_x(:,:), drc_x (:,:), aux1 (:), aux2 (:)
|
||||
! the transformation modes patterns
|
||||
! contain drho_core for all atomic types
|
||||
logical :: q_eq_zero
|
||||
! true if xq equal zero
|
||||
|
||||
call mallocate (aux1, nrxx)
|
||||
call mallocate (aux2, nrxx)
|
||||
|
||||
q_eq_zero = xq_x(1).eq.0.d0 .and. xq_x(2).eq.0.d0 .and. xq_x(3).eq.0.d0
|
||||
if (q_eq_zero) then
|
||||
u_x => ug0
|
||||
drc_x => d0rc
|
||||
vloc_x => vlocg0
|
||||
iudrho_x = iud0rho
|
||||
else
|
||||
u_x => u
|
||||
drc_x => drc
|
||||
vloc_x => vlocq
|
||||
iudrho_x = iudrho
|
||||
endif
|
||||
|
||||
call davcio_drho (aux2, lrdrho, iudrho_x, nu_i, - 1)
|
||||
do ir = 1, nrxx
|
||||
dvloc (ir) = aux2(ir) * dmuxc(ir,1,1)
|
||||
enddo
|
||||
|
||||
call cft3 (aux2, nr1, nr2, nr3, nrx1, nrx2, nrx3, - 1)
|
||||
call setv (2 * nrxx, 0.d0, aux1, 1)
|
||||
do ig = 1, ngm
|
||||
qg2 = (g(1,ig)+xq_x(1))**2 + (g(2,ig)+xq_x(2))**2 + (g(3,ig)+xq_x(3))**2
|
||||
if (qg2.gt.1.d-8) then
|
||||
aux1(nl(ig)) = e2 * fpi * aux2(nl(ig)) / (tpiba2 * qg2)
|
||||
endif
|
||||
|
||||
enddo
|
||||
|
||||
if (nlcc_any) call setv (2 * nrxx, 0.d0, aux2, 1)
|
||||
do na = 1, nat
|
||||
mu = 3 * (na - 1)
|
||||
if (abs(u_x(mu+1,nu_i)) + abs(u_x(mu+2,nu_i)) + &
|
||||
abs(u_x(mu+3,nu_i)) .gt. 1.0d-12) then
|
||||
nt = ityp (na)
|
||||
do ig = 1, ngm
|
||||
|
||||
gtau = tpi * ( (g(1,ig) + xq_x(1)) * tau(1,na) + &
|
||||
(g(2,ig) + xq_x(2)) * tau(2,na) + &
|
||||
(g(3,ig) + xq_x(3)) * tau(3,na) )
|
||||
|
||||
guexp = tpiba * ( (g(1,ig) + xq_x(1)) * u_x(mu+1,nu_i) + &
|
||||
(g(2,ig) + xq_x(2)) * u_x(mu+2,nu_i) + &
|
||||
(g(3,ig) + xq_x(3)) * u_x(mu+3,nu_i) ) * &
|
||||
DCMPLX(0.d0,-1.d0) * DCMPLX(cos(gtau),-sin(gtau))
|
||||
aux1 (nl(ig)) = aux1 (nl(ig)) + vloc_x (ig,nt) * guexp
|
||||
if (nlcc(nt)) aux2 (nl(ig)) = aux2 (nl(ig)) + drc_x(ig,nt) * guexp
|
||||
enddo
|
||||
endif
|
||||
|
||||
enddo
|
||||
call cft3 (aux1, nr1, nr2, nr3, nrx1, nrx2, nrx3, + 1)
|
||||
|
||||
call DAXPY (2 * nrxx, 1.d0, aux1, 1, dvloc, 1)
|
||||
if (nlcc_any) then
|
||||
call cft3 (aux2, nr1, nr2, nr3, nrx1, nrx2, nrx3, + 1)
|
||||
do ir = 1, nrxx
|
||||
aux2 (ir) = aux2 (ir) * dmuxc(ir,1,1)
|
||||
enddo
|
||||
call DAXPY (2 * nrxx, 1.d0, aux2, 1, dvloc, 1)
|
||||
|
||||
endif
|
||||
|
||||
if (doublegrid) call cinterpolate (dvloc, dvloc, - 1)
|
||||
call mfree (aux1)
|
||||
call mfree (aux2)
|
||||
return
|
||||
end subroutine dvscf
|
||||
|
|
@ -0,0 +1,133 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine gen_dpdvp
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! It calculates the scalar product < Pc dpsi/du | dH/du | psi > and
|
||||
! writes it on a file. Used in the metallic case.
|
||||
! Three files are used:
|
||||
! iudpdvp_1 : < Pc dpsi_k/du(-q) | dH/du(q) | psi_k >
|
||||
! iudpdvp_2 : < Pc dpsi_k/du(-q) | dH/du(0) | psi_{k+q} >
|
||||
! iudpdvp_3 : < Pc dpsi_{k+q}/du(0) | dH/du(q) | psi_k >
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
use allocate
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: ik, ikk, ikq, ig, nrec, nu_i, nu_j, ibnd, jbnd, ios
|
||||
|
||||
real (8) :: zero (3)
|
||||
complex (8) :: ZDOTC
|
||||
complex (8), pointer :: dvloc (:), dpsidvpsi (:,:)
|
||||
|
||||
|
||||
if (degauss.eq.0.d0) return
|
||||
call mallocate(dvloc, nrxx)
|
||||
call mallocate(dpsidvpsi, nbnd, nbnd)
|
||||
rewind (unit = iunigk)
|
||||
|
||||
call setv (3, 0.d0, zero, 1)
|
||||
|
||||
do ik = 1, nksq
|
||||
read (iunigk, err = 100, iostat = ios) npw, igk
|
||||
if (lgamma) then
|
||||
ikk = ik
|
||||
ikq = ik
|
||||
npwq = npw
|
||||
else
|
||||
ikk = 2 * ik - 1
|
||||
ikq = 2 * ik
|
||||
read (iunigk, err = 100, iostat = ios) npwq, igkq
|
||||
endif
|
||||
100 call error ('gen_dpdvp', 'reading iunigk-iunigkq', abs (ios) )
|
||||
call init_us_2 (npw, igk, xk (1, ikk), vkb0)
|
||||
call init_us_2 (npwq, igkq, xk (1, ikq), vkb)
|
||||
|
||||
call davcio (evc, lrwfc, iuwfc, ikk, - 1)
|
||||
|
||||
if (.not.lgamma) call davcio (evq, lrwfc, iuwfc, ikq, - 1)
|
||||
do nu_j = 1, 3 * nat
|
||||
call dvscf (nu_j, dvloc, xq)
|
||||
call dvdpsi (nu_j, xq, dvloc, vkb0, vkb, evc, dvpsi)
|
||||
do nu_i = 1, 3 * nat
|
||||
nrec = (nu_i - 1) * nksq + ik
|
||||
|
||||
call davcio (dpsi, lrdwf, iudqwf, nrec, - 1)
|
||||
do ibnd = 1, nbnd
|
||||
do jbnd = 1, nbnd
|
||||
dpsidvpsi (ibnd, jbnd) = &
|
||||
ZDOTC (npwq, dpsi (1,ibnd), 1, dvpsi (1,jbnd), 1)
|
||||
enddo
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call reduce (2 * nbnd * nbnd, dpsidvpsi)
|
||||
#endif
|
||||
nrec = nu_i + (nu_j - 1) * 3 * nat + (ik - 1) * 9 * nat * nat
|
||||
call davcio (dpsidvpsi, lrdpdvp, iudpdvp_1, nrec, + 1)
|
||||
enddo
|
||||
|
||||
if (.not.lgamma) then
|
||||
do nu_i = 1, 3 * nat
|
||||
nrec = (nu_i - 1) * nksq + ik
|
||||
call davcio (dpsi, lrdwf, iud0qwf, nrec, - 1)
|
||||
do ibnd = 1, nbnd
|
||||
do jbnd = 1, nbnd
|
||||
dpsidvpsi (ibnd, jbnd) = &
|
||||
ZDOTC (npwq, dpsi (1, ibnd), 1, dvpsi (1, jbnd), 1)
|
||||
enddo
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call reduce (2 * nbnd * nbnd, dpsidvpsi)
|
||||
#endif
|
||||
nrec = nu_i + (nu_j - 1) * 3 * nat + (ik - 1) * 9 * nat * nat
|
||||
call davcio (dpsidvpsi, lrdpdvp, iudpdvp_3, nrec, + 1)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
|
||||
if (.not.lgamma) then
|
||||
npw = npwq
|
||||
do ig = 1, npwx
|
||||
igk (ig) = igkq (ig)
|
||||
enddo
|
||||
do nu_j = 1, 3 * nat
|
||||
call dvscf (nu_j, dvloc, zero)
|
||||
|
||||
call dvdpsi (nu_j, zero, dvloc, vkb,vkb, evq, dvpsi)
|
||||
do nu_i = 1, 3 * nat
|
||||
nrec = (nu_i - 1) * nksq + ik
|
||||
|
||||
call davcio (dpsi, lrdwf, iudqwf, nrec, - 1)
|
||||
do ibnd = 1, nbnd
|
||||
do jbnd = 1, nbnd
|
||||
dpsidvpsi (ibnd, jbnd) = &
|
||||
ZDOTC (npwq, dpsi (1,ibnd), 1, dvpsi(1,jbnd), 1)
|
||||
enddo
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call reduce (2 * nbnd * nbnd, dpsidvpsi)
|
||||
#endif
|
||||
nrec = nu_i + (nu_j - 1) * 3 * nat + (ik - 1) * 9 * nat * nat
|
||||
|
||||
call davcio (dpsidvpsi, lrdpdvp, iudpdvp_2, nrec, + 1)
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
|
||||
call close_open (4)
|
||||
call mfree (dvloc)
|
||||
call mfree (dpsidvpsi)
|
||||
return
|
||||
end subroutine gen_dpdvp
|
||||
|
|
@ -0,0 +1,83 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine gen_dwfc (isw_sl)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! Calculates and writes | d/du(0) psi(k+q) >
|
||||
!
|
||||
! Several cases are possible:
|
||||
! isw_sl = 1 : it calculates | d/du(q) psi_k >
|
||||
! isw_sl = 2 : it calculates | d/du(0) psi_k+q >
|
||||
! isw_sl = 3,4 : it calculates | d/du(0) psi_k >
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
#ifdef PARA
|
||||
use para
|
||||
#endif
|
||||
implicit none
|
||||
integer isw_sl, nirr_x, irr, irr1, imode0
|
||||
! switch
|
||||
! the number of irreducible representation
|
||||
! counter on the representations
|
||||
! counter on the representations
|
||||
! counter on the modes
|
||||
integer, pointer:: npert_x (:)
|
||||
! the number of perturbations per IR
|
||||
|
||||
if (isw_sl.eq.1) then
|
||||
nirr_x = nirr
|
||||
npert_x => npert
|
||||
else
|
||||
nirr_x = nirrg0
|
||||
npert_x => npertg0
|
||||
endif
|
||||
!
|
||||
! For each irreducible representation we compute the change
|
||||
! of the wavefunctions
|
||||
!
|
||||
do irr = 1, nirr_x
|
||||
imode0 = 0
|
||||
do irr1 = 1, irr - 1
|
||||
imode0 = imode0 + npert_x (irr1)
|
||||
enddo
|
||||
if (npert_x (irr) .eq.1) then
|
||||
write (6, '(//,5x,"Representation #", i3, &
|
||||
& " mode # ",i3)') irr, imode0 + 1
|
||||
else
|
||||
write (6, '(//,5x,"Representation #", i3, &
|
||||
& " modes # ",3i3)') irr, (imode0 + irr1, irr1 = &
|
||||
& 1, npert_x (irr) )
|
||||
|
||||
endif
|
||||
call solve_linter_d3 (irr, imode0, npert_x (irr), isw_sl)
|
||||
enddo
|
||||
!
|
||||
! Writes FermiEnergy shift on a file
|
||||
!
|
||||
#ifdef PARA
|
||||
if (me.ne.1.or.mypool.ne.1) goto 210
|
||||
#endif
|
||||
if (isw_sl.eq.3.and.degauss.ne.0.d0) then
|
||||
rewind (unit = iuef)
|
||||
write (iuef) ef_sh
|
||||
endif
|
||||
#ifdef PARA
|
||||
210 continue
|
||||
#endif
|
||||
!
|
||||
! closes and opens some units --useful in case of interrupted run--
|
||||
!
|
||||
|
||||
call close_open (isw_sl)
|
||||
return
|
||||
end subroutine gen_dwfc
|
||||
|
|
@ -0,0 +1,115 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine incdrhoscf2 (drhoscf, weight, ik, dbecsum, mode, flag)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! This routine computes the change of the charge density due to the
|
||||
! perturbation. It is called at the end of the computation of the
|
||||
! change of the wavefunction for a given k point.
|
||||
!
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use allocate
|
||||
|
||||
implicit none
|
||||
integer :: ik
|
||||
! input: the k point
|
||||
|
||||
real (8) :: weight
|
||||
! input: the weight of the k point
|
||||
complex (8) :: drhoscf (nrxxs), dbecsum (nhm * (nhm + 1) / 2, nat)
|
||||
! output: the change of the charge densit
|
||||
! inp/out: the accumulated dbec
|
||||
integer :: mode, flag
|
||||
! flag =1 if dpsi is used (in solve_linte
|
||||
! flag!=1 if dpsi is not used (in addusdd
|
||||
!
|
||||
! here the local variable
|
||||
!
|
||||
|
||||
real (8) :: wgt
|
||||
! the effective weight of the k point
|
||||
|
||||
complex (8), pointer :: psi (:), dpsic (:)
|
||||
! the wavefunctions in real space
|
||||
! the change of wavefunctions in real sp
|
||||
|
||||
integer :: ibnd, jbnd, ikk, ir, ig
|
||||
! counter on bands
|
||||
! counter on bands
|
||||
! the record ik
|
||||
! counter on mesh points
|
||||
! counter on G vectors
|
||||
|
||||
call start_clock ('incdrhoscf')
|
||||
call mallocate (dpsic, nrxxs)
|
||||
call mallocate (psi , nrxxs)
|
||||
wgt = 2.d0 * weight / omega
|
||||
if (lgamma) then
|
||||
ikk = ik
|
||||
else
|
||||
ikk = 2 * ik - 1
|
||||
endif
|
||||
!
|
||||
! dpsi contains the perturbed wavefunctions of this k point
|
||||
! evc contains the unperturbed wavefunctions of this k point
|
||||
!
|
||||
! do ibnd = 1,nbnd_occ(ikk)
|
||||
do ibnd = 1, nbnd
|
||||
call setv (2 * nrxxs, 0.d0, psi, 1)
|
||||
do ig = 1, npw
|
||||
psi (nls (igk (ig) ) ) = evc (ig, ibnd)
|
||||
enddo
|
||||
call cft3s (psi, nr1s, nr2s, nr3s, nrx1s, nrx2s, nrx3s, + 2)
|
||||
call setv (2 * nrxxs, 0.d0, dpsic, 1)
|
||||
!
|
||||
! here we add the term in the valence due to the change of the
|
||||
! constraint. dvpsi is used as work space, dpsi is unchanged
|
||||
!
|
||||
if (flag.eq.1) then
|
||||
call ZCOPY (npwx, dpsi (1, ibnd), 1, dvpsi (1, ibnd), 1)
|
||||
else
|
||||
call setv (2 * npwx, 0.d0, dvpsi (1, ibnd), 1)
|
||||
endif
|
||||
! call ZGEMM('N','N', npwq, nbnd, nbnd, (1.d0,0.d0),
|
||||
! + evq, npwx, prodval(1,1,mode),nbnd,
|
||||
! + (1.d0,0.d0),dvpsi,npwx)
|
||||
if (okvan) then
|
||||
call error ('incdrhoscf2', 'US not allowed', 1)
|
||||
! do jbnd=1,nbnd
|
||||
! call ZAXPY(npwq,prodval(jbnd,ibnd,mode),
|
||||
! + evq(1,jbnd),1,dvpsi(1,ibnd),1)
|
||||
! enddo
|
||||
endif
|
||||
do ig = 1, npwq
|
||||
dpsic (nls (igkq (ig) ) ) = dvpsi (ig, ibnd)
|
||||
enddo
|
||||
|
||||
call cft3s (dpsic, nr1s, nr2s, nr3s, nrx1s, nrx2s, nrx3s, + 2)
|
||||
do ir = 1, nrxxs
|
||||
drhoscf (ir) = drhoscf (ir) + wgt * conjg (psi (ir) ) * dpsic (ir)
|
||||
! if (ir.lt.20) write (6,*) drhoscf(ir)
|
||||
enddo
|
||||
|
||||
enddo
|
||||
call addusdbec (ik, wgt, dvpsi, dbecsum)
|
||||
! write(6,*) '*********************'
|
||||
! do ig=1,20
|
||||
! write(6,*) dbecsum(ig,1)
|
||||
! enddo
|
||||
! call stocall mallocate (ph(.true.)
|
||||
call mfree (psi)
|
||||
call mfree (dpsic)
|
||||
|
||||
call stop_clock ('incdrhoscf')
|
||||
return
|
||||
end subroutine incdrhoscf2
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
work.pc
|
||||
/home/giannozz/O-sesame/Modules/work.pc
|
||||
/home/giannozz/O-sesame/PW/work.pc
|
||||
/home/giannozz/O-sesame/PH/work.pc
|
||||
|
|
@ -0,0 +1,198 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
|
||||
subroutine openfild3
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! This subroutine opens all the files necessary for the
|
||||
! third derivative calculation.
|
||||
!
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
#ifdef PARA
|
||||
use para
|
||||
#endif
|
||||
|
||||
implicit none
|
||||
integer :: ios
|
||||
! integer variable for I/O control
|
||||
character (len=20) :: filint
|
||||
! the name of the file
|
||||
logical :: exst
|
||||
! logical variable to check file existe
|
||||
|
||||
|
||||
if (len_trim(filpun).eq.0) call error ('openfild3', 'wrong filpun name', 1)
|
||||
!
|
||||
! The file with the wavefunctions
|
||||
!
|
||||
iuwfc = 20
|
||||
|
||||
lrwfc = 2 * nbnd * npwx
|
||||
filint = trim(filpun) //'.wfc'
|
||||
call diropn (iuwfc, filint, lrwfc, exst)
|
||||
if (.not.exst) call error ('openfild3', 'file '//filint//' not found', 1)
|
||||
!
|
||||
! The file with deltaV_{bare} * psi
|
||||
!
|
||||
iubar = 21
|
||||
lrbar = 2 * nbnd * npwx
|
||||
filint = trim(filpun) //'.bar'
|
||||
call diropn (iubar, filint, lrbar, exst)
|
||||
if (recover.and..not.exst) call error ('openfild3', 'file bar not &
|
||||
&found', 1)
|
||||
!
|
||||
! The file with the solution delta psi
|
||||
!
|
||||
iudwf = 22
|
||||
lrdwf = 2 * nbnd * npwx
|
||||
filint = trim(filpun) //'.dwf'
|
||||
call diropn (iudwf, filint, lrdwf, exst)
|
||||
if (recover.and..not.exst) call error ('openfild3', 'file dwf not &
|
||||
&found', 1)
|
||||
!
|
||||
! Here the sequential files
|
||||
!
|
||||
! The igk at a given k (and k+q if q!=0)
|
||||
!
|
||||
iunigk = 24
|
||||
filint = trim(filpun) //'.igk'
|
||||
call seqopn (iunigk, filint, 'unformatted', exst)
|
||||
!
|
||||
! a formatted file which contains the dynamical matrix in cartesian
|
||||
! coordinates is opened in the current directory
|
||||
#ifdef PARA
|
||||
! ... by the first node only, other nodes write on unit 6 (i.e. /dev/null)
|
||||
!
|
||||
if (me.ne.1.or.mypool.ne.1) then
|
||||
iudyn = 6
|
||||
goto 100
|
||||
return
|
||||
endif
|
||||
#endif
|
||||
iudyn = 26
|
||||
open (unit = iudyn, file = fildyn, status = 'unknown', err = 110, &
|
||||
iostat = ios)
|
||||
110 call error ('openfild3', 'opening file'//fildyn, abs (ios) )
|
||||
rewind (iudyn)
|
||||
#ifdef PARA
|
||||
|
||||
|
||||
|
||||
100 continue
|
||||
#endif
|
||||
!cccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
||||
!
|
||||
! Variation of the charge density with respect to a perturbation
|
||||
! with a generic q
|
||||
!
|
||||
iudrho = 25
|
||||
iud0rho = 33
|
||||
if (lgamma) iud0rho = iudrho
|
||||
lrdrho = 2 * nrx1 * nrx2 * nrx3 * nspin
|
||||
#ifdef PARA
|
||||
!
|
||||
! is opened only by the first task of each pool
|
||||
!
|
||||
if (me.ne.1) goto 120
|
||||
#endif
|
||||
filint = trim(fildrho)
|
||||
call diropn (iudrho, filint, lrdrho, exst)
|
||||
!
|
||||
! Variation of the charge density with respect to a perturbation with q=
|
||||
! Not needed if q=0
|
||||
!
|
||||
if (.not.lgamma) then
|
||||
filint = trim(fild0rho)
|
||||
call diropn (iud0rho, filint, lrdrho, exst)
|
||||
endif
|
||||
#ifdef PARA
|
||||
120 continue
|
||||
#endif
|
||||
!
|
||||
! If q=0, we need only one file with the variation of the wavefunctions
|
||||
!
|
||||
iud0qwf = iudwf
|
||||
iudqwf = iudwf
|
||||
if (.not.lgamma) then
|
||||
!
|
||||
! Open the file with the solution q=0 delta psi
|
||||
!
|
||||
iud0qwf = 34
|
||||
filint = trim(filpun) //'.d0wf'
|
||||
call diropn (iud0qwf, filint, lrdwf, exst)
|
||||
!
|
||||
! Open the file with the solution q=0 delta psi
|
||||
!
|
||||
iudqwf = 35
|
||||
filint = trim(filpun) //'.dqwf'
|
||||
call diropn (iudqwf, filint, lrdwf, exst)
|
||||
endif
|
||||
!
|
||||
! The file with <psi| dqV |psi>
|
||||
!
|
||||
iupdqvp = 36
|
||||
lrpdqvp = 2 * nbnd * nbnd
|
||||
filint = trim(filpun) //'.pdp'
|
||||
call diropn (iupdqvp, filint, lrpdqvp, exst)
|
||||
!
|
||||
! The file with <psi| d0V |psi>
|
||||
!
|
||||
iupd0vp = iupdqvp
|
||||
if (.not.lgamma) then
|
||||
iupd0vp = 37
|
||||
filint = trim(filpun) //'.p0p'
|
||||
call diropn (iupd0vp, filint, lrpdqvp, exst)
|
||||
|
||||
endif
|
||||
if (degauss.ne.0.d0) then
|
||||
!
|
||||
! The file with <dqpsi| dqV |psi> (only in the metallic case)
|
||||
!
|
||||
iudpdvp_1 = 38
|
||||
lrdpdvp = 2 * nbnd * nbnd
|
||||
filint = trim(filpun) //'.pv1'
|
||||
call diropn (iudpdvp_1, filint, lrdpdvp, exst)
|
||||
!
|
||||
! The file with <dqpsi| d0V |psi>
|
||||
!
|
||||
iudpdvp_2 = iudpdvp_1
|
||||
iudpdvp_3 = iudpdvp_1
|
||||
if (.not.lgamma) then
|
||||
iudpdvp_2 = 39
|
||||
filint = trim(filpun) //'.pv2'
|
||||
call diropn (iudpdvp_2, filint, lrdpdvp, exst)
|
||||
!
|
||||
! The file with <d0psi| dqV |psi>
|
||||
!
|
||||
iudpdvp_3 = 40
|
||||
filint = trim(filpun) //'.pv3'
|
||||
call diropn (iudpdvp_3, filint, lrdpdvp, exst)
|
||||
endif
|
||||
!
|
||||
! The file containing the variation of the FermiEnergy ef_sh
|
||||
#ifdef PARA
|
||||
! opened only by the first task of the first pool
|
||||
!
|
||||
|
||||
if (me.ne.1.or.mypool.ne.1) goto 130
|
||||
#endif
|
||||
iuef = 41
|
||||
filint = trim(filpun) //'.efs'
|
||||
call seqopn (iuef, filint, 'unformatted', exst)
|
||||
#ifdef PARA
|
||||
|
||||
130 continue
|
||||
#endif
|
||||
|
||||
endif
|
||||
return
|
||||
end subroutine openfild3
|
||||
|
|
@ -0,0 +1,60 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
|
||||
subroutine print_clock_d3
|
||||
|
||||
use d3com
|
||||
implicit none
|
||||
write (6, * )
|
||||
call print_clock ('D3TOTEN')
|
||||
call print_clock ('d3_setup')
|
||||
|
||||
call print_clock ('phq_init')
|
||||
write (6, * )
|
||||
call print_clock ('solve_linter')
|
||||
call print_clock ('ortho')
|
||||
call print_clock ('cgsolve')
|
||||
call print_clock ('incdrhoscf')
|
||||
call print_clock ('dv_of_drho')
|
||||
#ifdef PARA
|
||||
call print_clock ('psymdvscf')
|
||||
call print_clock ('psymd0rho')
|
||||
#else
|
||||
|
||||
call print_clock ('symdvscf')
|
||||
#endif
|
||||
write (6, * )
|
||||
call print_clock ('cgsolve')
|
||||
|
||||
call print_clock ('ch_psi')
|
||||
write (6, * )
|
||||
call print_clock ('ch_psi')
|
||||
call print_clock ('h_psiq')
|
||||
|
||||
call print_clock ('last')
|
||||
write (6, * )
|
||||
call print_clock ('h_psiq')
|
||||
call print_clock ('firstfft')
|
||||
call print_clock ('product')
|
||||
|
||||
call print_clock ('secondfft')
|
||||
write (6, * )
|
||||
write (6, * ) ' General routines'
|
||||
call print_clock ('ccalbec')
|
||||
call print_clock ('cft3')
|
||||
call print_clock ('cft3s')
|
||||
call print_clock ('cinterpolate')
|
||||
call print_clock ('davcio')
|
||||
write (6, * )
|
||||
#ifdef PARA
|
||||
write (6, * ) ' Parallel routines'
|
||||
call print_clock ('reduce')
|
||||
call print_clock ('poolreduce')
|
||||
#endif
|
||||
return
|
||||
end subroutine print_clock_d3
|
||||
|
|
@ -0,0 +1,63 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
|
||||
subroutine psymd0rho (nper, irr, dvtosym)
|
||||
!-----------------------------------------------------------------------
|
||||
! p-symmetrize the charge density.
|
||||
!
|
||||
#include "machine.h"
|
||||
#ifdef PARA
|
||||
use allocate
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
use para
|
||||
|
||||
implicit none
|
||||
integer :: nper, irr
|
||||
! the number of perturbations
|
||||
! the representation under consideration
|
||||
|
||||
complex (8) :: dvtosym (nrxx, nper)
|
||||
! the potential to symmetrize
|
||||
|
||||
! local variables
|
||||
|
||||
integer :: i, iper, npp0
|
||||
complex (8),pointer :: ddvtosym (:,:)
|
||||
! the potential to symmetrize
|
||||
|
||||
! if (nsymq.eq.1.and. (.not.minus_q) ) return
|
||||
|
||||
call start_clock ('psymd0rho')
|
||||
|
||||
call mallocate( ddvtosym, nrx1 * nrx2 * nrx3, nper)
|
||||
npp0 = 0
|
||||
do i = 1, me-1
|
||||
npp0 = npp0 + npp (i)
|
||||
enddo
|
||||
|
||||
npp0 = npp0 * ncplane+1
|
||||
do iper = 1, nper
|
||||
call cgather_sym (dvtosym (1, iper), ddvtosym (1, iper) )
|
||||
enddo
|
||||
|
||||
call symd0rho (nper, irr, ddvtosym, s, ftau, nsymg0, irgq, tg0, &
|
||||
nat, nr1, nr2, nr3, nrx1, nrx2, nrx3)
|
||||
do iper = 1, nper
|
||||
call ZCOPY (npp (me) * ncplane, ddvtosym (npp0, iper), 1, dvtosym &
|
||||
(1, iper), 1)
|
||||
enddo
|
||||
call mfree(ddvtosym)
|
||||
|
||||
call stop_clock ('psymd0rho')
|
||||
#endif
|
||||
return
|
||||
end subroutine psymd0rho
|
||||
|
|
@ -0,0 +1,158 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine qstar_d3 (d3dyn, at, bg, nat, nsym, s, invs, irt, rtau, &
|
||||
nq, sxq, isq, imq, iudyn, wrmode)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
#include "machine.h"
|
||||
use allocate
|
||||
implicit none
|
||||
!
|
||||
! input variables
|
||||
!
|
||||
|
||||
integer :: nat, nsym, s (3, 3, 48), invs (48), irt (48, nat), &
|
||||
nq, isq (48), imq, iudyn
|
||||
! number of atoms in the unit cell
|
||||
! number of symmetry operations
|
||||
! the symmetry operations
|
||||
! index of the inverse operations
|
||||
! index of the rotated atom
|
||||
! degeneracy of the star of q
|
||||
! symmetry op. giving the rotated q
|
||||
! index of -q in the star (0 if nont present)
|
||||
! unit number
|
||||
|
||||
complex (8) :: d3dyn (3 * nat, 3 * nat, 3 * nat)
|
||||
! the dynmatrix derivative
|
||||
|
||||
real (8) :: at (3, 3), bg (3, 3), rtau (3, 48, nat), sxq (3, 48)
|
||||
! direct lattice vectors
|
||||
! reciprocal lattice vectors
|
||||
! for eaxh atom and rotation gives the
|
||||
! R vector involved
|
||||
! list of q in the star
|
||||
logical :: wrmode (3 * nat )
|
||||
! if .true. this mode is to be written
|
||||
!
|
||||
! local variables
|
||||
!
|
||||
|
||||
integer :: iq, nsq, isym, na, nb, nc, icar, jcar, kcar, i, j, k
|
||||
! counter on q vectors
|
||||
! number of sym.op. giving each q in the list
|
||||
! index of a symm.op.
|
||||
! counters on atoms
|
||||
! counters on atoms
|
||||
! counters on atoms
|
||||
! cartesian coordinate counters
|
||||
! cartesian coordinate counters
|
||||
! cartesian coordinate counters
|
||||
! generic counters
|
||||
|
||||
complex (8), pointer :: phi (:,:,:,:,:,:), phi2 (:,:,:,:,:,:)
|
||||
! an auxiliary dyn. matrix.
|
||||
! another one
|
||||
|
||||
call mallocate (phi ,3,3,3,nat,nat,nat)
|
||||
call mallocate (phi2,3,3,3,nat,nat,nat)
|
||||
!
|
||||
! Sets number of symmetry operations giving each q in the list
|
||||
!
|
||||
nsq = nsym / nq
|
||||
if (nsq * nq.ne.nsym) call error ('qstar_d3', 'wrong degeneracy', &
|
||||
1)
|
||||
!
|
||||
! Writes dyn.mat d3dyn(3*nat,3*nat,3*nat)
|
||||
! on the 6-index array phi(3,3,3,nat,nat,nat)
|
||||
!
|
||||
do i = 1, 3 * nat
|
||||
na = (i - 1) / 3 + 1
|
||||
icar = i - 3 * (na - 1)
|
||||
do j = 1, 3 * nat
|
||||
nb = (j - 1) / 3 + 1
|
||||
jcar = j - 3 * (nb - 1)
|
||||
do k = 1, 3 * nat
|
||||
nc = (k - 1) / 3 + 1
|
||||
kcar = k - 3 * (nc - 1)
|
||||
phi (icar, jcar, kcar, na, nb, nc) = d3dyn (i, j, k)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!
|
||||
! Goes to crystal coordinates
|
||||
!
|
||||
do na = 1, nat
|
||||
do nb = 1, nat
|
||||
do nc = 1, nat
|
||||
call trntnsc_3 (phi (1, 1, 1, na, nb, nc), at, bg, - 1)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!
|
||||
! For each q of the star rotates phi with the appropriate sym.op. -> phi
|
||||
!
|
||||
do iq = 1, nq
|
||||
call setv (2 * 27 * nat * nat * nat, 0.d0, phi2, 1)
|
||||
do isym = 1, nsym
|
||||
if (isq (isym) .eq.iq) then
|
||||
call rotate_and_add_d3 (phi, phi2, nat, isym, s, invs, irt, &
|
||||
rtau, sxq (1, iq) )
|
||||
endif
|
||||
enddo
|
||||
call DSCAL (2 * 27 * nat * nat * nat, 1.d0 / nsq, phi2, 1)
|
||||
!
|
||||
! Back to cartesian coordinates
|
||||
!
|
||||
do na = 1, nat
|
||||
do nb = 1, nat
|
||||
do nc = 1, nat
|
||||
call trntnsc_3 (phi2 (1, 1, 1, na, nb, nc), at, bg, + 1)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!
|
||||
! Writes the dynamical matrix in cartesian coordinates on file
|
||||
!
|
||||
|
||||
call write_d3dyn (sxq (1, iq), phi2, nat, iudyn, wrmode)
|
||||
if (imq.eq.0) then
|
||||
!
|
||||
! if -q is not in the star recovers its matrix by time reversal
|
||||
!
|
||||
do na = 1, nat
|
||||
do nb = 1, nat
|
||||
do nc = 1, nat
|
||||
do i = 1, 3
|
||||
do j = 1, 3
|
||||
do k = 1, 3
|
||||
phi2 (i, j, k, na, nb, nc) = conjg (phi2 (i, j, k, na, nb, nc) &
|
||||
)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!
|
||||
! and writes it (changing temporarily sign to q)
|
||||
!
|
||||
call DSCAL (3, - 1.d0, sxq (1, iq), 1)
|
||||
call write_d3dyn (sxq (1, iq), phi2, nat, iudyn, wrmode)
|
||||
|
||||
call DSCAL (3, - 1.d0, sxq (1, iq), 1)
|
||||
|
||||
endif
|
||||
|
||||
enddo
|
||||
call mfree (phi)
|
||||
call mfree (phi2)
|
||||
return
|
||||
end subroutine qstar_d3
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!----------------------------------------------------------------------
|
||||
subroutine read_ef
|
||||
!-----------------------------------------------------------------------
|
||||
! Reads the shift of the Fermi Energy
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use d3com
|
||||
#ifdef PARA
|
||||
use para
|
||||
#endif
|
||||
implicit none
|
||||
|
||||
#ifdef PARA
|
||||
include 'mpif.h'
|
||||
integer :: root, errcode, nat_3
|
||||
#endif
|
||||
integer :: ios
|
||||
|
||||
if (degauss.eq.0.d0) return
|
||||
#ifdef PARA
|
||||
if (me.ne.1.or.mypool.ne.1) goto 210
|
||||
#endif
|
||||
rewind (unit = iuef)
|
||||
read (iuef, err = 100, iostat = ios) ef_sh
|
||||
|
||||
100 call error ('d3_valence', 'reading iuef', abs (ios) )
|
||||
#ifdef PARA
|
||||
210 continue
|
||||
nat_3 = 3 * nat
|
||||
root = 0
|
||||
call MPI_bcast (ef_sh, nat_3, MPI_REAL8, root, MPI_COMM_WORLD, &
|
||||
errcode)
|
||||
|
||||
call error ('read_ef', 'at bcast', errcode)
|
||||
#endif
|
||||
return
|
||||
end subroutine read_ef
|
||||
|
|
@ -0,0 +1,91 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine rotate_and_add_d3 (phi, phi2, nat, isym, s, invs, irt, &
|
||||
rtau, sxq)
|
||||
!-----------------------------------------------------------------------
|
||||
! Rotates a third order matrix (phi) in crystal coordinates according
|
||||
! to the specified symmetry operation and add the rotated matrix
|
||||
! to phi2. phi is left unmodified.
|
||||
!
|
||||
#include "machine.h"
|
||||
implicit none
|
||||
!
|
||||
! input variables
|
||||
!
|
||||
|
||||
integer :: nat, isym, s (3, 3, 48), invs (48), irt (48, nat)
|
||||
! number of atoms in the unit cell
|
||||
! index of the symm.op.
|
||||
! the symmetry operations
|
||||
! index of the inverse operations
|
||||
! index of the rotated atom
|
||||
|
||||
complex (8) :: phi (3, 3, 3, nat, nat, nat), phi2 (3, 3, 3, nat, nat, nat)
|
||||
! the input d3dyn.mat.
|
||||
! in crystal coordinates
|
||||
! the rotated d3dyn.mat
|
||||
! in crystal coordinates
|
||||
real (8) :: rtau (3, 48, nat), sxq (3)
|
||||
! for each atom and rotation gives
|
||||
! the R vector involved
|
||||
! the rotated q involved in this sym.op
|
||||
!
|
||||
! local variables
|
||||
!
|
||||
|
||||
integer :: na, nb, nc, sna, snb, snc, ism1, i, j, k, l, m, n
|
||||
! counters on atoms
|
||||
! indices of rotated atoms
|
||||
! index of the inverse symm.op.
|
||||
! generic counters
|
||||
|
||||
real (8) :: arg
|
||||
! argument of the phase
|
||||
|
||||
complex (8) :: phase, work
|
||||
! auxiliary variable
|
||||
real (8) :: tpi
|
||||
parameter (tpi = 2.d0 * 3.14159265358979d0)
|
||||
|
||||
|
||||
ism1 = invs(isym)
|
||||
do nc = 1, nat
|
||||
snc = irt(isym,nc)
|
||||
do na = 1, nat
|
||||
do nb = 1, nat
|
||||
sna = irt(isym,na)
|
||||
snb = irt(isym,nb)
|
||||
arg = (sxq (1) * (rtau(1,isym,na) - rtau(1,isym,nb) ) &
|
||||
+ sxq (2) * (rtau(2,isym,na) - rtau(2,isym,nb) ) &
|
||||
+ sxq (3) * (rtau(3,isym,na) - rtau(3,isym,nb) ) ) * tpi
|
||||
phase = DCMPLX(cos(arg),-sin(arg))
|
||||
do m = 1, 3
|
||||
do i = 1, 3
|
||||
do j = 1, 3
|
||||
work = DCMPLX(0.d0, 0.d0)
|
||||
do k = 1, 3
|
||||
do l = 1, 3
|
||||
do n = 1, 3
|
||||
work = work &
|
||||
+ s(m,n,ism1) * s(i,k,ism1) * s(j,l,ism1) &
|
||||
* phi(n,k,l,nc,na,nb) * phase
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
phi2(m,i,j,snc,sna,snb) = phi2(m,i,j,snc,sna,snb) + work
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
return
|
||||
end subroutine rotate_and_add_d3
|
||||
|
|
@ -0,0 +1,59 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine set_d3irr
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! It computes a basis for all the irreducible representations of the
|
||||
! group of the crystal, which are contained in the representation
|
||||
! which has as basis the displacement vectors.
|
||||
! This basis will be used for those quantities that depend on the
|
||||
! q=0 perturbation.
|
||||
!
|
||||
! Receives in input: nsymg0, s, invs, irt, rtau
|
||||
! Calculates: ug0, tg0, npertg0, nirrg0, irgq
|
||||
!
|
||||
! NB: It assumes that the phonon calculation for the q=0 case, has been
|
||||
! performed with iswitch=-2. If this is not the case the following
|
||||
! routine does not work.
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
|
||||
implicit none
|
||||
integer :: w_nsymq, w_irotmq
|
||||
! work array
|
||||
! work array
|
||||
|
||||
real (8) :: zero (3), w_gi (3, 48), w_gimq (3)
|
||||
! a null vector
|
||||
! work array
|
||||
complex (8) :: w_tmq (3, 3, 3 * nat)
|
||||
! work array
|
||||
|
||||
logical :: w_minus_q
|
||||
! work array
|
||||
|
||||
call setv (3, 0.d0, zero, 1)
|
||||
|
||||
w_minus_q = .true.
|
||||
if (nsymg0.gt.1) then
|
||||
call io_pattern(fild0rho,nirrg0,npertg0,ug0,-1)
|
||||
call set_sym_irr (nat, at, bg, zero, s, invs, nsymg0, rtau, irt, &
|
||||
irgq, w_nsymq, w_minus_q, w_irotmq, tg0, w_tmq, ug0, npertg0, &
|
||||
nirrg0, w_gi, w_gimq, iverbosity)
|
||||
else
|
||||
call set_irr_nosym (nat, at, bg, zero, s, invs, nsymg0, rtau, &
|
||||
irt, irgq, w_nsymq, w_minus_q, w_irotmq, tg0, w_tmq, ug0, &
|
||||
npertg0, nirrg0, w_gi, w_gimq, iverbosity)
|
||||
endif
|
||||
|
||||
return
|
||||
end subroutine set_d3irr
|
||||
|
|
@ -0,0 +1,94 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine set_efsh (drhoscf, imode0, irr, npe)
|
||||
!-----------------------------------------------------------------------
|
||||
! This routine calculates the FermiEnergy shift
|
||||
! and stores it in the variable ef_sh
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
implicit none
|
||||
integer :: npe, imode0, irr, ipert, ik, ikk, ibnd
|
||||
! input: the number of perturbation
|
||||
! input: the position of the current mode
|
||||
! input: index of the current irr. rep.
|
||||
! counter on perturbations
|
||||
! counter on k_points
|
||||
! counter on k_points
|
||||
! counter on bands
|
||||
|
||||
complex (8) :: drhoscf (nrxx, npe), delta_n, def (3)
|
||||
! input: variation of the charge density
|
||||
! the change in electron number
|
||||
! the change of the Fermi energy for each per
|
||||
real (8) :: dos_ef, weight, w0gauss, wdelta
|
||||
! density of states at Ef
|
||||
! kpoint weight
|
||||
! delta function
|
||||
! delta function weight
|
||||
|
||||
save dos_ef
|
||||
logical :: first
|
||||
! Used for initialization
|
||||
data first / .true. /
|
||||
save first
|
||||
!
|
||||
! first call: calculates density of states at Ef
|
||||
!
|
||||
if (first) then
|
||||
|
||||
first = .false.
|
||||
dos_ef = 0.d0
|
||||
do ik = 1, nksq
|
||||
if (lgamma) then
|
||||
ikk = ik
|
||||
else
|
||||
ikk = 2 * ik - 1
|
||||
endif
|
||||
weight = wk (ikk)
|
||||
do ibnd = 1, nbnd
|
||||
wdelta = w0gauss ( (ef - et (ibnd, ikk) ) / degauss, ngauss) &
|
||||
/ degauss
|
||||
dos_ef = dos_ef + weight * wdelta
|
||||
enddo
|
||||
enddo
|
||||
#ifdef PARA
|
||||
call poolreduce (1, dos_ef)
|
||||
#endif
|
||||
endif
|
||||
!
|
||||
! determines Fermi energy shift (such that each pertubation is neutral)
|
||||
!
|
||||
write (6, * )
|
||||
do ipert = 1, npe
|
||||
call cft3 (drhoscf (1, ipert), nr1, nr2, nr3, nrx1, nrx2, nrx3, &
|
||||
- 1)
|
||||
#ifdef PARA
|
||||
delta_n = (0.d0, 0.d0)
|
||||
if (gg (1) .lt.1.0d-8) delta_n = omega * drhoscf (nl (1), ipert)
|
||||
call reduce (2, delta_n)
|
||||
#else
|
||||
delta_n = omega * drhoscf (nl (1), ipert)
|
||||
#endif
|
||||
def (ipert) = - delta_n / dos_ef
|
||||
enddo
|
||||
!
|
||||
! symmetrizes the Fermi energy shift
|
||||
!
|
||||
call sym_def1 (def, irr)
|
||||
do ipert = 1, npe
|
||||
ef_sh (imode0 + ipert) = DREAL (def (ipert) )
|
||||
enddo
|
||||
|
||||
write (6, '(5x,"Pert. #",i3,": Fermi energy shift (Ryd) =", &
|
||||
& 2f10.4)') (ipert, def (ipert) , ipert = 1, npe)
|
||||
return
|
||||
end subroutine set_efsh
|
||||
|
|
@ -0,0 +1,254 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!---------------------------------------------------------------------
|
||||
subroutine set_sym_irr (nat, at, bg, xq, s, invs, nsym, rtau, irt, &
|
||||
irgq, nsymq, minus_q, irotmq, t, tmq, u, npert, nirr, gi, gimq, &
|
||||
iverbosity)
|
||||
!---------------------------------------------------------------------
|
||||
!
|
||||
! This subroutine computes a basis for all the irreducible
|
||||
! representations of the small group of q, which are contained
|
||||
! in the representation which has as basis the displacement vectors.
|
||||
! This is achieved by building a random hermitean matrix,
|
||||
! symmetrizing it and diagonalizing the result. The eigenvectors
|
||||
! give a basis for the irreducible representations of the
|
||||
! small group of q.
|
||||
!
|
||||
! Furthermore it computes:
|
||||
! 1) the small group of q
|
||||
! 2) the possible G vectors associated to every symmetry operation
|
||||
! 3) the matrices which represent the small group of q on the
|
||||
! pattern basis.
|
||||
!
|
||||
! Original routine was from C. Bungaro.
|
||||
! Revised Oct. 1995 by Andrea Dal Corso.
|
||||
! April 1997: parallel stuff added (SdG)
|
||||
!
|
||||
#include "machine.h"
|
||||
use parameters, only : DP
|
||||
use allocate
|
||||
#ifdef PARA
|
||||
use para
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef PARA
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
!
|
||||
! first the dummy variables
|
||||
!
|
||||
|
||||
integer :: nat, nsym, s (3, 3, 48), invs (48), irt (48, nat), &
|
||||
iverbosity, npert (3 * nat), irgq (48), nsymq, irotmq, nirr
|
||||
! input: the number of atoms
|
||||
! input: the number of symmetries
|
||||
! input: the symmetry matrices
|
||||
! input: the inverse of each matrix
|
||||
! input: the rotated of each atom
|
||||
! input: write control
|
||||
! output: the dimension of each represe
|
||||
! output: the small group of q
|
||||
! output: the order of the small group
|
||||
! output: the symmetry sending q -> -q+
|
||||
! output: the number of irr. representa
|
||||
|
||||
real(kind=DP) :: xq (3), rtau (3, 48, nat), at (3, 3), bg (3, 3), &
|
||||
gi (3, 48), gimq (3)
|
||||
! input: the q point
|
||||
! input: the R associated to each tau
|
||||
! input: the direct lattice vectors
|
||||
! input: the reciprocal lattice vectors
|
||||
! output: [S(irotq)*q - q]
|
||||
! output: [S(irotmq)*q + q]
|
||||
|
||||
complex(kind=DP) :: u (3 * nat, 3 * nat), t (3, 3, 48, 3 * nat), &
|
||||
tmq (3, 3, 3 * nat)
|
||||
! output: the pattern vectors
|
||||
! output: the symmetry matrices
|
||||
! output: the matrice sending q -> -q+G
|
||||
logical :: minus_q
|
||||
! output: if true one symmetry send q -
|
||||
!
|
||||
! here the local variables
|
||||
!
|
||||
real(kind=DP) :: tpi
|
||||
|
||||
parameter (tpi = 2.0d0 * 3.14159265358979d0)
|
||||
|
||||
integer :: na, nb, imode, jmode, ipert, jpert, nsymtot, imode0, &
|
||||
irr, ipol, jpol, isymq, irot, sna
|
||||
! counter on atoms
|
||||
! counter on atoms
|
||||
! counter on modes
|
||||
! counter on modes
|
||||
! counter on perturbations
|
||||
! counter on perturbations
|
||||
! total number of symmetries
|
||||
! auxiliry variable for mode counting
|
||||
! counter on irreducible representation
|
||||
! counter on polarizations
|
||||
! counter on polarizations
|
||||
! counter on symmetries
|
||||
! counter on rotations
|
||||
! the rotated atom
|
||||
|
||||
integer :: info
|
||||
|
||||
real(kind=DP) :: eigen (3 * nat), modul, arg
|
||||
! the eigenvalues of dynamical ma
|
||||
! the modulus of the mode
|
||||
! the argument of the phase
|
||||
|
||||
complex(kind=DP) :: wdyn (3, 3, nat, nat), phi (3 * nat, 3 * nat), &
|
||||
wrk_u (3, nat), wrk_ru (3, nat), fase
|
||||
! the dynamical matrix
|
||||
! the bi-dimensional dynamical ma
|
||||
! one pattern
|
||||
! the rotated of one pattern
|
||||
! the phase factor
|
||||
|
||||
logical :: lgamma
|
||||
! if true gamma point
|
||||
!
|
||||
! Allocate the necessary quantities
|
||||
!
|
||||
lgamma = (xq(1).eq.0.d0 .and. xq(2).eq.0.d0 .and. xq(3).eq.0.d0)
|
||||
!
|
||||
! find the small group of q
|
||||
!
|
||||
call smallgq (xq,at,bg,s,nsym,irgq,nsymq,irotmq,minus_q,gi,gimq)
|
||||
!
|
||||
! And we compute the matrices which represent the symmetry transformat
|
||||
! in the basis of the displacements
|
||||
!
|
||||
call setv (2 * 3 * 3 * 48 * 3 * nat, 0.d0, t, 1)
|
||||
call setv (2 * 3 * 3 * 3 * nat, 0.d0, tmq, 1)
|
||||
if (minus_q) then
|
||||
nsymtot = nsymq + 1
|
||||
else
|
||||
nsymtot = nsymq
|
||||
|
||||
endif
|
||||
do isymq = 1, nsymtot
|
||||
if (isymq.le.nsymq) then
|
||||
irot = irgq (isymq)
|
||||
else
|
||||
irot = irotmq
|
||||
endif
|
||||
imode0 = 0
|
||||
do irr = 1, nirr
|
||||
do ipert = 1, npert (irr)
|
||||
imode = imode0 + ipert
|
||||
do na = 1, nat
|
||||
do ipol = 1, 3
|
||||
jmode = 3 * (na - 1) + ipol
|
||||
wrk_u (ipol, na) = u (jmode, imode)
|
||||
enddo
|
||||
enddo
|
||||
!
|
||||
! transform this pattern to crystal basis
|
||||
!
|
||||
do na = 1, nat
|
||||
call trnvecc (wrk_u (1, na), at, bg, - 1)
|
||||
enddo
|
||||
!
|
||||
! the patterns are rotated with this symmetry
|
||||
!
|
||||
call setv (2 * 3 * nat, 0.d0, wrk_ru, 1)
|
||||
do na = 1, nat
|
||||
sna = irt (irot, na)
|
||||
arg = 0.d0
|
||||
do ipol = 1, 3
|
||||
arg = arg + xq (ipol) * rtau (ipol, irot, na)
|
||||
enddo
|
||||
arg = arg * tpi
|
||||
if (isymq.eq.nsymtot.and.minus_q) then
|
||||
fase = DCMPLX (cos (arg), sin (arg) )
|
||||
else
|
||||
fase = DCMPLX (cos (arg), - sin (arg) )
|
||||
endif
|
||||
do ipol = 1, 3
|
||||
do jpol = 1, 3
|
||||
wrk_ru (ipol, sna) = wrk_ru (ipol, sna) + s (jpol, ipol, irot) &
|
||||
* wrk_u (jpol, na) * fase
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!
|
||||
! Transform back the rotated pattern
|
||||
!
|
||||
do na = 1, nat
|
||||
call trnvecc (wrk_ru (1, na), at, bg, 1)
|
||||
enddo
|
||||
!
|
||||
! Computes the symmetry matrices on the basis of the pattern
|
||||
!
|
||||
do jpert = 1, npert (irr)
|
||||
imode = imode0 + jpert
|
||||
do na = 1, nat
|
||||
do ipol = 1, 3
|
||||
jmode = ipol + (na - 1) * 3
|
||||
if (isymq.eq.nsymtot.and.minus_q) then
|
||||
tmq (jpert, ipert, irr) = tmq (jpert, ipert, irr) + conjg (u ( &
|
||||
jmode, imode) * wrk_ru (ipol, na) )
|
||||
else
|
||||
t (jpert, ipert, irot, irr) = t (jpert, ipert, irot, irr) &
|
||||
+ conjg (u (jmode, imode) ) * wrk_ru (ipol, na)
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
imode0 = imode0 + npert (irr)
|
||||
enddo
|
||||
|
||||
enddo
|
||||
!
|
||||
! Note: the following lines are for testing purposes
|
||||
!
|
||||
! nirr = 1
|
||||
! npert(1)=1
|
||||
! do na=1,3*nat/2
|
||||
! u(na,1)=(0.d0,0.d0)
|
||||
! u(na+3*nat/2,1)=(0.d0,0.d0)
|
||||
! enddo
|
||||
! u(1,1)=(-1.d0,0.d0)
|
||||
! write(6,'(" Setting mode for testing ")')
|
||||
! do na=1,3*nat
|
||||
! write(6,*) u(na,1)
|
||||
! enddo
|
||||
! nsymq=1
|
||||
! minus_q=.false.
|
||||
|
||||
#ifdef PARA
|
||||
!
|
||||
! parallel stuff: first node broadcasts everything to all nodes
|
||||
!
|
||||
400 continue
|
||||
!-waits for all nodes to be ready
|
||||
call mpi_barrier (MPI_COMM_WORLD, info)
|
||||
!-real*8
|
||||
call mpi_bcast (gi, 144, MPI_REAL8, 0, MPI_COMM_WORLD, info)
|
||||
call mpi_bcast (gimq, 3, MPI_REAL8, 0, MPI_COMM_WORLD, info)
|
||||
!-complex*16
|
||||
call mpi_bcast (t, 2592 * nat, MPI_REAL8, 0, MPI_COMM_WORLD, info)
|
||||
call mpi_bcast (tmq, 54 * nat, MPI_REAL8, 0, MPI_COMM_WORLD, info)
|
||||
call mpi_bcast (u, 18 * nat * nat, MPI_REAL8, 0, MPI_COMM_WORLD, &
|
||||
info)
|
||||
!-integer
|
||||
call mpi_bcast (nsymq, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, info)
|
||||
call mpi_bcast (npert, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, info)
|
||||
call mpi_bcast (nirr, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, info)
|
||||
call mpi_bcast (irotmq, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, info)
|
||||
call mpi_bcast (irgq, 48, MPI_INTEGER, 0, MPI_COMM_WORLD, info)
|
||||
!-logical
|
||||
|
||||
call mpi_bcast (minus_q, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, info)
|
||||
#endif
|
||||
return
|
||||
end subroutine set_sym_irr
|
||||
|
|
@ -0,0 +1,107 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine sgama_d3 (nsymq, nat, s, ityp, nr1, nr2, nr3, nsymg0, &
|
||||
irt, ftau, at, bg, tau)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! It calculates e/o reorder: nsymg0, s, irt, ftau
|
||||
!
|
||||
! Matrices of the symmetry operations -s- are read from the iunpun file.
|
||||
! They are calculated by the pw/lib/sgama.F routine and are
|
||||
! ordered in the following way this way:
|
||||
! a) the first nrot matrices are symmetries of the lattice
|
||||
! b) the first nsymq matrices are symmetries for the small group of q
|
||||
!
|
||||
! This routine finds which symmetries of the lattice are also symmetries
|
||||
! of the crystal,
|
||||
! it calculates the order of the crystal group: nsymg0
|
||||
! and reorder the s matrices in this way:
|
||||
! a) the first nsymg0 matrices are symmetries of the crystal
|
||||
! b) the first nsymq matrices are symmetries for the small group of q
|
||||
!
|
||||
#include "machine.h"
|
||||
|
||||
implicit none
|
||||
|
||||
integer :: nsymq, nat, s (3, 3, 48), ityp (nat), nr1, nr2, nr3, &
|
||||
nsymg0, irt (48, nat), ftau (3, 48)
|
||||
! input: order of the small group of q
|
||||
! input: number of atoms in the cell
|
||||
! in/out: matrices of the symmetry operations
|
||||
! input: type of each atom
|
||||
! input:
|
||||
! input: dimension of the FFT mesh
|
||||
! input:
|
||||
! output: order of the crystal group
|
||||
! output: for each atom gives the rotated ato
|
||||
! output: fractionary translation of each sym
|
||||
|
||||
real (8) :: at (3, 3), bg (3, 3), tau (3, nat)
|
||||
! input: direct lattice vectors
|
||||
! input: reciprocal lattice vectors
|
||||
! input: coordinates of atomic positions
|
||||
!
|
||||
! local variables
|
||||
!
|
||||
|
||||
integer :: nrot, irot, jrot, ipol, jpol, na
|
||||
! order of the lattice point group
|
||||
! counter on the rotations
|
||||
! counter on the rotations
|
||||
! counter on the polarizations
|
||||
! counter on the polarizations
|
||||
! counter on atoms
|
||||
|
||||
logical :: sym (48)
|
||||
! if true the symmetry is a true symmetry
|
||||
!
|
||||
! It calculates the order of the lattice group by finding the first
|
||||
! singular matrice
|
||||
!
|
||||
nrot = 48
|
||||
do irot = 1, 48
|
||||
if ( (s (1, 1, irot) .eq.0) .and. (s (2, 1, irot) .eq.0) .and. (s &
|
||||
(3, 1, irot) .eq.0) ) then
|
||||
nrot = irot - 1
|
||||
goto 10
|
||||
endif
|
||||
enddo
|
||||
10 continue
|
||||
!
|
||||
! It finds the true symmetries of the crystal
|
||||
!
|
||||
call sgam_at (nrot, s, nat, tau, ityp, at, bg, nr1, nr2, nr3, sym, &
|
||||
irt, ftau)
|
||||
!
|
||||
! copy symm. operation in sequential order so that:
|
||||
! irot <= nsymq are sym.ops. of the small group of q
|
||||
! nsymq+1 <= irot <= nsymg0 are sym.ops. of the crystal
|
||||
!
|
||||
do irot = 1, nsymq
|
||||
if (.not.sym (irot) ) call error ('sgama_d3', 'unexpected', 1)
|
||||
enddo
|
||||
jrot = nsymq
|
||||
do irot = nsymq + 1, nrot
|
||||
if (sym (irot) ) then
|
||||
jrot = jrot + 1
|
||||
do ipol = 1, 3
|
||||
do jpol = 1, 3
|
||||
s (ipol, jpol, jrot) = s (ipol, jpol, irot)
|
||||
enddo
|
||||
ftau (ipol, jrot) = ftau (ipol, irot)
|
||||
enddo
|
||||
do na = 1, nat
|
||||
irt (jrot, na) = irt (irot, na)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
|
||||
nsymg0 = jrot
|
||||
return
|
||||
end subroutine sgama_d3
|
||||
|
|
@ -0,0 +1,334 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
|
||||
subroutine solve_linter_d3 (irr, imode0, npe, isw_sl)
|
||||
!-----------------------------------------------------------------------
|
||||
! This routine is a driver for the solution of the linear system whic
|
||||
! defines the change of the wavefunction due to the perturbation.
|
||||
! It reads from a file the charge variation due to perturbation
|
||||
! and calculates variation of the wavefunctions.
|
||||
!
|
||||
! 1) It writes on file the proiection on conduction band of the variation
|
||||
! of the wavefunction with respect to the perturbation
|
||||
!
|
||||
! Several cases are possible:
|
||||
! isw_sl = 1 : calculates | Pc d/du(q) psi_k > and writes on: iudqwf
|
||||
! isw_sl = 2 : calculates | Pc d/du(0) psi_k+q > and writes on: iud0qwf
|
||||
! isw_sl = 3 : calculates | Pc d/du(0) psi_k > and writes on: iudwf
|
||||
!
|
||||
! 2) It writes on a file the scalar product of the wavefunctions with the
|
||||
! K-S Hamiltonian
|
||||
! isw_sl = 1 : calculates <psi_k+q|dH/du(q)|psi_k > and writes on: iupdqvp
|
||||
! isw_sl = 3 : calculates <psi_k |dH/du(0)|psi_k > and writes on: iupd0vp
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
use allocate
|
||||
|
||||
implicit none
|
||||
integer :: irr, npe, imode0, isw_sl
|
||||
! input: the irreducible representation
|
||||
! input: the number of perturbation
|
||||
! input: the position of the modes
|
||||
! input: a switch
|
||||
|
||||
real (8) :: thresh, wg1, wg2, wwg, deltae, theta, anorm, averlt, &
|
||||
eprec, aux_avg (2), w0gauss, wgauss, tcpu, get_clock, xq_ (3)
|
||||
! the convergence threshold
|
||||
! weight for metals
|
||||
! weight for metals
|
||||
! weight for metals
|
||||
! difference of energy
|
||||
! the theta function
|
||||
! the norm of the error
|
||||
! average number of iterations
|
||||
! cut-off for preconditioning
|
||||
! auxiliary variable for avg. iter. coun
|
||||
! function computing the delta function
|
||||
! function computing the theta function
|
||||
! cpu time
|
||||
|
||||
complex (8) :: ps (nbnd), ZDOTC, dbecsum, psidvpsi
|
||||
! the scalar products
|
||||
! the scalar product function
|
||||
! dummy variable
|
||||
! auxiliary dpsi dV matrix element between k+q and k wavefunctions
|
||||
|
||||
real (8), pointer :: h_diag (:,:)
|
||||
! the diagonal part of the Hamiltonian
|
||||
complex (8), pointer :: drhoscf (:,:), dvloc (:,:), spsi (:), auxg (:), &
|
||||
dpsiaux (:,:)
|
||||
! the variation of the charge
|
||||
! variation of local part of the potenti
|
||||
! the function spsi
|
||||
logical :: q0mode_f, conv_root, lmetq0
|
||||
! if .true. it is useless to compute this
|
||||
! true if linter is converged
|
||||
! true if xq=(0,0,0) in a metal
|
||||
|
||||
integer :: ipert, ibnd, jbnd, lter, ltaver, lintercall, ik, ikk, &
|
||||
ikq, ig, ir, nrec, ios, mode, iuaux
|
||||
! counter on perturbations
|
||||
! counter on bands
|
||||
! counter on bands
|
||||
! counter on iterations of linter
|
||||
! average counter
|
||||
! average number of call to linter
|
||||
! counter on k points
|
||||
! counter on k points
|
||||
! counter on k+q points
|
||||
! counter on G vectors
|
||||
! counter on mesh points
|
||||
! the record number
|
||||
! integer variable for I/O control
|
||||
! mode index
|
||||
|
||||
external ch_psi_all2, cg_psi
|
||||
!
|
||||
call start_clock ('solve_linter')
|
||||
call mallocate (drhoscf, nrxx, npe)
|
||||
call mallocate (dvloc, nrxx, npe)
|
||||
call mallocate (spsi, npwx)
|
||||
call mallocate (auxg, npwx)
|
||||
if (degauss.ne.0.d0) call mallocate (dpsiaux, npwx, nbnd)
|
||||
call mallocate (h_diag, npwx, nbnd)
|
||||
ltaver = 0
|
||||
lintercall = 0
|
||||
lmetq0 = (degauss.ne.0.d0) .and. (isw_sl.ge.3)
|
||||
|
||||
thresh = ethr_ph
|
||||
if (isw_sl.eq.1) then
|
||||
call DCOPY (3, xq, 1, xq_, 1)
|
||||
else
|
||||
call setv (3, 0.d0, xq_, 1)
|
||||
endif
|
||||
!
|
||||
! calculates the variation of the local part of the K-S potential
|
||||
!
|
||||
do ipert = 1, npe
|
||||
mode = imode0 + ipert
|
||||
call dvscf (mode, dvloc (1, ipert), xq_)
|
||||
enddo
|
||||
call setv (2 * npe * nrxx, 0.d0, drhoscf, 1)
|
||||
rewind (unit = iunigk)
|
||||
|
||||
do ik = 1, nksq
|
||||
read (iunigk, err = 100, iostat = ios) npw, igk
|
||||
100 call error ('solve_linter_d3', 'reading igk', abs (ios) )
|
||||
if (lgamma) then
|
||||
ikk = ik
|
||||
ikq = ik
|
||||
npwq = npw
|
||||
else
|
||||
read (iunigk, err = 200, iostat = ios) npwq, igkq
|
||||
200 call error ('solve_linter_d3', 'reading igkq', abs (ios) )
|
||||
if (isw_sl.eq.1) then
|
||||
ikk = 2 * ik - 1
|
||||
ikq = 2 * ik
|
||||
elseif (isw_sl.eq.2) then
|
||||
ikk = 2 * ik
|
||||
ikq = 2 * ik
|
||||
npw = npwq
|
||||
do ig = 1, npwx
|
||||
igk (ig) = igkq (ig)
|
||||
enddo
|
||||
elseif (isw_sl.eq.3) then
|
||||
ikk = 2 * ik - 1
|
||||
ikq = 2 * ik - 1
|
||||
npwq = npw
|
||||
do ig = 1, npwx
|
||||
igkq (ig) = igk (ig)
|
||||
enddo
|
||||
endif
|
||||
endif
|
||||
call init_us_2 (npw , igk , xk (1, ikk), vkb0)
|
||||
call init_us_2 (npwq, igkq, xk (1, ikq), vkb )
|
||||
!
|
||||
! reads unperturbed wavefuctions psi(k) and psi(k+q)
|
||||
!
|
||||
call davcio (evc, lrwfc, iuwfc, ikk, - 1)
|
||||
if (.not.lgamma) call davcio (evq, lrwfc, iuwfc, ikq, - 1)
|
||||
!
|
||||
! compute the kinetic energy
|
||||
!
|
||||
do ig = 1, npwq
|
||||
g2kin (ig) = ( (xk (1, ikq) + g (1, igkq (ig) ) ) **2 + &
|
||||
(xk (2, ikq) + g (2, igkq (ig) ) ) **2 + &
|
||||
(xk (3, ikq) + g (3, igkq (ig) ) ) **2) * tpiba2
|
||||
enddo
|
||||
!
|
||||
do ipert = 1, npe
|
||||
|
||||
q0mode_f = (.not.q0mode (imode0 + ipert) ) .and. (.not.lgamma) &
|
||||
.and. (isw_sl.ne.1)
|
||||
if (q0mode_f) then
|
||||
call setv (2 * nbnd * nbnd, 0.d0, psidqvpsi, 1)
|
||||
call setv (2 * nbnd * npwx, 0.d0, dpsi, 1)
|
||||
lintercall = 1
|
||||
goto 120
|
||||
endif
|
||||
!
|
||||
! calculates dvscf_q*psi_k in G_space, for all bands
|
||||
!
|
||||
mode = imode0 + ipert
|
||||
call dvdpsi (mode, xq_, dvloc (1, ipert), vkb0, vkb, evc, dvpsi)
|
||||
!
|
||||
! calculates matrix element of dvscf between k+q and k wavefunctions,
|
||||
! that will be written on a file
|
||||
!
|
||||
if (degauss.ne.0.d0) call setv (2 * npwx * nbnd, 0.d0, dpsiaux, 1)
|
||||
do ibnd = 1, nbnd
|
||||
if (isw_sl.ne.2) then
|
||||
do jbnd = 1, nbnd
|
||||
psidvpsi = ZDOTC(npwq, evq (1, jbnd), 1, dvpsi (1, ibnd),1)
|
||||
#ifdef PARA
|
||||
call reduce (2, psidvpsi)
|
||||
#endif
|
||||
psidqvpsi (jbnd, ibnd) = psidvpsi
|
||||
if (degauss.ne.0.d0) then
|
||||
deltae = et (ibnd, ikk) - et (jbnd, ikq)
|
||||
! theta = 2.0d0*wgauss(deltae/degauss,0)
|
||||
theta = 1.0d0
|
||||
if (abs (deltae) .gt.1.0d-5) then
|
||||
wg1 = wgauss ( (ef-et (ibnd, ikk) ) / degauss, ngauss)
|
||||
wg2 = wgauss ( (ef-et (jbnd, ikq) ) / degauss, ngauss)
|
||||
wwg = (wg1 - wg2) / deltae
|
||||
else
|
||||
wwg = - w0gauss ( (ef - et (ibnd, ikk) ) / degauss, &
|
||||
ngauss) / degauss
|
||||
endif
|
||||
psidvpsi = 0.5d0 * wwg * psidvpsi * theta
|
||||
call ZAXPY(npwq,psidvpsi,evq(1,jbnd),1,dpsiaux(1,ibnd),1)
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
!
|
||||
! Ortogonalize dvpsi
|
||||
!
|
||||
call start_clock ('ortho')
|
||||
wwg = 1.0d0
|
||||
do ibnd = 1, nbnd_occ (ikk)
|
||||
call setv (2 * npwx, 0.d0, auxg, 1)
|
||||
do jbnd = 1, nbnd
|
||||
ps (jbnd) = - wwg * ZDOTC(npwq, evq(1,jbnd), 1, dvpsi(1,ibnd), 1)
|
||||
enddo
|
||||
call reduce (2 * nbnd, ps)
|
||||
do jbnd = 1, nbnd
|
||||
call ZAXPY (npwq, ps (jbnd), evq (1, jbnd), 1, auxg, 1)
|
||||
enddo
|
||||
call ZCOPY (npwq, auxg, 1, spsi, 1)
|
||||
call DAXPY (2 * npwq, 1.0d0, spsi, 1, dvpsi (1, ibnd), 1)
|
||||
enddo
|
||||
call stop_clock ('ortho')
|
||||
call DSCAL (2 * npwx * nbnd, - 1.d0, dvpsi, 1)
|
||||
!
|
||||
! solution of the linear system (H-eS)*dpsi=dvpsi,
|
||||
! dvpsi=-P_c^+ (dvscf)*psi
|
||||
!
|
||||
call setv (2 * nbnd * npwx, 0.d0, dpsi, 1)
|
||||
do ibnd = 1, nbnd_occ (ikk)
|
||||
conv_root = .true.
|
||||
do ig = 1, npwq
|
||||
auxg (ig) = g2kin (ig) * evq (ig, ibnd)
|
||||
enddo
|
||||
eprec = 1.35d0 * ZDOTC (npwq, evq (1, ibnd), 1, auxg, 1)
|
||||
call reduce (1, eprec)
|
||||
do ig = 1, npwq
|
||||
h_diag (ig, ibnd) = max (1.0d0, g2kin (ig) / eprec)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call cgsolve_all (ch_psi_all2, cg_psi, et (1, ikk), dvpsi, dpsi, &
|
||||
h_diag, npwx, npwq, thresh, ik, lter, conv_root, anorm, &
|
||||
nbnd_occ (ikk) )
|
||||
|
||||
ltaver = ltaver + lter
|
||||
lintercall = lintercall + 1
|
||||
if (.not.conv_root) write (6, '(5x,"kpoint",i4," ibnd",i4, &
|
||||
& " linter: root not converged ",e10.3)') ikk, ibnd, anorm
|
||||
120 continue
|
||||
!
|
||||
! writes psidqvpsi on iupdqvp
|
||||
!
|
||||
nrec = imode0 + ipert + (ik - 1) * 3 * nat
|
||||
if (isw_sl.eq.1) then
|
||||
call davcio (psidqvpsi, lrpdqvp, iupdqvp, nrec, + 1)
|
||||
elseif (isw_sl.ge.3) then
|
||||
call davcio (psidqvpsi, lrpdqvp, iupd0vp, nrec, + 1)
|
||||
endif
|
||||
!
|
||||
! writes delta_psi on iunit iudwf, k=kpoint,
|
||||
!
|
||||
if (isw_sl.eq.1) then
|
||||
iuaux = iudqwf
|
||||
elseif (isw_sl.ge.3) then
|
||||
iuaux = iudwf
|
||||
elseif (isw_sl.eq.2) then
|
||||
iuaux = iud0qwf
|
||||
endif
|
||||
nrec = (imode0 + ipert - 1) * nksq + ik
|
||||
|
||||
call davcio (dpsi, lrdwf, iuaux, nrec, + 1)
|
||||
if (q0mode_f) goto 110
|
||||
if (isw_sl.ne.2) then
|
||||
if (degauss.ne.0.d0) then
|
||||
do ibnd = 1, nbnd
|
||||
wg1 = wgauss ( (ef - et (ibnd, ikk) ) / degauss, ngauss)
|
||||
call DSCAL (2 * npwq, wg1, dpsi (1, ibnd), 1)
|
||||
enddo
|
||||
call DAXPY (2 * npwx * nbnd, 1.0d0, dpsiaux, 1, dpsi, 1)
|
||||
endif
|
||||
endif
|
||||
110 continue
|
||||
!
|
||||
! This is used to calculate Fermi energy shift at q=0 in metals
|
||||
!
|
||||
if (lmetq0) call incdrhoscf2 (drhoscf (1, ipert), wk (ikk), &
|
||||
ik, dbecsum, 1, 1)
|
||||
enddo
|
||||
|
||||
enddo
|
||||
if (lmetq0) then
|
||||
do ipert = 1, npe
|
||||
call cinterpolate (drhoscf (1, ipert), drhoscf (1, ipert), 1)
|
||||
enddo
|
||||
|
||||
endif
|
||||
#ifdef PARA
|
||||
call poolreduce (2 * npe * nrxx, drhoscf)
|
||||
#endif
|
||||
|
||||
if (lmetq0) call set_efsh (drhoscf, imode0, irr, npe)
|
||||
aux_avg (1) = dfloat (ltaver)
|
||||
aux_avg (2) = dfloat (lintercall)
|
||||
call poolreduce (2, aux_avg)
|
||||
|
||||
averlt = aux_avg (1) / aux_avg (2)
|
||||
tcpu = get_clock ('D3TOTEN')
|
||||
|
||||
write (6, '(//,5x," thresh=",e10.3," total cpu time : ",f7.1, &
|
||||
& " secs av.it.: ",f5.1)') thresh, tcpu, averlt
|
||||
#ifdef FLUSH
|
||||
|
||||
call flush (6)
|
||||
#endif
|
||||
call mfree (h_diag)
|
||||
if (degauss.ne.0.d0) call mfree (dpsiaux)
|
||||
call mfree (auxg)
|
||||
call mfree (spsi)
|
||||
call mfree (dvloc)
|
||||
call mfree (drhoscf)
|
||||
|
||||
call stop_clock ('solve_linter')
|
||||
return
|
||||
end subroutine solve_linter_d3
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine stop_d3 (flag)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! This routine closes all files before stopping
|
||||
! flag is no longer used
|
||||
!
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
#ifdef PARA
|
||||
use para
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef PARA
|
||||
include 'mpif.h'
|
||||
integer :: info
|
||||
#endif
|
||||
logical :: flag
|
||||
|
||||
close (unit = iuwfc, status = 'keep')
|
||||
close (unit = iubar, status = 'keep')
|
||||
close (unit = iudwf, status = 'keep')
|
||||
#ifdef PARA
|
||||
if (me.ne.1) goto 100
|
||||
#endif
|
||||
close (unit = iudrho, status = 'keep')
|
||||
if (.not.lgamma) close (unit = iud0rho, status = 'keep')
|
||||
#ifdef PARA
|
||||
100 continue
|
||||
#endif
|
||||
close (unit = iunigk, status = 'delete')
|
||||
if (.not.lgamma) then
|
||||
close (unit = iud0qwf, status = 'keep')
|
||||
close (unit = iudqwf, status = 'keep')
|
||||
endif
|
||||
close (unit = iupdqvp, status = 'keep')
|
||||
if (.not.lgamma) close (unit = iupd0vp, status = 'keep')
|
||||
if (degauss.ne.0.d0) then
|
||||
close (unit = iudpdvp_1, status = 'keep')
|
||||
if (.not.lgamma) then
|
||||
close (unit = iudpdvp_2, status = 'keep')
|
||||
close (unit = iudpdvp_3, status = 'keep')
|
||||
endif
|
||||
endif
|
||||
call print_clock_d3
|
||||
call show_memory ()
|
||||
|
||||
#ifdef PARA
|
||||
call mpi_barrier (MPI_COMM_WORLD, info)
|
||||
call mpi_finalize (info)
|
||||
#endif
|
||||
|
||||
stop
|
||||
return
|
||||
end subroutine stop_d3
|
||||
|
|
@ -0,0 +1,62 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!---------------------------------------------------------------------
|
||||
subroutine sym_def1 (def, irr)
|
||||
!---------------------------------------------------------------------
|
||||
! Symmetrizes the first order changes of the Fermi energies of an
|
||||
! irreducible representation. These objects are defined complex because
|
||||
! perturbations may be complex
|
||||
!
|
||||
! Used in the q=0 metallic case only.
|
||||
!
|
||||
#include"machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
implicit none
|
||||
integer :: irr
|
||||
! input: the representation under consideration
|
||||
|
||||
complex (8) :: def (3)
|
||||
! inp/out: the fermi energy changes
|
||||
|
||||
integer :: ipert, jpert, isym, irot
|
||||
! counter on perturbations
|
||||
! counter on perturbations
|
||||
! counter on symmetries
|
||||
! the rotation
|
||||
|
||||
complex (8) :: w_def (3)
|
||||
! the fermi energy changes (work array)
|
||||
do ipert = 1, npertg0 (irr)
|
||||
def (ipert) = DREAL (def (ipert) )
|
||||
|
||||
enddo
|
||||
if (nsymq.eq.1) return
|
||||
!
|
||||
! Here we symmetrize with respect to the small group of q
|
||||
!
|
||||
call setv (6, 0.d0, w_def, 1)
|
||||
do ipert = 1, npertg0 (irr)
|
||||
do isym = 1, nsymq
|
||||
irot = irgq (isym)
|
||||
do jpert = 1, npertg0 (irr)
|
||||
w_def (ipert) = w_def (ipert) + tg0 (jpert, ipert, irot, irr) &
|
||||
* def (jpert)
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
!
|
||||
! normalize and exit
|
||||
!
|
||||
call DSCAL (6, 1.d0 / nsymq, w_def, 1)
|
||||
|
||||
call DCOPY (6, w_def, 1, def, 1)
|
||||
return
|
||||
end subroutine sym_def1
|
||||
|
|
@ -0,0 +1,97 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!---------------------------------------------------------------------
|
||||
|
||||
subroutine symd0rho (nper, irr, d0rho, s, ftau, nsymq, irgq, t, &
|
||||
nat, nr1, nr2, nr3, nrx1, nrx2, nrx3)
|
||||
!---------------------------------------------------------------------
|
||||
! symmetrizes q=0 drho
|
||||
!
|
||||
#include"machine.h"
|
||||
use allocate
|
||||
!
|
||||
implicit none
|
||||
integer :: nper, irr, s (3, 3, 48), ftau (3, 48), nsymq, irgq (48) &
|
||||
, nat, nr1, nr2, nr3, nrx1, nrx2, nrx3
|
||||
! the number of perturbations
|
||||
! the representation under consideration
|
||||
|
||||
complex (8) :: d0rho (nrx1, nrx2, nrx3, nper), t (3, 3, 48, 3 * nat)
|
||||
! charge variation to symmetrize
|
||||
|
||||
integer :: ri, rj, rk, i, j, k, ipert, jpert, isym, irot
|
||||
!
|
||||
! the rotated points
|
||||
! counter on mesh points
|
||||
! counter on perturbations
|
||||
! counter on perturbations
|
||||
! counter on symmetries
|
||||
! the rotation
|
||||
|
||||
complex (8), pointer :: aux1 (:,:,:,:)
|
||||
! the symmetrized charge
|
||||
|
||||
|
||||
call start_clock ('symd0rho')
|
||||
do k = 1, nr3
|
||||
do j = 1, nr2
|
||||
do i = 1, nr1
|
||||
do ipert = 1, nper
|
||||
d0rho (i, j, k, ipert) = DREAL (d0rho (i, j, k, ipert) )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
|
||||
if (nsymq.eq.1) return
|
||||
|
||||
call mallocate (aux1, nrx1, nrx2, nrx3, nper)
|
||||
!
|
||||
! Here we symmetrize with respect to the group
|
||||
!
|
||||
call setv (2 * nrx1 * nrx2 * nrx3 * nper, 0.d0, aux1, 1)
|
||||
do k = 1, nr3
|
||||
do j = 1, nr2
|
||||
do i = 1, nr1
|
||||
do isym = 1, nsymq
|
||||
irot = irgq (isym)
|
||||
ri = s (1, 1, irot) * (i - 1) + s (2, 1, irot) * (j - 1) + s (3, &
|
||||
1, irot) * (k - 1) - ftau (1, irot)
|
||||
ri = mod (ri, nr1) + 1
|
||||
if (ri.lt.1) ri = ri + nr1
|
||||
rj = s (1, 2, irot) * (i - 1) + s (2, 2, irot) * (j - 1) + s (3, &
|
||||
2, irot) * (k - 1) - ftau (2, irot)
|
||||
rj = mod (rj, nr2) + 1
|
||||
if (rj.lt.1) rj = rj + nr2
|
||||
rk = s (1, 3, irot) * (i - 1) + s (2, 3, irot) * (j - 1) + s (3, &
|
||||
3, irot) * (k - 1) - ftau (3, irot)
|
||||
rk = mod (rk, nr3) + 1
|
||||
|
||||
if (rk.lt.1) rk = rk + nr3
|
||||
do ipert = 1, nper
|
||||
do jpert = 1, nper
|
||||
aux1 (i, j, k, ipert) = aux1 (i, j, k, ipert) + t (jpert, ipert, &
|
||||
irot, irr) * d0rho (ri, rj, rk, jpert)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call DSCAL (2 * nrx1 * nrx2 * nrx3 * nper, 1.d0 / float (nsymq), &
|
||||
aux1, 1)
|
||||
|
||||
call ZCOPY (nrx1 * nrx2 * nrx3 * nper, aux1, 1, d0rho, 1)
|
||||
call mfree (aux1)
|
||||
|
||||
call stop_clock ('symd0rho')
|
||||
return
|
||||
end subroutine symd0rho
|
||||
|
|
@ -0,0 +1,82 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine trntnsc_3 (phi, at, bg, iflg)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! trasforms a COMPLEX third order tensor
|
||||
!(like the derivative of the dynamical matrix)
|
||||
! from crystal to cartesian axis (iflg >= 1) or viceversa (iflg <= -1)
|
||||
!
|
||||
#include"machine.h"
|
||||
implicit none
|
||||
|
||||
integer :: iflg
|
||||
! input: gives the versus of the trans.
|
||||
|
||||
complex (8) :: phi (3, 3, 3)
|
||||
! inp/out: the matrix to transform
|
||||
|
||||
real (8) :: at (3, 3), bg (3, 3)
|
||||
! input: the direct lattice vectors
|
||||
! input: the reciprocal lattice
|
||||
|
||||
integer :: i, j, k, l, m, n
|
||||
!
|
||||
! counters on polarizations
|
||||
!
|
||||
complex (8) :: wrk (3, 3, 3)
|
||||
! a work array
|
||||
|
||||
if (iflg.gt.0) then
|
||||
!
|
||||
! forward transformation (crystal to cartesian axis)
|
||||
!
|
||||
|
||||
call ZCOPY (27, phi, 1, wrk, 1)
|
||||
do m = 1, 3
|
||||
do i = 1, 3
|
||||
do j = 1, 3
|
||||
phi (m, i, j) = (0.d0, 0.d0)
|
||||
do n = 1, 3
|
||||
do k = 1, 3
|
||||
do l = 1, 3
|
||||
phi (m, i, j) = phi (m, i, j) + wrk (n, k, l) * bg (i, k) &
|
||||
* bg (j, l) * bg (m, n)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
else
|
||||
!
|
||||
! backward transformation (cartesian to crystal axis)
|
||||
!
|
||||
do m = 1, 3
|
||||
do i = 1, 3
|
||||
do j = 1, 3
|
||||
wrk (m, i, j) = (0.d0, 0.d0)
|
||||
do n = 1, 3
|
||||
do k = 1, 3
|
||||
do l = 1, 3
|
||||
wrk (m, i, j) = wrk (m, i, j) + phi (n, k, l) * at (k, i) &
|
||||
* at (l, j) * at (n, m)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
call ZCOPY (27, wrk, 1, phi, 1)
|
||||
endif
|
||||
return
|
||||
|
||||
|
||||
end subroutine trntnsc_3
|
||||
|
|
@ -0,0 +1,66 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
function w_1gauss (x, n)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! the derivative of w0gauss:
|
||||
!
|
||||
! --> (n=-99): second derivative of Fermi-Dirac function
|
||||
!
|
||||
implicit none
|
||||
real (8) :: w_1gauss, x
|
||||
! output: the value of the function
|
||||
! input: the point where to compute the function
|
||||
|
||||
integer :: n
|
||||
! input: the order of the smearing function
|
||||
!
|
||||
! here the local variables
|
||||
!
|
||||
real (8) :: a, arg, hp, hd, pi, aux1, aux2
|
||||
! the coefficients a_n
|
||||
! the argument of the exponential
|
||||
! the hermite function
|
||||
! the hermite function
|
||||
! pi
|
||||
! auxiliary variable
|
||||
! auxiliary variable
|
||||
integer :: i, ni
|
||||
! counter on n values
|
||||
! counter on 2n values
|
||||
! Fermi-Dirac smearing
|
||||
if (n.eq. - 99) then
|
||||
aux1 = exp (x)
|
||||
aux2 = exp ( - x)
|
||||
w_1gauss = (aux2 - aux1) / (2.d0 + aux1 + aux2) **2
|
||||
return
|
||||
endif
|
||||
!
|
||||
pi = 3.14159265358979d0
|
||||
arg = min (200.d0, x**2)
|
||||
w_1gauss = - 2.d0 * x * exp ( - arg) / sqrt (pi)
|
||||
if (n.eq.0) return
|
||||
hd = exp ( - arg)
|
||||
hp = 2.d0 * x * exp ( - arg)
|
||||
ni = 1
|
||||
a = 1.0 / sqrt (pi)
|
||||
do i = 1, n
|
||||
hd = 2.0d0 * x * hp - 2.0d0 * float (ni) * hd
|
||||
ni = ni + 1
|
||||
a = - a / (float (i) * 4.0d0)
|
||||
hp = 2.0d0 * x * hd-2.0d0 * float (ni) * hp
|
||||
ni = ni + 1
|
||||
w_1gauss = w_1gauss - a * hp
|
||||
enddo
|
||||
return
|
||||
|
||||
|
||||
|
||||
end function w_1gauss
|
||||
|
|
@ -0,0 +1,60 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine write_aux (isw)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! Writes on files partial computation of d3dyn
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
!
|
||||
implicit none
|
||||
integer :: isw
|
||||
!
|
||||
if (isw.eq.1) then
|
||||
call setv (54 * nat * nat * nat, 0.d0, d3dyn_aux1, 1)
|
||||
call setv (54 * nat * nat * nat, 0.d0, d3dyn_aux2, 1)
|
||||
call setv (54 * nat * nat * nat, 0.d0, d3dyn_aux3, 1)
|
||||
call setv (54 * nat * nat * nat, 0.d0, d3dyn_aux4, 1)
|
||||
call setv (54 * nat * nat * nat, 0.d0, d3dyn_aux5, 1)
|
||||
call setv (54 * nat * nat * nat, 0.d0, d3dyn_aux6, 1)
|
||||
call setv (54 * nat * nat * nat, 0.d0, d3dyn_aux7, 1)
|
||||
call setv (54 * nat * nat * nat, 0.d0, d3dyn_aux8, 1)
|
||||
call setv (54 * nat * nat * nat, 0.d0, d3dyn_aux9, 1)
|
||||
elseif (isw.eq.2) then
|
||||
call ZCOPY (27 * nat * nat * nat, d3dyn, 1, d3dyn_aux4, 1)
|
||||
call DAXPY (2 * 27 * nat * nat * nat, - 1.d0, d3dyn_aux5, 1, &
|
||||
d3dyn_aux4, 1)
|
||||
call DAXPY (2 * 27 * nat * nat * nat, - 1.d0, d3dyn_aux6, 1, &
|
||||
d3dyn_aux4, 1)
|
||||
call DAXPY (2 * 27 * nat * nat * nat, - 1.d0, d3dyn_aux7, 1, &
|
||||
d3dyn_aux4, 1)
|
||||
call DAXPY (2 * 27 * nat * nat * nat, - 1.d0, d3dyn_aux8, 1, &
|
||||
d3dyn_aux4, 1)
|
||||
call DAXPY (2 * 27 * nat * nat * nat, - 1.d0, d3dyn_aux9, 1, &
|
||||
d3dyn_aux4, 1)
|
||||
call DAXPY (2 * 27 * nat * nat * nat, - 1.d0, d3dyn_aux1, 1, &
|
||||
d3dyn_aux4, 1)
|
||||
call writed3dyn_5 (d3dyn_aux1, 'd3mat.1', - 1)
|
||||
call writed3dyn_5 (d3dyn_aux4, 'd3mat.4', - 1)
|
||||
call writed3dyn_5 (d3dyn_aux5, 'd3mat.5', - 1)
|
||||
call writed3dyn_5 (d3dyn_aux6, 'd3mat.6', - 1)
|
||||
call writed3dyn_5 (d3dyn_aux7, 'd3mat.7', - 1)
|
||||
call writed3dyn_5 (d3dyn_aux8, 'd3mat.8', - 1)
|
||||
call writed3dyn_5 (d3dyn_aux9, 'd3mat.9', - 1)
|
||||
call writed3dyn_5 (d3dyn, 'd3mat.ns', - 1)
|
||||
elseif (isw.eq.3) then
|
||||
call writed3dyn_5 (d3dyn, 'd3mat.sy', 1)
|
||||
|
||||
endif
|
||||
return
|
||||
end subroutine write_aux
|
||||
|
|
@ -0,0 +1,55 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine write_d3dyn (xq, phi, nat, iudyn, wrmode)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
implicit none
|
||||
!
|
||||
! input variables
|
||||
!
|
||||
integer :: iudyn, nat
|
||||
! unit number
|
||||
! number of atom in the unit cell
|
||||
complex (8) :: phi (3, 3, 3, nat, nat, nat)
|
||||
! derivative of the dynamical matrix
|
||||
real (8) :: xq (3)
|
||||
! the q vector
|
||||
logical :: wrmode (3 * nat)
|
||||
! if .true. this mode is to be written
|
||||
!
|
||||
! local variables
|
||||
!
|
||||
integer :: na, nb, nc, icar, jcar, kcar, i
|
||||
! counters on atoms
|
||||
! cartesian coordinate counters
|
||||
! generic counter
|
||||
write (iudyn, 9000) (xq (icar), icar = 1, 3)
|
||||
do i = 1, 3 * nat
|
||||
if (wrmode (i) ) then
|
||||
write (iudyn, '(/,12x,"modo:",i5,/)') i
|
||||
nc = (i - 1) / 3 + 1
|
||||
kcar = i - 3 * (nc - 1)
|
||||
do na = 1, nat
|
||||
do nb = 1, nat
|
||||
write (iudyn, '(2i3)') na, nb
|
||||
do icar = 1, 3
|
||||
write (iudyn, '(3e24.12)') (phi (kcar, icar, jcar, nc, na, nb) &
|
||||
, jcar = 1, 3)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
|
||||
enddo
|
||||
|
||||
return
|
||||
9000 format(/,5x,'Third derivative in cartesian axes', &
|
||||
& //,5x,'q = ( ',3f14.9,' ) ',/)
|
||||
end subroutine write_d3dyn
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
subroutine write_igk
|
||||
!
|
||||
use pwcom
|
||||
use phcom
|
||||
implicit none
|
||||
if (nksq.ne.1) return
|
||||
rewind (unit = iunigk)
|
||||
write (iunigk) npw, igk
|
||||
|
||||
if (.not.lgamma) write (iunigk) npwq, igkq
|
||||
return
|
||||
end subroutine write_igk
|
||||
|
|
@ -0,0 +1,97 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine writed3dyn_5 (d3dyn_x, filename, isw)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! writes in a file the third derivative of dynamical matrix
|
||||
! isw = +1 : d3dyn_x is in cartesian axis
|
||||
! isw = -1 : rotates d3dyn_x from the basis of pattern to
|
||||
! cartesian axis
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use phcom
|
||||
use d3com
|
||||
use allocate
|
||||
#ifdef PARA
|
||||
use para
|
||||
#endif
|
||||
implicit none
|
||||
integer :: isw, iud3dyn, n_d3, na, nb, icart, jcart, kcart, na_i, &
|
||||
na_j, na_k
|
||||
! input: switch
|
||||
! index on cartesian coordinates
|
||||
! index on cartesian coordinates
|
||||
! index on cartesian coordinates
|
||||
! index on modes
|
||||
! index on modes
|
||||
! index on modes
|
||||
|
||||
complex (8) :: d3dyn_x (3 * nat, 3 * nat, 3 * nat), work
|
||||
! input: the third derivative of the dynamical matrix
|
||||
complex (8), pointer :: aux (:,:,:)
|
||||
! auxiliary space
|
||||
|
||||
character (len=*) :: filename
|
||||
! input: the name of the file
|
||||
|
||||
#ifdef PARA
|
||||
if (me.ne.1.or.mypool.ne.1) return
|
||||
#endif
|
||||
|
||||
call mallocate (aux, 3 * nat, 3 * nat, 3 * nat)
|
||||
if (isw.eq. + 1) then
|
||||
call ZCOPY (27 * nat * nat * nat, d3dyn_x, 1, aux, 1)
|
||||
elseif (isw.eq. - 1) then
|
||||
!
|
||||
! Rotates third derivative of the dynamical basis from the basis
|
||||
! of modes to cartesisn axis
|
||||
!
|
||||
do kcart = 1, 3 * nat
|
||||
do icart = 1, 3 * nat
|
||||
do jcart = 1, 3 * nat
|
||||
work = (0.d0, 0.d0)
|
||||
do na_k = 1, 3 * nat
|
||||
do na_i = 1, 3 * nat
|
||||
do na_j = 1, 3 * nat
|
||||
work = work + conjg (ug0 (kcart, na_k) ) * u (icart, na_i) &
|
||||
* d3dyn_x (na_k, na_i, na_j) * conjg (u (jcart, na_j) )
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
aux (kcart, icart, jcart) = work
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
|
||||
endif
|
||||
iud3dyn = 57
|
||||
|
||||
open (unit = iud3dyn, file = trim(filename), status = 'unknown')
|
||||
do n_d3 = 1, 3 * nat
|
||||
write (iud3dyn, * )
|
||||
write (iud3dyn, * ) ' modo:', n_d3
|
||||
write (iud3dyn, * )
|
||||
do na = 1, nat
|
||||
do nb = 1, nat
|
||||
write (iud3dyn, '(2i3)') na, nb
|
||||
do icart = 1, 3
|
||||
write (iud3dyn, '(3E24.12)') (aux (n_d3, icart + 3 * (na - 1) , &
|
||||
jcart + 3 * (nb - 1) ) , jcart = 1, 3)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
enddo
|
||||
|
||||
close (iud3dyn)
|
||||
|
||||
call mfree (aux)
|
||||
return
|
||||
end subroutine writed3dyn_5
|
||||
|
|
@ -0,0 +1,234 @@
|
|||
#
|
||||
# temporary Makefile for Gamma-only code
|
||||
#
|
||||
include ../make.rules
|
||||
include ../make.sys
|
||||
#
|
||||
# targets
|
||||
#
|
||||
PWOBJS=../PW/aainit.o \
|
||||
../PW/addusforce.o \
|
||||
../PW/addusstress.o \
|
||||
../PW/allocate_locpot.o \
|
||||
../PW/allocate_nlpot.o \
|
||||
../PW/allowed.o \
|
||||
../PW/atomic_wfc.o \
|
||||
../PW/bachel.o \
|
||||
../PW/bfgs.o \
|
||||
../PW/cdiagh.o \
|
||||
../PW/cft.o \
|
||||
../PW/cft3.o \
|
||||
../PW/cft3s.o \
|
||||
../PW/cft_3.o \
|
||||
../PW/cfts_3.o \
|
||||
../PW/checkallsym.o \
|
||||
../PW/checksym.o \
|
||||
../PW/clocks.o \
|
||||
../PW/constrain.o \
|
||||
../PW/conv_to_num.o \
|
||||
../PW/coset.o \
|
||||
../PW/cryst_to_car.o \
|
||||
../PW/cubicsym.o \
|
||||
../PW/d_matrix.o \
|
||||
../PW/date_and_tim.o \
|
||||
../PW/davcio.o \
|
||||
../PW/delta_e.o \
|
||||
../PW/deriv_drhoc.o \
|
||||
../PW/diropn.o \
|
||||
../PW/divide.o \
|
||||
../PW/divide_et_impera.o \
|
||||
../PW/dqvan2.o \
|
||||
../PW/drhoc.o \
|
||||
../PW/dsum.o \
|
||||
../PW/dvloc_of_g.o \
|
||||
../PW/dylmr2.o \
|
||||
../PW/dynamics.o \
|
||||
../PW/efermig.o \
|
||||
../PW/efermit.o \
|
||||
../PW/eqvect.o \
|
||||
../PW/erf.o \
|
||||
../PW/error.o \
|
||||
../PW/estimate.o \
|
||||
../PW/ewald.o \
|
||||
../PW/force_cc.o \
|
||||
../PW/force_corr.o \
|
||||
../PW/force_ew.o \
|
||||
../PW/force_lc.o \
|
||||
../PW/forces.o \
|
||||
../PW/functionals.o \
|
||||
../PW/g_psi.o \
|
||||
../PW/gen_us_dj.o \
|
||||
../PW/gen_us_dy.o \
|
||||
../PW/gk_sort.o \
|
||||
../PW/good_fft_dimension.o \
|
||||
../PW/gweights.o \
|
||||
../PW/hexsym.o \
|
||||
../PW/hinit0.o \
|
||||
../PW/hinit1.o \
|
||||
../PW/hpsort.o \
|
||||
../PW/init_ns.o \
|
||||
../PW/init_us_1.o \
|
||||
../PW/init_us_2.o \
|
||||
../PW/init_vloc.o \
|
||||
../PW/invmat.o \
|
||||
../PW/io_pot.o \
|
||||
../PW/ions.o \
|
||||
../PW/irrek.o \
|
||||
../PW/iweights.o \
|
||||
../PW/kpoint_grid.o \
|
||||
../PW/latgen.o \
|
||||
../PW/lchk_tauxk.o \
|
||||
../PW/linmin.o \
|
||||
../PW/lsda_functionals.o \
|
||||
../PW/mix_pot.o \
|
||||
../PW/mode_group.o \
|
||||
../PW/move_ions.o \
|
||||
../PW/multable.o \
|
||||
../PW/n_plane_waves.o \
|
||||
../PW/new_ns.o \
|
||||
../PW/openfil.o \
|
||||
../PW/potinit.o \
|
||||
../PW/print_clock_pw.o \
|
||||
../PW/punch.o \
|
||||
../PW/qvan2.o \
|
||||
../PW/random.o \
|
||||
../PW/read_ncpp.o \
|
||||
../PW/rgen.o \
|
||||
../PW/readin.o \
|
||||
../PW/readnewvan.o \
|
||||
../PW/readvan.o \
|
||||
../PW/recips.o \
|
||||
../PW/remove_atomic_rho.o \
|
||||
../PW/restart_from_file.o \
|
||||
../PW/restart_in_electrons.o \
|
||||
../PW/restart_in_ions.o \
|
||||
../PW/rho2zeta.o \
|
||||
../PW/setv.o \
|
||||
../PW/ruotaijk.o \
|
||||
../PW/s_axis_to_ca.o \
|
||||
../PW/save_in_cbands.o \
|
||||
../PW/save_in_electrons.o \
|
||||
../PW/save_in_ions.o \
|
||||
../PW/saveall.o \
|
||||
../PW/scale_h.o \
|
||||
../PW/swap.o \
|
||||
../PW/scnds.o \
|
||||
../PW/scopy_t3e.o \
|
||||
../PW/seqopn.o \
|
||||
../PW/set_fft_dim.o \
|
||||
../PW/set_kplusq.o \
|
||||
../PW/set_kup_and_kdw.o \
|
||||
../PW/set_pencils.o \
|
||||
../PW/setqf.o \
|
||||
../PW/set_vrs.o \
|
||||
../PW/setup.o \
|
||||
../PW/setupkpt.o \
|
||||
../PW/sgama.o \
|
||||
../PW/sgam_at.o \
|
||||
../PW/sgam_ph.o \
|
||||
../PW/show_memory.o \
|
||||
../PW/simpson.o \
|
||||
../PW/smallg_q.o \
|
||||
../PW/sph_bes.o \
|
||||
../PW/stop_pw.o \
|
||||
../PW/struct_fact.o \
|
||||
../PW/sumkg.o \
|
||||
../PW/read_pseudo.o \
|
||||
../PW/stress.o \
|
||||
../PW/stres_cc.o \
|
||||
../PW/stres_ewa.o \
|
||||
../PW/stres_gradcorr.o \
|
||||
../PW/stres_har.o \
|
||||
../PW/stres_knl.o \
|
||||
../PW/stres_loc.o \
|
||||
../PW/summary.o \
|
||||
../PW/sumkt.o \
|
||||
../PW/symrho.o \
|
||||
../PW/symtns.o \
|
||||
../PW/symvect.o \
|
||||
../PW/tabd.o \
|
||||
../PW/trntns.o \
|
||||
../PW/trnvecc.o \
|
||||
../PW/trnvect.o \
|
||||
../PW/tweights.o \
|
||||
../PW/update_pot.o \
|
||||
../PW/updathes.o \
|
||||
../PW/usnldiag.o \
|
||||
../PW/vcsmd.o \
|
||||
../PW/vcsubs.o \
|
||||
../PW/vhpsi.o \
|
||||
../PW/vloc_of_g.o \
|
||||
../PW/volume.o \
|
||||
../PW/vpack.o \
|
||||
../PW/w0gauss.o \
|
||||
../PW/w1gauss.o \
|
||||
../PW/wgauss.o \
|
||||
../PW/which_dft.o \
|
||||
../PW/write_ns.o \
|
||||
../PW/ylmr2.o \
|
||||
../PW/input.o \
|
||||
../PW/write_config_to_file.o \
|
||||
../PW/read_conf_from_file.o
|
||||
|
||||
MODULES = ../Modules/*.o ../PW/allocate.o ../PW/error_handler.o \
|
||||
../PW/restart.o ../PW/upf_to_internal.o
|
||||
|
||||
GAMMA=rbecmod.o \
|
||||
gamma.o \
|
||||
fake.o \
|
||||
add_vuspsi.o \
|
||||
addusdens.o \
|
||||
allocate_fft.o \
|
||||
allocate_wfc.o \
|
||||
atomic_rho.o \
|
||||
c_bands.o \
|
||||
rdiaghg.o \
|
||||
regterg.o \
|
||||
data_structure_para.o \
|
||||
data_structure_scal.o \
|
||||
electrons.o \
|
||||
force_us.o \
|
||||
ggen.o \
|
||||
gradcorr.o \
|
||||
h_psi.o \
|
||||
init_run.o \
|
||||
interpolate.o \
|
||||
mix_rho.o \
|
||||
newd.o \
|
||||
pw_gemm.o \
|
||||
read_file.o \
|
||||
rotate_wfc.o \
|
||||
s_psi.o \
|
||||
set_rhoc.o \
|
||||
setlocal.o \
|
||||
stres_us.o \
|
||||
sum_band.o \
|
||||
v_of_rho.o \
|
||||
vloc_psi.o \
|
||||
wfcinit.o
|
||||
|
||||
CGOBJS = cgcom.o cg_readin.o a_h.o cgsolve.o d2ion.o dynmat_init.o \
|
||||
drhodv.o dvb_cc.o dvpsi_kb.o dyndiar.o dynmatcc.o dielec.o \
|
||||
zvscal.o find_equiv_sites.o generate_dynamical_matrix.o \
|
||||
generate_effective_charges.o h_h.o macro.o dvpsi_e.o \
|
||||
rhod2vkb.o solve_ph.o solve_e.o cg_summary.o cg_setup.o \
|
||||
cg_setupdgc.o writedyn.o pw_dot.o \
|
||||
dmxc.o dgradcorr.o dgcxc_spin.o dgcxc.o raman.o
|
||||
#
|
||||
# targets
|
||||
#
|
||||
include .dependencies
|
||||
|
||||
all: pwg.x phcg.x
|
||||
|
||||
pwg.x: $(GAMMA) $(PWOBJS) pwscf.o
|
||||
$(LD) -o pwg.x $(FFLAGS) pwscf.o $(GAMMA) $(PWOBJS) $(MODULES) $(LFLAGS)
|
||||
|
||||
phcg.x: $(GAMMA) $(PWOBJS) $(CGOBJS)
|
||||
$(LD) -o phcg.x $(FFLAGS) $(CGOBJS) $(GAMMA) $(PWOBJS) $(MODULES) $(LFLAGS)
|
||||
|
||||
clean:
|
||||
-/bin/rm -f *.x *.o *.d *~ *.F90 *.mod
|
||||
veryclean: clean
|
||||
-/bin/rm .dependencies
|
||||
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
2003-01-10
|
||||
|
||||
This directory contains a Gamma-only (k=0) version of pw.x,
|
||||
using only half G-vectors and performing two fft's at the
|
||||
same time whenever possible. It is faster and leaner than
|
||||
the ordinary pw.x version, but it can be used only for k=0
|
||||
sampling of the Brillouin Zone. Only Davidson diagonalization
|
||||
is implemented (CG and DIIS are not). It should have otherwise
|
||||
all the functionality of the normal version.
|
||||
|
||||
This directory contains also a Gamma-only, q=0 version of
|
||||
the phonon code, called "raman". It works in conjunction
|
||||
with the Gamma-only version of pw.x. Uses a conjugate-
|
||||
gradient algorithm for the solution of linear-response
|
||||
equation. Hopefully useful for normal mode calculations in
|
||||
molecules. Does not work with ultrasoft pseudopotentials.
|
||||
|
||||
The "raman" code can also calculate Raman coefficients with
|
||||
finite differences (experimental).
|
||||
|
||||
Installation:
|
||||
compile pw.x first
|
||||
cd Gamma
|
||||
make lib
|
||||
make pw.x
|
||||
make raman (if desired)
|
||||
Usage:
|
||||
Input data for the ordinary versions of pw.x and ph.x should
|
||||
work also for pw.x and raman in this directory
|
||||
|
||||
|
|
@ -0,0 +1,143 @@
|
|||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine A_h(e,h,ah)
|
||||
!-----------------------------------------------------------------------
|
||||
#include "machine.h"
|
||||
use parameters, only: DP
|
||||
use pwcom
|
||||
use gamma
|
||||
use rbecmod
|
||||
use cgcom
|
||||
use funct
|
||||
!
|
||||
implicit none
|
||||
integer :: j, jkb, ibnd, na,nt,ih
|
||||
real(kind=DP) :: e(nbnd)
|
||||
complex(kind=DP) :: h(npwx,nbnd), ah(npwx,nbnd)
|
||||
!
|
||||
complex(kind=DP) :: fp, fm
|
||||
complex(kind=DP), pointer:: dpsic(:), drhoc(:), dvxc(:)
|
||||
real(kind=DP), pointer :: dv(:), drho(:)
|
||||
!
|
||||
call start_clock('a_h')
|
||||
!
|
||||
drho => auxr
|
||||
dpsic => aux2
|
||||
drhoc => aux3
|
||||
!
|
||||
call setv(nrxx,0.d0,drho,1)
|
||||
!
|
||||
! [(k+G)^2 - e ]psi
|
||||
do ibnd = 1,nbnd
|
||||
! set to zero the imaginary part of h at G=0
|
||||
! needed for numerical stability
|
||||
if (gstart==2) h(1,ibnd) = cmplx(DREAL(h(1,ibnd)),0.d0)
|
||||
do j = 1,npw
|
||||
ah(j,ibnd) = (g2kin(j)-e(ibnd)) * h(j,ibnd)
|
||||
end do
|
||||
end do
|
||||
! V_Loc psi
|
||||
do ibnd = 1,nbnd, 2
|
||||
call setv(2*nrxx,0.d0,dpsic,1)
|
||||
call setv(2*nrxx,0.d0, psic,1)
|
||||
if (ibnd.lt.nbnd) then
|
||||
! two ffts at the same time
|
||||
do j = 1,npw
|
||||
psic (nl (igk(j))) = evc(j,ibnd) + (0.0,1.d0)* evc(j,ibnd+1)
|
||||
dpsic(nl (igk(j))) = h(j,ibnd) + (0.0,1.d0)* h(j,ibnd+1)
|
||||
psic (nlm(igk(j)))= conjg(evc(j,ibnd)-(0.0,1.d0)* evc(j,ibnd+1))
|
||||
dpsic(nlm(igk(j)))= conjg( h(j,ibnd)-(0.0,1.d0)* h(j,ibnd+1))
|
||||
end do
|
||||
else
|
||||
do j = 1,npw
|
||||
psic (nl (igk(j))) = evc(j,ibnd)
|
||||
dpsic(nl (igk(j))) = h(j,ibnd)
|
||||
psic (nlm(igk(j))) = conjg( evc(j,ibnd))
|
||||
dpsic(nlm(igk(j))) = conjg( h(j,ibnd))
|
||||
end do
|
||||
end if
|
||||
call cft3s( psic,nr1,nr2,nr3,nrx1,nr2,nr3,2)
|
||||
call cft3s(dpsic,nr1,nr2,nr3,nrx1,nr2,nr3,2)
|
||||
do j = 1,nrxx
|
||||
drho(j) = drho(j) - 2.0*degspin/omega * &
|
||||
DREAL(psic(j)*conjg(dpsic(j)))
|
||||
dpsic(j) = dpsic(j) * vrs(j,current_spin)
|
||||
end do
|
||||
call cft3s(dpsic,nr1,nr2,nr3,nrx1,nr2,nr3,-2)
|
||||
if (ibnd.lt.nbnd) then
|
||||
! two ffts at the same time
|
||||
do j = 1,npw
|
||||
fp = (dpsic (nl(igk(j))) + dpsic (nlm(igk(j))))*0.5d0
|
||||
fm = (dpsic (nl(igk(j))) - dpsic (nlm(igk(j))))*0.5d0
|
||||
ah(j,ibnd ) = ah(j,ibnd) +cmplx(DREAL(fp), DIMAG(fm))
|
||||
ah(j,ibnd+1) = ah(j,ibnd+1)+cmplx(DIMAG(fp),-DREAL(fm))
|
||||
end do
|
||||
else
|
||||
do j = 1,npw
|
||||
ah(j,ibnd) = ah(j,ibnd) + dpsic (nl(igk(j)))
|
||||
end do
|
||||
end if
|
||||
end do
|
||||
!
|
||||
nullify(dpsic)
|
||||
! V_NL psi
|
||||
call pw_gemm ('Y', nkb, nbnd, npw, vkb, npwx, h, npwx, becp, nkb)
|
||||
if (nkb.gt.0) call add_vuspsi (npwx, npw, nbnd, h, ah)
|
||||
!
|
||||
do j = 1,nrxx
|
||||
drhoc(j) = DCMPLX(drho(j),0.d0)
|
||||
end do
|
||||
call cft3(drhoc,nr1,nr2,nr3,nrx1,nr2,nr3,-1)
|
||||
!
|
||||
! drho is deltarho(r), drhoc is deltarho(g)
|
||||
!
|
||||
! mu'(n(r)) psi(r) delta psi(r)
|
||||
!
|
||||
dvxc => aux2
|
||||
do j = 1,nrxx
|
||||
dvxc(j) = drho(j)*dmuxc(j)
|
||||
end do
|
||||
!
|
||||
! add gradient correction contribution (if any)
|
||||
!
|
||||
call start_clock('dgradcorr')
|
||||
if (igcx.ne.0.or.igcc.ne.0) call dgradcor1 &
|
||||
(rho, grho, dvxc_rr, dvxc_sr, dvxc_ss, dvxc_s, &
|
||||
drho, drhoc, nr1,nr2,nr3, nrx1, nrx2, nrx3, nrxx, nspin, &
|
||||
nl, nlm, ngm, g, alat, omega, dvxc)
|
||||
call stop_clock('dgradcorr')
|
||||
nullify (drho)
|
||||
!
|
||||
! 1/|r-r'| * psi(r') delta psi(r')
|
||||
!
|
||||
! gstart is the first nonzero G vector (needed for parallel execution)
|
||||
!
|
||||
if (gstart==2) drhoc(nl(1)) = 0.d0
|
||||
!
|
||||
do j = gstart,ngm
|
||||
drhoc(nl (j)) = e2*fpi*drhoc(nl(j))/ (tpiba2*gg(j))
|
||||
drhoc(nlm(j)) = conjg(drhoc(nl (j)))
|
||||
end do
|
||||
call cft3(drhoc,nr1,nr2,nr3,nrx1,nr2,nr3,+1)
|
||||
!
|
||||
! drhoc now contains deltaV_hartree
|
||||
!
|
||||
dv => auxr
|
||||
do j = 1,nrxx
|
||||
dv(j) = - DREAL(dvxc(j)) - DREAL(drhoc(j))
|
||||
end do
|
||||
!
|
||||
call vloc_psi(npwx, npw, nbnd, evc, dv, ah)
|
||||
!
|
||||
! set to zero the imaginary part of ah at G=0
|
||||
! needed for numerical stability
|
||||
if (gstart.eq.2) then
|
||||
do ibnd = 1, nbnd
|
||||
ah(1,ibnd) = cmplx(DREAL(ah(1,ibnd)),0.d0)
|
||||
end do
|
||||
end if
|
||||
!
|
||||
call stop_clock('a_h')
|
||||
!
|
||||
return
|
||||
end subroutine A_h
|
||||
|
|
@ -0,0 +1,73 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine add_vuspsi (lda, n, m, psi, hpsi )
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! This routine applies the Ultra-Soft Hamiltonian to a
|
||||
! vector psi and puts the result in hpsi.
|
||||
! Requires the products of psi with all beta functions
|
||||
! in array becp(nkb,m) (calculated by ccalbec)
|
||||
! input:
|
||||
! lda leading dimension of arrays psi, spsi
|
||||
! n true dimension of psi, spsi
|
||||
! m number of states psi
|
||||
! psi
|
||||
! output:
|
||||
! hpsi V_US*psi is added to hpsi
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use rbecmod
|
||||
use allocate
|
||||
implicit none
|
||||
!
|
||||
! First the dummy variables
|
||||
!
|
||||
integer :: lda, n, m
|
||||
complex(kind=DP) :: psi (lda, m), hpsi (lda, m)
|
||||
!
|
||||
! here the local variables
|
||||
!
|
||||
integer :: jkb, ikb, ih, jh, na, nt, ijkb0, ibnd
|
||||
! counters
|
||||
real(kind=DP), allocatable :: ps (:,:)
|
||||
! the product vkb and psi
|
||||
!
|
||||
if (nkb.eq.0) return
|
||||
allocate(ps(nkb,m))
|
||||
ps(:,:) = 0.d0
|
||||
call start_clock ('add_vuspsi')
|
||||
ijkb0 = 0
|
||||
do nt = 1, ntyp
|
||||
do na = 1, nat
|
||||
if (ityp (na) .eq.nt) then
|
||||
do ibnd = 1, m
|
||||
do jh = 1, nh (nt)
|
||||
jkb = ijkb0 + jh
|
||||
do ih = 1, nh (nt)
|
||||
ikb = ijkb0 + ih
|
||||
ps (ikb, ibnd) = ps (ikb, ibnd) + &
|
||||
deeq(ih,jh,na,current_spin) * becp(jkb,ibnd)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
ijkb0 = ijkb0 + nh (nt)
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
call DGEMM ('N', 'N', 2*n, m, nkb, 1.d0, vkb, &
|
||||
2*lda, ps, nkb, 1.d0, hpsi, 2*lda)
|
||||
deallocate (ps)
|
||||
|
||||
call stop_clock ('add_vuspsi')
|
||||
return
|
||||
end subroutine add_vuspsi
|
||||
|
||||
|
|
@ -0,0 +1,108 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!----------------------------------------------------------------------
|
||||
subroutine addusdens
|
||||
!----------------------------------------------------------------------
|
||||
!
|
||||
! This routine adds to the charge density the part which is due to
|
||||
! the US augmentation.
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use gamma
|
||||
use allocate
|
||||
implicit none
|
||||
!
|
||||
! here the local variables
|
||||
!
|
||||
|
||||
integer :: ig, na, nt, ih, jh, ijh, ir, is
|
||||
! counter on G vectors
|
||||
! counter on atoms
|
||||
! the atom type
|
||||
! counter on beta functions
|
||||
! counter on beta functions
|
||||
! composite index ih jh
|
||||
! counter on mesh points
|
||||
! counter on spin polarization
|
||||
|
||||
real(kind=DP), pointer :: qmod (:), ylmk0 (:,:)
|
||||
! the modulus of G
|
||||
! the spherical harmonics
|
||||
|
||||
complex(kind=DP) :: skk
|
||||
complex(kind=DP), pointer :: qg (:), aux (:,:)
|
||||
! work space for FFT
|
||||
! work space for rho(G,nspin)
|
||||
|
||||
|
||||
call start_clock ('addusdens')
|
||||
|
||||
call mallocate(aux , ngm, nspin)
|
||||
call mallocate(qg, nrxx)
|
||||
call mallocate(qmod, ngm)
|
||||
call mallocate(ylmk0, ngm, lqx * lqx)
|
||||
|
||||
call setv (2 * ngm * nspin, 0.d0, aux, 1)
|
||||
call ylmr2 (lqx * lqx, ngm, g, gg, ylmk0)
|
||||
do ig = 1, ngm
|
||||
qmod (ig) = sqrt (gg (ig) )
|
||||
enddo
|
||||
do nt = 1, ntyp
|
||||
if (tvanp (nt) ) then
|
||||
ijh = 0
|
||||
do ih = 1, nh (nt)
|
||||
do jh = ih, nh (nt)
|
||||
call qvan2 (ngm, ih, jh, nt, qmod, qgm, ylmk0)
|
||||
ijh = ijh + 1
|
||||
do na = 1, nat
|
||||
if (ityp (na) .eq.nt) then
|
||||
!
|
||||
! Multiply becsum and qg with the correct structure factor
|
||||
!
|
||||
do is = 1, nspin
|
||||
do ig = 1, ngm
|
||||
skk = eigts1 (ig1 (ig), na) * &
|
||||
eigts2 (ig2 (ig), na) * &
|
||||
eigts3 (ig3 (ig), na)
|
||||
aux(ig,is)=aux(ig,is) + qgm(ig)*skk*becsum(ijh,na,is)
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
!
|
||||
! convert aux to real space and add to the charge density
|
||||
!
|
||||
if (okvan) then
|
||||
do is = 1, nspin
|
||||
call setv (2 * nrxx, 0.d0, qg, 1)
|
||||
do ig = 1, ngm
|
||||
qg (nl (ig) ) = aux (ig, is)
|
||||
qg (nlm(ig) ) = conjg(aux(ig, is))
|
||||
enddo
|
||||
call cft3 (qg, nr1, nr2, nr3, nrx1, nrx2, nrx3, 1)
|
||||
do ir = 1, nrxx
|
||||
rho (ir, is) = rho (ir, is) + DREAL (qg (ir) )
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
|
||||
call mfree (ylmk0)
|
||||
call mfree (qmod)
|
||||
call mfree (qg)
|
||||
call mfree (aux)
|
||||
|
||||
call stop_clock ('addusdens')
|
||||
return
|
||||
end subroutine addusdens
|
||||
|
||||
|
|
@ -0,0 +1,75 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine allocate_fft
|
||||
!-----------------------------------------------------------------------
|
||||
! This routine computes the data structure associated to the FFT
|
||||
! grid and allocate memory for all the arrays which depend upon
|
||||
! these dimensions
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use gamma
|
||||
use allocate
|
||||
implicit none
|
||||
!
|
||||
! determines the data structure for fft arrays
|
||||
!
|
||||
#ifdef PARA
|
||||
call data_structure_para
|
||||
#else
|
||||
call data_structure_scal
|
||||
#endif
|
||||
!
|
||||
if (nrxx.lt.ngm) then
|
||||
write (6, '(/,4x," nr1=",i4," nr2= ", i4, " nr3=",i4, &
|
||||
&" nrxx = ",i8," ngm=",i8)') nr1, nr2, nr3, nrxx, ngm
|
||||
call error ('allocate_fft', 'the nr"s are too small!', 1)
|
||||
|
||||
endif
|
||||
if (nrxxs.lt.ngms) then
|
||||
write (6, '(/,4x," nr1s=",i4," nr2s= ", i4, " nr3s=",i4, &
|
||||
&" nrxxs = ",i8," ngms=",i8)') nr1s, nr2s, nr3s, nrxxs, ngms
|
||||
call error ('allocate_fft', 'the nrs"s are too small!', 1)
|
||||
|
||||
endif
|
||||
if (ngm.le.0) call error ('allocate_fft', 'wrong ngm', 1)
|
||||
if (ngms.le.0) call error ('allocate_fft', 'wrong ngms', 1)
|
||||
if (nrxx.le.0) call error ('allocate_fft', 'wrong nrxx', 1)
|
||||
if (nrxxs.le.0) call error ('allocate_fft', 'wrong nrxxs', 1)
|
||||
if (nspin.le.0) call error ('allocate_fft', 'wrong nspin', 1)
|
||||
!
|
||||
! Allocate memory for all kind of stuff.
|
||||
!
|
||||
call mallocate(g, 3, ngm)
|
||||
call mallocate(gg, ngm)
|
||||
call mallocate(nl, ngm)
|
||||
call mallocate(nlm, ngm)
|
||||
call mallocate(igtongl, ngm)
|
||||
call mallocate(ig1, ngm)
|
||||
call mallocate(ig2, ngm)
|
||||
call mallocate(ig3, ngm)
|
||||
call mallocate(rho, nrxx, nspin)
|
||||
call mallocate(rho_save, nrxx, nspin)
|
||||
call mallocate(vr, nrxx,nspin)
|
||||
call mallocate(vltot, nrxx)
|
||||
call mallocate(vnew , nrxx, nspin)
|
||||
call mallocate(rho_core, nrxx)
|
||||
call mallocate(psic, nrxx)
|
||||
call mallocate(vrs, nrxx, nspin)
|
||||
if (doublegrid) then
|
||||
call mallocate(nls, ngms)
|
||||
call mallocate(nlsm,ngms)
|
||||
else
|
||||
nls => nl
|
||||
nlsm=> nlm
|
||||
endif
|
||||
return
|
||||
end subroutine allocate_fft
|
||||
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine allocate_wfc
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! dynamical allocation of arrays: wavefunctions and eigenvectors
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use rbecmod
|
||||
use allocate
|
||||
implicit none
|
||||
!
|
||||
! Allocate memory
|
||||
!
|
||||
call mallocate(et, nbndx, nkstot)
|
||||
call mallocate(wg, nbnd, nkstot)
|
||||
call mallocate(evc, npwx, nbndx)
|
||||
allocate(becp(nkb, nbndx))
|
||||
! Needed with LDA+U
|
||||
|
||||
if (lda_plus_u) call mallocate(swfcatom, npwx, natomwfc)
|
||||
|
||||
call setv (nbndx * nkstot, 0.d0, et, 1)
|
||||
write (6, 100) nbndx, nbnd, natomwfc, npwx, nelec, nkb, ngl
|
||||
|
||||
100 format (/5x,'nbndx = ',i5,' nbnd = ',i5,' natomwfc = ',i5, &
|
||||
& ' npwx = ',i7, &
|
||||
& /5x,'nelec = ',f7.2,' nkb = ',i5,' ngl = ',i7)
|
||||
return
|
||||
end subroutine allocate_wfc
|
||||
|
||||
|
|
@ -0,0 +1,153 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine atomic_rho (rhoa, nspina)
|
||||
!-----------------------------------------------------------------------
|
||||
! This routine calculates rhoa as the superposition of atomic charges.
|
||||
!
|
||||
! nspina is the number of spin components to be calculated
|
||||
!
|
||||
! if nspina = 1 the total atomic charge density is calculated
|
||||
! if nspina = 2 the spin up and spin down atomic charge densities are
|
||||
! calculated assuming an uniform atomic spin-polarization
|
||||
! equal to starting_magnetization(nt)
|
||||
!
|
||||
! NB: nspina may not be equal to nspin because in some cases (as in upda
|
||||
! the total charge only could be needed, even in a LSDA calculation.
|
||||
!
|
||||
!
|
||||
#include "machine.h"
|
||||
|
||||
use pwcom
|
||||
use gamma
|
||||
use allocate
|
||||
implicit none
|
||||
integer :: nspina
|
||||
! the number of spin polarizations
|
||||
|
||||
real(kind=DP) :: rhoa (nrxx, nspina), rhoneg, rhorea, rhoima, gx
|
||||
real(kind=DP), pointer :: rhocgnt (:), aux (:)
|
||||
! the output atomic charge
|
||||
! negative charge
|
||||
! real charge
|
||||
! imaginary charge
|
||||
! the modulus of G
|
||||
! the value of the integral
|
||||
! the integrand function
|
||||
|
||||
complex(kind=DP), pointer :: rhocg (:,:)
|
||||
! auxiliary var: charge dens. in G spac
|
||||
|
||||
integer :: ir, is, ig, igl, igl0, nt
|
||||
! counter on mesh points
|
||||
! counter on spin polarizations
|
||||
! counter on G vectors
|
||||
! counter on G vectors shells
|
||||
! index of first shell with G != 0
|
||||
! counter on atom types
|
||||
|
||||
!
|
||||
! superposition of atomic charges contained in the array rho_at and
|
||||
! already set in readin-readvan
|
||||
!
|
||||
call mallocate(rhocg, ngm, nspina)
|
||||
call mallocate(aux, ndm)
|
||||
call mallocate(rhocgnt, ngl)
|
||||
|
||||
! psic is the generic work space
|
||||
call setv (nrxx, 0.d0, rhoa, 1)
|
||||
|
||||
call setv (2 * nspina * ngm, 0.d0, rhocg, 1)
|
||||
do nt = 1, ntyp
|
||||
!
|
||||
! Here we compute the G=0 term
|
||||
!
|
||||
if (gl (1) .lt.1.0d-8) then
|
||||
do ir = 1, msh (nt)
|
||||
aux (ir) = rho_at (ir, nt)
|
||||
enddo
|
||||
call simpson (msh (nt), aux, rab (1, nt), rhocgnt (1) )
|
||||
igl0 = 2
|
||||
else
|
||||
igl0 = 1
|
||||
endif
|
||||
!
|
||||
! Here we compute the G<>0 term
|
||||
!
|
||||
do igl = igl0, ngl
|
||||
gx = sqrt (gl (igl) ) * tpiba
|
||||
do ir = 1, msh (nt)
|
||||
if (r (ir, nt) .lt.1.0d-8) then
|
||||
aux (ir) = rho_at (ir, nt)
|
||||
else
|
||||
aux (ir) = rho_at (ir, nt) * sin (gx * r (ir, nt) ) / &
|
||||
(r (ir, nt) * gx)
|
||||
endif
|
||||
enddo
|
||||
call simpson (msh (nt), aux, rab (1, nt), rhocgnt (igl) )
|
||||
enddo
|
||||
!
|
||||
! we compute the 3D atomic charge in reciprocal space
|
||||
!
|
||||
if (nspina.eq.1) then
|
||||
do ig = 1, ngm
|
||||
rhocg (ig, 1) = rhocg (ig, 1) + strf (ig, nt) * &
|
||||
rhocgnt ( igtongl (ig) ) / omega
|
||||
enddo
|
||||
else
|
||||
|
||||
do ig = 1, ngm
|
||||
rhocg (ig, 1) = rhocg (ig, 1) + 0.5d0 * (1.d0 + &
|
||||
starting_magnetization (nt) ) * strf (ig, nt) * &
|
||||
rhocgnt ( igtongl (ig) ) / omega
|
||||
|
||||
rhocg (ig, 2) = rhocg (ig, 2) + 0.5d0 * (1.d0 - &
|
||||
starting_magnetization (nt) ) * strf (ig, nt) * &
|
||||
rhocgnt ( igtongl (ig) ) / omega
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
call mfree (rhocgnt)
|
||||
|
||||
call mfree (aux)
|
||||
do is = 1, nspina
|
||||
!
|
||||
! and we return to real space
|
||||
!
|
||||
call setv (2 * nrxx, 0.d0, psic, 1)
|
||||
do ig = 1, ngm
|
||||
psic (nl (ig) ) = rhocg (ig, is)
|
||||
psic (nlm(ig) ) = conjg( rhocg (ig, is) )
|
||||
enddo
|
||||
call cft3 (psic, nr1, nr2, nr3, nrx1, nrx2, nrx3, 1)
|
||||
!
|
||||
! we check that everything is correct
|
||||
!
|
||||
rhoneg = 0.d0
|
||||
rhoima = 0.d0
|
||||
do ir = 1, nrxx
|
||||
rhorea = DREAL (psic (ir) )
|
||||
rhoneg = rhoneg + min (0.d0, rhorea)
|
||||
rhoima = rhoima + abs (DIMAG (psic (ir) ) )
|
||||
rhoa (ir, is) = rhorea
|
||||
enddo
|
||||
rhoneg = rhoneg / (nr1 * nr2 * nr3)
|
||||
rhoima = rhoima / (nr1 * nr2 * nr3)
|
||||
#ifdef PARA
|
||||
call reduce (1, rhoneg)
|
||||
call reduce (1, rhoima)
|
||||
#endif
|
||||
if (rhoneg.lt. - 1.0d-4.or.rhoima.gt.1.0d-4) &
|
||||
write (6,'(/" Warning: negative or imaginary starting charge ",&
|
||||
&2f12.6,i3)') rhoneg, rhoima, is
|
||||
enddo
|
||||
|
||||
call mfree (rhocg)
|
||||
return
|
||||
end subroutine atomic_rho
|
||||
|
||||
|
|
@ -0,0 +1,178 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine c_bands (iter, ik_, dr2)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! This routine is a driver for the diagonalization routines of the
|
||||
! total Hamiltonian at Gammma point only
|
||||
! It reads the Hamiltonian and an initial guess of the wavefunctions
|
||||
! from a file and computes initialization quantities for Davidson
|
||||
! iterative diagonalization.
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use allocate
|
||||
use g_psi_mod
|
||||
implicit none
|
||||
!
|
||||
! First the I/O variables
|
||||
!
|
||||
integer :: ik_, iter
|
||||
! k-point already done
|
||||
! current iterations
|
||||
real(kind=DP) :: dr2
|
||||
! current accuracy of self-consistency
|
||||
!
|
||||
! here the local variables
|
||||
!
|
||||
|
||||
real(kind=DP) :: avg_iter, cg_iter, v_of_0, dsum, erf
|
||||
! average number of iterations
|
||||
! number of iteration in CG
|
||||
! the average of the potential
|
||||
! summation function
|
||||
! error function
|
||||
|
||||
integer :: ik, ig, ibnd, ntrt, ntry, notconv
|
||||
! counter on k points
|
||||
! counter on G vectors
|
||||
! counter on bands
|
||||
! number of iterations in Davidson
|
||||
! number or repeated call to EGTER
|
||||
! number of notconverged elements
|
||||
|
||||
if (ik_.eq.nks) then
|
||||
ik_ = 0
|
||||
return
|
||||
endif
|
||||
|
||||
call start_clock ('c_bands')
|
||||
!
|
||||
! allocate arrays
|
||||
!
|
||||
call mallocate(h_diag, npwx)
|
||||
|
||||
call mallocate(s_diag, npwx)
|
||||
|
||||
if (isolve.eq.0.and.loverlap) then
|
||||
write (6, '(" Davidson diagonalization with overlap")')
|
||||
else
|
||||
call error ('c_bands', 'not implemented', 1)
|
||||
endif
|
||||
avg_iter = 0.d0
|
||||
!
|
||||
! v_of_0 is (Vloc)(G=0)
|
||||
!
|
||||
v_of_0 = dsum (nrxx, vltot, 1) / float (nr1 * nr2 * nr3)
|
||||
#ifdef PARA
|
||||
call reduce (1, v_of_0)
|
||||
#endif
|
||||
!
|
||||
|
||||
if (nks.gt.1) rewind (iunigk)
|
||||
!
|
||||
! For each k point diagonalizes the hamiltonian
|
||||
!
|
||||
do ik = 1, nks
|
||||
if (lsda) current_spin = isk (ik)
|
||||
!
|
||||
! Reads the Hamiltonian and the list k+G <-> G of this k point
|
||||
!
|
||||
if (nks.gt.1) read (iunigk) npw, igk
|
||||
!
|
||||
! do not recalculate k-points if restored from a previous run
|
||||
!
|
||||
if (ik.le.ik_) goto 20
|
||||
!
|
||||
! various initializations
|
||||
!
|
||||
call init_us_2 (npw, igk, xk (1, ik), vkb)
|
||||
!
|
||||
! read in wavefunctions from the previous iteration
|
||||
!
|
||||
|
||||
if (nks.gt.1.or..not.reduce_io) call davcio (evc, nwordwfc, &
|
||||
iunwfc, ik, - 1)
|
||||
! Needed for LDA+U
|
||||
if (lda_plus_u) call davcio (swfcatom, nwordatwfc, iunat, ik,- 1)
|
||||
!
|
||||
! sets the kinetic energy
|
||||
!
|
||||
do ig = 1, npw
|
||||
g2kin (ig) = (xk (1, ik) + g (1, igk (ig) ) ) **2 + &
|
||||
(xk (2, ik) + g (2, igk (ig) ) ) **2 + &
|
||||
(xk (3, ik) + g (3, igk (ig) ) ) **2
|
||||
enddo
|
||||
!
|
||||
! Put the correct units on the kinetic energy
|
||||
!
|
||||
call DSCAL (npw, tpiba2, g2kin, 1)
|
||||
!
|
||||
! Put the correct units on the kinetic energy
|
||||
!
|
||||
if (qcutz.gt.0.d0) then
|
||||
do ig = 1, npw
|
||||
g2kin (ig) = g2kin (ig) + qcutz * (1.d0 + erf ( (g2kin (ig) &
|
||||
- ecfixed) / q2sigma) )
|
||||
enddo
|
||||
|
||||
endif
|
||||
!
|
||||
! h_diag are the diagonal matrix elements of the hamiltonian
|
||||
! used in g_psi to evaluate the correction to the trial eigenvectors
|
||||
!
|
||||
do ig = 1, npw
|
||||
h_diag (ig) = g2kin (ig) + v_of_0
|
||||
enddo
|
||||
call usnldiag (h_diag, s_diag)
|
||||
ntry = 0
|
||||
|
||||
15 continue
|
||||
|
||||
call regterg (npw, npwx, nbnd, nbndx, evc, ethr, gstart, &
|
||||
et (1, ik), notconv, ntrt)
|
||||
avg_iter = avg_iter + ntrt
|
||||
!
|
||||
! save wave-functions to be used as input for the iterative
|
||||
! diagonalization of the next scf iteration and for rho calculation
|
||||
!
|
||||
if (nks.gt.1.or..not.reduce_io) call davcio (evc, nwordwfc, &
|
||||
iunwfc, ik, 1)
|
||||
ntry = ntry + 1
|
||||
if (ntry.le.5.and. ( &
|
||||
.not.lscf.and.notconv.gt.0.or.lscf.and.notconv.gt.5) ) goto 15
|
||||
|
||||
if (notconv.ne.0) write (6, '(" warning : ",i3," eigenvectors not",&
|
||||
&" converged after ",i3," attemps")') notconv, ntry
|
||||
if (notconv.gt.max (5, nbnd / 4) ) stop
|
||||
20 continue
|
||||
!
|
||||
! save restart information
|
||||
!
|
||||
|
||||
call save_in_cbands (iter, ik, dr2)
|
||||
enddo
|
||||
ik_ = 0
|
||||
#ifdef PARA
|
||||
call poolreduce (1, avg_iter)
|
||||
#endif
|
||||
avg_iter = avg_iter / nkstot
|
||||
write (6, 9000) ethr, avg_iter
|
||||
!
|
||||
! deallocate work space
|
||||
!
|
||||
call mfree (s_diag)
|
||||
call mfree (h_diag)
|
||||
|
||||
call stop_clock ('c_bands')
|
||||
return
|
||||
9000 format(5x,'ethr = ',1pe9.2,', avg # of iterations =',0pf5.1 )
|
||||
end subroutine c_bands
|
||||
|
||||
|
|
@ -0,0 +1,148 @@
|
|||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine cg_readin
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
use pwcom
|
||||
use cgcom
|
||||
use io
|
||||
implicit none
|
||||
integer :: iunit
|
||||
namelist /inputph/ prefix, fildyn, trans, epsil, raman, nmodes, &
|
||||
tr2_ph, niter_ph, amass, tmp_dir, asr, deltatau, nderiv, &
|
||||
first, last
|
||||
!
|
||||
call start_clock('cg_readin')
|
||||
!
|
||||
prefix = 'pwscf'
|
||||
fildyn = 'matdyn'
|
||||
epsil = .true.
|
||||
trans = .true.
|
||||
raman = .true.
|
||||
asr = .false.
|
||||
tr2_ph = 1.0e-12
|
||||
niter_ph= 50
|
||||
nmodes = 0
|
||||
deltatau= 0.0
|
||||
nderiv = 2
|
||||
first = 1
|
||||
last = 0
|
||||
#if defined(T3E) || defined(ORIGIN)
|
||||
iunit=9
|
||||
#else
|
||||
iunit=5
|
||||
#endif
|
||||
read(iunit,'(a)') title_ph
|
||||
read(iunit,inputph)
|
||||
#ifdef PARA
|
||||
call init_pool
|
||||
#endif
|
||||
!
|
||||
! read the input file produced by 'punch' subroutine in pwscf program
|
||||
! allocate memory and recalculate what is needed
|
||||
!
|
||||
call read_file
|
||||
!
|
||||
! various checks
|
||||
!
|
||||
if (.not.trans .and. .not.epsil) &
|
||||
& call error('data','nothing to do',1)
|
||||
if (nks.ne.1) call error('data','too many k-points',1)
|
||||
! if (xk(1,1).ne.0.0 .or. xk(2,1).ne.0.0 .or. xk(3,1).ne.0.0)
|
||||
! & call error('data','only k=0 allowed',1)
|
||||
if (nmodes.gt.3*nat .or. nmodes.lt.0) &
|
||||
& call error('data','wrong number of normal modes',1)
|
||||
if (epsil .and. nmodes.ne.0) call error('data','not allowed',1)
|
||||
if (raman .and. deltatau.le.0.d0) &
|
||||
& call error('data','deltatau > 0 needed for raman CS',1)
|
||||
if (nderiv.ne.2 .and. nderiv.ne.4) &
|
||||
call error('data','nderiv not allowed',1)
|
||||
!
|
||||
if (last.eq.0) last=3*nat
|
||||
!
|
||||
call cg_readmodes(iunit)
|
||||
!
|
||||
call stop_clock('cg_readin')
|
||||
!
|
||||
return
|
||||
end subroutine cg_readin
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine cg_readmodes(iunit)
|
||||
!-----------------------------------------------------------------------
|
||||
#include "machine.h"
|
||||
use parameters, only: DP
|
||||
use allocate
|
||||
use pwcom
|
||||
use cgcom
|
||||
!
|
||||
implicit none
|
||||
integer :: iunit
|
||||
!
|
||||
integer :: na, nu, mu
|
||||
real(kind=DP) utest, unorm, DDOT
|
||||
!
|
||||
! allocate space for modes, dynamical matrix, auxiliary stuff
|
||||
!
|
||||
call mallocate (u, 3*nat, 3*nat)
|
||||
call mallocate (dyn,3*nat, 3*nat)
|
||||
call mallocate (equiv_atoms, nat, nat)
|
||||
call mallocate (n_equiv_atoms, nat)
|
||||
call mallocate (has_equivalent,nat)
|
||||
!
|
||||
! nmodes not given: use defaults (all modes) as normal modes ...
|
||||
!
|
||||
if (nmodes.eq.0) then
|
||||
call find_equiv_sites (nat,nat,nsym,irt,has_equivalent, &
|
||||
& n_diff_sites,n_equiv_atoms,equiv_atoms)
|
||||
if (n_diff_sites .le. 0 .or. n_diff_sites .gt. nat) &
|
||||
& call error('equiv.sites','boh!',1)
|
||||
!
|
||||
! these are all modes, but only independent modes are calculated
|
||||
!
|
||||
nmodes = 3*nat
|
||||
call setv(3*nat*nmodes,0.d0,u,1)
|
||||
do nu = 1,nmodes
|
||||
u(nu,nu) = 1.0
|
||||
end do
|
||||
! look if ASR can be exploited to reduce the number of calculations
|
||||
! we need to locate an independent atom with no equivalent atoms
|
||||
nasr=0
|
||||
if (asr.and.n_diff_sites.gt.1) then
|
||||
do na = 1, n_diff_sites
|
||||
if (n_equiv_atoms(na).eq.1 ) then
|
||||
nasr = equiv_atoms(na, 1)
|
||||
go to 1
|
||||
end if
|
||||
end do
|
||||
1 continue
|
||||
end if
|
||||
else
|
||||
if (asr) call error('readin','warning: asr disabled',-1)
|
||||
nasr=0
|
||||
!
|
||||
! ... otherwise read normal modes from input
|
||||
!
|
||||
do na = 1,nat
|
||||
has_equivalent(na) = 0
|
||||
end do
|
||||
do nu = 1,nmodes
|
||||
read (iunit,*,end=10,err=10) (u(mu,nu), mu=1,3*nat)
|
||||
do mu = 1, nu-1
|
||||
utest = DDOT(3*nat,u(1,nu),1,u(1,mu),1)
|
||||
if (abs(utest).gt.1.0e-10) then
|
||||
print *, ' warning: input modes are not orthogonal'
|
||||
call DAXPY(3*nat,-utest,u(1,mu),1,u(1,nu),1)
|
||||
end if
|
||||
end do
|
||||
unorm = sqrt(DDOT(3*nat,u(1,nu),1,u(1,nu),1))
|
||||
if (abs(unorm).lt.1.0e-10) go to 10
|
||||
call DSCAL(3*nat,1.0/unorm,u(1,nu),1)
|
||||
end do
|
||||
go to 20
|
||||
10 call error('phonon','wrong data read',1)
|
||||
endif
|
||||
20 continue
|
||||
!
|
||||
return
|
||||
end subroutine cg_readmodes
|
||||
|
|
@ -0,0 +1,112 @@
|
|||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine cg_setup
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
#include "machine.h"
|
||||
use parameters, only: DP
|
||||
use allocate
|
||||
use pwcom
|
||||
use io, only: prefix
|
||||
use cgcom
|
||||
use funct
|
||||
!
|
||||
implicit none
|
||||
!
|
||||
integer :: i, l, nt, kpoint
|
||||
logical :: exst
|
||||
character (len=20) :: filint
|
||||
real(kind=DP) :: rhotot, dmxc
|
||||
external dmxc
|
||||
!
|
||||
call start_clock('cg_setup')
|
||||
!
|
||||
! convert masses to atomic units
|
||||
!
|
||||
call DSCAL(ntyp,amconv,amass,1)
|
||||
!
|
||||
! sum self-consistent part (vr) and local part (vltot) of potential
|
||||
!
|
||||
call set_vrs(vrs,vltot,vr,nrxx,nspin,doublegrid)
|
||||
!
|
||||
! allocate memory for various arrays
|
||||
!
|
||||
call mallocate (dmuxc, nrxx)
|
||||
call mallocate (dvpsi, npwx, nbnd)
|
||||
call mallocate ( dpsi, npwx, nbnd)
|
||||
call mallocate ( auxr, nrxx)
|
||||
call mallocate ( aux2, nrxx)
|
||||
call mallocate ( aux3, nrxx)
|
||||
!
|
||||
! allocate memory for gradient corrections (if needed)
|
||||
!
|
||||
if (igcx.ne.0 .or. igcc.ne.0) then
|
||||
call mallocate ( dvxc_rr,nrxx,nspin,nspin)
|
||||
call mallocate ( dvxc_sr,nrxx,nspin,nspin)
|
||||
call mallocate ( dvxc_ss,nrxx,nspin,nspin)
|
||||
call mallocate ( dvxc_s ,nrxx,nspin,nspin)
|
||||
call mallocate ( grho ,3, nrxx, nspin)
|
||||
end if
|
||||
!
|
||||
!
|
||||
! initialize structure factor array
|
||||
!
|
||||
call struc_fact ( nat, tau, ntyp, ityp, ngm, g, bg, &
|
||||
& nr1, nr2, nr3, strf, eigts1, eigts2, eigts3 )
|
||||
!
|
||||
! compute drhocore/dtau for each atom type (if needed)
|
||||
!
|
||||
nlcc_any = .false.
|
||||
do nt=1,ntyp
|
||||
nlcc_any = nlcc_any .or. nlcc(nt)
|
||||
end do
|
||||
!!! if (nlcc_any) call set_drhoc(xq)
|
||||
!
|
||||
! local potential
|
||||
!
|
||||
call init_vloc
|
||||
!
|
||||
call convert_to_num &
|
||||
& (ntyp,numeric,ndm,mesh,r,lmaxx,lmax,lloc,nnl,aps,alps,vnl)
|
||||
!
|
||||
call init_us_1
|
||||
!
|
||||
call newd
|
||||
!
|
||||
! derivative of the xc potential
|
||||
!
|
||||
call setv(nrxx,0.d0,dmuxc,1)
|
||||
do i = 1,nrxx
|
||||
rhotot = rho(i,current_spin)+rho_core(i)
|
||||
if ( rhotot.gt. 1.d-30 ) dmuxc(i)= dmxc( rhotot)
|
||||
if ( rhotot.lt.-1.d-30 ) dmuxc(i)=-dmxc(-rhotot)
|
||||
end do
|
||||
!
|
||||
! initialize data needed for gradient corrections
|
||||
!
|
||||
call cg_setupdgc
|
||||
!
|
||||
iunres=88
|
||||
!
|
||||
! open the wavefunction file (already existing)
|
||||
!
|
||||
lrwfc=2*nbnd*npwx
|
||||
filint = trim(prefix) //'.wfc'
|
||||
call diropn(iunpun,filint,lrwfc,exst)
|
||||
if(.not.exst) call error('main','file '//filpun//' not found',1)
|
||||
!
|
||||
! read wave functions and calculate indices
|
||||
!
|
||||
kpoint=1
|
||||
call davcio(evc,lrwfc,iunpun,kpoint,-1)
|
||||
close(unit=iunpun,status='keep')
|
||||
call gk_sort (xk(1,kpoint),ngm,g,ecutwfc/tpiba2,npw,igk,g2kin)
|
||||
!
|
||||
! Kleinman-Bylander PPs
|
||||
!
|
||||
call init_us_2 (npw, igk, xk(1,kpoint), vkb)
|
||||
!
|
||||
call stop_clock('cg_setup')
|
||||
!
|
||||
return
|
||||
end subroutine cg_setup
|
||||
|
|
@ -0,0 +1,129 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine cg_setupdgc
|
||||
!-----------------------------------------------------------------------
|
||||
! Setup all arrays needed in the gradient correction case
|
||||
! This version requires on input allocated array
|
||||
!
|
||||
use parameters, only: DP
|
||||
use pwcom
|
||||
use cgcom
|
||||
use funct
|
||||
!
|
||||
implicit none
|
||||
integer k, is
|
||||
real(kind=DP) &
|
||||
& grho2(2), rh, zeta, grh2, epsr, epsg, fac, &
|
||||
& sx,sc,v1x,v2x,v1c,v2c,vrrx,vsrx,vssx, &
|
||||
& vrrc,vsrc,vssc, &
|
||||
& v1xup,v1xdw,v2xup,v2xdw, &
|
||||
& v1cup,v1cdw, &
|
||||
& vrrxup,vrrxdw,vrsxup,vrsxdw,vssxup,vssxdw, &
|
||||
& vrrcup,vrrcdw,vrscup,vrscdw, &
|
||||
& vrzcup,vrzcdw
|
||||
!
|
||||
parameter (epsr=1.0d-6, epsg=1.0d-10)
|
||||
!
|
||||
if (igcx.eq.0 .and. igcc.eq.0) return
|
||||
call start_clock('setup_dgc')
|
||||
!
|
||||
call setv(nrxx*nspin*nspin,0.d0,dvxc_rr,1)
|
||||
call setv(nrxx*nspin*nspin,0.d0,dvxc_sr,1)
|
||||
call setv(nrxx*nspin*nspin,0.d0,dvxc_ss,1)
|
||||
call setv(nrxx*nspin*nspin,0.d0,dvxc_s ,1)
|
||||
call setv(3*nrxx*nspin,0.d0,grho ,1)
|
||||
!
|
||||
! add rho_core
|
||||
!
|
||||
fac=1.d0/float(nspin)
|
||||
if (nlcc_any) then
|
||||
do is=1,nspin
|
||||
do k=1,nrxx
|
||||
rho(k,is)=rho(k,is)+ rho_core(k)*fac
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
do is=1,nspin
|
||||
call gradient (nrx1,nrx2,nrx3,nr1,nr2,nr3,nrxx,rho(1,is), &
|
||||
ngm,g,nl,alat,grho(1,1,is))
|
||||
enddo
|
||||
!
|
||||
if (nspin.eq.1) then
|
||||
do k = 1,nrxx
|
||||
grho2(1)=grho(1,k,1)**2+grho(2,k,1)**2+grho(3,k,1)**2
|
||||
if (abs(rho(k,1)).gt.epsr.and.grho2(1).gt.epsg) then
|
||||
call gcxc(rho(k,nspin),grho2,sx,sc,v1x,v2x,v1c,v2c)
|
||||
call dgcxc(rho(k,nspin),grho2,vrrx,vsrx,vssx,vrrc,vsrc,vssc)
|
||||
dvxc_rr(k,1,1) = e2 * ( vrrx + vrrc )
|
||||
dvxc_sr(k,1,1) = e2 * ( vsrx + vsrc )
|
||||
dvxc_ss(k,1,1) = e2 * ( vssx + vssc )
|
||||
dvxc_s (k,1,1) = e2 * ( v2x + v2c )
|
||||
endif
|
||||
end do
|
||||
else
|
||||
do k = 1,nrxx
|
||||
grho2(2)=grho(1,k,2)**2+grho(2,k,2)**2+grho(3,k,2)**2
|
||||
rh=rho(k,1)+rho(k,2)
|
||||
grh2= (grho(1,k,1)+grho(1,k,2))**2 &
|
||||
+ (grho(2,k,1)+grho(2,k,2))**2 &
|
||||
+ (grho(3,k,1)+grho(3,k,2))**2
|
||||
!
|
||||
call gcx_spin(rho(k,1),rho(k,2),grho2(1),grho2(2),sx, &
|
||||
v1xup,v1xdw,v2xup,v2xdw)
|
||||
!
|
||||
call dgcxc_spin(rho(k,1),rho(k,2),grho(1,k,1),grho(1,k,2), &
|
||||
vrrxup,vrrxdw,vrsxup,vrsxdw,vssxup,vssxdw, &
|
||||
vrrcup,vrrcdw,vrscup,vrscdw,vssc,vrzcup,vrzcdw)
|
||||
!
|
||||
if (rh.gt.epsr) then
|
||||
zeta=(rho(k,1)-rho(k,2))/rh
|
||||
call gcc_spin(rh,zeta,grh2,sc,v1cup,v1cdw,v2c)
|
||||
!
|
||||
dvxc_rr(k,1,1)=e2*(vrrxup+vrrcup+vrzcup*(1.d0-zeta)/rh)
|
||||
dvxc_rr(k,1,2)=e2*(vrrcup-vrzcup*(1.d0+zeta)/rh)
|
||||
dvxc_rr(k,2,1)=e2*(vrrcdw+vrzcdw*(1.d0-zeta)/rh)
|
||||
dvxc_rr(k,2,2)=e2*(vrrxdw+vrrcdw-vrzcdw*(1.d0+zeta)/rh)
|
||||
!
|
||||
dvxc_s(k,1,1)=e2*(v2xup+v2c)
|
||||
dvxc_s(k,1,2)=e2*v2c
|
||||
dvxc_s(k,2,1)=e2*v2c
|
||||
dvxc_s(k,2,2)=e2*(v2xdw+v2c)
|
||||
else
|
||||
dvxc_rr(k,1,1)=0.d0
|
||||
dvxc_rr(k,1,2)=0.d0
|
||||
dvxc_rr(k,2,1)=0.d0
|
||||
dvxc_rr(k,2,2)=0.d0
|
||||
!
|
||||
dvxc_s(k,1,1)=0.d0
|
||||
dvxc_s(k,1,2)=0.d0
|
||||
dvxc_s(k,2,1)=0.d0
|
||||
dvxc_s(k,2,2)=0.d0
|
||||
endif
|
||||
dvxc_sr(k,1,1)=e2*(vrsxup+vrscup)
|
||||
dvxc_sr(k,1,2)=e2*vrscup
|
||||
dvxc_sr(k,2,1)=e2*vrscdw
|
||||
dvxc_sr(k,2,2)=e2*(vrsxdw+vrscdw)
|
||||
!
|
||||
dvxc_ss(k,1,1)=e2*(vssxup+vssc)
|
||||
dvxc_ss(k,1,2)=e2*vssc
|
||||
dvxc_ss(k,2,1)=e2*vssc
|
||||
dvxc_ss(k,2,2)=e2*(vssxdw+vssc)
|
||||
enddo
|
||||
endif
|
||||
if (nlcc_any) then
|
||||
do is=1,nspin
|
||||
do k=1,nrxx
|
||||
rho(k,is)=rho(k,is)- rho_core(k)*fac
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
call stop_clock('setup_dgc')
|
||||
!
|
||||
return
|
||||
end subroutine cg_setupdgc
|
||||
|
|
@ -0,0 +1,80 @@
|
|||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine cg_summary
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
!%%%%%%%%%% summarize input data %%%%%%%%%%%%%%%%%%%
|
||||
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
!
|
||||
use pwcom
|
||||
use cgcom
|
||||
!
|
||||
implicit none
|
||||
integer :: nu, mu, i,l, na, nt
|
||||
!
|
||||
write (6,'(/5x,a75)') title
|
||||
write (6,9010) crystal,alat,omega,nat,ecutwfc,gcutm,tr2_ph
|
||||
!
|
||||
write (6,9020) (i,celldm(i),i=1,6)
|
||||
write (6,9030) ngm,nr1,nr2,nr3,nks
|
||||
write (6,9040)
|
||||
write (6,9050) (na,atm(ityp(na)),amass(ityp(na))/amconv, &
|
||||
& (tau(i,na),i=1,3),na=1,nat)
|
||||
do nt = 1,ntyp
|
||||
write (6,9060) nlc(nt), nnl(nt)
|
||||
write (6,9070) nt,psd(nt),zp(nt),lmax(nt),lloc(nt)
|
||||
write (6,9080)
|
||||
write (6,'(/5x,"core")')
|
||||
write (6,9090) (alpc(i,nt),i=1,2)
|
||||
write (6,9100) (cc(i,nt),i=1,2)
|
||||
do l = 0,lmax(nt)
|
||||
write (6,'(/5x,"l = ",i2)') l
|
||||
write (6,9090) (alps(i,l,nt),i=1,3)
|
||||
write (6,9100) (aps(i,l,nt),i=1,3)
|
||||
write (6,9110) (aps(i,l,nt),i=4,6)
|
||||
end do
|
||||
end do
|
||||
write (6,9115)
|
||||
do nt = 1,ntyp
|
||||
write (6,9116) atm(nt),zv(nt),psd(nt)
|
||||
end do
|
||||
write (6, &
|
||||
&'(//5x,"atomic displacements are normalized to unity"/)')
|
||||
if (nmodes.lt.3*nat) then
|
||||
write (6, &
|
||||
& '(5x,"phonon polarizations are as follows:"/)')
|
||||
do nu = 1,nmodes
|
||||
write (6,'(" mode # ",i3)') nu
|
||||
write (6,'(3(" (",f6.3,2f7.3,") "))') &
|
||||
& ( u(mu,nu), mu = 1,3*nat)
|
||||
end do
|
||||
end if
|
||||
!
|
||||
return
|
||||
!
|
||||
9010 format (//5x,'crystal is ',a20 &
|
||||
& //5x,'lattice parameter = ',f12.4 &
|
||||
& /5x,'unit-cell volume = ',f12.4 &
|
||||
& /5x,'number of atoms /cell = ',i12 &
|
||||
& /5x,'kinetic-energy cutoff = ',f12.4 &
|
||||
& /5x,'g-space cutoff (gcutm)= ',f12.4 &
|
||||
& /5x,'convergence threshold = ',1pe12.1/)
|
||||
!
|
||||
9020 format(/ 2 ( 3x,3(2x,'celldm(',i1,')=',f11.7) / ))
|
||||
9030 format (5x,'ngm =',i6,' nr1 =',i5,' nr2 =',i5,' nr3 =',i5, &
|
||||
& ' nks =',i5)
|
||||
9040 format (/5x,'site no atom mass',27x,'tau')
|
||||
9050 format (7x,i2,9x,a2,3x,f8.4,9x,3f11.7)
|
||||
9060 format (/15x,'atomic pseudopotential parameters', &
|
||||
& ': nlc =',i4,' nnl =',i4/)
|
||||
9070 format (/5x,'atom',i2,' is ',a2,' zval =',f5.1,' lmax=',i2, &
|
||||
& ' lloc=',i2)
|
||||
9080 format (/14x,'i=',7x,'1',10x,'2',10x,'3')
|
||||
9090 format (5x,'alpha =',4x,3g11.5)
|
||||
9100 format (5x,'a(i) =',4x,3g11.5)
|
||||
9110 format (5x,'a(i+3)=',4x,3g11.5)
|
||||
9115 format (/5x,'atomic species valence pseudopotential')
|
||||
9116 format (5x,a6,9x,f10.2,8x,5 (a2,'(',f5.2,')'))
|
||||
!
|
||||
end subroutine cg_summary
|
||||
|
|
@ -0,0 +1,76 @@
|
|||
!
|
||||
! These are PHONON-specific modules (Conjugate Gradient version)
|
||||
!
|
||||
module phunits
|
||||
character(len=20) :: fildyn
|
||||
character(len=75) :: title_ph
|
||||
integer iuwfc, iubar, iudwf, iuscf, iuvkb, lrwfc, lrbar, lrdwf, lrscf
|
||||
end module phunits
|
||||
|
||||
module flags
|
||||
logical :: trans, epsil, raman, equil, nlcc_any, asr
|
||||
end module flags
|
||||
|
||||
module dielectric
|
||||
use parameters, only: DP
|
||||
real(kind=DP) :: epsilon0(3,3)
|
||||
real(kind=DP), pointer :: zstar(:,:,:)
|
||||
end module dielectric
|
||||
module modes1
|
||||
use parameters, only: DP
|
||||
integer :: nmodes
|
||||
real(kind=DP), pointer:: dyn(:,:), u(:,:)
|
||||
end module modes1
|
||||
|
||||
module cgconv
|
||||
use parameters, only: DP
|
||||
integer :: niter_ph
|
||||
real(kind=DP) :: tr2_ph
|
||||
end module cgconv
|
||||
|
||||
module AA
|
||||
use parameters, only: DP
|
||||
complex(kind=DP), pointer :: aux2(:), aux3(:)
|
||||
real(kind=DP), pointer :: auxr(:)
|
||||
end module AA
|
||||
|
||||
module dmu
|
||||
use parameters, only: DP
|
||||
real(kind=DP), pointer:: &
|
||||
dmuxc(:), &! d V_xc / d rho
|
||||
grho(:,:,:), &! gradient of the unperturbed density
|
||||
dvxc_rr(:,:,:), &!
|
||||
dvxc_sr(:,:,:), &! derivatives of the E_xc functional w.r.t.
|
||||
dvxc_ss(:,:,:), &! r=rho and s=|grad(rho)|
|
||||
dvxc_s (:,:,:)
|
||||
end module dmu
|
||||
|
||||
module phon
|
||||
use parameters, only: DP
|
||||
complex(kind=DP), pointer:: dvpsi(:,:), dpsi(:,:)
|
||||
end module phon
|
||||
|
||||
module symmetry
|
||||
integer :: n_diff_sites, nasr
|
||||
integer, pointer:: equiv_atoms(:,:), n_equiv_atoms(:)
|
||||
integer, pointer:: has_equivalent(:)
|
||||
end module symmetry
|
||||
|
||||
module diffs
|
||||
use parameters, only: DP
|
||||
integer :: nderiv, first, last
|
||||
real(kind=DP) :: deltatau
|
||||
end module diffs
|
||||
|
||||
module cgcom
|
||||
use cgconv
|
||||
use phunits
|
||||
use flags
|
||||
use modes1
|
||||
use AA
|
||||
use phon
|
||||
use diffs
|
||||
use dmu
|
||||
use symmetry
|
||||
use dielectric
|
||||
end module cgcom
|
||||
|
|
@ -0,0 +1,146 @@
|
|||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine cgsolve (operator,npw,evc,npwx,nbnd,overlap, &
|
||||
& nbndx,orthonormal,precondition,diagonal, &
|
||||
& startwith0,e,b,u,h,Ah,pu,niter,eps,iter,x)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! conjugate-gradient solution of a system of constrained linear equations
|
||||
! "operator" is the linear operator - diagonal preconditioning allowed
|
||||
! x = solution, u = gradient, h = conjugate gradient, Ah = operator*h
|
||||
!
|
||||
#include "machine.h"
|
||||
use parameters, only: DP
|
||||
implicit none
|
||||
integer npw, npwx, nbnd, nbndx, niter, iter
|
||||
real(kind=DP) :: diagonal(npw), e(nbnd), overlap(nbndx,nbnd)
|
||||
complex(kind=DP) :: x(npwx,nbnd), b(npwx,nbnd), u(npwx,nbnd), &
|
||||
h(npwx,nbnd),Ah(npwx,nbnd),evc(npwx,nbnd), pu(npwx,nbnd)
|
||||
logical :: orthonormal, precondition,startwith0
|
||||
!
|
||||
integer :: ibnd, jbnd, i, info
|
||||
real(kind=DP) :: lagrange(nbnd,nbnd)
|
||||
real(kind=DP) :: lambda, u_u, uu0, u_A_h, alfa, eps, uu(nbnd), DDOT
|
||||
external DDOT, operator
|
||||
!
|
||||
call start_clock('cgsolve')
|
||||
!
|
||||
! starting gradient |u> = (A|x>-|b>)-lambda|psi> (lambda=<Ax-b|psi_i>)
|
||||
!
|
||||
if (.not.startwith0) then
|
||||
call operator(e,x,u)
|
||||
else
|
||||
call setv(2*npwx*nbnd,0.d0,u,1)
|
||||
! note that we assume x=0 on input
|
||||
end if
|
||||
!
|
||||
call DAXPY(2*npwx*nbnd,-1.d0,b,1,u,1)
|
||||
if (precondition) then
|
||||
call zvscal(npw,npwx,nbnd,diagonal,u,pu)
|
||||
call pw_gemm ('Y', nbnd, nbnd, npw, evc, npwx, pu, npwx, lagrange, nbnd)
|
||||
else
|
||||
call pw_gemm ('Y', nbnd, nbnd, npw, evc, npwx, u, npwx, lagrange, nbnd)
|
||||
end if
|
||||
if (.not. orthonormal) &
|
||||
call DPOTRS('U',nbnd,nbnd,overlap,nbndx,lagrange,nbnd,info)
|
||||
if (info.ne.0) call error('cgsolve','error in potrs',info)
|
||||
!
|
||||
call DGEMM ('N', 'N', 2*npw, nbnd, nbnd, -1.d0, evc, &
|
||||
2*npwx, lagrange, nbndx, 1.d0, u, 2*npwx)
|
||||
!
|
||||
! starting conjugate gradient |h> = |u>
|
||||
if (precondition) then
|
||||
call zvscal(npw,npwx,nbnd,diagonal,u,h)
|
||||
else
|
||||
call ZCOPY(npwx,nbnd,u,1,h,1)
|
||||
end if
|
||||
! uu = <u|h>
|
||||
call pw_dot('Y',npw,nbnd,u,npwx,h,npwx,uu)
|
||||
u_u = 0.0d0
|
||||
do ibnd=1,nbnd
|
||||
u_u = u_u + uu(ibnd)
|
||||
end do
|
||||
!
|
||||
! print '('' iter # '',i3,'' u_u = '',e10.4)', 0, u_u
|
||||
!
|
||||
! main iteration loop
|
||||
!
|
||||
do iter = 1, niter
|
||||
!
|
||||
! calculate A|h>
|
||||
!
|
||||
call operator(e,h,Ah)
|
||||
!
|
||||
! u_A_h = <u|A|h> (NB: must be equal to <h|A|h>)
|
||||
if (precondition) then
|
||||
call zvscal(npw,npwx,nbnd,diagonal,u,pu)
|
||||
! uu = <u|PA|h>
|
||||
call pw_dot('Y',npw,nbnd,pu,npwx,Ah,npwx,uu)
|
||||
else
|
||||
! uu = <u|A|h>
|
||||
call pw_dot('Y',npw,nbnd, u,npwx,Ah,npwx,uu)
|
||||
end if
|
||||
u_A_h = 0.0d0
|
||||
do ibnd=1,nbnd
|
||||
u_A_h = u_A_h + uu(ibnd)
|
||||
end do
|
||||
!
|
||||
lambda = - u_u / u_A_h
|
||||
! update the gradient and the trial solution
|
||||
uu0 = u_u
|
||||
u_u = 0.0
|
||||
call DAXPY(2*npwx*nbnd,lambda, h,1,x,1)
|
||||
call DAXPY(2*npwx*nbnd,lambda,Ah,1,u,1)
|
||||
! lagrange multipliers ensure orthogonality of the solution
|
||||
if (precondition) then
|
||||
call zvscal(npw,npwx,nbnd,diagonal,u,pu)
|
||||
call pw_gemm ('Y',nbnd, nbnd, npw, evc, npwx, pu, npwx, lagrange, nbnd)
|
||||
else
|
||||
call pw_gemm ('Y',nbnd, nbnd, npw, evc, npwx, u, npwx, lagrange, nbnd)
|
||||
end if
|
||||
if (.not. orthonormal) &
|
||||
call DPOTRS('U',nbnd,nbnd,overlap,nbndx,lagrange,nbnd,info)
|
||||
if (info.ne.0) call error('cgsolve','error in potrs',info)
|
||||
call DGEMM ('N', 'N', 2*npw, nbnd, nbnd,-1.d0, evc, &
|
||||
2*npwx, lagrange, nbndx, 1.d0, u, 2*npwx)
|
||||
if (precondition) then
|
||||
call zvscal(npw,npwx,nbnd,diagonal,u,pu)
|
||||
! uu = <u|A|u>
|
||||
call pw_dot('Y',npw,nbnd, u,npwx,pu,npwx,uu)
|
||||
else
|
||||
! uu = <u|u>
|
||||
call pw_dot('Y',npw,nbnd, u,npwx, u,npwx,uu)
|
||||
end if
|
||||
u_u = 0.0d0
|
||||
do ibnd=1,nbnd
|
||||
u_u = u_u + uu(ibnd)
|
||||
end do
|
||||
! print '('' iter # '',i3,'' u_u = '',e10.4)', iter, u_u
|
||||
!
|
||||
if( u_u .le. eps) go to 10
|
||||
if (iter.eq.niter) then
|
||||
write(6,'('' *** Conjugate Gradient minimization'', &
|
||||
& '' not converged after '',i3,'' iterations''/ &
|
||||
& '' residual norm |Ax-b|^2 : '',e10.4)') iter,u_u
|
||||
go to 10
|
||||
end if
|
||||
! update the conjugate gradient
|
||||
alfa = u_u / uu0
|
||||
do ibnd = 1,nbnd
|
||||
if (precondition) then
|
||||
do i=1,npw
|
||||
h(i,ibnd) = alfa*h(i,ibnd) + u(i,ibnd)*diagonal(i)
|
||||
end do
|
||||
else
|
||||
do i=1,npw
|
||||
h(i,ibnd) = alfa*h(i,ibnd) + u(i,ibnd)
|
||||
end do
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
!
|
||||
10 continue
|
||||
call stop_clock('cgsolve')
|
||||
!
|
||||
return
|
||||
end subroutine cgsolve
|
||||
|
|
@ -0,0 +1,163 @@
|
|||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine d2ion (nat,ntyp,ityp,zv,tau,alat,omega, &
|
||||
at,bg,g,gg,ngm,nmodes,u,has_equivalent,dyn)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! calculate the ionic contribution to the dynamical matrix
|
||||
! (both real- and reciprocal-space contributions are present)
|
||||
!
|
||||
#include "machine.h"
|
||||
use parameters, only : DP
|
||||
implicit none
|
||||
integer :: nat, ntyp, ngm, ityp(nat), nmodes, has_equivalent(nat)
|
||||
real(kind=DP):: tau(3,nat), g(3,ngm), gg(ngm), zv(ntyp), &
|
||||
u(3*nat,nmodes), dyn(3*nat,nmodes), at(3,3), bg(3,3), omega, alat
|
||||
!
|
||||
integer :: nu_i,nu_j, mu_i,mu_j, na,nb, nta,ntb, ng, mxr, nrm, nr, i
|
||||
parameter(mxr=50)
|
||||
real(kind=DP) :: facg(nat), arg, tpi, fpi, tpiba2, e2, alpha, &
|
||||
r(3,mxr), r2(mxr), dtau(3), erfc, rmax, rr, &
|
||||
upperbound, charge, gt2, fac, fnat, df, d2f, ar
|
||||
parameter(e2=2.0, tpi=2.0*3.14159265358979d0 )
|
||||
external erfc, rgen
|
||||
!
|
||||
!
|
||||
tpiba2 = (tpi/alat)**2
|
||||
fpi = 2.0*tpi
|
||||
!
|
||||
charge = 0.0
|
||||
do na=1, nat
|
||||
charge = charge + zv(ityp(na))
|
||||
end do
|
||||
!
|
||||
alpha=0.5
|
||||
! appropriate for c60
|
||||
write(6,'('' d2ion: alpha = '',f6.2)') alpha
|
||||
!
|
||||
call setv(3*nat*nmodes,0.d0,dyn,1)
|
||||
!
|
||||
! G-space sum here
|
||||
!
|
||||
do ng = 1, ngm
|
||||
!
|
||||
! for parallel execution: first vector not necessarily G=0
|
||||
!
|
||||
if(gg(ng).lt.1.e-6) go to 10
|
||||
!
|
||||
! upperbound is a safe upper bound for the error ON THE ENERGY
|
||||
!
|
||||
upperbound=e2*charge**2*sqrt(2*alpha/tpi)* &
|
||||
& erfc(sqrt(tpiba2*gg(ng)/4.0/alpha))
|
||||
if(upperbound.lt.1.0e-6) go to 20
|
||||
!
|
||||
gt2 = gg(ng)*tpiba2
|
||||
fac = -e2*fpi*tpiba2/omega*exp(-gt2/alpha/4.0)/gt2
|
||||
do na = 1,nat
|
||||
nta= ityp(na)
|
||||
fnat = 0.0
|
||||
do nb= 1,nat
|
||||
ntb= ityp(nb)
|
||||
arg = tpi*(g(1,ng)*(tau(1,na)-tau(1,nb))+ &
|
||||
g(2,ng)*(tau(2,na)-tau(2,nb))+ &
|
||||
g(3,ng)*(tau(3,na)-tau(3,nb)) )
|
||||
facg(nb) = fac*zv(nta)*zv(ntb)*cos(arg)
|
||||
fnat = fnat + facg(nb)
|
||||
end do
|
||||
facg(na) = facg(na) - fnat
|
||||
mu_i = 3*(na-1)
|
||||
do nu_i = 1,nmodes
|
||||
if (has_equivalent( (nu_i-1)/3+1 ).eq.1 ) go to 15
|
||||
arg = g(1,ng)*u(mu_i+1,nu_i) + &
|
||||
g(2,ng)*u(mu_i+2,nu_i) + &
|
||||
g(3,ng)*u(mu_i+3,nu_i)
|
||||
if (arg.eq.0.0) go to 15
|
||||
do nu_j = 1,nmodes
|
||||
do nb= 1,nat
|
||||
mu_j = 3*(nb-1)
|
||||
dyn(nu_i,nu_j) = dyn(nu_i,nu_j) + facg(nb) * arg * &
|
||||
( g(1,ng)*u(mu_j+1,nu_j) + &
|
||||
g(2,ng)*u(mu_j+2,nu_j) + &
|
||||
g(3,ng)*u(mu_j+3,nu_j) )
|
||||
end do
|
||||
end do
|
||||
15 continue
|
||||
end do
|
||||
end do
|
||||
10 continue
|
||||
end do
|
||||
print '('' WARNING: G-sum not converged in d2ion '')'
|
||||
print '('' d2ion : alpha = '',f6.2)', alpha
|
||||
!
|
||||
20 continue
|
||||
!
|
||||
#define GAMMA
|
||||
#ifdef GAMMA
|
||||
call DSCAL(3*nat*nmodes,2.d0,dyn,1)
|
||||
#endif
|
||||
!
|
||||
! for parallel execution: only node with G=0 calculates R-space term
|
||||
!
|
||||
if(gg(1).gt.1.e-6) go to 30
|
||||
!
|
||||
! R-space sum here
|
||||
!
|
||||
rmax=5.0/sqrt(alpha)/alat
|
||||
!
|
||||
! with this choice terms up to ZiZj*erfc(5) are counted (erfc(5)=2x10^-12)
|
||||
!
|
||||
do na=1, nat
|
||||
nta= ityp(na)
|
||||
mu_i = 3*(na-1)
|
||||
do nb=1, nat
|
||||
if(nb.ne.na) then
|
||||
ntb= ityp(nb)
|
||||
mu_j = 3*(nb-1)
|
||||
do i=1,3
|
||||
dtau(i)=tau(i,na)-tau(i,nb)
|
||||
end do
|
||||
!
|
||||
! generates nearest-neighbors shells r(i)=R(i)-dtau(i)
|
||||
!
|
||||
call rgen(dtau,rmax,mxr,at,bg,r,r2,nrm)
|
||||
do nr=1, nrm
|
||||
rr=sqrt(r2(nr))*alat
|
||||
ar = sqrt(alpha)*rr
|
||||
d2f = ( 3.0*erfc(ar) + sqrt(8.0/tpi)*ar* &
|
||||
(3.0+2.0*ar**2)*exp(-ar**2) ) / rr**5
|
||||
df = ( -erfc(ar) - sqrt(8.0/tpi)*ar*exp(-ar**2) ) / rr**3
|
||||
do nu_i = 1,nmodes
|
||||
if (has_equivalent( (nu_i-1)/3+1 ).eq.1 ) go to 25
|
||||
arg = r(1,nr)*u(mu_i+1,nu_i) + &
|
||||
r(2,nr)*u(mu_i+2,nu_i) + &
|
||||
r(3,nr)*u(mu_i+3,nu_i)
|
||||
do nu_j = 1,nmodes
|
||||
dyn(nu_i,nu_j) = dyn(nu_i,nu_j) + &
|
||||
e2*zv(nta)*zv(ntb) * (d2f*alat * arg * &
|
||||
alat*( r(1,nr)*u(mu_j+1,nu_j) + &
|
||||
r(2,nr)*u(mu_j+2,nu_j) + &
|
||||
r(3,nr)*u(mu_j+3,nu_j) ) + &
|
||||
df * ( u(mu_i+1,nu_i)*u(mu_j+1,nu_j) + &
|
||||
u(mu_i+2,nu_i)*u(mu_j+2,nu_j) + &
|
||||
u(mu_i+3,nu_i)*u(mu_j+3,nu_j) ) -&
|
||||
d2f*alat * arg * &
|
||||
alat*( r(1,nr)*u(mu_i+1,nu_j) + &
|
||||
r(2,nr)*u(mu_i+2,nu_j) + &
|
||||
r(3,nr)*u(mu_i+3,nu_j) ) - &
|
||||
df * ( u(mu_i+1,nu_i)*u(mu_i+1,nu_j) + &
|
||||
u(mu_i+2,nu_i)*u(mu_i+2,nu_j) + &
|
||||
u(mu_i+3,nu_i)*u(mu_i+3,nu_j) ) )
|
||||
end do
|
||||
25 continue
|
||||
end do
|
||||
end do
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
!
|
||||
30 continue
|
||||
#ifdef PARA
|
||||
call reduce(3*nat*nmodes,dyn)
|
||||
#endif
|
||||
return
|
||||
end subroutine d2ion
|
||||
|
|
@ -0,0 +1,477 @@
|
|||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine data_structure_para
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! distribute columns to processes for parallel fft
|
||||
! columns are sets of g-vectors along z: g(k) = i1*b1+i2*b2+i3*b3 ,
|
||||
! with g^2<gcut and (i1,i2) running over the (xy) plane.
|
||||
! Columns are "active" for a given (i1,i2) if they contain a nonzero
|
||||
! number of wavevectors
|
||||
!
|
||||
#ifdef PARA
|
||||
use para
|
||||
use pwcom
|
||||
use allocate
|
||||
use mp, only: mp_sum
|
||||
use mp_global, only: intra_pool_comm
|
||||
!
|
||||
implicit none
|
||||
!
|
||||
integer, pointer :: &
|
||||
ngc(:), &! number of g-vectors per column (dense grid)
|
||||
ngcs(:), &! number of g-vectors per column (smooth grid
|
||||
ngcw(:), &! number of wavefct plane waves per colum
|
||||
in1(:), &! index i for column (i1,i2)
|
||||
in2(:), &! index j for column (i1,i2)
|
||||
index(:) ! used to order column
|
||||
integer ic, &! fft index for this column (dense grid)
|
||||
ics, &! as above for the smooth grid
|
||||
icm, &! fft index for column (-i1,-i2) (dense grid)
|
||||
icms, &! as above for the smooth grid
|
||||
ncp_(maxproc), &! number of column per processor (work space)
|
||||
ngp(maxproc), &! number of g-vectors per proc (dense grid)
|
||||
ngps(maxproc), &! number of g-vectors per proc (smooth grid)
|
||||
ngpw(maxproc) ! number of wavefct plane waves per proc
|
||||
!
|
||||
integer np, nps1, &! counters on planes
|
||||
nq, nqs, &! counters on planes
|
||||
max1,min1,max2,min2, &! aux. variables
|
||||
m1, m2, n1, n2, i, mc, &! generic counter
|
||||
idum, nct_, &! check variables
|
||||
j,jj, &! counters on processors
|
||||
n1m1,n2m1,n3m1, &! nr1-1 and so on
|
||||
i1, i2, i3, &! counters on G space
|
||||
good_fft_dimension ! a function with obvious meaning
|
||||
logical has_gzero
|
||||
real(kind=8), pointer :: aux(:) ! used to order columns
|
||||
real(kind=8) amod, gkcut ! square modulus of G vectors
|
||||
!
|
||||
! set the dimensions of fft arrays
|
||||
!
|
||||
nrx1 =good_fft_dimension(nr1 )
|
||||
nrx2 = nr2
|
||||
nrx3 =good_fft_dimension(nr3 )
|
||||
!
|
||||
nrx1s=good_fft_dimension(nr1s)
|
||||
nrx2s=nr2s
|
||||
nrx3s=good_fft_dimension(nr3s)
|
||||
!
|
||||
! compute number of columns for each processor
|
||||
!
|
||||
ncplane = nrx1*nrx2
|
||||
ncplanes= nrx1s*nrx2s
|
||||
!
|
||||
! global variables allocated here
|
||||
!
|
||||
call mallocate (ipc , ncplane)
|
||||
call mallocate (ipcs, ncplanes)
|
||||
!
|
||||
! local variables to be deallocated at the end
|
||||
!
|
||||
call mallocate (ngc , ncplane)
|
||||
call mallocate (ngcs, ncplane)
|
||||
call mallocate (ngcw, ncplane)
|
||||
call mallocate (in1 , ncplane)
|
||||
call mallocate (in2 , ncplane)
|
||||
call mallocate (index,ncplane)
|
||||
call mallocate (aux, ncplane)
|
||||
!
|
||||
! set the number of plane per process
|
||||
!
|
||||
if (nr3.lt.nproc) call error('set_fft_para', &
|
||||
& 'some processors have no planes ',-1)
|
||||
if (nr3s.lt.nproc) call error('set_fft_para', &
|
||||
& 'some processors have no smooth planes ',-1)
|
||||
!
|
||||
if (nproc.eq.1) then
|
||||
npp(1) = nr3
|
||||
npps(1)= nr3s
|
||||
else
|
||||
np = nr3/nproc
|
||||
nq = nr3 - np*nproc
|
||||
nps1 = nr3s/nproc
|
||||
nqs = nr3s - nps1*nproc
|
||||
do i = 1, nproc
|
||||
npp(i) = np
|
||||
if (i.le.nq) npp(i) = np + 1
|
||||
npps(i) = nps1
|
||||
if (i.le.nqs) npps(i) = nps1 + 1
|
||||
end do
|
||||
end if
|
||||
!
|
||||
! Now compute for each point of the big plane how many column have
|
||||
! non zero vectors on the smooth and dense grid
|
||||
!
|
||||
do mc = 1,ncplane
|
||||
ipc(mc) = 0
|
||||
end do
|
||||
do mc = 1,ncplanes
|
||||
ipcs(mc)= 0
|
||||
end do
|
||||
!
|
||||
nct = 0
|
||||
ncts= 0
|
||||
!
|
||||
! NOTA BENE: the exact limits for a correctly sized FFT grid are:
|
||||
! -nr/2,..,+nr/2 for nr even; -(nr-1)/2,..,+(nr-1)/2 for nr odd.
|
||||
! If the following limits are increased, a slightly undersized fft
|
||||
! grid, with some degree of G-vector refolding, can be used
|
||||
! (at your own risk - a check is done in ggen).
|
||||
!
|
||||
n1m1=nr1/2
|
||||
n2m1=nr2/2
|
||||
n3m1=nr3/2
|
||||
!
|
||||
gkcut = ecutwfc / tpiba2
|
||||
do i1=-n1m1,n1m1
|
||||
do i2=-n2m1,n2m1
|
||||
!
|
||||
! nct counts columns containing G-vectors for the dense grid
|
||||
!
|
||||
nct=nct+1
|
||||
if (nct.gt.ncplane) call error('set_fft_para','too many columns',1)
|
||||
ngc (nct) = 0
|
||||
ngcs(nct) = 0
|
||||
ngcw(nct) = 0
|
||||
!
|
||||
do i3 = -n3m1,n3m1
|
||||
amod = (bg(1,1)*i1 + bg(1,2)*i2 + bg(1,3)*i3)**2 + &
|
||||
(bg(2,1)*i1 + bg(2,2)*i2 + bg(2,3)*i3)**2 + &
|
||||
(bg(3,1)*i1 + bg(3,2)*i2 + bg(3,3)*i3)**2
|
||||
if (amod.le.gcutm) ngc (nct)= ngc (nct)+ 1
|
||||
if (amod.le.gcutms) ngcs(nct)= ngcs(nct)+ 1
|
||||
if (amod.le.gkcut) ngcw(nct)= ngcw(nct)+ 1
|
||||
enddo
|
||||
if (ngc(nct).gt.0) then
|
||||
!
|
||||
! this column contains G-vectors
|
||||
!
|
||||
in1(nct) = i1
|
||||
in2(nct) = i2
|
||||
if (ngcs(nct).gt.0) then
|
||||
!
|
||||
! ncts counts columns contaning G-vectors for the smooth grid
|
||||
!
|
||||
ncts=ncts+1
|
||||
if (ncts.gt.ncplanes) &
|
||||
call error('set_fft_para','too many columns',2)
|
||||
end if
|
||||
else
|
||||
!
|
||||
! this column has no G-vectors: reset the counter
|
||||
!
|
||||
nct=nct-1
|
||||
end if
|
||||
enddo
|
||||
end do
|
||||
!
|
||||
if(nct .eq.0) call error('set_fft_para','number of column 0', 1)
|
||||
if(ncts.eq.0) call error('set_fft_para','number smooth column 0', 1)
|
||||
!
|
||||
! Sort the columns. First the column with the largest number of G
|
||||
! vectors on the wavefunction sphere (active columns),
|
||||
! then on the smooth sphere, then on the big sphere. Dirty trick:
|
||||
!
|
||||
do mc = 1,nct
|
||||
aux(mc)=-(ngcw(mc)*nrx3**2 + ngcs(mc)*nrx3 + ngc(mc))
|
||||
end do
|
||||
call hpsort(nct,aux,index)
|
||||
!
|
||||
! assign columns to processes
|
||||
!
|
||||
has_gzero=.false.
|
||||
do j=1,nproc
|
||||
ncp (j) = 0
|
||||
ncps(j) = 0
|
||||
nkcp(j) = 0
|
||||
ngp (j) = 0
|
||||
ngps(j) = 0
|
||||
ngpw(j) = 0
|
||||
end do
|
||||
!
|
||||
do mc=1, nct
|
||||
i = index(mc)
|
||||
!
|
||||
! index contains the desired ordering of columns (see above)
|
||||
!
|
||||
i1=in1(i)
|
||||
i2=in2(i)
|
||||
!
|
||||
if ( i1.lt.0.or.(i1.eq.0.and.i2.lt.0) ) go to 30
|
||||
!
|
||||
! only half of the columns, plus column (0,0), are scanned:
|
||||
! column (-i1,-i2) must be assigned to the same proc as column (i1,i2)
|
||||
!
|
||||
! ic : position, in fft notation, in dense grid, of column ( i1, i2)
|
||||
! icm : " " " " " " (-i1,-i2)
|
||||
! ics : " " " smooth " " ( i1, i2)
|
||||
! icms: " " " smooth " " (-i1,-i2)
|
||||
!
|
||||
m1 = i1 + 1
|
||||
if (m1.lt.1) m1 = m1 + nr1
|
||||
m2 = i2 + 1
|
||||
if (m2.lt.1) m2 = m2 + nr2
|
||||
ic = m1 + (m2-1)*nrx1
|
||||
!
|
||||
n1 = -i1 + 1
|
||||
if (n1.lt.1) n1 = n1 + nr1
|
||||
n2 = -i2 + 1
|
||||
if (n2.lt.1) n2 = n2 + nr2
|
||||
icm = n1 + (n2-1)*nrx1
|
||||
!
|
||||
m1 = i1 + 1
|
||||
if (m1.lt.1) m1 = m1 + nr1s
|
||||
m2 = i2 + 1
|
||||
if (m2.lt.1) m2 = m2 + nr2s
|
||||
ics = m1 + (m2-1)*nrx1s
|
||||
!
|
||||
n1 =-i1 + 1
|
||||
if (n1.lt.1) n1 = n1 + nr1s
|
||||
n2 =-i2 + 1
|
||||
if (n2.lt.1) n2 = n2 + nr2s
|
||||
icms = n1 + (n2-1)*nrx1s
|
||||
!
|
||||
jj=1
|
||||
if (ngcw(i).gt.0) then
|
||||
!
|
||||
! this is an active column: find which processor has currently
|
||||
! the smallest number of plane waves
|
||||
!
|
||||
do j=1,nproc
|
||||
if (ngpw(j).lt.ngpw(jj)) jj = j
|
||||
end do
|
||||
else
|
||||
!
|
||||
! this is an inactive column: find which processor has currently
|
||||
! the smallest number of G-vectors
|
||||
!
|
||||
do j=1,nproc
|
||||
if (ngp(j).lt.ngp(jj)) jj = j
|
||||
end do
|
||||
end if
|
||||
!
|
||||
! jj is the processor to which this column is assigned
|
||||
! use -jj for inactive columns, jj for active columns
|
||||
!
|
||||
ipc(ic) = -jj
|
||||
ncp(jj) = ncp(jj) + 1
|
||||
ngp(jj) = ngp(jj) + ngc(i)
|
||||
if (ngcs(i).gt.0) then
|
||||
ncps(jj)=ncps(jj)+1
|
||||
ngps(jj)=ngps(jj)+ngcs(i)
|
||||
ipcs(ics)=-jj
|
||||
endif
|
||||
if (ngcw(i).gt.0) then
|
||||
ipcs(ics)=jj
|
||||
ipc(ic) = jj
|
||||
ngpw(jj)= ngpw(jj) + ngcw(i)
|
||||
nkcp(jj)= nkcp(jj) + 1
|
||||
endif
|
||||
!
|
||||
if (i1.eq.0.and.i2.eq.0.and.jj.eq.me) has_gzero = .true.
|
||||
!
|
||||
! now assign the (-i1,-i2) column to the same processor
|
||||
!
|
||||
if (i1.eq.0.and.i2.eq.0) go to 30
|
||||
!
|
||||
! do not count twice column (0,0) !
|
||||
!
|
||||
ipc(icm) = -jj
|
||||
ncp(jj) = ncp(jj) + 1
|
||||
ngp(jj) = ngp(jj) + ngc(i)
|
||||
if (ngcs(i).gt.0) then
|
||||
ncps(jj)=ncps(jj)+1
|
||||
ngps(jj)=ngps(jj)+ngcs(i)
|
||||
ipcs(icms)=-jj
|
||||
endif
|
||||
if (ngcw(i).gt.0) then
|
||||
ipcs(icms)=jj
|
||||
ipc(icm) = jj
|
||||
ngpw(jj)= ngpw(jj) + ngcw(i)
|
||||
nkcp(jj)= nkcp(jj) + 1
|
||||
endif
|
||||
30 continue
|
||||
enddo
|
||||
!
|
||||
! ipc is the processor for this column in the dense grid
|
||||
! ipcs is the same, for the smooth grid
|
||||
!
|
||||
! write(6,'(" Proc planes cols G planes cols G columns G"/ &
|
||||
! & " (dense grid) (smooth grid) (wavefct grid)'")')
|
||||
!do i=1,nproc
|
||||
! write(6,'(i3,2x,3(i5,2i7))') i, npp(i),ncp(i),ngp(i), &
|
||||
! npps(i),ncps(i),ngps(i), nkcp(i), ngpw(i)
|
||||
!end do
|
||||
!
|
||||
! ngm contains the number of G vectors on this processor (me)
|
||||
! remember that ngp counts all G-vectors, while we want only half
|
||||
! same for ngms (smooth grid)
|
||||
!
|
||||
if (has_gzero) then
|
||||
ngm = (ngp (me)-1)/2 + 1
|
||||
ngms= (ngps(me)-1)/2 + 1
|
||||
else
|
||||
ngm = ngp (me)/2
|
||||
ngms= ngps(me)/2
|
||||
end if
|
||||
!
|
||||
! nxx and nxxs are copies of nrxx and nrxxs, the local fft data size,
|
||||
! to be stored in "parallel" commons. Not a very elegant solution.
|
||||
!
|
||||
if (nproc.eq.1) then
|
||||
nrxx =nrx1*nrx2*nrx3
|
||||
nrxxs=nrx1s*nrx2s*nrx3s
|
||||
else
|
||||
nrxx = max(nrx3*ncp(me), nrx1*nrx2*npp(me))
|
||||
nrxxs= max(nrx3s*ncps(me), nrx1s*nrx2s*npps(me))
|
||||
end if
|
||||
nxx = nrxx
|
||||
nxxs= nrxxs
|
||||
!
|
||||
! computing the starting column for each processor
|
||||
!
|
||||
do i=1,nproc
|
||||
if(ngpw(i).eq.0) call error('set_fft_para', &
|
||||
& 'some processors have no pencils, not yet implemented',1)
|
||||
if (i.eq.1) then
|
||||
ncp0(i) = 0
|
||||
ncp0s(i)= 0
|
||||
else
|
||||
ncp0(i) = ncp0 (i-1) + ncp (i-1)
|
||||
ncp0s(i)= ncp0s(i-1) + ncps(i-1)
|
||||
endif
|
||||
enddo
|
||||
!
|
||||
! Now compute the arrays ipc and icpl (dense grid):
|
||||
! ipc contain the number of the column for that processor.
|
||||
! zero if the column do not belong to the processor.
|
||||
! Note that input ipc is used and overwritten.
|
||||
! icpl contains the point in the plane for each column
|
||||
!
|
||||
!- active columns first........
|
||||
!
|
||||
call mallocate(icpl, nct)
|
||||
call mallocate(icpls, ncts)
|
||||
!
|
||||
do j=1,nproc
|
||||
ncp_(j) = 0
|
||||
end do
|
||||
do mc =1,ncplane
|
||||
if (ipc(mc).gt.0) then
|
||||
j = ipc(mc)
|
||||
ncp_(j) = ncp_(j) + 1
|
||||
icpl(ncp_(j) + ncp0(j)) = mc
|
||||
if (j.eq.me) then
|
||||
ipc(mc) = ncp_(j)
|
||||
else
|
||||
ipc(mc) = 0
|
||||
end if
|
||||
end if
|
||||
end do
|
||||
!
|
||||
!-..... ( intermediate check ) ....
|
||||
!
|
||||
do j=1,nproc
|
||||
if (ncp_(j).ne.nkcp(j)) &
|
||||
& call error('set_fft_para','ncp_(j).ne.nkcp(j)',j)
|
||||
end do
|
||||
!
|
||||
!- ........then the remaining columns
|
||||
!
|
||||
do mc =1,ncplane
|
||||
if (ipc(mc).lt.0) then
|
||||
j = -ipc(mc)
|
||||
ncp_(j) = ncp_(j) + 1
|
||||
icpl(ncp_(j) + ncp0(j)) = mc
|
||||
if (j.eq.me) then
|
||||
ipc(mc) = ncp_(j)
|
||||
else
|
||||
ipc(mc) = 0
|
||||
end if
|
||||
end if
|
||||
end do
|
||||
!
|
||||
!-... ( final check )
|
||||
!
|
||||
nct_ = 0
|
||||
do j=1,nproc
|
||||
if (ncp_(j).ne.ncp(j)) &
|
||||
& call error('set_fft_para','ncp_(j).ne.ncp(j)',j)
|
||||
nct_ = nct_ + ncp_(j)
|
||||
end do
|
||||
if (nct_.ne.nct) &
|
||||
& call error('set_fft_para','nct_.ne.nct',1)
|
||||
!
|
||||
! now compute the arrays ipcs and icpls
|
||||
! (as ipc and icpls, for the smooth grid)
|
||||
!
|
||||
! active columns first...
|
||||
!
|
||||
do j=1,nproc
|
||||
ncp_(j) = 0
|
||||
end do
|
||||
do mc =1,ncplanes
|
||||
if (ipcs(mc).gt.0) then
|
||||
j = ipcs(mc)
|
||||
ncp_(j)=ncp_(j) + 1
|
||||
icpls(ncp_(j) + ncp0s(j)) = mc
|
||||
if (j.eq.me) then
|
||||
ipcs(mc) = ncp_(j)
|
||||
else
|
||||
ipcs(mc) = 0
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
!
|
||||
!-..... ( intermediate check ) ....
|
||||
!
|
||||
do j=1,nproc
|
||||
if (ncp_(j).ne.nkcp(j)) &
|
||||
& call error('set_fft_para','ncp_(j).ne.nkcp(j)',j)
|
||||
end do
|
||||
!
|
||||
! and then all the others
|
||||
!
|
||||
do mc =1,ncplanes
|
||||
if (ipcs(mc).lt.0) then
|
||||
j = -ipcs(mc)
|
||||
ncp_(j) = ncp_(j) + 1
|
||||
icpls(ncp_(j) + ncp0s(j)) = mc
|
||||
if (j.eq.me) then
|
||||
ipcs(mc) = ncp_(j)
|
||||
else
|
||||
ipcs(mc) = 0
|
||||
end if
|
||||
end if
|
||||
end do
|
||||
!
|
||||
!-... ( final check )
|
||||
!
|
||||
nct_ = 0
|
||||
do j=1,nproc
|
||||
if (ncp_(j).ne.ncps(j)) &
|
||||
& call error('set_fft_para','ncp_(j).ne.ncps(j)',j)
|
||||
nct_ = nct_ + ncp_(j)
|
||||
end do
|
||||
if (nct_.ne.ncts) &
|
||||
& call error('set_fft_para','nct_.ne.ncts',1)
|
||||
!
|
||||
call mfree (aux)
|
||||
call mfree (index)
|
||||
call mfree (in2)
|
||||
call mfree (in1)
|
||||
call mfree (ngcw)
|
||||
call mfree (ngcs)
|
||||
call mfree (ngc )
|
||||
!
|
||||
ngm_l = ngm
|
||||
ngms_l = ngms
|
||||
ngm_g = ngm
|
||||
ngms_g = ngms
|
||||
call mp_sum( ngm_g , intra_pool_comm )
|
||||
call mp_sum( ngms_g, intra_pool_comm )
|
||||
!
|
||||
#endif
|
||||
return
|
||||
end subroutine data_structure_para
|
||||
|
|
@ -0,0 +1,86 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine data_structure_scal
|
||||
!-----------------------------------------------------------------------
|
||||
! this routine sets the data structure for the fft arrays.
|
||||
! This version computes also the smooth and hard mesh
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use mp, only: mp_sum
|
||||
use mp_global, only: intra_pool_comm
|
||||
implicit none
|
||||
integer :: n1, n2, n3, i1, i2, i3
|
||||
! counters on G space
|
||||
!
|
||||
integer :: good_fft_dimension
|
||||
! a function with obvious meaning
|
||||
|
||||
real(kind=DP) :: amod
|
||||
! modulus of G vectors
|
||||
!
|
||||
nrx1 = good_fft_dimension (nr1)
|
||||
nrx1s = good_fft_dimension (nr1s)
|
||||
!
|
||||
! nrx2 and nrx3 are there just for compatibility
|
||||
!
|
||||
nrx2 = nr2
|
||||
nrx3 = nr3
|
||||
|
||||
nrxx = nrx1 * nrx2 * nrx3
|
||||
nrx2s = nr2s
|
||||
nrx3s = nr3s
|
||||
nrxxs = nrx1s * nrx2s * nrx3s
|
||||
!
|
||||
! compute the number of g necessary to the calculation
|
||||
!
|
||||
n1 = nr1 + 1
|
||||
n2 = nr2 + 1
|
||||
n3 = nr3 + 1
|
||||
|
||||
ngm = 0
|
||||
ngms = 0
|
||||
!
|
||||
! exclude space with x<0
|
||||
!
|
||||
do i1 = 0, n1
|
||||
do i2 = - n2, n2
|
||||
!
|
||||
! exclude plane with x=0, y<0
|
||||
!
|
||||
if(i1.eq.0.and.i2.lt.0) go to 10
|
||||
do i3 = - n3, n3
|
||||
!
|
||||
! exclude line with x=0, y=0, z<0
|
||||
!
|
||||
if(i1.eq.0.and.i2.eq.0.and.i3.lt.0) go to 20
|
||||
amod = (i1 * bg (1, 1) + i2 * bg (1, 2) + i3 * bg (1, 3) ) **2 + &
|
||||
(i1 * bg (2, 1) + i2 * bg (2, 2) + i3 * bg (2, 3) ) **2 + &
|
||||
(i1 * bg (3, 1) + i2 * bg (3, 2) + i3 * bg (3, 3) ) **2
|
||||
if (amod.le.gcutm) ngm = ngm + 1
|
||||
if (amod.le.gcutms) ngms = ngms + 1
|
||||
20 continue
|
||||
enddo
|
||||
10 continue
|
||||
enddo
|
||||
enddo
|
||||
!
|
||||
! compute the global number of g, i.e. the sum over all processors
|
||||
! whithin a pool
|
||||
!
|
||||
ngm_l = ngm
|
||||
ngms_l = ngms
|
||||
ngm_g = ngm
|
||||
ngms_g = ngms
|
||||
call mp_sum( ngm_g , intra_pool_comm )
|
||||
call mp_sum( ngms_g, intra_pool_comm )
|
||||
!
|
||||
return
|
||||
end subroutine data_structure_scal
|
||||
|
||||
|
|
@ -0,0 +1,41 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine dgcxc (r, s2, vrrx, vsrx, vssx, vrrc, vsrc, vssc)
|
||||
!-----------------------------------------------------------------------
|
||||
use parameters, only : DP
|
||||
implicit none
|
||||
real(kind=DP) :: r, s2, vrrx, vsrx, vssx, vrrc, vsrc, vssc
|
||||
real(kind=DP) :: dr, s, ds
|
||||
|
||||
real(kind=DP) :: sx, sc, v1xp, v2xp, v1cp, v2cp, v1xm, v2xm, v1cm, &
|
||||
v2cm
|
||||
s = sqrt (s2)
|
||||
dr = min (1.d-4, 1.d-2 * r)
|
||||
|
||||
ds = min (1.d-4, 1.d-2 * s)
|
||||
call gcxc (r + dr, s2, sx, sc, v1xp, v2xp, v1cp, v2cp)
|
||||
|
||||
call gcxc (r - dr, s2, sx, sc, v1xm, v2xm, v1cm, v2cm)
|
||||
vrrx = 0.5d0 * (v1xp - v1xm) / dr
|
||||
|
||||
vrrc = 0.5d0 * (v1cp - v1cm) / dr
|
||||
vsrx = 0.25d0 * (v2xp - v2xm) / dr
|
||||
|
||||
vsrc = 0.25d0 * (v2cp - v2cm) / dr
|
||||
call gcxc (r, (s + ds) **2, sx, sc, v1xp, v2xp, v1cp, v2cp)
|
||||
|
||||
call gcxc (r, (s - ds) **2, sx, sc, v1xm, v2xm, v1cm, v2cm)
|
||||
vsrx = vsrx + 0.25d0 * (v1xp - v1xm) / ds / s
|
||||
|
||||
vsrc = vsrc + 0.25d0 * (v1cp - v1cm) / ds / s
|
||||
vssx = 0.5d0 * (v2xp - v2xm) / ds / s
|
||||
|
||||
vssc = 0.5d0 * (v2cp - v2cm) / ds / s
|
||||
return
|
||||
end subroutine dgcxc
|
||||
|
|
@ -0,0 +1,163 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine dgcxc_spin (rup, rdw, gup, gdw, vrrxup, vrrxdw, vrsxup, &
|
||||
vrsxdw, vssxup, vssxdw, vrrcup, vrrcdw, vrscup, vrscdw, vssc, &
|
||||
vrzcup, vrzcdw)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! This routine computes the derivative of the exchange and correlatio
|
||||
! potentials with respect to the density, the gradient and zeta
|
||||
!
|
||||
use parameters, only : DP
|
||||
implicit none
|
||||
real(kind=DP) :: rup, rdw, gup (3), gdw (3), vrrxup, vrrxdw, vrsxup, &
|
||||
vrsxdw, vssxup, vssxdw, vrrcup, vrrcdw, vrscup, vrscdw, vssc, &
|
||||
vrzcup, vrzcdw
|
||||
! input: the charges and the gradient
|
||||
! output: derivatives of the exchange
|
||||
! output: derivatives of the exchange
|
||||
! output: derivatives of the correlat
|
||||
! output: derivatives of the correlat
|
||||
! output: derivatives of the correlat
|
||||
!
|
||||
! local variables
|
||||
!
|
||||
real(kind=DP) :: r, zeta, sup2, sdw2, s2, s, sup, sdw, dr, dzeta, ds, &
|
||||
drup, drdw, dsup, dsdw, sx, sc, v1xupp, v1xdwp, v2xupp, v2xdwp, &
|
||||
v1xupm, v1xdwm, v2xupm, v2xdwm, v1cupp, v1cdwp, v2cp, v1cupm, &
|
||||
v1cdwm, v2cm
|
||||
! charge densities and square gr
|
||||
! gradients
|
||||
! delta charge densities and gra
|
||||
! delta gradients
|
||||
! energies
|
||||
! exchange potentials
|
||||
! exchange potentials
|
||||
! coorelation potentials
|
||||
! coorelation potentials
|
||||
real(kind=DP) :: eps
|
||||
|
||||
parameter (eps = 1.d-6)
|
||||
r = rup + rdw
|
||||
if (r.gt.eps) then
|
||||
zeta = (rup - rdw) / r
|
||||
else
|
||||
zeta = 2.d0
|
||||
|
||||
endif
|
||||
sup2 = gup (1) **2 + gup (2) **2 + gup (3) **2
|
||||
sdw2 = gdw (1) **2 + gdw (2) **2 + gdw (3) **2
|
||||
|
||||
s2 = (gup (1) + gdw (1) ) **2 + (gup (2) + gdw (2) ) **2 + &
|
||||
(gup (3) + gdw (3) ) **2
|
||||
sup = sqrt (sup2)
|
||||
sdw = sqrt (sdw2)
|
||||
s = sqrt (s2)
|
||||
!
|
||||
! up part of exchange
|
||||
!
|
||||
|
||||
if (rup.gt.eps.and.sup.gt.eps) then
|
||||
drup = min (1.d-4, 1.d-2 * rup)
|
||||
dsup = min (1.d-4, 1.d-2 * sdw)
|
||||
!
|
||||
! derivatives of exchange: up part
|
||||
!
|
||||
call gcx_spin (rup + drup, rdw, sup2, sdw2, sx, v1xupp, v1xdwp, &
|
||||
v2xupp, v2xdwp)
|
||||
|
||||
call gcx_spin (rup - drup, rdw, sup2, sdw2, sx, v1xupm, v1xdwm, &
|
||||
v2xupm, v2xdwm)
|
||||
vrrxup = 0.5d0 * (v1xupp - v1xupm) / drup
|
||||
|
||||
|
||||
vrsxup = 0.25d0 * (v2xupp - v2xupm) / drup
|
||||
call gcx_spin (rup, rdw, (sup + dsup) **2, sdw2, sx, v1xupp, &
|
||||
v1xdwp, v2xupp, v2xdwp)
|
||||
|
||||
call gcx_spin (rup, rdw, (sup - dsup) **2, sdw2, sx, v1xupm, &
|
||||
v1xdwm, v2xupm, v2xdwm)
|
||||
vrsxup = vrsxup + 0.25d0 * (v1xupp - v1xupm) / dsup / sup
|
||||
vssxup = 0.5d0 * (v2xupp - v2xupm) / dsup / sup
|
||||
else
|
||||
vrrxup = 0.d0
|
||||
vrsxup = 0.d0
|
||||
vssxup = 0.d0
|
||||
|
||||
endif
|
||||
|
||||
if (rdw.gt.eps.and.sdw.gt.eps) then
|
||||
drdw = min (1.d-4, 1.d-2 * rdw)
|
||||
dsdw = min (1.d-4, 1.d-2 * sdw)
|
||||
!
|
||||
! derivatives of exchange: down part
|
||||
!
|
||||
call gcx_spin (rup, rdw + drdw, sup2, sdw2, sx, v1xupp, v1xdwp, &
|
||||
v2xupp, v2xdwp)
|
||||
|
||||
call gcx_spin (rup, rdw - drdw, sup2, sdw2, sx, v1xupm, v1xdwm, &
|
||||
v2xupm, v2xdwm)
|
||||
vrrxdw = 0.5d0 * (v1xdwp - v1xdwm) / drdw
|
||||
|
||||
vrsxdw = 0.25d0 * (v2xdwp - v2xdwm) / drdw
|
||||
call gcx_spin (rup, rdw, sup2, (sdw + dsdw) **2, sx, v1xupp, &
|
||||
v1xdwp, v2xupp, v2xdwp)
|
||||
|
||||
call gcx_spin (rup, rdw, sup2, (sdw - dsdw) **2, sx, v1xupm, &
|
||||
v1xdwm, v2xupm, v2xdwm)
|
||||
vrsxdw = vrsxdw + 0.25d0 * (v1xdwp - v1xdwm) / dsdw / sdw
|
||||
vssxdw = 0.5d0 * (v2xdwp - v2xdwm) / dsdw / sdw
|
||||
else
|
||||
vrrxdw = 0.d0
|
||||
vrsxdw = 0.d0
|
||||
vssxdw = 0.d0
|
||||
endif
|
||||
!
|
||||
! derivatives of correlation
|
||||
!
|
||||
|
||||
if (r.gt.eps.and.abs (zeta) .le.1.d0.and.s.gt.eps) then
|
||||
|
||||
dr = min (1.d-4, 1.d-2 * r)
|
||||
call gcc_spin (r + dr, zeta, s2, sc, v1cupp, v1cdwp, v2cp)
|
||||
|
||||
call gcc_spin (r - dr, zeta, s2, sc, v1cupm, v1cdwm, v2cm)
|
||||
vrrcup = 0.5d0 * (v1cupp - v1cupm) / dr
|
||||
|
||||
vrrcdw = 0.5d0 * (v1cdwp - v1cdwm) / dr
|
||||
|
||||
ds = min (1.d-4, 1.d-2 * s)
|
||||
call gcc_spin (r, zeta, (s + ds) **2, sc, v1cupp, v1cdwp, v2cp)
|
||||
|
||||
call gcc_spin (r, zeta, (s - ds) **2, sc, v1cupm, v1cdwm, v2cm)
|
||||
vrscup = 0.5d0 * (v1cupp - v1cupm) / ds / s
|
||||
vrscdw = 0.5d0 * (v1cdwp - v1cdwm) / ds / s
|
||||
|
||||
vssc = 0.5d0 * (v2cp - v2cm) / ds / s
|
||||
dzeta = min (1.d-4, 1.d-2 * abs (zeta) )
|
||||
|
||||
if (dzeta.lt.1.d-7) dzeta = 1.d-7
|
||||
call gcc_spin (r, zeta + dzeta, s2, sc, v1cupp, v1cdwp, v2cp)
|
||||
|
||||
call gcc_spin (r, zeta - dzeta, s2, sc, v1cupm, v1cdwm, v2cm)
|
||||
vrzcup = 0.5d0 * (v1cupp - v1cupm) / dzeta
|
||||
vrzcdw = 0.5d0 * (v1cdwp - v1cdwm) / dzeta
|
||||
else
|
||||
vrrcup = 0.d0
|
||||
vrrcdw = 0.d0
|
||||
vrscup = 0.d0
|
||||
vrscdw = 0.d0
|
||||
vssc = 0.d0
|
||||
vrzcup = 0.d0
|
||||
vrzcdw = 0.d0
|
||||
|
||||
endif
|
||||
return
|
||||
end subroutine dgcxc_spin
|
||||
|
|
@ -0,0 +1,287 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!--------------------------------------------------------------------
|
||||
subroutine dgradcor1 (rho, grho, dvxc_rr, dvxc_sr, dvxc_ss, dvxc_s, &
|
||||
drho, drhoc, nr1, nr2, nr3, nrx1, nrx2, nrx3, nrxx, nspin, &
|
||||
nl, nlm, ngm, g, alat, omega, dvxc)
|
||||
! ===================
|
||||
!--------------------------------------------------------------------
|
||||
! ADD Gradient Correction contibution to screening potential
|
||||
! phonon calculation, half G-vectors
|
||||
#include "machine.h"
|
||||
use parameters, only : DP
|
||||
use allocate
|
||||
implicit none
|
||||
|
||||
!
|
||||
integer :: nr1, nr2, nr3, nrx1, nrx2, nrx3, nrxx, ngm, nspin, &
|
||||
nl (ngm), nlm(ngm)
|
||||
|
||||
real(kind=DP) :: rho (nrxx, nspin), grho (3, nrxx, nspin), &
|
||||
dvxc_rr(nrxx, nspin, nspin), dvxc_sr (nrxx, nspin, nspin), &
|
||||
dvxc_ss (nrxx,nspin, nspin), dvxc_s (nrxx, nspin, nspin),&
|
||||
drho (nrxx,nspin), g (3, ngm), alat, omega
|
||||
|
||||
complex(kind=DP) :: drhoc(nrxx, nspin), dvxc (nrxx, nspin)
|
||||
integer :: k, ipol, is, js, ks, ls
|
||||
real(kind=DP) :: epsr, epsg, grho2
|
||||
complex(kind=DP) :: s1
|
||||
complex(kind=DP) :: a (2, 2, 2), b (2, 2, 2, 2), c (2, 2, 2), &
|
||||
ps (2, 2), ps1 (3, 2, 2), ps2 (3, 2, 2, 2)
|
||||
real(kind=DP), pointer :: gdrho (:,:,:)
|
||||
complex(kind=DP), pointer :: h (:,:,:), dh (:)
|
||||
parameter (epsr = 1.0d-6, epsg = 1.0d-10)
|
||||
|
||||
call mallocate(gdrho, 3, nrxx , nspin)
|
||||
call mallocate(h, 3, nrxx , nspin)
|
||||
call mallocate(dh, nrxx)
|
||||
|
||||
call setv (6 * nrxx * nspin, 0.d0, h, 1)
|
||||
do is = 1, nspin
|
||||
call gradient1 (nrx1, nrx2, nrx3, nr1, nr2, nr3, nrxx, &
|
||||
drhoc(1, is), ngm, g, nl, nlm, alat, gdrho (1, 1, is) )
|
||||
enddo
|
||||
do k = 1, nrxx
|
||||
grho2 = grho(1, k, 1)**2 + grho(2, k, 1)**2 + grho(3, k, 1)**2
|
||||
if (nspin.eq.1) then
|
||||
!
|
||||
! LDA case
|
||||
!
|
||||
if (abs (rho (k, 1) ) .gt.epsr.and.grho2.gt.epsg) then
|
||||
s1 = grho (1, k, 1) * gdrho (1, k, 1) + &
|
||||
grho (2, k, 1) * gdrho (2, k, 1) + &
|
||||
grho (3, k, 1) * gdrho (3, k, 1)
|
||||
!
|
||||
! linear variation of the first term
|
||||
!
|
||||
dvxc (k, 1) = dvxc (k, 1) + dvxc_rr (k, 1, 1) * drho (k, 1) &
|
||||
+ dvxc_sr (k, 1, 1) * s1
|
||||
do ipol = 1, 3
|
||||
h (ipol, k, 1) = (dvxc_sr(k, 1, 1) * drho(k, 1) + &
|
||||
dvxc_ss(k, 1, 1) * s1 )*grho(ipol, k, 1) + &
|
||||
dvxc_s (k, 1, 1) * gdrho (ipol, k, 1)
|
||||
enddo
|
||||
else
|
||||
do ipol = 1, 3
|
||||
h (ipol, k, 1) = (0.d0, 0.d0)
|
||||
enddo
|
||||
endif
|
||||
else
|
||||
!
|
||||
! LSDA case
|
||||
!
|
||||
call setv (8, 0.d0, ps, 1)
|
||||
do is = 1, nspin
|
||||
do js = 1, nspin
|
||||
do ipol = 1, 3
|
||||
ps1(ipol, is, js) = drho (k, is) * grho (ipol, k, js)
|
||||
ps(is, js) = ps(is, js) + grho(ipol,k,is)*gdrho(ipol,k,js)
|
||||
enddo
|
||||
do ks = 1, nspin
|
||||
if (is.eq.js.and.js.eq.ks) then
|
||||
a (is, js, ks) = dvxc_sr (k, is, is)
|
||||
c (is, js, ks) = dvxc_sr (k, is, is)
|
||||
else
|
||||
if (is.eq.1) then
|
||||
a (is, js, ks) = dvxc_sr (k, 1, 2)
|
||||
else
|
||||
a (is, js, ks) = dvxc_sr (k, 2, 1)
|
||||
endif
|
||||
if (js.eq.1) then
|
||||
c (is, js, ks) = dvxc_sr (k, 1, 2)
|
||||
else
|
||||
c (is, js, ks) = dvxc_sr (k, 2, 1)
|
||||
endif
|
||||
endif
|
||||
do ipol = 1, 3
|
||||
ps2 (ipol, is, js, ks) = ps (is, js) * grho (ipol, k, ks)
|
||||
enddo
|
||||
do ls = 1, nspin
|
||||
if (is.eq.js.and.js.eq.ks.and.ks.eq.ls) then
|
||||
b (is, js, ks, ls) = dvxc_ss (k, is, is)
|
||||
else
|
||||
if (is.eq.1) then
|
||||
b (is, js, ks, ls) = dvxc_ss (k, 1, 2)
|
||||
else
|
||||
b (is, js, ks, ls) = dvxc_ss (k, 2, 1)
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
do is = 1, nspin
|
||||
do js = 1, nspin
|
||||
dvxc (k, is) = dvxc (k, is) + dvxc_rr (k, is, js) * drho (k, &
|
||||
js)
|
||||
do ipol = 1, 3
|
||||
h (ipol, k, is) = h (ipol, k, is) + &
|
||||
dvxc_s (k, is, js) * gdrho(ipol, k, js)
|
||||
enddo
|
||||
do ks = 1, nspin
|
||||
dvxc (k, is) = dvxc (k, is) + a (is, js, ks) * ps (js, ks)
|
||||
do ipol = 1, 3
|
||||
h (ipol, k, is) = h (ipol, k, is) + &
|
||||
c (is, js, ks) * ps1 (ipol, js, ks)
|
||||
enddo
|
||||
do ls = 1, nspin
|
||||
do ipol = 1, 3
|
||||
h (ipol, k, is) = h (ipol, k, is) + &
|
||||
b (is, js, ks, ls) * ps2 (ipol, js, ks, ls)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
! linear variation of the second term
|
||||
do is = 1, nspin
|
||||
call grad_dot1 (nrx1, nrx2, nrx3, nr1, nr2, nr3, nrxx, &
|
||||
h (1, 1, is), ngm, g, nl, nlm, alat, dh)
|
||||
do k = 1, nrxx
|
||||
dvxc (k, is) = dvxc (k, is) - dh (k)
|
||||
enddo
|
||||
enddo
|
||||
call mfree (dh)
|
||||
call mfree (h)
|
||||
call mfree (gdrho)
|
||||
return
|
||||
end subroutine dgradcor1
|
||||
!
|
||||
!--------------------------------------------------------------------
|
||||
subroutine gradient1(nrx1, nrx2, nrx3, nr1, nr2, nr3, nrxx, &
|
||||
a, ngm, g, nl, nlm, alat, ga)
|
||||
!--------------------------------------------------------------------
|
||||
! Calculates ga = \grad a in R-space (a is G-space)
|
||||
use parameters, only : DP
|
||||
use allocate
|
||||
implicit none
|
||||
integer :: nrx1, nrx2, nrx3, nr1, nr2, nr3, nrxx, ngm, nl (ngm), &
|
||||
nlm(ngm)
|
||||
complex(kind=DP) :: a (nrxx)
|
||||
real(kind=DP) :: ga (3, nrxx), g (3, ngm), alat
|
||||
integer :: n, ipol
|
||||
real(kind=DP) :: tpi, tpiba
|
||||
parameter (tpi = 2.d0 * 3.14159265358979d0)
|
||||
complex(kind=DP), pointer :: gaux (:)
|
||||
|
||||
call mallocate(gaux, nrxx)
|
||||
|
||||
tpiba = tpi / alat
|
||||
|
||||
! a(G) multiply by i(q+G) to get (\grad_ipol a)(q+G) ...
|
||||
! do ipol = 1, 3
|
||||
! x, y
|
||||
ipol=1
|
||||
do n = 1, nrxx
|
||||
gaux (n) = (0.d0, 0.d0)
|
||||
enddo
|
||||
do n = 1, ngm
|
||||
gaux(nl (n)) = CMPLX(0.d0, g(ipol , n))* a (nl(n)) - &
|
||||
g(ipol+1, n) * a (nl(n))
|
||||
gaux(nlm(n)) = CMPLX(0.d0, - g(ipol , n))* conjg(a (nl(n))) + &
|
||||
g(ipol+1, n) * conjg(a (nl(n)))
|
||||
enddo
|
||||
! bring back to R-space, (\grad_ipol a)(r) ...
|
||||
|
||||
call cft3 (gaux, nr1, nr2, nr3, nrx1, nrx2, nrx3, 1)
|
||||
! ...and add the factor 2\pi/a missing in the definition of q+G
|
||||
do n = 1, nrxx
|
||||
ga (ipol , n) = DREAL(gaux (n)) * tpiba
|
||||
ga (ipol+1, n) = DIMAG(gaux (n)) * tpiba
|
||||
enddo
|
||||
! z
|
||||
ipol=3
|
||||
do n = 1, nrxx
|
||||
gaux (n) = (0.d0, 0.d0)
|
||||
enddo
|
||||
do n = 1, ngm
|
||||
gaux(nl (n)) = CMPLX(0.d0, g(ipol, n)) * a (nl(n))
|
||||
gaux(nlm(n)) = conjg(gaux(nl(n)))
|
||||
enddo
|
||||
! bring back to R-space, (\grad_ipol a)(r) ...
|
||||
call cft3 (gaux, nr1, nr2, nr3, nrx1, nrx2, nrx3, 1)
|
||||
! ...and add the factor 2\pi/a missing in the definition of q+G
|
||||
do n = 1, nrxx
|
||||
ga (ipol, n) = DREAL(gaux (n)) * tpiba
|
||||
enddo
|
||||
! enddo
|
||||
call mfree (gaux)
|
||||
return
|
||||
|
||||
end subroutine gradient1
|
||||
!--------------------------------------------------------------------
|
||||
subroutine grad_dot1 (nrx1, nrx2, nrx3, nr1, nr2, nr3, nrxx, &
|
||||
a, ngm, g, nl, nlm, alat, da)
|
||||
!--------------------------------------------------------------------
|
||||
! Calculates da = \sum_i \grad_i a_i in R-space
|
||||
use parameters, only : DP
|
||||
use allocate
|
||||
implicit none
|
||||
integer :: nrx1, nrx2, nrx3, nr1, nr2, nr3, nrxx, ngm, nl (ngm), &
|
||||
nlm(ngm)
|
||||
complex(kind=DP) :: a (3, nrxx), da (nrxx)
|
||||
|
||||
real(kind=DP) :: g (3, ngm), alat
|
||||
integer :: n, ipol
|
||||
real(kind=DP) :: tpi, tpiba
|
||||
parameter (tpi = 2.d0 * 3.14159265358979d0)
|
||||
complex(kind=DP), pointer :: aux (:)
|
||||
complex(kind=DP) :: fp, fm, aux1, aux2
|
||||
|
||||
call mallocate(aux , nrxx)
|
||||
|
||||
tpiba = tpi / alat
|
||||
do n = 1, nrxx
|
||||
da(n) = (0.d0, 0.d0)
|
||||
enddo
|
||||
!!! do ipol = 1, 3
|
||||
! x, y
|
||||
ipol=1
|
||||
! copy a(ipol,r) to a complex array...
|
||||
do n = 1, nrxx
|
||||
aux (n) = CMPLX(DREAL(a(ipol, n)),DREAL(a(ipol+1, n)))
|
||||
enddo
|
||||
! bring a(ipol,r) to G-space, a(G) ...
|
||||
call cft3 (aux, nr1, nr2, nr3, nrx1, nrx2, nrx3, - 1)
|
||||
! multiply by i(q+G) to get (\grad_ipol a)(q+G) ...
|
||||
do n = 1, ngm
|
||||
fp = (aux(nl (n)) + aux (nlm(n)))*0.5d0
|
||||
fm = (aux(nl (n)) - aux (nlm(n)))*0.5d0
|
||||
aux1 = cmplx(DREAL(fp), DIMAG(fm))
|
||||
aux2 = cmplx(DIMAG(fp),-DREAL(fm))
|
||||
da (nl(n)) = da (nl(n)) + CMPLX(0.d0, g(ipol , n)) * aux1 + &
|
||||
CMPLX(0.d0, g(ipol+1, n)) * aux2
|
||||
end do
|
||||
! z
|
||||
ipol=3
|
||||
! copy a(ipol,r) to a complex array...
|
||||
do n = 1, nrxx
|
||||
aux (n) = a(ipol, n)
|
||||
enddo
|
||||
! bring a(ipol,r) to G-space, a(G) ...
|
||||
call cft3 (aux, nr1, nr2, nr3, nrx1, nrx2, nrx3, - 1)
|
||||
! multiply by i(q+G) to get (\grad_ipol a)(q+G) ...
|
||||
do n = 1, ngm
|
||||
da (nl(n)) = da (nl(n)) + CMPLX(0.d0, g(ipol, n)) * aux(nl(n))
|
||||
enddo
|
||||
!!! enddo
|
||||
do n = 1, ngm
|
||||
da(nlm(n)) = conjg(da(nl(n)))
|
||||
enddo
|
||||
! bring back to R-space, (\grad_ipol a)(r) ...
|
||||
call cft3 (da, nr1, nr2, nr3, nrx1, nrx2, nrx3, 1)
|
||||
! ...add the factor 2\pi/a missing in the definition of q+G and sum
|
||||
do n = 1, nrxx
|
||||
da (n) = da (n) * tpiba
|
||||
enddo
|
||||
call mfree (aux)
|
||||
|
||||
return
|
||||
end subroutine grad_dot1
|
||||
|
|
@ -0,0 +1,123 @@
|
|||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine dielec(do_zstar)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! calculates the dielectric tensor and effective charges
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use cgcom
|
||||
use allocate
|
||||
implicit none
|
||||
logical :: do_zstar
|
||||
!
|
||||
integer :: ibnd,ipol,jpol,na,nu,kpoint
|
||||
character(len=7) :: filbar, fildwf
|
||||
real(kind=DP) :: w, weight
|
||||
real(kind=DP), pointer :: work(:,:)
|
||||
complex(kind=DP), pointer :: dpsi2(:,:), dpsi3(:,:)
|
||||
logical :: done
|
||||
!
|
||||
call start_clock('dielec')
|
||||
!
|
||||
call mallocate(dpsi2, npwx, nbnd)
|
||||
call mallocate(dpsi3, npwx, nbnd)
|
||||
call mallocate(work, nbnd, 3)
|
||||
!
|
||||
call setv(9,0.d0,epsilon0,1)
|
||||
if (do_zstar) call setv(9*nat,0.d0,zstar,1)
|
||||
! do kpoint=1,nks
|
||||
kpoint=1
|
||||
weight = wk(kpoint)
|
||||
w = fpi/omega * weight
|
||||
!
|
||||
!** calculate Effective Charges (<DeltaV*psi(ion)|DeltaPsi(E)>)
|
||||
!
|
||||
! read DeltaPsi(E)
|
||||
! pol. 1
|
||||
ipol=1
|
||||
iudwf=10+ipol
|
||||
write(fildwf,'(''fildwx'',i1)') ipol
|
||||
call seqopn (iudwf,fildwf,'unformatted',done)
|
||||
read (iudwf) dpsi
|
||||
close(unit=iudwf)
|
||||
! pol. 2
|
||||
ipol=2
|
||||
iudwf=10+ipol
|
||||
write(fildwf,'(''fildwx'',i1)') ipol
|
||||
call seqopn (iudwf,fildwf,'unformatted',done)
|
||||
read (iudwf) dpsi2
|
||||
close(unit=iudwf)
|
||||
! pol. 3
|
||||
ipol=3
|
||||
iudwf=10+ipol
|
||||
write(fildwf,'(''fildwx'',i1)') ipol
|
||||
call seqopn (iudwf,fildwf,'unformatted',done)
|
||||
read (iudwf) dpsi3
|
||||
close(unit=iudwf)
|
||||
!
|
||||
if (.not.do_zstar) go to 10
|
||||
!
|
||||
do nu = 1,nmodes
|
||||
na = (nu-1)/3+1
|
||||
if (has_equivalent(na).eq.0) then
|
||||
! DeltaV*psi(ion) for mode nu is recalculated
|
||||
call dvpsi_kb(kpoint,nu)
|
||||
!
|
||||
jpol= mod(nu-1,3)+1
|
||||
! work is the real part of <DeltaV*Psi(ion)|DeltaPsi(E)>
|
||||
call pw_dot('N',npw,nbnd,dvpsi,npwx,dpsi ,npwx,work(1,1))
|
||||
call pw_dot('N',npw,nbnd,dvpsi,npwx,dpsi2,npwx,work(1,2))
|
||||
call pw_dot('N',npw,nbnd,dvpsi,npwx,dpsi3,npwx,work(1,3))
|
||||
do ipol = 1,3
|
||||
do ibnd = 1,nbnd
|
||||
zstar(ipol,jpol,na) = zstar(ipol,jpol,na) + 2.0*weight*work(ibnd,ipol)
|
||||
end do
|
||||
end do
|
||||
end if
|
||||
end do
|
||||
10 continue
|
||||
!** calculate Dielectric Tensor (<DeltaV*psi(E)\DeltaPsi(E)>)
|
||||
!
|
||||
do jpol=1,3
|
||||
! read DeltaV*Psi(elec) for polarization jpol
|
||||
iubar=jpol
|
||||
write(filbar,'(''filbar'',i1)') iubar
|
||||
call seqopn (iubar,filbar,'unformatted',done)
|
||||
read (iubar) dvpsi
|
||||
close(iubar)
|
||||
! now work is the real part of <DeltaV*psi(E)|DeltaPsi(E)>
|
||||
call pw_dot('N',npw,nbnd,dvpsi,npwx,dpsi ,npwx,work(1,1))
|
||||
call pw_dot('N',npw,nbnd,dvpsi,npwx,dpsi2,npwx,work(1,2))
|
||||
call pw_dot('N',npw,nbnd,dvpsi,npwx,dpsi3,npwx,work(1,3))
|
||||
do ipol = 1,3
|
||||
do ibnd = 1,nbnd
|
||||
epsilon0(ipol,jpol) = epsilon0(ipol,jpol) + 4.0*w*work(ibnd,ipol)
|
||||
end do
|
||||
end do
|
||||
end do
|
||||
! end do
|
||||
#ifdef PARA
|
||||
if (do_zstar) call reduce(3*3*nat,zstar)
|
||||
call reduce(3*3,epsilon0)
|
||||
#endif
|
||||
call mfree(work)
|
||||
call mfree(dpsi3)
|
||||
call mfree(dpsi2)
|
||||
!
|
||||
! add the diagonal part
|
||||
!
|
||||
do ipol=1,3
|
||||
epsilon0(ipol,ipol) = epsilon0(ipol,ipol) + 1.0
|
||||
if (do_zstar) then
|
||||
do na=1,nat
|
||||
zstar(ipol,ipol,na) = zstar(ipol,ipol,na) + zv(ityp(na))
|
||||
end do
|
||||
end if
|
||||
end do
|
||||
!
|
||||
call stop_clock('dielec')
|
||||
!
|
||||
return
|
||||
end subroutine dielec
|
||||
|
|
@ -0,0 +1,126 @@
|
|||
!
|
||||
! Copyright (C) 2001 PWSCF group
|
||||
! This file is distributed under the terms of the
|
||||
! GNU General Public License. See the file `License'
|
||||
! in the root directory of the present distribution,
|
||||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
function dmxc (rho)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! derivative of the xc potential with respect to the local density
|
||||
!
|
||||
use parameters, only : DP
|
||||
use funct
|
||||
implicit none
|
||||
! I/O variables
|
||||
|
||||
real(kind=DP) :: rho, dmxc
|
||||
! input: the charge density ( positive )
|
||||
! output: the derivative of the xc potential
|
||||
|
||||
|
||||
real(kind=DP) :: dr, vxp, vcp, vxm, vcm, ex, ec
|
||||
! delta rrho for numerical derivatives
|
||||
! the potentials for + charge
|
||||
! the potentials for - charge
|
||||
! the energy
|
||||
! DFT functional
|
||||
! auxiliary variables
|
||||
real(kind=DP) :: vx, rs, dpz
|
||||
|
||||
|
||||
integer :: iflg
|
||||
! parameters
|
||||
real(kind=DP) :: small, e2, pi34, third
|
||||
parameter (small = 1.d-30, e2 = 2.d0)
|
||||
|
||||
parameter (pi34 = 0.75d0 / 3.141592653589793d+00, third = 1.d0 / &
|
||||
3.d0)
|
||||
dmxc = 0.d0
|
||||
if (rho.le.small) then
|
||||
return
|
||||
|
||||
endif
|
||||
!
|
||||
! first case: analytical derivatives available
|
||||
!
|
||||
if (iexch.eq.1.and.icorr.eq.1) then
|
||||
rs = (pi34 / rho) **third
|
||||
!..exchange
|
||||
call slater (rs, ex, vx)
|
||||
dmxc = vx / (3.d0 * rho)
|
||||
!..correlation
|
||||
iflg = 2
|
||||
if (rs.lt.1.0d0) iflg = 1
|
||||
dmxc = dmxc + dpz (rs, iflg)
|
||||
else
|
||||
!
|
||||
! second case: numerical derivatives
|
||||
!
|
||||
dr = min (1.d-6, 1.d-4 * rho)
|
||||
call xc (rho + dr, ex, ec, vxp, vcp)
|
||||
call xc (rho - dr, ex, ec, vxm, vcm)
|
||||
dmxc = (vxp + vcp - vxm - vcm) / (2.d0 * dr)
|
||||
endif
|
||||
!
|
||||
! scales to rydberg units
|
||||
!
|
||||
|
||||
dmxc = e2 * dmxc
|
||||
return
|
||||
|
||||
end function dmxc
|
||||
!-----------------------------------------------------------------------
|
||||
function dpz (rs, iflg)
|
||||
!-----------------------------------------------------------------------
|
||||
! derivative of the correlation potential with respect to the local den
|
||||
! Perdew and Zunger parameterization of the C.A. functional
|
||||
!
|
||||
use parameters, only : DP
|
||||
implicit none
|
||||
real(kind=DP) :: rs, dpz
|
||||
! input : the value of rs
|
||||
! output: the derivative of the corr. poten
|
||||
|
||||
integer :: iflg
|
||||
! input : flag to choose the functional for
|
||||
|
||||
real(kind=DP) :: b1, b2, a1, a2, gc, a, b, c, d, pi, fpi
|
||||
!\
|
||||
! \
|
||||
! \
|
||||
! \
|
||||
! parameter which define the functional
|
||||
!
|
||||
!
|
||||
!
|
||||
! /
|
||||
! /
|
||||
!/
|
||||
parameter (a = 0.0311d0, b = - 0.048d0, c = 0.0020d0, d = - &
|
||||
0.0116d0, gc = - 0.1423d0, b1 = 1.0529d0, b2 = 0.3334d0, a1 = &
|
||||
7.0d0 * b1 / 6.d0, a2 = 4.d0 * b2 / 3.d0, pi = 3.14159265358979d0, &
|
||||
fpi = 4.d0 * pi)
|
||||
|
||||
real(kind=DP) :: x, den, dmx, dmrs
|
||||
! auxiliary variable
|
||||
! auxiliary variable
|
||||
! auxiliary variable
|
||||
! auxiliary variable
|
||||
if (iflg.eq.1) then
|
||||
dmrs = a / rs + 2.d0 / 3.d0 * c * (log (rs) + 1.d0) + (2.d0 * &
|
||||
d-c) / 3.d0
|
||||
else
|
||||
x = sqrt (rs)
|
||||
den = 1.d0 + x * (b1 + x * b2)
|
||||
dmx = gc * ( (a1 + 2.d0 * a2 * x) * den - 2.d0 * (b1 + 2.d0 * &
|
||||
b2 * x) * (1.d0 + x * (a1 + x * a2) ) ) / den**3
|
||||
dmrs = 0.5d0 * dmx / x
|
||||
endif
|
||||
!
|
||||
|
||||
dpz = - fpi * rs**4.d0 / 9.d0 * dmrs
|
||||
return
|
||||
end function dpz
|
||||
|
|
@ -0,0 +1,52 @@
|
|||
!
|
||||
!-----------------------------------------------------------------------
|
||||
subroutine drhodv(nu_i)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! calculate the electronic term <psi|dv|dpsi> of the dynamical matrix
|
||||
!
|
||||
#include "machine.h"
|
||||
use pwcom
|
||||
use cgcom
|
||||
implicit none
|
||||
integer :: nu_i
|
||||
!
|
||||
integer :: nu_j, ibnd, kpoint
|
||||
real(kind=DP) :: dynel(nmodes), work(nbnd)
|
||||
!
|
||||
call start_clock('drhodv')
|
||||
!
|
||||
call setv(nmodes,0.d0,dynel,1)
|
||||
kpoint = 1
|
||||
! do kpoint=1,nks
|
||||
!
|
||||
!** calculate the dynamical matrix (<DeltaV*psi(ion)|\DeltaPsi(ion)>)
|
||||
!
|
||||
do nu_j = 1,nmodes
|
||||
!
|
||||
! DeltaV*psi(ion) for mode nu_j is recalculated
|
||||
!
|
||||
call dvpsi_kb(kpoint,nu_j)
|
||||
!
|
||||
! this is the real part of <DeltaV*Psi(ion)|DeltaPsi(ion)>
|
||||
!
|
||||
call pw_dot('N',npw,nbnd,dvpsi,npwx,dpsi ,npwx,work)
|
||||
do ibnd = 1,nbnd
|
||||
dynel(nu_j) = dynel(nu_j) + 2.0*wk(kpoint)*work(ibnd)
|
||||
end do
|
||||
end do
|
||||
#ifdef PARA
|
||||
call reduce(nmodes,dynel)
|
||||
#endif
|
||||
!
|
||||
! NB this must be done only at the end of the calculation!
|
||||
!
|
||||
do nu_j = 1,nmodes
|
||||
dyn(nu_i,nu_j) = - (dyn(nu_i,nu_j)+dynel(nu_j))
|
||||
end do
|
||||
!
|
||||
call stop_clock('drhodv')
|
||||
!
|
||||
return
|
||||
end subroutine drhodv
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue