!-------------! module system !-------------! save integer :: nn integer :: mm integer, allocatable :: lbnd(:) integer, allocatable :: rbnd(:) integer, allocatable :: lspn(:) integer, allocatable :: rspn(:) integer, allocatable :: oper(:) integer, allocatable :: frst(:) integer, allocatable :: last(:) integer, allocatable :: vrtx(:) integer, allocatable :: site(:,:) integer, allocatable :: blen(:) real(8), allocatable :: hamp(:) end module system !-----------------! !------------! module mdata !------------! save integer, allocatable :: plbnd(:) integer, allocatable :: prbnd(:) integer, allocatable :: loopnmbr(:) integer, allocatable :: loopordr(:) real(8) :: nmsr=0.d0 real(8), allocatable :: scor(:) real(8), allocatable :: dcor(:) end module mdata !----------------! !================! program jq3chain !=====================! ! Anders Sandvik, 2012 !---------------------! use system; use mdata; implicit none integer :: i,j,init,bins,mstps,istps real(8) :: jj,qq open(10,file='read.in',status='old') read(10,*)nn,jj,qq,mm read(10,*)init,bins,mstps,istps close(10) call initran(1) call makelattice() call initsystem(init,jj,qq) if (istps>0) then do i=1,istps call montecarlosweep(jj,qq) enddo call writeconf() endif allocate(scor(0:nn/2)); scor=0.d0 allocate(dcor(0:nn/2)); dcor=0.d0 do j=1,bins do i=1,mstps call montecarlosweep(jj,qq) call measure() enddo call writebindata() call writeconf() enddo call deallocateall() end program jq3chain !====================! !---------------------------------! subroutine montecarlosweep(jj,qq) !---------------------------------! use system; implicit none real(8) :: jj,qq call diagonalupdate(jj,qq) call makevertexlist() call loopupdate() call stateupdate() end subroutine montecarlosweep !------------------------------! !--------------------------------! subroutine diagonalupdate(jj,qq) !--------------------------------! use system; implicit none integer :: i,c real(8) :: p,jj,qq,pq,ran external :: ran pq=0.25d0*qq/(0.25d0*qq+jj) lspn(:)=rspn(:) do i=0,mm-1 if (mod(oper(i),8)==0) then 10 c=int(ran()*nn)+1 if (lspn(site(1,c))/=lspn(site(2,c))) then p=ran() if (p=0) then vrtx(frst(i))=v0 vrtx(v0)=frst(i) vrtx(last(i))=v1 vrtx(v1)=last(i) else vrtx(v0)=v1 vrtx(v1)=v0 endif vrtx(v0+1)=12*mm+4*rbnd(i)-3 vrtx(v1+1)=12*mm+4*lbnd(i)-1 v0=v0+4 enddo end subroutine makevertexlist !-----------------------------! !-----------------------! subroutine loopupdate() !-----------------------! use system; implicit none integer :: b,p,v0,v1,v2 real(8) :: ran external :: ran do v0=0,12*mm+4*nn-1,2 if (vrtx(v0)>=0) then v1=v0 if (ran()<0.5d0) then call visitloop() else call fliploop() endif endif enddo contains !----------------------! subroutine visitloop() !----------------------! do vrtx(v1)=-1 v2=ieor(v1,1) v1=vrtx(v2) vrtx(v2)=-1 if (v1==v0) exit enddo end subroutine visitloop !------------------------! !---------------------! subroutine fliploop() !---------------------! do p=v1/12 if (p=s1.and.loopordr(k)<=s2 ls=loopordr(l)>=s1.and.loopordr(l)<=s2 if (ks.neqv.ls) br=br-0.75d0 endif endif elseif (loopnmbr(i)==loopnmbr(k).and.loopnmbr(j)==loopnmbr(l)) then br=br+0.1875d0 elseif (loopnmbr(i)==loopnmbr(l).and.loopnmbr(j)==loopnmbr(k)) then br=br+0.1875d0 endif enddo dcor(r)=dcor(r)+br enddo end subroutine bondcorrelations !-------------------------------! end subroutine measure !----------------------! !---------------------------! subroutine propagatebonds() !---------------------------! use system; use mdata; implicit none integer :: i,c,s1,s2,s3,s4 prbnd(:)=rbnd(:) do i=0,mm/2-1 c=oper(i)/16 s1=site(1,c) s2=site(2,c) s3=prbnd(s1) s4=prbnd(s2) prbnd(s1)=s2 prbnd(s2)=s1 prbnd(s3)=s4 prbnd(s4)=s3 if (btest(oper(i),3)) then s1=site(3,c) s2=site(4,c) s3=prbnd(s1) s4=prbnd(s2) prbnd(s1)=s2 prbnd(s2)=s1 prbnd(s3)=s4 prbnd(s4)=s3 s1=site(5,c) s2=site(6,c) s3=prbnd(s1) s4=prbnd(s2) prbnd(s1)=s2 prbnd(s2)=s1 prbnd(s3)=s4 prbnd(s4)=s3 endif enddo plbnd(:)=lbnd(:) do i=mm-1,mm/2,-1 c=oper(i)/16 s1=site(1,c) s2=site(2,c) s3=plbnd(s1) s4=plbnd(s2) plbnd(s1)=s2 plbnd(s2)=s1 plbnd(s3)=s4 plbnd(s4)=s3 if (btest(oper(i),3)) then s1=site(3,c) s2=site(4,c) s3=plbnd(s1) s4=plbnd(s2) plbnd(s1)=s2 plbnd(s2)=s1 plbnd(s3)=s4 plbnd(s4)=s3 s1=site(5,c) s2=site(6,c) s3=plbnd(s1) s4=plbnd(s2) plbnd(s1)=s2 plbnd(s2)=s1 plbnd(s3)=s4 plbnd(s4)=s3 endif enddo end subroutine propagatebonds !-----------------------------! !----------------------! subroutine makeloops() !----------------------! use system; use mdata; implicit none integer :: i,s,s1,nl,lo nl=0 lo=0 loopnmbr(:)=0 do s1=1,nn-1,2 if (loopnmbr(s1)==0) then nl=nl+1 s=s1 do loopnmbr(s)=nl loopordr(s)=lo; lo=lo+1 s=prbnd(s) loopnmbr(s)=nl loopordr(s)=lo; lo=lo+1 s=plbnd(s) if (s==s1) exit enddo endif enddo end subroutine makeloops !------------------------! !-------------------------! subroutine writebindata() !-------------------------! use system; use mdata; implicit none integer :: r scor(:)=scor(:)/(dble(nn)*nmsr) dcor(:)=dcor(:)/(dble(nn)*nmsr) open(10,file='cor.dat',status='unknown',position='append') do r=0,nn/2 write(10,'(i4,2f16.12)')r,scor(r),dcor(r) enddo close(10) scor=0.d0 dcor=0.d0 nmsr=0.d0 end subroutine writebindata !---------------------------! !---------------------------------! subroutine initsystem(init,jj,qq) !---------------------------------! use system; use mdata; implicit none integer :: i,c,x,y,init real(8) :: ran,jj,qq external :: ran mm=mm*nn/2 allocate(oper(0:mm-1)) allocate(vrtx(0:12*mm+4*nn-1)) allocate(lspn(nn)) allocate(rspn(nn)) allocate(lbnd(nn)) allocate(rbnd(nn)) allocate(plbnd(nn)) allocate(prbnd(nn)) allocate(frst(nn)) allocate(last(nn)) allocate(loopnmbr(nn)) allocate(loopordr(nn)) if (init==0) then do i=1,nn lspn(i)=(-1)**i enddo rspn=lspn do i=1,nn-1,2 lbnd(i)=i+1 lbnd(i+1)=i enddo rbnd=lbnd do i=0,mm-1 c=2*int(ran()*(nn/2))+1 if (ran()