63c4ab898c9e90bd4931f75fe59ec809a1b0d05a
[MNH-git_open_source-lfs.git] / src / SURFEX / writesurf_flake_sbln.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_FLAKE_SBL_n(HPROGRAM,HWRITE)
7 !     ####################################
8 !
9 !!****  *WRITE_FLAKE_n* - writes FLAKE 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_FLAKE_n,       ONLY : LSBL
44 USE MODD_FLAKE_SBL_n,   ONLY : NLVL, XZ, XU, XT, XQ, XTKE, XLMO, XP
45 !
46 USE MODI_WRITE_SURF
47 !
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=12) :: 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 !*       1.     Prognostic fields:
72 !               -----------------
73 !
74 !* flag to define if SBL is computed
75 !
76 IF (LHOOK) CALL DR_HOOK('WRITESURF_FLAKE_SBL_N',0,ZHOOK_HANDLE)
77 YRECFM='WAT_SBL'
78 YCOMMENT='flag to use SBL levels'
79  CALL WRITE_SURF(HPROGRAM,YRECFM,LSBL,IRESP,HCOMMENT=YCOMMENT)
80 !
81 IF (.NOT. LSBL .AND. LHOOK) CALL DR_HOOK('WRITESURF_FLAKE_SBL_N',1,ZHOOK_HANDLE)
82 IF (.NOT. LSBL) RETURN
83 !
84 !* number of levels
85 !
86 YRECFM='WAT_SBL_LVL'
87 YCOMMENT='number of SBL levels'
88  CALL WRITE_SURF(HPROGRAM,YRECFM,NLVL,IRESP,HCOMMENT=YCOMMENT)
89 !
90 !* altitudes
91 !
92 DO JLAYER=1,NLVL
93   WRITE(YRECFM,'(A9,I2.2,A1)') 'WAT_SBL_Z',JLAYER,' '
94   YCOMMENT='altitudes of SBL levels (m)'
95   CALL WRITE_SURF(HPROGRAM,YRECFM,XZ(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
96 END DO
97 !
98 IF (HWRITE/='PRE') THEN
99   !
100   !* wind in SBL
101   !
102   DO JLAYER=1,NLVL
103     WRITE(YRECFM,'(A9,I2.2,A1)') 'WAT_SBL_U',JLAYER,' '
104     YCOMMENT='wind at SBL levels (m/s)'
105     CALL WRITE_SURF(HPROGRAM,YRECFM,XU(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
106   END DO
107   !
108   !* temperature in SBL
109   !
110   DO JLAYER=1,NLVL
111     WRITE(YRECFM,'(A9,I2.2,A1)') 'WAT_SBL_T',JLAYER,' '
112     YCOMMENT='temperature at SBL levels (K)'
113     CALL WRITE_SURF(HPROGRAM,YRECFM,XT(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
114   END DO
115   !
116   !* humidity in SBL
117   !
118   DO JLAYER=1,NLVL
119     WRITE(YRECFM,'(A9,I2.2,A1)') 'WAT_SBL_Q',JLAYER,' '
120     YCOMMENT='humidity at SBL levels (kg/m3)'
121     CALL WRITE_SURF(HPROGRAM,YRECFM,XQ(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
122   END DO
123   !
124   !* Tke in SBL
125   !
126   DO JLAYER=1,NLVL
127     WRITE(YRECFM,'(A9,I2.2,A1)') 'WAT_SBL_E',JLAYER,' '
128     YCOMMENT='Tke at SBL levels (m2/s2)'
129     CALL WRITE_SURF(HPROGRAM,YRECFM,XTKE(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
130   END DO
131   !
132   !* Monin-Obhukov length
133   !
134   YRECFM='WAT_SBL_LMO     '
135   CALL WRITE_SURF(HPROGRAM,YRECFM,XLMO(:),IRESP,HCOMMENT=YCOMMENT)
136   !
137   !* Air pressure in SBL
138   !
139   DO JLAYER=1,NLVL
140     WRITE(YRECFM,'(A9,I2.2,A1)') 'WAT_SBL_P',JLAYER,' '
141     YCOMMENT='Pressure at SBL levels (Pa)'
142     CALL WRITE_SURF(HPROGRAM,YRECFM,XP(:,JLAYER),IRESP,HCOMMENT=YCOMMENT)
143   END DO
144   !
145 ENDIF
146 !
147 IF (LHOOK) CALL DR_HOOK('WRITESURF_FLAKE_SBL_N',1,ZHOOK_HANDLE)
148 !
149 !
150 !-------------------------------------------------------------------------------
151 !
152 END SUBROUTINE WRITESURF_FLAKE_SBL_n