Class | qprop_class |
In: |
MeasureClass/OLDS/qprop_class.F90
MeasureClass/BK/qprop_class.F90 |
Subroutine : | |
this : | type(quark_prop), intent(inout) |
subroutine delete_qprop(this) implicit none type(quark_prop), intent(inout) :: this return end subroutine
Subroutine : | |
this : | type(quark_prop), intent(inout) |
subroutine delete_qprop(this) implicit none type(quark_prop), intent(inout) :: this return end subroutine
Subroutine : | |
this : | type(quark_prop), intent(inout) |
u : | type(vfield_gluon_wg), intent(in) |
subroutine get_qprop(this,u) use comlib implicit none type(quark_prop), intent(inout) :: this type(vfield_gluon_wg), intent(in) :: u type(field_quark_wg), allocatable :: y type(field_quark_wg), allocatable :: dy integer :: ix,iy,iz,it,is,ic,js,jc,ixyz integer :: ieo,ieoxyz,ith integer :: iout,iiter integer :: itry real(DP) :: tol, rtmp0, rtmp1 allocate(y,dy) call new(y) call new(dy) if (.not.associated(this%wf)) then call error_stop("please assign wavefunction pointer for qprop.") endif do js=1,SPIN do jc=1,COL ! ! set local source ! if (0==nodeid) then select case(this%wf%type) case(TYPE_WF_LOCAL) write(*,'("%M Set source TYPE= LOCAL")') case(TYPE_WF_JACOBI) write(*,'("%M Set source TYPE= JACOBI, Nsmr=",I3," Ksrm=",E24.15)')this%wf%Nsmr,this%wf%Ksmr end select write(*,'("%M (col,spin)=(",I3,",",I3,") at ")',advance='no') jc,js write(*,'("(it,iz,iy,ix)=(",I3,",",I3,",",I3,",",I3,")")') this%wf%itt0,this%wf%itz0,this%wf%ity0,this%wf%itx0 endif call set_source(this%wf,jc,js,y,u) iout = this%iout tol = this%tol iiter = this%iiter if (0==nodeid) write(iout,'("# iout=",I3," tol=",E24.15," maxiter=",I6)')iout,tol,iiter #ifdef _DEBUG if (0==nodeid) write( *,'("# iout=",I3," tol=",E24.15," maxiter=",I6)')iout,tol,iiter #endif select type(parameter => this%parameter) type is (quark_truncd_dw_overlap) call assign_inv_mult_ov(parameter,iout,tol,iiter,dy,y,u) #ifdef _CLOVER type is (quark_clover) #else type is (quark_wilson) #endif call assign_inv_mult_wd(parameter,iout,tol,iiter,dy,y,u) end select !$OMP PARALLEL DO PRIVATE(ix,iy,iz,ixyz,it,ieo,ith,is,ic) do ix=1,NX do iy=1,NY do iz=1,NZ ixyz = iz + (iy-1)*NZ + (ix-1)*NZ*NY do it=1,NT ieo = mod(ipeo+it+iz+iy+ix,2) ith = it/2 do is=1,SPIN do ic=1,COL this%qprop(ic,jc,is,js,ixyz,it) = dy%eo(ieo)%s(ith,iz,iy,ix)%y(ic,is) enddo enddo enddo enddo enddo enddo rtmp0 = abs2(dy) rtmp1 = abs2(y) if (0 == nodeid) then write(iout,'("%M Dy^2=",E24.15," y^2=",E24.15)')rtmp0,rtmp1 #ifdef _DEBUG write( *,'("%M Dy^2=",E24.15," y^2=",E24.15)')rtmp0,rtmp1 #endif endif #ifdef _PERFMON_ call error_stop("stop for performace monitoring.") #endif enddo enddo !call comlib_finalize() !stop deallocate(y,dy) return end subroutine
Subroutine : | |
this : | type(quark_prop), intent(inout) |
u : | type(vfield_gluon_wg), intent(in) |
subroutine get_qprop(this,u) use comlib implicit none type(quark_prop), intent(inout) :: this type(vfield_gluon_wg), intent(in) :: u type(field_quark_wg), allocatable :: y type(field_quark_wg), allocatable :: dy integer :: ix,iy,iz,it,is,ic,js,jc,ixyz integer :: ieo,ieoxyz,ith integer :: iout,iiter integer :: itry real(DP) :: tol, rtmp0, rtmp1 allocate(y,dy) call new(y) call new(dy) if (.not.associated(this%wf)) then call error_stop("please assign wavefunction pointer for qprop.") endif do js=1,SPIN do jc=1,COL ! ! set local source ! if (0==nodeid) then select case(this%wf%type) case(TYPE_WF_LOCAL) write(*,'("%M Set source TYPE= LOCAL")') case(TYPE_WF_JACOBI) write(*,'("%M Set source TYPE= JACOBI, Nsmr=",I3," Ksrm=",E24.15)')this%wf%Nsmr,this%wf%Ksmr end select write(*,'("%M (col,spin)=(",I3,",",I3,") at ")',advance='no') jc,js write(*,'("(it,iz,iy,ix)=(",I3,",",I3,",",I3,",",I3,")")') this%wf%itt0,this%wf%itz0,this%wf%ity0,this%wf%itx0 endif call set_source(this%wf,jc,js,y,u) iout = this%iout tol = this%tol iiter = this%iiter if (0==nodeid) write(iout,'("# iout=",I3," tol=",E24.15," maxiter=",I6)')iout,tol,iiter #ifdef _DEBUG if (0==nodeid) write( *,'("# iout=",I3," tol=",E24.15," maxiter=",I6)')iout,tol,iiter #endif select type(parameter => this%parameter) type is (quark_truncd_dw_overlap) call assign_inv_mult_ov(parameter,iout,tol,iiter,dy,y,u) #ifdef _CLOVER type is (quark_clover) #else type is (quark_wilson) #endif call assign_inv_mult_wd(parameter,iout,tol,iiter,dy,y,u) end select !$OMP PARALLEL DO PRIVATE(ix,iy,iz,ixyz,it,ieo,ith,is,ic) do ix=1,NX do iy=1,NY do iz=1,NZ ixyz = iz + (iy-1)*NZ + (ix-1)*NZ*NY do it=1,NT ieo = mod(ipeo+it+iz+iy+ix,2) ith = it/2 do is=1,SPIN do ic=1,COL this%qprop(ic,jc,is,js,ixyz,it) = dy%eo(ieo)%s(ith,iz,iy,ix)%y(ic,is) enddo enddo enddo enddo enddo enddo rtmp0 = abs2(dy) rtmp1 = abs2(y) if (0 == nodeid) then write(iout,'("%M Dy^2=",E24.15," y^2=",E24.15)')rtmp0,rtmp1 #ifdef _DEBUG write( *,'("%M Dy^2=",E24.15," y^2=",E24.15)')rtmp0,rtmp1 #endif endif #ifdef _PERFMON_ call error_stop("stop for performace monitoring.") #endif enddo enddo !call comlib_finalize() !stop deallocate(y,dy) return end subroutine
Function : | |
str : | character(len=CHARLEN) |
this : | type(quark_prop), intent(in) |
function get_parameter_str_qprop(this) result(str) implicit none type(quark_prop), intent(in) :: this character(len=CHARLEN) :: str select type(parameter => this%parameter) type is (quark_truncd_dw_overlap) #ifdef _CLOVER type is (quark_clover) #else type is (quark_wilson) #endif write(str,'("kappa=",F14.6)')get_kappa(parameter) end select return end function
Subroutine : | |
this : | type(quark_prop), intent(inout) |
iout : | integer, optional, intent(in) |
subroutine new_qprop(this,iout) use file_tools_class implicit none type(quark_prop), intent(inout) :: this integer, optional, intent(in) :: iout if (present(iout)) then this%iout = iout else this%iout = search_free_file_unit() endif this%tol = 1.0e-14_DP this%iiter = 10000 return end subroutine
Subroutine : | |
this : | type(quark_prop), intent(inout) |
iout : | integer, optional, intent(in) |
subroutine new_qprop(this,iout) use file_tools_class implicit none type(quark_prop), intent(inout) :: this integer, optional, intent(in) :: iout if (present(iout)) then this%iout = iout else this%iout = search_free_file_unit() endif this%tol = 1.0e-14_DP this%iiter = 10000 return end subroutine