da_roughness_from_lanu.inc

1 subroutine da_roughness_from_lanu(ltbl, mminlu, date, xp, lanu, rough)
2 
3    !-----------------------------------------------------------------------
4    ! Purpose: TBD
5    !-----------------------------------------------------------------------
6 
7    implicit none
8 
9    integer             ,   intent(in)    :: ltbl
10    character (len=4)   ,   intent(in)    :: mminlu
11    character (len=19)  ,   intent(in)    :: date
12    type (xpose_type),      intent(in)    :: xp  ! domain decomposition vars.
13    real, dimension(xp%ims:xp%ime,xp%jms:xp%jme),   intent(in)    :: lanu 
14    real, dimension(xp%ims:xp%ime,xp%jms:xp%jme),   intent(out)   :: rough 
15 
16    integer                               :: LS, LC, LI, LUCATS, LuseAS, &
17                                            LUMATCH, year, month, day,  &
18                                            julday, Isn, io_error, &
19                                            m1, m2, n1, n2 
20    real                                  :: albd, slmo, sfem
21    real(kind=4), dimension(50,2)         :: sfz0
22    character (len=4)                     :: LUtype
23    logical                               :: exist
24 
25    if (trace_use) call da_trace_entry("da_roughness_from_lanu")
26 
27    read(unit=date,fmt='(I4,1x,I2,1X,I2)') year, month, day
28    call da_julian_day(year,month,day,Julday, 1)
29    Isn = 1
30    if (JULDAY < 105 .OR. JULDAY > 288) Isn=2
31 
32    inquire (file = 'LANDUSE.TBL', exist = exist)
33 
34    if (exist) then
35       open (unit = ltbl, file = 'LANDUSE.TBL', form='formatted', &
36                      action = 'read', iostat = io_error)
37    else
38       call da_error(__FILE__,__LINE__,&
39          (/"Cannot open file LANDUSE.TBL for conversion of roughness"/))
40    end if
41 
42    lumatch=0  
43 
44    do
45       read (unit=ltbl,fmt='(A4)', iostat=io_error) lutype
46       if (io_error /= 0) exit
47       read (unit=ltbl,fmt=*, iostat=io_error) lucats,luseas
48 
49       if (lutype == mminlu) lumatch=1 
50 
51       do LS=1,LuseAS 
52          read (unit=ltbl,fmt=*)  
53          do lc=1,lucats 
54             if (lutype == mminlu) then 
55                read (unit=ltbl,fmt=*) li, albd, slmo, sfem, sfz0(lc,ls)
56                ! prevent compiler whinge
57                if (albd == 0.0 .or. sfem == 0.0 .or. slmo == 0.0) then
58                end if
59                if (LC /= LI) then
60                  call da_error(__FILE__,__LINE__, &
61                    (/"Missing landuse: lc"/))
62                end if
63             else 
64                read (unit=ltbl,fmt=*) 
65             end if 
66          end do 
67       end do
68    end do
69 
70    close (unit=ltbl)
71 
72    if (lumatch == 0)then
73     call da_error(__FILE__,__LINE__,&
74       (/"landuse in input file does not match lutable"/))
75    end if   
76 
77    m1 = xp % its
78    m2 = xp % ite
79    n1 = xp % jts
80    n2 = xp % jte
81 
82    do lc = m1,m2
83       do ls = n1,n2
84          Li = int(lanu(lc,ls)+0.001)
85          rough(lc,ls) =  sfz0(Li,Isn)/100.
86       end do
87    end do
88 
89    if (trace_use) call da_trace_exit("da_roughness_from_lanu")
90 
91 end subroutine da_roughness_from_lanu
92 
93