!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
***s/r bubble - generates initial condition for convective bubble
* experiment (Robert, A.)
*
#include "model_macros_f.h"
*
subroutine bubble 1
implicit none
*
*author
* Sylvie Gravel - rpn - Apr 2003
*
*revision
* v3_11 - Gravel S. - initial version
*
*object
*
*arguments
* none
*
*interfaces
INTERFACE
subroutine acqui
#include "acq_int.cdk"
end subroutine acqui
END INTERFACE
*
*implicits
#include "glb_ld.cdk"
#include "dcst.cdk"
#include "lun.cdk"
#include "ptopo.cdk"
#include "cstv.cdk"
#include "geomg.cdk"
#include "grd.cdk"
#include "pres.cdk"
#include "tr3d.cdk"
#include "vt1.cdk"
#include "ind.cdk"
#include "acq.cdk"
#include "theo.cdk"
#include "bubble.cdk"
*
integer i,j,k,l,err
integer i00
real psmin, psmax, radius, radius2, sm_rad, pert_t, s
integer vmmlod, vmmget, vmmuld
external vmmlod, vmmget, vmmuld
integer key0, key(Tr3d_ntr)
real, allocatable, dimension(: ) :: work
real tr
pointer (patr, tr(LDIST_SHAPE,*))
**
* ---------------------------------------------------------------
*
if (Ptopo_myproc.eq.0) then
write(lun_out,9000)
endif
*
sm_rad = 0.5*bb_radius
if ( Theo_case_S .eq. '2_BUBBLES') sm_rad = 3.*bb_radius
*
allocate(work(g_nk))
*---------------------------------------------------------------------
* Generate pressure field from Pres_ptop, Cstv_pisrf_8, and coordinate
* Generate corresponding temperature and geopotential height for
* isentropic atmosphere with Theta=Cstv_tstr_8
* Set winds to zero
*---------------------------------------------------------------------
do k=1,g_nk
work(k) = Geomg_pia(k) + Geomg_pibb(k)*Cstv_pisrf_8*100.
do j=1,l_nj
do i=1,l_ni
Ind_t (i,j,k) =
$ bb_isoth*(work(k)/(Cstv_pisrf_8*100.))**Dcst_cappa_8
Ind_fi(i,j,k) =
$ Dcst_rgasd_8*(bb_isoth-Ind_t(i,j,k))/Dcst_cappa_8
Ind_u (i,j,k) = 0.
Ind_v (i,j,k) = 0.
enddo
enddo
enddo
*---------------------------------------------------------------------
* Initialize 2D fields
*---------------------------------------------------------------------
do j=1,l_nj
do i=1,l_ni
Ind_q(i,j,g_nk) = alog(work(g_nk))
Ind_q(i,j,1 ) = alog(work(1))
Ind_topo(i,j) = 0.
end do
end do
*
psmin=Cstv_pisrf_8*100.
psmax=Cstv_pisrf_8*100.
*
if ( Ptopo_myproc.eq.0 ) then
write(lun_out,*)'PSMIN = ',PSMIN,' PSMAX = ',PSMAX,
$ ' PSMINMAX = ',0.5*(PSMIN+PSMAX),' (PASCAL)'
endif
*
Pres_surf = Cstv_pisrf_8*100.
Pres_top = dble(Pres_ptop*100.)
*
call rpn_comm_xch_halo ( Ind_topo, LDIST_DIM,l_ni,l_nj,1,
$ G_halox,G_haloy,G_periodx,G_periody,l_ni,0 )
*---------------------------------------------------------------------
* Generate perturbation for temperature field
*---------------------------------------------------------------------
do k=1,g_nk
do j=1,l_nj
do i=1,l_ni
i00 = i + l_i0 - 1
radius = sqrt((float(i00)-bb_xcntr)**2. + (float(k)-bb_zcntr)**2.)
pert_t = 0.0
if (radius .le. bb_radius .and. Theo_case_S .eq. 'BUBBLE')
$ pert_t = bb_dpth
if ( Theo_case_S .eq. 'BUBBLE_G'.or. Theo_case_S .eq. '2_BUBBLES') then
if( radius .le. sm_rad) then
pert_t = bb_dpth
else
pert_t = bb_dpth*exp(-((radius-sm_rad)/bb_radius)**2)
endif
endif
if ( Theo_case_S .eq. '2_BUBBLES') then
radius2=
$ sqrt((float(i00)-bb_xcntr2)**2. + (float(k)-bb_zcntr2)**2.)
if (radius2 .le. bb_radius2)
$ pert_t = bb_dpth2*exp(-(radius2/bb_radius2)**2)
endif
Ind_t (i,j,k) = Ind_t(i,j,k) + pert_t
enddo
enddo
enddo
deallocate (work)
*---------------------------------------------------------------------
* create tracers (humidity and BB)
*---------------------------------------------------------------------
key0 = VMM_KEY (trt1)
do k=1,Tr3d_ntr
key(k) = key0 + k
end do
if (Tr3d_ntr.gt.0) then
err = vmmlod(key,Tr3d_ntr)
do k=1,Tr3d_ntr
err = vmmget(key(k),patr,tr)
if (Tr3d_name_S(k).eq.'HU') then
do l=1,G_nk
do j=1,l_nj
do i=1,l_ni
tr(i,j,l) = 0.
end do
end do
end do
elseif (Tr3d_name_S(k).eq.'BB') then
do l=1,G_nk
do j=1,l_nj
do i=1,l_ni
i00 = i + l_i0 - 1
radius = sqrt((float(i00)-bb_xcntr)**2. +
$ (float(l)-bb_zcntr)**2.)
tr(i,j,l) = 0.
if (radius .le. bb_radius .and. Theo_case_S .eq. 'BUBBLE')
$ tr(i,j,l) = bb_dpth
if ( Theo_case_S .eq. 'BUBBLE_G'
$ .or. Theo_case_S .eq. '2_BUBBLES') then
if( radius .le. sm_rad) then
tr(i,j,l) = bb_dpth
else
tr(i,j,l) = bb_dpth*exp(-((radius-sm_rad)/bb_radius)**2)
endif
endif
if ( Theo_case_S .eq. '2_BUBBLES') then
radius2= sqrt((float(i00)-bb_xcntr2)**2. +
$ (float(l)-bb_zcntr2)**2.)
if (radius2 .le. bb_radius2)
$ tr(i,j,l) = bb_dpth2*exp(-(radius2/bb_radius2)**2)
endif
end do
end do
end do
endif
end do
err = vmmuld(key,Tr3d_ntr)
endif
9000 format(/,' CREATING INPUT DATA FOR BUBBLE THEORETICAL CASE '
+ /,' ===============================================')
*
* ---------------------------------------------------------------
*
return
end