Class lma_class
In: SingletMesons_Simple_v1.3/VERYOLD/OBSOLETE3/lma_class.F90
timer_class comlib print_status_class filename lattice_class solver_parameter_class inverse_class logging_class gauge_field_class gauge_field_dd_class single_prec_class wilson_quark_field_class wilson_quark_field_dd_class wilson_quark_dd_class s_cchlf_class clover_quark_class clover_quark_dd_class wilson_quark_parameter_class gauge_dd_class quark_prop_class wavefunc_class fftw3_class hadron_class gamma_matrix_class lma_class dot/f_97.png

Methods

Included Modules

timer_class comlib print_status_class filename lattice_class solver_parameter_class inverse_class logging_class gauge_field_class gauge_field_dd_class single_prec_class wilson_quark_field_class wilson_quark_field_dd_class wilson_quark_dd_class s_cchlf_class clover_quark_class clover_quark_dd_class wilson_quark_parameter_class gauge_dd_class quark_prop_class wavefunc_class fftw3_class hadron_class gamma_matrix_class

Public Instance methods

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

[Source]

subroutine delete_lowmode_op(this)
  implicit none
  type(lowmode_op_obj), intent(inout) :: this
  deallocate(this%X)
  return
end subroutine
Subroutine :
this :type(lowmode_obj), intent(inout)
csw :real(8), intent(in)
u :type(gvfield_dd_wg_obj), intent(in)

[Source]

subroutine get_lowmode(this,csw,u)
  implicit none
  type(lowmode_obj), intent(inout) :: this
  real(8), intent(in) :: csw
  type(gvfield_dd_wg_obj), intent(in) :: u
  type(wqfield_dd_wg_obj), pointer :: w
  type(wqfield_dd_wg_obj), pointer :: s(:),r
#ifdef _CLOVER
  real(8) :: dummy
  type(ctfield_dd_obj),   pointer :: ucl
  type(cchlfield_dd_obj), pointer :: fclinv,fcl
  type(cchmfield_dd_obj), pointer :: f1,f2
#endif
  type(wilson_quark_parameter_obj) :: quark_param
  real(8) :: rtmp,err
  complex(8) :: ctmp,BB(this%NEV,this%NEV)
  integer :: i,j,k
  integer :: ic,is,isp,jc,js,jqp,iqp
  integer :: ieo,ideo,id,ibx,iby,ibz,ieoxyz,ibth,ibt
  integer :: idx,idy,idz,idt,idd
  integer :: ix,iy,iz,it,iev

!=======================================================
! for dummy parameter to extract (hopping + clover) term
!=======================================================
  quark_param%kappa=0.125d0  ! dummy kappa
#ifdef _CLOVER
  quark_param%csw  =csw
!=================================
! calc clover term
! ucl    : clover leaf field str.
! fclinv : inverse clover term
! fcl    : normal clover term
!=================================
  allocate(ucl,f1,f2,fclinv,fcl)
  call make_clover_term(ucl,u)
  call make_inverse_clover_term(quark_param,fclinv,ucl,dummy,0) 
  call clover_f1f2(quark_param%kappa,quark_param%csw,f1,f2,ucl)
  call conv_matrix_to_linear(f1,f2,fcl)
  deallocate(ucl,f1,f2)
#else
  quark_param%csw  =0.0d0
#endif

  allocate(w)
  call new(w)

!====================================
! compute small dirac matrix
!
!  R = V'*D*V
!
!====================================
  do j=1,this%NEV
#ifdef _CLOVER
    call mult_wilson_dirac(quark_param%kappa,this%V(j),w,u,fclinv)
    call mult_clover_term(w,fcl)
#else
    call mult_wilson_dirac(quark_param%kappa,this%V(j),w,u)
#endif
    do i=1,this%NEV
      this%R(i,j) = prod(this%V(i),w)
    enddo
  enddo

#ifdef _DEBUG_
!====================================
!  Check Orthgonality
!====================================
  do j=1,this%NEV
  do i=1,this%NEV
    ctmp = prod(this%V(i),this%V(j))
    if (nodeid==0) write(*,'("%%C*C",2I3,2E24.16)')i,j,ctmp
  enddo
  enddo

!====================================
! DEBUG R and DV-VR
!====================================
  if (nodeid==0) then
    do j=1,this%NEV
    do i=1,this%NEV
      write(*,'("%%R",2I3,2E24.16)')i,j,this%R(i,j)
    enddo
    enddo
  endif

!====================
! check  DV - VR ?
!====================
  allocate(s(this%NEV),r)
  do i=1,this%NEV
    call new(s(i))
    call clear(s(i))
    do j=1,this%NEV
      call qmult1_accum_add(this%R(j,i),this%V(j),s(i))
    enddo
  enddo
  call new(r)
  do i=1,this%NEV
