Constant : | |
EXP_WAV =2 : | integer, parameter |
Original external subprogram is wavefunc_param_class#EXP_WAV
Constant : | |
EXP_WAV =2 : | integer, parameter |
Original external subprogram is wavefunc_param_class#EXP_WAV
Constant : | |
EXP_WAV =2 : | integer, parameter |
Original external subprogram is wavefunc_param_class#EXP_WAV
Constant : | |
LOCAL_WAV =1 : | integer, parameter |
Original external subprogram is wavefunc_param_class#LOCAL_WAV
Constant : | |
LOCAL_WAV =1 : | integer, parameter |
Original external subprogram is wavefunc_param_class#LOCAL_WAV
Constant : | |
LOCAL_WAV =1 : | integer, parameter |
Original external subprogram is wavefunc_param_class#LOCAL_WAV
Constant : | |
MAXPOL_WAV =50 : | integer, parameter |
Original external subprogram is wavefunc_param_class#MAXPOL_WAV
Constant : | |
MAXPOL_WAV =50 : | integer, parameter |
Original external subprogram is wavefunc_param_class#MAXPOL_WAV
Constant : | |
MAXPOL_WAV =50 : | integer, parameter |
Original external subprogram is wavefunc_param_class#MAXPOL_WAV
Constant : | |
MAXPOL_WAV =50 : | integer, parameter |
Original external subprogram is wavefunc_param_class#MAXPOL_WAV
Constant : | |
MAXPOL_WAV =50 : | integer, parameter |
Original external subprogram is wavefunc_param_class#MAXPOL_WAV
Constant : | |
MAXPOL_WAV =50 : | integer, parameter |
Original external subprogram is wavefunc_param_class#MAXPOL_WAV
Constant : | |
MAXPOL_WAV =50 : | integer, parameter |
Original external subprogram is wavefunc_param_class#MAXPOL_WAV
Constant : | |
MAXPOL_WAV =50 : | integer, parameter |
Original external subprogram is wavefunc_param_class#MAXPOL_WAV
Constant : | |
POLY_WAV =4 : | integer, parameter |
Original external subprogram is wavefunc_param_class#POLY_WAV
Constant : | |
POLY_WAV =4 : | integer, parameter |
Original external subprogram is wavefunc_param_class#POLY_WAV
Constant : | |
POLY_WAV =4 : | integer, parameter |
Original external subprogram is wavefunc_param_class#POLY_WAV
Constant : | |
USER_WAV =5 : | integer, parameter |
Original external subprogram is wavefunc_param_class#USER_WAV
Constant : | |
USER_WAV =5 : | integer, parameter |
Original external subprogram is wavefunc_param_class#USER_WAV
Constant : | |
WALL_WAV =3 : | integer, parameter |
Original external subprogram is wavefunc_param_class#WALL_WAV
Constant : | |
WALL_WAV =3 : | integer, parameter |
Original external subprogram is wavefunc_param_class#WALL_WAV
Constant : | |
WALL_WAV =3 : | integer, parameter |
Original external subprogram is wavefunc_param_class#WALL_WAV
Subroutine : | |
this : | type(snk_wavefunc_obj), intent(inout) |
subroutine delete_snk_wavefunc(this) implicit none type(snk_wavefunc_obj), intent(inout) :: this call delete(this%param) if (allocated(this%wavefunc)) deallocate(this%wavefunc) return end subroutine
Subroutine : | |
this : | type(snk_wavefunc_obj), intent(inout) |
subroutine delete_snk_wavefunc(this) implicit none type(snk_wavefunc_obj), intent(inout) :: this call delete(this%param) if (allocated(this%wavefunc)) deallocate(this%wavefunc) return end subroutine
Subroutine : | |
this : | type(src_wavefunc_obj), intent(inout) |
subroutine delete_src_wavefunc(this) implicit none type(src_wavefunc_obj), intent(inout) :: this call delete(this%param) if (allocated(this%wavefunc)) deallocate(this%wavefunc) return end subroutine
Subroutine : | |
this : | type(src_wavefunc_obj), intent(inout) |
subroutine delete_src_wavefunc(this) implicit none type(src_wavefunc_obj), intent(inout) :: this call delete(this%param) if (allocated(this%wavefunc)) deallocate(this%wavefunc) return end subroutine
Subroutine : | |
this : | type(wavefunc_param_obj), intent(inout) |
subroutine delete_wavefunc(this) implicit none type(wavefunc_param_obj), intent(inout) :: this return end subroutine
Subroutine : | |
this : | type(wavefunc_param_obj), intent(inout) |
subroutine delete_wavefunc(this) implicit none type(wavefunc_param_obj), intent(inout) :: this return end subroutine
Subroutine : | |
this : | type(snk_wavefunc_obj), intent(inout) |
subroutine get_snk_wavefunc(this) use print_status_class implicit none type(snk_wavefunc_obj), intent(inout) :: this type(src_wavefunc_obj), allocatable :: twf integer :: itt,isp,it,it0 integer :: ix,iy,iz integer :: itx,ity,itz character(len=CHARLEN) :: str if (allocated(this%wavefunc)) deallocate(this%wavefunc) allocate(this%wavefunc(NSPACE)) allocate(twf) call new(twf) twf%param = this%param twf%itx0 = 1 twf%ity0 = 1 twf%itz0 = 1 twf%itt0 = 1 call get(twf) do it=1,NT itt = it if (itt == twf%itt0) then !$OMP PARALLEL DO PRIVATE(isp) do isp=1,NSPACE this%wavefunc(isp) = twf%wavefunc(1,1,isp,it) enddo endif enddo #ifdef _DDD_ !============ do ix=1,NX do iy=1,NY do iz=1,NZ itx = ix + ipsite(1)*NX ity = iy + ipsite(2)*NY itz = iz + ipsite(3)*NZ isp=ispace(ix,iy,iz) write(str,'(3I3," :",I9,I2,2E24.15,I11," SWF")') itx,ity,itz,isp,1,this%wavefunc(isp), itx-1+(ity-1)*NTX+(itz-1)*NTX*NTY call print_status(str) enddo enddo enddo !============ #endif call delete(twf) deallocate(twf) return end subroutine
Subroutine : | |
this : | type(snk_wavefunc_obj), intent(inout) |
subroutine get_snk_wavefunc(this) use print_status_class implicit none type(snk_wavefunc_obj), intent(inout) :: this type(src_wavefunc_obj), allocatable :: twf integer :: itt,isp,it,it0 integer :: ix,iy,iz integer :: itx,ity,itz character(len=CHARLEN) :: str if (allocated(this%wavefunc)) deallocate(this%wavefunc) allocate(this%wavefunc(NSPACE)) allocate(twf) call new(twf) twf%param = this%param twf%itx0 = 1 twf%ity0 = 1 twf%itz0 = 1 twf%itt0 = 1 call get(twf) do it=1,NT itt = it if (itt == twf%itt0) then !$OMP PARALLEL DO PRIVATE(isp) do isp=1,NSPACE this%wavefunc(isp) = twf%wavefunc(1,1,isp,it) enddo endif enddo #ifdef _DDD_ !============ do ix=1,NX do iy=1,NY do iz=1,NZ itx = ix + ipsite(1)*NX ity = iy + ipsite(2)*NY itz = iz + ipsite(3)*NZ isp=ispace(ix,iy,iz) write(str,'(3I3," :",I9,I2,2E24.15,I11," SWF")') itx,ity,itz,isp,1,this%wavefunc(isp), itx-1+(ity-1)*NTX+(itz-1)*NTX*NTY call print_status(str) enddo enddo enddo !============ #endif call delete(twf) deallocate(twf) return end subroutine
Subroutine : | |
this : | type(src_wavefunc_obj), intent(inout) |
subroutine get_src_wavefunc(this) use print_status_class implicit none type(src_wavefunc_obj), intent(inout) :: this integer :: it,iz,iy,ix,ic,is,jc,js,isp integer :: itt,itz,ity,itx integer :: rx,ry,rz,ipol integer :: ipx,ipy,ipz,ipt integer :: ix0,iy0,iz0,it0 real(DP) :: rsrc,vsrc,rmax character(len=CHARLEN) :: str if ( this%param%type == USER_WAV) return if (allocated(this%wavefunc)) deallocate(this%wavefunc) allocate(this%wavefunc(COL,SPIN,NSPACE,NT)) !$OMP PARALLEL WORKSHARE this%wavefunc(:,:,:,:) = Z0 !$OMP END PARALLEL WORKSHARE select case (this%param%type) case (LOCAL_WAV) ipt = (this%itt0-1)/NT ipz = (this%itz0-1)/NZ ipy = (this%ity0-1)/NY ipx = (this%itx0-1)/NX if ( (ipt == 0) .and. (ipz == ipsite(3)) .and. (ipy == ipsite(2)) .and. (ipx == ipsite(1)) ) then it0 = mod(this%itt0-1,NT)+1 iz0 = mod(this%itz0-1,NZ)+1 iy0 = mod(this%ity0-1,NY)+1 ix0 = mod(this%itx0-1,NX)+1 isp=ispace(ix0,iy0,iz0) do is=1,SPIN do ic=1,COL this%wavefunc(ic,is,isp,it0) = Z1 enddo enddo endif #ifdef _FULL_ do it=1,NT do ix=1,NX do iy=1,NY do iz=1,NZ itt=it itz=iz+ipsite(3)*NZ ity=iy+ipsite(2)*NY itx=ix+ipsite(1)*NX if ( (itz==this%itz0) .and. (ity==this%ity0) .and. (itx==this%itx0) .and. (itt==this%itt0) ) then isp=ispace(ix,iy,iz) do is=1,SPIN do ic=1,COL this%wavefunc(ic,is,isp,it) = Z1 enddo enddo endif enddo enddo enddo enddo #endif case (EXP_WAV) rmax = MIN(NTX,NTZ,NTY) rmax = (rmax/2.0_DP - 1.0_DP) + 0.5_DP ipt = (this%itt0-1)/NT it0 = mod(this%itt0-1,NT)+1 #ifdef _DDD_ !============ write(str,'("EXP_WAVE:",4I3," :",3I2," :",2E12.4)') this%itx0,this%ity0,this%itz0,this%itt0, ipsite(1),ipsite(2),ipsite(3), this%param%Asmear,this%param%Bsmear call print_status(str) !============ #endif do it=1,NT itt=it if (itt == this%itt0) then !$OMP PARALLEL DO PRIVATE(ix,iy,iz,itx,ity,itz,isp,rx,ry,rz,rsrc,vsrc,is,ic) do ix=1,NX do iy=1,NY do iz=1,NZ itz=iz+ipsite(3)*NZ ity=iy+ipsite(2)*NY itx=ix+ipsite(1)*NX isp=ispace(ix,iy,iz) ! ! 2-point distance with periodic boundary condition ! rx=MIN(IABS(itx-this%itx0),IABS(itx-this%itx0+NTX),IABS(itx-this%itx0-NTX)) ry=MIN(IABS(ity-this%ity0),IABS(ity-this%ity0+NTY),IABS(ity-this%ity0-NTY)) rz=MIN(IABS(itz-this%itz0),IABS(itz-this%itz0+NTZ),IABS(itz-this%itz0-NTZ)) rsrc = sqrt(real(rx**2+ry**2+rz**2,kind=KIND(rsrc))) if ( rsrc < rmax) then vsrc = this%param%Asmear*exp(-rsrc*this%param%Bsmear) do is=1,SPIN do ic=1,COL this%wavefunc(ic,is,isp,it)=cmplx(vsrc,0.0_DP,kind=KIND(vsrc)) enddo enddo endif if ( (rx==0) .and. (ry==0) .and. (rz==0) ) then do is=1,SPIN do ic=1,COL this%wavefunc(ic,is,isp,it) = Z1 enddo enddo endif #ifdef _DDD_ !================ do is=1,SPIN do ic=1,COL write(str,'(3I3," :",I9,I2,2E24.15,I11,2I2" WWW")') itx,ity,itz,isp,it,this%wavefunc(ic,is,isp,it), itx-1+(ity-1)*NTX+(itz-1)*NTX*NTY,ic,is call print_status(str) enddo enddo !================ #endif enddo enddo enddo endif enddo case (WALL_WAV) vsrc = 1.0_DP/real(NTX*NTY*NTZ,kind=KIND(vsrc)) do it=1,NT itt=it if (itt==this%itt0) then !$OMP PARALLEL DO PRIVATE(ix,iy,iz,itx,ity,itz,isp,is,ic) do ix=1,NX do iy=1,NY do iz=1,NZ itz=iz+ipsite(3)*NZ ity=iy+ipsite(2)*NY itx=ix+ipsite(1)*NX isp=ispace(ix,iy,iz) do is=1,SPIN do ic=1,COL this%wavefunc(ic,is,isp,it) = cmplx(vsrc,0.0_DP,kind=KIND(vsrc)) enddo enddo enddo enddo enddo endif enddo case (POLY_WAV) rmax = MIN(NTX,NTZ,NTY) rmax = (rmax/2.0_DP - 1.0_DP) + 0.5_DP do it=1,NT itt=it if (itt==this%itt0) then !$OMP PARALLEL DO PRIVATE(ix,iy,iz,itx,ity,itz,isp,rx,ry,rz,rsrc,vsrc,ipol,is,ic) do ix=1,NX do iy=1,NY do iz=1,NZ itz=iz+ipsite(3)*NZ ity=iy+ipsite(2)*NY itx=ix+ipsite(1)*NX isp=ispace(ix,iy,iz) ! ! 2-point distance with periodic boundary condition ! rx=MIN(IABS(itx-this%itx0),IABS(itx-this%itx0+NTX),IABS(itx-this%itx0-NTX)) ry=MIN(IABS(ity-this%ity0),IABS(ity-this%ity0+NTY),IABS(ity-this%ity0-NTY)) rz=MIN(IABS(itz-this%itz0),IABS(itz-this%itz0+NTZ),IABS(itz-this%itz0-NTZ)) rsrc = sqrt(real(rx**2+ry**2+rz**2,kind=KIND(rsrc))) vsrc = 1.0_DP do ipol = 1,this%param%Npolsf vsrc = vsrc - this%param%Psmear(ipol)*rsrc**ipol enddo do is=1,SPIN do ic=1,COL this%wavefunc(ic,is,isp,it)=cmplx(vsrc,0.0_DP,kind=KIND(vsrc)) enddo enddo enddo enddo enddo endif enddo end select #ifdef _DDD_ !============== vsrc = 0.0_DP do ix=1,NX do iy=1,NY do iz=1,NZ isp=ispace(ix,iy,iz) vsrc = vsrc + REAL(this%wavefunc(1,1,isp,this%itt0),kind=DP)**2 enddo enddo enddo call comlib_sumcast(vsrc) if (0==nodeid) then write(*,'("|WF|^2=",E24.15)')vsrc endif !============== #endif return end subroutine
Subroutine : | |
this : | type(src_wavefunc_obj), intent(inout) |
subroutine get_src_wavefunc(this) use print_status_class implicit none type(src_wavefunc_obj), intent(inout) :: this integer :: it,iz,iy,ix,ic,is,jc,js,isp integer :: itt,itz,ity,itx integer :: rx,ry,rz,ipol integer :: ipx,ipy,ipz,ipt integer :: ix0,iy0,iz0,it0 real(DP) :: rsrc,vsrc,rmax character(len=CHARLEN) :: str if ( this%param%type == USER_WAV) return if (allocated(this%wavefunc)) deallocate(this%wavefunc) allocate(this%wavefunc(COL,SPIN,NSPACE,NT)) !$OMP PARALLEL WORKSHARE this%wavefunc(:,:,:,:) = Z0 !$OMP END PARALLEL WORKSHARE select case (this%param%type) case (LOCAL_WAV) ipt = (this%itt0-1)/NT ipz = (this%itz0-1)/NZ ipy = (this%ity0-1)/NY ipx = (this%itx0-1)/NX if ( (ipt == 0) .and. (ipz == ipsite(3)) .and. (ipy == ipsite(2)) .and. (ipx == ipsite(1)) ) then it0 = mod(this%itt0-1,NT)+1 iz0 = mod(this%itz0-1,NZ)+1 iy0 = mod(this%ity0-1,NY)+1 ix0 = mod(this%itx0-1,NX)+1 isp=ispace(ix0,iy0,iz0) do is=1,SPIN do ic=1,COL this%wavefunc(ic,is,isp,it0) = Z1 enddo enddo endif #ifdef _FULL_ do it=1,NT do ix=1,NX do iy=1,NY do iz=1,NZ itt=it itz=iz+ipsite(3)*NZ ity=iy+ipsite(2)*NY itx=ix+ipsite(1)*NX if ( (itz==this%itz0) .and. (ity==this%ity0) .and. (itx==this%itx0) .and. (itt==this%itt0) ) then isp=ispace(ix,iy,iz) do is=1,SPIN do ic=1,COL this%wavefunc(ic,is,isp,it) = Z1 enddo enddo endif enddo enddo enddo enddo #endif case (EXP_WAV) rmax = MIN(NTX,NTZ,NTY) rmax = (rmax/2.0_DP - 1.0_DP) + 0.5_DP ipt = (this%itt0-1)/NT it0 = mod(this%itt0-1,NT)+1 #ifdef _DDD_ !============ write(str,'("EXP_WAVE:",4I3," :",3I2," :",2E12.4)') this%itx0,this%ity0,this%itz0,this%itt0, ipsite(1),ipsite(2),ipsite(3), this%param%Asmear,this%param%Bsmear call print_status(str) !============ #endif do it=1,NT itt=it if (itt == this%itt0) then !$OMP PARALLEL DO PRIVATE(ix,iy,iz,itx,ity,itz,isp,rx,ry,rz,rsrc,vsrc,is,ic) do ix=1,NX do iy=1,NY do iz=1,NZ itz=iz+ipsite(3)*NZ ity=iy+ipsite(2)*NY itx=ix+ipsite(1)*NX isp=ispace(ix,iy,iz) ! ! 2-point distance with periodic boundary condition ! rx=MIN(IABS(itx-this%itx0),IABS(itx-this%itx0+NTX),IABS(itx-this%itx0-NTX)) ry=MIN(IABS(ity-this%ity0),IABS(ity-this%ity0+NTY),IABS(ity-this%ity0-NTY)) rz=MIN(IABS(itz-this%itz0),IABS(itz-this%itz0+NTZ),IABS(itz-this%itz0-NTZ)) rsrc = sqrt(real(rx**2+ry**2+rz**2,kind=KIND(rsrc))) if ( rsrc < rmax) then vsrc = this%param%Asmear*exp(-rsrc*this%param%Bsmear) do is=1,SPIN do ic=1,COL this%wavefunc(ic,is,isp,it)=cmplx(vsrc,0.0_DP,kind=KIND(vsrc)) enddo enddo endif if ( (rx==0) .and. (ry==0) .and. (rz==0) ) then do is=1,SPIN do ic=1,COL this%wavefunc(ic,is,isp,it) = Z1 enddo enddo endif #ifdef _DDD_ !================ do is=1,SPIN do ic=1,COL write(str,'(3I3," :",I9,I2,2E24.15,I11,2I2" WWW")') itx,ity,itz,isp,it,this%wavefunc(ic,is,isp,it), itx-1+(ity-1)*NTX+(itz-1)*NTX*NTY,ic,is call print_status(str) enddo enddo !================ #endif enddo enddo enddo endif enddo case (WALL_WAV) vsrc = 1.0_DP/real(NTX*NTY*NTZ,kind=KIND(vsrc)) do it=1,NT itt=it if (itt==this%itt0) then !$OMP PARALLEL DO PRIVATE(ix,iy,iz,itx,ity,itz,isp,is,ic) do ix=1,NX do iy=1,NY do iz=1,NZ itz=iz+ipsite(3)*NZ ity=iy+ipsite(2)*NY itx=ix+ipsite(1)*NX isp=ispace(ix,iy,iz) do is=1,SPIN do ic=1,COL this%wavefunc(ic,is,isp,it) = cmplx(vsrc,0.0_DP,kind=KIND(vsrc)) enddo enddo enddo enddo enddo endif enddo case (POLY_WAV) rmax = MIN(NTX,NTZ,NTY) rmax = (rmax/2.0_DP - 1.0_DP) + 0.5_DP do it=1,NT itt=it if (itt==this%itt0) then !$OMP PARALLEL DO PRIVATE(ix,iy,iz,itx,ity,itz,isp,rx,ry,rz,rsrc,vsrc,ipol,is,ic) do ix=1,NX do iy=1,NY do iz=1,NZ itz=iz+ipsite(3)*NZ ity=iy+ipsite(2)*NY itx=ix+ipsite(1)*NX isp=ispace(ix,iy,iz) ! ! 2-point distance with periodic boundary condition ! rx=MIN(IABS(itx-this%itx0),IABS(itx-this%itx0+NTX),IABS(itx-this%itx0-NTX)) ry=MIN(IABS(ity-this%ity0),IABS(ity-this%ity0+NTY),IABS(ity-this%ity0-NTY)) rz=MIN(IABS(itz-this%itz0),IABS(itz-this%itz0+NTZ),IABS(itz-this%itz0-NTZ)) rsrc = sqrt(real(rx**2+ry**2+rz**2,kind=KIND(rsrc))) vsrc = 1.0_DP do ipol = 1,this%param%Npolsf vsrc = vsrc - this%param%Psmear(ipol)*rsrc**ipol enddo do is=1,SPIN do ic=1,COL this%wavefunc(ic,is,isp,it)=cmplx(vsrc,0.0_DP,kind=KIND(vsrc)) enddo enddo enddo enddo enddo endif enddo end select #ifdef _DDD_ !============== vsrc = 0.0_DP do ix=1,NX do iy=1,NY do iz=1,NZ isp=ispace(ix,iy,iz) vsrc = vsrc + REAL(this%wavefunc(1,1,isp,this%itt0),kind=DP)**2 enddo enddo enddo call comlib_sumcast(vsrc) if (0==nodeid) then write(*,'("|WF|^2=",E24.15)')vsrc endif !============== #endif return end subroutine
Subroutine : | |
this : | type(wavefunc_param_obj), intent(inout) |
subroutine get_wavefunc(this) implicit none type(wavefunc_param_obj), intent(inout) :: this complex(8), parameter :: z0=(0.0d0,0.0d0) complex(8), parameter :: z1=(1.0d0,0.0d0) integer :: iz,iy,ix,it,ic,is,jc,js,isp integer :: itt,itz,ity,itx integer :: rx,ry,rz,ipol real(8) :: rsrc,vsrc,rmax if ( this%type == USER_WAV) return this%wavefunc(:,:,:,:)=z0 select case (this%type) case (LOCAL_WAV) do it=1,NT do ix=1,NX do iy=1,NY do iz=1,NZ itt=it+ipsite(4)*NT itz=iz+ipsite(3)*NZ ity=iy+ipsite(2)*NY itx=ix+ipsite(1)*NX if ( (itt==this%itt0) .and. (itz==this%itz0) .and. (ity==this%ity0) .and. (itx==this%itx0) ) then isp=ispace(ix,iy,iz) do is=1,SPIN do ic=1,COL this%wavefunc(ic,is,isp,it)=z1 enddo enddo endif enddo enddo enddo enddo case (EXP_WAV) rmax = MIN(NTX,NTZ,NTY) rmax = (rmax/2.0d0 - 1.0d0) + 0.5d0 do it=1,NT do ix=1,NX do iy=1,NY do iz=1,NZ itt=it+ipsite(4)*NT itz=iz+ipsite(3)*NZ ity=iy+ipsite(2)*NY itx=ix+ipsite(1)*NX isp=ispace(ix,iy,iz) if (itt==this%itt0) then ! rx = itx - this%itx0 ! ry = ity - this%ity0 ! rz = itz - this%itz0 ! ! 2-point distance with periodic boundary condition ! rx=MIN(IABS(itx-this%itx0),IABS(itx-this%itx0+NTX),IABS(itx-this%itx0-NTX)) ry=MIN(IABS(ity-this%ity0),IABS(ity-this%ity0+NTY),IABS(ity-this%ity0-NTY)) rz=MIN(IABS(itz-this%itz0),IABS(itz-this%itz0+NTZ),IABS(itz-this%itz0-NTZ)) rsrc = sqrt(real(rx**2+ry**2+rz**2,kind=KIND(rsrc))) if ( rsrc < rmax) then vsrc = this%Asmear*exp(-rsrc*this%Bsmear) do is=1,SPIN do ic=1,COL this%wavefunc(ic,is,isp,it)=cmplx(vsrc,0.0d0,kind=KIND(vsrc)) enddo enddo endif if ( (rx==0) .and. (ry==0) .and. (rz==0) ) then do is=1,SPIN do ic=1,COL this%wavefunc(ic,is,isp,it)=z1 enddo enddo endif endif enddo enddo enddo enddo case (WALL_WAV) vsrc = 1.0d0/real(NTX*NTY*NTZ,kind=KIND(vsrc)) do it=1,NT do ix=1,NX do iy=1,NY do iz=1,NZ itt=it+ipsite(4)*NT itz=iz+ipsite(3)*NZ ity=iy+ipsite(2)*NY itx=ix+ipsite(1)*NX isp=ispace(ix,iy,iz) if (itt==this%itt0) then do is=1,SPIN do ic=1,COL this%wavefunc(ic,is,isp,it)=cmplx(vsrc,0.0d0,kind=KIND(vsrc)) enddo enddo endif enddo enddo enddo enddo case (POLY_WAV) rmax = MIN(NTX,NTZ,NTY) rmax = (rmax/2.0d0 - 1.0d0) + 0.5d0 do it=1,NT do ix=1,NX do iy=1,NY do iz=1,NZ itt=it+ipsite(4)*NT itz=iz+ipsite(3)*NZ ity=iy+ipsite(2)*NY itx=ix+ipsite(1)*NX isp=ispace(ix,iy,iz) if (itt==this%itt0) then ! rx = itx - this%itx0 ! ry = ity - this%ity0 ! rz = itz - this%itz0 ! ! 2-point distance with periodic boundary condition ! rx=MIN(IABS(itx-this%itx0),IABS(itx-this%itx0+NTX),IABS(itx-this%itx0-NTX)) ry=MIN(IABS(ity-this%ity0),IABS(ity-this%ity0+NTY),IABS(ity-this%ity0-NTY)) rz=MIN(IABS(itz-this%itz0),IABS(itz-this%itz0+NTZ),IABS(itz-this%itz0-NTZ)) rsrc = sqrt(real(rx**2+ry**2+rz**2,kind=KIND(rsrc))) vsrc = 1.0d0 do ipol = 1,this%Npolsf vsrc = vsrc - this%Psmear(ipol)*rsrc**ipol enddo do is=1,SPIN do ic=1,COL this%wavefunc(ic,is,isp,it)=cmplx(vsrc,0.0d0,kind=KIND(vsrc)) enddo enddo endif enddo enddo enddo enddo end select return end subroutine
Subroutine : | |
this : | type(wavefunc_param_obj), intent(inout) |
subroutine get_wavefunc(this) implicit none type(wavefunc_param_obj), intent(inout) :: this complex(8), parameter :: z0=(0.0d0,0.0d0) complex(8), parameter :: z1=(1.0d0,0.0d0) integer :: iz,iy,ix,it,ic,is,jc,js,isp integer :: itt,itz,ity,itx integer :: rx,ry,rz,ipol real(8) :: rsrc,vsrc,rmax if ( this%type == USER_WAV) return this%wavefunc(:,:,:,:)=z0 select case (this%type) case (LOCAL_WAV) do it=1,NT do ix=1,NX do iy=1,NY do iz=1,NZ itt=it+ipsite(4)*NT itz=iz+ipsite(3)*NZ ity=iy+ipsite(2)*NY itx=ix+ipsite(1)*NX if ( (itt==this%itt0) .and. (itz==this%itz0) .and. (ity==this%ity0) .and. (itx==this%itx0) ) then isp=ispace(ix,iy,iz) do is=1,SPIN do ic=1,COL this%wavefunc(ic,is,isp,it)=z1 enddo enddo endif enddo enddo enddo enddo case (EXP_WAV) rmax = MIN(NTX,NTZ,NTY) rmax = (rmax/2.0d0 - 1.0d0) + 0.5d0 do it=1,NT do ix=1,NX do iy=1,NY do iz=1,NZ itt=it+ipsite(4)*NT itz=iz+ipsite(3)*NZ ity=iy+ipsite(2)*NY itx=ix+ipsite(1)*NX isp=ispace(ix,iy,iz) if (itt==this%itt0) then ! rx = itx - this%itx0 ! ry = ity - this%ity0 ! rz = itz - this%itz0 ! ! 2-point distance with periodic boundary condition ! rx=MIN(IABS(itx-this%itx0),IABS(itx-this%itx0+NTX),IABS(itx-this%itx0-NTX)) ry=MIN(IABS(ity-this%ity0),IABS(ity-this%ity0+NTY),IABS(ity-this%ity0-NTY)) rz=MIN(IABS(itz-this%itz0),IABS(itz-this%itz0+NTZ),IABS(itz-this%itz0-NTZ)) rsrc = sqrt(real(rx**2+ry**2+rz**2,kind=KIND(rsrc))) if ( rsrc < rmax) then vsrc = this%Asmear*exp(-rsrc*this%Bsmear) do is=1,SPIN do ic=1,COL this%wavefunc(ic,is,isp,it)=cmplx(vsrc,0.0d0,kind=KIND(vsrc)) enddo enddo endif if ( (rx==0) .and. (ry==0) .and. (rz==0) ) then do is=1,SPIN do ic=1,COL this%wavefunc(ic,is,isp,it)=z1 enddo enddo endif endif enddo enddo enddo enddo case (WALL_WAV) vsrc = 1.0d0/real(NTX*NTY*NTZ,kind=KIND(vsrc)) do it=1,NT do ix=1,NX do iy=1,NY do iz=1,NZ itt=it+ipsite(4)*NT itz=iz+ipsite(3)*NZ ity=iy+ipsite(2)*NY itx=ix+ipsite(1)*NX isp=ispace(ix,iy,iz) if (itt==this%itt0) then do is=1,SPIN do ic=1,COL this%wavefunc(ic,is,isp,it)=cmplx(vsrc,0.0d0,kind=KIND(vsrc)) enddo enddo endif enddo enddo enddo enddo case (POLY_WAV) rmax = MIN(NTX,NTZ,NTY) rmax = (rmax/2.0d0 - 1.0d0) + 0.5d0 do it=1,NT do ix=1,NX do iy=1,NY do iz=1,NZ itt=it+ipsite(4)*NT itz=iz+ipsite(3)*NZ ity=iy+ipsite(2)*NY itx=ix+ipsite(1)*NX isp=ispace(ix,iy,iz) if (itt==this%itt0) then ! rx = itx - this%itx0 ! ry = ity - this%ity0 ! rz = itz - this%itz0 ! ! 2-point distance with periodic boundary condition ! rx=MIN(IABS(itx-this%itx0),IABS(itx-this%itx0+NTX),IABS(itx-this%itx0-NTX)) ry=MIN(IABS(ity-this%ity0),IABS(ity-this%ity0+NTY),IABS(ity-this%ity0-NTY)) rz=MIN(IABS(itz-this%itz0),IABS(itz-this%itz0+NTZ),IABS(itz-this%itz0-NTZ)) rsrc = sqrt(real(rx**2+ry**2+rz**2,kind=KIND(rsrc))) vsrc = 1.0d0 do ipol = 1,this%Npolsf vsrc = vsrc - this%Psmear(ipol)*rsrc**ipol enddo do is=1,SPIN do ic=1,COL this%wavefunc(ic,is,isp,it)=cmplx(vsrc,0.0d0,kind=KIND(vsrc)) enddo enddo endif enddo enddo enddo enddo end select return end subroutine
Function : | |
ipp : | integer |
ipx : | integer |
ipy : | integer |
ipz : | integer |
periodic boundary condition
function imom(ipx,ipy,ipz) result(ipp) ! ! periodic boundary condition ! implicit none integer :: ipx,ipy,ipz,ipp ipp = 1 + mod(ipz-1+NZ,NZ) + mod(ipy-1+NY,NY)*NZ + mod(ipx-1+NX,NX)*NZ*NY return end function
Function : | |
ipp : | integer |
ipx : | integer |
ipy : | integer |
ipz : | integer |
periodic boundary condition
function imom(ipx,ipy,ipz) result(ipp) ! ! periodic boundary condition ! implicit none integer :: ipx,ipy,ipz,ipp ipp = 1 + mod(ipz-1+NZ,NZ) + mod(ipy-1+NY,NY)*NZ + mod(ipx-1+NX,NX)*NZ*NY return end function
Function : | |
isp : | integer |
ix : | integer |
iy : | integer |
iz : | integer |
function ispace(ix,iy,iz) result(isp) implicit none integer :: ix,iy,iz,isp isp=iz + (iy-1)*NZ + (ix-1)*NZ*NY return end function
Function : | |
isp : | integer |
ix : | integer |
iy : | integer |
iz : | integer |
function ispace(ix,iy,iz) result(isp) implicit none integer :: ix,iy,iz,isp isp=iz + (iy-1)*NZ + (ix-1)*NZ*NY return end function
Function : | |
isp : | integer |
ix : | integer |
iy : | integer |
iz : | integer |
function ispace(ix,iy,iz) result(isp) implicit none integer :: ix,iy,iz,isp isp=iz + (iy-1)*NZ + (ix-1)*NZ*NY return end function
Function : | |
isp : | integer |
ix : | integer |
iy : | integer |
iz : | integer |
function ispace(ix,iy,iz) result(isp) implicit none integer :: ix,iy,iz,isp isp=iz + (iy-1)*NZ + (ix-1)*NZ*NY return end function
Subroutine : | |
this : | type(snk_wavefunc_obj), intent(inout) |
subroutine new_snk_wavefunc(this) implicit none type(snk_wavefunc_obj), intent(inout) :: this call new(this%param) if (allocated(this%wavefunc)) deallocate(this%wavefunc) return end subroutine
Subroutine : | |
this : | type(snk_wavefunc_obj), intent(inout) |
subroutine new_snk_wavefunc(this) implicit none type(snk_wavefunc_obj), intent(inout) :: this call new(this%param) if (allocated(this%wavefunc)) deallocate(this%wavefunc) return end subroutine
Subroutine : | |
this : | type(src_wavefunc_obj), intent(inout) |
subroutine new_src_wavefunc(this) implicit none type(src_wavefunc_obj), intent(inout) :: this call new(this%param) this%itx0 = 1 this%ity0 = 1 this%itz0 = 1 this%itt0 = 1 if (allocated(this%wavefunc)) deallocate(this%wavefunc) return end subroutine
Subroutine : | |
this : | type(src_wavefunc_obj), intent(inout) |
subroutine new_src_wavefunc(this) implicit none type(src_wavefunc_obj), intent(inout) :: this call new(this%param) this%itx0 = 1 this%ity0 = 1 this%itz0 = 1 this%itt0 = 1 if (allocated(this%wavefunc)) deallocate(this%wavefunc) return end subroutine
Subroutine : | |
this : | type(wavefunc_param_obj), intent(inout) |
subroutine new_wavefunc(this) implicit none type(wavefunc_param_obj), intent(inout) :: this this%type = LOCAL_WAV this%itx0 = 1 this%ity0 = 1 this%itz0 = 1 this%itt0 = 1 this%wavefunc(:,:,:,:) = (0.0d0,0.0d0) return end subroutine
Subroutine : | |
this : | type(wavefunc_param_obj), intent(inout) |
subroutine new_wavefunc(this) implicit none type(wavefunc_param_obj), intent(inout) :: this this%type = LOCAL_WAV this%itx0 = 1 this%ity0 = 1 this%itz0 = 1 this%itt0 = 1 this%wavefunc(:,:,:,:) = (0.0d0,0.0d0) return end subroutine
Subroutine : | |
this : | type(snk_wavefunc_obj), intent(inout) |
subroutine print_snk_wavefunc(this) implicit none type(snk_wavefunc_obj), intent(inout) :: this if (nodeid==0) then write(*,'("==== Sink Parameters ====")') endif call print(this%param) return end subroutine
Subroutine : | |
this : | type(snk_wavefunc_obj), intent(inout) |
subroutine print_snk_wavefunc(this) implicit none type(snk_wavefunc_obj), intent(inout) :: this if (nodeid==0) then write(*,'("==== Sink Parameters ====")') endif call print(this%param) return end subroutine
Subroutine : | |
this : | type(src_wavefunc_obj), intent(inout) |
subroutine print_src_wavefunc(this) implicit none type(src_wavefunc_obj), intent(inout) :: this if (nodeid==0) then write(*,'("==== Source Parameters ====")') write(*,'(" Source Center (xyzt):",4I3)') this%itx0,this%ity0,this%itz0,this%itt0 endif call print(this%param) return end subroutine
Subroutine : | |
this : | type(src_wavefunc_obj), intent(inout) |
subroutine print_src_wavefunc(this) implicit none type(src_wavefunc_obj), intent(inout) :: this if (nodeid==0) then write(*,'("==== Source Parameters ====")') write(*,'(" Source Center (xyzt):",4I3)') this%itx0,this%ity0,this%itz0,this%itt0 endif call print(this%param) return end subroutine
Subroutine : | |
this : | type(wavefunc_param_obj), intent(inout) |
subroutine print_wavefunc(this) implicit none type(wavefunc_param_obj), intent(inout) :: this integer :: i if (nodeid==0) then write(*,'("==== Wave function Parameters ====")') write(*,'(" Wave function Center (xyzt):",4I3)') this%itx0,this%ity0,this%itz0,this%itt0 ! wavefunc center select case(this%type) case (LOCAL_WAV) write(*,'(3X," Local Source")') case (EXP_WAV) write(*,'(3X," Exponential Source")') write(*,'(3X," Asmear :",E24.16)')this%Asmear write(*,'(3X," Bsmear :",E24.16)')this%Bsmear case (WALL_WAV) write(*,'(3X," Wall Source")') case (POLY_WAV) write(*,'(3X," Polynomial Source")') write(*,'(3X," Order :",I3)')this%Npolsf write(*,'(3X," Psmear(:) :",100E24.16)') (this%Psmear(i),i=1,this%Npolsf) end select write(*,'(80("="))') endif return end subroutine
Subroutine : | |
this : | type(wavefunc_param_obj), intent(inout) |
subroutine print_wavefunc(this) implicit none type(wavefunc_param_obj), intent(inout) :: this integer :: i if (nodeid==0) then write(*,'("==== Wave function Parameters ====")') write(*,'(" Wave function Center (xyzt):",4I3)') this%itx0,this%ity0,this%itz0,this%itt0 ! wavefunc center select case(this%type) case (LOCAL_WAV) write(*,'(3X," Local Source")') case (EXP_WAV) write(*,'(3X," Exponential Source")') write(*,'(3X," Asmear :",E24.16)')this%Asmear write(*,'(3X," Bsmear :",E24.16)')this%Bsmear case (WALL_WAV) write(*,'(3X," Wall Source")') case (POLY_WAV) write(*,'(3X," Polynomial Source")') write(*,'(3X," Order :",I3)')this%Npolsf write(*,'(3X," Psmear(:) :",100E24.16)') (this%Psmear(i),i=1,this%Npolsf) end select write(*,'(80("="))') endif return end subroutine
Subroutine : | |
iout : | integer, intent(in) |
this : | type(wavefunc_param_obj), intent(inout) |
subroutine read_wavefunc(iout,this) implicit none integer, intent(in) :: iout type(wavefunc_param_obj), intent(inout) :: this integer :: ierr,i if (nodeid==0) then read(iout,*) this%type read(iout,*) this%itx0,this%ity0,this%itz0,this%itt0 endif if (NPU>1) then call comlib_bcast(this%type,0) call comlib_bcast(this%itx0,0) call comlib_bcast(this%ity0,0) call comlib_bcast(this%itz0,0) call comlib_bcast(this%itt0,0) endif if ( this%type < 1 .and. this%type > 5) then write(*,'(" Wave function type error.")') write(*,'(" type = 1:loc, 2:exp, 3:wall, 4:pol, 5:usr")') stop endif if ( (this%itx0 < 1) .or. (this%itx0 > NTX) .or. (this%ity0 < 1) .or. (this%ity0 > NTY) .or. (this%itz0 < 1) .or. (this%itz0 > NTZ) .or. (this%itt0 < 1) .or. (this%itt0 > NTT) ) then write(*,'(" Source center (x,y,z,t) error.")') write(*,'(" x<=[1,NTX], y<=[1,NTY], z<=[1,NTZ], t<=[1,NTT]")') stop endif if (nodeid==0) then if ( ( this%type == LOCAL_WAV) .OR. ( this%type == WALL_WAV) ) then ! local or wall source function continue else if ( this%type == EXP_WAV) then ! exponential source function read(iout,*)this%Asmear,this%Bsmear else if ( this%type == POLY_WAV) then ! polynomial source function read(iout,*)this%Npolsf ! read order of polynomial if ( this%Npolsf > MAXPOL) then write(*,'(" Error Npolsf > MAXPOL")') ierr=1 goto 100 endif read(iout,*)(this%Psmear(i),i=1,this%Npolsf) ! read polynomial coeffcients endif endif 100 if (ierr==1) stop if (NPU>1) then call comlib_bcast(this%Asmear,0) call comlib_bcast(this%Bsmear,0) call comlib_bcast(this%Npolsf,0) if (this%type== POLY_WAV) then do i=1,this%Npolsf call comlib_bcast(this%Psmear(i),0) enddo endif endif return end subroutine
Subroutine : | |
iout : | integer, intent(in) |
this : | type(wavefunc_param_obj), intent(inout) |
subroutine read_wavefunc(iout,this) implicit none integer, intent(in) :: iout type(wavefunc_param_obj), intent(inout) :: this integer :: ierr,i if (nodeid==0) then read(iout,*) this%type read(iout,*) this%itx0,this%ity0,this%itz0,this%itt0 endif if (NPU>1) then call comlib_bcast(this%type,0) call comlib_bcast(this%itx0,0) call comlib_bcast(this%ity0,0) call comlib_bcast(this%itz0,0) call comlib_bcast(this%itt0,0) endif if ( this%type < 1 .and. this%type > 5) then write(*,'(" Wave function type error.")') write(*,'(" type = 1:loc, 2:exp, 3:wall, 4:pol, 5:usr")') stop endif if ( (this%itx0 < 1) .or. (this%itx0 > NTX) .or. (this%ity0 < 1) .or. (this%ity0 > NTY) .or. (this%itz0 < 1) .or. (this%itz0 > NTZ) .or. (this%itt0 < 1) .or. (this%itt0 > NTT) ) then write(*,'(" Source center (x,y,z,t) error.")') write(*,'(" x<=[1,NTX], y<=[1,NTY], z<=[1,NTZ], t<=[1,NTT]")') stop endif if (nodeid==0) then if ( ( this%type == LOCAL_WAV) .OR. ( this%type == WALL_WAV) ) then ! local or wall source function continue else if ( this%type == EXP_WAV) then ! exponential source function read(iout,*)this%Asmear,this%Bsmear else if ( this%type == POLY_WAV) then ! polynomial source function read(iout,*)this%Npolsf ! read order of polynomial if ( this%Npolsf > MAXPOL) then write(*,'(" Error Npolsf > MAXPOL")') ierr=1 goto 100 endif read(iout,*)(this%Psmear(i),i=1,this%Npolsf) ! read polynomial coeffcients endif endif 100 if (ierr==1) stop if (NPU>1) then call comlib_bcast(this%Asmear,0) call comlib_bcast(this%Bsmear,0) call comlib_bcast(this%Npolsf,0) if (this%type== POLY_WAV) then do i=1,this%Npolsf call comlib_bcast(this%Psmear(i),0) enddo endif endif return end subroutine
Subroutine : | |
this : | type(src_wavefunc_obj), intent(inout) |
iout : | integer, intent(in) |
subroutine read_src_wavefunc(this,iout) use error_class implicit none type(src_wavefunc_obj), intent(inout) :: this integer, intent(in) :: iout ! ! read source center,time ! if (nodeid==0) then read(iout,*) this%itx0,this%ity0,this%itz0,this%itt0 endif if (NPU>1) then call comlib_bcast(this%itx0,0) call comlib_bcast(this%ity0,0) call comlib_bcast(this%itz0,0) call comlib_bcast(this%itt0,0) endif if ( (this%itx0 < 1) .or. (this%itx0 > NTX) .or. (this%ity0 < 1) .or. (this%ity0 > NTY) .or. (this%itz0 < 1) .or. (this%itz0 > NTZ) .or. (this%itt0 < 1) .or. (this%itt0 > NTT)) then call error_message(" Source center (x,y,z,t) error.") call error_stop(" x<=[1,NTX], y<=[1,NTY], z<=[1,NTZ] t<=[1,NTT]") endif ! ! read source wave function parameters ! call read(this%param,iout) return end subroutine
Subroutine : | |
this : | type(src_wavefunc_obj), intent(inout) |
iout : | integer, intent(in) |
subroutine read_src_wavefunc(this,iout) use error_class implicit none type(src_wavefunc_obj), intent(inout) :: this integer, intent(in) :: iout ! ! read source center,time ! if (nodeid==0) then read(iout,*) this%itx0,this%ity0,this%itz0,this%itt0 endif if (NPU>1) then call comlib_bcast(this%itx0,0) call comlib_bcast(this%ity0,0) call comlib_bcast(this%itz0,0) call comlib_bcast(this%itt0,0) endif if ( (this%itx0 < 1) .or. (this%itx0 > NTX) .or. (this%ity0 < 1) .or. (this%ity0 > NTY) .or. (this%itz0 < 1) .or. (this%itz0 > NTZ) .or. (this%itt0 < 1) .or. (this%itt0 > NTT)) then call error_message(" Source center (x,y,z,t) error.") call error_stop(" x<=[1,NTX], y<=[1,NTY], z<=[1,NTZ] t<=[1,NTT]") endif ! ! read source wave function parameters ! call read(this%param,iout) return end subroutine
Derived Type : | |
param : | type(wavefunc_param_obj) |
wavefunc(:) : | complex(DP), allocatable |
quark sink wavefunction
Derived Type : | |
param : | type(wavefunc_param_obj) |
wavefunc(:) : | complex(DP), allocatable |
quark sink wavefunction
Derived Type : | |||
param : | type(wavefunc_param_obj) | ||
wavefunc(:,:,:,:) : | complex(DP), allocatable
| ||
itx0 : | integer
| ||
ity0 : | integer
| ||
itz0 : | integer
| ||
itt0 : | integer
|
quark source wavefunction
Derived Type : | |||
param : | type(wavefunc_param_obj) | ||
wavefunc(:,:,:,:) : | complex(DP), allocatable
| ||
itx0 : | integer
| ||
ity0 : | integer
| ||
itz0 : | integer
| ||
itt0 : | integer
|
quark source wavefunction
Derived Type : | |||
type : | integer
| ||
Npolsf : | integer
| ||
idummy(2) : | integer | ||
Asmear : | real(DP)
| ||
Bsmear : | real(DP)
| ||
Psmear(MAXPOL_WAV) : | real(DP)
|
quark source function parameters
Original external subprogram is wavefunc_param_class#wavefunc_param_obj
Derived Type : | |||
type : | integer
| ||
Npolsf : | integer
| ||
idummy(2) : | integer | ||
Asmear : | real(DP)
| ||
Bsmear : | real(DP)
| ||
Psmear(MAXPOL_WAV) : | real(DP)
|
quark source function parameters
Original external subprogram is wavefunc_param_class#wavefunc_param_obj
Derived Type : | |||
type : | integer
| ||
Npolsf : | integer
| ||
idummy(2) : | integer | ||
Asmear : | real(DP)
| ||
Bsmear : | real(DP)
| ||
Psmear(MAXPOL_WAV) : | real(DP)
|
quark source function parameters
Original external subprogram is wavefunc_param_class#wavefunc_param_obj
Derived Type : | |||
type : | integer
| ||
itx0 : | integer
| ||
ity0 : | integer
| ||
itz0 : | integer
| ||
itt0 : | integer
| ||
Npolsf : | integer
| ||
Asmear : | real(8)
| ||
Bsmear : | real(8)
| ||
Psmear(MAXPOL) : | real(8)
| ||
wavefunc(COL,SPIN,NSPACE,NT) : | complex(8)
|
quark source function parameters
Derived Type : | |||
type : | integer
| ||
itx0 : | integer
| ||
ity0 : | integer
| ||
itz0 : | integer
| ||
itt0 : | integer
| ||
Npolsf : | integer
| ||
Asmear : | real(8)
| ||
Bsmear : | real(8)
| ||
Psmear(MAXPOL) : | real(8)
| ||
wavefunc(COL,SPIN,NSPACE,NT) : | complex(8)
|
quark source function parameters