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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/libf/phylmd/ajsec.f revision 3 by guez, Wed Feb 27 13:16:39 2008 UTC trunk/phylmd/ajsec.f revision 82 by guez, Wed Mar 5 14:57:53 2014 UTC
# Line 1  Line 1 
1  !  module ajsec_m
2  ! $Header: /home/cvsroot/LMDZ4/libf/phylmd/ajsec.F,v 1.1.1.1 2004/05/19 12:53:08 lmdzadmin Exp $  
3  !    IMPLICIT none
4        SUBROUTINE ajsec(paprs, pplay, t,q, d_t,d_q)  
5        use dimens_m  contains
6        use dimphy  
7        use YOMCST    SUBROUTINE ajsec(paprs, pplay, t, q, d_t, d_q)
8        IMPLICIT none  
9  c======================================================================      ! From LMDZ4/libf/phylmd/ajsec.F, version 1.1.1.1 2004/05/19 12:53:08
10  c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818  
11  c Objet: ajustement sec (adaptation du GCM du LMD)      ! Author: Z. X. Li (LMD/CNRS) date: 1993/08/18
12  c======================================================================      ! Objet : ajustement sec
13  c Arguments:  
14  c t-------input-R- Temperature      USE dimphy, ONLY : klev, klon
15  c      USE suphec_m, ONLY : rcpd, rkappa
16  c d_t-----output-R-Incrementation de la temperature  
17  c======================================================================      REAL, intent(in):: paprs(klon, klev+1)
18        REAL, intent(in):: paprs(klon,klev+1)      real, intent(in):: pplay(klon, klev)
19        real pplay(klon,klev)      REAL, intent(in):: t(klon, klev) ! temperature
20        REAL t(klon,klev), q(klon,klev)      real, intent(in):: q(klon, klev)
21        REAL d_t(klon,klev), d_q(klon,klev)      REAL, intent(out):: d_t(klon, klev) ! incrémentation de la température
22  c      REAL, intent(out):: d_q(klon, klev)
23        INTEGER limbas, limhau ! les couches a ajuster  
24  ccc      PARAMETER (limbas=klev-3, limhau=klev)      ! Local:
25        PARAMETER (limbas=1, limhau=klev)      INTEGER, PARAMETER:: limbas=1, limhau=klev ! les couches à ajuster
26  c      LOGICAL, PARAMETER:: mixq = .FALSE.
27        LOGICAL mixq      REAL, dimension(klon, limbas: limhau):: zh, zq, zpk, zpkdp
28  ccc      PARAMETER (mixq=.TRUE.)      REAL hm, sm, qm
29        PARAMETER (mixq=.FALSE.)      LOGICAL down
30  c      INTEGER i, k, k1, k2
31        REAL zh(klon,klev)  
32        REAL zq(klon,klev)      !--------------------------------------------------------------------
33        REAL zpk(klon,klev)  
34        REAL zpkdp(klon,klev)      zpk = pplay(:, limbas: limhau)**RKAPPA
35        REAL hm, sm, qm      zh = RCPD * t(:, limbas: limhau) / zpk
36        LOGICAL modif(klon), down      zq = q(:, limbas: limhau)
37        INTEGER i, k, k1, k2      forall (k = limbas: limhau) &
38  c           zpkdp(:, k) = zpk(:, k) * (paprs(:, k) - paprs(:, k+1))
39  c Initialisation:  
40  c      ! Correction des profils instables :
41        DO k = 1, klev      DO i = 1, klon
42        DO i = 1, klon         IF (any((/(zh(i, k) < zh(i, k - 1), k = limbas + 1, limhau)/))) THEN
43           d_t(i,k) = 0.0            ! Profil instable, à modifier
          d_q(i,k) = 0.0  
       ENDDO  
       ENDDO  
 c------------------------------------- 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  
 c  
       DO k = limbas, limhau  
       DO i = 1, klon  
          zpkdp(i,k) = zpk(i,k) * (paprs(i,k)-paprs(i,k+1))  
       ENDDO  
       ENDDO  
 c  
       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  
 c------------------------------------- correction des profils instables  
       DO 1080 i = 1, klon  
       IF (modif(i)) THEN  