#ifdef _CLOVER
    call mult_wilson_dirac(quark_param%kappa,this%V(i),w,u,fclinv)
    call mult_clover_term(w,fcl)
#else
    call mult_wilson_dirac(quark_param%kappa,this%V(i),w,u)
#endif
    call qsub(w,s(i),r)
    err = sqrt(abs2(r)/abs2(w))
    if (nodeid==0) then
      write(*,'("%%DV-VR:",I3,2E24.16)')i,err
    endif
  enddo
  deallocate(s,r)
#endif

  deallocate(w)
#ifdef _CLOVER
  deallocate(fclinv,fcl)
#endif

!============================================================
! convert array format from type(wqfield) to qprop type.
!============================================================
  this%NPROP = this%NEV/(COL*SPIN)
  if (mod(this%NEV,(COL*SPIN))/=0) this%NPROP = this%NPROP + 1
  allocate(this%VV(this%NPROP))

  do iev=1,this%NEV
    call evnum_to_clspqp(iev,jc,js,jqp)

    do ieo =0,1
    do ideo=0,1
    do id = 0,NDM-1
      idd=id*2+idmod(id,ideo) ! calc. block index in 1-pu
      idt=mod(idd,NDT)
      idz=mod(idd/NDT,NDZ)
      idy=mod(idd/NDT/NDZ,NDY)
      idx=mod(idd/NDT/NDZ/NDY,NDX)

      do ibx=1,NBX  ! site loop in 1 block.
      do iby=1,NBY
      do ibz=1,NBZ
      ieoxyz=mod(iddeo(id,ideo)+ibz+iby+ibx+ieo,2)
      do ibth=1-ieoxyz,NBTH-ieoxyz
        ibt=ibth*2+ieoxyz
        ix=ibx+idx*NBX ! calc. global site index
        iy=iby+idy*NBY
        iz=ibz+idz*NBZ
        it=ibt+idt*NBT

        isp=ispace(ix,iy,iz)

        do is=1,SPIN
        do ic=1,COL
          this%VV(jqp)%q(ic,jc,is,js,isp,it) = this%V(iev)%deo(ideo)%eo(ieo)%b(id)%s(ibth,ibz,iby,ibx)%y(ic,is)
        enddo
        enddo

      enddo
      enddo
      enddo
      enddo
    enddo
    enddo
    enddo
  enddo
  deallocate(this%V)

#ifdef _DEBUG_
!====================================
!  Check Orthgonality
!====================================
  do j=1,this%NEV
  do i=1,this%NEV
    call evnum_to_clspqp(j,jc,js,jqp)
    call evnum_to_clspqp(i,ic,is,iqp)
    ctmp = z0
    do it=1,NT
    do isp=1,NSPACE
      ctmp = ctmp + conjg(this%VV(iqp)%q(1,ic,1,is,isp,it)) *this%VV(jqp)%q(1,jc,1,js,isp,it) + conjg(this%VV(iqp)%q(2,ic,1,is,isp,it)) *this%VV(jqp)%q(2,jc,1,js,isp,it) + conjg(this%VV(iqp)%q(3,ic,1,is,isp,it)) *this%VV(jqp)%q(3,jc,1,js,isp,it) + conjg(this%VV(iqp)%q(1,ic,2,is,isp,it)) *this%VV(jqp)%q(1,jc,2,js,isp,it) + conjg(this%VV(iqp)%q(2,ic,2,is,isp,it)) *this%VV(jqp)%q(2,jc,2,js,isp,it) + conjg(this%VV(iqp)%q(3,ic,2,is,isp,it)) *this%VV(jqp)%q(3,jc,2,js,isp,it) + conjg(this%VV(iqp)%q(1,ic,3,is,isp,it)) *this%VV(jqp)%q(1,jc,3,js,isp,it) + conjg(this%VV(iqp)%q(2,ic,3,is,isp,it)) *this%VV(jqp)%q(2,jc,3,js,isp,it) + conjg(this%VV(iqp)%q(3,ic,3,is,isp,it)) *this%VV(jqp)%q(3,jc,3,js,isp,it) + conjg(this%VV(iqp)%q(1,ic,4,is,isp,it)) *this%VV(jqp)%q(1,jc,4,js,isp,it) + conjg(this%VV(iqp)%q(2,ic,4,is,isp,it)) *this%VV(jqp)%q(2,jc,4,js,isp,it) + conjg(this%VV(iqp)%q(3,ic,4,is,isp,it)) *this%VV(jqp)%q(3,jc,4,js,isp,it)
    enddo
    enddo
    call comlib_sumcast(ctmp)
    if (nodeid==0) write(*,'("%%C*C",2I3,2E24.16)')i,j,ctmp
  enddo
  enddo
