| 1 | SUBROUTINE LWVD & |
|---|
| 2 | & ( KIDIA, KFDIA, KLON , KLEV , KTRAER,& |
|---|
| 3 | & PABCU, PDBDT,& |
|---|
| 4 | & PGA , PGB,& |
|---|
| 5 | & PCNTRB, PDISD, PDISU, PDWFSU & |
|---|
| 6 | & ) |
|---|
| 7 | |
|---|
| 8 | !**** *LWVD* - L.W., VERTICAL INTEGRATION, DISTANT LAYERS |
|---|
| 9 | |
|---|
| 10 | ! PURPOSE. |
|---|
| 11 | ! -------- |
|---|
| 12 | ! CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS |
|---|
| 13 | |
|---|
| 14 | !** INTERFACE. |
|---|
| 15 | ! ---------- |
|---|
| 16 | |
|---|
| 17 | ! EXPLICIT ARGUMENTS : |
|---|
| 18 | ! -------------------- |
|---|
| 19 | ! ==== INPUTS === |
|---|
| 20 | ! PABCU : (KLON,NUA,3*KLEV+1) ; ABSORBER AMOUNTS |
|---|
| 21 | ! PDBDT : (KLON,KLEV) ; LAYER PLANCK FUNCTION GRADIENT |
|---|
| 22 | ! PGA, PGB ; PADE APPROXIMANTS |
|---|
| 23 | ! ==== OUTPUTS === |
|---|
| 24 | ! PCNTRB : (KLON,KLEV+1,KLEV+1); ENERGY EXCHANGE MATRIX |
|---|
| 25 | ! PDIS.. : (KLON,KLEV+1) ; CONTRIBUTION BY DISTANT LAYERS |
|---|
| 26 | ! PDWFSU : (KLON,NSIL) ; SPECTRAL DOWNWARD FLUX AT SURFACE |
|---|
| 27 | |
|---|
| 28 | ! IMPLICIT ARGUMENTS : NONE |
|---|
| 29 | ! -------------------- |
|---|
| 30 | |
|---|
| 31 | ! METHOD. |
|---|
| 32 | ! ------- |
|---|
| 33 | |
|---|
| 34 | ! 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE |
|---|
| 35 | ! CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE |
|---|
| 36 | |
|---|
| 37 | ! EXTERNALS. |
|---|
| 38 | ! ---------- |
|---|
| 39 | |
|---|
| 40 | ! *LWTT* |
|---|
| 41 | |
|---|
| 42 | ! REFERENCE. |
|---|
| 43 | ! ---------- |
|---|
| 44 | |
|---|
| 45 | ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND |
|---|
| 46 | ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS |
|---|
| 47 | |
|---|
| 48 | ! AUTHOR. |
|---|
| 49 | ! ------- |
|---|
| 50 | ! JEAN-JACQUES MORCRETTE *ECMWF* |
|---|
| 51 | |
|---|
| 52 | ! MODIFICATIONS. |
|---|
| 53 | ! -------------- |
|---|
| 54 | ! ORIGINAL : 89-07-14 |
|---|
| 55 | ! JJ Morcrette 97-04-18 Revised continuum + Surf. Emissiv. |
|---|
| 56 | ! M.Hamrud 01-Oct-2003 CY28 Cleaning |
|---|
| 57 | !----------------------------------------------------------------------- |
|---|
| 58 | |
|---|
| 59 | USE PARKIND1 ,ONLY : JPIM ,JPRB |
|---|
| 60 | USE YOMHOOK ,ONLY : LHOOK, DR_HOOK |
|---|
| 61 | |
|---|
| 62 | USE YOELW , ONLY : NSIL ,NIPD ,NTRA ,NUA ,NG1P1 |
|---|
| 63 | |
|---|
| 64 | IMPLICIT NONE |
|---|
| 65 | |
|---|
| 66 | INTEGER(KIND=JPIM),INTENT(IN) :: KLON |
|---|
| 67 | INTEGER(KIND=JPIM),INTENT(IN) :: KLEV |
|---|
| 68 | INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA |
|---|
| 69 | INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA |
|---|
| 70 | INTEGER(KIND=JPIM),INTENT(IN) :: KTRAER |
|---|
| 71 | REAL(KIND=JPRB) ,INTENT(IN) :: PABCU(KLON,NUA,3*KLEV+1) |
|---|
| 72 | REAL(KIND=JPRB) ,INTENT(IN) :: PDBDT(KLON,NSIL,KLEV) |
|---|
| 73 | REAL(KIND=JPRB) ,INTENT(IN) :: PGA(KLON,NIPD,2,KLEV) |
|---|
| 74 | REAL(KIND=JPRB) ,INTENT(IN) :: PGB(KLON,NIPD,2,KLEV) |
|---|
| 75 | REAL(KIND=JPRB) ,INTENT(OUT) :: PCNTRB(KLON,KLEV+1,KLEV+1) |
|---|
| 76 | REAL(KIND=JPRB) ,INTENT(OUT) :: PDISD(KLON,KLEV+1) |
|---|
| 77 | REAL(KIND=JPRB) ,INTENT(OUT) :: PDISU(KLON,KLEV+1) |
|---|
| 78 | REAL(KIND=JPRB) ,INTENT(INOUT) :: PDWFSU(KLON,NSIL) |
|---|
| 79 | !----------------------------------------------------------------------- |
|---|
| 80 | |
|---|
| 81 | !* 0.1 ARGUMENTS |
|---|
| 82 | ! --------- |
|---|
| 83 | |
|---|
| 84 | !----------------------------------------------------------------------- |
|---|
| 85 | |
|---|
| 86 | ! ------------ |
|---|
| 87 | |
|---|
| 88 | REAL(KIND=JPRB) :: ZTT(KLON,NTRA), ZTT1(KLON,NTRA), ZTT2(KLON,NTRA) |
|---|
| 89 | |
|---|
| 90 | INTEGER(KIND=JPIM) :: IJKL, IKD1, IKD2, IKJ, IKJP1, IKM1, IKN,& |
|---|
| 91 | & IKP1, IKU1, IKU2, ITT, JA, JK, JKJ, JL, JLK |
|---|
| 92 | |
|---|
| 93 | REAL(KIND=JPRB) :: ZWW, ZWW1, ZWW2, ZWW3, ZWW4, ZWW5, ZWW6 |
|---|
| 94 | REAL(KIND=JPRB) :: ZHOOK_HANDLE |
|---|
| 95 | |
|---|
| 96 | #include "lwttm.intfb.h" |
|---|
| 97 | |
|---|
| 98 | !----------------------------------------------------------------------- |
|---|
| 99 | |
|---|
| 100 | !* 1. INITIALIZATION |
|---|
| 101 | ! -------------- |
|---|
| 102 | |
|---|
| 103 | !* 1.1 INITIALIZE LAYER CONTRIBUTIONS |
|---|
| 104 | ! ------------------------------ |
|---|
| 105 | |
|---|
| 106 | IF (LHOOK) CALL DR_HOOK('LWVD',0,ZHOOK_HANDLE) |
|---|
| 107 | DO JK = 1, KLEV+1 |
|---|
| 108 | DO JL = KIDIA,KFDIA |
|---|
| 109 | PDISD(JL,JK) = 0.0_JPRB |
|---|
| 110 | PDISU(JL,JK) = 0.0_JPRB |
|---|
| 111 | ENDDO |
|---|
| 112 | ENDDO |
|---|
| 113 | |
|---|
| 114 | !* 1.2 INITIALIZE TRANSMISSION FUNCTIONS |
|---|
| 115 | ! --------------------------------- |
|---|
| 116 | |
|---|
| 117 | DO JA = 1, NTRA |
|---|
| 118 | DO JL = KIDIA,KFDIA |
|---|
| 119 | ZTT (JL,JA) = 1.0_JPRB |
|---|
| 120 | ZTT1(JL,JA) = 1.0_JPRB |
|---|
| 121 | ZTT2(JL,JA) = 1.0_JPRB |
|---|
| 122 | ENDDO |
|---|
| 123 | ENDDO |
|---|
| 124 | |
|---|
| 125 | ! ------------------------------------------------------------------ |
|---|
| 126 | |
|---|
| 127 | !* 2. VERTICAL INTEGRATION |
|---|
| 128 | ! -------------------- |
|---|
| 129 | |
|---|
| 130 | !* 2.2 CONTRIBUTION FROM DISTANT LAYERS |
|---|
| 131 | ! --------------------------------- |
|---|
| 132 | |
|---|
| 133 | !* 2.2.1 DISTANT AND ABOVE LAYERS |
|---|
| 134 | ! ------------------------ |
|---|
| 135 | |
|---|
| 136 | !* 2.2.2 FIRST UPPER LEVEL |
|---|
| 137 | ! ----------------- |
|---|
| 138 | |
|---|
| 139 | DO JK = 1 , KLEV-1 |
|---|
| 140 | IKP1=JK+1 |
|---|
| 141 | IKN=(JK-1)*NG1P1+1 |
|---|
| 142 | IKD1= JK *NG1P1+1 |
|---|
| 143 | |
|---|
| 144 | CALL LWTTM & |
|---|
| 145 | & ( KIDIA , KFDIA , KLON,& |
|---|
| 146 | & PGA(1,1,1,JK) , PGB(1,1,1,JK),& |
|---|
| 147 | & PABCU(1,1,IKN), PABCU(1,1,IKD1), ZTT1 & |
|---|
| 148 | & ) |
|---|
| 149 | |
|---|
| 150 | !* 2.2.3 HIGHER UP |
|---|
| 151 | ! --------- |
|---|
| 152 | |
|---|
| 153 | ITT=1 |
|---|
| 154 | DO JKJ=IKP1,KLEV |
|---|
| 155 | IF(ITT == 1) THEN |
|---|
| 156 | ITT=2 |
|---|
| 157 | ELSE |
|---|
| 158 | ITT=1 |
|---|
| 159 | ENDIF |
|---|
| 160 | IKJP1=JKJ+1 |
|---|
| 161 | IKD2= JKJ *NG1P1+1 |
|---|
| 162 | |
|---|
| 163 | IF(ITT == 1) THEN |
|---|
| 164 | CALL LWTTM & |
|---|
| 165 | & ( KIDIA , KFDIA , KLON,& |
|---|
| 166 | & PGA(1,1,1,JKJ), PGB(1,1,1,JKJ),& |
|---|
| 167 | & PABCU(1,1,IKN), PABCU(1,1,IKD2), ZTT1 & |
|---|
| 168 | & ) |
|---|
| 169 | |
|---|
| 170 | ELSE |
|---|
| 171 | CALL LWTTM & |
|---|
| 172 | & ( KIDIA , KFDIA , KLON,& |
|---|
| 173 | & PGA(1,1,1,JKJ), PGB(1,1,1,JKJ),& |
|---|
| 174 | & PABCU(1,1,IKN), PABCU(1,1,IKD2), ZTT2 & |
|---|
| 175 | & ) |
|---|
| 176 | |
|---|
| 177 | ENDIF |
|---|
| 178 | |
|---|
| 179 | DO JA = 1, KTRAER |
|---|
| 180 | DO JL = KIDIA,KFDIA |
|---|
| 181 | ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5_JPRB |
|---|
| 182 | ENDDO |
|---|
| 183 | ENDDO |
|---|
| 184 | |
|---|
| 185 | DO JL = KIDIA,KFDIA |
|---|
| 186 | ZWW1=PDBDT(JL,1,JKJ)*ZTT(JL,1) *ZTT(JL,10) |
|---|
| 187 | ZWW2=PDBDT(JL,2,JKJ)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11) |
|---|
| 188 | ZWW3=PDBDT(JL,3,JKJ)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12) |
|---|
| 189 | ZWW4=PDBDT(JL,4,JKJ)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13) |
|---|
| 190 | ZWW5=PDBDT(JL,5,JKJ)*ZTT(JL,3) *ZTT(JL,14) |
|---|
| 191 | ZWW6=PDBDT(JL,6,JKJ)*ZTT(JL,6) *ZTT(JL,15) |
|---|
| 192 | ZWW=ZWW1+ZWW2+ZWW3+ZWW4+ZWW5+ZWW6 |
|---|
| 193 | PDISD(JL,JK)=PDISD(JL,JK)+ZWW |
|---|
| 194 | PCNTRB(JL,JK,IKJP1)=ZWW |
|---|
| 195 | IF (JK == 1) THEN |
|---|
| 196 | PDWFSU(JL,1)=PDWFSU(JL,1)+ZWW1 |
|---|
| 197 | PDWFSU(JL,2)=PDWFSU(JL,2)+ZWW2 |
|---|
| 198 | PDWFSU(JL,3)=PDWFSU(JL,3)+ZWW3 |
|---|
| 199 | PDWFSU(JL,4)=PDWFSU(JL,4)+ZWW4 |
|---|
| 200 | PDWFSU(JL,5)=PDWFSU(JL,5)+ZWW5 |
|---|
| 201 | PDWFSU(JL,6)=PDWFSU(JL,6)+ZWW6 |
|---|
| 202 | ENDIF |
|---|
| 203 | ENDDO |
|---|
| 204 | |
|---|
| 205 | ENDDO |
|---|
| 206 | ENDDO |
|---|
| 207 | |
|---|
| 208 | !* 2.2.4 DISTANT AND BELOW LAYERS |
|---|
| 209 | ! ------------------------ |
|---|
| 210 | |
|---|
| 211 | !* 2.2.5 FIRST LOWER LEVEL |
|---|
| 212 | ! ----------------- |
|---|
| 213 | |
|---|
| 214 | DO JK=3,KLEV+1 |
|---|
| 215 | IKN=(JK-1)*NG1P1+1 |
|---|
| 216 | IKM1=JK-1 |
|---|
| 217 | IKJ=JK-2 |
|---|
| 218 | IKU1= IKJ *NG1P1+1 |
|---|
| 219 | |
|---|
| 220 | CALL LWTTM & |
|---|
| 221 | & ( KIDIA , KFDIA , KLON,& |
|---|
| 222 | & PGA(1,1,1,IKJ) , PGB(1,1,1,IKJ),& |
|---|
| 223 | & PABCU(1,1,IKU1), PABCU(1,1,IKN), ZTT1 & |
|---|
| 224 | & ) |
|---|
| 225 | |
|---|
| 226 | !* 2.2.6 DOWN BELOW |
|---|
| 227 | ! ---------- |
|---|
| 228 | |
|---|
| 229 | ITT=1 |
|---|
| 230 | DO JLK=1,IKJ |
|---|
| 231 | IF(ITT == 1) THEN |
|---|
| 232 | ITT=2 |
|---|
| 233 | ELSE |
|---|
| 234 | ITT=1 |
|---|
| 235 | ENDIF |
|---|
| 236 | IJKL=IKM1-JLK |
|---|
| 237 | IKU2=(IJKL-1)*NG1P1+1 |
|---|
| 238 | |
|---|
| 239 | IF(ITT == 1) THEN |
|---|
| 240 | CALL LWTTM & |
|---|
| 241 | & ( KIDIA , KFDIA , KLON,& |
|---|
| 242 | & PGA(1,1,1,IJKL), PGB(1,1,1,IJKL),& |
|---|
| 243 | & PABCU(1,1,IKU2), PABCU(1,1,IKN) , ZTT1 & |
|---|
| 244 | & ) |
|---|
| 245 | |
|---|
| 246 | ELSE |
|---|
| 247 | CALL LWTTM & |
|---|
| 248 | & ( KIDIA , KFDIA , KLON,& |
|---|
| 249 | & PGA(1,1,1,IJKL), PGB(1,1,1,IJKL),& |
|---|
| 250 | & PABCU(1,1,IKU2), PABCU(1,1,IKN) , ZTT2 & |
|---|
| 251 | & ) |
|---|
| 252 | |
|---|
| 253 | ENDIF |
|---|
| 254 | |
|---|
| 255 | DO JA = 1, KTRAER |
|---|
| 256 | DO JL = KIDIA,KFDIA |
|---|
| 257 | ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5_JPRB |
|---|
| 258 | ENDDO |
|---|
| 259 | ENDDO |
|---|
| 260 | |
|---|
| 261 | DO JL = KIDIA,KFDIA |
|---|
| 262 | ZWW=PDBDT(JL,1,IJKL)*ZTT(JL,1) *ZTT(JL,10)& |
|---|
| 263 | & +PDBDT(JL,2,IJKL)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)& |
|---|
| 264 | & +PDBDT(JL,3,IJKL)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)& |
|---|
| 265 | & +PDBDT(JL,4,IJKL)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)& |
|---|
| 266 | & +PDBDT(JL,5,IJKL)*ZTT(JL,3) *ZTT(JL,14)& |
|---|
| 267 | & +PDBDT(JL,6,IJKL)*ZTT(JL,6) *ZTT(JL,15) |
|---|
| 268 | PDISU(JL,JK)=PDISU(JL,JK)+ZWW |
|---|
| 269 | PCNTRB(JL,JK,IJKL)=ZWW |
|---|
| 270 | ENDDO |
|---|
| 271 | |
|---|
| 272 | ENDDO |
|---|
| 273 | ENDDO |
|---|
| 274 | |
|---|
| 275 | ! ------------------------------------------------------------------ |
|---|
| 276 | |
|---|
| 277 | IF (LHOOK) CALL DR_HOOK('LWVD',1,ZHOOK_HANDLE) |
|---|
| 278 | END SUBROUTINE LWVD |
|---|
