C^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 5/1, 2009 ^^^^^
SUBROUTINE CHAVER(IREC8,IREC9,KOPR,NOPR,KBZTYP)
C^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Use MKL_DFTI
IMPLICIT REAL(A-H,O-Y)
IMPLICIT COMPLEX(Z)
INCLUDE 'PACVPP'
complex(8) :: X_IN ((IFX2-1)*IFY2*IFZ2)
type(DFTI_DESCRIPTOR), POINTER :: Desc_Handle
integer status
real(8) Scale
integer lengths(3)
C
!$OMP THREADPRIVATE( /ZAJEKO/, /EIGENP/ )
C-----ARRAYS FOR MFFT--------------------------------------------
COMPLEX(8) ZC3D1(IFX2,IFY2,IFZ2)
REAL(8) CHG3D(IFX2,IFY2,IFZ2)
C================================================================
C EQUIVALENCE (ZC11D(1),ZC3D1(1,1,1))
C================================================================
KFT1 = IFX2
KFT2 = IFY2
KFT3 = IFZ2
KSUM=KFT1*KFT2*KFT3
KVOL=(KFT1-1)*KFT2*KFT3
CCC = 2.D0*RVOL/(2.D0*PAI)**3/FLOAT(KV3)
KIMG=1
WRITE (6,*) 'OEPNMP IN CHAVER'
DO 7701 I=1,KSUM
CHGB1(I)=0.0D0
7701 CONTINUE
WRITE (6,*) 'OEPNMP IN CHAVER2'
DO 7731 KK=1,KFT3
DO 7732 JJ=1,KFT2
DO 7733 II=1,KFT1
CHG3D(II,JJ,KK)=0.0D0
ZC3D1(II,JJ,KK)=DCMPLX(0.0D0,0.0D0)
7733 CONTINUE
7732 CONTINUE
7731 CONTINUE
C WRITE (6,*) 'CHECK POINT 0 IN CHAVER'
!$OMP PARALLEL DEFAULT(NONE)
!$OMP& COPYIN( ZAJ, OCCUP )
!$OMP& FIRSTPRIVATE( KFT1,KFT2,KFT3,KSUM, CHG3D )
!$OMP& PRIVATE(IIBA,I1, L1,L2,L3,
!$OMP& scale, lengths, status, X_IN, Desc_Handle,
!$OMP& IERR,IERR1, II,JJ,KK, INDX, ZC3D1 )
!$OMP& SHARED( KV3,NBD1,NBD2,
!$OMP& IBA,NBASE, IGF1,IGF2,IGF3,
!$OMP& UNIVOL, CHGB1 )
!$OMP DO
C!$OMP DO REDUCTION(+:CHGB1)
DO 7820 IK=1,KV3
C WRITE (6,*) 'CHECK POINT IN CHAVER, IK = ',IK
DO 7810 IBAN=NBD1,NBD2
IIBA=IBA(IK)
DO 7831 KK=1,KFT3
DO 7832 JJ=1,KFT2
DO 7833 II=1,KFT1
ZC3D1(II,JJ,KK)=DCMPLX(0.0D0,0.0D0)
7833 CONTINUE
7832 CONTINUE
7831 CONTINUE
C DO 7830 I=1,KSUM
C ZC11D(I)=DCMPLX(0.0D0,0.0D0)
C 7830 CONTINUE
C
DO 232 I=1,IIBA
I1=NBASE(I,IK)
L1=IGF1(I1)
L2=IGF2(I1)
L3=IGF3(I1)
ZC3D1(L1,L2,L3) = ZAJ(I,IBAN,IK)
232 CONTINUE
C*****---- INVERSE FAST FOURIER TRANSFORMATION -----
C CALL C3FFT_MKL(ZC3D1,KFT1,KFT1-1,KFT2,KFT3,1,IERR1)
C
C INLINE C3FFT_MKL
C
DO 111 KK=1,KFT3
DO 112 JJ=1,KFT2
DO 113 II=1,KFT1-1
INDX=(KFT1-1)*KFT2*(KK-1)+(KFT1-1)*(JJ-1)+II
X_IN(INDX)=ZC3D1(II,JJ,KK)
113 CONTINUE
112 CONTINUE
111 CONTINUE
lengths(1) = KFT1-1
lengths(2) = KFT2
lengths(3) = KFT3
Status = DftiCreateDescriptor( Desc_Handle,
& DFTI_DOUBLE, DFTI_COMPLEX, 3, lengths)
C INVERSE FFT IFFT = 1
Scale = 1.0
Status = DftiSetValue(Desc_Handle, DFTI_BACKWARD_SCALE, Scale)
Status = DftiCommitDescriptor( Desc_Handle )
Status = DftiComputeBackward( Desc_Handle, X_IN)
C
DO 211 KK=1,KFT3
DO 212 JJ=1,KFT2
DO 213 II=1,KFT1-1
INDX=(KFT1-1)*KFT2*(KK-1)+(KFT1-1)*(JJ-1)+II
ZC3D1(II,JJ,KK)=X_IN(INDX)
213 CONTINUE
212 CONTINUE
211 CONTINUE
C
Status = DftiFreeDescriptor(Desc_Handle)
C
DO 1831 KK=1,KFT3
DO 1832 JJ=1,KFT2
DO 1833 II=1,KFT1
CHG3D(II,JJ,KK)=CHG3D(II,JJ,KK)+OCCUP(IBAN,IK)*
& DCONJG(ZC3D1(II,JJ,KK))*ZC3D1(II,JJ,KK)
1833 CONTINUE
1832 CONTINUE
1831 CONTINUE
C
7810 CONTINUE
7820 CONTINUE
!$OMP END DO
C
!$OMP CRITICAL
DO 1731 KK=1,KFT3
DO 1732 JJ=1,KFT2
DO 1733 II=1,KFT1
INDX=KFT1*KFT2*(KK-1)+KFT1*(JJ-1)+II
CHGB1(INDX)=CHGB1(INDX)+CHG3D(II,JJ,KK)
1733 CONTINUE
1732 CONTINUE
1731 CONTINUE
!$OMP END CRITICAL
!$OMP END PARALLEL
C
C DO 7900 I=1,KSUM
C ZC11D(I)=CCC*CHGB1(I)
C 7900 CONTINUE
C
DO 1631 KK=1,KFT3
DO 1632 JJ=1,KFT2
DO 1633 II=1,KFT1
INDX=KFT1*KFT2*(KK-1)+KFT1*(JJ-1)+II
ZC3D1(II,JJ,KK)=CCC*CHGB1(INDX)
1633 CONTINUE
1632 CONTINUE
1631 CONTINUE
C
C*****---- FAST FOURIER TRANSFORMATION -----
CALL C3FFT_MKL(ZC3D1,KFT1,KFT1-1,KFT2,KFT3,-1,IERR)
DENOM=1.0D0/DBLE(KVOL)
DO 30 I=1,KG
L1=IGF1(I)
L2=IGF2(I)
L3=IGF3(I)
ZCHG(I)=ZC3D1(L1,L2,L3)*DENOM
30 CONTINUE
C---------------KNGP ---> KNG KPO ---> KOPR -----------------------
IF (KBZTYP.LT.0 .OR. KBZTYP.GE.2) THEN
CALL CHGAVR(KOPR,NOPR,KIMG)
END IF
C---------------------------------------------------------------
RETURN
END