Cocal: /home/uryu/Cocal_svn_checkinout/Cocal/code/Subroutine/correct_matter_source

00001 subroutine correct_matter_source_midpoint(sou)
00002   use phys_constant, only : long, pi
00003   use grid_parameter, only : nrg, ntg, npg
00004   use coordinate_grav_r, only  :   drg, rg, hrg
00005   use def_matter, only : rs
00006   use interface_interpo_linear_type0_2Dsurf
00007   implicit none
00008   real(long), pointer :: sou(:,:,:)
00009   real(long) :: hsurf
00010   integer    :: irg, itg, ipg
00011   real(long) :: x(2),f(2), v, sougc
00012   real(long), external :: lagint_2nd
00013 !
00014 ! -- Correct the weight for a matter source in a volume integral
00015   do ipg = 1, npg
00016     do itg = 1, ntg
00017       call interpo_linear_type0_2Dsurf(hsurf,rs,itg,ipg)
00018       do irg = 1, nrg
00019 !cmout stop ' Do not change lines correct_matter_source_midpoint.f90 '
00020         if (hsurf < rg(irg)) then 
00021           sou(irg,itg,ipg) = sou(irg,itg,ipg)*(hsurf-rg(irg-1))/drg(irg)
00022           exit
00023         end if
00024 !cmout        if (hrg(irg) <= hsurf.and.hsurf <= rg(irg)) then 
00025 !!        sou(irg,itg,ipg) = sou(irg,itg,ipg)*(hsurf-rg(irg-1))/drg(irg)
00026 !cmout          x(1) = hrg(irg-1) ; f(1) = sou(irg-1,itg,ipg)
00027 !cmout          x(2) = hrg(irg)   ; f(2) = sou(irg,itg,ipg)
00028 !cmout          v = 0.5d0*(hsurf + rg(irg-1))
00029 !cmout          sougc = lagint_2nd(x,f,v)
00030 !cmout          sou(irg,itg,ipg) = sougc*(v/hrg(irg))**2 &
00031 !cmout          &                *(hsurf-rg(irg-1))/drg(irg)
00032 !cmout          exit
00033 !cmout        end if
00034 !cmout        if (rg(irg) < hsurf.and.hsurf < hrg(irg+1)) then 
00035 !!!        sou(irg,itg,ipg) = sou(irg,itg,ipg)
00036 !!!                         *(1.d0+(hsurf-rg(irg))/drg(irg+1))
00037 !cmout          x(1) = hrg(irg-1) ; f(1) = sou(irg-1,itg,ipg)
00038 !cmout          x(2) = hrg(irg)   ; f(2) = sou(irg,itg,ipg)
00039 !bak          v = 0.5d0*(hsurf + rg(irg-1))
00040 !cmout          v = 0.5d0*(hsurf + rg(irg))
00041 !cmout          sougc = lagint_2nd(x,f,v)
00042 !bak          sou(irg,itg,ipg) = sougc*(v/hrg(irg))**2 &
00043 !bak          &                *(1.d0+(hsurf-rg(irg))/drg(irg+1))
00044 !cmout          sou(irg+1,itg,ipg) = sougc*(v/hrg(irg+1))**2 &
00045 !cmout          &                  *(hsurf-rg(irg))/drg(irg+1)
00046 !cmout          exit
00047 !cmout        end if
00048       end do
00049     end do
00050   end do
00051 end subroutine correct_matter_source_midpoint
/home/uryu/Cocal_svn_checkinout/Cocal/code/Subroutine/correct_matter_source_midpoint.f90
