Fortran语言--*界面程序。
程序员文章站
2023-12-25 22:59:09
...
PROGRAM dambreak
USE IFPORT
implicit none
! //LBM model
Real*8, parameter:: w(0:8) = (/4.0d0/9.0d0,1.0d0/9.0d0,1.0d0/9.0d0,1.0d0/9.0d0,1.0d0/9.0d0,1.0d0/36.0d0,1.0d0/36.0d0,1.0d0/36.0d0,1.0d0/36.0d0/)
Real*8, parameter:: rhoA = 1.d0
Integer, parameter:: e(0:8,0:1)=(/(/0,1,0,-1, 0,1,-1,-1, 1/),(/0,0,1, 0,-1,1, 1,-1,-1/)/)
Integer, parameter:: inv(0:8) = (/0,3,4,1,2,7,8,5,6/)
Integer, parameter:: xDim=5900,yDim=920,xFluid=3400,yFluid=600
integer, parameter:: itslip(0:8) = (/0,1,2,3,2,5,6,6,5/)
integer, parameter:: ibslip(0:8) = (/0,1,4,3,4,8,7,7,8/)
integer, parameter:: irslip(0:8) = (/0,1,2,1,4,5,5,8,8/)
integer, parameter:: ilslip(0:8) = (/0,3,2,3,4,6,6,7,7/)
! Real*8 :: w(0:8),e(0:8,0:1),inv(0:8) !Real*8为双精度实型
Real*8 :: rho(1:xDim,1:yDim),mass(1:xDim,1:yDim),u(1:xDim,1:yDim,0:1)
Real*8 :: fEq(1:xDim,1:yDim,0:8),f(1:xDim,1:yDim,0:8),fpost(1:xDim,1:yDim,0:8)
Real*8 :: uxy,uSqr,F_eq,mass1,mass2,P_lt2ph
Real*8 :: afb,aft,afr,afl,adb,adt,adr,adl
Real*8 :: dx,dt,vis_phy,gra_phy,den_phy
Real*8 :: gravn,vis_lb,tau,omega,times,p_lb
Integer:: iflag(0:xDim+1,0:yDim+1)
Integer:: i,tStep,x,y,tMax,BCTYPE
Character ( len = 100 ) :: command_file_name = 'file_commands.txt'
integer::csys
! \\Deleting the former folder
csys = SYSTEM('C:\Windows\System32\cmd.exe /E:ON /V:ON /K "phan.bat" ')
!
CALL Readparameters(tMax,BCTYPE,dx,dt,vis_phy,gra_phy,den_phy)
print*,tMax,BCTYPE,dx,dt,vis_phy,gra_phy,den_phy
if (BCTYPE.eq.1) then !Non-slip BC
adr = 1.0d0; afr=1.d0 - adr
adb = 1.0d0; afb=1.d0 - adb
adt = 1.0d0; aft=1.d0 - adt
adl = 1.0d0; afl=1.d0 - adl
elseif(BCTYPE.eq.2) then !Slip BC
adr = 0.0d0; afr=1.d0 - adr
adb = 0.0d0; afb=1.d0 - adb
adt = 0.0d0; aft=1.d0 - adt
adl = 0.0d0; afl=1.d0 - adl
elseif(BCTYPE.eq.3) then !Hybrid BC
adr = 0.0d0; afr=1.d0 - adr
adb = 0.0d0; afb=1.d0 - adb
adt = 1.0d0; aft=1.d0 - adt
adl = 0.0d0; afl=1.d0 - adl
endif
! //Unit conversion
P_lt2ph=dx*dx/(dt*dt)
! print*,P_lt2ph
! pause
! stop
! //Calculating relaxation time
gravn=gra_phy*dt*dt/dx !重力的无量纲值
vis_lb=vis_phy*dt/(dx*dx) !viscosity的无量纲值
tau=3.d0*vis_lb+0.5d0
omega=1.995d0
! omega=1.d0/tau
print*,omega,tau
!
CALL iniCondi(rho,mass,u,iflag,f,fpost,xDim,yDim,xFluid,yFluid,w)
!
! goto 301
open (11, file='pressure.txt',status='unknown')
open (12, file='masstotal.txt',status='unknown')
!循环开始--------------------------------------------------------------------------------------------------
DO 300 tStep = 1, tMax
CALL massUpdate(fpost,rho,mass,iflag,xDim,yDim,e,inv)
CALL stream(f,fpost,mass,iflag,u,afb,aft,afr,afl,adb,adt,adr,adl,xDIm,yDim,rhoA,e,w,inv,ibslip,itslip,irslip,ilslip)
CALL collide(f,fpost,iflag,rho,u,xDim,yDim,omega,gravn,w,e,p_lb,mass,P_lt2ph)
CALL cellsUpdate(f,rho,u,iflag,mass,xDim,yDim,w,e)
! //Print out result
IF(mod(tStep,100) .eq. 0)then
print*,'Time Step = ',tStep
! CALL output(rho,u,iflag,mass,tStep,xDim, yDim)
ENDIF
times=dt*dble(tstep) ! dble 函数,把数据转换成双精度。
write(11,*) times,p_lb
!
do x=1,xDim
do y=1,yDim
do i=0,8
fpost(x,y,i)=f(x,y,i) !每次循环完了就把f储存在fpost以待调用
enddo
enddo
enddo
! //Checking mass conservation
mass1=0.d0
mass2=0.d0
do x=1,xDim
do y=1,yDim
mass1=mass1+mass(x,y) !总质量
if (iflag(x,y).eq.1.or.iflag(x,y).eq.2) mass2=mass2+mass(x,y) !iflag=1、2是啥意思？？？？
enddo
enddo
if (isnan(mass1)) then
Print*,'THE NaN ERROR OCCURS'
PAUSE
STOP
endif
Write(12,116)tStep, mass1,mass2,mass1-mass2
116 format(i15,3f20.5)
!
300 CONTINUE
close(11)
!
301 continue
! call run_gnuplot ( command_file_name )
!
END PROGRAM dambreak
!-----------Equilibrium Function-------------------------------------------------------
Real*8 function F_eq(wi,rhoxy,uxy,uSqr)
implicit none
Real*8:: uxy,uSqr,wi,rhoxy
F_eq = wi*rhoxy*(1.d0+3.0d0*uxy+4.5d0*uxy*uxy-1.5d0*uSqr)
end function
!-------------------------------------------------------------------------------------
!-----Reading parameters--------------------------------------------------------------
SUBROUTINE Readparameters(tMax,BCTYPE,dx,dt,vis_phy,gra_phy,den_phy)
!
implicit none
Integer::tMax,BCTYPE
Real*8:: dx,dt,vis_phy,gra_phy,den_phy
!
open(1,file='PARAMETERS.txt')
read(1,*)
read(1,*)
read(1,*)tMax
read(1,*)
read(1,*)dx,dt
read(1,*)
read(1,*)BCTYPE
read(1,*)
read(1,*)vis_phy
read(1,*)
read(1,*)gra_phy
read(1,*)
read(1,*)den_phy
close(1)
END SUBROUTINE
!--------------------------------------------------------------------------------------
!------------------SUBROUTINE: iniCondi------------------------------------------------
! Function: Generating Initial conditions
!
SUBROUTINE iniCondi(rho,mass,u,iflag,f,fpost,xDim,yDim,xFluid,yFluid,w)
implicit none
!
Integer:: xDim,yDim,xFluid,yFluid,x,y,i
Integer:: iflag(0:xDim+1,0:yDim+1)
Real*8 :: rho(1:xDim,1:yDim),mass(1:xDim,1:yDim),u(1:xDim,1:yDim,0:1)
Real*8 :: f(1:xDim,1:yDim,0:8),fpost(1:xDim,1:yDim,0:8)
Real*8 :: w(0:8)
! //For fluid cells
do x=1,xFluid
do y=1,yFluid
rho(x,y) = 1.d0
iflag(x,y)= 1
mass(x,y) = rho(x,y)
u(x,y,0) = 0.d0
u(x,y,1) = 0.d0
do i = 0, 8
f(x,y,i)=w(i)
fpost(x,y,i)=w(i)
end do
enddo
enddo
! //For surface cells
y=yFluid+1
do x=1,xFluid
rho(x,y) = 1.d0
iflag(x,y)= 2
mass(x,y) = rho(x,y)*0.5d0
u(x,y,0) = 0.d0
u(x,y,1) = 0.d0
do i = 0, 8
f(x,y,i)=w(i)
fpost(x,y,i)=w(i)
end do
enddo
x=xFluid+1
do y=1,yFluid
rho(x,y) = 1.d0
iflag(x,y)= 2
mass(x,y) = rho(x,y)*0.5d0
u(x,y,0) = 0.d0
u(x,y,1) = 0.d0
do i = 0, 8
f(x,y,i)=w(i)
fpost(x,y,i)=w(i)
end do
enddo
x=xFluid+1
y=yFluid+1
rho(x,y) = 1.d0
iflag(x,y)= 2
mass(x,y) = rho(x,y)*0.25d0
u(x,y,0) = 0.d0
u(x,y,1) = 0.d0
do i = 0, 8
f(x,y,i)=w(i)
fpost(x,y,i)=w(i)
end do
! //For gas cells
do x=xFluid+2,xDim
do y=1,yDim
rho(x,y) = 0.d0
iflag(x,y)= 3
mass(x,y) = 0.d0
u(x,y,0) = 0.d0
u(x,y,1) = 0.d0
enddo
enddo
do x=1,xFluid+1
do y=yFluid+2,yDim
rho(x,y) = 0.d0
iflag(x,y)= 3
mass(x,y) = 0.d0
u(x,y,0) = 0.d0
u(x,y,1) = 0.d0
enddo
enddo
! //For wall boundary flags
do x=0,xDim+1,xDim+1
do y=0,yDim+1
iflag(x,y)= 0
enddo
enddo
do x=0,xDim+1
do y=0,yDim+1,yDim+1
iflag(x,y)= 0
enddo
enddo
END SUBROUTINE iniCondi
!--------------------------------------------------------------------------------------
!-----------------SUBROUTINE: massUpdate-----------------------------------------------
! Function: Evaluate mass-flux
!
SUBROUTINE massUpdate(fpost,rho,mass,iflag,xDim,yDim,e,inv)
implicit none
!
Integer:: xDim,yDim
Real*8 :: fpost(1:xDim,1:yDim,0:8),rho(1:xDim,1:yDim)
Real*8 :: mass(1:xDim,1:yDim)
Real*8 :: eps,epst,dmtol,dm
Integer:: e(0:8,0:1),inv(0:8)
Integer:: iflag(0:xDim+1,0:yDim+1)
Integer:: x,y,i,xt,yt
!
DO 270 x = 1, xDim
DO 270 y = 1, yDim
if (iflag(x,y).eq.1) then !For fluid
mass(x,y)=rho(x,y)
elseif (iflag(x,y).eq.2) then !For interface
dmtol=0.d0
eps = 0.d0 !eps体积分数。 我喜欢设rho=1所以我的mass=eps
if (rho(x,y).gt.0.d0) eps = mass(x,y)/rho(x,y) !GE是大于等于号(>=),GT是大于号(>),LE是小于等于号(<=),LT是小于号(<)
do i=1,8
xt = x+e(i,0)
yt = y+e(i,1)
dm = 0.d0
! // As Thurey's papers
if (iflag(xt,yt).eq.1) then !fluid cell：如果x+e(i,0)仍然在流体区域的话，求质量差
! dm = 0.5d0*(1.d0+eps)
! dm = dm*(fpost(xt,yt,inv(i))-fpost(x,y,i))
dm = fpost(xt,yt,inv(i))-fpost(x,y,i) !质量的交换=下一位置的反过来减去这一位置的正向，也就是fluid cell质量差
elseif (iflag(xt,yt).eq.2) then !interface cell
dm = fpost(xt,yt,inv(i))-fpost(x,y,i)
epst = 0.d0
if (rho(xt,yt).gt.0.d0) epst = mass(xt,yt)/rho(xt,yt)
dm = 0.5d0*(eps+epst)*dm
endif
! // As Thurey's MS thesis
! if (iflag(xt,yt).eq.1.（fluid cell）or.iflag(xt,yt).eq.2（interface cell）) then
! epst = 0.d0
! if (rho(xt,yt).gt.0.d0) epst = mass(xt,yt)/rho(xt,yt)
! dm = epst*fpost(xt,yt,inv(i))-eps*fpost(x,y,i)
! endif
dmtol = dmtol+dm
enddo
mass(x,y)=mass(x,y)+dmtol
elseif (iflag(x,y).eq.3) then !eq.3 应该是气体点mass(x,y)= 0.d0，气体和其他点没有质量交换的意思了
mass(x,y)= 0.d0
endif
270 CONTINUE
END SUBROUTINE massUpdate
!--------------------------------------------------------------------------------------
!-------------------SUBROUTINE: Stream-------------------------------------------------
! Function: Carrying out streaming step in LBM
! Note: This subroutine included the wall boundary conditions
!
SUBROUTINE stream(f,fpost,mass,iflag,u,afb,aft,afr,afl,adb,adt,adr,adl,xDIm,yDim,rhoA,e,w,inv,ibslip,itslip,irslip,ilslip)
implicit none
!
Integer:: xDIm,yDim
Real*8 :: f(1:xDim,1:yDim,0:8),u(1:xDim,1:yDim,0:1),mass(1:xDim,1:yDim),fpost(1:xDim,1:yDim,0:8)
Real*8 :: afb,aft,afr,afl,adb,adt,adr,adl
Real*8 :: w(0:8),rhoA
Real*8 :: nx,ny,ne,fEqei,fEqinv,fno,uSqr,uxy,F_eq
Integer:: ibslip(0:8),itslip(0:8),irslip(0:8),ilslip(0:8)
Integer:: iflag(0:xDim+1,0:yDim+1),e(0:8,0:1),inv(0:8)
Integer:: x,y,i,xt,yt,ixa,ixb,iya,iyb,it
!
do 210 x = 1, xDim
do 210 y = 1, yDim
if (iflag(x,y).eq.3) goto 210 !For empty cells，!如果符合if里的条件，则会进行下一次循环。也就是空气点不做下面的循环
do i=1,8
it=inv(i)
xt=x+e(it,0)
yt=y+e(it,1)
if(iflag(xt,yt).eq.1.or.iflag(xt,yt).eq.2) then
f(x,y,i) = fpost(xt,yt,i)!Normal translation
if (iflag(x,y).eq.2) then
! // Compute normal vector and inner product -----
ixa=x-1
ixb=x+1
iya=y-1
iyb=y+1
if(x.eq.1) ixa=x
if(x.eq.xDim) ixb=x
if(y.eq.1) iya=y
if(y.eq.yDim) iyb=y
nx = mass(ixb,y)-mass(ixa,y)
ny = mass(x,iyb)-mass(x,iya)
ne=nx*dble(e(i,0))+ny*dble(e(i,1))
! ---------------------------------------------------
if (ne.gt.0) then ! Surface reconstruction
uSqr = u(x,y,0)*u(x,y,0)+u(x,y,1)*u(x,y,1)
uxy = u(x,y,0)*dble(e(i,0)) + u(x,y,1)*dble(e(i,1))
fEqei=F_eq(w(i),rhoA,uxy,uSqr)
! uxy = u(x,y,0)*dble(-e(i,0)) + u(x,y,1)*dble(-e(i,1))
uxy = -uxy
fEqinv=F_eq(w(inv(i)),rhoA,uxy,uSqr)
f(x,y,i)=fEqei+fEqinv-fpost(x,y,inv(i))
if(f(x,y,i).lt.0.d0) f(x,y,i)=0.d0
endif
endif
elseif(iflag(xt,yt).eq.3) then ! Surface reconstruction
uSqr = u(x,y,0)*u(x,y,0)+u(x,y,1)*u(x,y,1)
uxy = u(x,y,0)*dble(e(i,0)) + u(x,y,1)*dble(e(i,1))
fEqei=F_eq(w(i),rhoA,uxy,uSqr)
! uxy = u(x,y,0)*dble(-e(i,0)) + u(x,y,1)*dble(-e(i,1))
uxy = -uxy
fEqinv=F_eq(w(inv(i)),rhoA,uxy,uSqr)
f(x,y,i)=fEqei+fEqinv-fpost(x,y,inv(i))
if(f(x,y,i).lt.0.d0) f(x,y,i)=0.d0
elseif(iflag(xt,yt).eq.0) then !Wall
! //No-slip condition (bounce-back) ----!
fno = fpost(x,y,inv(i))
! //Option for free-slip condition on walls -!
if(yt.eq.0) f(x,y,i) = fpost(x,y,ibslip(i))*afb + fno*adb
if(yt.eq.yDim+1) f(x,y,i) = fpost(x,y,itslip(i))*aft + fno*adt
if(xt.eq.xDim+1) f(x,y,i) = fpost(x,y,irslip(i))*afr + fno*adr
if(xt.eq.0) f(x,y,i) = fpost(x,y,ilslip(i))*afl + fno*adl
endif
enddo
210 continue
END SUBROUTINE stream
!--------------------------------------------------------------------------------------
!-------------------------------COLLISION----------------------------------------------
! Function: Carring out collision step in LBM BGK
!
SUBROUTINE collide(f,fpost,iflag,rho,u,xDim,yDim,omega,gravn,w,e,p_lb,mass,P_lt2ph)
implicit none
!
Integer:: xDim,yDim
Real*8 :: w(0:8),rho(1:xDim,1:yDim),u(1:xDim,1:yDim,0:1)
Real*8 :: f(1:xDim,1:yDim,0:8),fpost(1:xDim,1:yDim,0:8),mass(1:xDim,1:yDim),rhoavg
Real*8 :: deltaF,uxy,uSqr,F_eq,fEq,fi,dex,dey,omega,gravn,p_lb,eps,P_lt2ph,rhototal
Integer:: iflag(0:xDim+1,0:yDim+1),e(0:8,0:1)
Integer:: x,y,i,ntt
!
do 220 x = 1, xDim
do 220 y = 1, yDim
if (iflag(x,y).eq.3)goto 220
! //Calculate velocity and density
u(x,y,0)=0.d0
u(x,y,1)=0.d0
rho(x,y)=0.d0
do i=0,8
fi=f(x,y,i)
u(x,y,0)=u(x,y,0)+fi*dble(e(i,0))
u(x,y,1)=u(x,y,1)+fi*dble(e(i,1))
rho(x,y)=rho(x,y)+fi
rho(x,y)=dmax1(rho(x,y),0.d0)
enddo
! //Perform collision
uSqr = u(x,y,0)*u(x,y,0)+u(x,y,1)*u(x,y,1)
eps=0.d0
if (rho(x,y).gt.0.d0) eps=mass(x,y)/rho(x,y)
do i = 0, 8
dex=dble(e(i,0))
dey=dble(e(i,1))
uxy = u(x,y,0)*dex + u(x,y,1)*dey
fEq=F_eq(w(i),rho(x,y),uxy,uSqr)
f(x,y,i)=(1.0d0-omega)*f(x,y,i)+omega*fEq
deltaF=-3.d0*w(i)*rho(x,y)*dey*gravn
! deltaF=-eps*w(i)*rho(x,y)*dey*gravn
f(x,y,i)=f(x,y,i)+deltaF
enddo
220 continue
! //Pressure
p_lb=0.d0
if (mass(xDim,3).gt.0.d0) then
rhototal=0.d0
ntt=0
do x = 1, xDim
do y = 1, yDim
if (iflag(x,y).eq.1.or.iflag(x,y).eq.2) then
rhototal=rhototal+rho(x,y)
ntt=ntt+1
endif
enddo
enddo
rhoavg=rhototal/dble(ntt)
!
ntt=0
do i = 1,yDim
if (iflag(xDim,3+i).eq.1) then
ntt=ntt+1
else
goto 221
endif
enddo
221 continue
p_lb= (rho(xDim,3)-rhoavg)/3.d0+gravn*rho(xDim,3)*dble(ntt)
p_lb= 10.d0*p_lb*P_lt2ph
endif
END SUBROUTINE collide
!--------------------------------------------------------------------------------------
!-----------------------UPDATING CELLS' INFORMATION------------------------------------
SUBROUTINE cellsUpdate(f,rho,u,iflag,mass,xDim,yDim,w,e)
implicit none
!
Integer:: xDim,yDim
Real*8 :: f(1:xDim,1:yDim,0:8),rho(1:xDim,1:yDim),mass(1:xDim,1:yDim),u(1:xDim,1:yDim,0:1)
Real*8 :: nu(1:8),nutotal,dfull,dempt,nx,ny,massex,uSqravg,uxyavg,F_eq,usum,vsum,rsum
Real*8 :: w(0:8),kapa,Tol_massex
Integer:: iflag(0:xDim+1,0:yDim+1),e(0:8,0:1)
Integer:: ixa,ixb,iya,iyb,x,y,xt,yt,xtt,ytt,i,ii,k,ntt,nt1,nt2,nt3,nfc,nic,nwc,ngc
Character*3 :: cc(1:xDim,1:yDim)
kapa=1.d-3
Tol_massex=0.d0
!
do x=1,xDim
do y=1,yDim
cc(x,y)=' '
enddo
enddo
!----- BEGIN (Flag change criteria) -----!
do 280 x=1,xDim
do 280 y=1,yDim
if(iflag(x,y).eq.2) then
dfull = (1.d0+kapa)*rho(x,y)
dempt = -kapa*rho(x,y)
if(mass(x,y).gt.dfull) then
cc(x,y)='i_f'
! // Compute normal vector and inner product -----
ixa=x-1
ixb=x+1
iya=y-1
iyb=y+1
if(x.eq.1) ixa=x
if(x.eq.xDim) ixb=x
if(y.eq.1) iya=y
if(y.eq.yDim) iyb=y
nx = mass(ixa,y)-mass(ixb,y)
ny = mass(x,iya)-mass(x,iyb)
nutotal=0.d0
do i=1,8
nu(i)=0.d0
xt=x+e(i,0)
yt=y+e(i,1)
if (iflag(xt,yt).eq.1.or.iflag(xt,yt).eq.0) goto 212
if (mass(xt,yt).gt.(1.d0+kapa)*rho(xt,yt)) goto 212
nu(i)=nx*dble(e(i,0))+ny*dble(e(i,1))
nu(i)=dmax1(nu(i),0.d0)
nutotal=nutotal+nu(i)
212 continue
enddo
if(nutotal.gt.0.d0) then
massex=mass(x,y)-rho(x,y)
mass(x,y)=rho(x,y)
nutotal=1.d0/nutotal
do i=1,8
xt=x+e(i,0)
yt=y+e(i,1)
if (nu(i).gt.0.d0) mass(xt,yt)=mass(xt,yt)+massex*nu(i)*nutotal
enddo
endif
elseif (mass(x,y).lt.dempt) then
cc(x,y)='i_e'
! // Compute normal vector and inner product -----
ixa=x-1
ixb=x+1
iya=y-1
iyb=y+1
if(x.eq.1) ixa=x
if(x.eq.xDim) ixb=x
if(y.eq.1) iya=y
if(y.eq.yDim) iyb=y
nx = mass(ixa,y)-mass(ixb,y)
ny = mass(x,iya)-mass(x,iyb)
nutotal=0.d0
do i=1,8
nu(i)=0.d0
xt=x+e(i,0)
yt=y+e(i,1)
if (iflag(xt,yt).eq.3.or.iflag(xt,yt).eq.0) goto 213
if (mass(xt,yt).lt.(-kapa*rho(xt,yt))) goto 213
nu(i)=nx*dble(e(i,0))+ny*dble(e(i,1))
nu(i)=dmin1(nu(i),0.d0)
nu(i)=dabs(nu(i))
nutotal=nutotal+nu(i)
213 continue
enddo
if(nutotal.gt.0.d0) then
massex=mass(x,y)
mass(x,y)=0.d0
do i=1,8
f(x,y,i)=0.d0
enddo
u(x,y,0) = 0.d0
u(x,y,1) = 0.d0
rho(x,y) = 0.d0
nutotal=1.d0/nutotal
do i=1,8
xt=x+e(i,0)
yt=y+e(i,1)
if (nu(i).gt.0.d0) mass(xt,yt)=mass(xt,yt)+massex*nu(i)*nutotal
enddo
endif
else
nfc=0
nic=0
nwc=0
ngc=0
do i=1,8
xt=x+e(i,0)
yt=y+e(i,1)
if(iflag(xt,yt).eq.0) nwc=nwc+1
if(iflag(xt,yt).eq.1) nfc=nfc+1
if(iflag(xt,yt).eq.2) nic=nic+1
if(iflag(xt,yt).eq.3) ngc=ngc+1
enddo
if ((nfc+nic+nwc).eq.8) then
if ((nfc+nwc).ge.4) then
iflag(x,y)=1
Tol_massex=Tol_massex+mass(x,y)-rho(x,y)
mass(x,y)=rho(x,y)
endif
elseif ((ngc+nic+nwc).eq.8) then
if ((ngc+nwc).ge.4) then
iflag(x,y)=3
Tol_massex=Tol_massex+mass(x,y)
mass(x,y)=0.d0
do i=1,8
f(x,y,i)=0.d0
enddo
u(x,y,0) = 0.d0
u(x,y,1) = 0.d0
rho(x,y) = 0.d0
endif
endif
endif
endif
280 continue
!----- FINISH (Flag change criteria) -----!
! ---------------------------------------------------
!----- BEGIN (Initialization of newly fulled and emptied cells) -!
do 290 x=1,xDim
do 290 y=1,yDim
if(iflag(x,y).eq.2.and.cc(x,y).eq.'i_f') then
do i=1, 8
xt=x+e(i,0)
yt=y+e(i,1)
if(iflag(xt,yt).eq.3) then
ntt = 0
usum = 0.d0
vsum = 0.d0
rsum = 0.d0
do ii = 1, 8
xtt=xt+e(ii,0)
ytt=yt+e(ii,1)
if (xtt.eq.0.or.xtt.eq.xDim+1) goto 299
if (ytt.eq.0.or.ytt.eq.yDim+1) goto 299
if(iflag(xtt,ytt).eq.1.or.(iflag(xtt,ytt).eq.2.and.cc(xtt,ytt).eq.'i_f')) then
usum = usum + u(xtt,ytt,0)
vsum = vsum + u(xtt,ytt,1)
rsum = rsum + rho(xtt,ytt)
ntt = ntt + 1
endif
299 continue
enddo
if(ntt.eq.0) then
print*,'WHAT HAPPENED !!!'
PAUSE
endif
u(xt,yt,0) = usum / dble(ntt)
u(xt,yt,1) = vsum / dble(ntt)
rho(xt,yt) = rsum / dble(ntt)
! DF function
uSqravg = u(xt,yt,0)*u(xt,yt,0)+u(xt,yt,1)*u(xt,yt,1)
do k = 0, 8
uxyavg = u(xt,yt,0)*dble(e(k,0)) + u(xt,yt,1)*dble(e(k,1))
f(xt,yt,k) =F_eq(w(k),rho(xt,yt),uxyavg,uSqravg)
enddo
iflag(xt,yt)=2
! cc(xt,yt)='i_i'
endif
enddo
elseif(iflag(x,y).eq.2.and.cc(x,y).eq.'i_e') then
do i=1, 8
xt=x+e(i,0)
yt=y+e(i,1)
if(iflag(xt,yt).eq.1) iflag(xt,yt)=2
enddo
endif
290 continue
!----- FINISH (Initialization of newly fulled and emptied cells) -!
!----------------CHANGE FLAGS----------------------------------------------------------
DO 293 x=1,xDim
DO 293 y=1,yDim
if(iflag(x,y).eq.2.and.cc(x,y).eq.'i_f') then
iflag(x,y)=1
elseif (iflag(x,y).eq.2.and.cc(x,y).eq.'i_e') then
iflag(x,y)=3
endif
293 CONTINUE
! //Handing for unphysical splashes or bubbles
DO 295 x=1,xDim
DO 295 y=1,yDim
if(iflag(x,y).eq.1.and.cc(x,y).eq.'i_f') then
if (mass(x,y).gt.(1.d0+kapa)*rho(x,y)) then
Tol_massex=Tol_massex+mass(x,y)-rho(x,y)
mass(x,y)=rho(x,y)
! print*,'splashes occur line 635'
else
do i=1,8
xt=x+e(i,0)
yt=y+e(i,1)
if(iflag(xt,yt).eq.2) then
nfc=0
nic=0
nwc=0
do ii=1,8
xtt=xt+e(ii,0)
ytt=yt+e(ii,1)
if(iflag(xtt,ytt).eq.0) nwc=nwc+1
if(iflag(xtt,ytt).eq.1) nfc=nfc+1
if(iflag(xtt,ytt).eq.2) nic=nic+1
enddo
if ((nfc+nic+nwc).eq.8) then
if ((nfc+nwc).ge.5) then
iflag(xt,yt)=1
Tol_massex=Tol_massex+mass(xt,yt)-rho(xt,yt)
mass(xt,yt)=rho(xt,yt)
endif
endif
endif
enddo
endif
elseif (iflag(x,y).eq.3.and.cc(x,y).eq.'i_e') then
if (mass(x,y).lt.(-kapa)*rho(x,y)) then
Tol_massex=Tol_massex+mass(x,y)
mass(x,y)=0.d0
endif
elseif (iflag(x,y).eq.2) then
nt1=0
nt3=0
do i=1,8
xt=x+e(i,0)
yt=y+e(i,1)
if (iflag(x,y).eq.1.or.iflag(x,y).eq.0) nt1=nt1+1
if (iflag(x,y).eq.3.or.iflag(x,y).eq.0) nt3=nt3+1
enddo
if (nt1.eq.8) then
Tol_massex=Tol_massex+mass(x,y)-rho(x,y)
mass(x,y)=rho(x,y)
iflag(x,y)=1
endif
if (nt3.eq.8) then
Tol_massex=Tol_massex+mass(x,y)
mass(x,y)=0.d0
rho(x,y)=0.d0
iflag(x,y)=3
do i=1,8
f(x,y,i)=0.d0
enddo
endif
endif
295 CONTINUE
nt2=0
DO 296 x=1,xDim
DO 296 y=1,yDim
if(iflag(x,y).eq.2) nt2=nt2+1
296 CONTINUE
Tol_massex=Tol_massex*1.d0/(dble(nt2))
DO 297 x=1,xDim
DO 297 y=1,yDim
if(iflag(x,y).eq.2) mass(x,y)=mass(x,y)+Tol_massex
297 CONTINUE
END SUBROUTINE
!--------------------------------------------------------------------------------------
!---------------------------SUBROUTINE OUTPUT------------------------------------------
SUBROUTINE output(rho,u,iflag,mass,tStep,xDim, yDim)
implicit none
Integer:: xDim, yDim
Real*8 :: rho(1:xDim,1:yDim),mass(1:xDim,1:yDim),u(1:xDim,1:yDim,0:1)
Integer:: iflag(0:xDim+1,0:yDim+1),tStep
Integer:: index,x,y
character*100:: filename1,filename2,n_time,dim
!
write(n_time,'(I0)')tStep
filename1=trim(n_time)//'TIME'//'.dat'
open(1,file='RESULTS\'//trim(filename1),status='unknown')
! write(1,*)'# x y flag ux uy mass rho'
index=0
do 111 x=1, xDim
do 111 y=1, yDim
write(1,102) x,y,iflag(x,y),u(x,y,0),u(x,y,1),mass(x,y),rho(x,y)
111 continue
close (1)
102 format(3i4, 4f12.5)
! Write inputfile for MicroAVS
filename2=trim(n_time)//'MAVS_TIME'//'.fld'
open(1,file='RESULTS\'//trim(filename2),status='unknown')
write(1,'(a16)')'# AVS field file'
write(1,*)'ndim = 2'
write(dim,'(I0)')yDim
write(1,*)trim('dim1 = '//trim(dim))
write(dim,'(I0)')xDim
write(1,*)trim('dim2 = '//trim(dim))
write(1,*)'nspace = 2'
write(1,*)'veclen = 1'
write(1,*)'data = float'
write(1,*)'field = irregular'
write(1,*)'variable 1 file='//trim(filename1)//' filetype=ascii skip=0 offset=2 stride=7'
write(1,*)'coord 1 file='//trim(filename1)//' filetype=ascii skip=0 offset=0 stride=7'
write(1,*)'coord 2 file='//trim(filename1)//' filetype=ascii skip=0 offset=1 stride=7'
close(1)
END SUBROUTINE
!--------------------------------------------------------------------------------------
subroutine run_gnuplot ( command_file_name )
implicit none
!
character ( len = 100 ) command
character ( len = * ) command_file_name
integer status
integer system
!
! Issue a command to the system that will startup GNUPLOT, using
! the file we just wrote as input.
!
write ( command, * ) 'gnuplot ' // trim ( command_file_name )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'Issuing the command:' // trim ( command )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) ' Press RETURN to proceed.'
print*,trim ( command )
!pause
status = system ( trim ( command ) )
if ( status == 0 ) then
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'RUN_GNUPLOT:'
write ( *, '(a)' ) ' Normal end of execution of the GNUPLOT program.'
else
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'RUN_GNUPLOT - Fatal error!'
write ( *, '(a)' ) ' An error code was returned when the GNUPLOT command'
write ( *, '(a)' ) ' was issued. Perhaps GNUPLOT is not in your path.'
write ( *, '(a)' ) ' Type "which gnuplot" to check this.'
stop
end if
return
end