Commit b5393a27 authored by Daniel Wortmann's avatar Daniel Wortmann

Removed polymorphic variables in IO to make FLEUR run with PGI compilers

parent 7ea50a4d
......@@ -193,8 +193,7 @@ CONTAINS
TYPE (t_usdus) :: usdus
TYPE (t_zMat) :: zMat
LOGICAL :: l_real
l_real=sym%invs.AND.(.NOT.noco%l_soc).AND.(.NOT.noco%l_noco)
zmat%l_real=sym%invs.AND.(.NOT.noco%l_soc).AND.(.NOT.noco%l_noco)
! ..
! ..
llpd=(atoms%lmaxd*(atoms%lmaxd+3))/2
......@@ -520,22 +519,13 @@ CONTAINS
n_end = noccbd
END IF
END IF
zMat%l_real = l_real
IF (l_real) THEN
IF (zmat%l_real) THEN
IF (.NOT.ALLOCATED(zMat%z_r)) THEN
ALLOCATE (zMat%z_r(dimension%nbasfcn,dimension%neigd))
zMat%nbasfcn = dimension%nbasfcn
zMat%nbands = dimension%neigd
END IF
zMat%z_r = 0
#ifndef __PGI
CALL cdn_read(&
eig_id,dimension%nvd,dimension%jspd,mpi%irank,mpi%isize,&
ikpt,jspin,dimension%nbasfcn,noco%l_ss,noco%l_noco,&
noccbd,n_start,n_end,&
lapw%nmat,lapw%nv,ello,evdu,epar,kveclo,&
lapw%k1,lapw%k2,lapw%k3,bkpt,wk,nbands,eig,zMat%z_r)
#endif
ELSE
IF (.NOT.ALLOCATED(zMat%z_c)) THEN
ALLOCATE (zMat%z_c(dimension%nbasfcn,dimension%neigd))
......@@ -543,15 +533,15 @@ CONTAINS
zMat%nbands = dimension%neigd
END IF
zMat%z_c = 0
#ifndef __PGI
CALL cdn_read(&
endif
CALL cdn_read(&
eig_id,dimension%nvd,dimension%jspd,mpi%irank,mpi%isize,&
ikpt,jspin,dimension%nbasfcn,noco%l_ss,noco%l_noco,&
noccbd,n_start,n_end,&
lapw%nmat,lapw%nv,ello,evdu,epar,kveclo,&
lapw%k1,lapw%k2,lapw%k3,bkpt,wk,nbands,eig,zMat%z_c)
#endif
endif
lapw%k1,lapw%k2,lapw%k3,bkpt,wk,nbands,eig,zMat)
!IF (l_evp.AND.(isize.GT.1)) THEN
! eig(1:noccbd) = eig(n_start:n_end)
!ENDIF
......@@ -587,7 +577,7 @@ CONTAINS
nslibd = nslibd + 1
eig(nslibd) = eig(i)
we(nslibd) = we(i)
if (l_real) THEN
if (zmat%l_real) THEN
zMat%z_r(:,nslibd) = zMat%z_r(:,i)
else
zMat%z_c(:,nslibd) = zMat%z_c(:,i)
......@@ -603,7 +593,7 @@ CONTAINS
nslibd = nslibd + 1
eig(nslibd) = eig(sliceplot%nnne)
we(nslibd) = we(sliceplot%nnne)
if (l_real) Then
if (zmat%l_real) Then
zMat%z_r(:,nslibd) = zMat%z_r(:,sliceplot%nnne)
else
zMat%z_c(:,nslibd) = zMat%z_c(:,sliceplot%nnne)
......@@ -614,7 +604,7 @@ CONTAINS
nslibd = nslibd + 1
eig(nslibd) = eig(i)
we(nslibd) = we(i)
if (l_real) THEN
if (zmat%l_real) THEN
zMat%z_r(:,nslibd) = zMat%z_r(:,i)
else
zMat%z_c(:,nslibd) = zMat%z_c(:,i)
......@@ -644,7 +634,7 @@ CONTAINS
IF (.NOT.((jspin.EQ.2) .AND. noco%l_noco)) THEN
CALL timestart("cdnval: pwden")
CALL pwden(stars,kpts,banddos,oneD, input,mpi,noco,cell,atoms,sym,ikpt,&
jspin,lapw,noccbd,igq_fft,we, eig,bkpt,qpw,cdom,qis,results%force,f_b8,zMat,l_real)
jspin,lapw,noccbd,igq_fft,we, eig,bkpt,qpw,cdom,qis,results%force,f_b8,zMat)
CALL timestop("cdnval: pwden")
END IF
!+new
......@@ -654,7 +644,7 @@ CONTAINS
IF (banddos%dos.AND.(banddos%ndir.EQ.-3)) THEN
IF (.NOT.((jspin.EQ.2) .AND. noco%l_noco)) THEN
CALL q_int_sl(jspin,stars,atoms,sym, volsl,volintsl,&
cell,noccbd,lapw, nsl,zsl,nmtsl,oneD, qintsl(:,:),zMat,l_real)
cell,noccbd,lapw, nsl,zsl,nmtsl,oneD, qintsl(:,:),zMat)
!
END IF
......@@ -666,7 +656,7 @@ CONTAINS
CALL timestart("cdnval: vacden")
CALL vacden(vacuum,dimension,stars,oneD, kpts,input, cell,atoms,noco,banddos,&
gvac1d,gvac2d, we,ikpt,jspin,vz,vz0, noccbd,bkpt,lapw, evac,eig,&
rhtxy,rht,qvac,qvlay, qstars,cdomvz,cdomvxy,zMat,l_real)
rhtxy,rht,qvac,qvlay, qstars,cdomvz,cdomvxy,zMat)
CALL timestop("cdnval: vacden")
END IF
!---> perform Brillouin zone integration and summation over the
......@@ -705,13 +695,13 @@ CONTAINS
cveccof(3,-atoms%llod:atoms%llod,noccbd,atoms%nlod,atoms%nat) )
CALL to_pulay(input,atoms,noccbd,sym, lapw, noco,cell,bkpt,noccbd,eig,usdus,&
kveclo,ispin,oneD, acof(:,0:,:,ispin),bcof(:,0:,:,ispin),&
e1cof,e2cof,aveccof,bveccof, ccof(-atoms%llod,1,1,1,ispin),acoflo,bcoflo,cveccof,zMat,l_real)
e1cof,e2cof,aveccof,bveccof, ccof(-atoms%llod,1,1,1,ispin),acoflo,bcoflo,cveccof,zMat)
CALL timestop("cdnval: to_pulay")
ELSE
CALL timestart("cdnval: abcof")
CALL abcof(input,atoms,noccbd,sym, cell, bkpt,lapw,noccbd,usdus, noco,ispin,kveclo,oneD,&
acof(:,0:,:,ispin),bcof(:,0:,:,ispin),ccof(-atoms%llod:,:,:,:,ispin),zMat,l_real)
acof(:,0:,:,ispin),bcof(:,0:,:,ispin),ccof(-atoms%llod:,:,:,:,ispin),zMat)
CALL timestop("cdnval: abcof")
END IF
......@@ -840,7 +830,7 @@ CONTAINS
cartk=matmul(bkpt,cell%bmat)
IF (banddos%ndir.GT.0) THEN
CALL sympsi(bkpt,lapw%nv(jspin),lapw%k1(:,jspin),lapw%k2(:,jspin),&
lapw%k3(:,jspin),sym,dimension,nbands,cell,eig,noco, ksym,jsym,zMat,l_real)
lapw%k3(:,jspin),sym,dimension,nbands,cell,eig,noco, ksym,jsym,zMat)
END IF
!
!--dw now write k-point data to tmp_dos
......@@ -854,7 +844,7 @@ CONTAINS
END IF
!---> end of loop over PE's
IF (l_real) THEN
IF (zmat%l_real) THEN
DEALLOCATE (zMat%z_r)
ELSE
DEALLOCATE (zMat%z_c)
......
......@@ -7,7 +7,7 @@
MODULE m_pwden
CONTAINS
SUBROUTINE pwden(stars,kpts,banddos,oneD, input,mpi,noco,cell,atoms,sym, &
ikpt,jspin,lapw,ne, igq_fft,we,eig,bkpt, qpw,cdom, qis,forces,f_b8,zMat,realdata)
ikpt,jspin,lapw,ne, igq_fft,we,eig,bkpt, qpw,cdom, qis,forces,f_b8,zMat)
!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
! In this subroutine the star function expansion coefficients of
! the plane wave charge density is determined.
......@@ -98,7 +98,6 @@ CONTAINS
REAL,INTENT(IN) :: bkpt(3)
!-----> BASIS FUNCTION INFORMATION
INTEGER,INTENT(IN):: ne
LOGICAL,OPTIONAL,INTENT(IN)::realdata
!-----> CHARGE DENSITY INFORMATION
INTEGER,INTENT(IN) :: ikpt,jspin
COMPLEX,INTENT(INOUT) :: qpw(:,:) !(stars%n3d,dimension%jspd)
......@@ -136,12 +135,7 @@ CONTAINS
COMPLEX CPP_BLAS_cdotc
EXTERNAL CPP_BLAS_cdotc
IF (PRESENT(realdata)) THEN
l_real=realdata
ELSE
l_real=zMat%l_real
ENDIF
!-------> ABBREVIATIONS
!
! rhon : charge density in real space
......@@ -192,7 +186,7 @@ CONTAINS
psi2i(0:stars%kq1d*stars%kq2d*stars%kq3d-1),&
rhomat(0:stars%kq1d*stars%kq2d*stars%kq3d-1,4) )
ELSE
IF (l_real) THEN
IF (zmat%l_real) THEN
ALLOCATE ( psir(-stars%kq1d*stars%kq2d:2*stars%kq1d*stars%kq2d*(stars%kq3d+1)-1),&
psii(1),&
rhon(-stars%kq1d*stars%kq2d:stars%kq1d*stars%kq2d*(stars%kq3d+1)-1) )
......@@ -233,7 +227,7 @@ CONTAINS
IF (noco%l_noco) THEN
q0_11 = zero
q0_22 = zero
IF (.NOT.l_real ) THEN
IF (.NOT.zmat%l_real ) THEN
DO nu = 1 , ne
q0_11 = q0_11 + we(nu) * CPP_BLAS_cdotc(lapw%nv(1),zMat%z_c(1,nu),1,zMat%z_c(1,nu),1)
q0_22 = q0_22 + we(nu) * CPP_BLAS_cdotc(lapw%nv(2),zMat%z_c(lapw%nv(1)+atoms%nlotot+1,nu),1, zMat%z_c(lapw%nv(1)+atoms%nlotot+1,nu),1)
......@@ -242,7 +236,7 @@ CONTAINS
q0_11 = q0_11/cell%omtil
q0_22 = q0_22/cell%omtil
ELSE
IF (l_real) THEN
IF (zmat%l_real) THEN
DO nu = 1 , ne
q0=q0+we(nu)*CPP_BLAS_sdot(lapw%nv(jspin),zMat%z_r(1,nu),1,zMat%z_r(1,nu),1)
ENDDO
......@@ -338,7 +332,7 @@ CONTAINS
psir=0.0
psii=0.0
!------> map WF into FFTbox
IF (l_real) THEN
IF (zmat%l_real) THEN
DO iv = 1 , lapw%nv(jspin)
psir( iv1d(iv,jspin) ) = zMat%z_r(iv,nu)
ENDDO
......@@ -365,7 +359,7 @@ CONTAINS
CALL cfft(psi2r,psi2i,ifftq3,stars%kq3_fft,ifftq3,isn)
ELSE
isn = 1
IF (l_real) THEN
IF (zmat%l_real) THEN
CALL rfft(isn,stars%kq1_fft,stars%kq2_fft,stars%kq3_fft+1,stars%kq1_fft,stars%kq2_fft,stars%kq3_fft,&
nw1,nw2,nw3,wsave,psir(ifftq3d), psir(-ifftq2))
......@@ -490,7 +484,7 @@ CONTAINS
ENDDO
ENDIF
ELSE
IF (l_real) THEN
IF (zmat%l_real) THEN
DO in=-1,stars%kq3_fft,2
DO im=0,ifftq2-1
ir = ifftq2 * in + im
......@@ -532,7 +526,7 @@ CONTAINS
CALL cfft(rhomat(0,idens),psi1r,ifftq3,stars%kq3_fft,ifftq3,isn)
ELSE
!---> psir is used here as work array, charge is real ,but fft complex
IF (l_real) THEN
IF (zmat%l_real) THEN
psir(ifftq3d:)=0.0
IF (input%l_f) kpsir(ifftq3d:)=0.0
ELSE
......@@ -543,7 +537,7 @@ CONTAINS
ENDIF
isn = -1
IF (l_real) THEN
IF (zmat%l_real) THEN
CALL rfft(isn,stars%kq1_fft,stars%kq2_fft,stars%kq3_fft+1,stars%kq1_fft,stars%kq2_fft,stars%kq3_fft,&
stars%kq1_fft,stars%kq2_fft,stars%kq3_fft,wsave,psir(ifftq3d), rhon(-ifftq2))
IF (input%l_f) CALL rfft(isn,stars%kq1_fft,stars%kq2_fft,stars%kq3_fft+1,stars%kq1_fft,stars%kq2_fft,stars%kq3_fft,&
......@@ -569,7 +563,7 @@ CONTAINS
cwk(stars%igfft(ik,1))=cwk(stars%igfft(ik,1))+CONJG(stars%pgfft(ik))* CMPLX(rhomat(igq_fft(ik),idens),psi1r(igq_fft(ik)))
ENDDO
ELSE
IF (l_real) THEN
IF (zmat%l_real) THEN
DO ik = 0 , stars%kmxq_fft - 1
cwk(stars%igfft(ik,1))=cwk(stars%igfft(ik,1))+CONJG(stars%pgfft(ik))* CMPLX(rhon(igq_fft(ik)),zero)
ENDDO
......@@ -580,7 +574,7 @@ CONTAINS
ENDIF
!+apw
IF (input%l_f) THEN
IF (l_real) THEN
IF (zmat%l_real) THEN
DO ik = 0 , stars%kmxq_fft - 1
ecwk(stars%igfft(ik,1))=ecwk(stars%igfft(ik,1))+CONJG(stars%pgfft(ik))* CMPLX(ekin(igq_fft(ik)),zero)
ENDDO
......@@ -620,7 +614,7 @@ CONTAINS
IF ( ABS( q0 ) .GT. 1.0e-9) THEN
IF ( ABS( q0 - REAL(cwk(1)) )/q0 .GT. tol_3 ) THEN
WRITE(99,*) "XX:",ne,lapw%nv
IF (l_real) THEN
IF (zmat%l_real) THEN
DO istr=1,SIZE(zMat%z_r,2)
WRITE(99,*) "X:",istr,zMat%z_r(:,istr)
ENDDO
......
......@@ -2,7 +2,7 @@ MODULE m_qintsl
USE m_juDFT
CONTAINS
SUBROUTINE q_int_sl(isp,stars,atoms,sym, volsl,volintsl, cell,&
ne,lapw, nsl,zsl,nmtsl,oneD, qintslk,zMat,realdata)
ne,lapw, nsl,zsl,nmtsl,oneD, qintslk,zMat)
! *******************************************************
! calculate the charge of the En(k) state
! in the interstitial region of each leyer
......@@ -30,7 +30,6 @@ CONTAINS
REAL, INTENT (IN) :: volintsl(atoms%nat)
REAL, INTENT (IN) :: zsl(2,atoms%nat) ,volsl(atoms%nat)
REAL, INTENT (OUT):: qintslk(:,:)!(nsl,dimension%neigd)
LOGICAL,OPTIONAL, INTENT (IN) :: realdata
! ..
! .. Local Scalars ..
REAL q1,zsl1,zsl2,qi,volsli,volintsli
......@@ -40,12 +39,6 @@ CONTAINS
! .. Local Arrays ..
COMPLEX, ALLOCATABLE :: stfunint(:,:),z_z(:)
LOGICAL :: l_real
IF (PRESENT(realdata)) THEN
l_real=realdata
ELSE
l_real=zMat%l_real
ENDIF
! ..
IF (oneD%odi%d1) CALL juDFT_error("well, does not work with 1D. Not clear how to define a layer.",calledby ="q_int_sl")
!
......@@ -76,7 +69,7 @@ CONTAINS
DO n = 1,ne
z_z(:) = CMPLX(0.0,0.0)
q1 = 0.0
IF (l_real) THEN
IF (zmat%l_real) THEN
DO i = 1,lapw%nv(isp)
q1 = q1 + zMat%z_r(i,n)*zMat%z_r(i,n)
ENDDO
......@@ -102,7 +95,7 @@ CONTAINS
IF (ind.EQ.0 .OR. indp.EQ.0) CYCLE
phase = stars%rgphs(ix1,iy1,iz1)/ (stars%nstr(ind)*cell%omtil)
phasep = stars%rgphs(-ix1,-iy1,-iz1)/ (stars%nstr(indp)*cell%omtil)
IF (l_real) THEN
IF (zmat%l_real) THEN
z_z(ind) = z_z(ind) + zMat%z_r(j,n)*zMat%z_r(i,n)*REAL(phase)
z_z(indp) = z_z(indp) + zMat%z_r(i,n)*zMat%z_r(j,n)*REAL(phasep)
ELSE
......
......@@ -12,7 +12,7 @@ CONTAINS
we,ikpt,jspin,vz,vz0,&
ne,bkpt,lapw,&
evac,eig,rhtxy,rht,qvac,qvlay,&
stcoeff,cdomvz,cdomvxy,zMat,realdata)
stcoeff,cdomvz,cdomvxy,zMat)
!***********************************************************************
! ****** change vacden(....,q) for vacuum density of states shz Jan.96
......@@ -86,8 +86,6 @@ CONTAINS
INTEGER, INTENT (IN) :: gvac1(DIMENSION%nv2d),gvac2(DIMENSION%nv2d)
COMPLEX, INTENT (OUT):: stcoeff(vacuum%nstars,DIMENSION%neigd,vacuum%layerd,2)
!
LOGICAL,OPTIONAL,INTENT(IN)::realdata
! local STM variables
INTEGER nv2(DIMENSION%jspd)
INTEGER kvac1(DIMENSION%nv2d,DIMENSION%jspd),kvac2(DIMENSION%nv2d,DIMENSION%jspd),map2(DIMENSION%nvd,DIMENSION%jspd)
......@@ -122,12 +120,6 @@ CONTAINS
REAL, ALLOCATABLE :: u_1(:,:,:,:),ue_1(:,:,:,:)
!+odim
! ..
LOGICAL ::l_real
IF (PRESENT(realdata)) THEN
l_real=realdata
ELSE
l_real=zMat%l_real
ENDIF
! ..
! *******************************************************************************
......@@ -337,7 +329,7 @@ CONTAINS
CMPLX(-dt_1(l,m)*bess(m) +&
t_1(l,m)*stars%sk2(irec2)*dbss(m),0.0)/&
((wronk_1)*SQRT(cell%omtil))
IF (l_real) THEN
IF (zmat%l_real) THEN
ac_1(l,m,:ne,ispin) = ac_1(l,m,:ne,ispin) + zMat%z_r(kspin,:ne)*av_1
bc_1(l,m,:ne,ispin) = bc_1(l,m,:ne,ispin) + zMat%z_r(kspin,:ne)*bv_1
ELSE
......@@ -380,7 +372,7 @@ CONTAINS
av = -c_1 * CMPLX( dte(l),zks*te(l) )
bv = c_1 * CMPLX( dt(l),zks* t(l) )
! -----> loop over basis functions
IF (l_real) THEN
IF (zmat%l_real) THEN
ac(l,:ne,ispin) = ac(l,:ne,ispin) + zMat%z_r(kspin,:ne)*av
bc(l,:ne,ispin) = bc(l,:ne,ispin) + zMat%z_r(kspin,:ne)*bv
ELSE
......@@ -437,7 +429,7 @@ CONTAINS
CMPLX(-dt_1(l,m)*bess(m) +&
t_1(l,m)*stars%sk2(irec2)*dbss(m),0.0)/&
((wronk_1)*SQRT(cell%omtil))
IF (l_real) THEN
IF (zmat%l_real) THEN
ac_1(l,m,:ne,jspin) = ac_1(l,m,:ne,jspin) + zMat%z_r(k,:ne)*av_1
bc_1(l,m,:ne,jspin) = bc_1(l,m,:ne,jspin) + zMat%z_r(k,:ne)*bv_1
ELSE
......@@ -475,7 +467,7 @@ CONTAINS
av = -c_1 * CMPLX( dte(l),zks*te(l) )
bv = c_1 * CMPLX( dt(l),zks* t(l) )
! -----> loop over basis functions
IF (l_real) THEN
IF (zmat%l_real) THEN
ac(l,:ne,jspin) = ac(l,:ne,jspin) + zMat%z_r(k,:ne)*av
bc(l,:ne,jspin) = bc(l,:ne,jspin) + zMat%z_r(k,:ne)*bv
ELSE
......
......@@ -13,7 +13,7 @@ CONTAINS
& con1,phase,ylm,ntyp,na,k,fgp,&
& s,nv,ne,nbasf0,alo1,blo1,clo1,&
& kvec,nkvec,enough,acof,bcof,ccof,&
& acoflo,bcoflo,aveccof,bveccof,cveccof,zMat,realdata)
& acoflo,bcoflo,aveccof,bveccof,cveccof,zMat)
!
!*********************************************************************
! for details see abclocdn; calles by to_pulay
......@@ -49,7 +49,6 @@ CONTAINS
COMPLEX, INTENT (INOUT) :: cveccof(:,-atoms%llod:,:,:,:)!(3,-atoms%llod:llod,nobd,atoms%nlod,atoms%nat)
LOGICAL, INTENT (OUT) :: enough(atoms%nat)
INTEGER, INTENT (INOUT) :: nkvec(atoms%nlod,atoms%nat)
LOGICAL,OPTIONAL,INTENT(IN) ::realdata
! ..
! .. Local Scalars ..
COMPLEX ctmp,term1
......@@ -60,9 +59,6 @@ CONTAINS
! .. Local Arrays ..
COMPLEX clotmp(-atoms%llod:atoms%llod)
! ..
LOGICAL:: l_real
l_real=zMat%l_real
IF (PRESENT(realdata)) l_real=realdata
enough(na) = .TRUE.
term1 = con1* ((atoms%rmt(ntyp)**2)/2)*phase
!
......@@ -96,7 +92,7 @@ CONTAINS
ctmp = clotmp(m)*( ccchi(1)*zMat%z_c(nbasf,ie)+ccchi(2)*zMat%z_c(kspin+nbasf,ie) )
ENDIF
ELSE
IF (l_real) THEN
IF (zmat%l_real) THEN
ctmp = zMat%z_r(nbasf,ie)*clotmp(m)
ELSE
ctmp = zMat%z_c(nbasf,ie)*clotmp(m)
......@@ -144,7 +140,7 @@ CONTAINS
ctmp = clotmp(m)*( ccchi(1)*zMat%z_c(nbasf,ie)+ccchi(2)*zMat%z_c(kspin+nbasf,ie) )
ENDIF
ELSE
IF (l_real) THEN
IF (zmat%l_real) THEN
ctmp = zMat%z_r(nbasf,ie)*clotmp(m)
ELSE
ctmp = zMat%z_c(nbasf,ie)*clotmp(m)
......
MODULE m_abcof
CONTAINS
SUBROUTINE abcof(input,atoms,nobd,sym, cell, bkpt,lapw,ne,usdus,&
noco,jspin,kveclo,oneD, acof,bcof,ccof,zMat,realdata)
noco,jspin,kveclo,oneD, acof,bcof,ccof,zMat)
! ************************************************************
! subroutine constructs the a,b coefficients of the linearized
! m.t. wavefunctions for each band and atom. c.l. fu
......@@ -30,7 +30,6 @@ CONTAINS
INTEGER, INTENT (IN) :: nobd
INTEGER, INTENT (IN) :: ne
INTEGER, INTENT (IN) :: jspin
LOGICAL,OPTIONAL,INTENT(IN)::realdata
! ..
! .. Array Arguments ..
INTEGER, INTENT (IN) :: kveclo(atoms%nlotot)
......@@ -58,14 +57,8 @@ CONTAINS
REAL, ALLOCATABLE :: work_r(:)
COMPLEX, ALLOCATABLE :: work_c(:)
LOGICAL :: l_real
IF (PRESENT(realdata)) THEN
l_real=realdata
ELSE
l_real=zMat%l_real
ENDIF
IF (l_real) THEN
IF (zmat%l_real) THEN
IF (noco%l_soc.AND.sym%invs) CALL judft_error("BUG in abcof, SOC&INVS but real?")
IF (noco%l_noco) CALL judft_error("BUG in abcof, l_noco but real?")
ENDIF
......@@ -127,11 +120,11 @@ CONTAINS
!$OMP& acof_loc,bcof_loc,acof_inv,bcof_inv)&
!$OMP& SHARED(noco,atoms,sym,cell,oneD,lapw,nvmax,ne,zMat,usdus,n,ci,iintsp,&
!$OMP& jspin,bkpt,qss1,qss2,qss3,&
!$OMP& apw,const,natom,l_real,&
!$OMP& apw,const,natom,&
!$OMP& nobd,&
!$OMP& alo1,blo1,clo1,kvec,nbasf0,nkvec,enough,acof,bcof)&
!$OMP& REDUCTION(+:ccof)
IF (l_real) THEN
IF (zmat%l_real) THEN
ALLOCATE ( work_r(nobd) )
ELSE
ALLOCATE ( work_c(nobd) )
......@@ -149,7 +142,7 @@ CONTAINS
!$OMP DO
DO k = 1,nvmax
IF (.NOT.noco%l_noco) THEN
IF (l_real) THEN
IF (zmat%l_real) THEN
work_r(:ne)=zMat%z_r(k,:ne)
ELSE
work_c(:ne)=zMat%z_c(k,:ne)
......@@ -240,7 +233,7 @@ CONTAINS
c_2 = c_0 * dfj(l)
! ----> loop over bands
!$ if (.false.) THEN
IF (l_real) THEN
IF (zmat%l_real) THEN
acof(:ne,lm,natom) = acof(:ne,lm,natom) + c_1 * work_r(:ne)
bcof(:ne,lm,natom) = bcof(:ne,lm,natom) + c_2 * work_r(:ne)
ELSE
......@@ -248,7 +241,7 @@ CONTAINS
bcof(:ne,lm,natom) = bcof(:ne,lm,natom) + c_2 * work_c(:ne)
END IF
!$ endif
!$ if (l_real) THEN
!$ if (zmat%l_real) THEN
!$ acof_loc(:ne,lm) = acof_loc(:ne,lm) + c_1 * work_r(:ne)
!$ bcof_loc(:ne,lm) = bcof_loc(:ne,lm) + c_2 * work_r(:ne)
!$ else
......@@ -294,7 +287,7 @@ CONTAINS
!$ if (noco%l_soc.and.sym%invs) THEN
!$ IF (atoms%invsat(natom).EQ.1) DEALLOCATE(acof_inv,bcof_inv)
!$ endif
IF (l_real) THEN
IF (zmat%l_real) THEN
DEALLOCATE(work_r)
ELSE
DEALLOCATE(work_c)
......
......@@ -18,7 +18,7 @@ MODULE m_sympsi
! Jussi Enkovaara, Juelich 2004
CONTAINS
SUBROUTINE sympsi(bkpt,nv,kx,ky,kz,sym,DIMENSION,ne,cell,eig,noco, ksym,jsym,zMat,l_real)
SUBROUTINE sympsi(bkpt,nv,kx,ky,kz,sym,DIMENSION,ne,cell,eig,noco, ksym,jsym,zMat)
USE m_grp_k
USE m_inv3
......@@ -39,7 +39,6 @@ CONTAINS
REAL, INTENT (IN) :: bkpt(3),eig(DIMENSION%neigd)
INTEGER, INTENT (OUT):: jsym(DIMENSION%neigd),ksym(DIMENSION%neigd)
LOGICAL,INTENT(IN) :: l_real
! ..
! .. Local Scalars ..
REAL degthre
......@@ -129,7 +128,7 @@ CONTAINS
norm(i)=norm(i)+ABS(zMat%z_c(k,i))**2
ENDDO
ELSE
IF (l_real) THEN
IF (zmat%l_real) THEN
DO k=1,nv
norm(i)=norm(i)+ABS(zMat%z_r(k,i))**2
ENDDO
......@@ -161,7 +160,7 @@ CONTAINS
DO c=1,nclass
DO n1=1,ndeg
DO n2=1,ndeg
IF (l_real) THEN
IF (zmat%l_real) THEN
DO k=1,nv
csum(n1,n2,c)=csum(n1,n2,c)+zMat%z_r(k,deg(n1))*&
zMat%z_r(gmap(k,c),deg(n2))/(norm(deg(n1))*norm(deg(n2)))
......@@ -221,7 +220,7 @@ CONTAINS
WRITE(444,124) bkpt
WRITE(444,*) 'Group is ' ,grpname
DO c=1,nirr
IF (l_real)THEN
IF (zmat%l_real)THEN
IF (ANY(ABS(char_table).GT.0.001)) THEN
WRITE(444,123) c,irrname(c),(char_table(c,n),n=1,nclass)
ELSE
......
......@@ -552,17 +552,10 @@ CONTAINS
zMat%z_c(:lapw%nmat,:ne_found) = cmplx(0.0,0.0)
ENDIF
endif
if (l_real) THEN
CALL write_eig(eig_id, nk,jsp,ne_found,ne_all,lapw%nv(jsp),lapw%nmat,&
CALL write_eig(eig_id, nk,jsp,ne_found,ne_all,lapw%nv(jsp),lapw%nmat,&
lapw%k1(:lapw%nv(jsp),jsp),lapw%k2 (:lapw%nv(jsp),jsp),lapw%k3(:lapw%nv(jsp),jsp),&
bkpt, kpts%wtkpt(nk),eig(:ne_found),enpara%el0(0:,:,jsp), enpara%ello0(:,:,jsp),enpara%evac0(:,jsp),&
atoms%nlotot,kveclo,mpi%n_size,mpi%n_rank,z=zMat%z_r(:,:ne_found))
else
CALL write_eig(eig_id, nk,jsp,ne_found,ne_all,lapw%nv(jsp),lapw%nmat,&
lapw%k1(:lapw%nv(jsp),jsp),lapw%k2 (:lapw%nv(jsp),jsp),lapw%k3(:lapw%nv(jsp),jsp),&
bkpt, kpts%wtkpt(nk),eig(:ne_found),enpara%el0(0:,:,jsp), enpara%ello0(:,:,jsp),enpara%evac0(:,jsp),&
atoms%nlotot,kveclo,mpi%n_size,mpi%n_rank,z=zMat%z_c(:,:ne_found))
endif
atoms%nlotot,kveclo,mpi%n_size,mpi%n_rank,zMat)
IF (noco%l_noco) THEN
CALL write_eig(eig_id, nk,2,ne_found,ne_all,lapw%nv(2),lapw%nmat,&
lapw%k1(:lapw%nv(2),2),lapw%k2 (:lapw%nv(2),2),lapw%k3(:lapw%nv(2),2),&
......
......@@ -82,16 +82,12 @@ CONTAINS
lhelp= MAX(lapw%nmat,(DIMENSION%neigd+2)*DIMENSION%neigd)
#ifdef __PGI
STOP "CODE NOT WORKING WITH PGI"
#else
CALL read_eig(eig_id,nk,jsp,bk=bkpt,neig=ne,nv=lapw%nv(jsp),nmat=lapw%nmat, eig=eig,kveclo=kveclo,zmat=zmat)
IF (l_real) THEN
CALL read_eig(eig_id,nk,jsp,bk=bkpt,neig=ne,nv=lapw%nv(jsp),nmat=lapw%nmat, eig=eig,kveclo=kveclo,z=zMat%z_r)
ALLOCATE ( h_r(DIMENSION%neigd,DIMENSION%neigd),s_r(DIMENSION%neigd,DIMENSION%neigd) )
h_r = 0.0 ; s_r=0.0
ALLOCATE ( help_r(lhelp) )
ELSE
CALL read_eig(eig_id,nk,jsp,bk=bkpt,neig=ne,nv=lapw%nv(jsp),nmat=lapw%nmat, eig=eig,kveclo=kveclo,z=zMat%z_c)
! in outeig z is complex conjugated to make it usable for abcof. Here we
! first have to undo this complex conjugation for the
! multiplication with a and b matrices.
......@@ -101,7 +97,6 @@ CONTAINS
h_c = 0.0 ; s_c=0.0
ALLOCATE ( help_r(lhelp) )
ENDIF
#endif
!
DO i = 1,ne
IF (l_real) THEN
......
......@@ -73,10 +73,8 @@ CONTAINS
COMPLEX,ALLOCATABLE :: zhelp1(:,:),zhelp2(:,:)
COMPLEX,ALLOCATABLE :: hso(:,:),hsomtx(:,:,:,:)
COMPLEX,ALLOCATABLE :: sigma_xc_apw(:,:),sigma_xc(:,:)
REAL, ALLOCATABLE :: z_r(:,:,:)
COMPLEX,ALLOCATABLE :: z_c(:,:,:)
TYPE(t_zMAT)::zmat(dimension%jspd)
! ..
! .. External Subroutines ..
EXTERNAL CPP_LAPACK_cheev
......@@ -90,17 +88,26 @@ CONTAINS
!