[cig-commits] r12713 - mc/2D/ConMan/trunk/src
sdk at geodynamics.org
sdk at geodynamics.org
Tue Aug 26 06:33:48 PDT 2008
Author: sdk
Date: 2008-08-26 06:33:48 -0700 (Tue, 26 Aug 2008)
New Revision: 12713
Modified:
mc/2D/ConMan/trunk/src/fluxke.F
Log:
essagecleaned up non-essential code
Modified: mc/2D/ConMan/trunk/src/fluxke.F
===================================================================
--- mc/2D/ConMan/trunk/src/fluxke.F 2008-08-26 13:33:36 UTC (rev 12712)
+++ mc/2D/ConMan/trunk/src/fluxke.F 2008-08-26 13:33:48 UTC (rev 12713)
@@ -29,38 +29,11 @@
c
eng=zero
- work=zero
- cwork = zero
- phib = zero
- tm = zero
- area = zero
do 10 i=1,numnp
snnu(i) = zero
pmass(i) = zero
10 continue
- do ivel = 1 , numel
- do node = 1, 4
- tl(node) = t(ien(ivel,node))
- xl(1,node) = x(1,ien(ivel,node) )
- xl(2,node) = x(2,ien(ivel,node) )
- enddo
- call genshg(shdx, shdy, det, xl, ivel)
- volume=det(1)+det(2)+det(3)+det(4)
- tme=zero
- areae=zero
- do intp = 1, 4
- tme = tme
- & + (shl(1,intp)*tl(1) + shl(2,intp)*tl(2)
- & + shl(3,intp)*tl(3) + shl(4,intp)*tl(4))*det(intp)
- areae = areae + det(intp)
- enddo
- area = area + areae/volume
- tm = tm + tme/volume
- enddo
- tm = tm/area
c
-c
-c
do 1000 ivel = 1 , numel
c
c..... localize coordinates, temperature and velocity
@@ -85,33 +58,7 @@
c
volume=det(1)+det(2)+det(3)+det(4)
flux = zero
- ework = zero
- ephib = zero
-c
- do intp = 1, 4
- uxq = shdx(1,intp)*vl(1) + shdx(2,intp)*vl(3)
- & + shdx(3,intp)*vl(5) + shdx(4,intp)*vl(7)
- uyq = shdy(1,intp)*vl(1) + shdy(2,intp)*vl(3)
- & + shdy(3,intp)*vl(5) + shdy(4,intp)*vl(7)
- vxq = shdx(1,intp)*vl(2) + shdx(2,intp)*vl(4)
- & + shdx(3,intp)*vl(6) + shdx(4,intp)*vl(8)
- uyq = shdy(1,intp)*vl(2) + shdy(2,intp)*vl(4)
- & + shdy(3,intp)*vl(6) + shdy(4,intp)*vl(8)
- ework = ework + 0.5*(1.0e0*(uxq*uxq + uyq*uyq) +
- & (uyq+vxq)*(vxq+uyq))*det(intp)*evisc(intp)
- ephib = ephib + (tm-
- & tl(1)*shl(1,intp)+tl(2)*shl(2,intp)
- & +tl(3)*shl(3,intp)+tl(4)*shl(4,intp))
- & *(vl(2)*shl(1,intp)+vl(4)*shl(2,intp)
- & +vl(6)*shl(3,intp)+vl(8)*shl(4,intp))*det(intp)
-c 1/2.000 is a scaling to make Ra come out to 10^5
-ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc
- enddo
eng = eng + eeng*volume
-c work = work + 1.0e-2*ework/volume
- if (mat(ivel) .gt. 1) work = work + ework/volume
- if (mat(ivel) .gt. 1) phib = phib + ephib/volume
- if(mat(ivel).eq.2) cwork=cwork+ework/volume
c
do intp=1, 4
flux = flux - (shdy(1,intp)*tl(1) + shdy(2,intp)*tl(2)
@@ -174,43 +121,32 @@
fluxb = 0
pvelt = 0
pvelb = 0
-c..... flux across the top
-c fac = 3.0e3 * 1300.0 / 6.0e5
- fac = 1.0
do 1300 node=1, nodebn/2 - 1
xtemp = x(1,nb(1,node) ) - x(1,nb(1,node+1) )
vtemp = v(1,nb(1,node) ) + v(1,nb(1,node+1) )
ttemp = snnu( nb(1,node) ) + snnu( nb(1,node+1) )
- xtott = xtott + xtemp
- fluxt = fluxt + ttemp * xtemp * pt5
- pvelt = pvelb + vtemp * xtemp * pt5
+ xtotb = xtotb + xtemp
+ fluxb = fluxb + ttemp * xtemp * pt5
1300 continue
c..... flux across the bottom
do 1400 node=nodebn/2 + 1, nodebn -1
xtemp = x(1,nb(1,node) ) - x(1,nb(1,node+1) )
vtemp = v(1,nb(1,node) ) + v(1,nb(1,node+1) )
ttemp = snnu( nb(1,node) ) + snnu( nb(1,node+1) )
- xtotb = xtotb + xtemp
- fluxb = fluxb + ttemp * xtemp * pt5
- pvelb = pvelb + vtemp * xtemp * pt5
-c write(80,*) x(1,nb(1,node)) , snnu(nb(1,node))
+ xtott = xtotb + xtemp
+ fluxt = fluxt + ttemp * xtemp * pt5
1400 continue
-c write(80,1002)(fac*snnu(nb(1,node)),node=nodebn/2+1,nodebn)
-1002 format(361(1pe14.7,1x))
c
- prtary(1) = fluxt/xtott
- prtary(2) = fluxb/xtotb
+ prtary(1) = fluxb/xtotb
+ prtary(2) = fluxt/xtott
prtary(3) = eng
prtary(4) = time
- prtary(5) = pvelt/xtott
- prtary(6) = pvelb/xtotb
write(itsout,1001) prtary(1),prtary(2),prtary(3),
- & prtary(4),prtary(5),prtary(6),
- & cwork, work, phib, tm, work/phib
+ & prtary(4)
c
c..... return
c
-1001 format ( 11(e15.8,1x))
+1001 format ( 4(e15.8,1x))
1006 format ( 5x, i5, 10x, f15.8)
return
end
More information about the cig-commits
mailing list