C^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 5/1, 2009
SUBROUTINE DIAGON(IREC8)
C^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
IMPLICIT REAL(A-H,O-Y)
IMPLICIT COMPLEX(Z)
INCLUDE 'PACVPP'
PARAMETER(KNMT=KNG11*(KNG11+1)/2,KNM9=9*KNG11)
C!$OMP THREADPRIVATE( /PSSNL/, /ZAJEKO/ )
!$OMP THREADPRIVATE( /PSSNL/ )
!XOCL SUBPROCESSOR PS(IPARA)=PQ(1:IPARA)
!XOCL INDEX PARTITION IP=(PS,INDEX=1:KNV3,PART=BAND)
DIMENSION ZZ2(KNG1,KEG,KNV3),EKK(KEG,KNV3)
C DIMENSION SSS(KNG1,KNV3,KTYP,10),OCCUU(KEG,KNV3)
!XOCL LOCAL ZZ2(:,:,/IP),SSS(:,/IP,:,:)
!XOCL LOCAL EKK(:,/IP),OCCUU(:,/IP)
C EQUIVALENCE (ZAJ,ZZ2),(SNL,SSS),(EKO,EKK)
C & ,(OCCUP,OCCUU)
C EIGEN-VALUE PROBLEM
DIMENSION ZAAA(KNMT)
& ,WORK-PART(---),ZAWORK(KNG1)
& ,IFLG(KEG)
& ,ZVN(KNG11,KEG),ZZZ(KNG11,KNG11),EG(KEG)
C & ,EVR(KNG11,KEG),EVI(KNG11,KEG),EG(KEG)
C & ,WK1(KNG11,6),WK2(8*KEG),ZWK3(KNG11,2),IWK(6*KEG+KNG11)
C & ,IFLG(KEG)
C & ,WWW(3*KNG11),ZWW(5*KNG11),ZAWORK(KNG1)
C & ,WOK(KNM9),CCC(KNG11,KNG11)
C
DIMENSION PPM(KNG11),IJG(KNG11)
C
IF (KNG1.NE.KNG11) THEN
WRITE (6,*) 'WORNING] KNG1 IS NOT EQUAL TO KNG11'
END IF
C
DO 4 I=1,KG
ZCHGO(I) = ZCHG(I)
ZCHG(I) = DCMPLX(0.0D0,0.0D0)
4 CONTINUE
C ////////////////////////////
C // DIAGONALIZE AT K-POINT //
C ////////////////////////////
C VPP-PARALLEL START DIAGON
C!XOCL PARALLEL REGION
!XOCL SPREAD NOBARRIER DO /IP
C
!$OMP PARALLEL DEFAULT(NONE)
!$OMP& COPYIN( SNL )
C!$OMP& FIRSTPRIVATE( )
!$OMP& PRIVATE( CS,CP,CD, I1,I2, L1,L2,L3, MM, IIBA, IIKB,
!$OMP& AKX,AKY,AKZ, LNUM,NNN, II, PPMT,
!$OMP& ZVN, ZZZ, ZAAA, PPM, IJG, EG,
!$OMP& ZAWORK,WORK-PART,ICON, KBAS,KGB,IOPT,EPS )
!$OMP& SHARED( KV3, WS,WP,WD, PAI4, GR, IG1,IG2,IG3, IGPO,
!$OMP& VX,VY,VZ,IBA,IBA2,NBASE,NBMAT,NBD1,NBD2,
!$OMP& ZCHGO, ZVXC, ZPSCC, ZFM3, ZZ2,EKK,
!$OMP& UNIVOL, KX1,KY1,KZ1, GX,GY,GZ, NLSPD )
!$OMP DO
DO 100 NNN=1,KNV3
C IWRT(NNN) =NNN
WRITE (6,*) 'CHECK POINT 1 IN DIAGON, NNN =',NNN,PAI4
C WRITE (6,*) 'CHECK POINT 11,KNG11,KNV3,KEG=',KNG11,KNV3,KEG
AKX = VX(NNN)
AKY = VY(NNN)
AKZ = VZ(NNN)
IIKB = IBA(NNN)
IIBA = IBA2(NNN)
C PSEUDOPOTENTIAL NON-LOCAL PART MATRIX ELEMENT
DO 71 I=1,KNG11*(KNG11+1)/2
ZAAA(I)=DCMPLX(0.0D0,0.0D0)
71 CONTINUE
DO 272 I=1,KNG11
DO 274 K=1,KEG
C EVR(I,K)=0.0D0
C EVI(I,K)=0.0D0
ZVN(I,K)=CMPLX(0.0,0.0)
274 CONTINUE
DO 273 J=1,KNG11
C CCC(J,I)=0.0D0
ZZZ(J,I)=CMPLX(0.0,0.0)
273 CONTINUE
272 CONTINUE
C
DO 6 IT=1,KTYP
CS=1.0D0/(WS(IT)*UNIVOL)
CP=1.0D0/(WP(IT)*UNIVOL)
CWL(1)=CS
CWL(2)=CP
CWL(3)=CP
CWL(4)=CP
IF (NLSPD(IT).EQ.2) THEN
CD=1.0D0/(WD(IT)*UNIVOL)
CWL(5)=CD
CWL(6)=CD
CWL(7)=CD
CWL(8)=CD
CWL(9)=CD
END IF
IF (NLSPD(IT).EQ.1) THEN
LNUM = 4
ELSE
LNUM = 9
END IF
DO 5 I=1,IIBA
I1 = NBMAT(I,NNN)
L1=IG1(I1)+KX1
L2=IG2(I1)+KY1
L3=IG3(I1)+KZ1
II=I*(I-1)/2
DO 8700 L=1,LNUM
DO 7600 J =1,I
PPMT = CWL(L)*SNL(I,NNN,IT,L)*SNL(J,NNN,IT,L)
ZAAA(II+J) = ZAAA(II+J) + PPMT *
& ZFM3( IGPO( L1-IG1(NBMAT(J,NNN)),
& L2-IG2(NBMAT(J,NNN)),
& L3-IG3(NBMAT(J,NNN)) ) ,IT)
7600 CONTINUE
8700 CONTINUE
5 CONTINUE
6 CONTINUE
C MATRIX ELEMENT AND KINETIC ENERGY
DO 230 I=1,IIBA
PPM(I) = ( (AKX+GX(NBMAT(I,NNN)))**2
& + (AKY+GY(NBMAT(I,NNN)))**2
& + (AKZ+GZ(NBMAT(I,NNN)))**2 )/2.D0
230 CONTINUE
DO 222 I=1,IIBA
I1=NBMAT(I,NNN)
I2=I*(I-1)/2
L1=IG1(I1)+KX1
L2=IG2(I1)+KY1
L3=IG3(I1)+KZ1
ZAAA(I*(I+1)/2) = ZAAA(I*(I+1)/2) + PPM(I)
DO 222 J=1,I
C HARTREE, EXCHANGE AND CORE POTENTIAL
IJG(J) = ( IGPO( L1-IG1(NBMAT(J,NNN)), L2-IG2(NBMAT(J,NNN)),
& L3-IG3(NBMAT(J,NNN)) ) )
IF(IJG(J).NE.1) THEN
ZAAA(I2+J) = ZAAA(I2+J) + PAI4*ZCHGO(IJG(J))/GR(IJG(J))**2
END IF
ZAAA(I2+J) = ZAAA(I2+J) + ZVXC(IJG(J)) + ZPSCC(IJG(J))
222 CONTINUE
C=====DIAGONALIZATION SSL2
DO 7701 I=1,IIBA
MM = I*(I-1)/2
DO 7702 J=1,I
ZZZ(I,J)=ZAAA(MM+J)
IF (I.NE.J) ZZZ(J,I)=CONJG(ZZZ(I,J))
C RMAT = DREAL(ZAAA(MM+J))
C CMAT = DIMAG(ZAAA(MM+J))
C CCC(I,J) = RMAT
C IF (I.NE.J) CCC(J,I) = CMAT
7702 CONTINUE
7701 CONTINUE
C""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
KBAS = KNG11
KGB = KEG
IOPT = 2
EPS = 1.0D-15
C CALL HZES1M(ZAAA,IIBA,KGB,KGB,EPS,IOPT,EG,EVR,KBAS,EVI,IFLG
C & ,WK1,WK2,ZWK3,IWK,ICON)
C WRITE(6,*) KBAS,IIBA,KGB
C CALL CHOBSD(ZZZ,KBAS,IIBA,EG,-KGB,ZVN,KGB,EPS,WWW,ZWW,ICON)
C CALL DHEIG2(CCC,KBAS,IIBA,-KGB,EG,EVR,EVI,WOK,ICON)
CALL DIAGONAL(ZZZ,KBAS,IIBA,KGB,EG,ZVN,WORK-PART,ICON)
C""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
IF(ICON.NE.0) THEN
WRITE(6,*) '*****!! AT HZES1M, ICON=',ICON
END IF
C
DO 7164 M=1,KEG
EKK(M,NNN)=EG(M)
C WRITE(6,*) 'NNN = ',NNN,'IBAN = ',M
C WRITE(6,*) 'ENERGY = ',EKO(M,NNN)
7164 CONTINUE
C OUTPUT EIGENVECTORS ON FILE 80 (DIRECT-ACCESS) (KNG11 <---> IIBA)
C WRITE(6,*) 'ZAJ = '
DO 231 IBAN = NBD1,NBD2
DO 33 J=1,IIBA
C ZAJ(J,IBAN,NNN) = EVR(J,IBAN) + ZI*EVI(J,IBAN)
ZZ2(J,IBAN,NNN) = ZVN(J,IBAN)
C*********ZV1(J) = EVR(J,IBAN) + ZI*EVI(J,IBAN)
33 CONTINUE
DO 97 M=1,IIKB
ZAWORK(M)=0.D0
97 CONTINUE
DO 91 J=1,IIBA
DO 92 M=1,IIKB
IF (NBASE(M,NNN) .EQ. NBMAT(J,NNN)) THEN
ZAWORK(M)=ZZ2(J,IBAN,NNN)
ENDIF
92 CONTINUE
91 CONTINUE
DO 93 M=1,IIKB
ZZ2(M,IBAN,NNN)=ZAWORK(M)
93 CONTINUE
C**************DO 34 J=IIBA+1,KNG1
C ZV1(J) = DCMPLX(0.0D0,0.0D0)
C 34 CONTINUE
C IREC = KV3*(IBAN-1)+IWRT(NNN)
C IF (IREC8.NE.0) IREC=IREC8*IREC-IREC8+1
C**************WRITE(80,REC=IREC) ZV1
231 CONTINUE
100 CONTINUE
!$OMP END DO
!$OMP END PARALLEL
!XOCL END SPREAD
C!XOCL END PARALLEL
C
DO 3511 NNN = 1,KV3
DO 3512 IBAN = NBD1,NBD2
EKO(IBAN,NNN) = EKK(IBAN,NNN)
DO 3513 I= 1,IBA(NNN)
ZAJ(I,IBAN,NNN) = ZZ2(I,IBAN,NNN)
3513 CONTINUE
3512 CONTINUE
3511 CONTINUE
C
RETURN
END