44            k2 = limbas            k2 = limbas
45   8000     CONTINUE            do while (k2 <= limhau - 1)
46              k2 = k2 + 1               k2 = k2 + 1
47              IF (k2 .GT. limhau) goto 8001               IF (zh(i, k2) < zh(i, k2-1)) THEN
48              IF (zh(i,k2) .LT. zh(i,k2-1)) THEN                  k1 = k2 - 1
49                k1 = k2 - 1                  k = k1
50                k = k1                  sm = zpkdp(i, k2)
51                sm = zpkdp(i,k2)                  hm = zh(i, k2)
52                hm = zh(i,k2)                  qm = zq(i, k2)
53                qm = zq(i,k2)                  do
54   8020         CONTINUE                     sm = sm + zpkdp(i, k)
55                  sm = sm +zpkdp(i,k)                     hm = hm + zpkdp(i, k) * (zh(i, k)-hm) / sm
56                  hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm                     qm = qm + zpkdp(i, k) * (zq(i, k)-qm) / sm
57                  qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm                     down = .FALSE.
58                  down = .FALSE.                     IF (k1 /= limbas) THEN
59                  IF (k1 .ne. limbas) THEN                        IF (hm < zh(i, k1-1)) down = .TRUE.
60                    IF (hm .LT. zh(i,k1-1)) down = .TRUE.                     ENDIF
61                  ENDIF                     IF (down) THEN
62                  IF (down) THEN                        k1 = k1 - 1
63                    k1 = k1 - 1                        k = k1
64                    k = k1                     ELSE
65                  ELSE                        IF (k2 == limhau) exit
66                    IF ((k2 .EQ. limhau)) GOTO 8021                        IF (zh(i, k2 + 1) >= hm) exit
67                    IF ((zh(i,k2+1).GE.hm)) GOTO 8021                        k2 = k2 + 1
68                    k2 = k2 + 1                        k = k2
69                    k = k2                     ENDIF
70                  ENDIF                  end do
71                GOTO 8020  
72   8021         CONTINUE                  ! nouveau profil : constant (valeur moyenne)
73  c------------ nouveau profil : constant (valeur moyenne)                  DO k = k1, k2
74                DO k = k1, k2                     zh(i, k) = hm
75                  zh(i,k) = hm                     zq(i, k) = qm
76                  zq(i,k) = qm                  ENDDO
77                ENDDO                  k2 = k2 + 1
78                k2 = k2 + 1               ENDIF
79              ENDIF            end do
80            GOTO 8000         ENDIF
81   8001     CONTINUE      end DO
82        ENDIF  
83   1080 CONTINUE      d_t(:, : limbas - 1) = 0.
84  c      d_t(:, limbas: limhau) = zh * zpk / RCPD - t(:, limbas: limhau)
85        DO k = limbas, limhau      d_t(:, limhau + 1:) = 0.
86        DO i = 1, klon  
87           d_t(i,k) = zh(i,k)*zpk(i,k)/RCPD - t(i,k)      if (mixq) then
88           d_q(i,k) = zq(i,k) - q(i,k)         d_q(:, : limbas - 1) = 0.
89        ENDDO         d_q(:, limbas: limhau) = zq - q(:, limbas: limhau)
90        ENDDO         d_q(:, limhau + 1:) = 0.
91  c      else
92        IF (limbas.GT.1) THEN         d_q = 0.
93        DO k = 1, limbas-1      end if
94        DO i = 1, klon  
95           d_t(i,k) = 0.0    END SUBROUTINE ajsec
96           d_q(i,k) = 0.0  
97        ENDDO  end module ajsec_m
       ENDDO  
       ENDIF  
 c  
       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  
 c  
       IF (.NOT.mixq) THEN  
       DO k = 1, klev  
       DO i = 1, klon  
          d_q(i,k) = 0.0  
       ENDDO  
       ENDDO  
       ENDIF  
 c  
       RETURN  
       END  
Legend:
Removed from v.3  
changed lines
  Added in v.82
  ViewVC Help
Powered by ViewVC 1.1.21