5fe159af64f32dcdb16fa859d2b9732a074661ba
[MNH-git_open_source-lfs.git] / src / SURFEX / writesurf_gr_snow.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 WRITESURF_GR_SNOW(HPROGRAM,HSURFTYPE,HPREFIX,TPSNOW  )
7 !     ##########################################################
8 !
9 !!****  *WRITESURF_GR_SNOW* - routine to write snow surface fields
10 !!
11 !!    PURPOSE
12 !!    -------
13 !       Writes snow surface fields
14 !
15 !!**  METHOD
16 !!    ------
17 !!    
18 !!    
19 !!
20 !!    EXTERNAL
21 !!    --------
22 !!
23 !!       
24 !!    IMPLICIT ARGUMENTS
25 !!    ------------------ 
26 !!
27 !!    REFERENCE
28 !!    ---------
29 !!
30 !!      
31 !!
32 !!    AUTHOR
33 !!    ------
34 !!      V. Masson       * Meteo France *
35 !!
36 !!    MODIFICATIONS
37 !!    -------------
38 !!      Original      02/2003
39 !!     A. Bogatchev 09/2005 EBA snow option
40 !!     M.Moge    01/2016  using WRITE_SURF_FIELD2D/3D for 2D/3D surfex fields writes
41 !-----------------------------------------------------------------------------
42 !
43 !*       0.    DECLARATIONS
44 !
45 USE MODD_SURF_PAR,   ONLY : XUNDEF
46 USE MODD_TYPE_SNOW
47 USE MODD_PREP_SNOW, ONLY : LSNOW_FRAC_TOT
48 !
49 USE MODI_DETECT_FIELD
50 USE MODI_WRITE_SURF
51 USE MODI_WRITE_SURF_FIELD2D
52 USE MODI_WRITE_SURF_FIELD3D
53 !
54 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
55 USE PARKIND1  ,ONLY : JPRB
56 !
57 IMPLICIT NONE
58 !
59 !*       0.1   declarations of arguments
60 !
61  CHARACTER (LEN=6),  INTENT(IN) :: HPROGRAM   ! program
62  CHARACTER (LEN=*),  INTENT(IN) :: HSURFTYPE  ! generic name used for
63                                              ! snow characteristics
64                                              ! storage in file
65  CHARACTER (LEN=3),  INTENT(IN) :: HPREFIX    ! generic name of prefix for
66                                              ! patch identification
67 TYPE(SURF_SNOW),    INTENT(IN) :: TPSNOW     ! snow characteristics
68 !
69 !*       0.2   declarations of local variables
70 !
71 INTEGER             :: ISURFTYPE_LEN
72 !
73  CHARACTER (LEN=100) :: YFMT           ! format for writing
74  CHARACTER(LEN=12)   :: YRECFM         ! Name of the article to be read
75  CHARACTER(LEN=100):: YCOMMENT         ! Comment string
76  CHARACTER(LEN=100):: YCOMMENTUNIT     ! Comment string : unit of the datas in the field to write
77 INTEGER             :: IRESP          ! IRESP  : return-code if a problem appears
78 !
79 LOGICAL             :: GSNOW          ! T --> snow exists somewhere
80 !
81 INTEGER             :: JLAYER         ! loop counter
82 CHARACTER(LEN=4)    :: YPATCH              ! number of the patch
83  CHARACTER(LEN=4)    :: YNLAYER        ! String depending on the number of layer : less
84                                       !than 10 or more                              
85 !
86 REAL(KIND=JPRB) :: ZHOOK_HANDLE
87 !-------------------------------------------------------------------------------
88 IF (LHOOK) CALL DR_HOOK('WRITESURF_GR_SNOW',0,ZHOOK_HANDLE)
89 !
90 !*       1.    Initialisation
91 !              --------------
92
93 ISURFTYPE_LEN = LEN_TRIM(HSURFTYPE)
94 !
95 !
96 !*       2.    Type of snow scheme
97 !              -------------------
98 !
99 WRITE(YFMT,'(A5,I1,A4)') '(A3,A',ISURFTYPE_LEN,',A4)'
100 WRITE(YRECFM,YFMT) 'SN_',HSURFTYPE,'_TYP'
101 YRECFM=ADJUSTL(HPREFIX//YRECFM)
102 YCOMMENT=' '
103  CALL WRITE_SURF(HPROGRAM,YRECFM,TPSNOW%SCHEME,IRESP,HCOMMENT=YCOMMENT)
104 !
105 !
106 !*       3.    Number of layers
107 !              ----------------
108 !
109 WRITE(YFMT,'(A5,I1,A4)') '(A3,A',ISURFTYPE_LEN,',A2)'
110 WRITE(YRECFM,YFMT) 'SN_',HSURFTYPE,'_N'
111 YRECFM=ADJUSTL(HPREFIX//YRECFM)
112 YCOMMENT    = '(INTEGER)'
113  CALL WRITE_SURF(HPROGRAM,YRECFM,TPSNOW%NLAYER,IRESP,HCOMMENT=YCOMMENT)
114 !
115 !
116 !*       4.    Tests to find if there is snow
117 !              ------------------------------
118 !
119 IF (TPSNOW%NLAYER>0) THEN
120   CALL DETECT_FIELD(HPROGRAM,TPSNOW%WSNOW(:,1,:),GSNOW)
121 ELSE
122   GSNOW = .FALSE.
123 END IF
124 !
125 WRITE(YFMT,'(A5,I1,A1)') '(A3,A',ISURFTYPE_LEN,')'
126 WRITE(YRECFM,YFMT) 'SN_',HSURFTYPE
127 YRECFM=ADJUSTL(HPREFIX//YRECFM)
128 YCOMMENT    = '(LOGICAL)'
129  CALL WRITE_SURF(HPROGRAM,YRECFM,GSNOW,IRESP,HCOMMENT=YCOMMENT)
130 !
131 !
132 IF (.NOT. GSNOW) THEN
133   IF (LHOOK) CALL DR_HOOK('WRITESURF_GR_SNOW',1,ZHOOK_HANDLE)
134   RETURN
135 END IF
136 !
137 !
138 !*       5.    Additional key
139 !              ---------------
140 !
141 YCOMMENT    = '(LOGICAL)'
142  CALL WRITE_SURF(HPROGRAM,'LSNOW_FRAC_T',LSNOW_FRAC_TOT,IRESP,HCOMMENT=YCOMMENT)
143 !
144 !
145 IF (TPSNOW%SCHEME=='1-L' .OR. TPSNOW%SCHEME=='D95' .OR. TPSNOW%SCHEME=='EBA' .OR. &
146     TPSNOW%SCHEME=='3-L' .OR. TPSNOW%SCHEME=='CRO') THEN
147   !
148   !
149   !*       6.    Snow reservoir
150   !              --------------
151   !
152   YRECFM=ADJUSTL(HPREFIX//'WSN_'//HSURFTYPE)
153   YCOMMENT='X_Y_WSNOW_'//HSURFTYPE
154   YCOMMENTUNIT='kg/m2'
155   CALL WRITE_SURF_FIELD3D(HPROGRAM,TPSNOW%WSNOW,1,TPSNOW%NLAYER,YRECFM,YCOMMENT,YCOMMENTUNIT)
156   !
157   !*       7.    Snow density
158   !              ------------
159   !
160   YRECFM=ADJUSTL(HPREFIX//'RSN_'//HSURFTYPE)
161   YCOMMENT='X_Y_RSNOW_'//HSURFTYPE
162   YCOMMENTUNIT='kg/m2'
163   CALL WRITE_SURF_FIELD3D(HPROGRAM,TPSNOW%RHO,1,TPSNOW%NLAYER,YRECFM,YCOMMENT,YCOMMENTUNIT)
164   !
165 END IF
166 !
167 !*       8.    Snow temperature
168 !              ----------------
169 !
170 IF (TPSNOW%SCHEME=='1-L') THEN
171   !
172   YRECFM=ADJUSTL(HPREFIX//'TSN_'//HSURFTYPE)
173   YCOMMENT='X_Y_TSNOW_'//HSURFTYPE
174   YCOMMENTUNIT='kg/m2'
175   CALL WRITE_SURF_FIELD3D(HPROGRAM,TPSNOW%T,1,TPSNOW%NLAYER,YRECFM,YCOMMENT,YCOMMENTUNIT)
176   !
177 END IF
178 !
179 !*       9.    Heat content
180 !              ------------
181 !
182 IF (TPSNOW%SCHEME=='3-L' .OR. TPSNOW%SCHEME=='CRO') THEN
183   !
184   YRECFM=ADJUSTL(HPREFIX//'HSN_'//HSURFTYPE)
185   YCOMMENT='X_Y_HSNOW_'//HSURFTYPE
186   YCOMMENTUNIT='kg/m2'
187   CALL WRITE_SURF_FIELD3D(HPROGRAM,TPSNOW%HEAT,1,TPSNOW%NLAYER,YRECFM,YCOMMENT,YCOMMENTUNIT)
188   !
189 END IF
190 !
191 IF (TPSNOW%SCHEME=='CRO') THEN
192   !
193   !
194   !*       10.    Snow Gran1
195   !              ----------
196   !
197   YRECFM=ADJUSTL(HPREFIX//'SG1_'//HSURFTYPE)
198   YCOMMENT='X_Y_SGRAN1_'//HSURFTYPE
199   YCOMMENTUNIT='-'
200   CALL WRITE_SURF_FIELD3D(HPROGRAM,TPSNOW%GRAN1,1,TPSNOW%NLAYER,YRECFM,YCOMMENT,YCOMMENTUNIT)
201   !
202   !*       11.    Snow Gran2
203   !              ------------
204   !
205   YRECFM=ADJUSTL(HPREFIX//'SG2_'//HSURFTYPE)
206   YCOMMENT='X_Y_SGRAN2_'//HSURFTYPE
207   YCOMMENTUNIT='-'
208   CALL WRITE_SURF_FIELD3D(HPROGRAM,TPSNOW%GRAN2,1,TPSNOW%NLAYER,YRECFM,YCOMMENT,YCOMMENTUNIT)
209   !
210   !*       12.   Historical parameter
211   !              -------------------
212   !
213   YRECFM=ADJUSTL(HPREFIX//'SHI_'//HSURFTYPE)
214   YCOMMENT='X_Y_SHIST_'//HSURFTYPE
215   YCOMMENTUNIT='-'
216   CALL WRITE_SURF_FIELD3D(HPROGRAM,TPSNOW%HIST,1,TPSNOW%NLAYER,YRECFM,YCOMMENT,YCOMMENTUNIT)
217   !
218   !*       13.    Age parameter
219   !              ---------------
220   !
221   YRECFM=ADJUSTL(HPREFIX//'SAG_'//HSURFTYPE)
222   YCOMMENT='X_Y_SAGE_'//HSURFTYPE
223   YCOMMENTUNIT='-'
224   CALL WRITE_SURF_FIELD3D(HPROGRAM,TPSNOW%AGE,1,TPSNOW%NLAYER,YRECFM,YCOMMENT,YCOMMENTUNIT)
225   !
226 END IF
227 !
228 !
229 !*       14.    Albedo
230 !              ------
231 !
232 IF (TPSNOW%SCHEME=='D95' .OR. TPSNOW%SCHEME=='EBA' .OR. TPSNOW%SCHEME=='1-L' .OR. &
233     TPSNOW%SCHEME=='3-L' .OR. TPSNOW%SCHEME=='CRO') THEN
234   !
235   YRECFM=ADJUSTL(HPREFIX//'ASN_'//HSURFTYPE)
236   YCOMMENT='X_Y_ASNOW_'//HSURFTYPE
237   YCOMMENTUNIT='no unit'
238   CALL WRITE_SURF_FIELD2D(HPROGRAM,TPSNOW%ALB,YRECFM,YCOMMENT,YCOMMENTUNIT)
239   !
240 END IF
241 !
242 IF (LHOOK) CALL DR_HOOK('WRITESURF_GR_SNOW',1,ZHOOK_HANDLE)
243 !
244 END SUBROUTINE WRITESURF_GR_SNOW