/home/uryu/Cocal_svn_checkinout/Cocal/code/Subroutine/source_MoC_WL.f90

Go to the documentation of this file.

subroutine source_MoC_WL(souvec,sou)
  use grid_parameter, only : nrg, ntg, npg
  use coordinate_grav_r, only : rg
  use trigonometry_grav_phi, only : sinphig, cosphig
  use trigonometry_grav_theta, only : sinthg, costhg
  use interface_sourceterm_MoC_CF_corot
  use interface_sourceterm_MoC_CF
  use interface_sourceterm_MoC_WL_corot
  use interface_sourceterm_MoC_WL
  use def_vector_x, only : hvec_xg
  use make_array_3d
  use make_array_4d
  implicit none
  real(8), pointer :: sou(:,:,:), souvec(:,:,:,:)
  real(8), pointer :: souvec1(:,:,:,:), souvec2(:,:,:,:), 
                     souvec3(:,:,:,:), souvec4(:,:,:,:)
  real(8) :: xxx, yyy, zzz
  integer :: ipg, itg, irg
  character(len=1) :: chgra
!
  call alloc_array4d(souvec1,0,nrg,0,ntg,0,npg,1,3)
  call alloc_array4d(souvec2,0,nrg,0,ntg,0,npg,1,3)
  call alloc_array4d(souvec3,0,nrg,0,ntg,0,npg,1,3)
  call alloc_array4d(souvec4,0,nrg,0,ntg,0,npg,1,3)
!
  call sourceterm_MoC_CF_corot(souvec1)
  call sourceterm_MoC_CF(souvec2)
  call sourceterm_MoC_WL_corot(souvec3)
  call sourceterm_MoC_WL(souvec4)
  souvec(0:nrg,0:ntg,0:npg,1:3) = souvec1(0:nrg,0:ntg,0:npg,1:3) &
  &                             + souvec2(0:nrg,0:ntg,0:npg,1:3) &
  &                             + souvec3(0:nrg,0:ntg,0:npg,1:3) &
  &                             + souvec4(0:nrg,0:ntg,0:npg,1:3)
!
  do ipg = 1, npg
    do itg = 1, ntg
      do irg = 1, nrg
        xxx = hvec_xg(irg,itg,ipg,1)
        yyy = hvec_xg(irg,itg,ipg,2)
        zzz = hvec_xg(irg,itg,ipg,3)
        sou(irg,itg,ipg) = xxx*souvec(irg,itg,ipg,1) &
        &                + yyy*souvec(irg,itg,ipg,2) &
        &                + zzz*souvec(irg,itg,ipg,3)
      end do
    end do
  end do
!
  deallocate(souvec1)
  deallocate(souvec2)
  deallocate(souvec3)
  deallocate(souvec4)
!
!          call interpo_linear_type0(ramgc,ramg,irg,itg,ipg)
!          call interpo_linear_type0(psigc, psi,irg,itg,ipg)
!          call interpo_linear_type0(alpgc,alph,irg,itg,ipg)
!          call interpo_linear_type0(fnc2gc,fnc2,irg,itg,ipg)
!          afnc2inv = alpgc/fnc2gc
!          call interpo_linear_type0(emdgc,emdg,irg,itg,ipg)
!          call peos_q2hprho(emdgc,hhgc,pregc,rhogc,ene)
!
!          utgc  =       swflu *ramgc/(alpgc**2*hhgc) &
!             &      +(1.0d0-swflu)*hhgc/ber
end subroutine source_MoC_WL

---