module module_TERRAIN 1
private
public :: terrain_for, nmm_terrain
type nmm_terrain
integer :: nx,ny,level,input_type,io_form
real, pointer, dimension(:,:) :: avc,lnd,lah,loh
logical :: initialized
end type nmm_terrain
logical, save :: initialized=.false.
integer, parameter :: minlevel=0,maxlevel=20
type(nmm_terrain), target, save :: terrain(minlevel:maxlevel)
contains
function terrain_for(level,input_type,io_form) result(tr),10
implicit none
type(nmm_terrain), pointer :: tr
character*256 :: message
integer, intent(in) :: level,input_type,io_form
integer i
if(level<minlevel .or. level>maxlevel) then
3304 format("INVALID NESTING LEVEL ",I0,": only ",I0," through ",I0," are allowed.")
write(message,3304) level,minlevel,maxlevel
call wrf_error_fatal
(message)
endif
if(.not. initialized) then
call wrf_debug(3,'initialize...')
do i=minlevel,maxlevel
tr=>terrain(i)
tr%nx=0 ; tr%ny=0
tr%level=i
tr%initialized=.false.
nullify(tr%avc)
nullify(tr%lnd)
nullify(tr%lah)
nullify(tr%loh)
end do
initialized=.true.
call wrf_debug(3,'done with init.')
endif
call wrf_debug(3,'get terrain for this level')
tr=>terrain(level)
if(.not. tr%initialized) then
call wrf_debug(1,'terrain_for: need to read terrain')
call read_terrain(tr,input_type,io_form)
endif
call wrf_debug(3,'check input type and io form')
if(input_type /= tr%input_type) then
3306 format("MISMATCH IN INPUT_TYPE AT LEVEL ",I0,": input_type=",I0," and ",I0," both requested.")
write(message,3306) level,tr%input_type,input_type
call wrf_error_fatal(message)
endif
if(io_form /= tr%io_form) then
3309 format("MISMATCH IN IO_FORM AT LEVEL ",I0,": io_form=",I0," and ",I0," both reqested.")
write(message,3309) level,tr%io_form,io_form
call wrf_error_fatal(message)
endif
call wrf_debug(1,'terrain_for: returning')
end function terrain_for
subroutine read_terrain(tr,input_type,io_form) 1,36
USE module_domain
USE module_configure
USE module_timing
USE wrfsi_static
implicit none
type(nmm_terrain), pointer :: tr
integer, intent(in) :: io_form, input_type
integer, parameter :: IO_BIN=1, IO_NET=2
CHARACTER(LEN=6) :: nestpath
character(len=128) :: input_fname
integer :: comm_1,comm_2, handle,istatus
integer :: level
character (len=32) :: cname
integer :: ndim
character (len=3) :: memorder
character (len=32) :: stagger
integer, dimension(3) :: domain_start, domain_end
integer :: wrftype,n,i,j
character (len=128), dimension(3) :: dimnames
character*256 :: message
real, allocatable, dimension(:,:,:) :: real_domain
character (len=10), parameter :: name(24) = (/ "XLAT_M ", &
"XLONG_M ", &
"XLAT_V ", &
"XLONG_V ", &
"E ", &
"F ", &
"LANDMASK ", &
"LANDUSEF ", &
"LU_INDEX ", &
"HCNVX ", &
"HSTDV ", &
"HASYW ", &
"HASYS ", &
"HASYSW ", &
"HASYNW ", &
"HLENW ", &
"HLENS ", &
"HLENSW ", &
"HLENNW ", &
"HANIS ", &
"HSLOP ", &
"HANGL ", &
"HZMAX ", &
"HGT_M " /)
level=tr%level
write(nestpath,"(a4,i1,a1)") 'nest',level,'/'
input_types: if (input_type == 1) then
!
! si version of the static file
!
CALL get_wrfsi_static_dims(nestpath,tr%nx,tr%ny)
ALLOCATE (tr%avc(tr%nx,tr%ny))
ALLOCATE (tr%lnd(tr%nx,tr%ny))
ALLOCATE (tr%lah(tr%nx,tr%ny))
ALLOCATE (tr%loh(tr%nx,tr%ny))
CALL get_wrfsi_static_2d(nestpath, 'avc', tr%avc)
CALL get_wrfsi_static_2d(nestpath, 'lnd', tr%lnd)
CALL get_wrfsi_static_2d(nestpath, 'lah', tr%lah)
CALL get_wrfsi_static_2d(nestpath, 'loh', tr%loh)
else if (input_type == 2) then
!
! WPS version of the static file
!
call wrf_debug(3,'wps static file')
#ifdef INTIO
if (io_form == IO_BIN) write(input_fname,"(A,I2.2,A)") "geo_nmm_nest.l",level,".int"
#endif
#ifdef NETCDF
if (io_form == IO_NET) write(input_fname,"(A,I2.2,A)") "geo_nmm_nest.l",level,".nc"
#endif
comm_1 = 1
comm_2 = 1
#ifdef INTIO
if (io_form == IO_BIN) &
call ext_int_open_for_read(trim(input_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
#endif
#ifdef NETCDF
if (io_form == IO_NET) &
call ext_ncd_open_for_read(trim(input_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
#endif
if (istatus /= 0) CALL wrf_error_fatal('NEST_TERRAIN error after ext_XXX_open_for_read '//trim(input_fname))
read_loop: do n=1,24
cname = name(n)
domain_start = 1
domain_end = 1
#ifdef INTIO
if (io_form == IO_BIN) &
call ext_int_get_var_info(handle, cname, ndim, memorder, stagger, domain_start, domain_end, wrftype, istatus)
#endif
#ifdef NETCDF
if (io_form == IO_NET) &
call ext_ncd_get_var_info(handle, cname, ndim, memorder, stagger, domain_start, domain_end, wrftype, istatus)
#endif
if (allocated(real_domain)) deallocate(real_domain)
allocate(real_domain(domain_start(1):domain_end(1), domain_start(2):domain_end(2), domain_start(3):domain_end(3)))
#ifdef INTIO
if (io_form == IO_BIN) then
call ext_int_read_field(handle, '0000-00-00_00:00:00', cname, real_domain, wrftype, &
1, 1, 0, memorder, stagger, &
dimnames, domain_start, domain_end, domain_start, domain_end, &
domain_start, domain_end, istatus)
end if
#endif
#ifdef NETCDF
if (io_form == IO_NET) then
call ext_ncd_read_field(handle, '0000-00-00_00:00:00', cname, real_domain, wrftype, &
1, 1, 0, memorder, stagger, &
dimnames, domain_start, domain_end, domain_start, domain_end, &
domain_start, domain_end, istatus)
end if
#endif
write(message,'("domain nx=",I0," ny=",I0)') domain_end(1),domain_end(2)
tr%nx = domain_end(1)
tr%ny = domain_end(2)
write(message,'("nx=",I0," ny=",I0)') tr%nx,tr%ny
if (cname(1:10) == "XLAT_M ") then
call wrf_debug(10,'tr%lah...')
ALLOCATE (tr%lah(tr%nx,tr%ny))
call wrf_debug(10,'allocated...')
do j=1,tr%ny
do i=1,tr%nx
tr%lah(i,j) = real_domain(i,j,1)
end do
end do
call wrf_debug(10,'tr%lah.')
else if (cname(1:10) == "XLONG_M ") then
call wrf_debug(10,'tr%loh...')
ALLOCATE (tr%loh(tr%nx,tr%ny))
call wrf_debug(10,'allocated...')
do j=1,tr%ny
do i=1,tr%nx
tr%loh(i,j) = real_domain(i,j,1)
end do
end do
call wrf_debug(10,'tr%loh.')
else if (cname(1:10) == "LANDMASK ") then
call wrf_debug(10,'tr%lnd...')
ALLOCATE (tr%lnd(tr%nx,tr%ny))
call wrf_debug(10,'allocated...')
do j=1,tr%ny
do i=1,tr%nx
tr%lnd(i,j) = real_domain(i,j,1)
end do
end do
call wrf_debug(10,'tr%lnd')
else if (cname(1:10) == "HGT_M ") then
call wrf_debug(10,'tr%avc...')
ALLOCATE (tr%avc(tr%nx,tr%ny))
call wrf_debug(10,'allocated...')
do j=1,tr%ny
do i=1,tr%nx
tr%avc(i,j) = real_domain(i,j,1)
end do
end do
call wrf_debug(10,'tr%avc.')
end if
end do read_loop
call wrf_debug(10,"past read loop")
if(allocated(real_domain)) deallocate(real_domain)
call wrf_debug(10,'past deallocate')
#ifdef INTIO
if (io_form == IO_BIN) then
call ext_int_ioclose(handle, istatus)
end if
#endif
#ifdef NETCDF
if (io_form == IO_NET) then
call ext_ncd_ioclose(handle, istatus)
end if
#endif
call wrf_debug(10,"past close")
if(.not. associated(tr%lah)) call readfail(tr,input_fname,'lah')
if(.not. associated(tr%loh)) call readfail(tr,input_fname,'loh')
if(.not. associated(tr%lnd)) call readfail(tr,input_fname,'lnd')
if(.not. associated(tr%avc)) call readfail(tr,input_fname,'avc')
else
CALL wrf_error_fatal('NEST_TERRAIN wrong input_type')
end if input_types
tr%input_type=input_type
tr%io_form=io_form
tr%initialized=.true.
call wrf_debug(10,"done in read_terrain")
end subroutine read_terrain
subroutine readfail(tr,input_fname,what) 4,1
implicit none
type(nmm_terrain), pointer :: tr
character*256 :: message
character*3 :: what
character(len=128) :: input_fname
3123 format('Did not find "',A,'" in file "',A,'".')
write(message,3123) trim(what),trim(input_fname)
call wrf_error_fatal(message)
end subroutine readfail
end module module_TERRAIN