#endif

!======================================================
! remove identity part from R
!            to extract clover+hopping part.
!  D = 1 + kappa (csw F + M) = 1 + kappa Mcl
!  Mcl = (D-1)/kappa
!  R =  (R-1)/kappa <=> V`*Mcl*V
!======================================================
  do i=1,this%NEV
  do j=1,this%NEV
    if (i==j) then
      this%R(i,j) = (this%R(i,j) - z1)/quark_param%kappa
    else
      this%R(i,j) =  this%R(i,j)/quark_param%kappa
    endif
  enddo
  enddo

  return
end subroutine
Subroutine :
this :type(lowmode_obj), intent(in)
qp :type(quark_prop_obj), intent(inout)
iflg :integer, intent(in)
 this : low-mode eigen basises
   qp : (input) full-mode quark propagator
        (output) high-mode quark propagator (by full mode prop-low mode prop)
 iflg : 0 to remove V*R\V',  1  to remove  gamma5*V*R'\V'*gamma5

[Source]

subroutine get_qprop_hm(this,qp,iflg)
!
!  this : low-mode eigen basises
!    qp : (input) full-mode quark propagator
!         (output) high-mode quark propagator (by full mode prop-low mode prop)
!  iflg : 0 to remove V*R\V',  1  to remove  gamma5*V*R'\V'*gamma5
!
  implicit none
  type(lowmode_obj),    intent(in)    :: this
  type(quark_prop_obj), intent(inout) :: qp
  integer,              intent(in)    :: iflg
  type(quark_prop_obj), pointer :: tmpqp

  call tic(qp%parameter%etime)
  allocate(tmpqp)
  tmpqp = qp
  call get_qprop_lm(this,tmpqp,iflg)
  qp%q(:,:,:,:,:,:) = qp%q(:,:,:,:,:,:) - tmpqp%q(:,:,:,:,:,:) 
  deallocate(tmpqp)
  call tac(qp%parameter%etime)

  return
end subroutine
Subroutine :
this :type(lowmode_obj), intent(in)
qp :type(quark_prop_obj), intent(inout)
iflg :integer, intent(in), optional

compute lowmode quark propagator

qp := V*RR V’*wf for iflg =0 qp := gamma5*V*RR‘V’*gamma5*wf for iflg =1

 RR = 1 + kappa R
 R  = V'*(cswF+M)*V, subspace rep. for clover+hopping matrix

[Source]

subroutine get_qprop_lm(this,qp,iflg)
!
! compute lowmode quark propagator
!
! qp :=        V*RR \V'*wf         for iflg =0
! qp := gamma5*V*RR'\V'*gamma5*wf  for iflg =1
!
!  RR = 1 + kappa R
!  R  = V'*(cswF+M)*V, subspace rep. for clover+hopping matrix
!
  implicit none
  type(lowmode_obj), intent(in) :: this
  type(quark_prop_obj), intent(inout) :: qp
  integer, intent(in), optional :: iflg
  complex(8) :: VV(this%NEV,COL,SPIN)
  complex(8) :: RR(this%NEV,this%NEV)
  complex(8) :: g5q(SPIN)
  complex(8), allocatable :: SUM(:)
  integer :: jflg
  integer :: ic,is,isp,it,iev,jev
  integer :: jc,js
  integer :: kc,ks,kqp,kev

  call tic(qp%parameter%etime)

  if (.not. present(iflg)) then
    jflg=0
  else
    jflg=iflg
  endif

  if (jflg/=0.and.jflg/=1) then
    write(*,'("get_qprop_lm: flag (0 or 1) error, iflg=",I3)')jflg
    call comlib_finalize
    stop
  endif

!=============================
!  RR = 1 + kappa R
!=============================
  call get_lowmode_matrix(qp%parameter%quark_mass%kappa,this%NEV,this%R,RR)

  qp%q(:,:,:,:,:,:) = z0
  do it =1,NT
  do isp=1,NSPACE
    do is=1,SPIN
    do ic=1,COL
      qp%q(ic,ic,is,is,isp,it) = qp%parameter%wavefunc_sous%wavefunc(ic,is,isp,it)
    enddo
    enddo
  enddo
  enddo
  if (jflg==1) call mult_gamma5_qp(qp%q)

!======================
!  vdotw = V'*wf 
!======================
  VV(:,:,:) = z0
  do iev=1,this%NEV
    call evnum_to_clspqp(iev,kc,ks,kqp)
    do it =1,NT
    do isp=1,NSPACE
      do js=1,SPIN
      do is=1,SPIN
      do jc=1,COL
      do ic=1,COL
        VV(iev,jc,js) = VV(iev,jc,js) + conjg(this%VV(kqp)%q(ic,kc,is,ks,isp,it)) * qp%q(ic,jc,is,js,isp,it)
      enddo
      enddo
      enddo
      enddo
    enddo
    enddo
  enddo

  allocate(SUM(this%NEV*COL*SPIN))
  SUM(:) = RESHAPE(VV,(/this%NEV*COL*SPIN/))
  call comlib_sumcast(SUM)
  VV(1:this%NEV,1:COL,1:SPIN) = RESHAPE(SUM,(/this%NEV,COL,SPIN/))
!  do iev=1,this%NEV
!    do js=1,SPIN
!    do jc=1,COL
!      call comlib_sumcast(VV(iev,jc,js))
!    enddo
!    enddo
!  enddo

  do js=1,SPIN
  do jc=1,COL
    call inv_mult_RR(jflg,this%NEV,RR,VV(:,jc,js))
  enddo
  enddo

  qp%q(:,:,:,:,:,:) = z0
  do iev=1,this%NEV
    call evnum_to_clspqp(iev,kc,ks,kqp)
    do it =1,NT
    do isp=1,NSPACE
      do js=1,SPIN
      do is=1,SPIN
      do jc=1,COL
      do ic=1,COL
        qp%q(ic,jc,is,js,isp,it) = qp%q(ic,jc,is,js,isp,it) +this%VV(kqp)%q(ic,kc,is,ks,isp,it)*VV(iev,jc,js)
      enddo
      enddo
      enddo
      enddo
    enddo
    enddo
  enddo
  if (jflg==1) call mult_gamma5_qp(qp%q)

  call tac(qp%parameter%etime)

  return
end subroutine
Subroutine :
this :type(lowmode_obj), intent(inout)

[Source]

subroutine load_lowmode(this)
  implicit none
  type(lowmode_obj), intent(inout) :: this
  character(len=_CHARLEN_) :: fname,str,path
  type(timer_obj) :: timer
  integer :: i,j,icnv
  logical :: flag

  call new(timer)
  call tic(timer)

  do
    inquire(unit=io_unit,opened=flag)
    if (flag) then
      io_unit=io_unit+1
    else
      this%iout=io_unit
      exit
    endif
  enddo

  write(str,'(I6.6)')this%traj
  path=TRIM(ADJUSTL(this%fpath))//'/'//TRIM(ADJUSTL(str))//'/'
  write(str,'(".x",z1,"y",z1,"z",z1,"t",z1)')(ipsite(i),i=1,NDIM)
  fname=TRIM(ADJUSTL(path))//TRIM(TRIM(ADJUSTL(this%fname))//TRIM(ADJUSTL(str)))
  write(str,'(" Load Files (",I5,") : ",A)')nodeid,TRIM(fname)
  call print_status(str)

  open(this%iout,file=fname,status='unknown',form='unformatted')
  read(this%iout)icnv
  if (icnv < this%NEV) then
    if (nodeid==0) write(*,'("%Warn: Required subspace dimension is", " shorter than the stored subspace dimension, icnv=", I4," NEV=",I4)') icnv,this%NEV
    this%NEV = icnv
  endif
  if (associated(this%V)) deallocate(this%V)
  allocate(this%V(this%NEV))
  do i=1,this%NEV
    call new(this%V(i))
  enddo
  do i=1,this%NEV
    read(this%iout)this%V(i)
  enddo
  close(this%iout)

  if (associated(this%R)) deallocate(this%R)
  allocate(this%R(this%NEV,this%NEV))
  this%R(:,:)=z0

  call tac(timer)
  call average(timer)
  if (nodeid==0) write(*,'("    Num Vec : ",I3)')this%NEV
  if (nodeid==0) write(*,'("  Load Time : ",F14.6)')timer%elapse

  return
end subroutine
lowmode_obj
Derived Type :
V(:) :type(wqfield_dd_wg_obj), pointer
VV(:) :type(quark_prop_obj), pointer
R(:,:) :complex(8), pointer
NEV =12 :integer
NPROP :integer
traj :integer
iout :integer
fname ="" :character(len=CHARLEN)
fpath ="" :character(len=CHARLEN)
lowmode_op_obj
Derived Type :
X(:,:,:,:) :complex(8), pointer
NEV :integer
idummy(3) :integer
Subroutine :
this :type(lowmode_op_obj), intent(inout)
NEV :integer, intent(in)

[Source]

subroutine new_lowmode_op(this,NEV)
  use gamma_matrix_class
  implicit none
  type(lowmode_op_obj), intent(inout) :: this
  integer, intent(in) :: NEV
  allocate(this%X(NEV,NEV,NTT,0:NOP-1))
  return
end subroutine