subroutine check_corr(rand)
!
! check correlation of wf1 and wf2
!
implicit none
type(rand_gfsr_obj), intent(inout) :: rand
type(src_wavefunc_obj), allocatable :: wf(:)
integer :: ic,is,jc,js,kc,ks
integer :: it(2),iz(2),iy(2),ix(2)
integer :: iput(2),ipuz(2),ipuy(2),ipux(2)
integer :: itx(2),ity(2),itz(2),itt(2)
integer :: isp(2),ippu(2)
integer :: ii,ipu
integer :: xx1,yy1,zz1,tt1
integer :: xx2,yy2,zz2,tt2
real(DP) :: rx,ry,rz,rt,rdist
complex(DP) :: corr(COL,SPIN,COL,SPIN)
complex(DP) :: ctmp(COL,SPIN,2)
integer :: nns,ins
nns=10*12
node_site(:,:)=0
node_site(1,nodeid)=ipsite(1)
node_site(2,nodeid)=ipsite(2)
node_site(3,nodeid)=ipsite(3)
! node_site(4,nodeid)=ipsite(4)
node_site(4,nodeid)=0
#ifndef _singlePU
do ipu=0,NPU-1
call comlib_bcast(node_site(:,ipu),ipu)
enddo
#endif
do tt1=1,NTT
do zz1=1,NTZ
do yy1=1,NTY
do xx1=1,NTX
! do tt2=1,NTT
! do zz2=1,NTZ
! do yy2=1,NTY
! do xx2=1,NTX
xx2=16
yy2=9
zz2=5
tt2=5
itx(1) = xx1
ity(1) = yy1
itz(1) = zz1
itt(1) = tt1
itx(2) = xx2
ity(2) = yy2
itz(2) = zz2
itt(2) = tt2
rx=MIN(IABS(itx(1)-itx(2)),IABS(itx(1)-itx(2)+NTX),IABS(itx(1)-itx(2)-NTX))
ry=MIN(IABS(ity(1)-ity(2)),IABS(ity(1)-ity(2)+NTY),IABS(ity(1)-ity(2)-NTY))
rz=MIN(IABS(itz(1)-itz(2)),IABS(itz(1)-itz(2)+NTZ),IABS(itz(1)-itz(2)-NTZ))
rt=MIN(IABS(itt(1)-itt(2)),IABS(itt(1)-itt(2)+NTT),IABS(itt(1)-itt(2)-NTT))
rdist = sqrt(real(rx**2+ry**2+rz**2+rt**2,kind=KIND(rdist)))
do ii=1,2
it(ii) = mod(itt(ii)-1,NT)+1
iz(ii) = mod(itz(ii)-1,NZ)+1
iy(ii) = mod(ity(ii)-1,NY)+1
ix(ii) = mod(itx(ii)-1,NX)+1
iput(ii) = (itt(ii)-1)/NT
ipuz(ii) = (itz(ii)-1)/NZ
ipuy(ii) = (ity(ii)-1)/NY
ipux(ii) = (itx(ii)-1)/NX
isp(ii) = ispace(ix(ii),iy(ii),iz(ii))
do ipu=0,NPU-1
if ( (node_site(1,ipu) == ipux(ii)) .and. (node_site(2,ipu) == ipuy(ii)) .and. (node_site(3,ipu) == ipuz(ii)) .and. (node_site(4,ipu) == iput(ii)) ) then
ippu(ii) = ipu
endif
enddo
enddo
allocate(wf(nns))
do ins=1,nns
call new(wf(ins))
enddo
do ins=1,nns
call set_noisy_wavefunc(wf(ins),rand)
enddo
corr = Z0
do ins=1,nns
do ii=1,2
do is=1,SPIN
do ic=1,COL
if (nodeid==ippu(ii)) then
ctmp(ic,is,ii) = wf(ins)%wavefunc(ic,is,isp(ii),it(ii))
else
ctmp(ic,is,ii) = Z0
endif
#ifndef _singlePU
call comlib_bcast(ctmp(ic,is,ii),ippu(ii))
#endif
enddo
enddo
enddo
corr(ic,is,jc,js) = corr(ic,is,jc,js) + ctmp(ic,is,1)*conjg(ctmp(jc,js,2))
enddo
deallocate(wf)
corr = corr/nns
if (nodeid==0) then
write(*,'("%",8I4)')xx1,yy1,zz1,tt1, xx2,yy2,zz2,tt2
do js=1,SPIN
do is=1,SPIN
do jc=1,COL
do ic=1,COL
if (abs(corr(ic,is,jc,js)) > 0.5_DP) write(*,'("@",8I4,4I3,2ES12.4)')xx1,yy1,zz1,tt1, xx2,yy2,zz2,tt2, ic,is,jc,js, corr
enddo
enddo
enddo
enddo
endif
! enddo
! enddo
! enddo
! enddo
enddo
enddo
enddo
enddo
return
end subroutine