/[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

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