C^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
SUBROUTINE STRESS(IPCC,SCHGPC,ETOT1,TOTCH,EPC,PCM
& ,KOPR,NBZTYP)
C^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
IMPLICIT REAL(A-H,O-Y)
IMPLICIT COMPLEX(Z)
INCLUDE 'PACVPP'
C VPP-PARALLEL
!XOCL SUBPROCESSOR PS(IPARA)=PQ(1:IPARA)
!XOCL INDEX PARTITION IP=(PS,INDEX=1:KNV3,PART=BAND)
DIMENSION ZZZ(KNG1,KEG,KNV3),OCCUU(KEG,KNV3)
!XOCL LOCAL ZZZ(:,:,/IP),OCCUU(:,/IP)
EQUIVALENCE (ZAJ,ZZZ),(OCCUP,OCCUU)
DIMENSION OO(3,3,KO)
!XOCL INDEX PARTITION IQ=(PS,INDEX=1:KO,PART=BAND)
!XOCL LOCAL OO(:,:,/IQ)
EQUIVALENCE (OP,OO)
C
DIMENSION SSS(3,3),TTT(3,3)
C STRESS CALCULATION FOR KINETIC, HARTREE, EX-COR, LOCAL AND ETOT1
CCC =2.D0*RVOL/(2.D0*PAI)**3/FLOAT(KV3)
DO 1000 IS=1,6
SIGSTR(IS)=0.0D0
1000 CONTINUE
RGG(1)=0.0D0
ZXXX(1)=DCMPLX(0.0D0,0.0D0)
ZYYY(1)=DCMPLX(0.0D0,0.0D0)
ZZZZ(1)=DCMPLX(0.0D0,0.0D0)
DO 1001 I=2,KG
ZXXX(I)=DCMPLX(0.0D0,0.0D0)
ZYYY(I)=DCMPLX(0.0D0,0.0D0)
ZZZZ(I)=DCMPLX(0.0D0,0.0D0)
RGG(I)=1.0D0/(GR(I)*GR(I))
1001 CONTINUE
C KINETIC PART
C VPP-PARALLEL START
C!XOCL PARALLEL REGION
!XOCL SPREAD DO /IP
DO 1100 IK=1,KV3
C IWRT(IK) =IK
AKX = VX(IK)
AKY = VY(IK)
AKZ = VZ(IK)
DO 1110 IBAN=NBD1,NBD2
CW=CCC*OCCUU(IBAN,IK)
DO 1120 I=1,IBA(IK)
I1 = NBASE(I,IK)
STMP=CW*DCONJG(ZZZ(I,IBAN,IK))*ZZZ(I,IBAN,IK)
SIGSTR(1)=SIGSTR(1)-STMP*(AKX+GX(I1))*(AKX+GX(I1))
SIGSTR(2)=SIGSTR(2)-STMP*(AKX+GX(I1))*(AKY+GY(I1))
SIGSTR(3)=SIGSTR(3)-STMP*(AKX+GX(I1))*(AKZ+GZ(I1))
SIGSTR(4)=SIGSTR(4)-STMP*(AKY+GY(I1))*(AKY+GY(I1))
SIGSTR(5)=SIGSTR(5)-STMP*(AKY+GY(I1))*(AKZ+GZ(I1))
SIGSTR(6)=SIGSTR(6)-STMP*(AKZ+GZ(I1))*(AKZ+GZ(I1))
1120 CONTINUE
1110 CONTINUE
1100 CONTINUE
!XOCL END SPREAD SUM(SIGSTR)
C!XOCL END PARALLEL
SSS1=SIGSTR(1)
SSS2=SIGSTR(2)
SSS3=SIGSTR(3)
SSS4=SIGSTR(4)
SSS5=SIGSTR(5)
SSS6=SIGSTR(6)
WRITE (6,*) 'TOTAL STR 1 1 = ',SIGSTR(1)
WRITE (6,*) ' 2 = ',SIGSTR(2)
WRITE (6,*) ' 3 = ',SIGSTR(3)
WRITE (6,*) ' 4 = ',SIGSTR(4)
WRITE (6,*) ' 5 = ',SIGSTR(5)
WRITE (6,*) ' 6 = ',SIGSTR(6)
C HARTREE PART I=1 -----> GR(1)=0.0D0 : RGG(1)=INFINITE
C EXCHANGE-CORRELATION + LOCAL PS PARTS
DO 1250 I=1,KG
ZVP(I)=ZVXC(I)
1250 CONTINUE
CALL XCFFT(1,SCHGPC)
CALL XCFFT(2,SCHGPC)
IF (IPCC.EQ.1) CALL XSTPC(1,SCHGPC)
STMQ=DCONJG(ZEXC(1))*(ZCHG(1)+ZRHPC(1))-DCONJG(ZVXC(1))*ZCHG(1)
& -DCONJG(ZVXC(1))*ZRHPC(1)
SS1=-DCONJG(ZEXC(1))*ZRRPC(1)
SSX=-DCONJG(ZXXX(1))*(ZCHG(1)+ZRHPC(1))
SSY=-DCONJG(ZYYY(1))*(ZCHG(1)+ZRHPC(1))
SSZ=-DCONJG(ZZZZ(1))*(ZCHG(1)+ZRHPC(1))
SIGSTR(1)=SIGSTR(1)+STMQ+SS1*GX(1)*GX(1)+SSX
SIGSTR(4)=SIGSTR(4)+STMQ+SS1*GY(1)*GY(1)+SSY
SIGSTR(6)=SIGSTR(6)+STMQ+SS1*GZ(1)*GZ(I)+SSZ
TTT1=SIGSTR(1)-SSS1
TTT2=SIGSTR(2)-SSS2
TTT3=SIGSTR(3)-SSS3
TTT4=SIGSTR(4)-SSS4
TTT5=SIGSTR(5)-SSS5
TTT6=SIGSTR(6)-SSS6
SSS1=SIGSTR(1)
SSS2=SIGSTR(2)
SSS3=SIGSTR(3)
SSS4=SIGSTR(4)
SSS5=SIGSTR(5)
SSS6=SIGSTR(6)
WRITE (6,*) 'TOTAL STR 2 1 = ',TTT1
WRITE (6,*) ' 2 = ',TTT2
WRITE (6,*) ' 3 = ',TTT3
WRITE (6,*) ' 4 = ',TTT4
WRITE (6,*) ' 5 = ',TTT5
WRITE (6,*) ' 6 = ',TTT6
STX=0.0D0
STY=0.0D0
STZ=0.0D0
STT=0.0D0
STU=0.0D0
STV=0.0D0
STW=0.0D0
DO 1200 I=2,KG
STMP=0.5D0*PAI4*DCONJG(ZCHG(I))*ZCHG(I)*RGG(I)
STMQ=DCONJG(ZEXC(I))*(ZCHG(I)+ZRHPC(I))-DCONJG(ZVXC(I))*ZCHG(I)
& -DCONJG(ZVXC(I))*ZRHPC(I)
STM1= DCONJG(ZEXC(I))*ZRRPC(I)
STMX= DCONJG(ZXXX(I))*(ZCHG(I)+ZRHPC(I))
STMY= DCONJG(ZYYY(I))*(ZCHG(I)+ZRHPC(I))
STMZ= DCONJG(ZZZZ(I))*(ZCHG(I)+ZRHPC(I))
C STX=STX+DREAL(DCONJG(ZVXC(I))*ZRRPC(I))*GX(I)*GX(I)
C STY=STY+DREAL(DCONJG(ZEXC(I))*ZRRPC(I))*GX(I)*GX(I)
C STZ=STZ+STMX
C STT=STT+STMY
STX=STX+STMP*(2.0D0*GX(I)*GX(I)*RGG(I)-1.0D0)+STMQ
& -STMS*2.0D0*GX(I)*GX(I)-STMR-STM1*GX(I)*GX(I)-STMX
STY=STY+STMP*(2.0D0*GX(I)*GX(I)*RGG(I)-1.0D0)
STZ=STZ+STMQ
STT=STT-STMS*2.0D0*GX(I)*GX(I)
STU=STU-STMR
STV=STV-STM1*GX(I)*GX(I)
STW=STW-STMX
STMR=ZPSCC(I)*DCONJG(ZCHG(I))
STMS=ZDSCC(I)*DCONJG(ZCHG(I))
SIGSTR(1)=SIGSTR(1)+STMP*(2.0D0*GX(I)*GX(I)*RGG(I)-1.0D0)+STMQ
& -STMS*2.0D0*GX(I)*GX(I)-STMR-STM1*GX(I)*GX(I)-STMX
SIGSTR(2)=SIGSTR(2)+STMP*(2.0D0*GX(I)*GY(I)*RGG(I))
& -STMS*2.0D0*GX(I)*GY(I)
SIGSTR(3)=SIGSTR(3)+STMP*(2.0D0*GX(I)*GZ(I)*RGG(I))
& -STMS*2.0D0*GX(I)*GZ(I)
SIGSTR(4)=SIGSTR(4)+STMP*(2.0D0*GY(I)*GY(I)*RGG(I)-1.0D0)+STMQ
& -STMS*2.0D0*GY(I)*GY(I)-STMR-STM1*GY(I)*GY(I)-STMY
SIGSTR(5)=SIGSTR(5)+STMP*(2.0D0*GY(I)*GZ(I)*RGG(I))
& -STMS*2.0D0*GY(I)*GZ(I)
SIGSTR(6)=SIGSTR(6)+STMP*(2.0D0*GZ(I)*GZ(I)*RGG(I)-1.0D0)+STMQ
& -STMS*2.0D0*GZ(I)*GZ(I)-STMR-STM1*GZ(I)*GZ(I)-STMZ
1200 CONTINUE
WRITE (6,*) 'ZVX,ZEX = ',STX,STY
WRITE (6,*) 'STM1(XY)= ',STZ,STT
WRITE (6,*) 'STU,V,W = ',STU,STV,STW
STOT=STY+STZ+STT+STU+STV+STW
WRITE (6,*) 'STOT = ',STOT
TTT1=SIGSTR(1)-SSS1
TTT2=SIGSTR(2)-SSS2
TTT3=SIGSTR(3)-SSS3
TTT4=SIGSTR(4)-SSS4
TTT5=SIGSTR(5)-SSS5
TTT6=SIGSTR(6)-SSS6
SSS1=SIGSTR(1)
SSS2=SIGSTR(2)
SSS3=SIGSTR(3)
SSS4=SIGSTR(4)
SSS5=SIGSTR(5)
SSS6=SIGSTR(6)
WRITE (6,*) 'TOTAL STR 3 1 = ',TTT1
WRITE (6,*) ' 2 = ',TTT2
WRITE (6,*) ' 3 = ',TTT3
WRITE (6,*) ' 4 = ',TTT4
WRITE (6,*) ' 5 = ',TTT5
WRITE (6,*) ' 6 = ',TTT6
DO 1251 I=1,KNG
ZVXC(I)=ZVP(I)
1251 CONTINUE
C CALL NON-LOCAL PART SUBROUTINE
CALL STRNL(ETOT1)
C NON-LOCAL PS AND EWALD PARTS
DO 1400 IS=1,6
SIGSTR(IS)=SIGSTR(IS)+SIGNL(IS)+SIGEWA(IS)
1400 CONTINUE
WRITE (6,*) 'SIGEWA 1 = ',SIGEWA(1)
WRITE (6,*) 'SIGEWA 2 = ',SIGEWA(2)
WRITE (6,*) 'SIGEWA 3 = ',SIGEWA(3)
WRITE (6,*) 'SIGEWA 4 = ',SIGEWA(4)
WRITE (6,*) 'SIGEWA 5 = ',SIGEWA(5)
WRITE (6,*) 'SIGEWA 6 = ',SIGEWA(6)
WRITE (6,*) 'SIGNL 1 = ',SIGNL(1)
WRITE (6,*) 'SIGNL 2 = ',SIGNL(2)
WRITE (6,*) 'SIGNL 3 = ',SIGNL(3)
WRITE (6,*) 'SIGNL 4 = ',SIGNL(4)
WRITE (6,*) 'SIGNL 5 = ',SIGNL(5)
WRITE (6,*) 'SIGNL 6 = ',SIGNL(6)
TTT1=SIGSTR(1)-SSS1
TTT2=SIGSTR(2)-SSS2
TTT3=SIGSTR(3)-SSS3
TTT4=SIGSTR(4)-SSS4
TTT5=SIGSTR(5)-SSS5
TTT6=SIGSTR(6)-SSS6
SSS1=SIGSTR(1)
SSS2=SIGSTR(2)
SSS3=SIGSTR(3)
SSS4=SIGSTR(4)
SSS5=SIGSTR(5)
SSS6=SIGSTR(6)
WRITE (6,*) 'TOTAL STR 4 1 = ',TTT1
WRITE (6,*) ' 2 = ',TTT2
WRITE (6,*) ' 3 = ',TTT3
WRITE (6,*) ' 4 = ',TTT4
WRITE (6,*) ' 5 = ',TTT5
WRITE (6,*) ' 6 = ',TTT6
SIGSTR(1)=SIGSTR(1)-ETOT1*TOTCH/UNIVOL
SIGSTR(4)=SIGSTR(4)-ETOT1*TOTCH/UNIVOL
SIGSTR(6)=SIGSTR(6)-ETOT1*TOTCH/UNIVOL
TTT1=SIGSTR(1)-SSS1
TTT2=SIGSTR(2)-SSS2
TTT3=SIGSTR(3)-SSS3
TTT4=SIGSTR(4)-SSS4
TTT5=SIGSTR(5)-SSS5
TTT6=SIGSTR(6)-SSS6
SSS1=SIGSTR(1)
SSS2=SIGSTR(2)
SSS3=SIGSTR(3)
SSS4=SIGSTR(4)
SSS5=SIGSTR(5)
SSS6=SIGSTR(6)
WRITE (6,*) 'TOTAL STR 5 1 = ',TTT1
WRITE (6,*) ' 2 = ',TTT2
WRITE (6,*) ' 3 = ',TTT3
WRITE (6,*) ' 4 = ',TTT4
WRITE (6,*) ' 5 = ',TTT5
WRITE (6,*) ' 6 = ',TTT6
WRITE (6,*) 'TOTAL SUMM 1 = ',SSS1
WRITE (6,*) ' 2 = ',SSS2
WRITE (6,*) ' 3 = ',SSS3
WRITE (6,*) ' 4 = ',SSS4
WRITE (6,*) ' 5 = ',SSS5
WRITE (6,*) ' 6 = ',SSS6
IF (NBZTYP.LE.1) GO TO 9000
DENOM = 1.0D0/FLOAT(KOPR)
SSS(1,1)=SIGSTR(1)
SSS(2,2)=SIGSTR(4)
SSS(3,3)=SIGSTR(6)
SSS(1,2)=SIGSTR(2)
SSS(1,3)=SIGSTR(3)
SSS(2,3)=SIGSTR(5)
SSS(2,1)=SSS(1,2)
SSS(3,1)=SSS(1,3)
SSS(3,2)=SSS(2,3)
DO 1210 I=1,3
DO 1220 J=1,3
TTT(I,J)=0.0D0
1220 CONTINUE
1210 CONTINUE
!XOCL SPREAD DO /IQ
DO 2400 IOP = 1,KOPR
DO 2200 I=1,3
DO 2300 J=1,3
SXX=SSS(1,1)
SXY=SSS(1,2)
SXZ=SSS(1,3)
SYY=SSS(2,2)
SYZ=SSS(2,3)
SZZ=SSS(3,3)
TXX=OO(1,I,IOP)*SSS(I,J)*OO(1,J,IOP)
TXY=OO(1,I,IOP)*SSS(I,J)*OO(2,J,IOP)
TXZ=OO(1,I,IOP)*SSS(I,J)*OO(3,J,IOP)
TYY=OO(2,I,IOP)*SSS(I,J)*OO(2,J,IOP)
TYZ=OO(2,I,IOP)*SSS(I,J)*OO(3,J,IOP)
TZZ=OO(3,I,IOP)*SSS(I,J)*OO(3,J,IOP)
TTT(1,1)=TTT(1,1) + OO(1,I,IOP)*SSS(I,J)*OO(1,J,IOP)
TTT(1,2)=TTT(1,2) + OO(1,I,IOP)*SSS(I,J)*OO(2,J,IOP)
TTT(1,3)=TTT(1,3) + OO(1,I,IOP)*SSS(I,J)*OO(3,J,IOP)
TTT(2,2)=TTT(2,2) + OO(2,I,IOP)*SSS(I,J)*OO(2,J,IOP)
TTT(2,3)=TTT(2,3) + OO(2,I,IOP)*SSS(I,J)*OO(3,J,IOP)
TTT(3,3)=TTT(3,3) + OO(3,I,IOP)*SSS(I,J)*OO(3,J,IOP)
2300 CONTINUE
2200 CONTINUE
2400 CONTINUE
!XOCL END SPREAD SUM(TTT)
SIGSTR(1)=TTT(1,1)*DENOM
SIGSTR(2)=TTT(1,2)*DENOM
SIGSTR(3)=TTT(1,3)*DENOM
SIGSTR(4)=TTT(2,2)*DENOM
SIGSTR(5)=TTT(2,3)*DENOM
SIGSTR(6)=TTT(3,3)*DENOM
SSS1=SIGSTR(1)
SSS2=SIGSTR(2)
SSS3=SIGSTR(3)
SSS4=SIGSTR(4)
SSS5=SIGSTR(5)
SSS6=SIGSTR(6)
WRITE (6,*) 'TOTAL SUMM OP1 = ',SSS1
WRITE (6,*) ' 2 = ',SSS2
WRITE (6,*) ' 3 = ',SSS3
WRITE (6,*) ' 4 = ',SSS4
WRITE (6,*) ' 5 = ',SSS5
WRITE (6,*) ' 6 = ',SSS6
9000 CONTINUE
RETURN
END