trunk/phylmd/ajsec.f

SUBROUTINE ajsec(paprs, pplay, t,q, d_t,d_q)

  ! From LMDZ4/libf/phylmd/ajsec.F,v 1.1.1.1 2004/05/19 12:53:08

  use dimens_m
  use dimphy
  use SUPHEC_M
  IMPLICIT none
  !======================================================================
  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
  ! Objet: ajustement sec (adaptation du GCM du LMD)
  !======================================================================
  ! Arguments:
  ! t-------input-R- Temperature
  !
  ! d_t-----output-R-Incrementation de la temperature
  !======================================================================
  REAL, intent(in):: paprs(klon,klev+1)
  real, intent(in):: pplay(klon,klev)
  REAL, intent(in):: t(klon,klev)
  real q(klon,klev)
  REAL d_t(klon,klev), d_q(klon,klev)
  !
  INTEGER limbas, limhau ! les couches a ajuster
  !cc      PARAMETER (limbas=klev-3, limhau=klev)
  PARAMETER (limbas=1, limhau=klev)
  !
  LOGICAL mixq
  !cc      PARAMETER (mixq=.TRUE.)
  PARAMETER (mixq=.FALSE.)
  !
  REAL zh(klon,klev)
  REAL zq(klon,klev)
  REAL zpk(klon,klev)
  REAL zpkdp(klon,klev)
  REAL hm, sm, qm
  LOGICAL modif(klon), down
  INTEGER i, k, k1, k2
  !
  ! Initialisation:
  !
  DO k = 1, klev
     DO i = 1, klon
        d_t(i,k) = 0.0
        d_q(i,k) = 0.0
     ENDDO
  ENDDO
  !------------------------------------- detection des profils a modifier
  DO k = limbas, limhau
     DO i = 1, klon
        zpk(i,k) = pplay(i,k)**RKAPPA
        zh(i,k) = RCPD * t(i,k)/ zpk(i,k)
        zq(i,k) = q(i,k)
     ENDDO
  ENDDO
  !
  DO k = limbas, limhau
     DO i = 1, klon
        zpkdp(i,k) = zpk(i,k) * (paprs(i,k)-paprs(i,k+1))
     ENDDO
  ENDDO
  !
  DO i = 1, klon
     modif(i) = .FALSE.
  ENDDO
  DO k = limbas+1, limhau
     DO i = 1, klon
        IF (.NOT.modif(i)) THEN
           IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE.
        ENDIF
     ENDDO
  ENDDO
  !------------------------------------- correction des profils instables
  DO  i = 1, klon
     IF (modif(i)) THEN
        k2 = limbas
        do
           k2 = k2 + 1
           IF (k2 .GT. limhau) exit
           IF (zh(i,k2) .LT. zh(i,k2-1)) THEN
              k1 = k2 - 1
              k = k1
              sm = zpkdp(i,k2)
              hm = zh(i,k2)
              qm = zq(i,k2)
              do
                 sm = sm +zpkdp(i,k)
                 hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm
                 qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm
                 down = .FALSE.
                 IF (k1 .ne. limbas) THEN
                    IF (hm .LT. zh(i,k1-1)) down = .TRUE.
                 ENDIF
                 IF (down) THEN
                    k1 = k1 - 1
                    k = k1
                 ELSE
                    IF ((k2 .EQ. limhau)) exit
                    IF ((zh(i,k2+1).GE.hm)) exit
                    k2 = k2 + 1
                    k = k2
                 ENDIF
              end do

              !------------ nouveau profil : constant (valeur moyenne)
              DO k = k1, k2
                 zh(i,k) = hm
                 zq(i,k) = qm
              ENDDO
              k2 = k2 + 1
           ENDIF
        end do
     ENDIF
  end DO
  !
  DO k = limbas, limhau
     DO i = 1, klon
        d_t(i,k) = zh(i,k)*zpk(i,k)/RCPD - t(i,k)
        d_q(i,k) = zq(i,k) - q(i,k)
     ENDDO
  ENDDO
  !
  IF (limbas.GT.1) THEN
     DO k = 1, limbas-1
        DO i = 1, klon
           d_t(i,k) = 0.0
           d_q(i,k) = 0.0
        ENDDO
     ENDDO
  ENDIF
  !
  IF (limhau.LT.klev) THEN
     DO k = limhau+1, klev
        DO i = 1, klon
           d_t(i,k) = 0.0
           d_q(i,k) = 0.0
        ENDDO
     ENDDO
  ENDIF
  !
  IF (.NOT.mixq) THEN
     DO k = 1, klev
        DO i = 1, klon
           d_q(i,k) = 0.0
        ENDDO
     ENDDO
  ENDIF

