/[lmdze]/trunk/Sources/phylmd/ajsec.f
ViewVC logotype

Annotation of /trunk/Sources/phylmd/ajsec.f

Parent Directory Parent Directory | Revision Log Revision Log

Revision 10 - (hide annotations)
Fri Apr 18 14:45:53 2008 UTC (16 years, 1 month ago) by guez
Original Path: trunk/libf/phylmd/ajsec.f
File size: 3958 byte(s) 
Added NetCDF directory "/home/guez/include" in "g95.mk" and
"nag_tools.mk".

Added some "intent" attributes in "PVtheta", "advtrac", "caladvtrac",
"calfis", "diagedyn", "dissip", "vlspltqs", "aeropt", "ajsec",
"calltherm", "clmain", "cltrac", "cltracrn", "concvl", "conema3",
"conflx", "fisrtilp", "newmicro", "nuage", "diagcld1", "diagcld2",
"drag_noro", "lift_noro", "SUGWD", "physiq", "phytrac", "radlwsw", "thermcell".

Removed the case "ierr == 0" in "abort_gcm"; moved call to "histclo"
and messages for end of run from "abort_gcm" to "gcm"; replaced call
to "abort_gcm" in "leapfrog" by exit from outer loop.

In "calfis": removed argument "pp" and variable "unskap"; changed
"pksurcp" from scalar to rank 2; use "pressure_var"; rewrote
computation of "zplev", "zplay", "ztfi", "pcvgt" using "dyn_phy";
added computation of "pls".

Removed unused variable in "dynredem0".

In "exner_hyb": changed "dellta" from scalar to rank 1; replaced call
to "ssum" by call to "sum"; removed variables "xpn" and "xps";
replaced some loops by array expressions.

In "leapfrog": use "pressure_var"; deleted variables "p", "longcles".

Converted common blocks "YOECUMF", "YOEGWD" to modules.

Removed argument "pplay" in "cvltr", "diagetpq", "nflxtr".

Created module "raddimlw" from include file "raddimlw.h".

Corrected call to "new_unit" in "test_disvert".
1 guez 3 !
2     ! $Header: /home/cvsroot/LMDZ4/libf/phylmd/ajsec.F,v 1.1.1.1 2004/05/19 12:53:08 lmdzadmin Exp $
3     !
4     SUBROUTINE ajsec(paprs, pplay, t,q, d_t,d_q)
5     use dimens_m
6     use dimphy
7     use YOMCST
8     IMPLICIT none
9     c======================================================================
10     c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
11     c Objet: ajustement sec (adaptation du GCM du LMD)
12     c======================================================================
13     c Arguments:
14     c t-------input-R- Temperature
15     c
16     c d_t-----output-R-Incrementation de la temperature
17     c======================================================================
18     REAL, intent(in):: paprs(klon,klev+1)
19 guez 10 real, intent(in):: pplay(klon,klev)
20 guez 3 REAL t(klon,klev), q(klon,klev)
21     REAL d_t(klon,klev), d_q(klon,klev)
22     c
23     INTEGER limbas, limhau ! les couches a ajuster
24     ccc PARAMETER (limbas=klev-3, limhau=klev)
25     PARAMETER (limbas=1, limhau=klev)
26     c
27     LOGICAL mixq
28     ccc PARAMETER (mixq=.TRUE.)
29     PARAMETER (mixq=.FALSE.)
30     c
31     REAL zh(klon,klev)
32     REAL zq(klon,klev)
33     REAL zpk(klon,klev)
34     REAL zpkdp(klon,klev)
35     REAL hm, sm, qm
36     LOGICAL modif(klon), down
37     INTEGER i, k, k1, k2
38     c
39     c Initialisation:
40     c
41     DO k = 1, klev
42     DO i = 1, klon
43     d_t(i,k) = 0.0
44     d_q(i,k) = 0.0
45     ENDDO
46     ENDDO
47     c------------------------------------- detection des profils a modifier
48     DO k = limbas, limhau
49     DO i = 1, klon
50     zpk(i,k) = pplay(i,k)**RKAPPA
51     zh(i,k) = RCPD * t(i,k)/ zpk(i,k)
52     zq(i,k) = q(i,k)
53     ENDDO
54     ENDDO
55     c
56     DO k = limbas, limhau
57     DO i = 1, klon
58     zpkdp(i,k) = zpk(i,k) * (paprs(i,k)-paprs(i,k+1))
59     ENDDO
60     ENDDO
61     c
62     DO i = 1, klon
63     modif(i) = .FALSE.
64     ENDDO
65     DO k = limbas+1, limhau
66     DO i = 1, klon
67     IF (.NOT.modif(i)) THEN
68     IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE.
69     ENDIF
70     ENDDO
71     ENDDO
72     c------------------------------------- correction des profils instables
73     DO 1080 i = 1, klon
74     IF (modif(i)) THEN
75     k2 = limbas
76     8000 CONTINUE
77     k2 = k2 + 1
78     IF (k2 .GT. limhau) goto 8001
79     IF (zh(i,k2) .LT. zh(i,k2-1)) THEN
80     k1 = k2 - 1
81     k = k1
82     sm = zpkdp(i,k2)
83     hm = zh(i,k2)
84     qm = zq(i,k2)
85     8020 CONTINUE
86     sm = sm +zpkdp(i,k)
87     hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm
88     qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm
89     down = .FALSE.
90     IF (k1 .ne. limbas) THEN
91     IF (hm .LT. zh(i,k1-1)) down = .TRUE.
92     ENDIF
93     IF (down) THEN
94     k1 = k1 - 1
95     k = k1
96     ELSE
97     IF ((k2 .EQ. limhau)) GOTO 8021
98     IF ((zh(i,k2+1).GE.hm)) GOTO 8021
99     k2 = k2 + 1
100     k = k2
101     ENDIF
102     GOTO 8020
103     8021 CONTINUE
104     c------------ nouveau profil : constant (valeur moyenne)
105     DO k = k1, k2
106     zh(i,k) = hm
107     zq(i,k) = qm
108     ENDDO
109     k2 = k2 + 1
110     ENDIF
111     GOTO 8000
112     8001 CONTINUE
113     ENDIF
114     1080 CONTINUE
115     c
116     DO k = limbas, limhau
117     DO i = 1, klon
118     d_t(i,k) = zh(i,k)*zpk(i,k)/RCPD - t(i,k)
119     d_q(i,k) = zq(i,k) - q(i,k)
120     ENDDO
121     ENDDO
122     c
123     IF (limbas.GT.1) THEN
124     DO k = 1, limbas-1
125     DO i = 1, klon
126     d_t(i,k) = 0.0
127     d_q(i,k) = 0.0
128     ENDDO
129     ENDDO
130     ENDIF
131     c
132     IF (limhau.LT.klev) THEN
133     DO k = limhau+1, klev
134     DO i = 1, klon
135     d_t(i,k) = 0.0
136     d_q(i,k) = 0.0
137     ENDDO
138     ENDDO
139     ENDIF
140     c
141     IF (.NOT.mixq) THEN
142     DO k = 1, klev
143     DO i = 1, klon
144     d_q(i,k) = 0.0
145     ENDDO
146     ENDDO
147     ENDIF
148     c
149     RETURN
150     END
  ViewVC Help
Powered by ViewVC 1.1.21