00001 subroutine source_trfreeG_WL(souten)
00002 use grid_parameter, only : nrg, ntg, npg, nrf, ntf, npf
00003 use interface_sourceterm_trfreeG_WL
00004 use interface_sourceterm_trfreeG_drot_SFC
00005 use interface_interpo_fl2gr_midpoint
00006 use interface_correct_matter_source_midpoint
00007 use make_array_3d
00008 use make_array_4d
00009 implicit none
00010 real(8), pointer :: souten(:,:,:,:)
00011 real(8), pointer :: soutenf(:,:,:,:), souf(:,:,:), soug(:,:,:)
00012 real(8), pointer :: sou1(:,:,:,:), sou2(:,:,:,:)
00013 integer :: ia
00014
00015 call alloc_array4d(soutenf,0,nrf,0,ntf,0,npf,1,6)
00016 call alloc_array3d(souf,0,nrf,0,ntf,0,npf)
00017 call alloc_array3d(soug,0,nrg,0,ntg,0,npg)
00018 call alloc_array4d(sou1,0,nrg,0,ntg,0,npg,1,6)
00019 call alloc_array4d(sou2,0,nrg,0,ntg,0,npg,1,6)
00020
00021 call sourceterm_trfreeG_drot_SFC(soutenf)
00022 do ia = 1, 6
00023 souf(0:nrf,0:ntf,0:npf) = soutenf(0:nrf,0:ntf,0:npf,ia)
00024 call interpo_fl2gr_midpoint(souf,soug)
00025 call correct_matter_source_midpoint(soug)
00026 sou1(0:nrg,0:ntg,0:npg,ia) = soug(0:nrg,0:ntg,0:npg)
00027 end do
00028 call sourceterm_trfreeG_WL(sou2)
00029 souten(0:nrg,0:ntg,0:npg,1:6) = sou1(0:nrg,0:ntg,0:npg,1:6) &
00030 & + sou2(0:nrg,0:ntg,0:npg,1:6)
00031
00032 deallocate(soutenf)
00033 deallocate(souf)
00034 deallocate(soug)
00035 deallocate(sou1)
00036 deallocate(sou2)
00037
00038 end subroutine source_trfreeG_WL