END SUBROUTINE ajsec
1	guez	52	SUBROUTINE ajsec(paprs, pplay, t,q, d_t,d_q)
2
3			! From LMDZ4/libf/phylmd/ajsec.F,v 1.1.1.1 2004/05/19 12:53:08
4
5			use dimens_m
6			use dimphy
7			use SUPHEC_M
8			IMPLICIT none
9			!======================================================================
10			! Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
11			! Objet: ajustement sec (adaptation du GCM du LMD)
12			!======================================================================
13			! Arguments:
14			! t-------input-R- Temperature
15			!
16			! d_t-----output-R-Incrementation de la temperature
17			!======================================================================
18			REAL, intent(in):: paprs(klon,klev+1)
19			real, intent(in):: pplay(klon,klev)
20			REAL, intent(in):: t(klon,klev)
21			real q(klon,klev)
22			REAL d_t(klon,klev), d_q(klon,klev)
23			!
24			INTEGER limbas, limhau ! les couches a ajuster
25			!cc PARAMETER (limbas=klev-3, limhau=klev)
26			PARAMETER (limbas=1, limhau=klev)
27			!
28			LOGICAL mixq
29			!cc PARAMETER (mixq=.TRUE.)
30			PARAMETER (mixq=.FALSE.)
31			!
32			REAL zh(klon,klev)
33			REAL zq(klon,klev)
34			REAL zpk(klon,klev)
35			REAL zpkdp(klon,klev)
36			REAL hm, sm, qm
37			LOGICAL modif(klon), down
38			INTEGER i, k, k1, k2
39			!
40			! Initialisation:
41			!
42			DO k = 1, klev
43			DO i = 1, klon
44			d_t(i,k) = 0.0
45			d_q(i,k) = 0.0
46			ENDDO
47			ENDDO
48			!------------------------------------- detection des profils a modifier
49			DO k = limbas, limhau
50			DO i = 1, klon
51			zpk(i,k) = pplay(i,k)**RKAPPA
52			zh(i,k) = RCPD * t(i,k)/ zpk(i,k)
53			zq(i,k) = q(i,k)
54			ENDDO
55			ENDDO
56			!
57			DO k = limbas, limhau
58			DO i = 1, klon
59			zpkdp(i,k) = zpk(i,k) * (paprs(i,k)-paprs(i,k+1))
60			ENDDO
61			ENDDO
62			!
63			DO i = 1, klon
64			modif(i) = .FALSE.
65			ENDDO
66			DO k = limbas+1, limhau
67			DO i = 1, klon
68			IF (.NOT.modif(i)) THEN
69			IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE.
70			ENDIF
71			ENDDO
72			ENDDO
73			!------------------------------------- correction des profils instables
74			DO i = 1, klon
75			IF (modif(i)) THEN
76			k2 = limbas
77			do
78			k2 = k2 + 1
79			IF (k2 .GT. limhau) exit
80			IF (zh(i,k2) .LT. zh(i,k2-1)) THEN
81	guez	3	k1 = k2 - 1
82			k = k1
83			sm = zpkdp(i,k2)
84			hm = zh(i,k2)
85			qm = zq(i,k2)
86	guez	52	do
87			sm = sm +zpkdp(i,k)
88			hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm
89			qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm
90			down = .FALSE.
91			IF (k1 .ne. limbas) THEN
92			IF (hm .LT. zh(i,k1-1)) down = .TRUE.
93			ENDIF
94			IF (down) THEN
95			k1 = k1 - 1
96			k = k1
97			ELSE
98			IF ((k2 .EQ. limhau)) exit
99			IF ((zh(i,k2+1).GE.hm)) exit
100			k2 = k2 + 1
101			k = k2
102			ENDIF
103			end do
104
105			!------------ nouveau profil : constant (valeur moyenne)
106	guez	3	DO k = k1, k2
107	guez	52	zh(i,k) = hm
108			zq(i,k) = qm
109	guez	3	ENDDO
110			k2 = k2 + 1
111	guez	52	ENDIF
112			end do
113			ENDIF
114			end DO
115			!
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			!
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			!
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			!
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
149			END SUBROUTINE ajsec