/[lmdze]/trunk/libf/phylmd/ajsec.f90
ViewVC logotype

Diff of /trunk/libf/phylmd/ajsec.f90

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

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