3261a2818091b6c198976f6a31bc4e28eb76b570
[MNH-git_open_source-lfs.git] / src / SURFEX / write_diag_pgd_grdnn.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 WRITE_DIAG_PGD_GRDN_n(HPROGRAM)
7 !     #########################################
8 !
9 !!****  *WRITE_DIAG_PGD_TEB_GARDEN_n* - writes the ISBA physiographic diagnostic fields
10 !!
11 !!    PURPOSE
12 !!    -------
13 !!
14 !!**  METHOD
15 !!    ------
16 !!
17 !!    EXTERNAL
18 !!    --------
19 !!
20 !!
21 !!    IMPLICIT ARGUMENTS
22 !!    ------------------
23 !!
24 !!    REFERENCE
25 !!    ---------
26 !!
27 !!
28 !!    AUTHOR
29 !!    ------
30 !!      V. Masson   *Meteo France*      
31 !!
32 !!    MODIFICATIONS
33 !!    -------------
34 !!      Original    01/2004 
35 !!      Modified    10/2004 by P. Le Moigne: add XZ0REL, XVEGTYPE_PATCH
36 !!      Modified    11/2005 by P. Le Moigne: limit length of VEGTYPE_PATCH field names
37 !-------------------------------------------------------------------------------
38 !
39 !*       0.    DECLARATIONS
40 !              ------------
41 !
42 USE MODD_SURF_PAR,       ONLY : XUNDEF
43 USE MODD_TEB_VEG_n,      ONLY : CPHOTO, CHORT
44 USE MODD_TEB_GARDEN_n,   ONLY : XLAI, XVEG, XZ0,XALBNIR_SOIL,XALBVIS_SOIL,XALBUV_SOIL,&
45                                 XRSMIN, XGAMMA, XRGL, XCV, XEMIS, XDG, XWRMAX_CF,     &
46                                 XVEGTYPE, XALBNIR, XALBVIS, XALBUV, XD_ICE  
47 !
48 USE MODD_DIAG_MISC_TEB_n,ONLY : LSURF_DIAG_ALBEDO
49 !
50 USE MODD_IO_SURF_FA, ONLY : LFANOCOMPACT, LPREP
51 !
52 USE MODI_INIT_IO_SURF_n
53 USE MODI_WRITE_SURF
54 USE MODI_END_IO_SURF_n
55 !
56 !
57 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
58 USE PARKIND1  ,ONLY : JPRB
59 !
60 IMPLICIT NONE
61 !
62 !*       0.1   Declarations of arguments
63 !              -------------------------
64 !
65  CHARACTER(LEN=6),  INTENT(IN)  :: HPROGRAM ! program calling
66 !
67 !*       0.2   Declarations of local variables
68 !              -------------------------------
69 !
70 INTEGER           :: IRESP          ! IRESP  : return-code if a problem appears
71  CHARACTER(LEN=12) :: YRECFM         ! Name of the article to be read
72  CHARACTER(LEN=100):: YCOMMENT       ! Comment string
73  CHARACTER(LEN=2)  :: YLVLV, YPAS
74 !
75 INTEGER           :: JL, JP
76 REAL(KIND=JPRB) :: ZHOOK_HANDLE
77 !-------------------------------------------------------------------------------
78 !
79 !         Initialisation for IO
80 !
81 IF (LHOOK) CALL DR_HOOK('WRITE_DIAG_PGD_GRDN_N',0,ZHOOK_HANDLE)
82  CALL INIT_IO_SURF_n(HPROGRAM,'TOWN  ','TEB   ','WRITE')
83 !
84 !* Leaf Area Index
85 !
86 IF (CPHOTO=='NON' .OR. CPHOTO=='AGS' .OR. CPHOTO=='AST') THEN
87   !
88   YRECFM='GD_LAI'
89   YCOMMENT='leaf area index (-)'
90   !
91   CALL WRITE_SURF(HPROGRAM,YRECFM,XLAI(:),IRESP,HCOMMENT=YCOMMENT)
92   !
93 ENDIF
94 !
95 !-------------------------------------------------------------------------------
96 !
97 !* Vegetation fraction
98 !
99 YRECFM='GD_VEG'
100 YCOMMENT='vegetation fraction (-)'
101 !
102  CALL WRITE_SURF(HPROGRAM,YRECFM,XVEG(:),IRESP,HCOMMENT=YCOMMENT)
103 !
104 !* Surface roughness length (without snow)
105 !
106 YRECFM='GD_Z0VEG'
107 YCOMMENT='surface roughness length (without snow) (M)'
108 !
109  CALL WRITE_SURF(HPROGRAM,YRECFM,XZ0(:),IRESP,HCOMMENT=YCOMMENT)
110 !
111 !-------------------------------------------------------------------------------
112 !
113 !* Soil depth for each patch
114 !
115 DO JL=1,SIZE(XDG,2)
116   WRITE(YRECFM,FMT='(A4,I1)') 'GD_DG',JL
117   YCOMMENT='soil depth'//' (M)'
118   CALL WRITE_SURF(HPROGRAM,YRECFM,XDG(:,JL),IRESP,HCOMMENT=YCOMMENT)
119 END DO
120 !
121 !-------------------------------------------------------------------------------
122 ! For Earth System Model
123 IF(LFANOCOMPACT.AND..NOT.LPREP)THEN
124    CALL END_IO_SURF_n(HPROGRAM)
125    IF (LHOOK) CALL DR_HOOK('WRITE_DIAG_PGD_GRDN_N',1,ZHOOK_HANDLE)
126    RETURN
127 ENDIF
128 !
129 !-------------------------------------------------------------------------------
130 !
131 !* Runoff soil ice depth for each patch
132 !
133 IF(CHORT=='SGH')THEN
134   YRECFM='GD_DICE'
135   YCOMMENT='soil ice depth for runoff (m)'
136   CALL WRITE_SURF(HPROGRAM,YRECFM,XD_ICE(:),IRESP,HCOMMENT=YCOMMENT)
137 ENDIF
138 !
139 !-------------------------------------------------------------------------------
140 !
141 !* Fraction of each vegetation type for each patch
142 !
143 DO JL=1,SIZE(XVEGTYPE,2)
144   WRITE(YPAS,'(I2)') JL 
145   YLVLV=ADJUSTL(YPAS(:LEN_TRIM(YPAS)))
146   WRITE(YRECFM,FMT='(A12)') 'GD_VEGTY_P'//YLVLV
147   YCOMMENT='fraction of each vegetation type '//' (-)'
148   CALL WRITE_SURF(HPROGRAM,YRECFM,XVEGTYPE(:,JL),IRESP,HCOMMENT=YCOMMENT)
149 END DO
150 !-------------------------------------------------------------------------------
151 !
152 !* other surface parameters
153 !
154 YRECFM='GD_RSMIN'
155 YCOMMENT='minimum stomatal resistance (SM-1)'
156  CALL WRITE_SURF(HPROGRAM,YRECFM,XRSMIN(:),IRESP,HCOMMENT=YCOMMENT)
157 !
158 YRECFM='GD_GAMMA'
159 YCOMMENT='coefficient for RSMIN calculation (-)'
160  CALL WRITE_SURF(HPROGRAM,YRECFM,XGAMMA(:),IRESP,HCOMMENT=YCOMMENT)
161 !
162 YRECFM='GD_CV'
163 YCOMMENT='vegetation thermal inertia coefficient (-)'
164  CALL WRITE_SURF(HPROGRAM,YRECFM,XCV(:),IRESP,HCOMMENT=YCOMMENT)
165 !
166 YRECFM='GD_RGL'
167 YCOMMENT='maximum solar radiation usable in photosynthesis (-)'
168  CALL WRITE_SURF(HPROGRAM,YRECFM,XRGL(:),IRESP,HCOMMENT=YCOMMENT)
169 !
170 YRECFM='GD_EMIS_ISBA'
171 YCOMMENT='surface emissivity (-)'
172  CALL WRITE_SURF(HPROGRAM,YRECFM,XEMIS(:),IRESP,HCOMMENT=YCOMMENT)
173 !
174 YRECFM='GD_WRMAX_CF'
175 YCOMMENT='coefficient for maximum water interception (-)'
176  CALL WRITE_SURF(HPROGRAM,YRECFM,XWRMAX_CF(:),IRESP,HCOMMENT=YCOMMENT)
177 !
178 !-------------------------------------------------------------------------------
179 !
180 IF (LSURF_DIAG_ALBEDO) THEN
181 !
182 !* Soil albedos
183 !
184 !
185    YRECFM='GD_ALBNIR_S'
186    YCOMMENT='soil near-infra-red albedo (-)'
187    CALL WRITE_SURF(HPROGRAM,YRECFM,XALBNIR_SOIL(:),IRESP,HCOMMENT=YCOMMENT)
188 !
189 !-------------------------------------------------------------------------------
190 !
191    YRECFM='GD_ALBVIS_S'
192    YCOMMENT='soil visible albedo (-)'
193    CALL WRITE_SURF(HPROGRAM,YRECFM,XALBVIS_SOIL(:),IRESP,HCOMMENT=YCOMMENT)
194 !
195 !-------------------------------------------------------------------------------
196 !
197    YRECFM='GD_ALBUV_S'
198    YCOMMENT='soil UV albedo (-)'
199    CALL WRITE_SURF(HPROGRAM,YRECFM,XALBUV_SOIL(:),IRESP,HCOMMENT=YCOMMENT)
200 !
201 !-------------------------------------------------------------------------------
202 !
203 !* albedos
204 !
205    YRECFM='GD_ALBNIR_T'
206    YCOMMENT='total near-infra-red albedo (-)'
207    CALL WRITE_SURF(HPROGRAM,YRECFM,XALBNIR(:),IRESP,HCOMMENT=YCOMMENT)
208 !
209 !-------------------------------------------------------------------------------
210 !
211    YRECFM='GD_ALBVIS_T'
212    YCOMMENT='total visible albedo (-)'
213    CALL WRITE_SURF(HPROGRAM,YRECFM,XALBVIS(:),IRESP,HCOMMENT=YCOMMENT)
214 !
215 !-------------------------------------------------------------------------------
216 !
217    YRECFM='GD_ALBUV_T'
218    YCOMMENT='total UV albedo (-)'
219    CALL WRITE_SURF(HPROGRAM,YRECFM,XALBUV(:),IRESP,HCOMMENT=YCOMMENT)
220 !
221 END IF
222 !
223 !-------------------------------------------------------------------------------
224 !
225 !         End of IO
226 !
227  CALL END_IO_SURF_n(HPROGRAM)
228 IF (LHOOK) CALL DR_HOOK('WRITE_DIAG_PGD_GRDN_N',1,ZHOOK_HANDLE)
229 !
230 !
231 END SUBROUTINE WRITE_DIAG_PGD_GRDN_n