da_roughness_from_lanu.inc

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