Juan 13/01/2014: add header SURFEX_LIC to all SURFEX files
[MNH-git_open_source-lfs.git] / src / SURFEX / write_diag_seb_flaken.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_SEB_FLAKE_n(HPROGRAM)
7 !     #################################
8 !
9 !!****  *WRITE_DIAG_SEB_FLAKE_n* - writes FLAKE diagnostics
10 !!
11 !!    PURPOSE
12 !!    -------
13 !!
14 !!
15 !!**  METHOD
16 !!    ------
17 !!          
18 !!    REFERENCE
19 !!    ---------
20 !!
21 !!
22 !!    AUTHOR
23 !!    ------
24 !!      V. Masson   *Meteo France*      
25 !!
26 !!    MODIFICATIONS
27 !!    -------------
28 !!      Original    01/2004
29 !!      Modified    01/2006 : sea flux parameterization.
30 !-------------------------------------------------------------------------------
31 !
32 !*       0.    DECLARATIONS
33 !              ------------
34 !
35 USE MODD_DIAG_FLAKE_n,  ONLY : N2M, LSURF_BUDGET, LRAD_BUDGET,  LCOEF,   &
36                                  LSURF_VARS, XRN, XH, XLE, XLEI, XGFLUX,   &
37                                  XRI, XCD, XCH, XCE, XZ0, XZ0H,            &
38                                  XT2M, XQ2M, XHU2M,                        &
39                                  XZON10M, XMER10M, XQS,                    &
40                                  XSWD, XSWU, XLWD, XLWU, XSWBD, XSWBU,     &
41                                  XFMU, XFMV  
42
43 USE MODD_CH_WATFLUX_n,  ONLY : XDEP, CCH_DRY_DEP, CCH_NAMES, NBEQ
44 !
45 USE MODI_INIT_IO_SURF_n
46 USE MODI_WRITE_SURF
47 USE MODI_END_IO_SURF_n
48 !
49 !
50 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
51 USE PARKIND1  ,ONLY : JPRB
52 !
53 IMPLICIT NONE
54 !
55 !*       0.1   Declarations of arguments
56 !              -------------------------
57 !
58  CHARACTER(LEN=6),  INTENT(IN)  :: HPROGRAM ! program calling
59 !
60 !*       0.2   Declarations of local variables
61 !              -------------------------------
62 !
63 INTEGER           :: IRESP          ! IRESP  : return-code if a problem appears
64  CHARACTER(LEN=12) :: YRECFM         ! Name of the article to be read
65  CHARACTER(LEN=100):: YCOMMENT       ! Comment string
66  CHARACTER(LEN=2)  :: YNUM
67 !
68 INTEGER           :: JSV, JSW
69 REAL(KIND=JPRB) :: ZHOOK_HANDLE
70 !-------------------------------------------------------------------------------
71 !
72 !         Initialisation for IO
73 !
74 IF (LHOOK) CALL DR_HOOK('WRITE_DIAG_SEB_FLAKE_N',0,ZHOOK_HANDLE)
75  CALL INIT_IO_SURF_n(HPROGRAM,'WATER ','FLAKE ','WRITE')
76 !
77 !
78 !*       2.     Richardson number :
79 !               -----------------
80 !
81 IF (N2M>=1) THEN
82
83 YRECFM='RI_WAT'
84 YCOMMENT='Bulk-Richardson number for water'
85 !
86  CALL WRITE_SURF(HPROGRAM,YRECFM,XRI(:),IRESP,HCOMMENT=YCOMMENT)
87 !
88 END IF
89 !
90 !*       3.     Energy fluxes :
91 !               -------------
92 !
93 IF (LSURF_BUDGET) THEN
94
95 YRECFM='RN_WAT'
96 YCOMMENT='net radiation for water'//' (W/m2)'
97 !
98  CALL WRITE_SURF(HPROGRAM,YRECFM,XRN(:),IRESP,HCOMMENT=YCOMMENT)
99 !
100 YRECFM='H_WAT'
101 YCOMMENT='sensible heat flux for water'//' (W/m2)'
102 !
103  CALL WRITE_SURF(HPROGRAM,YRECFM,XH(:),IRESP,HCOMMENT=YCOMMENT)
104 !
105 YRECFM='LE_WAT'
106 YCOMMENT='total latent heat flux for water'//' (W/m2)'
107 !
108  CALL WRITE_SURF(HPROGRAM,YRECFM,XLE(:),IRESP,HCOMMENT=YCOMMENT)
109 !
110 YRECFM='LEI_WAT'
111 YCOMMENT='sublimation latent heat flux for water-ice'//' (W/m2)'
112 !
113  CALL WRITE_SURF(HPROGRAM,YRECFM,XLEI(:),IRESP,HCOMMENT=YCOMMENT)
114 !
115 YRECFM='GFLUX_WAT'
116 YCOMMENT='conduction flux for water'//' (W/m2)'
117 !
118  CALL WRITE_SURF(HPROGRAM,YRECFM,XGFLUX(:),IRESP,HCOMMENT=YCOMMENT)
119 !
120 IF (LRAD_BUDGET) THEN
121 !
122    YRECFM='SWD_WAT'
123    YCOMMENT='short wave downward radiation for water'//' (W/m2)'
124    !
125    CALL WRITE_SURF(HPROGRAM,YRECFM,XSWD(:),IRESP,HCOMMENT=YCOMMENT)
126    !
127    YRECFM='SWU_WAT'
128    YCOMMENT='short wave upward radiation for water'//' (W/m2)'
129    !
130    CALL WRITE_SURF(HPROGRAM,YRECFM,XSWU(:),IRESP,HCOMMENT=YCOMMENT)
131    !
132    YRECFM='LWD_WAT'
133    YCOMMENT='downward long wave radiation'//' (W/m2)'
134    !
135    CALL WRITE_SURF(HPROGRAM,YRECFM,XLWD(:),IRESP,HCOMMENT=YCOMMENT)
136    !
137    YRECFM='LWU_WAT'
138    YCOMMENT='upward long wave radiation'//' (W/m2)'
139    !
140    CALL WRITE_SURF(HPROGRAM,YRECFM,XLWU(:),IRESP,HCOMMENT=YCOMMENT)
141    !       
142    DO JSW=1, SIZE(XSWBD,2)
143       YNUM=ACHAR(48+JSW)
144       !
145       YRECFM='SWD_WAT_'//YNUM
146       YCOMMENT='downward short wave radiation by spectral band '//' (W/m2)'
147       !
148       CALL WRITE_SURF(HPROGRAM,YRECFM,XSWBD(:,JSW),IRESP,HCOMMENT=YCOMMENT)
149       !
150       YRECFM='SWU_WAT_'//YNUM
151       YCOMMENT='upward short wave radiation by spectral band'//' (W/m2)'
152       !
153       CALL WRITE_SURF(HPROGRAM,YRECFM,XSWBU(:,JSW),IRESP,HCOMMENT=YCOMMENT)
154       !
155    ENDDO
156 !
157 ENDIF
158 !
159 YRECFM='FMU_WAT'
160 YCOMMENT='u-component of momentum flux for water'//' (kg/ms2)'
161 !
162  CALL WRITE_SURF(HPROGRAM,YRECFM,XFMU(:),IRESP,HCOMMENT=YCOMMENT)
163 YRECFM='FMV_WAT'
164 YCOMMENT='v-component of momentum flux for water'//' (kg/ms2)'
165 !
166  CALL WRITE_SURF(HPROGRAM,YRECFM,XFMV(:),IRESP,HCOMMENT=YCOMMENT)
167 !
168 END IF
169 !
170 !
171 !*       4.     Transfer coefficients
172 !               ---------------------
173 !
174 IF (LCOEF) THEN
175
176 YRECFM='CD_WAT'
177 YCOMMENT='drag coefficient for wind over water (W/s2)'
178 !
179  CALL WRITE_SURF(HPROGRAM,YRECFM,XCD(:),IRESP,HCOMMENT=YCOMMENT)
180 !
181 YRECFM='CH_WAT'
182 YCOMMENT='drag coefficient for heat (W/s)'
183 !
184  CALL WRITE_SURF(HPROGRAM,YRECFM,XCH(:),IRESP,HCOMMENT=YCOMMENT)
185 !
186 YRECFM='CE_WAT'
187 YCOMMENT='drag coefficient for vapor (W/s/K)'
188 !
189  CALL WRITE_SURF(HPROGRAM,YRECFM,XCE(:),IRESP,HCOMMENT=YCOMMENT)
190 !
191 YRECFM='Z0_WAT'
192 YCOMMENT='roughness length over water (m)'
193
194  CALL WRITE_SURF(HPROGRAM,YRECFM,XZ0(:),IRESP,HCOMMENT=YCOMMENT)
195 !
196 YRECFM='Z0H_WAT'
197 YCOMMENT='thermal roughness length over water (m)'
198 !
199  CALL WRITE_SURF(HPROGRAM,YRECFM,XZ0H(:),IRESP,HCOMMENT=YCOMMENT)
200 !
201 END IF
202 !
203 !
204 !*       5.     Surface humidity
205 !               ----------------
206 !
207 IF (LSURF_VARS) THEN
208
209 YRECFM='QS_WAT'
210 YCOMMENT='specific humidity over water'//' (KG/KG)'
211 !
212  CALL WRITE_SURF(HPROGRAM,YRECFM,XQS(:),IRESP,HCOMMENT=YCOMMENT)
213 !
214 ENDIF
215 !
216
217 !
218 !*       6.     parameters at 2 and 10 meters :
219 !               -----------------------------
220 !
221 IF (N2M>=1) THEN
222
223 YRECFM='T2M_WAT'
224 YCOMMENT='2 meters temperature'//' (K)'
225 !
226  CALL WRITE_SURF(HPROGRAM,YRECFM,XT2M(:),IRESP,HCOMMENT=YCOMMENT)
227 !
228 YRECFM='Q2M_WAT'
229 YCOMMENT='2 meters specific humidity'//' (KG/KG)'
230 !
231  CALL WRITE_SURF(HPROGRAM,YRECFM,XQ2M(:),IRESP,HCOMMENT=YCOMMENT)
232 !
233 YRECFM='HU2M_WAT'
234 YCOMMENT='2 meters relative humidity'//' (KG/KG)'
235 !
236  CALL WRITE_SURF(HPROGRAM,YRECFM,XHU2M(:),IRESP,HCOMMENT=YCOMMENT)
237 !
238 YRECFM='ZON10M_WAT'
239 YCOMMENT='10 meters zonal wind'//' (M/S)'
240 !
241  CALL WRITE_SURF(HPROGRAM,YRECFM,XZON10M(:),IRESP,HCOMMENT=YCOMMENT)
242 !
243 YRECFM='MER10M_WAT'
244 YCOMMENT='10 meters meridian wind'//' (M/S)'
245 !
246  CALL WRITE_SURF(HPROGRAM,YRECFM,XMER10M(:),IRESP,HCOMMENT=YCOMMENT)
247 !
248 END IF
249 !
250 !
251 !*       7.     chemical diagnostics:
252 !               --------------------
253 !
254 IF (NBEQ>0 .AND. CCH_DRY_DEP=="WES89 ") THEN
255   DO JSV = 1,SIZE(CCH_NAMES,1)
256     YRECFM='DV_WAT_'//TRIM(CCH_NAMES(JSV))
257     WRITE(YCOMMENT,'(A26)')'final dry deposition (m/s)'
258     CALL WRITE_SURF(HPROGRAM,YRECFM,XDEP(:,JSV),IRESP,HCOMMENT=YCOMMENT)
259   END DO
260 ENDIF
261 !
262 !-------------------------------------------------------------------------------
263 !
264 !         End of IO
265 !
266  CALL END_IO_SURF_n(HPROGRAM)
267 IF (LHOOK) CALL DR_HOOK('WRITE_DIAG_SEB_FLAKE_N',1,ZHOOK_HANDLE)
268 !
269 !
270 END SUBROUTINE WRITE_DIAG_SEB_FLAKE_n