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