Changeset 878 for LMDZ4/trunk/libf/phylmd/ajsec.F
- Timestamp:
- Jan 14, 2008, 1:03:39 PM (17 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
LMDZ4/trunk/libf/phylmd/ajsec.F
r766 r878 2 2 ! $Header$ 3 3 ! 4 SUBROUTINE ajsec(paprs, pplay, t,q, d_t,d_q) 4 SUBROUTINE ajsec(paprs, pplay, t,q,limbas,d_t,d_q) 5 USE dimphy 6 IMPLICIT none 7 c====================================================================== 8 c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818 9 c Objet: ajustement sec (adaptation du GCM du LMD) 10 c====================================================================== 11 c Arguments: 12 c t-------input-R- Temperature 13 c 14 c d_t-----output-R-Incrementation de la temperature 15 c====================================================================== 16 cym#include "dimensions.h" 17 cym#include "dimphy.h" 18 #include "YOMCST.h" 19 REAL paprs(klon,klev+1), pplay(klon,klev) 20 REAL t(klon,klev), q(klon,klev) 21 REAL d_t(klon,klev), d_q(klon,klev) 22 c 23 INTEGER limbas(klon), limhau ! les couches a ajuster 24 c 25 LOGICAL mixq 26 ccc PARAMETER (mixq=.TRUE.) 27 PARAMETER (mixq=.FALSE.) 28 c 29 REAL zh(klon,klev) 30 REAL zho(klon,klev) 31 REAL zq(klon,klev) 32 REAL zpk(klon,klev) 33 REAL zpkdp(klon,klev) 34 REAL hm, sm, qm 35 LOGICAL modif(klon), down 36 INTEGER i, k, k1, k2 37 c 38 c Initialisation: 39 c 40 cym 41 limhau=klev 42 43 DO k = 1, klev 44 DO i = 1, klon 45 d_t(i,k) = 0.0 46 d_q(i,k) = 0.0 47 ENDDO 48 ENDDO 49 c------------------------------------- detection des profils a modifier 50 DO k = 1, limhau 51 DO i = 1, klon 52 zpk(i,k) = pplay(i,k)**RKAPPA 53 zh(i,k) = RCPD * t(i,k)/ zpk(i,k) 54 zho(i,k) = zh(i,k) 55 zq(i,k) = q(i,k) 56 ENDDO 57 ENDDO 58 c 59 DO k = 1, limhau 60 DO i = 1, klon 61 zpkdp(i,k) = zpk(i,k) * (paprs(i,k)-paprs(i,k+1)) 62 ENDDO 63 ENDDO 64 c 65 DO i = 1, klon 66 modif(i) = .FALSE. 67 ENDDO 68 DO k = 2, limhau 69 DO i = 1, klon 70 IF (.NOT.modif(i).and.k-1>limbas(i)) THEN 71 IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE. 72 ENDIF 73 ENDDO 74 ENDDO 75 c------------------------------------- correction des profils instables 76 DO 1080 i = 1, klon 77 IF (modif(i)) THEN 78 k2 = limbas(i) 79 8000 CONTINUE 80 k2 = k2 + 1 81 IF (k2 .GT. limhau) goto 8001 82 IF (zh(i,k2) .LT. zh(i,k2-1)) THEN 83 k1 = k2 - 1 84 k = k1 85 sm = zpkdp(i,k2) 86 hm = zh(i,k2) 87 qm = zq(i,k2) 88 8020 CONTINUE 89 sm = sm +zpkdp(i,k) 90 hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm 91 qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm 92 down = .FALSE. 93 IF (k1 .ne. limbas(i)) THEN 94 IF (hm .LT. zh(i,k1-1)) down = .TRUE. 95 ENDIF 96 IF (down) THEN 97 k1 = k1 - 1 98 k = k1 99 ELSE 100 IF ((k2 .EQ. limhau)) GOTO 8021 101 IF ((zh(i,k2+1).GE.hm)) GOTO 8021 102 k2 = k2 + 1 103 k = k2 104 ENDIF 105 GOTO 8020 106 8021 CONTINUE 107 c------------ nouveau profil : constant (valeur moyenne) 108 DO k = k1, k2 109 zh(i,k) = hm 110 zq(i,k) = qm 111 ENDDO 112 k2 = k2 + 1 113 ENDIF 114 GOTO 8000 115 8001 CONTINUE 116 ENDIF 117 1080 CONTINUE 118 c 119 DO k = 1, limhau 120 DO i = 1, klon 121 d_t(i,k) = (zh(i,k)-zho(i,k))*zpk(i,k)/RCPD 122 d_q(i,k) = zq(i,k) - q(i,k) 123 ENDDO 124 ENDDO 125 c 126 ! FH : les d_q et d_t sont maintenant calcules de facon a valoir 127 ! effectivement 0. si on ne fait rien. 128 ! 129 ! IF (limbas.GT.1) THEN 130 ! DO k = 1, limbas-1 131 ! DO i = 1, klon 132 ! d_t(i,k) = 0.0 133 ! d_q(i,k) = 0.0 134 ! ENDDO 135 ! ENDDO 136 ! ENDIF 137 c 138 ! IF (limhau.LT.klev) THEN 139 ! DO k = limhau+1, klev 140 ! DO i = 1, klon 141 ! d_t(i,k) = 0.0 142 ! d_q(i,k) = 0.0 143 ! ENDDO 144 ! ENDDO 145 ! ENDIF 146 c 147 IF (.NOT.mixq) THEN 148 DO k = 1, klev 149 DO i = 1, klon 150 d_q(i,k) = 0.0 151 ENDDO 152 ENDDO 153 ENDIF 154 c 155 RETURN 156 END 157 158 SUBROUTINE ajsec_convV2(paprs, pplay, t,q, d_t,d_q) 5 159 USE dimphy 6 160 IMPLICIT none
Note: See TracChangeset
for help on using the changeset viewer.