Juan 8/12/2016: add management of LEN_HREC in MNH & SURFEX
[MNH-git_open_source-lfs.git] / src / SURFEX / writesurf_teb_gardenn.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_TEB_GARDEN_n(HPROGRAM,HPATCH)
7 !     #####################################
8 !
9 !!****  *WRITESURF_TEB_GARDEN_n* - writes ISBA prognostic fields
10 !!                        
11 !!
12 !!    PURPOSE
13 !!    -------
14 !!
15 !!**  METHOD
16 !!    ------
17 !!
18 !!    EXTERNAL
19 !!    --------
20 !!
21 !!
22 !!    IMPLICIT ARGUMENTS
23 !!    ------------------
24 !!
25 !!    REFERENCE
26 !!    ---------
27 !!
28 !!
29 !!    AUTHOR
30 !!    ------
31 !!      V. Masson   *Meteo France*      
32 !!
33 !!    MODIFICATIONS
34 !!    -------------
35 !!      Original    01/2003 
36 !!      P. LeMoigne 12/2004 : correct dimensionning if more than 10 layers in
37 !!                            the soil (diffusion version)
38 !!      B. Decharme  2008    : Floodplains
39 !!      B. Decharme  01/2009 : Optional Arpege deep soil temperature write
40 !!      B. Decharme  09/2012 : suppress NWG_LAYER (parallelization problems)
41 !-------------------------------------------------------------------------------
42 !
43 !*       0.    DECLARATIONS
44 !              ------------
45 USE MODD_TEB_VEG_n,    ONLY : CPHOTO, CRESPSL, NNBIOMASS
46
47 USE MODD_TEB_GARDEN_n, ONLY : NGROUND_LAYER,                               &
48                               XTG, XWG, XWGI, XWR, XLAI, TSNOW,            &
49                               XRESA, XAN, XANFM, XLE, XANDAY,              &
50                               XRESP_BIOMASS, XBIOMASS
51 !
52 USE MODD_SURF_PAR, ONLY : NUNDEF
53 !
54 USE MODI_WRITE_SURF
55 USE MODI_WRITESURF_GR_SNOW
56 USE MODD_DST_n
57 USE MODD_DST_SURF
58 !
59 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
60 USE PARKIND1  ,ONLY : JPRB
61 !
62 IMPLICIT NONE
63 !
64 !*       0.1   Declarations of arguments
65 !              -------------------------
66 !
67  CHARACTER(LEN=6),  INTENT(IN)  :: HPROGRAM ! program calling
68  CHARACTER(LEN=3),  INTENT(IN)  :: HPATCH   ! current teb patch
69 !
70 !*       0.2   Declarations of local variables
71 !              -------------------------------
72 !
73 INTEGER           :: IRESP          ! IRESP  : return-code if a problem appears
74  CHARACTER(LEN=LEN_HREC) :: YRECFM         ! Name of the article to be read
75  CHARACTER(LEN=100):: YCOMMENT       ! Comment string
76  CHARACTER(LEN=14) :: YFORM          ! Writing format
77  CHARACTER(LEN=4 ) :: YLVL
78 !
79 INTEGER :: JLAYER ! loop counter on soil layers
80 !
81 REAL, DIMENSION(:),ALLOCATABLE  :: ZWORK      ! 2D array to write data in file
82 !
83 INTEGER :: JNBIOMASS
84 REAL(KIND=JPRB) :: ZHOOK_HANDLE
85 !
86 !------------------------------------------------------------------------------
87 !
88 !*       2.     Prognostic fields:
89 !               -----------------
90 !
91 IF (LHOOK) CALL DR_HOOK('WRITESURF_TEB_GARDEN_N',0,ZHOOK_HANDLE)
92 ALLOCATE(ZWORK(SIZE(XTG,1)))
93 !* soil temperatures
94 !
95 DO JLAYER=1,NGROUND_LAYER
96   WRITE(YLVL,'(I2)') JLAYER
97   YRECFM=HPATCH//'GD_TG'//ADJUSTL(YLVL(:LEN_TRIM(YLVL)))
98   YRECFM=ADJUSTL(YRECFM)
99   YFORM='(A11,I1.1,A4)'
100   IF (JLAYER >= 10)  YFORM='(A11,I2.2,A4)'
101   WRITE(YCOMMENT,FMT=YFORM) 'X_Y_GD_TG',JLAYER,' (K)'
102   ZWORK=XTG(:,JLAYER)
103   CALL WRITE_SURF(HPROGRAM,YRECFM,ZWORK,IRESP,HCOMMENT=YCOMMENT)
104 END DO
105 !
106 !
107 !* soil liquid water content
108 !
109 DO JLAYER=1,NGROUND_LAYER
110   WRITE(YLVL,'(I2)') JLAYER
111   YRECFM=HPATCH//'GD_WG'//ADJUSTL(YLVL(:LEN_TRIM(YLVL)))
112   YRECFM=ADJUSTL(YRECFM)
113   YFORM='(A11,I1.1,A8)'
114   IF (JLAYER >= 10)  YFORM='(A11,I2.2,A8)'
115   WRITE(YCOMMENT,FMT=YFORM) 'X_Y_GD_WG',JLAYER,' (m3/m3)'
116   ZWORK=XWG(:,JLAYER)
117   CALL WRITE_SURF(HPROGRAM,YRECFM,ZWORK,IRESP,HCOMMENT=YCOMMENT)
118 END DO
119 !
120 !
121 !* soil ice water content
122 !
123 DO JLAYER=1,NGROUND_LAYER
124   WRITE(YLVL,'(I2)') JLAYER
125   YRECFM=HPATCH//'GD_WGI'//ADJUSTL(YLVL(:LEN_TRIM(YLVL)))
126   YRECFM=ADJUSTL(YRECFM)
127   YFORM='(A11,I1.1,A8)'
128   IF (JLAYER >= 10)  YFORM='(A11,I2.2,A8)'
129   WRITE(YCOMMENT,YFORM) 'X_Y_GD_WGI',JLAYER,' (m3/m3)'
130   ZWORK=XWGI(:,JLAYER)
131   CALL WRITE_SURF(HPROGRAM,YRECFM,ZWORK,IRESP,HCOMMENT=YCOMMENT)
132 END DO
133 !
134 DEALLOCATE(ZWORK)
135 !
136 !* water intercepted on leaves
137 !
138 YRECFM=HPATCH//'GD_WR'
139 YRECFM=ADJUSTL(YRECFM)
140 YCOMMENT='X_Y_GD_WR (kg/m2)'
141  CALL WRITE_SURF(HPROGRAM,YRECFM,XWR(:),IRESP,HCOMMENT=YCOMMENT)
142 !
143 !* Leaf Area Index
144 !
145 IF (CPHOTO/='NON' .AND. CPHOTO/='AGS' .AND. CPHOTO/='AST') THEN
146   YRECFM=HPATCH//'GD_LAI'
147   YRECFM=ADJUSTL(YRECFM)
148   YCOMMENT='X_Y_GD_LAI (m2/m2)'
149  CALL WRITE_SURF(HPROGRAM,YRECFM,XLAI(:),IRESP,HCOMMENT=YCOMMENT)
150 END IF
151 !
152 IF (CPHOTO=='NIT') THEN
153   !
154   DO JNBIOMASS=1,NNBIOMASS
155     WRITE(YLVL,'(I1)') JNBIOMASS
156     YRECFM=HPATCH//'GD_BIOMA'//ADJUSTL(YLVL(:LEN_TRIM(YLVL)))
157     YFORM='(A11,I1.1,A8)'
158     WRITE(YCOMMENT,FMT=YFORM) 'X_Y_BIOMASS',JNBIOMASS,' (kg/m2)'
159     CALL WRITE_SURF(HPROGRAM,YRECFM,XBIOMASS(:,JNBIOMASS),IRESP,HCOMMENT=YCOMMENT)
160   END DO
161   !
162   !
163   DO JNBIOMASS=2,NNBIOMASS
164     WRITE(YLVL,'(I1)') JNBIOMASS
165     YRECFM=HPATCH//'GD_RESPI'//ADJUSTL(YLVL(:LEN_TRIM(YLVL)))
166     YFORM='(A16,I1.1,A10)'
167     WRITE(YCOMMENT,FMT=YFORM) 'X_Y_RESP_BIOMASS',JNBIOMASS,' (kg/m2/s)'
168     CALL WRITE_SURF(HPROGRAM,YRECFM,XRESP_BIOMASS(:,JNBIOMASS),IRESP,HCOMMENT=YCOMMENT)
169   END DO
170   !
171 END IF
172 !
173 !* aerodynamical resistance
174 !
175 YRECFM=HPATCH//'GD_RES'
176 YRECFM=ADJUSTL(YRECFM)
177 YCOMMENT='X_Y_GD_RESA (s/m)'
178  CALL WRITE_SURF(HPROGRAM,YRECFM,XRESA(:),IRESP,HCOMMENT=YCOMMENT)
179 !
180 !* snow mantel
181 !
182 YRECFM='GD'
183  CALL WRITESURF_GR_SNOW(HPROGRAM,YRECFM,HPATCH,TSNOW)
184 IF (LHOOK) CALL DR_HOOK('WRITESURF_TEB_GARDEN_N',1,ZHOOK_HANDLE)
185 !
186 !-------------------------------------------------------------------------------
187 !
188 END SUBROUTINE WRITESURF_TEB_GARDEN_n