Commit afec7521 authored by giannozz's avatar giannozz

End of this set of not-so-fundamental changes. Summary:

1) no more f_defs.h file to be included in fortran files
2) all CMPLX explicitly defined as CMPLX(...,KIND=dp)
3) blas/lapack names in lowercase (not all of them, actually)
4) documentation accordingly updated (plus unrelated changes to user_guide)


git-svn-id: http://qeforge.qe-forge.org/svn/q-e/trunk/espresso@5805 c92efa57-630b-4861-b058-cf58834340f0
parent 070f0ff1
......@@ -5,7 +5,6 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
#include "f_defs.h"
!
!-----------------------------------------------------------------------
subroutine allocate_d3
......
!
! Copyright (C) 2001-2008 Quantum-ESPRESSO group
! Copyright (C) 2001-2008 Quantum ESPRESSO 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,
......@@ -14,7 +14,6 @@ subroutine bcast_d3_input
!
!
#ifdef __PARA
#include "f_defs.h"
use pwcom
use phcom
use d3com
......
......@@ -12,7 +12,6 @@ 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 "f_defs.h"
USE kinds, only : DP
use pwcom
USE uspp, ONLY: vkb
......@@ -80,14 +79,14 @@ subroutine ch_psi_all2 (n, h, ah, e, ik, m)
endif
ps = (0.d0, 0.d0)
call ZGEMM ('C', 'N', nbnd, m, n, (1.d0, 0.d0) , evq, npwx, spsi, &
call zgemm ('C', 'N', nbnd, m, n, (1.d0, 0.d0) , evq, npwx, spsi, &
npwx, (0.d0, 0.d0) , ps, nbnd)
ps = ps * alpha_pv
#ifdef __PARA
call mp_sum( ps, intra_pool_comm )
#endif
call ZGEMM ('N', 'N', n, m, nbnd, (1.d0, 0.d0) , evq, npwx, ps, &
call zgemm ('N', 'N', n, m, nbnd, (1.d0, 0.d0) , evq, npwx, ps, &
nbnd, (1.d0, 0.d0) , hpsi, npwx)
spsi = hpsi
!
......
......@@ -5,7 +5,6 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
#include "f_defs.h"
!-----------------------------------------------------------------------
SUBROUTINE close_open (isw)
!-----------------------------------------------------------------------
......
......@@ -5,7 +5,6 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
#include "f_defs.h"
!
!----------------------------------------------------------------------
SUBROUTINE d0rhod2v (ipert, drhoscf)
......@@ -53,7 +52,7 @@ SUBROUTINE d0rhod2v (ipert, drhoscf)
REAL (DP) :: gtau, & ! the product G*\tau_s
wgg ! the weight of a K point
COMPLEX (DP) :: ZDOTC, d3dywrk (3*nat,3*nat), fac, alpha(8), work
COMPLEX (DP) :: zdotc, d3dywrk (3*nat,3*nat), fac, alpha(8), work
COMPLEX (DP), ALLOCATABLE :: work0 (:), work1 (:), work2 (:), &
work3 (:), work4 (:), work5 (:), &
work6 (:)
......@@ -87,7 +86,7 @@ SUBROUTINE d0rhod2v (ipert, drhoscf)
g(2,ng)*tau(2,na) + &
g(3,ng)*tau(3,na) )
fac = CMPLX(COS(gtau),SIN(gtau))
fac = CMPLX(COS(gtau),SIN(gtau),kind=DP)
d3dywrk(na_icart,na_jcart) = &
d3dywrk(na_icart,na_jcart) - &
......@@ -162,14 +161,14 @@ SUBROUTINE d0rhod2v (ipert, drhoscf)
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)
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 mp_sum( alpha, intra_pool_comm )
#endif
......
......@@ -5,7 +5,6 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
#include "f_defs.h"
!
!-----------------------------------------------------------------------
SUBROUTINE d3_exc
......@@ -62,7 +61,7 @@ SUBROUTINE d3_exc
CALL davcio_drho (work2, lrdrho, iudrho, jpert, - 1)
DO kpert = 1, 3 * nat
CALL davcio_drho (work3, lrdrho, iudrho, kpert, - 1)
aux = CMPLX (0.d0, 0.d0)
aux = CMPLX(0.d0, 0.d0,kind=DP)
DO ir = 1, nrxx
aux = aux + &
d2muxc (ir) * work1 (ir) * &
......
......@@ -5,7 +5,6 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
#include "f_defs.h"
!-----------------------------------------------------------------------
SUBROUTINE d3_init
!-----------------------------------------------------------------------
......
......@@ -5,7 +5,6 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
#include "f_defs.h"
!
!-----------------------------------------------------------------------
SUBROUTINE d3_readin()
......
......@@ -5,7 +5,6 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
#include "f_defs.h"
!
!-----------------------------------------------------------------------
SUBROUTINE d3_recover (ilab, isw)
......
......@@ -5,7 +5,6 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
#include "f_defs.h"
!
!-----------------------------------------------------------------------
SUBROUTINE d3_setup()
......
!
! Copyright (C) 2001-2008 Quantum-ESPRESSO group
! Copyright (C) 2001-2008 Quantum ESPRESSO 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 .
!
#include "f_defs.h"
!
!-----------------------------------------------------------------------
subroutine d3_summary
......
......@@ -14,7 +14,6 @@ subroutine d3_symdyn (d3dyn, u, ug0, xq, s, invs, rtau, irt, irgq, &
! of the modes
!
!
#include "f_defs.h"
USE kinds, only : DP
USE mp_global, ONLY : inter_pool_comm, intra_pool_comm
USE mp, ONLY : mp_sum
......
......@@ -16,7 +16,6 @@ subroutine d3_symdynph (xq, phi, s, invs, rtau, irt, irgq, nsymq, &
! q -> -q+G if present.
!
!
#include "f_defs.h"
USE kinds, only : DP
USE constants, only : tpi
implicit none
......@@ -104,7 +103,7 @@ subroutine d3_symdynph (xq, phi, s, invs, rtau, irt, irgq, nsymq, &
rtau (kpol, irotmq, nb) ) )
enddo
arg = arg * tpi
fase = CMPLX (cos (arg), sin (arg) )
fase = CMPLX(cos (arg), sin (arg) ,kind=DP)
do npol = 1, 3
do kpol = 1, 3
do lpol = 1, 3
......@@ -161,7 +160,7 @@ subroutine d3_symdynph (xq, phi, s, invs, rtau, irt, irgq, nsymq, &
rtau (ipol, irot, nb) ) )
enddo
arg = arg * tpi
faseq (isymq) = CMPLX (cos (arg), sin (arg) )
faseq (isymq) = CMPLX(cos (arg), sin (arg) ,kind=DP)
do mpol = 1, 3
do ipol = 1, 3
do jpol = 1, 3
......
......@@ -5,7 +5,6 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
#include "f_defs.h"
!
!-----------------------------------------------------------------------
subroutine d3_valence
......@@ -139,7 +138,7 @@ subroutine d3_valence
do nu_i = 1, 3 * nat
if (q0mode (nu_i) .or.lgamma) then
wrk1 = CMPLX (0.d0, 0.d0)
wrk1 = CMPLX(0.d0, 0.d0,kind=DP)
do ibnd = 1, nbnd
do jbnd = 1, nbnd
de1 = et (ibnd, ikk) - et (jbnd, ikq)
......@@ -161,7 +160,7 @@ subroutine d3_valence
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 = CMPLX (0.d0, 0.d0)
wrk1 = CMPLX(0.d0, 0.d0,kind=DP)
do ibnd = 1, nbnd
wrk1 = wrk1 + wk (ikk) * ef_sh (nu_i) * dpsidvpsi (ibnd, ibnd) &
* w0gauss ( (ef - et (ibnd, ikk) ) / degauss, ngauss) / &
......@@ -188,7 +187,7 @@ subroutine d3_valence
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) = CMPLX (0.d0, 0.d0)
aux2 (nu_i, nu_j, nu_k) = CMPLX(0.d0, 0.d0,kind=DP)
enddo
enddo
endif
......
......@@ -5,7 +5,6 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
#include "f_defs.h"
!
!-----------------------------------------------------------------------
subroutine d3dyn_cc
......@@ -64,7 +63,7 @@ subroutine d3dyn_cc
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 = CMPLX (cos (arg), sin (arg) )
exc = CMPLX(cos (arg), sin (arg) ,kind=DP)
drc_exp (ig, na) = d0rc (ig, nta) * exc
enddo
enddo
......@@ -74,7 +73,7 @@ subroutine d3dyn_cc
arhox = abs (rhox)
if (arhox > 1.0d-30) then
call xc (arhox, ex, ec, vx, vc)
aux (ir) = CMPLX (e2 * (vx + vc), 0.d0)
aux (ir) = CMPLX(e2 * (vx + vc), 0.d0,kind=DP)
endif
enddo
......@@ -87,9 +86,9 @@ subroutine d3dyn_cc
do k_cart = 1, 3
na_k = k_cart + 3 * (na - 1)
work = CMPLX (0.d0, 0.d0)
work = (0.d0, 0.d0)
do ig = 1, ngm
work = work + CMPLX (0.d0, 1.d0) * g (i_cart, ig) * g (j_cart, ig) &
work = work + (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
......@@ -119,7 +118,7 @@ subroutine d3dyn_cc
na_i = i_cart + 3 * (na - 1)
do j_cart = 1, 3
na_j = j_cart + 3 * (na - 1)
work = CMPLX (0.d0, 0.d0)
work = (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)
......@@ -142,7 +141,7 @@ subroutine d3dyn_cc
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 = CMPLX (cos (arg), sin (arg) )
exc = CMPLX(cos (arg), sin (arg) ,kind=DP)
drc_exp (ig, na) = drc (ig, nta) * exc
enddo
enddo
......@@ -168,7 +167,7 @@ subroutine d3dyn_cc
do j_cart = 1, 3
na_j = j_cart + 3 * (na - 1)
work = CMPLX (0.d0, 0.d0)
work = (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) )
......
......@@ -17,7 +17,6 @@ subroutine d3ionq (nat, ntyp, ityp, zv, tau, alat, omega, q, at, &
! Both the real and reciprocal space terms
! are included.
!
#include "f_defs.h"
!
USE kinds, only : DP
USE io_global, ONLY : stdout
......@@ -136,7 +135,7 @@ subroutine d3ionq (nat, ntyp, ityp, zv, tau, alat, omega, q, at, &
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)
facg = fac * zv (nta) * zv (ntb) * CMPLX(sin (arg), 0.d0,kind=DP)
fnat = fnat + facg
enddo
endif
......@@ -160,7 +159,7 @@ subroutine d3ionq (nat, ntyp, ityp, zv, tau, alat, omega, q, at, &
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)
fnat = fac * zv (nta) * zv (ntb) * CMPLX(sin (arg), 0.d0,kind=DP)
do jcart = 1, 3
nu_j = 3 * (nb - 1) + jcart
do kcart = 1, 3
......@@ -192,7 +191,7 @@ subroutine d3ionq (nat, ntyp, ityp, zv, tau, alat, omega, q, at, &
+ (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) )
CMPLX( - sin (argq), - cos (argq) ,kind=DP)
do jcart = 1, 3
nu_j = 3 * (nb - 1) + jcart
do kcart = 1, 3
......@@ -261,21 +260,21 @@ subroutine d3ionq (nat, ntyp, ityp, zv, tau, alat, omega, q, at, &
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) * CMPLX (cos (qrg), sin (qrg) ) * &
zv (nta) * zv (ntb) * CMPLX(cos (qrg), sin (qrg) ,kind=DP) * &
d3f * alat**3 * r (icart, nr) * r (jcart, nr) * r (kcart, nr)
if (icart == jcart) then
d3dy2 (nu_i, nu_j, nu_k) = d3dy2 (nu_i, nu_j, nu_k) - &
e2 * zv (nta) * zv (ntb) * d2f * &
CMPLX (cos (qrg), sin (qrg) ) * alat * r (kcart, nr)
CMPLX(cos (qrg), sin (qrg) ,kind=DP) * alat * r (kcart, nr)
end if
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) * CMPLX (cos (qrg), sin (qrg) ) * &
zv (nta) * zv (ntb) * CMPLX(cos (qrg), sin (qrg) ,kind=DP) * &
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) * CMPLX (cos (qrg), sin (qrg) ) * &
zv (nta) * zv (ntb) * CMPLX(cos (qrg), sin (qrg) ,kind=DP) * &
d2f * alat * r (icart, nr)
!
! nc = na case
......@@ -283,21 +282,21 @@ subroutine d3ionq (nat, ntyp, ityp, zv, tau, alat, omega, q, at, &
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) * CMPLX (cos (qrg), sin (qrg) ) * &
zv (nta) * zv (ntb) * CMPLX(cos (qrg), sin (qrg) ,kind=DP) * &
d3f * alat**3 * r (icart, nr) * r (jcart, nr) * r (kcart, nr)
if (icart == jcart) then
d3dy2 (nu_i, nu_j, nu_k) = d3dy2 (nu_i, nu_j, nu_k) + e2 *&
zv (nta) * zv (ntb) * CMPLX (cos (qrg), sin (qrg) ) &
zv (nta) * zv (ntb) * CMPLX(cos (qrg), sin (qrg) ,kind=DP) &
* d2f * alat * r (kcart, nr)
end if
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) * CMPLX (cos (qrg), sin (qrg) ) * &
zv (nta) * zv (ntb) * CMPLX(cos (qrg), sin (qrg) ,kind=DP) * &
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) * CMPLX (cos (qrg), sin (qrg) ) * &
zv (nta) * zv (ntb) * CMPLX(cos (qrg), sin (qrg) ,kind=DP) * &
d2f * alat * r (icart, nr)
!
! na = nb case (NB: role of nu_k and nu_j are interchanged)
......
!
! Copyright (C) 2001-2008 Quantum-ESPRESSO group
! Copyright (C) 2001-2008 Quantum ESPRESSO 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,
......
......@@ -5,7 +5,6 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
#include "f_defs.h"
!
!-----------------------------------------------------------------------
program d3toten
......
!
! Copyright (C) 2001-2006 Quantum-ESPRESSO group
! Copyright (C) 2001-2006 Quantum ESPRESSO 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 .
!
#include "f_defs.h"
!
!----------------------------------------------------------------------
subroutine d3vrho()
......@@ -43,7 +42,7 @@ subroutine d3vrho()
! auxiliary variable
! the true weight of a K point
complex (DP) :: alpha (8), ZDOTC, work
complex (DP) :: alpha (8), zdotc, work
complex (DP), allocatable :: d3dynwrk (:,:,:), d3dynwrk2 (:,:,:), &
rhog (:), work1 (:,:), work2 (:,:), work3 (:)
......@@ -56,7 +55,7 @@ subroutine d3vrho()
d3dynwrk (:,:,:) = (0.d0, 0.d0)
do ir = 1, nrxx
rhog (ir) = CMPLX (rho%of_r (ir, 1), 0.d0)
rhog (ir) = CMPLX(rho%of_r (ir, 1), 0.d0,kind=DP)
enddo
call cft3 (rhog, nr1, nr2, nr3, nrx1, nrx2, nrx3, - 1)
!
......@@ -129,14 +128,14 @@ subroutine d3vrho()
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)
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 mp_sum ( alpha, intra_pool_comm )
#endif
......
......@@ -5,7 +5,6 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
#include "f_defs.h"
!
!-----------------------------------------------------------------------
SUBROUTINE davcio_drho2 (drho, lrec, iunit, nrec, isw)
......@@ -60,7 +59,7 @@ SUBROUTINE davcio_drho2 (drho, lrec, iunit, nrec, isw)
itmp = itmp + dfftp%nnp * dfftp%npp (proc)
ENDDO
drho (:) = (0.d0, 0.d0)
CALL ZCOPY (dfftp%nnp * dfftp%npp (me_pool+1), ddrho (itmp), 1, drho, 1)
CALL zcopy (dfftp%nnp * dfftp%npp (me_pool+1), ddrho (itmp), 1, drho, 1)
ENDIF
DEALLOCATE(ddrho)
......
......@@ -16,7 +16,6 @@ subroutine dpsi_corr (evcq, psidvpsi_x, ik, ikq, nu)
! this routine corrects dpsi in such a way that the density matrix
! is given by: Sum_{k,nu} 2 * | dpsi > < psi |
!
#include "f_defs.h"
USE kinds, only : DP
use pwcom
use phcom
......@@ -48,7 +47,7 @@ subroutine dpsi_corr (evcq, psidvpsi_x, ik, ikq, nu)
!
do ibnd = 1, nbnd
wg1 = wgauss ( (ef - et (ibnd, ik) ) / degauss, ngauss)
call DSCAL (2 * npwq, wg1, dpsi (1, ibnd), 1)
call dscal (2 * npwq, wg1, dpsi (1, ibnd), 1)
enddo
!
! Adds to dpsi the term containing the valence wavefunctions
......@@ -65,7 +64,7 @@ subroutine dpsi_corr (evcq, psidvpsi_x, ik, ikq, nu)
/ degauss
endif
psidvpsi = 0.5d0 * wwg * psidvpsi_x (jbnd, ibnd)
call ZAXPY (npwq, psidvpsi, evcq (1, jbnd), 1, dpsi (1, ibnd), &
call zaxpy (npwq, psidvpsi, evcq (1, jbnd), 1, dpsi (1, ibnd), &
1)
enddo
enddo
......@@ -76,7 +75,7 @@ subroutine dpsi_corr (evcq, psidvpsi_x, ik, ikq, nu)
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) &
call daxpy (2 * npw, wfshift, evcq (1, ibnd), 1, dpsi (1, ibnd) &
, 1)
enddo
......
......@@ -5,7 +5,6 @@
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
#include "f_defs.h"
!
!-----------------------------------------------------------------------
subroutine dpsidpsidv
......@@ -23,7 +22,7 @@ subroutine dpsidpsidv
integer :: ik, ikk, ikq, ibnd, jbnd, nu_i, nu_j, nu_z, nrec
real (DP) :: wgauss, wga (nbnd), wgq (nbnd), w0gauss, w0g (nbnd), &
deltae, wg1, wg2, wwg
complex (DP) :: wrk, wrk0, ZDOTC
complex (DP) :: wrk, wrk0, zdotc
complex (DP), allocatable :: dqpsi (:,:), ps1_ij (:,:), ps1_ji (:,:),&
ps3_ij (:,:), ps2_ji (:,:), d3dyn1 (:,:,:), d3dyn2 (:,:,:),&
d3dyn3 (:,:,:)
......@@ -84,8 +83,8 @@ subroutine dpsidpsidv
nrec = nu_z + (ik - 1) * 3 * nat