C^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ SUBROUTINE DIAGON(IREC8) C^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ IMPLICIT REAL(A-H,O-Y) IMPLICIT COMPLEX(Z) INCLUDE 'PACVPP' PARAMETER(KNMT=KNG11*(KNG11+1)/2,KNM9=9*KNG11) !XOCL SUBPROCESSOR PS(IPARA)=PQ(1:IPARA) !XOCL INDEX PARTITION IP=(PS,INDEX=1:KNV3,PART=BAND) DIMENSION ZZ2(KNG1,KEG,KNV3),SSS(KNG1,KNV3,KTYP,10) DIMENSION EKK(KEG,KNV3),OCCUU(KEG,KNV3) !XOCL LOCAL ZZ2(:,:,/IP),SSS(:,/IP,:,:) !XOCL LOCAL EKK(:,/IP),OCCUU(:,/IP) EQUIVALENCE (ZAJ,ZZ2),(SNL,SSS),(EKO,EKK) & ,(OCCUP,OCCUU) C EIGEN-VALUE PROBLEM DIMENSION ZAAA(KNMT) & ,WWW(3*KNG11),ZWW(5*KNG11),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 & ,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 C!XOCL PARALLEL REGION !XOCL SPREAD DO /IP DO 100 NNN=1,KNV3 C IWRT(NNN) =NNN 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)*SSS(I,NNN,IT,L)*SSS(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 DHEIG2(CCC,KBAS,IIBA,-KGB,EG,EVR,EVI,WOK,ICON) CALL CHOBSD(ZZZ,KBAS,IIBA,EG,-KGB,ZVN,KGB,EPS,WWW,ZWW,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 = ',EKK(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 !XOCL END SPREAD C!XOCL END PARALLEL RETURN END