Class meson_class
In: MeasureClass/OLDS/meson_class.F90
MeasureClass/BK/meson_class.F90
comlib lattice_class logfile_class timer_class field_gauge_class quark_clover_class quark_wilson_class hmc_std_quark_wilson_class quark_dwf_class quark_dw_ovlp_class hmc_status_class wavefunction_class file_tools_class error_class qprop_class field_fermion_class meson_class dot/f_83.png

Methods

delete   delete   get   get   meson_prop   meson_prop   new   new   print   print   save  

Included Modules

comlib lattice_class logfile_class timer_class field_gauge_class quark_clover_class quark_wilson_class hmc_std_quark_wilson_class quark_dwf_class quark_dw_ovlp_class hmc_status_class wavefunction_class file_tools_class error_class qprop_class field_fermion_class

Public Instance methods

Subroutine :
this :type(meson_prop), intent(inout)

[Source]

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)

[Source]

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)

[Source]

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)

[Source]

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
meson_prop
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)
meson_prop
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)

[Source]

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)

[Source]

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)

[Source]

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)

[Source]

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)

[Source]

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