Juan 8/12/2016: add management of LEN_HREC in MNH & SURFEX
[MNH-git_open_source-lfs.git] / src / SURFEX / writesurf_teb_canopyn.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_CANOPY_n(HPROGRAM,HWRITE)
7 !     ####################################
8 !
9 !!****  *WRITE_TEB_n* - writes TEB 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/2003 
35 !!      E. Martin   01/2012 avoid write of XUNDEF fields
36 !-------------------------------------------------------------------------------
37 !
38 !*       0.    DECLARATIONS
39 !              ------------
40 !
41 !
42 !
43 USE MODD_TEB_n,          ONLY : LCANOPY
44 USE MODD_TEB_CANOPY_n,   ONLY : NLVL, XZ, XU, XT, XQ, XTKE, XLMO, XLM, XLEPS, XP
45 USE MODD_SURF_PAR       ,ONLY : XUNDEF
46 !
47 USE MODI_WRITE_SURF
48 !
49 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
50 USE PARKIND1  ,ONLY : JPRB
51 !
52 IMPLICIT NONE
53 !
54 !*       0.1   Declarations of arguments
55 !              -------------------------
56 !
57  CHARACTER(LEN=6),  INTENT(IN)  :: HPROGRAM ! program calling
58  CHARACTER(LEN=3),  INTENT(IN)  :: HWRITE   ! 'PREP' : does not write SBL XUNDEF fields
59 !                                          ! 'ALL' : all fields are written
60 !*       0.2   Declarations of local variables
61 !              -------------------------------
62 !
63 INTEGER           :: IRESP          ! IRESP  : return-code if a problem appears
64  CHARACTER(LEN=LEN_HREC) :: YRECFM         ! Name of the article to be read
65  CHARACTER(LEN=100):: YCOMMENT       ! Comment string
66 !
67 INTEGER :: JLAYER  ! loop counter on layers
68 REAL(KIND=JPRB) :: ZHOOK_HANDLE
69 !
70 !-------------------------------------------------------------------------------
71 !
72 !*       1.     Prognostic fields:
73 !               -----------------
74 !
75 !* flag to define if canopy is computed
76 !
77 IF (LHOOK) CALL DR_HOOK('WRITESURF_TEB_CANOPY_N',0,ZHOOK_HANDLE)
78 YRECFM='TEB_CANOPY'
79 YCOMMENT='flag to use canopy levels'
80  CALL WRITE_SURF(HPROGRAM,YRECFM,LCANOPY,IRESP,HCOMMENT=YCOMMENT)
81 !
82 IF (.NOT. LCANOPY .AND. LHOOK) CALL DR_HOOK('WRITESURF_TEB_CANOPY_N',1,ZHOOK_HANDLE)
83 IF (.NOT. LCANOPY) RETURN
84 !
85 !* number of levels
86 !
87 YRECFM='TEB_CAN_LVL'
88 YCOMMENT='number of canopy levels'
89  CALL WRITE_SURF(HPROGRAM,YRECFM,NLVL,IRESP,HCOMMENT=YCOMMENT)
90 !
91 !* altitudes
92 !
93 DO JLAYER=1,NLVL
94   WRITE(YRECFM,'(A9,I2.2,A1)') 'TEB_CAN_Z',JLAYER,' '
95   YCOMMENT='altitudes of canopy levels (m)'
96   CALL WRITE_SURF(HPROGRAM,YRECFM,XZ(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
97 END DO
98 !
99 IF (HWRITE/='PRE') THEN
100   !
101   !* wind in canopy
102   !
103   DO JLAYER=1,NLVL
104     WRITE(YRECFM,'(A9,I2.2,A1)') 'TEB_CAN_U',JLAYER,' '
105     YCOMMENT='wind at canopy levels (m/s)'
106     CALL WRITE_SURF(HPROGRAM,YRECFM,XU(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
107   END DO
108   !
109   !* temperature in canopy
110   !
111   DO JLAYER=1,NLVL
112     WRITE(YRECFM,'(A9,I2.2,A1)') 'TEB_CAN_T',JLAYER,' '
113     YCOMMENT='temperature at canopy levels (K)'
114     CALL WRITE_SURF(HPROGRAM,YRECFM,XT(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
115   END DO
116   !
117   !* humidity in canopy
118   !
119   DO JLAYER=1,NLVL
120     WRITE(YRECFM,'(A9,I2.2,A1)') 'TEB_CAN_Q',JLAYER,' '
121     YCOMMENT='humidity at canopy levels (kg/m3)'
122     CALL WRITE_SURF(HPROGRAM,YRECFM,XQ(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
123   END DO
124   !
125   !* Tke in canopy
126   !
127   DO JLAYER=1,NLVL
128     WRITE(YRECFM,'(A9,I2.2,A1)') 'TEB_CAN_E',JLAYER,' '
129     YCOMMENT='Tke at canopy levels (m2/s2)'
130     CALL WRITE_SURF(HPROGRAM,YRECFM,XTKE(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
131   END DO
132   !
133   !* Monin-Obhukov length
134   !
135   DO JLAYER=1,NLVL
136     WRITE(YRECFM,'(A10,I2.2)') 'TEB_CAN_MO',JLAYER
137     YCOMMENT='Monin-Obukhov length (m)'
138     CALL WRITE_SURF(HPROGRAM,YRECFM,XLMO(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
139   END DO
140   !
141   !* mixing length
142   !
143   IF (ASSOCIATED(XLM)) THEN
144     DO JLAYER=1,NLVL
145       WRITE(YRECFM,'(A10,I2.2)') 'TEB_CAN_LM',JLAYER
146       YCOMMENT='mixing length (m)'
147       CALL WRITE_SURF(HPROGRAM,YRECFM,XLM(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
148    END DO
149   END IF
150   !
151   !* dissipative length
152   !
153   IF (ASSOCIATED(XLEPS)) THEN
154     DO JLAYER=1,NLVL
155       WRITE(YRECFM,'(A10,I2.2)') 'TEB_CAN_LE',JLAYER
156       YCOMMENT='mixing length (m)'
157       CALL WRITE_SURF(HPROGRAM,YRECFM,XLEPS(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
158     END DO
159   END IF
160   !
161   !* Air pressure in canopy
162   !
163   DO JLAYER=1,NLVL
164     WRITE(YRECFM,'(A9,I2.2,A1)') 'TEB_CAN_P',JLAYER,' '
165     YCOMMENT='Pressure at canopy levels (Pa)'
166     CALL WRITE_SURF(HPROGRAM,YRECFM,XP(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
167   END DO
168   !
169 ENDIF
170 !
171 IF (LHOOK) CALL DR_HOOK('WRITESURF_TEB_CANOPY_N',1,ZHOOK_HANDLE)
172 !-------------------------------------------------------------------------------
173 !
174 END SUBROUTINE WRITESURF_TEB_CANOPY_n