Class | meson_class |
In: |
MeasureClass/OLDS/meson_class.F90
MeasureClass/BK/meson_class.F90 |
Subroutine : | |
this : | type(meson_prop), intent(inout) |
subroutine delete_mprop(this) implicit none type(meson_prop), intent(inout) :: this real(DP) :: etime character(CHARLEN) :: str select type(p => this%param) #ifdef _CLOVER type is (quark_clover) #else type is (quark_wilson) #endif call delete(p) type is (quark_truncd_dw_overlap) call delete(p) end select deallocate(this%param) write(*,*)"delete quark" call delete(this%wf) deallocate(this%wf) write(*,*)"delete wf" call toc(m_etime) if (.not.is_measured(this)) then call delete(m_etime) return endif etime = get_elapse(m_etime) write(str,'("%M ETIME:",E24.15)')etime call print(this%log_file_meson,str) call delete(this%log_file_meson) call delete(this%log_file_solver) write(*,*)"delete logs" if (0==nodeid) then write(*,'(" ETIME:",E24.15)')etime write(*,'(80("-"))') endif call delete(m_etime) write(*,*)"delete etime" return end subroutine
Subroutine : | |
this : | type(meson_prop), intent(inout) |
subroutine delete_mprop(this) implicit none type(meson_prop), intent(inout) :: this real(DP) :: etime character(CHARLEN) :: str select type(p => this%param) #ifdef _CLOVER type is (quark_clover) #else type is (quark_wilson) #endif call delete(p) type is (quark_truncd_dw_overlap) call delete(p) end select deallocate(this%param) write(*,*)"delete quark" call delete(this%wf) deallocate(this%wf) write(*,*)"delete wf" call toc(m_etime) if (.not.is_measured(this)) then call delete(m_etime) return endif etime = get_elapse(m_etime) write(str,'("%M ETIME:",E24.15)')etime call print(this%log_file_meson,str) call delete(this%log_file_meson) call delete(this%log_file_solver) write(*,*)"delete logs" if (0==nodeid) then write(*,'(" ETIME:",E24.15)')etime write(*,'(80("-"))') endif call delete(m_etime) write(*,*)"delete etime" return end subroutine
Subroutine : | |
this : | type(meson_prop), intent(inout) |
u : | type(vfield_gluon_wg), intent(in) |
subroutine get_mprop(this,u) use qprop_class use field_fermion_class, only : zgamma,igamma implicit none type(meson_prop), intent(inout) :: this type(vfield_gluon_wg), intent(in) :: u type(quark_prop), allocatable :: qp integer :: idir,it,ic,is,jc,js,ixyz complex(DP) :: ctmp,zsnk,zsrc integer :: js_src,is_snk character(CHARLEN) :: str integer :: iout if (.not.is_measured(this)) return iout = get_file_unit(this%log_file_solver) allocate(qp) call new(qp,iout=iout) qp%tol = this%tol qp%parameter => this%param qp%wf => this%wf call get(qp,u) do it=1,NT ! ! PS ! ctmp = Z0 !$OMP PARALLEL DO PRIVATE(ixyz,ic,is) REDUCTION(+:ctmp) do ixyz=1,NX*NY*NZ do js=1,SPIN do is=1,SPIN do jc=1,COL do ic=1,COL ctmp = ctmp + real(qp%qprop(ic,jc,is,js,ixyz,it))**2 +aimag(qp%qprop(ic,jc,is,js,ixyz,it))**2 enddo enddo enddo enddo enddo #ifndef _singlePU call comlib_sumcast(ctmp) #endif this%mprop(it,1) = ctmp do idir=1,3 ! ! vector x ! ctmp = Z0 !$OMP PARALLEL DO PRIVATE(ixyz,ic,is,zsrc,js_src,zsnk,is_snk) REDUCTION(+:ctmp) do ixyz=1,NX*NY*NZ do js=1,SPIN do is=1,SPIN zsrc = zgamma(igamma(js,idir),5)*zgamma(js,idir) js_src = igamma(igamma(js,idir),5) zsnk = zgamma(igamma(is,5),idir)*zgamma(is, 5) is_snk = igamma(igamma(is,5),idir) do jc=1,COL do ic=1,COL ctmp = ctmp + zsrc*conjg(qp%qprop(ic,jc,is,js_src,ixyz,it)) *zsnk* qp%qprop(ic,jc,is_snk,js,ixyz,it) enddo enddo enddo enddo enddo #ifndef _singlePU call comlib_sumcast(ctmp) #endif this%mprop(it,1+idir) = ctmp enddo enddo qp%parameter => NULL() qp%wf => NULL() call delete(qp) deallocate(qp) return end subroutine
Subroutine : | |
this : | type(meson_prop), intent(inout) |
u : | type(vfield_gluon_wg), intent(in) |
subroutine get_mprop(this,u) use qprop_class use field_fermion_class, only : zgamma,igamma implicit none type(meson_prop), intent(inout) :: this type(vfield_gluon_wg), intent(in) :: u type(quark_prop), allocatable :: qp integer :: idir,it,ic,is,jc,js,ixyz complex(DP) :: ctmp,zsnk,zsrc integer :: js_src,is_snk character(CHARLEN) :: str integer :: iout if (.not.is_measured(this)) return iout = get_file_unit(this%log_file_solver) allocate(qp) call new(qp,iout=iout) qp%tol = this%tol qp%parameter => this%param qp%wf => this%wf call get(qp,u) do it=1,NT ! ! PS ! ctmp = Z0 !$OMP PARALLEL DO PRIVATE(ixyz,ic,is) REDUCTION(+:ctmp) do ixyz=1,NX*NY*NZ do js=1,SPIN do is=1,SPIN do jc=1,COL do ic=1,COL ctmp = ctmp + real(qp%qprop(ic,jc,is,js,ixyz,it))**2 +aimag(qp%qprop(ic,jc,is,js,ixyz,it))**2 enddo enddo enddo enddo enddo #ifndef _singlePU call comlib_sumcast(ctmp) #endif this%mprop(it,1) = ctmp do idir=1,3 ! ! vector x ! ctmp = Z0 !$OMP PARALLEL DO PRIVATE(ixyz,ic,is,zsrc,js_src,zsnk,is_snk) REDUCTION(+:ctmp) do ixyz=1,NX*NY*NZ do js=1,SPIN do is=1,SPIN zsrc = zgamma(igamma(js,idir),5)*zgamma(js,idir) js_src = igamma(igamma(js,idir),5) zsnk = zgamma(igamma(is,5),idir)*zgamma(is, 5) is_snk = igamma(igamma(is,5),idir) do jc=1,COL do ic=1,COL ctmp = ctmp + zsrc*conjg(qp%qprop(ic,jc,is,js_src,ixyz,it)) *zsnk* qp%qprop(ic,jc,is_snk,js,ixyz,it) enddo enddo enddo enddo enddo #ifndef _singlePU call comlib_sumcast(ctmp) #endif this%mprop(it,1+idir) = ctmp enddo enddo qp%parameter => NULL() qp%wf => NULL() call delete(qp) deallocate(qp) return end subroutine
Derived Type : | |
mprop(NT,CH) : | complex(DP) |
param => NULL() : | class(quark_wilson), pointer |
wf => NULL() : | type(wavefunc), pointer |
traj = 0 : | integer |
traj_interval_measure = 0 : | integer |
quark_type = 0 : | integer |
fname_quark ="measure_quark_param" : | character(CHARLEN) |
fname_meson ="mprop." : | character(CHARLEN) |
fname_solver ="log_solver_measurement." : | character(CHARLEN) |
log_file_meson : | type(logfile) |
log_file_solver : | type(logfile) |
Derived Type : | |
mprop(NT,CH) : | complex(DP) |
param => NULL() : | class(quark_wilson), pointer |
wf => NULL() : | type(wavefunc), pointer |
traj = 0 : | integer |
traj_interval_measure = 0 : | integer |
quark_type = 0 : | integer |
fname_quark ="measure_quark_param" : | character(CHARLEN) |
fname_meson ="mprop." : | character(CHARLEN) |
fname_solver ="log_solver_measurement." : | character(CHARLEN) |
log_file_meson : | type(logfile) |
log_file_solver : | type(logfile) |
tol : | real(DP) |
Subroutine : | |
this : | type(meson_prop), intent(inout) |
quark_fname : | character(len=*), intent(in) |
status : | type(hmc_status), target, intent(in) |
subroutine new_mprop(this,quark_fname,status) use file_tools_class use error_class implicit none type(meson_prop), intent(inout) :: this character(len=*), intent(in) :: quark_fname type(hmc_status), target, intent(in) :: status integer :: quark_type integer :: iout character(CHARLEN) :: fname call new(m_etime) call tic(m_etime) if (associated(this%wf)) then call delete(this%wf) deallocate(this%wf) endif allocate(this%wf) call new(this%wf) this%fname_quark = REPEAT(' ',LEN(this%fname_quark)) this%fname_quark = TRIM(quark_fname) this%mprop(:,:) = Z0 iout = search_free_file_unit() if (0 == nodeid) then write(*,'(80("="))') write(*,'(" Read Quark file: ",A)')TRIM(this%fname_quark) open(iout,file=TRIM(ADJUSTL(this%fname_quark)),form='formatted',status='old') read(iout,*) ! comment line read(iout,*) this%traj_interval_measure read(iout,*) ! comment line read(iout,*) this%quark_type read(iout,*) ! comment line endif #ifndef _singlePU call comlib_bcast(this%traj_interval_measure,0) call comlib_bcast(this%quark_type,0) #endif select case(this%quark_type) case(1) #ifdef _CLOVER allocate(quark_clover::this%param) if (0==nodeid) write(*,'(" Clover Type quark:")') #else allocate(quark_wilson::this%param) if (0==nodeid) write(*,'(" Wilson Type quark:")') #endif case(2) allocate(quark_truncd_dw_overlap::this%param) if (0==nodeid) write(*,'(" DW-Overlap Type quark:")') case default call error_stop("error in quark_type: new_mprop.") end select select type(p => this%param) #ifdef _CLOVER type is (quark_clover) #else type is (quark_wilson) #endif call new(p,id=0) call read(p,iout) type is (quark_truncd_dw_overlap) call new(p,id=0) call read(p,iout) call set_coef(p) end select if (0 == nodeid) then read(iout,*) ! comment line read(iout,*) this%tol ! read solver tolerance read(iout,*) ! comment line endif #ifndef _singlePU call comlib_bcast(this%tol,0) #endif call read(this%wf,iout) if (0 == nodeid) then close(iout) write(*,'(" Read Quark file OK")') endif this%traj = get_trajectory_number(status) if (.not.is_measured(this)) return if (0==nodeid) then write(*,'(80("-"))') write(*,'(" Measurment MESON @ traj=",I6)') this%traj select type(p => this%param) #ifdef _CLOVER type is (quark_clover) #else type is (quark_wilson) #endif call print(p) type is (quark_truncd_dw_overlap) call print(p) end select endif write(fname,'(A,I6.6)')TRIM(ADJUSTL(this%fname_meson)),this%traj call new(this%log_file_meson,fname) write(fname,'(A,I6.6)')TRIM(ADJUSTL(this%fname_solver)),this%traj call new(this%log_file_solver,fname) call print(this%log_file_solver,"# measurement solver log") return end subroutine
Subroutine : | |
this : | type(meson_prop), intent(inout) |
quark_fname : | character(len=*), intent(in) |
status : | type(hmc_status), target, intent(in) |
subroutine new_mprop(this,quark_fname,status) use file_tools_class use error_class implicit none type(meson_prop), intent(inout) :: this character(len=*), intent(in) :: quark_fname type(hmc_status), target, intent(in) :: status integer :: quark_type integer :: iout character(CHARLEN) :: fname call new(m_etime) call tic(m_etime) if (associated(this%wf)) then call delete(this%wf) deallocate(this%wf) endif allocate(this%wf) call new(this%wf) this%fname_quark = REPEAT(' ',LEN(this%fname_quark)) this%fname_quark = TRIM(quark_fname) this%mprop(:,:) = Z0 iout = search_free_file_unit() if (0 == nodeid) then write(*,'(80("="))') write(*,'(" Read Quark file: ",A)')TRIM(this%fname_quark) open(iout,file=TRIM(ADJUSTL(this%fname_quark)),form='formatted',status='old') read(iout,*) ! comment line read(iout,*) this%traj_interval_measure read(iout,*) ! comment line read(iout,*) this%quark_type read(iout,*) ! comment line endif #ifndef _singlePU call comlib_bcast(this%traj_interval_measure,0) call comlib_bcast(this%quark_type,0) #endif select case(this%quark_type) case(1) #ifdef _CLOVER allocate(quark_clover::this%param) if (0==nodeid) write(*,'(" Clover Type quark:")') #else allocate(quark_wilson::this%param) if (0==nodeid) write(*,'(" Wilson Type quark:")') #endif case(2) allocate(quark_truncd_dw_overlap::this%param) if (0==nodeid) write(*,'(" DW-Overlap Type quark:")') case default call error_stop("error in quark_type: new_mprop.") end select select type(p => this%param) #ifdef _CLOVER type is (quark_clover) #else type is (quark_wilson) #endif call new(p,id=0) call read(p,iout) type is (quark_truncd_dw_overlap) call new(p,id=0) call read(p,iout) call set_coef(p) end select if (0 == nodeid) then read(iout,*) ! comment line read(iout,*) this%tol ! read solver tolerance read(iout,*) ! comment line endif #ifndef _singlePU call comlib_bcast(this%tol,0) #endif call read(this%wf,iout) if (0 == nodeid) then close(iout) write(*,'(" Read Quark file OK")') endif this%traj = get_trajectory_number(status) if (.not.is_measured(this)) return if (0==nodeid) then write(*,'(80("-"))') write(*,'(" Measurment MESON @ traj=",I6)') this%traj select type(p => this%param) #ifdef _CLOVER type is (quark_clover) #else type is (quark_wilson) #endif call print(p) type is (quark_truncd_dw_overlap) call print(p) end select endif write(fname,'(A,I6.6)')TRIM(ADJUSTL(this%fname_meson)),this%traj call new(this%log_file_meson,fname) write(fname,'(A,I6.6)')TRIM(ADJUSTL(this%fname_solver)),this%traj call new(this%log_file_solver,fname) call print(this%log_file_solver,"# measurement solver log") return end subroutine
Subroutine : | |
this : | type(meson_prop), intent(inout) |
subroutine print_mprop(this) implicit none type(meson_prop), intent(inout) :: this if (0==nodeid) then write(*,'(80("-"))') write(*,'("Meson Parmeters:")') write(*,'(" Quark Parameters:")') select type(p => this%param) #ifdef _CLOVER type is (quark_clover) #else type is (quark_wilson) #endif call print(p) type is (quark_truncd_dw_overlap) call print(p) end select write(*,'(" Solver tolerance:",E24.15)')this%tol write(*,*) write(*,'(" Wavefunction Parameters:")') endif call print(this%wf) if (0==nodeid) then write(*,'(" Measure Skip Traj:",I6)') this%traj_interval_measure write(*,'(80("-"))') endif return end subroutine
Subroutine : | |
this : | type(meson_prop), intent(inout) |
subroutine print_mprop(this) implicit none type(meson_prop), intent(inout) :: this if (0==nodeid) then write(*,'(80("-"))') write(*,'("Meson Parmeters:")') write(*,'(" Quark Parameters:")') select type(p => this%param) #ifdef _CLOVER type is (quark_clover) #else type is (quark_wilson) #endif call print(p) type is (quark_truncd_dw_overlap) call print(p) end select write(*,'(" Solver tolerance:",E24.15)')this%tol write(*,*) write(*,'(" Wavefunction Parameters:")') endif call print(this%wf) if (0==nodeid) then write(*,'(" Measure Skip Traj:",I6)') this%traj_interval_measure write(*,'(80("-"))') endif return end subroutine
Subroutine : | |
this : | type(meson_prop), intent(inout) |
subroutine save_mprop(this) implicit none type(meson_prop), intent(inout) :: this integer :: jtt,itt character(CHARLEN) :: str if (.not.is_measured(this)) return if (0==nodeid) then write(str,'("%M iout=",I3)')get_file_unit(this%log_file_meson) call print(this%log_file_meson,TRIM(str)) write(str,'("%M TRAJ TIME PS Vx Vy Vz")') call print(this%log_file_meson,TRIM(str)) do itt=0,NTT-1 jtt = mod(itt + (this%wf%itt0-1) + NTT,NTT)+1 write(str,'("%M",I6,I4,4(2E24.15))')this%traj,itt, this%mprop(jtt,1),this%mprop(jtt,2),this%mprop(jtt,3),this%mprop(jtt,4) call print(this%log_file_meson,TRIM(str)) enddo write(str,'("%M",80("="))') call print(this%log_file_meson,TRIM(str)) endif return end subroutine