00001 subroutine source_komar_mass_compact_WL(souf)
00002 use phys_constant, only : long, pi
00003 use grid_parameter, only : nrf, ntf, npf
00004 use coordinate_grav_r, only : rg
00005 use trigonometry_grav_theta, only : sinthg, costhg
00006 use trigonometry_grav_phi, only : sinphig, cosphig
00007 use def_matter
00008 use def_matter_parameter, only : radi, ber, ome
00009 use def_metric, only : psi, alph, bvxd, bvyd, bvzd, bvxu, bvyu, bvzu
00010 use def_metric_hij, only : hxxd, hxyd, hxzd, hyyd, hyzd, hzzd
00011 use def_metric_on_SFC_CF
00012 use def_metric_on_SFC_WL
00013 use def_vector_phi, only : vec_phif
00014 use make_array_3d
00015 use interface_interpo_gr2fl
00016 implicit none
00017 real(long), pointer :: souf(:,:,:)
00018 real(long) :: emdw, alphw, psiw, rhow, prew, hhw, utw, rhoHw, esseS
00019 real(long) :: rjjx, rjjy, rjjz, rjjbeta, ene
00020 real(long) :: vphif(1:3)
00021 real(long) :: otermx, otermy, otermz, omew
00022 real(long) :: bvxdfw, bvydfw, bvzdfw, bvxufw, bvyufw, bvzufw
00023 integer :: irf, itf, ipf
00024 real(long) :: zfac, small = 1.0d-15
00025 real(long) :: hhxxdf, hhxydf, hhxzdf, hhyxdf, hhyydf, hhyzdf,
00026 hhzxdf, hhzydf, hhzzdf
00027
00028 do ipf = 0, npf
00029 do itf = 0, ntf
00030 do irf = 0, nrf
00031 emdw = emd(irf,itf,ipf)
00032 if (emdw <= small) emdw = small
00033 psiw = psif(irf,itf,ipf)
00034 alphw = alphf(irf,itf,ipf)
00035 bvxufw = bvxuf(irf,itf,ipf)
00036 bvyufw = bvyuf(irf,itf,ipf)
00037 bvzufw = bvzuf(irf,itf,ipf)
00038 bvxdfw = bvxdf(irf,itf,ipf)
00039 bvydfw = bvydf(irf,itf,ipf)
00040 bvzdfw = bvzdf(irf,itf,ipf)
00041 call peos_q2hprho(emdw, hhw, prew, rhow, ene)
00042 utw = utf(irf,itf,ipf)
00043 omew = omef(irf,itf,ipf)
00044
00045 vphif(1) = vec_phif(irf,itf,ipf,1)
00046 vphif(2) = vec_phif(irf,itf,ipf,2)
00047 vphif(3) = vec_phif(irf,itf,ipf,3)
00048
00049 hhxxdf = hxxdf(irf,itf,ipf)
00050 hhxydf = hxydf(irf,itf,ipf)
00051 hhxzdf = hxzdf(irf,itf,ipf)
00052 hhyydf = hyydf(irf,itf,ipf)
00053 hhyzdf = hyzdf(irf,itf,ipf)
00054 hhzzdf = hzzdf(irf,itf,ipf)
00055 hhyxdf = hhxydf
00056 hhzxdf = hhxzdf
00057 hhzydf = hhyzdf
00058
00059 otermx = bvxdfw + omew*vphif(1) &
00060 & + hhxxdf*omew*vphif(1) &
00061 & + hhxydf*omew*vphif(2) &
00062 & + hhxzdf*omew*vphif(3)
00063 otermy = bvydfw + omew*vphif(2) &
00064 & + hhyxdf*omew*vphif(1) &
00065 & + hhyydf*omew*vphif(2) &
00066 & + hhyzdf*omew*vphif(3)
00067 otermz = bvzdfw + omew*vphif(3) &
00068 & + hhzxdf*omew*vphif(1) &
00069 & + hhzydf*omew*vphif(2) &
00070 & + hhzzdf*omew*vphif(3)
00071
00072 rhoHw = hhw*rhow*(alphw*utw)**2 - prew
00073 esseS = -hhw*rhow + 4.0d0*prew + rhoHw
00074
00075 rjjx = hhw*rhow*alphw*utw**2*psiw**4*otermx
00076 rjjy = hhw*rhow*alphw*utw**2*psiw**4*otermy
00077 rjjz = hhw*rhow*alphw*utw**2*psiw**4*otermz
00078
00079 rjjbeta = rjjx*bvxufw + rjjy*bvyufw + rjjz*bvzufw
00080
00081 souf(irf,itf,ipf) = (alphw*(esseS+rhoHw) - 2.0d0*rjjbeta)*psiw**6
00082 end do
00083 end do
00084 end do
00085
00086 end subroutine source_komar_mass_compact_WL
