source: LMDZ5/branches/LMDZ5_SPLA/libf/phylmd/rrtm/sutoph.F90

Last change on this file was 1990, checked in by Laurent Fairhead, 11 years ago

Corrections à la version r1989 pour permettre la compilation avec RRTM
Inclusion de la licence CeCILL_V2 pour RRTM

Changes to revision r1989 to enable RRTM code compilation
RRTM part put under CeCILL_V2 licence
  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
File size: 8.2 KB
Line 
1!OPTIONS XOPT(NOEVAL)
2SUBROUTINE SUTOPH(KULOUT)
3
4!**** *SUTOPH*   - Initialize common YOMTOPH top parameterization
5
6!     Purpose.
7!     --------
8!           Initialize YOMTOPH, the common that contains the top pressure
9!           and the first level of parameterization
10!           it also contains mesospheric drag vertical profil
11
12!**   Interface.
13!     ----------
14!        *CALL* *SUTOPH(KULOUT)
15
16!        Explicit arguments :
17!        --------------------
18!        KULOUT : Logical unit for the output
19
20!        Implicit arguments :
21!        --------------------
22!        COMMON YOMTOPH, YOMSTA
23
24!     Method.
25!     -------
26!        See documentation
27
28!     Externals.
29!     ----------
30
31!     Reference.
32!     ----------
33!        Documentation ARPEGE
34
35!     Author.
36!     -------
37!        A. Lasserre-Bigorry
38
39!     Modifications.
40!     --------------
41!        Original : 91-06-10
42!        Modified 92-02-22 by M. Deque (test of consistency between phys. para.)
43!        Modified by R. EL Khatib : 93-04-02 Set-up defaults controled by LECMWF
44!        Modified 93-11-17 by Ph. Dandin : FMR scheme with MF physics
45!        Modified 97-05-17 by M. Deque   : frozen FMR                 
46!        M.Hamrud      01-Oct-2003 CY28 Cleaning
47!        F.Bouyssel 04-11-22 : NTCOET,ETCOET
48!        P. Marquet 05-09-12 : NTAJUC
49!        M. Deque   05-09-12 : default RCLX
50!        M. Deque   05-09-12 : default TPSCLIM
51!     ------------------------------------------------------------------
52
53USE PARKIND1  ,ONLY : JPIM     ,JPRB
54USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
55
56USE YOMDIM   , ONLY : NFLEVG
57! Ce qui concerne NULNAM commente par MPL le 15.04.09
58!USE YOMLUN   , ONLY : NULNAM
59USE YOMCT0B  , ONLY : LECMWF
60USE YOMSTA   , ONLY : STPRE
61USE YOMTOPH  , ONLY : RMESOU   ,RMESOT   ,NTQSAT   ,NTDIFU   ,&
62 & NTCOEF   ,NTDRAG   ,NTCVIM   ,NTPLUI   ,NTRADI   ,&
63 & NTNEBU   ,NTOZON   ,NTDRME   ,ETQSAT   ,ETDIFU   ,&
64 & ETCOEF   ,ETDRAG   ,ETCVIM   ,ETPLUI   ,ETRADI   ,&
65 & ETNEBU   ,ETOZON   ,ETDRME   ,XDRMUK   ,XDRMUX   ,XDRMUP   ,&
66 & XDRMTK   ,XDRMTX   ,XDRMTP   ,NTCOET   ,ETCOET   ,&
67 & RMESOQ   ,XDRMQK   ,XDRMQP   ,RFMESOQ  ,RCLX     ,&
68 & NTAJUC   ,ETAJUC   ,TPSCLIM
69USE YOMPHY   , ONLY : LRAY     ,LRAYFM   ,LRAYFM15 ,LRRMES
70USE YOEPHY   , ONLY : LAGPHY
71
72!     ------------------------------------------------------------------
73
74IMPLICIT NONE
75
76INTEGER(KIND=JPIM),INTENT(IN)    :: KULOUT
77
78!     ------------------------------------------------------------------
79
80INTEGER(KIND=JPIM) :: JLEV
81
82REAL(KIND=JPRB) :: PAP, PAPX, ZMEST, ZMESU, ZMESQ
83
84REAL(KIND=JPRB) :: PMESQF
85REAL(KIND=JPRB) :: PMESTF
86REAL(KIND=JPRB) :: PMESUF
87REAL(KIND=JPRB) :: ZHOOK_HANDLE
88
89!     ------------------------------------------------------------------
90
91#include "namtoph.h"
92
93!     ------------------------------------------------------------------
94
95!*    Mesospheric drag shape function
96
97!     PMESUF(PAP,PAPX) = MAX( (PAPX-PAP)/MAX(PAP**1.5,1.E-10),0. )
98PMESUF(PAP,PAPX) = MAX( (PAPX-PAP)/MAX(PAP,1.E-10_JPRB),0.0_JPRB )
99PMESTF(PAP,PAPX) = MAX( (PAPX-PAP)/MAX(PAP,1.E-10_JPRB),0.0_JPRB )
100PMESQF(PAP,PAPX) = MAX( (PAPX-PAP)/MAX(PAP,1.E-10_JPRB),0.0_JPRB )
101
102!     ------------------------------------------------------------------
103
104#include "abor1.intfb.h"
105#include "posnam.intfb.h"
106#include "seapre.intfb.h"
107
108!     ------------------------------------------------------------------
109
110IF (LHOOK) CALL DR_HOOK('SUTOPH',0,ZHOOK_HANDLE)
111
112!     ------------------------------------------------------------------
113
114!*       1.    Set default values.
115!              -------------------
116
117!        1.1 Set implicit default values
118
119ETQSAT=0._JPRB
120ETDIFU=0._JPRB
121ETCOEF=0._JPRB
122ETDRAG=0._JPRB
123ETCVIM=0._JPRB
124ETPLUI=0._JPRB
125ETRADI=0._JPRB
126ETNEBU=0._JPRB
127ETOZON=0._JPRB
128ETDRME=0._JPRB
129ETCOET=0._JPRB
130ETAJUC=0._JPRB
131NTQSAT=1
132NTDIFU=1
133NTCOEF=1
134NTDRAG=1
135NTCVIM=1
136NTPLUI=1
137NTRADI=1
138NTNEBU=1
139NTOZON=1
140NTDRME=1
141NTCOET=1
142NTAJUC=1
143
144XDRMUK=0._JPRB
145XDRMUX=0._JPRB
146XDRMUP=0._JPRB
147XDRMTK=0._JPRB
148XDRMTX=0._JPRB
149XDRMTP=0._JPRB
150XDRMQK=0._JPRB
151XDRMQP=0._JPRB
152
153RFMESOQ=3.725E-06_JPRB
154RCLX=0.0_JPRB
155TPSCLIM=197._JPRB
156
157!        1.2 Modify default values according to LECMWF
158
159IF (LECMWF) THEN
160ELSE
161ENDIF
162
163!     ------------------------------------------------------------------
164
165!*       2.    Modify default values.
166!              ----------------------
167
168! Ce qui concerne NAMTOPH commente par MPL le 15.04.09
169!CALL POSNAM(NULNAM,'NAMTOPH')
170!READ(NULNAM,NAMTOPH)
171
172!*       2.1  Search corresponding level, to pressure in NAMTOPH
173!             for each parameterization
174
175IF(ETQSAT /= 0.0_JPRB) CALL SEAPRE (ETQSAT,NTQSAT,STPRE,NFLEVG)
176IF(ETDIFU /= 0.0_JPRB) CALL SEAPRE (ETDIFU,NTDIFU,STPRE,NFLEVG)
177IF(ETCOEF /= 0.0_JPRB) CALL SEAPRE (ETCOEF,NTCOEF,STPRE,NFLEVG)
178IF(ETDRAG /= 0.0_JPRB) CALL SEAPRE (ETDRAG,NTDRAG,STPRE,NFLEVG)
179IF(ETCVIM /= 0.0_JPRB) CALL SEAPRE (ETCVIM,NTCVIM,STPRE,NFLEVG)
180IF(ETPLUI /= 0.0_JPRB) CALL SEAPRE (ETPLUI,NTPLUI,STPRE,NFLEVG)
181IF(ETRADI /= 0.0_JPRB) THEN
182  IF (LRAY) THEN
183    CALL SEAPRE (ETRADI,NTRADI,STPRE,NFLEVG)
184  ENDIF
185  IF (LRAYFM.OR.LRAYFM15) THEN
186    ETRADI=0._JPRB
187    NTRADI=1
188  ENDIF
189ENDIF
190IF(ETNEBU /= 0.0_JPRB) CALL SEAPRE (ETNEBU,NTNEBU,STPRE,NFLEVG)
191IF(ETOZON /= 0.0_JPRB) CALL SEAPRE (ETOZON,NTOZON,STPRE,NFLEVG)
192IF(ETDRME /= 0.0_JPRB) CALL SEAPRE (ETDRME,NTDRME,STPRE,NFLEVG)
193IF(ETCOET /= 0.0_JPRB) CALL SEAPRE (ETCOET,NTCOET,STPRE,NFLEVG)
194IF(ETAJUC /= 0.0_JPRB) CALL SEAPRE (ETAJUC,NTAJUC,STPRE,NFLEVG)
195!     ------------------------------------------------------------------
196
197!*       3.    Print final values.
198!              -------------------
199
200WRITE(UNIT=KULOUT,FMT='('' COMMON YOMTOPH '')')
201WRITE(UNIT=KULOUT,FMT='('' ETQSAT = '',E10.4,'' NTQSAT = '',I10 &
202 & ,'' ETDIFU = '',E10.4,'' NTDIFU = '',I10 &
203 & ,/,'' ETCOEF = '',E10.4,'' NTCOEF = '',I10 &
204 & ,'' ETDRAG = '',E10.4,'' NTDRAG = '',I10 &
205 & ,/,'' ETCVIM = '',E10.4,'' NTCVIM = '',I10 &
206 & ,'' ETPLUI = '',E10.4,'' NTPLUI = '',I10 &
207 & ,/,'' ETRADI = '',E10.4,'' NTRADI = '',I10 &
208 & ,'' ETNEBU = '',E10.4,'' NTNEBU = '',I10 &
209 & ,/,'' ETOZON = '',E10.4,'' NTOZON = '',I10 &
210 & ,'' ETDRME = '',E10.4,'' NTDRME = '',I10 &
211 & ,/,'' ETCOET = '',E10.4,'' NTCOET = '',I10 &
212 & ,/,'' ETAJUC = '',E10.4,'' NTAJUC = '',I10 &
213 & ,/,'' XDRMUK = '',E10.4,'' XDRMUP = '',E10.4 &
214 & ,'' XDRMUX = '',E10.4,'' XDRMTK = '',E10.4 &
215 & ,'' XDRMTP = '',E10.4,'' XDRMTX = '',E10.4 &
216 & ,'' XDRMQK = '',E11.4,'' XDRMQP = '',E11.4 &
217 & ,/,'' RFMESOQ= '',E11.4,'' RCLX   = '',E11.4 &
218 & )')&
219 & ETQSAT,NTQSAT,ETDIFU,NTDIFU &
220 & ,ETCOEF,NTCOEF,ETDRAG,NTDRAG &
221 & ,ETCVIM,NTCVIM,ETPLUI,NTPLUI &
222 & ,ETRADI,NTRADI,ETNEBU,NTNEBU &
223 & ,ETOZON,NTOZON,ETDRME,NTDRME &
224 & ,ETCOET,NTCOET &
225 & ,ETAJUC,NTAJUC &
226 & ,XDRMUK,XDRMUP,XDRMUX,XDRMTK,XDRMTP,XDRMTX &
227 & ,XDRMQK,XDRMQP,RFMESOQ,RCLX
228
229!     VERIFICATION OF CONSISTENCY BETWEEN PHYSICAL PARAMETERIZATION
230
231IF (ETCOEF > ETDIFU.OR.ETCOEF > ETDRAG)THEN
232  WRITE(UNIT=KULOUT,FMT='('' ETCOEF TOO LOW '')')
233  CALL ABOR1('SUTOPH')
234ENDIF
235IF (ETQSAT > ETNEBU.OR.ETQSAT > ETPLUI.OR.ETQSAT > ETCVIM)THEN
236  WRITE(UNIT=KULOUT,FMT='('' ETQSAT TOO LOW '')')
237  CALL ABOR1('SUTOPH')
238ENDIF
239IF (ETCVIM > ETNEBU)THEN
240  WRITE(UNIT=KULOUT,FMT='('' ETCVIM TOO LOW '')')
241  CALL ABOR1('SUTOPH')
242ENDIF
243
244!     ------------------------------------------------------------------
245
246!*       4.    INITIALIZE MESOSPHERIC DRAG FOR U,V AND T
247!              -----------------------------------------
248
249IF (LRRMES.AND..NOT.LAGPHY) THEN
250  WRITE (UNIT=KULOUT,FMT='('' PROFIL VERTICAL DE DRAG MESO'',/&
251   & ,'' LEV'',T15,''VITESSE'',T45,''TEMPERATURE'' &
252   & , T65, ''HUMIDITE'' )') 
253  DO JLEV=1,NFLEVG
254    RMESOU(JLEV)=XDRMUK*PMESUF(STPRE(JLEV),XDRMUP)
255    RMESOT(JLEV)=XDRMTK*PMESTF(STPRE(JLEV),XDRMTP)
256    RMESOQ(JLEV)=XDRMQK*PMESQF(STPRE(JLEV),XDRMQP)
257    IF (XDRMUX /= 0.0_JPRB) RMESOU(JLEV)=MIN(RMESOU(JLEV),XDRMUX)
258    IF (XDRMTX /= 0.0_JPRB) RMESOT(JLEV)=MIN(RMESOT(JLEV),XDRMTX)
259    ZMESU=1.0_JPRB/MAX(1.E-8_JPRB,RMESOU(JLEV)*3600._JPRB*24._JPRB)
260    ZMEST=1.0_JPRB/MAX(1.E-8_JPRB,RMESOT(JLEV)*3600._JPRB*24._JPRB)
261    ZMESQ=1.0_JPRB/MAX(1.E-8_JPRB,RMESOQ(JLEV)*3600._JPRB*24._JPRB)
262    WRITE (UNIT=KULOUT,FMT='(I3,T10,E9.3,T20,G9.3,T40,E9.3,T50 &
263     & ,G9.3, T70,E9.3, T80,G9.3)') JLEV,RMESOU(JLEV),ZMESU, &
264     & RMESOT(JLEV),ZMEST, &
265     & RMESOQ(JLEV),ZMESQ
266  ENDDO
267ENDIF
268
269!     ------------------------------------------------------------------
270
271IF (LHOOK) CALL DR_HOOK('SUTOPH',1,ZHOOK_HANDLE)
272END SUBROUTINE SUTOPH
Note: See TracBrowser for help on using the repository browser.