<p><b>laura@ucar.edu</b> 2010-12-21 15:40:57 -0700 (Tue, 21 Dec 2010)</p><p>main drivers for short- and long-wave radiation codes<br>
</p><hr noshade><pre><font color="gray">Added: branches/atmos_physics/src/core_physics/module_driver_radiation_lw.F
===================================================================
--- branches/atmos_physics/src/core_physics/module_driver_radiation_lw.F (rev 0)
+++ branches/atmos_physics/src/core_physics/module_driver_radiation_lw.F 2010-12-21 22:40:57 UTC (rev 651)
@@ -0,0 +1,164 @@
+!=============================================================================================
+ module module_driver_radiation_lw
+ use grid_types
+
+ use module_physics_constants
+ use module_physics_vars
+
+!from wrf physics:
+!use module_ra_rrtmg_lw
+
+ implicit none
+ private
+ public:: allocate_radiation_lw, &
+ deallocate_radiation_lw, &
+ driver_radiation_lw, &
+ init_radiation_lw
+
+ integer,private:: i,j,k
+
+ contains
+
+!=============================================================================================
+ subroutine allocate_radiation_lw
+!=============================================================================================
+
+ if(.not.allocated(sfc_emiss_p) ) allocate(sfc_emiss_p(ims:ime,jms:jme) )
+ if(.not.allocated(snow_p) ) allocate(snow_p(ims:ime,jms:jme) )
+ if(.not.allocated(glw_p) ) allocate(glw_p(ims:ime,jms:jme) )
+ if(.not.allocated(lwcf_p) ) allocate(lwcf_p(ims:ime,jms:jme) )
+ if(.not.allocated(lwdnb_p) ) allocate(lwdnb_p(ims:ime,jms:jme) )
+ if(.not.allocated(lwdnbc_p) ) allocate(lwdnbc_p(ims:ime,jms:jme) )
+ if(.not.allocated(lwdnt_p) ) allocate(lwdnt_p(ims:ime,jms:jme) )
+ if(.not.allocated(lwdntc_p) ) allocate(lwdntc_p(ims:ime,jms:jme) )
+ if(.not.allocated(lwupb_p) ) allocate(lwupb_p(ims:ime,jms:jme) )
+ if(.not.allocated(lwupbc_p) ) allocate(lwupbc_p(ims:ime,jms:jme) )
+ if(.not.allocated(lwupt_p) ) allocate(lwupt_p(ims:ime,jms:jme) )
+ if(.not.allocated(lwuptc_p) ) allocate(lwuptc_p(ims:ime,jms:jme) )
+ if(.not.allocated(lwdnflx_p) ) allocate(lwdnflx_p(ims:ime,jms:jme) )
+ if(.not.allocated(lwdnflxc_p) ) allocate(lwdnflxc_p(ims:ime,jms:jme) )
+ if(.not.allocated(lwupflx_p) ) allocate(lwupflx_p(ims:ime,jms:jme) )
+ if(.not.allocated(lwupflxc_p) ) allocate(lwupflxc_p(ims:ime,jms:jme) )
+ if(.not.allocated(olrtoa_p) ) allocate(olrtoa_p(ims:ime,jms:jme) )
+
+ if(.not.allocated(rthratenlw_p) ) allocate(rthratenlw_p(ims:ime,kms:kme,jms:jme) )
+
+ end subroutine allocate_radiation_lw
+
+!=============================================================================================
+ subroutine deallocate_radiation_lw
+!=============================================================================================
+
+ if(allocated(sfc_emiss_p) ) deallocate(sfc_emiss_p )
+ if(allocated(snow_p) ) deallocate(snow_p )
+ if(allocated(glw_p) ) deallocate(glw_p )
+ if(allocated(lwcf_p) ) deallocate(lwcf_p )
+ if(allocated(lwdnb_p) ) deallocate(lwdnb_p )
+ if(allocated(lwdnbc_p) ) deallocate(lwdnbc_p )
+ if(allocated(lwdnt_p) ) deallocate(lwdnt_p )
+ if(allocated(lwdntc_p) ) deallocate(lwdntc_p )
+ if(allocated(lwupb_p) ) deallocate(lwupb_p )
+ if(allocated(lwupbc_p) ) deallocate(lwupbc_p )
+ if(allocated(lwupt_p) ) deallocate(lwupt_p )
+ if(allocated(lwuptc_p) ) deallocate(lwuptc_p )
+ if(allocated(lwdnflx_p) ) deallocate(lwdnflx_p )
+ if(allocated(lwdnflxc_p) ) deallocate(lwdnflxc_p )
+ if(allocated(lwupflx_p) ) deallocate(lwupflx_p )
+ if(allocated(lwupflxc_p) ) deallocate(lwupflxc_p )
+ if(allocated(olrtoa_p) ) deallocate(olrtoa_p )
+
+ if(allocated(rthratenlw_p) ) deallocate(rthratenlw_p )
+
+ end subroutine deallocate_radiation_lw
+
+!=============================================================================================
+ subroutine radiation_lw_from_MPAS(diag_physics,tend_physics)
+!=============================================================================================
+
+!inout arguments:
+ type(diag_physics_type),intent(inout):: diag_physics
+ type(tend_physics_type),intent(inout):: tend_physics
+
+!---------------------------------------------------------------------------------------------
+
+ end subroutine radiation_lw_from_MPAS
+
+!=============================================================================================
+ subroutine radiation_lw_to_MPAS(diag_physics,tend_physics)
+!=============================================================================================
+
+!input arguments:
+ type(diag_physics_type),intent(inout):: diag_physics
+ type(tend_physics_type),intent(inout):: tend_physics
+
+!---------------------------------------------------------------------------------------------
+
+ end subroutine radiation_lw_to_MPAS
+
+!=============================================================================================
+ subroutine init_radiation_lw
+!=============================================================================================
+
+ write(0,*) ' begin radiation_lw initialization:'
+ write(0,*) ' end radiation_lw initialization:'
+
+ end subroutine init_radiation_lw
+
+!=============================================================================================
+ subroutine driver_radiation_lw(diag_physics,tend_physics)
+!=============================================================================================
+
+!inout arguments:
+ type(diag_physics_type),intent(inout):: diag_physics
+ type(tend_physics_type),intent(inout):: tend_physics
+
+!---------------------------------------------------------------------------------------------
+ write(0,*)
+ write(0,*) '--- enter subroutine driver_radiation_lw:'
+
+!copy all MPAS arrays to rectangular grid:
+ call radiation_lw_from_MPAS(diag_physics,tend_physics)
+
+!call to longwave radiation scheme:
+ radiation_lw_select: select case (trim(radt_lw_scheme))
+
+ case ("rrtmg_lw")
+ write(0,*) '--- enter subroutine rrtmg_lw:'
+
+! call rrtmg_lwrad( &
+! rthratenlw = rthratenlw_p , lwupt = lwupt_p , lwuptc = lwuptc_p , &
+! lwdnt = lwdnt_p , lwdntc = lwdntc_p , lwupb = lwupb_p , &
+! lwupbc = lwupbc_p , lwdnb = lwdnb_p , lwdnbc = lwdnbc_p , &
+! lwcf = lwcf_p , glw = glw_p , olr = olrtoa_p , &
+! emiss = sfc_emiss_p , t3d = t_p , t8w = t2_p , &
+! tsk = tsk_p , p3d = pres_p , p8w = pres2_p , &
+! pi3d = pi_p , rho3d = rho_p , dz8w = dz_p , &
+! cldfra3d = cldfrac_p , r = R_d , g = g , &
+! icloud = icloud , warm_rain = warm_rain , f_ice_phy = f_ice , &
+! f_rain_phy = f_rain , xland = xland_p , xice = xice_p , &
+! snow = snow_p , qv3d = qv_p , qc3d = qc_p , &
+! qr3d = qr_p , qi3d = qi_p , qs3d = qs_p , &
+! qg3d = qg_p , f_qv = f_qv , f_qc = f_qc , &
+! f_qr = f_qr , f_qi = f_qi , f_qs = f_qs , &
+! f_qg = f_qg , &
+! !begin optional arguments:
+! lwupflx = lwupflx_p , lwupflxc = lwupflxc_p , lwdnflx = lwdnflx_p , &
+! lwdnflxc = lwdnflxc_p , &
+! !end optional arguments.
+! ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , &
+! ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , &
+! its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
+! )
+
+ case default
+
+ end select radiation_lw_select
+
+!copy all arrays back to MPAS geodesic grid:
+ call radiation_lw_to_MPAS(diag_physics,tend_physics)
+
+ end subroutine driver_radiation_lw
+
+!=============================================================================================
+ end module module_driver_radiation_lw
+!=============================================================================================
Added: branches/atmos_physics/src/core_physics/module_driver_radiation_sw.F
===================================================================
--- branches/atmos_physics/src/core_physics/module_driver_radiation_sw.F (rev 0)
+++ branches/atmos_physics/src/core_physics/module_driver_radiation_sw.F 2010-12-21 22:40:57 UTC (rev 651)
@@ -0,0 +1,338 @@
+!=============================================================================================
+ module module_driver_radiation_sw
+ use grid_types
+
+ use module_physics_aquaplanet !temporary until we have a time manager and sfc conditions.
+ use module_physics_constants
+ use module_physics_vars
+
+!from wrf physics:
+!use module_ra_rrtmg_sw
+
+ implicit none
+ private
+ public:: allocate_radiation_sw, &
+ deallocate_radiation_sw, &
+ driver_radiation_sw, &
+ init_radiation_sw
+
+ integer,private:: i,j,k
+
+ contains
+
+!=============================================================================================
+ subroutine allocate_radiation_sw
+!=============================================================================================
+
+ if(.not.allocated(xlat_p) ) allocate(xlat_p(ims:ime,jms:jme) )
+ if(.not.allocated(xlon_p) ) allocate(xlon_p(ims:ime,jms:jme) )
+
+ if(.not.allocated(xice_p) ) allocate(xice_p(ims:ime,jms:jme) )
+ if(.not.allocated(xland_p) ) allocate(xland_p(ims:ime,jms:jme) )
+
+ if(.not.allocated(sfc_albedo_p) ) allocate(sfc_albedo_p(ims:ime,jms:jme) )
+ if(.not.allocated(coszr_p) ) allocate(coszr_p(ims:ime,jms:jme) )
+ if(.not.allocated(snow_p) ) allocate(snow_p(ims:ime,jms:jme) )
+ if(.not.allocated(gsw_p) ) allocate(gsw_p(ims:ime,jms:jme) )
+ if(.not.allocated(swcf_p) ) allocate(swcf_p(ims:ime,jms:jme) )
+ if(.not.allocated(swdnb_p) ) allocate(swdnb_p(ims:ime,jms:jme) )
+ if(.not.allocated(swdnbc_p) ) allocate(swdnbc_p(ims:ime,jms:jme) )
+ if(.not.allocated(swdnt_p) ) allocate(swdnt_p(ims:ime,jms:jme) )
+ if(.not.allocated(swdntc_p) ) allocate(swdntc_p(ims:ime,jms:jme) )
+ if(.not.allocated(swupb_p) ) allocate(swupb_p(ims:ime,jms:jme) )
+ if(.not.allocated(swupbc_p) ) allocate(swupbc_p(ims:ime,jms:jme) )
+ if(.not.allocated(swupt_p) ) allocate(swupt_p(ims:ime,jms:jme) )
+ if(.not.allocated(swuptc_p) ) allocate(swuptc_p(ims:ime,jms:jme) )
+ if(.not.allocated(swdnflx_p) ) allocate(swdnflx_p(ims:ime,jms:jme) )
+ if(.not.allocated(swdnflxc_p) ) allocate(swdnflxc_p(ims:ime,jms:jme) )
+ if(.not.allocated(swupflx_p) ) allocate(swupflx_p(ims:ime,jms:jme) )
+ if(.not.allocated(swupflxc_p) ) allocate(swupflxc_p(ims:ime,jms:jme) )
+
+ if(.not.allocated(rthratensw_p) ) allocate(rthratensw_p(ims:ime,kms:kme,jms:jme) )
+
+ end subroutine allocate_radiation_sw
+
+!=============================================================================================
+ subroutine deallocate_radiation_sw
+!=============================================================================================
+
+ if(allocated(xlat_p) ) deallocate(xlat_p )
+ if(allocated(xlon_p) ) deallocate(xlon_p )
+
+ if(allocated(xice_p) ) deallocate(xice_p )
+ if(allocated(xland_p) ) deallocate(xland_p )
+
+ if(allocated(sfc_albedo_p) ) deallocate(sfc_albedo_p )
+ if(allocated(coszr_p) ) deallocate(coszr_p )
+ if(allocated(snow_p) ) deallocate(snow_p )
+ if(allocated(gsw_p) ) deallocate(gsw_p )
+ if(allocated(swcf_p) ) deallocate(swcf_p )
+ if(allocated(swdnb_p) ) deallocate(swdnb_p )
+ if(allocated(swdnbc_p) ) deallocate(swdnbc_p )
+ if(allocated(swdnt_p) ) deallocate(swdnt_p )
+ if(allocated(swdntc_p) ) deallocate(swdntc_p )
+ if(allocated(swupb_p) ) deallocate(swupb_p )
+ if(allocated(swupbc_p) ) deallocate(swupbc_p )
+ if(allocated(swupt_p) ) deallocate(swupt_p )
+ if(allocated(swuptc_p) ) deallocate(swuptc_p )
+ if(allocated(swdnflx_p) ) deallocate(swdnflx_p )
+ if(allocated(swdnflxc_p) ) deallocate(swdnflxc_p )
+ if(allocated(swupflx_p) ) deallocate(swupflx_p )
+ if(allocated(swupflxc_p) ) deallocate(swupflxc_p )
+
+ if(allocated(rthratensw_p) ) deallocate(rthratensw_p )
+
+ end subroutine deallocate_radiation_sw
+
+!=============================================================================================
+ subroutine radiation_sw_from_MPAS(mesh,diag_physics,tend_physics)
+!=============================================================================================
+
+!input arguments:
+ type(mesh_type),intent(in):: mesh
+
+!inout arguments:
+ type(diag_physics_type),intent(inout):: diag_physics
+ type(tend_physics_type),intent(inout):: tend_physics
+
+!---------------------------------------------------------------------------------------------
+
+ do j = jts,jte
+
+ do i = its,ite
+ xlat_p(i,j) = mesh % latCell % array(i)
+ xlon_p(i,j) = mesh % lonCell % array(i)
+
+ xice_p(i,j) = diag_physics % xice % array(i)
+ xland_p(i,j) = diag_physics % xland % array(i)
+ sfc_albedo_p(i,j) = diag_physics % sfc_albedo % array(i)
+ coszr_p(i,j) = diag_physics % coszr % array(i)
+ snow_p(i,j) = diag_physics % snow % array(i)
+
+ gsw_p(i,j) = diag_physics % gsw % array(i)
+ swcf_p(i,j) = diag_physics % swcf % array(i)
+ swdnb_p(i,j) = diag_physics % swdnb % array(i)
+ swdnbc_p(i,j) = diag_physics % swdnbc % array(i)
+ swdnt_p(i,j) = diag_physics % swdnt % array(i)
+ swdntc_p(i,j) = diag_physics % swdntc % array(i)
+ swupb_p(i,j) = diag_physics % swupb % array(i)
+ swupbc_p(i,j) = diag_physics % swupbc % array(i)
+ swupt_p(i,j) = diag_physics % swupt % array(i)
+ swuptc_p(i,j) = diag_physics % swuptc % array(i)
+ swdnflx_p(i,j) = diag_physics % swdnflx % array(i)
+ swdnflxc_p(i,j) = diag_physics % swdnflxc % array(i)
+ swupflx_p(i,j) = diag_physics % swupflx % array(i)
+ swupflxc_p(i,j) = diag_physics % swupflxc % array(i)
+ enddo
+
+ do k = kts,kte
+ do i = its,ite
+ rthratensw_p(i,k,j) = tend_physics % rthratensw % array(i,k)
+ enddo
+ enddo
+
+ enddo
+
+ end subroutine radiation_sw_from_MPAS
+
+!=============================================================================================
+ subroutine radiation_sw_to_MPAS(diag_physics,tend_physics)
+!=============================================================================================
+
+!input arguments:
+ type(diag_physics_type),intent(inout):: diag_physics
+ type(tend_physics_type),intent(inout):: tend_physics
+
+!---------------------------------------------------------------------------------------------
+
+ do j = jts,jte
+
+ do i = its,ite
+ diag_physics % xice % array(i) = xice_p(i,j)
+ diag_physics % xland % array(i) = xland_p(i,j)
+ diag_physics % sfc_albedo % array(i) = sfc_albedo_p(i,j)
+ diag_physics % coszr % array(i) = coszr_p(i,j)
+ diag_physics % snow % array(i) = snow_p(i,j)
+ diag_physics % gsw % array(i) = gsw_p(i,j)
+ diag_physics % swcf % array(i) = swcf_p(i,j)
+ diag_physics % swdnb % array(i) = swdnb_p(i,j)
+ diag_physics % swdnbc % array(i) = swdnbc_p(i,j)
+ diag_physics % swdnt % array(i) = swdnt_p(i,j)
+ diag_physics % swdntc % array(i) = swdntc_p(i,j)
+ diag_physics % swupb % array(i) = swupb_p(i,j)
+ diag_physics % swupbc % array(i) = swupbc_p(i,j)
+ diag_physics % swupt % array(i) = swupt_p(i,j)
+ diag_physics % swuptc % array(i) = swuptc_p(i,j)
+ diag_physics % swdnflx % array(i) = swdnflx_p(i,j)
+ diag_physics % swdnflxc % array(i) = swdnflxc_p(i,j)
+ diag_physics % swupflx % array(i) = swupflx_p(i,j)
+ diag_physics % swupflxc % array(i) = swupflxc_p(i,j)
+ enddo
+
+ do k = kts,kte
+ do i = its,ite
+ tend_physics % rthratensw % array(i,k) = rthratensw_p(i,k,j)
+ enddo
+ enddo
+
+ enddo
+
+ end subroutine radiation_sw_to_MPAS
+
+!=============================================================================================
+ subroutine init_radiation_sw(dminfo)
+!=============================================================================================
+
+!input arguments:
+ type(dm_info), intent(in):: dminfo
+
+!---------------------------------------------------------------------------------------------
+
+ write(0,*) ' begin radiation_sw initialization:'
+
+!call to shortwave radiation scheme:
+ radiation_sw_select: select case (trim(radt_sw_scheme))
+
+ case ("rrtmg_sw")
+
+ write(0,*) ' enter subroutine rrtmg_swinit:'
+ call rrtmg_swinit( &
+ dminfo = dminfo , allowed_to_read = allowed_to_read, &
+ ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , &
+ ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , &
+ its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
+ )
+ write(0,*) ' end subroutine rrtmg_swinit.'
+
+ case default
+
+ end select radiation_sw_select
+
+ write(0,*) ' end radiation_sw initialization:'
+
+ end subroutine init_radiation_sw
+
+!=============================================================================================
+ subroutine driver_radiation_sw(mesh,state,diag_physics,tend_physics)
+!=============================================================================================
+
+!input arguments:
+ type(mesh_type),intent(in) :: mesh
+ type(state_type),intent(in):: state
+
+!inout arguments:
+ type(diag_physics_type),intent(inout):: diag_physics
+ type(tend_physics_type),intent(inout):: tend_physics
+
+!local variables:
+ real(kind=RKIND),pointer:: xtime
+
+!---------------------------------------------------------------------------------------------
+ write(0,*)
+ write(0,*) '--- enter subroutine driver_radiation_sw:'
+
+ xtime => state % xtime % scalar
+
+!copy all MPAS arrays to rectangular grid:
+ call radiation_sw_from_MPAS(mesh,diag_physics,tend_physics)
+
+!... calculates solar declination:
+ call radconst(xtime,declin,solcon,julday,degrad,dpd)
+ write(0,*) ' xtime = ',xtime
+ write(0,*) ' declin = ',declin
+ write(0,*) ' solcon = ',solcon
+ write(0,*) ' julday = ',julday
+ write(0,*) ' degrad = ',degrad
+ write(0,*) ' dpd = ',dpd
+
+!call to shortwave radiation scheme:
+ radiation_sw_select: select case (trim(radt_sw_scheme))
+
+ case ("rrtmg_sw")
+ write(0,*) '--- enter subroutine rrtmg_sw:'
+ write(0,*) ' gmt = ', gmt
+ write(0,*) ' dt_radtsw = ', dt_radtsw
+
+! call rrtmg_swrad( &
+! rthratensw = rthratensw_p , swupt = swupt_p , swuptc = swuptc_p , &
+! swdnt = swdnt_p , swdntc = swdntc_p , swupb = swupb_p , &
+! swupbc = swupbc_p , swdnb = swdnb_p , swdnbc = swdnbc_p , &
+! swcf = swcf_p , gsw = gsw_p , xtime = xtime , &
+! gmt = gmt , xlat = xlat_p , xlong = xlon_p , &
+! radt = dt_radtsw , degrad = degrad , declin = declin , &
+! coszr = coszr_p , julday = julday , solcon = solcon , &
+! albedo = sfc_albedo_p , t3d = t_p , t8w = t2_p , &
+! tsk = tsk_p , p3d = pres_p , p8w = pres2_p , &
+! pi3d = pi_p , rho3d = rho_p , dz8w = dz_p , &
+! cldfra3d = cldfrac_p , r = R_d , g = g , &
+! icloud = icloud , warm_rain = warm_rain , f_ice_phy = f_ice , &
+! f_rain_phy = f_rain , xland = xland_p , xice = xice_p , &
+! snow = snow_p , qv3d = qv_p , qc3d = qc_p , &
+! qr3d = qr_p , qi3d = qi_p , qs3d = qs_p , &
+! qg3d = qg_p , f_qv = f_qv , f_qc = f_qc , &
+! f_qr = f_qr , f_qi = f_qi , f_qs = f_qs , &
+! f_qg = f_qg , &
+! !begin optional arguments:
+! swupflx = swupflx_p , swupflxc = swupflxc_p , swdnflx = swdnflx_p , &
+! swdnflxc = swdnflxc_p , &
+! !end optional arguments.
+! ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , &
+! ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , &
+! its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
+! )
+
+ case default
+
+ end select radiation_sw_select
+
+!copy all arrays back to MPAS geodesic grid:
+ call radiation_sw_to_MPAS(diag_physics,tend_physics)
+
+ end subroutine driver_radiation_sw
+
+!=============================================================================================
+ subroutine radconst(xtime,declin,solcon,julian,degrad,dpd)
+!=============================================================================================
+
+!input arguments:
+ integer,intent(in):: julian
+ real(kind=RKIND),intent(in):: degrad,dpd,xtime
+
+!output arguments:
+ real(kind=RKIND),intent(out):: declin,solcon
+
+!local variables:
+ real(kind=RKIND):: obecl,sinob,sxlong,arg,decdeg,djul,rjul,eccfac
+
+!---------------------------------------------------------------------------------------------
+
+ declin=0.
+ solcon=0.
+
+!obecl : obliquity = 23.5 degree.
+
+ obecl=23.5*degrad
+ sinob=sin(obecl)
+
+!calculate longitude of the sun from vernal equinox:
+
+ if(julian.ge.80.)sxlong=dpd*(julian-80.)
+ if(julian.lt.80.)sxlong=dpd*(julian+285.)
+ sxlong=sxlong*degrad
+ arg=sinob*sin(sxlong)
+ declin=asin(arg)
+ decdeg=declin/degrad
+
+!solar constant eccentricity factor (paltridge and platt 1976)
+
+ djul=julian*360./365.
+ rjul=djul*degrad
+ eccfac=1.000110+0.034221*cos(rjul)+0.001280*sin(rjul)+0.000719* &
+ cos(2*rjul)+0.000077*sin(2*rjul)
+ solcon=1370.*eccfac
+
+ end subroutine radconst
+
+!=============================================================================================
+ end module module_driver_radiation_sw
+!=============================================================================================
</font>
</pre>