C^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
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 SSS(KNG1,KNV3,KTYP,10)
& ,ZZZ(KNG1,KEG,KNV3),ZFC(KEG,KNV3,KATM,10)
& ,OCCUU(KEG,KNV3)
!XOCL LOCAL SSS(:,/IP,:,:),ZZZ(:,:,/IP),ZFC(:,/IP,:,:)
!XOCL LOCAL OCCUU(:,/IP)
EQUIVALENCE (SNL,SSS),(ZAJ,ZZZ),(ZFBB,ZFC)
& ,(OCCUP,OCCUU)
DIMENSION ZFX1(KEG),ZFX2(KEG),ZFX3(KEG),ZFX4(KEG)
DIMENSION ZFY1(KEG),ZFY2(KEG),ZFY3(KEG),ZFY4(KEG)
DIMENSION ZFZ1(KEG),ZFZ2(KEG),ZFZ3(KEG),ZFZ4(KEG)
DIMENSION ZFB1(KEG),ZFB2(KEG),ZFB3(KEG),ZFB4(KEG)
C
DIMENSION ZFX5(KEG),ZFX6(KEG),ZFX7(KEG),ZFX8(KEG),ZFX9(KEG)
DIMENSION ZFY5(KEG),ZFY6(KEG),ZFY7(KEG),ZFY8(KEG),ZFY9(KEG)
DIMENSION ZFZ5(KEG),ZFZ6(KEG),ZFZ7(KEG),ZFZ8(KEG),ZFZ9(KEG)
DIMENSION ZFB5(KEG),ZFB6(KEG),ZFB7(KEG),ZFB8(KEG),ZFB9(KEG)
DIMENSION ZFBA(KEG)
C
DO 1000 IA=1,KATM
ZFORC2(IA,1)=DCMPLX(0.0D0,0.0D0)
ZFORC2(IA,2)=DCMPLX(0.0D0,0.0D0)
ZFORC2(IA,3)=DCMPLX(0.0D0,0.0D0)
1000 CONTINUE
C VPP-PAEALLEL START
C!XOCL PARALLEL REGION
!XOCL SPREAD DO /IP
DO 2100 IK=1,KV3
IIBA = IBA(IK)
C*******DO 1 IBAN=NBD1,NBD2
C IREC = KV3*(IBAN-1)+IK
C IF (IREC8.NE.0) IREC=IREC8*IREC-IREC8+1
C READ(80,REC=IREC) ZV1
C DO 2 I=1,IIBA
C ZEVC(I,IBAN) = ZV1(I)
C 2 CONTINUE
C***1 CONTINUE
DO 2110 IA=1,KATM
CS=1.0D0/(WS(KFTYPE(IA))*UNIVOL)
CP=1.0D0/(WP(KFTYPE(IA))*UNIVOL)
DO 2115 IBAN=NBD1,NBD2
ZFX1(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFX2(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFX3(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFX4(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFY1(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFY2(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFY3(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFY4(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFZ1(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFZ2(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFZ3(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFZ4(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFB1(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFB2(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFB3(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFB4(IBAN)=DCMPLX(0.0D0,0.0D0)
2115 CONTINUE
DO 2200 IBAN=NBD1,NBD2
DO 1510 I=1,IIBA
I1=NBASE(I,IK)
ZTMP=ZZZ(I,IBAN,IK)*DCONJG( ZFM2( I1 ,IA ) )
ZTMP1=ZTMP*SSS(I,IK,KFTYPE(IA),1)
ZTMP2=ZTMP*SSS(I,IK,KFTYPE(IA),2)
ZTMP3=ZTMP*SSS(I,IK,KFTYPE(IA),3)
ZTMP4=ZTMP*SSS(I,IK,KFTYPE(IA),4)
ZFB1(IBAN)=ZFB1(IBAN)+ZTMP1
ZFB2(IBAN)=ZFB2(IBAN)+ZTMP2
ZFB3(IBAN)=ZFB3(IBAN)+ZTMP3
ZFB4(IBAN)=ZFB4(IBAN)+ZTMP4
ZFX1(IBAN)=ZFX1(IBAN)+GX(I1)*ZTMP1
ZFX2(IBAN)=ZFX2(IBAN)+GX(I1)*ZTMP2
ZFX3(IBAN)=ZFX3(IBAN)+GX(I1)*ZTMP3
ZFX4(IBAN)=ZFX4(IBAN)+GX(I1)*ZTMP4
ZFY1(IBAN)=ZFY1(IBAN)+GY(I1)*ZTMP1
ZFY2(IBAN)=ZFY2(IBAN)+GY(I1)*ZTMP2
ZFY3(IBAN)=ZFY3(IBAN)+GY(I1)*ZTMP3
ZFY4(IBAN)=ZFY4(IBAN)+GY(I1)*ZTMP4
ZFZ1(IBAN)=ZFZ1(IBAN)+GZ(I1)*ZTMP1
ZFZ2(IBAN)=ZFZ2(IBAN)+GZ(I1)*ZTMP2
ZFZ3(IBAN)=ZFZ3(IBAN)+GZ(I1)*ZTMP3
ZFZ4(IBAN)=ZFZ4(IBAN)+GZ(I1)*ZTMP4
1510 CONTINUE
2200 CONTINUE
DO 2205 IBAN=NBD1,NBD2
ZFC(IBAN,IK,IA,1)=CS*ZFB1(IBAN)
ZFC(IBAN,IK,IA,2)=CP*ZFB2(IBAN)
ZFC(IBAN,IK,IA,3)=CP*ZFB3(IBAN)
ZFC(IBAN,IK,IA,4)=CP*ZFB4(IBAN)
ZFORC2(IA,1)=ZFORC2(IA,1)+OCCUU(IBAN,IK)*
& ( DCONJG(ZFX1(IBAN))*ZFC(IBAN,IK,IA,1)
& +DCONJG(ZFX2(IBAN))*ZFC(IBAN,IK,IA,2)
& +DCONJG(ZFX3(IBAN))*ZFC(IBAN,IK,IA,3)
& +DCONJG(ZFX4(IBAN))*ZFC(IBAN,IK,IA,4) )
ZFORC2(IA,2)=ZFORC2(IA,2)+OCCUU(IBAN,IK)*
& ( DCONJG(ZFY1(IBAN))*ZFC(IBAN,IK,IA,1)
& +DCONJG(ZFY2(IBAN))*ZFC(IBAN,IK,IA,2)
& +DCONJG(ZFY3(IBAN))*ZFC(IBAN,IK,IA,3)
& +DCONJG(ZFY4(IBAN))*ZFC(IBAN,IK,IA,4) )
ZFORC2(IA,3)=ZFORC2(IA,3)+OCCUU(IBAN,IK)*
& ( DCONJG(ZFZ1(IBAN))*ZFC(IBAN,IK,IA,1)
& +DCONJG(ZFZ2(IBAN))*ZFC(IBAN,IK,IA,2)
& +DCONJG(ZFZ3(IBAN))*ZFC(IBAN,IK,IA,3)
& +DCONJG(ZFZ4(IBAN))*ZFC(IBAN,IK,IA,4) )
2205 CONTINUE
C
IF (NLSPD(KFTYPE(IA)).EQ.2) THEN
C
CD=1.0D0/(WD(KFTYPE(IA))*UNIVOL)
DO 2135 IBAN=NBD1,NBD2
ZFX5(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFX6(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFX7(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFX8(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFX9(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFY5(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFY6(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFY7(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFY8(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFY9(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFZ5(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFZ6(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFZ7(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFZ8(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFZ9(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFB5(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFB6(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFB7(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFB8(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFB9(IBAN)=DCMPLX(0.0D0,0.0D0)
ZFBA(IBAN)=DCMPLX(0.0D0,0.0D0)
2135 CONTINUE
DO 2230 IBAN=NBD1,NBD2
DO 1513 I=1,IIBA
I1=NBASE(I,IK)
ZTMP=ZZZ(I,IBAN,IK)*DCONJG( ZFM2( I1 ,IA ) )
ZTMP5=ZTMP*SSS(I,IK,KFTYPE(IA),5)
ZTMP6=ZTMP*SSS(I,IK,KFTYPE(IA),6)
ZTMP7=ZTMP*SSS(I,IK,KFTYPE(IA),7)
ZTMP8=ZTMP*SSS(I,IK,KFTYPE(IA),8)
ZTMP9=ZTMP*SSS(I,IK,KFTYPE(IA),9)
ZTMPA=ZTMP*SSS(I,IK,KFTYPE(IA),10)
ZFB5(IBAN)=ZFB5(IBAN)+ZTMP5
ZFB6(IBAN)=ZFB6(IBAN)+ZTMP6
ZFB7(IBAN)=ZFB7(IBAN)+ZTMP7
ZFB8(IBAN)=ZFB8(IBAN)+ZTMP8
ZFB9(IBAN)=ZFB9(IBAN)+ZTMP9
ZFBA(IBAN)=ZFBA(IBAN)+ZTMPA
ZFX5(IBAN)=ZFX5(IBAN)+GX(I1)*ZTMP5
ZFX6(IBAN)=ZFX6(IBAN)+GX(I1)*ZTMP6
ZFX7(IBAN)=ZFX7(IBAN)+GX(I1)*ZTMP7
ZFX8(IBAN)=ZFX8(IBAN)+GX(I1)*ZTMP8
ZFX9(IBAN)=ZFX9(IBAN)+GX(I1)*ZTMP9
ZFY5(IBAN)=ZFY5(IBAN)+GY(I1)*ZTMP5
ZFY6(IBAN)=ZFY6(IBAN)+GY(I1)*ZTMP6
ZFY7(IBAN)=ZFY7(IBAN)+GY(I1)*ZTMP7
ZFY8(IBAN)=ZFY8(IBAN)+GY(I1)*ZTMP8
ZFY9(IBAN)=ZFY9(IBAN)+GY(I1)*ZTMP9
ZFZ5(IBAN)=ZFZ5(IBAN)+GZ(I1)*ZTMP5
ZFZ6(IBAN)=ZFZ6(IBAN)+GZ(I1)*ZTMP6
ZFZ7(IBAN)=ZFZ7(IBAN)+GZ(I1)*ZTMP7
ZFZ8(IBAN)=ZFZ8(IBAN)+GZ(I1)*ZTMP8
ZFZ9(IBAN)=ZFZ9(IBAN)+GZ(I1)*ZTMP9
1513 CONTINUE
2230 CONTINUE
DO 2235 IBAN=NBD1,NBD2
ZFC(IBAN,IK,IA,5)=CD*ZFB5(IBAN)
ZFC(IBAN,IK,IA,6)=CD*ZFB6(IBAN)
ZFC(IBAN,IK,IA,7)=CD*ZFB7(IBAN)
ZFC(IBAN,IK,IA,8)=CD*ZFB8(IBAN)
ZFC(IBAN,IK,IA,9)=CD*ZFB9(IBAN)
ZFC(IBAN,IK,IA,10)=CD*ZFBA(IBAN)
C 4/20, 1999, MODIFIED ZFX,Y,Z1 ---> ZFX,Y,Z5
ZFORC2(IA,1)=ZFORC2(IA,1)+OCCUU(IBAN,IK)*
& ( DCONJG(ZFX5(IBAN))*ZFC(IBAN,IK,IA,5)
& +DCONJG(ZFX6(IBAN))*ZFC(IBAN,IK,IA,6)
& +DCONJG(ZFX7(IBAN))*ZFC(IBAN,IK,IA,7)
& +DCONJG(ZFX8(IBAN))*ZFC(IBAN,IK,IA,8)
& +DCONJG(ZFX9(IBAN))*ZFC(IBAN,IK,IA,9) )
ZFORC2(IA,2)=ZFORC2(IA,2)+OCCUU(IBAN,IK)*
& ( DCONJG(ZFY5(IBAN))*ZFC(IBAN,IK,IA,5)
& +DCONJG(ZFY6(IBAN))*ZFC(IBAN,IK,IA,6)
& +DCONJG(ZFY7(IBAN))*ZFC(IBAN,IK,IA,7)
& +DCONJG(ZFY8(IBAN))*ZFC(IBAN,IK,IA,8)
& +DCONJG(ZFY9(IBAN))*ZFC(IBAN,IK,IA,9) )
ZFORC2(IA,3)=ZFORC2(IA,3)+OCCUU(IBAN,IK)*
& ( DCONJG(ZFZ5(IBAN))*ZFC(IBAN,IK,IA,5)
& +DCONJG(ZFZ6(IBAN))*ZFC(IBAN,IK,IA,6)
& +DCONJG(ZFZ7(IBAN))*ZFC(IBAN,IK,IA,7)
& +DCONJG(ZFZ8(IBAN))*ZFC(IBAN,IK,IA,8)
& +DCONJG(ZFZ9(IBAN))*ZFC(IBAN,IK,IA,9) )
2235 CONTINUE
END IF
C
2110 CONTINUE
2100 CONTINUE
!XOCL END SPREAD SUM(ZFORC2)
C!XOCL END PARALLEL
ZCCC = 4.D0*ZI*RVOL/(2.D0*PAI)**3/FLOAT(KV3)
C---------------------------------------------------------
DO 1501 IA=1,KATM
ZFORC2(IA,1)=ZCCC*DIMAG( ZFORC2(IA,1) )
ZFORC2(IA,2)=ZCCC*DIMAG( ZFORC2(IA,2) )
ZFORC2(IA,3)=ZCCC*DIMAG( ZFORC2(IA,3) )
1501 CONTINUE
3000 FORMAT(I4,6F12.8)
RETURN
END