<p><b>laura@ucar.edu</b> 2011-01-13 16:35:29 -0700 (Thu, 13 Jan 2011)</p><p>Reads initial land-surface data from file LANDUSE.TBL<br>
</p><hr noshade><pre><font color="gray">Added: branches/atmos_physics/src/core_physics/module_physics_landuse.F
===================================================================
--- branches/atmos_physics/src/core_physics/module_physics_landuse.F (rev 0)
+++ branches/atmos_physics/src/core_physics/module_physics_landuse.F 2011-01-13 23:35:29 UTC (rev 688)
@@ -0,0 +1,241 @@
+#define DM_BCAST_CHAR(A) call dmpar_bcast_char(dminfo,A)
+#define DM_BCAST_MACRO(A) call dmpar_bcast_reals(dminfo,size(A),A)
+#define DM_BCAST_INTEGER(A) call dmpar_bcast_int(dminfo,A)
+
+!=============================================================================================
+ module module_physics_landuse
+ use configure,only: input_sfc_albedo,input_landuse_data
+ use dmpar
+ use grid_types
+
+ use module_physics_aquaplanet !for now,we set the julian day to March 21.
+ use module_physics_utilities
+
+ implicit none
+ private
+ public:: landuse_init_forMPAS
+
+!This module reads the file LANDUSE.TBL which defines the land type of each cell, depending on
+!the origin of the input data, as defined by the value of the variable "sfc_input_data".
+!The allowed values for sfc_input_data are:
+! input_sfc_data = OLD. (13 land types / summer and winter).
+! input_sfc_data = USGS. (33 land types / summer and winter).
+! input_sfc_data = MODIFIED_IGBP_MODIS_NOAH (33 land types / summer and winter).
+! input_sfc_data = SiB (16 land types / summer and winter).
+! input_sfc_data = LW12 ( 3 land types / all seasons).
+
+ integer,parameter:: frac_seaice = 0. ! = 1: treats seaice as fractional field.
+ ! = 0: ice/no-ice flag.
+
+ contains
+
+!=============================================================================================
+ subroutine landuse_init_forMPAS(dminfo,mesh,diag_physics,sfc_physics,sfc_input)
+!=============================================================================================
+
+!input arguments:
+ type(dm_info),intent(in):: dminfo
+ type(mesh_type),intent(in):: mesh
+ type(diag_physics_type),intent(in):: diag_physics
+ type(sfc_physics_type) ,intent(in):: sfc_physics
+ type(sfc_input_type) ,intent(in):: sfc_input
+
+!local variables:
+ character(len=35) :: lutype
+ character(len=128):: mess
+
+ integer,parameter:: land_unit = 15
+ integer,parameter:: open_ok = 0
+ integer,parameter:: max_cats = 100
+ integer,parameter:: max_seas = 12
+
+ integer:: ierr,istat
+ integer:: ic,is,isice,isn,iswater,lucats,lumatch,luseas
+ integer:: iCell,nCells
+
+ real(kind=RKIND):: li,xice_threshold
+ real(kind=RKIND),dimension(max_cats,max_seas):: albd,slmo,sfem,sfz0,therin,scfx,sfhc
+
+ real(kind=RKIND),dimension(:),pointer:: latCell
+ real(kind=RKIND),dimension(:),pointer:: lu_index,snoalb,snowc,xice
+ real(kind=RKIND),dimension(:),pointer:: albbck,embck,xicem,xland,z0
+ real(kind=RKIND),dimension(:),pointer:: mavail,sfc_albedo,sfc_emiss,thc,znt
+
+!---------------------------------------------------------------------------------------------
+
+ write(0,*) '--- enter subroutine landuse_init_forMPAS: julday=',julday
+
+ nCells = mesh % nCells
+ latCell => mesh % latCell % array
+
+ lu_index => sfc_input % lu_index % array
+ snoalb => sfc_input % snoalb % array
+ snowc => sfc_input % snowc % array
+ xice => sfc_input % xice % array
+
+ albbck => sfc_physics % albbck % array
+ embck => sfc_physics % embck % array
+ xicem => sfc_physics % xicem % array
+ xland => sfc_physics % xland % array
+ z0 => sfc_physics % z0 % array
+
+ mavail => diag_physics % mavail % array
+ sfc_albedo => diag_physics % sfc_albedo % array
+ sfc_emiss => diag_physics % sfc_emiss % array
+ thc => diag_physics % thc % array
+ znt => diag_physics % znt % array
+
+!reads in the landuse properties from landuse.tbl:
+ if(dminfo % my_proc_id == IO_NODE) then
+ open(land_unit,file='LANDUSE.TBL',form='FORMATTED',status='OLD',iostat=istat)
+ if(istat /= open_ok) &
+ call physics_error_fatal(istat,'subroutine landuse_init_forMPAS: ' // &
+ 'failure opening LANDUSE.TBL')
+
+ lumatch=0
+ find_lutype : do while (lumatch == 0)
+ read(unit=land_unit,*,iostat=ierr) lutype
+ read(unit=land_unit,*,iostat=ierr) lucats,luseas
+
+ if(lutype .eq. input_landuse_data)then
+ write(mess,*) 'landuse type = ' // trim (lutype) // ' found', lucats, &
+ ' categories', luseas, ' seasons'
+ call physics_message(mess)
+ lumatch=1
+ else
+ write(mess,*) 'skipping over lutype = ' // trim (lutype)
+ call physics_message(mess)
+ do is = 1,luseas
+ read(unit=land_unit,*,iostat=ierr)
+ do ic = 1,lucats
+ read(unit=land_unit,*)
+ enddo
+ enddo
+ endif
+ enddo find_lutype
+
+ do is = 1, luseas
+ read(unit=land_unit,*,iostat=ierr)
+ do ic = 1, lucats
+ read(unit=land_unit,*) li,albd(ic,is),slmo(ic,is),sfem(ic,is),sfz0(ic,is), &
+ therin(ic,is),scfx(ic,is),sfhc(ic,is)
+ enddo
+ enddo
+
+!defines the index iswater and isice as a function of sfc_input_data:
+ sfc_input_select: select case(trim(lutype))
+ case('OLD')
+ iswater = 7
+ isice = 11
+ case('USGS')
+ iswater = 16
+ isice = 24
+ case('MODIFIED_IGBP_MODIS_NOAH')
+ iswater = 17
+ isice = 15
+ case('SiB')
+ iswater = 15
+ isice = 16
+ case('LW12')
+ iswater = 2
+ isice = 3
+ case default
+ end select sfc_input_select
+ endif
+
+ DM_BCAST_CHAR(lutype)
+ DM_BCAST_INTEGER(luseas)
+ DM_BCAST_INTEGER(lucats)
+ DM_BCAST_INTEGER(iswater)
+ DM_BCAST_INTEGER(isice)
+ DM_BCAST_MACRO(albd)
+ DM_BCAST_MACRO(slmo)
+ DM_BCAST_MACRO(sfem)
+ DM_BCAST_MACRO(sfz0)
+ DM_BCAST_MACRO(therin)
+ DM_BCAST_MACRO(sfhc)
+ DM_BCAST_MACRO(scfx)
+
+ do is = 1, luseas
+ do ic = 1, lucats
+ write(0,101) ic,albd(ic,is),slmo(ic,is),sfem(ic,is),sfz0(ic,is), &
+ therin(ic,is),scfx(ic,is),sfhc(ic,is)
+ enddo
+ if(is .lt. luseas) write(0,*)
+ enddo
+
+!defines sea-ice threshold:
+ if(frac_seaice == 0) then
+ xice_threshold = 0.5
+ elseif(frac_seaice == 1) then
+ xice_threshold = 0.02
+ endif
+
+!defines the surface properties over the entire domain:
+ do iCell = 1, nCells
+
+ !finds the season as function of julian day (summer=1, winter=2):
+ isn = 1
+ if(julday.lt.0.05 .or. julday.gt.288) isn=2
+ if(latCell(iCell) .lt. 0.) isn=3-isn
+
+ is = nint(lu_index(iCell))
+
+ !set no data points to water:
+ if(is.eq.0) is = iswater
+ if(.not. input_sfc_albedo) albbck(iCell) = albd(is,isn)/100.
+ sfc_albedo(iCell) = albbck(iCell)
+
+ if(snowc(iCell) .gt. 0.5) then
+ if(input_sfc_albedo) then
+ sfc_albedo(iCell) = snoalb(iCell)
+ else
+ sfc_albedo(iCell) = albbck(iCell) / (1+scfx(is,isn))
+ endif
+ endif
+ thc(iCell) = therin(is,isn) / 100.
+ z0(iCell) = sfz0(is,isn) / 100.
+ znt(iCell) = z0(iCell)
+ mavail(iCell) = slmo(is,isn)
+ embck(iCell) = sfem(is,isn)
+ sfc_emiss(iCell) = embck(iCell)
+
+ if(is .ne. iswater) then
+ xland(iCell) = 1.0
+ else
+ xland(iCell) = 2.0
+ endif
+
+ !set sea-ice points to land with ice/snow surface properties:
+ xicem(iCell) = xice(iCell)
+ if(xice(iCell) .ge. xice_threshold) then
+ xland(iCell) = 1.0
+ albbck(iCell) = albd(isice,isn) / 100.
+ embck(iCell) = sfem(isice,isn) / 100.
+ if(frac_seaice .eq. 1) then
+ !0.08 is the albedo over open water.
+ !0.98 is the emissivity over open water.
+ sfc_albedo(iCell) = xice(iCell)*albbck(iCell) + (1-xice(iCell))*0.08
+ sfc_emiss(iCell) = xice(iCell)*embck(iCell) + (1-xice(iCell))*0.98
+ else
+ sfc_albedo(iCell) = albbck(iCell)
+ sfc_emiss(iCell) = embck(iCell)
+ endif
+ thc(iCell) = therin(isice,isn) / 100.
+ z0(icell) = sfz0(isice,isn) / 100.
+ znt(iCell) = z0(iCell)
+ mavail(iCell) = slmo(isice,isn)
+ endif
+
+ enddo
+
+ write(0,*) '--- end subroutine landuse_init_forMPAS'
+
+!formats:
+ 101 format(i4,8e15.8)
+
+ end subroutine landuse_init_forMPAS
+
+!=============================================================================================
+ end module module_physics_landuse
+!=============================================================================================
</font>
</pre>