Class | lma_class |
In: |
SingletMesons_Simple_v1.3/VERYOLD/OBSOLETE3/lma_class.F90
|
Subroutine : | |
this : | type(lowmode_op_obj), intent(inout) |
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) |
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
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
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) |
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
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) |
Subroutine : | |
this : | type(lowmode_op_obj), intent(inout) |
NEV : | integer, intent(in) |
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