Juan 13/01/2014: add header SURFEX_LIC to all SURFEX files
[MNH-git_open_source-lfs.git] / src / SURFEX / get_teb_depths.F90
1 !SURFEX_LIC Copyright 1994-2014 Meteo-France 
2 !SURFEX_LIC This is part of the SURFEX software governed by the CeCILL-C  licence
3 !SURFEX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
4 !SURFEX_LIC for details. version 1.
5 !     #########
6       SUBROUTINE GET_TEB_DEPTHS(HFILEPGDTYPE, PD_ROOF, PD_ROAD, PD_WALL, PD_FLOOR)
7 !     ##############################################################
8 !
9 !!**** *CONVERT_COVER* 
10 !!
11 !!    PURPOSE
12 !!    -------
13 !!
14 !!    METHOD
15 !!    ------
16 !!   
17 !!    EXTERNAL
18 !!    --------
19 !!
20 !!    IMPLICIT ARGUMENTS
21 !!    ------------------
22 !!
23 !!    REFERENCE
24 !!    ---------
25 !!
26 !!    AUTHOR
27 !!    ------
28 !!
29 !!    V. Masson        Meteo-France
30 !!
31 !!    MODIFICATION
32 !!    ------------
33 !!
34 !!    Original    01/2004
35 !     
36 !----------------------------------------------------------------------------
37 !
38 !*    0.     DECLARATION
39 !            -----------
40 !
41 USE MODD_DATA_COVER,     ONLY : XDATA_D_ROOF, XDATA_D_ROAD, XDATA_D_WALL, XDATA_D_FLOOR
42 USE MODD_DATA_COVER_PAR, ONLY : JPCOVER, NDATA_ROOF_LAYER, NDATA_ROAD_LAYER, &
43                                 NDATA_WALL_LAYER, NDATA_FLOOR_LAYER
44 !
45 USE MODI_READ_SURF
46 USE MODI_AV_PGD
47 USE MODI_OLD_NAME
48 USE MODI_THERMAL_LAYERS_CONF
49 !
50 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
51 USE PARKIND1  ,ONLY : JPRB
52 !
53 USE MODI_ABOR1_SFX
54 !
55 IMPLICIT NONE
56 !
57 !*    0.1    Declaration of arguments
58 !            ------------------------
59 !
60  CHARACTER(LEN=6),   INTENT(IN)  :: HFILEPGDTYPE ! type of input file
61 !
62 REAL, DIMENSION(:,:), INTENT(OUT), OPTIONAL   :: PD_ROOF
63 REAL, DIMENSION(:,:), INTENT(OUT), OPTIONAL   :: PD_ROAD
64 REAL, DIMENSION(:,:), INTENT(OUT), OPTIONAL   :: PD_WALL
65 REAL, DIMENSION(:,:), INTENT(OUT), OPTIONAL   :: PD_FLOOR
66 !
67 !*    0.2    Declaration of local variables
68 !            ------------------------------
69 !
70 LOGICAL, DIMENSION(JPCOVER)          :: GCOVER ! flag to read the covers
71 REAL,    DIMENSION(:,:), ALLOCATABLE :: ZCOVER ! cover fractions
72 REAL,    DIMENSION(:,:), ALLOCATABLE :: ZD     ! depth of surface layers
73 REAL,    DIMENSION(:,:), ALLOCATABLE :: ZPAR_D ! depth of data_surface layers
74 REAL,    DIMENSION(:,:), ALLOCATABLE :: ZPAR_HC, ZPAR_TC, ZHC, ZTC ! work arrays
75 !
76 INTEGER           :: IVERSION       ! surface version
77 INTEGER           :: IBUGFIX        ! surface bugfix version
78  CHARACTER(LEN=5)  :: YSURF          ! Type of surface
79  CHARACTER(LEN=12) :: YRECFM         ! Name of the article to be read
80  CHARACTER(LEN=12) :: YRECFM0        ! Name of the article to be read
81  CHARACTER(LEN=12) :: YRECFM1        ! Name of the article to be read
82  CHARACTER(LEN=12) :: YRECFM2        ! Name of the article to be read
83  CHARACTER(LEN=3)  :: YAREA          ! Area where field is to be averaged
84 INTEGER           :: IRESP          ! reading return code
85 LOGICAL           :: GDATA          ! T if depth is to be read in the file
86 REAL, DIMENSION(SIZE(XDATA_D_ROOF,1),SIZE(XDATA_D_ROOF,2)) :: ZDATA
87 INTEGER :: ILAYER                   ! number of surface layers
88 INTEGER :: JLAYER                   ! loop counter on surface layers
89 INTEGER :: IPAR_LAYER               ! number of data surface layers
90 INTEGER :: IDATA_LAYER              ! number of data surface layers from ecoclimap
91 INTEGER :: ILU                      ! number of points
92 REAL(KIND=JPRB) :: ZHOOK_HANDLE
93 !-------------------------------------------------------------------------------
94 !
95 !*    2.      SECONDARY VARIABLES
96 !             -------------------
97 !
98 !*    2.2     fields on artificial surfaces only
99 !             ----------------------------------
100 !
101 IF (LHOOK) CALL DR_HOOK('GET_TEB_DEPTHS',0,ZHOOK_HANDLE)
102 !
103 YRECFM='VERSION'
104  CALL READ_SURF(HFILEPGDTYPE,YRECFM,IVERSION,IRESP)
105 YRECFM='BUG'
106  CALL READ_SURF(HFILEPGDTYPE,YRECFM,IBUGFIX,IRESP)
107 !
108 IF (PRESENT(PD_ROOF)) THEN
109   YSURF='ROOF '
110   ZDATA = XDATA_D_ROOF
111   YRECFM0 = 'PAR_RF_LAYER'
112   YRECFM1 = 'L_D_ROOF'
113   YRECFM2 = 'D_D_ROOF'
114   IDATA_LAYER = NDATA_ROOF_LAYER
115   ILU     = SIZE(PD_ROOF,1)
116   ILAYER  = SIZE(PD_ROOF,2)
117   YAREA   = 'BLD'
118 END IF
119 IF (PRESENT(PD_WALL)) THEN
120   YSURF='WALL '
121   ZDATA = XDATA_D_WALL
122   YRECFM0 = 'PAR_WL_LAYER'
123   YRECFM1 = 'L_D_WALL'
124   YRECFM2 = 'D_D_WALL'
125   IDATA_LAYER = NDATA_WALL_LAYER
126   ILU     = SIZE(PD_WALL,1)
127   ILAYER  = SIZE(PD_WALL,2)
128   YAREA   = 'BLD'
129 END IF
130 IF (PRESENT(PD_ROAD)) THEN
131   YSURF='ROAD '
132   ZDATA = XDATA_D_ROAD
133   YRECFM0 = 'PAR_RD_LAYER'
134   YRECFM1 = 'L_D_ROAD'
135   YRECFM2 = 'D_D_ROAD'
136   IDATA_LAYER = NDATA_ROAD_LAYER
137   ILU     = SIZE(PD_ROAD,1)
138   ILAYER  = SIZE(PD_ROAD,2)
139   YAREA   = 'STR'
140 END IF
141 IF (PRESENT(PD_FLOOR)) THEN
142   YSURF='FLOOR'
143   ZDATA = XDATA_D_FLOOR
144   YRECFM0 = 'PAR_FL_LAYER'
145   YRECFM1 = 'L_D_FLOOR'
146   YRECFM2 = 'D_D_FLOOR'
147   IDATA_LAYER = NDATA_FLOOR_LAYER
148   ILU     = SIZE(PD_FLOOR,1)
149   ILAYER  = SIZE(PD_FLOOR,2)
150   YAREA   = 'BLD'
151 END IF
152
153 ALLOCATE(ZD(ILU,ILAYER))
154 !
155 !* read if the depths description are written in the file
156 IF (IVERSION<7 .OR. (IVERSION==7 .AND. IBUGFIX<=2)) THEN
157   GDATA = .FALSE.
158 ELSE
159   CALL READ_SURF(HFILEPGDTYPE,YRECFM1,GDATA,IRESP)
160 END IF
161 !
162 !* depths are read in the file
163 IF (GDATA) THEN
164   !* gets number of data layers
165   CALL READ_SURF(HFILEPGDTYPE,YRECFM0,IPAR_LAYER,IRESP)
166   !* gets the data layers depths
167   ALLOCATE(ZPAR_D(ILU,IPAR_LAYER))
168   DO JLAYER=1,IPAR_LAYER
169     WRITE(YRECFM,FMT='(A,I1)') TRIM(YRECFM2),JLAYER
170     CALL READ_SURF(HFILEPGDTYPE,YRECFM,ZPAR_D(:,JLAYER),IRESP,HDIR='A')
171   END DO
172 !
173 ELSE
174 !* depths are deduced from the cover types
175   ALLOCATE(ZPAR_D(ILU,IDATA_LAYER))
176   !* reading of the cover to obtain the thickness of layers
177   CALL OLD_NAME(HFILEPGDTYPE,'COVER_LIST      ',YRECFM)
178   CALL READ_SURF(HFILEPGDTYPE,YRECFM,GCOVER(:),IRESP,HDIR='-')
179   !* reading of the cover fractions
180   ALLOCATE(ZCOVER(ILU,JPCOVER))
181   YRECFM='COVER'
182   CALL READ_SURF(HFILEPGDTYPE,YRECFM,ZCOVER(:,:),GCOVER,IRESP,HDIR='A')
183   !
184   !* deduces the depths of each layer
185   DO JLAYER=1,IDATA_LAYER
186     CALL AV_PGD (ZPAR_D(:,JLAYER), ZCOVER, ZDATA(:,JLAYER),YAREA,'ARI')
187   END DO
188   DEALLOCATE(ZCOVER)
189 ENDIF
190 !
191 !* recomputes the grid from the available data
192 !
193 IF (IVERSION<7 .OR. (IVERSION==7 .AND. IBUGFIX<=2)) THEN
194   !* in old version of TEB, the computational grid was equal to the data grid
195   ZD(:,:) = ZPAR_D(:,:)
196 ELSE
197   !* recomputes the grid from the available data
198   ALLOCATE(ZPAR_HC(ILU,SIZE(ZPAR_D,2)))
199   ALLOCATE(ZPAR_TC(ILU,SIZE(ZPAR_D,2)))
200   ALLOCATE(ZTC    (ILU,ILAYER))
201   ALLOCATE(ZHC    (ILU,ILAYER))
202   ZPAR_HC = 1.E6  ! not physically used
203   ZPAR_TC = 1.    ! not physically used
204   CALL THERMAL_LAYERS_CONF(YSURF,ZPAR_HC,ZPAR_TC,ZPAR_D,ZHC,ZTC,ZD)
205   DEALLOCATE(ZPAR_HC)
206   DEALLOCATE(ZPAR_TC)
207   DEALLOCATE(ZHC)
208   DEALLOCATE(ZTC)
209 END IF
210 !
211 IF (PRESENT(PD_ROOF )) PD_ROOF  = ZD
212 IF (PRESENT(PD_WALL )) PD_WALL  = ZD
213 IF (PRESENT(PD_ROAD )) PD_ROAD  = ZD
214 IF (PRESENT(PD_FLOOR)) PD_FLOOR = ZD
215 !
216 DEALLOCATE(ZD)
217 !
218 IF (LHOOK) CALL DR_HOOK('GET_TEB_DEPTHS',1,ZHOOK_HANDLE)
219 !-------------------------------------------------------------------------------
220 !
221 END SUBROUTINE GET_TEB_DEPTHS