libf/phylmd/ajsec.f90

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	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	k1 = k2 - 1
82	k = k1
83	sm = zpkdp(i,k2)
84	hm = zh(i,k2)
85	qm = zq(i,k2)
86	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	DO k = k1, k2
107	zh(i,k) = hm
108	zq(i,k) = qm
109	ENDDO
110	k2 = k2 + 1
111	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