| 1 |
|
| 2 |
#include "ctrparam.h" |
| 3 |
|
| 4 |
! ========================================================== |
| 5 |
! |
| 6 |
! DD2G04.F: Diagnostic program for 2-D model. |
| 7 |
! |
| 8 |
! ---------------------------------------------------------- |
| 9 |
! |
| 10 |
! Revision History: |
| 11 |
! |
| 12 |
! When Who What |
| 13 |
! ----- ---------- ------- |
| 14 |
! 080200 Chien Wang repack based on CliChem3 & M24x11, |
| 15 |
! and add cpp. |
| 16 |
! |
| 17 |
! ========================================================== |
| 18 |
|
| 19 |
C**** DD2G04 BD2G04 DD2G04 01/02/93 0.1 |
| 20 |
C**** OPT(3) 0.2 |
| 21 |
C**** 0.3 |
| 22 |
C**** Diagnostic program for 2-D model. 0.4 |
| 23 |
C**** Like D2G04, but run on work station. 0.5 |
| 24 |
c SUBROUTINE DIAGA (U,V,T,P,Q,TC) 1. |
| 25 |
SUBROUTINE DIAGA (U,V,T,P,Q,NOCLM) |
| 26 |
C**** IDACC 2. |
| 27 |
C**** CONTENTS OF AJ(J,N) (SUM OVER LONGITUDE AND TIME OF) 3. |
| 28 |
C**** 1 SRINCP0 (W/M**2) 2 RD 4. |
| 29 |
C**** 2 SRNFP0 (W/M**2) 2 RD 5. |
| 30 |
C**** 3 SRNFP1 (W/M**2) 2 RD 6. |
| 31 |
C**** 4 SRABSATM=AJ(2)-AJ(6) (W/M**2) 2 D1 7. |
| 32 |
C**** 5 SRINCG (W/M**2) 2 RD 8. |
| 33 |
C**** 6 SRNFG (W/M**2) 2 RD 9. |
| 34 |
C**** 7 TRNFP0=AJ(74)+A2BYA1*AJ(9)/DTSRCE (W/M**2) 2 D1 10. |
| 35 |
C**** 8 TRNFP1=AJ(75)+A2BYA1*AJ(9)/DTSRCE (W/M**2) 2 D1 11. |
| 36 |
C**** 9 TRHDT (J/M**2) 1 SF 12. |
| 37 |
C**** 10 RNFP0=AJ(2)+AJ(7) (W/M**2) 2 D1 13. |
| 38 |
C**** 11 RNFP1=AJ(3)+AJ(8) (W/M**2) 2 D1 14. |
| 39 |
C**** 12 RHDT=A1BYA2*AJ(6)*DTSRCE+AJ(9) (J/M**2) 1 D1 15. |
| 40 |
C**** 13 QDT (J/M**2) 1 SF 16. |
| 41 |
C**** 14 EVHDT (J/M**2) 1 SF 17. |
| 42 |
C**** 15 F2DT (J/M**2) 1 GD 18. |
| 43 |
C**** 16 HEATZ1=AJ(41)+AJ(42) 1 D1 19. |
| 44 |
C**** 17 TG2 (K-273.16) 1 GD 20. |
| 45 |
C**** 18 TG1 (K-273.16) 1 GD 21. |
| 46 |
C**** 19 EVAP (KG/M**2) 1 GD 22. |
| 47 |
C**** 20 PRCP=AJ(61)+AJ(62) (100 PA) 1 D1 23. |
| 48 |
C**** 21 TX (K-273.16) (INTEGRAL OVER ATMOSPHERE OF) 4 DA 24. |
| 49 |
C**** 22 TX1 (K-273.16) 4 DA 25. |
| 50 |
C**** 23 TS (K-273.16) 3 SF 26. |
| 51 |
C**** 24 DTH/DPHI (STRATOSPHERE) 4 DA 27. |
| 52 |
C**** 25 DTH/DPHI (TROPOSPHERE) 4 DA 28. |
| 53 |
C**** 26 .0625*DTH*DLNP/(DU*DU+DV*DV) (STRATOSPHERE) 4 DA 29. |
| 54 |
C**** 27 .0625*DTH*DLNP/(DU*DU+DV*DV) (TROPOSPHERE) 4 DA 30. |
| 55 |
C**** 28 4*UMAX/(DX*SINJ) (STRATOSPHERE) replaced 4 DA 31. |
| 56 |
C**** 29 4*UMAX/(DX*SINJ) (TROPOSPHERE) replaced 4 DA 32. |
| 57 |
C**** 28 Wsfr variance |
| 58 |
C**** 29 Sea level pressure |
| 59 |
C**** 30 POICE (1) 1 GD 33. |
| 60 |
C**** 31 PSNOW (1) 4 DA 34. |
| 61 |
c 32 TAUL |
| 62 |
c 33 TAUF |
| 63 |
C**** 34 TG3 ocean only |
| 64 |
C**** 35 T(J+1)-T(J-1) (SUM OVER STRATOSPHERE OF) 4 DA 36. |
| 65 |
C**** 36 T(J+1)-T(J-1) (SUM OVER TROPOSPHERE OF) 4 DA 37. |
| 66 |
C**** 37 SQRT(DTH/DLNP)/SINJ (STRATOSPHERE) replaced 4 DA 38. |
| 67 |
C**** 38 SQRT(DTH/DLNP)/SINJ (TROPOSPHERE) replaced 4 DA 39. |
| 68 |
C**** 37 Surf Wind |
| 69 |
C**** 38 Total stress |
| 70 |
C**** 39 ENERGP (J/M**2) 1 PR 40. |
| 71 |
C**** 40 ERUN1 (J/M**2) 1 GP 41. |
| 72 |
C**** 41 EDIFS (J/M**2) 1 GP 42. |
| 73 |
C**** 42 F1DT (J/M**2) 1 GD 43. |
| 74 |
C**** 43 ERUN2 (J/M**2) 1 GP 44. |
| 75 |
C**** 44 HEATZ0=AJ(12)+AJ(13)+AJ(14)+AJ(39)-AJ(40) (J/M**2) 1 D1 45. |
| 76 |
C**** 45 DIFS (KG/M**2) 1 GP 46. |
| 77 |
C**** 46 DWTR1=AJ(20)*SCALE(20)-(AJ(19)+AJ(45)+AJ(54))*SCALE(19) 1 D1 47. |
| 78 |
C**** 47 RUN2 (KG/M**2) 1 GP 48. |
| 79 |
C**** 48 DWTR2=AJ(45)-AJ(47) (KG/M**2) 1 D1 49. |
| 80 |
C**** 49 WTR1 (KG/M**2) 1 GD 50. |
| 81 |
C**** 50 ACE1 (KG/M**2) 1 GD 51. |
| 82 |
C**** 51 WTR2 (KG/M**2) 1 GD 52. |
| 83 |
C**** 52 ACE2 (KG/M**2) 1 GD 53. |
| 84 |
C**** 53 SNOW (KG/M**2) 1 GD 54. |
| 85 |
C**** 54 RUN1 (KG/M**2) 1 GP 55. |
| 86 |
C**** 55 BTEMPW-TF 2 RD 56. |
| 87 |
C**** 56 HEATZ2=AJ(15)+AJ(43) (J/M**2) 1 D1 57. |
| 88 |
C**** 57 PCLDSS (1) (COMPOSITE OVER ATMOSPHERE) 2 RD 58. |
| 89 |
C**** 58 PCLDMC (1) (COMPOSITE OVER ATMOSPHERE) 2 RD 59. |
| 90 |
C**** 59 PCLD (1) (COMPOSITE OVER ATMOSPHERE) 2 RD 60. |
| 91 |
C**** 60 CLDTOPMC=AJ(80)/AJ(58) (100 PA) 0 D1 61. |
| 92 |
C**** 61 PRCPSS (100 PA) 1 CN 62. |
| 93 |
C**** 62 PRCPMC (100 PA) 1 CN 63. |
| 94 |
C**** 63 Q*P (100 PA) (INTEGRAL OVER ATMOSPHERE OF) 4 DA 64. |
| 95 |
C**** 64 GAM (K/M) (*SIG(TROPOSPHERE)/GRAV) 4 DA 65. |
| 96 |
C**** 65 GAMM (K-S**2/M**2) (SIG(TROPOSPHERE)/GAMD) 4 DA 66. |
| 97 |
C**** 66 GAMC (K/M) 4 DA 67. |
| 98 |
C**** 67 TRINCG (W/M**2) 2 RD 68. |
| 99 |
C**** 68-69 FREE 69. |
| 100 |
C**** 70 TRNFP0-TRNFG (W/M**2) 2 RD 70. |
| 101 |
C**** 71 TRNFP1-TRNFG (W/M**2) 2 RD 71. |
| 102 |
C**** 72 PLAVIS*S0*COSZ (W/M**2) 2 RD 72. |
| 103 |
C**** 73 PLANIR*S0*COSZ (W/M**2) 2 RD 73. |
| 104 |
C**** 74 ALBVIS*S0*COSZ (W/M**2) 2 RD 74. |
| 105 |
C**** 75 ALBNIR*S0*COSZ (W/M**2) 2 RD 75. |
| 106 |
C**** 76 SRRVIS*S0*COSZ (W/M**2) 2 RD 76. |
| 107 |
C**** 77 SRRNIR*S0*COSZ (W/M**2) 2 RD 77. |
| 108 |
C**** 78 SRAVIS*S0*COSZ (W/M**2) 2 RD 78. |
| 109 |
C**** 79 SRANIR*S0*COSZ (W/M**2) 2 RD 79. |
| 110 |
C**** 80 PBOTMC-PTOPMC (100 PA) 2 RD 80. |
| 111 |
C**** 81. |
| 112 |
C**** CONTENTS OF APJ(J,N) (SUM OVER LONGITUDE AND TIME OF) 82. |
| 113 |
C**** 1 P (100 PA) 4 DA 83. |
| 114 |
C**** 2 4*P4I (100 PA) (UV GRID) 4 DA 84. |
| 115 |
C**** 85. |
| 116 |
C**** CONTENTS OF AJL(J,L,N) (SUM OVER LONGITUDE AND TIME OF) 86. |
| 117 |
C**** 1 (TX-273.16)*P (100 K*PA) 4 DA 87. |
| 118 |
C**** 2 PHI*P (100 N/S**2) 4 DA 88. |
| 119 |
C**** 3 Q*P (100 PA) 4 DA 89. |
| 120 |
C**** 4 4*PU4I (100 PA*M/S) (UV GRID) 4 DA 90. |
| 121 |
C**** 5 4*PV4I (100 PA*M/S) (UV GRID) 4 DA 91. |
| 122 |
C**** 6 SD (100 N/S) 4 DA 92. |
| 123 |
C**** 7 -(PWAI*DA-PWI*SPAI/SPI*DA) (P GRID) 4 DA 93. |
| 124 |
C**** 8 FMX(MC)*P (100 PA) 1 CN 94. |
| 125 |
C**** 9 SRHR (W/M**2) 2 RD 95. |
| 126 |
C**** 10 TRHR (W/M**2) 2 RD 96. |
| 127 |
C**** 11 DTX(SS)*P (100 K*PA) 1 CN 97. |
| 128 |
C**** 12 DT(DC)*P C3 98. |
| 129 |
C**** 13 DT(MC)*P (100 PA*K) DRY HEATING C3 99. |
| 130 |
C**** 14 4*(PU4I*PU4I+PV4I*PV4I)/P4I (100 N/S**2) (UV GRID) 4 DA 100. |
| 131 |
C**** 15 4*PWW4I (100 N/S**2) (UV GRID) 4 DA 101. |
| 132 |
C**** 16 (TH*SQRT(P)-THGM)**2/GMEAN(PR**(1-KAPA)*DTH/DPR) 4 DA 102. |
| 133 |
C**** 17 TH*P 4 DA 103. |
| 134 |
C**** 18 RH*P 4 DA 104. |
| 135 |
C**** 19 PCLD*P (TOTAL) C3 105. |
| 136 |
C**** 20 16*PT16I*PV4I/P4I (100 PA*K*M/S) (UV GRID) 4 DA 106. |
| 137 |
C**** 21 16*PTV16I (100 PA*K*M/S) (UV GRID) 4 DA 107. |
| 138 |
C**** 22 16*PZ16I*PV4I/P4I (100 W/S**2) (UV GRID) 4 DA 108. |
| 139 |
C**** 23 16*PZV16I (100 W/S**2) (UV GRID) 4 DA 109. |
| 140 |
C**** 24 16*PQ16I*PV4I/P4I (100 PA*M/S) (UV GRID) 4 DA 110. |
| 141 |
C**** 25 16*PQV16I (100 PA*M/S) (UV GRID) 4 DA 111. |
| 142 |
C**** 26 4*PWW4I*PV4I/P4I (100 W/S**2) (UV GRID) 4 DA 112. |
| 143 |
C**** 27 4*PWWV4I (100 W/S**2) (UV GRID) 4 DA 113. |
| 144 |
C**** 28 PCLD*P (SS) C3 114. |
| 145 |
C**** 29 PCLD*P (MC) C3 115. |
| 146 |
C**** 30 2*(SHA*T+PHI) * SDMEAN 4 DA 116. |
| 147 |
C**** 31 2*(SHA*T+PHI) * SD 4 DA 117. |
| 148 |
C**** 32 2*Q * SDMEAN 4 DA 118. |
| 149 |
C**** 33 2*Q * SD 4 DA 119. |
| 150 |
C**** 34 2*PHI * (SD-SDMEAN) 4 DA 120. |
| 151 |
C**** 35 16*(U*U+V*V) * SD (UV GRID) 4 DA 121. |
| 152 |
C**** 36 8*(U*SD - U*SDMEAN) (UV GRID) 4 DA 122. |
| 153 |
C**** 37 8*(U+R*OMEGA*COSJ) * SD (UV GRID) 4 DA 123. |
| 154 |
C**** 38 DU(DC)*P (UV GRID) GD 124. |
| 155 |
C**** 39 DU(MC)*P (100 N/M/S) (UV GRID) 1 CN 125. |
| 156 |
C**** 40 DU(ED)*P*(DTSURF*DSIG*ED/DZ**2) (UV GRID) SF 126. |
| 157 |
C**** 41 U (SUM OVER I FROM 5 TO 9) (PV GRID) (COMMENTED OUT) 4 DA 127. |
| 158 |
C**** 41 P*V*((TH-THMEAN) * (DU/DP) / (DTH/DP) - U+UMEAN ) 4 DA 128. |
| 159 |
C**** 42 SRNFLB (W/M**2) 2 RD |
| 160 |
C**** 43 TRNFLB (W/M**2) 2 RD |
| 161 |
C**** 44 U (SUM OVER I FROM 35 TO 3) (PV GRID) (COMMENTED OUT) 4 DA 131. |
| 162 |
C**** 44 (2F-2D(UDX))*16PV(TH-THMEAN)/(DTH/DSIG)+(SD-SDMEAN)*8U 4 DA 132. |
| 163 |
C**** 45 SRNFLB CLEAR SKY (W/M**2) 2 RD |
| 164 |
C**** 46 TRNFLB CLEAR SKY (W/M**2) 2 RD |
| 165 |
C**** 47 V-V* =D((V-VI)*(T-TI)/DTHDP)/DP 4 DA 135. |
| 166 |
C**** 48 4*PU4I*PV4I/P4I (100 N/S**2) (UV GRID) 4 DA 136. |
| 167 |
C**** 49 4*PUV4I (100 N/S**2) (UV GRID) 4 DA 137. |
| 168 |
C**** 50 DT(MC)*P (100 PA*K) CHANGE OF PHASE 1 CN 138. |
| 169 |
C**** 51 FREE 139. |
| 170 |
C**** 52 PV =DTH/DP*(DUCOS(LAT)/COS(LAT)DLAT-F)-DTH/DLAT*DU/DP 4 DA 140. |
| 171 |
C**** 53 VDVT - VPDA4*DVT/PDA4 4 DA 141. |
| 172 |
C**** 54 SIGMA (VARIANCE FOR MOIST CONVECTION) 4 DA 142. |
| 173 |
C 55 NORT. TRANSPORT of Q by hor. diff. |
| 174 |
C 56 DQ due to hori. diff. |
| 175 |
C 57 DQ due to MC |
| 176 |
C**** 143. |
| 177 |
C**** CONTENTS OF ASJL(J,L,N) (SUM OVER LONGITUDE AND TIME OF) 144. |
| 178 |
C**** 1 TX (K) 4 DA 145. |
| 179 |
C**** 2 PHI (M**2/S**2) 4 DA 146. |
| 180 |
C**** 3 SRHR (W/M**2) 2 RD 147. |
| 181 |
C**** 4 TRHR (W/M**2) 2 RD 148. |
| 182 |
C**** 149. |
| 183 |
C**** CONTENTS OF AIJ(I,J,N) (SUM OVER TIME OF) 150. |
| 184 |
C**** 1 POICE (1) 4 DA 151. |
| 185 |
C**** 2 PSNOW (1) 4 DA 152. |
| 186 |
C**** 3 SNOW (KG/M**2) 4 DA 153. |
| 187 |
C**** 4 QDT (J/M**2) 1 SF 154. |
| 188 |
C**** 5 PREC (KG/M**2) 1 PR 155. |
| 189 |
C**** 6 EVAP (KG/M**2) 1 SF 156. |
| 190 |
C**** 7 BETA (1) 3 SF 157. |
| 191 |
C**** 8 4*P4 (100 PA) (UV GRID) 4 DA 158. |
| 192 |
C**** 9 PHI1000 (M**2/S**2) 4 DA 159. |
| 193 |
C**** 10 PHI850 (M**2/S**2-1500*GRAV) 4 DA 160. |
| 194 |
C**** 11 PHI700-3000*GRAV 4 DA 161. |
| 195 |
C**** 12 PHI500-5600*GRAV 4 DA 162. |
| 196 |
C**** 13 PHI300-9500*GRAV 4 DA 163. |
| 197 |
C**** 14 PHI100-16400*GRAV 4 DA 164. |
| 198 |
C**** 15 PHI30-24000*GRAV 4 DA 165. |
| 199 |
C**** 16 T700-273.16 (K-273.16)*GRAV) 4 DA 166. |
| 200 |
C**** 17 PCLDMC (1) (COMPOSITE OVER ATMOSPHERE) 2 RD 167. |
| 201 |
C**** 18 PBOTMC-PTOPMC (100 PA) 2 RD 168. |
| 202 |
C**** 19 PCLD (1) (COMPOSITE OVER ATMOSPHERE) 2 RD 169. |
| 203 |
C**** 20 16*P4*(SHA*T4+Z4)*V1*DSIG*DXV (100 W*M/S**2) (UV GRID) 4 DA 170. |
| 204 |
C**** 21 TRNFP0 (W/M**2) 2 RS 171. |
| 205 |
C**** 22 SRHDT+TRHDT (J/M**2) 1 SF 172. |
| 206 |
C**** 23 SRHDT+TRHDT+QDT+EVHDT+ENRGP (J/M**2) 1 SP 173. |
| 207 |
C**** 24 SRNFP0 (W/M**2) 2 RD 174. |
| 208 |
C**** 25 SRINCP0 (W/M**2) 2 RD 175. |
| 209 |
C**** 26 SRNFG (W/M**2) 2 RD 176. |
| 210 |
C**** 27 SRINCG (W/M**2) 2 RD 177. |
| 211 |
C**** 28 TG1 (K-273.16) 1 GD 178. |
| 212 |
C**** 29 PLICE+PEARTH*PFROZEN (1) 4 DA 179. |
| 213 |
C**** 30 TG2 (K-273.16) 1 GD 180. |
| 214 |
C**** 31 DTH/DPHI (TROPOSPHERE) 4 DA 181. |
| 215 |
C**** 32 RUN1 (KG/M**2) 1 SF 182. |
| 216 |
C**** 33 TS (K-273.16) (USING LAPSE RATE FROM TX1) 4 DA 183. |
| 217 |
C**** 34 CDM (1) 3 SF 184. |
| 218 |
C**** 35 TS (K-273.16) 3 SF 185. |
| 219 |
C**** 36 US (M/S) 3 SF 186. |
| 220 |
C**** 37 VS (M/S) 3 SF 187. |
| 221 |
C**** 38 PSL (100 PA-1000) (USING TS) 4 DA 188. |
| 222 |
C**** 39 UJET (M/S) 4 DA 189. |
| 223 |
C**** 40 VJET (M/S) 4 DA 190. |
| 224 |
C**** 41 PCLD(LOW) (1) 2 RD 191. |
| 225 |
C**** 42 PCLD(MID) (1) 2 RD 192. |
| 226 |
C**** 43 PCLD(HIGH) (1) 2 RD 193. |
| 227 |
C**** 44 BTEMPW-TF (K-273.16) 2 RD 194. |
| 228 |
C**** 45 PLAVIS*S0*COSZ (W/M**2) 2 RD 195. |
| 229 |
C**** 46 ALPHA0 (1) 1 SF 196. |
| 230 |
C**** 197. |
| 231 |
C**** CONTENTS OF AIL(I,L,N) (SUM OVER TIME OF) 198. |
| 232 |
C**** WE ARE NOT TAKING INTO ACCOUNT THE VARIATION OF MASS 199. |
| 233 |
C**** 1 U (M/S) (SUM OVER J FROM 11 TO 13) (PU GRID) 4 DA 200. |
| 234 |
C**** 2 V (M/S) (SUM OVER J FROM 11 TO 13) (PU GRID) 4 DA 201. |
| 235 |
C**** 3 SD (100 N/S) (SUM OVER J FROM 11 TO 13) 4 DA 202. |
| 236 |
C**** 4 TX (K-273.16) (SUM OVER J FROM 11 TO 13) 4 DA 203. |
| 237 |
C**** 5 RH (1) (SUM OVER J FROM 11 TO 13) 4 DA 204. |
| 238 |
C**** 6 DTX(MC)*P*DA (100 K*N) (SUM OVER J FROM 11 TO 13) 1 CN 205. |
| 239 |
C**** 7 (SRHR+TRHR)*DA (W) (SUM OVER J FROM 11 TO 13) 2 RD 206. |
| 240 |
C**** 9 SD (100 N/S) (AT J=19) 4 DA 207. |
| 241 |
C**** 10 TX-273.16 (AT J = 19) 4 DA 208. |
| 242 |
C**** 11 SR+TR (AT J = 19) 2 RD 209. |
| 243 |
C**** 12 2*U (AT J=19) 4 DA 210. |
| 244 |
C**** 13 SD (AT J = 21) 4 DA 211. |
| 245 |
C**** 14 TX-273.16 (AT J = 21) 4 DA 212. |
| 246 |
C**** 15 SR+TR (AT J = 21) 2 RD 213. |
| 247 |
C**** 16 2*U (AT J=21) 4 DA 214. |
| 248 |
C**** 215. |
| 249 |
C**** CONTENTS OF AIJL(I,J,L,N) (SUM OVER TIME OF) 216. |
| 250 |
C**** 1 4*P4*U1 (100 PA*M/S) (UV GRID) 4 DA 217. |
| 251 |
C**** 2 4*P4*V1 (100 PA*M/S) (UV GRID) 4 DA 218. |
| 252 |
C**** 3 16*P4*(SHA*T4+Z4) (100 N/S**2) (UV GRID) 4 DA 219. |
| 253 |
C**** 220. |
| 254 |
C**** CONTENTS OF IDACC(N), NUMBER OF ACCUMULATION TIMES OF 221. |
| 255 |
C**** 1 SOURCE TERMS (DETERMINED BY NDYN) 222. |
| 256 |
C**** 2 RADIATION SOURCE TERMS (DETERMINED BY NRAD) 223. |
| 257 |
C**** 3 SURFACE INTERACTION SOURCE TERMS (DETERMINED BY NDASF) 224. |
| 258 |
C**** 4 QUANTITIES IN DIAGA (DETERMINED BY NDAA) 225. |
| 259 |
C**** 5 ENERGY NUMBERS IN DIAG4 (DEYERMINED BY NDA4) 226. |
| 260 |
C**** 6 KINETIC ENERGY IN DIAG5 FROM DYNAMICS (DETERMINED BY NDA5K) 227. |
| 261 |
C**** 7 ENERGY IN DIAG5 FROM DYNAMICS (DETERMINED BY NDA5D) 228. |
| 262 |
C**** 8 ENERGY IN DIAG5 FROM SOURCES (DETERMINED BY NDA5S) 229. |
| 263 |
C**** 9 WAVE ENERGY IN DIAG7 (EVERY 12 HOURS) 230. |
| 264 |
C**** 10 ENERGY IN DIAG5 FROM FILTER (DETERMINED BY NFILTR) 231. |
| 265 |
C**** 232. |
| 266 |
|
| 267 |
#include "BD2G04.COM" 233. |
| 268 |
|
| 269 |
COMMON/SPEC2/KMT,KINC,COEK 233.1 |
| 270 |
DIMENSION TSZM(JM0),THSZM(JM0), 233.2 |
| 271 |
* TEMZ(JM0,LM0),COEKY(JM0),DTZDY(JM0,LM0),DTZDZ(JM0,LM0) |
| 272 |
& ,TA(JM0,LM0),PA(JM0) 233.3 |
| 273 |
COMMON/EPARA/VTH(JM0,LM0),WTH(JM0,LM0),VU(JM0,LM0),VV(JM0,LM0), |
| 274 |
& DQSDT(JM0,LM0) 233.4 |
| 275 |
* ,DWV(JM0),PHIT(JM0,LM0),TPRIM2(JM0,LM0),WU(JM0,LM0),CKS,CKN 233.5 |
| 276 |
* ,WQ(JM0,LM0),VQ(JM0,LM0) 233.6 |
| 277 |
c COMMON/HDFLUX/VQHD(JM0,LM0) |
| 278 |
COMMON/HDFLUX/VQHD(JM0,LM0),VTHD(JM0,LM0),VUHD(JM0,LM0), |
| 279 |
& VVHD(JM0,LM0) |
| 280 |
LOGICAL POLE 234. |
| 281 |
LOGICAL NOCLM |
| 282 |
COMMON/WORK1/PIT(IM0,JM0),SD(IM0,JM0,1) 235. |
| 283 |
COMMON/WORK2/PK(IM0,JM0,LM0),W(IM0,JM0,LM0),PHIE(IM0,JM0,LM0-1), |
| 284 |
c & FM(36,9), 236. |
| 285 |
* GMEAN(36),THJL(46,36),THSQJL(46,36),SDMEAN(46,35), 237. |
| 286 |
* UA(36),SQRTP(72),PDA(72),TRI(3), 238. |
| 287 |
* PDAN(72) 239. |
| 288 |
COMMON/WORK3/PHI(IM0,JM0,LM0),TX(IM0,JM0,LM0),THSEC(72),PSEC(72), 240. |
| 289 |
* D2SIG(36),SHETH(36) 241. |
| 290 |
DIMENSION LUPA(36),LDNA(36) 242. |
| 291 |
COMMON/WORK5/DUT(IO0,JM0,LM0),DVT(IO0,JM0,LM0) 243. |
| 292 |
CHARACTER*16 TITLE 244. |
| 293 |
DIMENSION PMB(7),GHT(7) 245. |
| 294 |
DATA PMB/1000.,850.,700.,500.,300.,100.,30./ 246. |
| 295 |
DATA GHT/0.,1500.,3000.,5600.,9500.,16400.,24000./ 247. |
| 296 |
DATA IFIRST/1/ 248. |
| 297 |
C**** QSAT=(RAIR/RVAPOR)*6.1071*EXP((L/RVAPOR)*(1/TF-1/T))/P 249. |
| 298 |
QSAT(TM,PR,QL)=3.797915*EXP(QL*(7.93252E-6-2.166847E-3/TM))/PR 250. |
| 299 |
CALL CLOCKS (MBEGIN) 251. |
| 300 |
IDACC(4)=IDACC(4)+1 252. |
| 301 |
IF(IFIRST.NE.1) GO TO 50 253. |
| 302 |
IFIRST=0 254. |
| 303 |
C**** INITIALIZE CERTAIN QUANTITIES 255. |
| 304 |
P1000=1000.**KAPA 255.5 |
| 305 |
HLAT=LHE 255.6 |
| 306 |
DQDTX=.622*HLAT/RGAS 255.7 |
| 307 |
JET=LTM 256. |
| 308 |
BYIM=1./FIM 257. |
| 309 |
SHA=RGAS/KAPA 258. |
| 310 |
BETA=.0065 259. |
| 311 |
BBYG=BETA/GRAV 260. |
| 312 |
RBBYG=RGAS*BETA/GRAV 261. |
| 313 |
GBYRB=GRAV/(RGAS*BETA) 262. |
| 314 |
EPSLON=1. 263. |
| 315 |
PTOPK=EXPBYK(PTOP) 264. |
| 316 |
KM=0 265. |
| 317 |
DO 5 K=1,7 266. |
| 318 |
IF(PTOP.GT.PMB(K)) GO TO 6 267. |
| 319 |
5 KM=KM+1 268. |
| 320 |
6 JEQ=2.+.5*JMM1 269. |
| 321 |
PRQ1=.75*PTOP 270. |
| 322 |
DLNP12=DLOG(.75/.35) 271. |
| 323 |
DLNP23=DLOG(.35/.1) 272. |
| 324 |
DO 10 L=1,LM 273. |
| 325 |
LUPA(L)=L+1 274. |
| 326 |
10 LDNA(L)=L-1 275. |
| 327 |
LDNA(1)=1 276. |
| 328 |
LUPA(LM)=LM 277. |
| 329 |
50 CONTINUE 278. |
| 330 |
c print *,' PRINT FROM DIAGA' |
| 331 |
C**** 279. |
| 332 |
C**** FILL IN HUMIDITY AND SIGMA DOT ARRAYS AT THE POLES 280. |
| 333 |
C**** 281. |
| 334 |
C**** 286. |
| 335 |
C**** CALCULATE PK AND TX, THE REAL TEMPERATURE 287. |
| 336 |
C**** 288. |
| 337 |
DO 80 L=1,LM 289. |
| 338 |
PK(1,1,L)=EXPBYK(SIG(L)*P(1,1)+PTOP) 290. |
| 339 |
TX(1,1,L)=T(1,1,L)*PK(1,1,L) 291. |
| 340 |
PK(1,JM,L)=EXPBYK(SIG(L)*P(1,JM)+PTOP) 292. |
| 341 |
TX(1,JM,L)=T(1,JM,L)*PK(1,JM,L) 293. |
| 342 |
DO 80 J=2,JMM1 301. |
| 343 |
DO 80 I=1,IM 302. |
| 344 |
PK(I,J,L)=EXPBYK(SIG(L)*P(I,J)+PTOP) 303. |
| 345 |
80 TX(I,J,L)=T(I,J,L)*PK(I,J,L) 304. |
| 346 |
C C C C C C C C C C C C C C C 304.5 |
| 347 |
JMM2=JM-2 304.51 |
| 348 |
IF(COEK.EQ.0.) GO TO 89 304.52 |
| 349 |
DO 74 J=1,JM 304.53 |
| 350 |
PA(J)=0. 304.54 |
| 351 |
DO 71 I=1,IM 304.55 |
| 352 |
71 PA(J)=PA(J)+P(I,J) 304.56 |
| 353 |
DO 73 L=1,LM 304.57 |
| 354 |
TA(J,L)=0. 304.58 |
| 355 |
DO 72 I=1,IM 304.59 |
| 356 |
72 TA(J,L)=TA(J,L)+T(I,J,L) 304.6 |
| 357 |
73 TA(J,L)=TA(J,L)/FIM 304.61 |
| 358 |
74 PA(J)=PA(J)/FIM 304.62 |
| 359 |
89 CONTINUE 304.63 |
| 360 |
C**** 305. |
| 361 |
C**** OUTSIDE J LOOP FOR ALL PRIMARY GRID ROWS 306. |
| 362 |
C**** 307. |
| 363 |
DO 490 J=1,JM 308. |
| 364 |
JM1=J-1 309. |
| 365 |
IF(J.EQ.1) JM1=1 310. |
| 366 |
JP1=J+1 311. |
| 367 |
IF(J.EQ.JM) JP1=JM 312. |
| 368 |
POLE=.FALSE. 313. |
| 369 |
IF(J.EQ.1.OR.J.EQ.JM) POLE=.TRUE. 314. |
| 370 |
IMAX=IM 315. |
| 371 |
IF(POLE) IMAX=1 316. |
| 372 |
CMAX=IMAX 316.5 |
| 373 |
DXYPJ=DXYP(J) 317. |
| 374 |
C**** NUMBERS ACCUMULATED FOR A SINGLE LEVEL 318. |
| 375 |
AT1=0. 319. |
| 376 |
BT1=0. 320. |
| 377 |
CT1=0. 321. |
| 378 |
BSCOV=0. 322. |
| 379 |
CSCOV=0. 323. |
| 380 |
SPI=0. 324. |
| 381 |
DO 120 I=1,IMAX 325. |
| 382 |
JR=J |
| 383 |
PLAND=FDATA(I,J,2) 327. |
| 384 |
POICE=ODATA(I,J,2)*(1.-PLAND) 328. |
| 385 |
PLICE=FDATA(I,J,3)*PLAND 329. |
| 386 |
POCEAN=(1.-PLAND)-POICE 330. |
| 387 |
PEARTH=PLAND-PLICE 331. |
| 388 |
AT1=AT1+(TX(I,J,1)-273.16)*POCEAN 332. |
| 389 |
BT1=BT1+(TX(I,J,1)-273.16)*PLAND 333. |
| 390 |
CT1=CT1+(TX(I,J,1)-273.16)*POICE 334. |
| 391 |
C 335. |
| 392 |
SCOVL=0. 336. |
| 393 |
IF(GDATA(I,J,2).GT.0.) SCOVL=PEARTH 337. |
| 394 |
IF(GDATA(I,J,12).GT.0.) SCOVL=SCOVL+PLICE 338. |
| 395 |
BSCOV=BSCOV+SCOVL 339. |
| 396 |
SCOVOI=0. 340. |
| 397 |
IF(GDATA(I,J,1).GT.0.) SCOVOI=POICE 341. |
| 398 |
CSCOV=CSCOV+SCOVOI 342. |
| 399 |
C 343. |
| 400 |
SPI=SPI+P(I,J) 344. |
| 401 |
AIJ(I,J,1)=AIJ(I,J,1)+POICE 345. |
| 402 |
AIJ(I,J,2)=AIJ(I,J,2)+(SCOVOI+SCOVL) 346. |
| 403 |
AIJ(I,J,3)=AIJ(I,J,3)+(GDATA(I,J,1)*POICE+GDATA(I,J,2)*PLAND) 347. |
| 404 |
TS=TX(I,J,1)*((P(I,J)+PTOP)/(SIG(1)*P(I,J)+PTOP))**RBBYG 348. |
| 405 |
C AIJ(I,J,8)=AIJ(I,J,8)+((P(I,J)+PTOP)*(1.+BBYG*FDATA(I,J,1)/TS) 349. |
| 406 |
C * **GBYRB-1000.) 350. |
| 407 |
AIJ(I,J,29)=AIJ(I,J,29)+(PLICE+PEARTH*GDATA(I,J,6)/ 351. |
| 408 |
* (GDATA(I,J,5)+GDATA(I,J,6)+1.E-20)) 352. |
| 409 |
C AIJ(I,J,33)=AIJ(I,J,33)+(TS-273.16) 353. |
| 410 |
AIJ(I,J,38)=AIJ(I,J,38)+((P(I,J)+PTOP)*(1.+BBYG*FDATA(I,J,1)/ 354. |
| 411 |
* BLDATA(I,J,2))**GBYRB-1000.) 355. |
| 412 |
120 CONTINUE 356. |
| 413 |
AJ(J,22)=AJ(J,22)+AT1 357. |
| 414 |
BJ(J,22)=BJ(J,22)+BT1 358. |
| 415 |
CJ(J,22)=CJ(J,22)+CT1 359. |
| 416 |
|
| 417 |
if(NOCLM)then |
| 418 |
BJ(J,31)=BJ(J,31)+BSCOV 360. |
| 419 |
CJ(J,31)=CJ(J,31)+CSCOV 361. |
| 420 |
endif |
| 421 |
|
| 422 |
APJ(J,1)=APJ(J,1)+SPI 362. |
| 423 |
C**** GEOPOTENTIALS CALCULATED FOR EACH LAYER 363. |
| 424 |
150 DO 160 I=1,IMAX 364. |
| 425 |
P1=SIG(1)*P(I,J)+PTOP 365. |
| 426 |
PUP=SIG(2)*P(I,J)+PTOP 366. |
| 427 |
IF(ABS(TX(I,J,2)-TX(I,J,1)).LT.EPSLON) GO TO 152 367. |
| 428 |
BBYGV=DLOG(TX(I,J,1)/TX(I,J,2))/(RGAS*DLOG(P1/PUP)) 368. |
| 429 |
PHI(I,J,1)=FDATA(I,J,1)+TX(I,J,1) 369. |
| 430 |
* *(((P(I,J)+PTOP)/P1)**(RGAS*BBYGV)-1.)/BBYGV 370. |
| 431 |
PHI(I,J,2)=PHI(I,J,1)+(TX(I,J,1)-TX(I,J,2))/BBYGV 371. |
| 432 |
GO TO 154 372. |
| 433 |
152 PHI(I,J,1)=FDATA(I,J,1)+RGAS*TX(I,J,1)*DLOG((P(I,J)+PTOP)/P1) 373. |
| 434 |
PHI(I,J,2)=PHI(I,J,1)+RGAS*.5*(TX(I,J,1)+TX(I,J,2))*DLOG(P1/PUP) 374. |
| 435 |
154 DO 160 L=3,LM 375. |
| 436 |
PDN=PUP 376. |
| 437 |
PUP=SIG(L)*P(I,J)+PTOP 377. |
| 438 |
IF(ABS(TX(I,J,L)-TX(I,J,L-1)).LT.EPSLON) GO TO 156 378. |
| 439 |
BBYGV=DLOG(TX(I,J,L-1)/TX(I,J,L))/(RGAS*DLOG(PDN/PUP)) 379. |
| 440 |
PHI(I,J,L)=PHI(I,J,L-1)+(TX(I,J,L-1)-TX(I,J,L))/BBYGV 380. |
| 441 |
GO TO 160 381. |
| 442 |
156 PHI(I,J,L)=PHI(I,J,L-1)+RGAS*.5*(TX(I,J,L-1)+TX(I,J,L)) 382. |
| 443 |
* *DLOG(PDN/PUP) 383. |
| 444 |
160 CONTINUE 384. |
| 445 |
C**** CALCULATE GEOPOTENTIAL HEIGHTS AT SPECIFIC MILLIBAR LEVELS 389. |
| 446 |
C**** NUMBERS ACCUMULATED FOR EACH ODD LEVEL 414. |
| 447 |
DO 230 L=1,LM 415. |
| 448 |
ATX=0. 416. |
| 449 |
BTX=0. 417. |
| 450 |
CTX=0. 418. |
| 451 |
TPI=0. 419. |
| 452 |
AQ=0. 420. |
| 453 |
BQ=0. 421. |
| 454 |
CQ=0. 422. |
| 455 |
PHIPI=0. 423. |
| 456 |
QPI=0. 424. |
| 457 |
THPI=0. 425. |
| 458 |
RHPI=0. 426. |
| 459 |
DO 220 I=1,IMAX 427. |
| 460 |
JR=J |
| 461 |
PLAND=FDATA(I,J,2) 429. |
| 462 |
POICE=ODATA(I,J,2)*(1.-PLAND) 430. |
| 463 |
POCEAN=(1.-PLAND)-POICE 431. |
| 464 |
SP=P(I,J) 432. |
| 465 |
ATX=ATX+(TX(I,J,L)-273.16)*POCEAN 433. |
| 466 |
BTX=BTX+(TX(I,J,L)-273.16)*PLAND 434. |
| 467 |
CTX=CTX+(TX(I,J,L)-273.16)*POICE 435. |
| 468 |
AQ=AQ+Q(I,J,L)*SP*POCEAN 436. |
| 469 |
BQ=BQ+Q(I,J,L)*SP*PLAND 437. |
| 470 |
CQ=CQ+Q(I,J,L)*SP*POICE 438. |
| 471 |
C 439. |
| 472 |
C 440. |
| 473 |
TPI=TPI+(TX(I,J,L)-273.16)*SP 441. |
| 474 |
PHIPI=PHIPI+PHI(I,J,L)*SP 442. |
| 475 |
QPI=QPI+Q(I,J,L)*SP 443. |
| 476 |
THPI=THPI+T(I,J,L)*SP 444. |
| 477 |
if(TX(I,J,L).gt.273.)then |
| 478 |
QLH=LHE 445. |
| 479 |
else |
| 480 |
QLH=LHS |
| 481 |
endif |
| 482 |
QSATL=QSAT(TX(I,J,L),SIG(L)*SP+PTOP,QLH) 446. |
| 483 |
IF(QSATL.GT.1.) QSATL=1. 447. |
| 484 |
RHPI=RHPI+Q(I,J,L)*SP/QSATL 448. |
| 485 |
c if(J.eq.7.and.(L.eq.6.or.L.eq.2))then |
| 486 |
c print *,' from DIAGA' |
| 487 |
c print *,' J=',J,' L=',L |
| 488 |
c print *,TX(I,J,L),Q(I,J,L) |
| 489 |
c call SAT(TX(I,J,L),SIG(L)*SP+PTOP,QSN,DN) |
| 490 |
c print *,Q(I,J,L)/QSATL,Q(I,J,L)/QSN |
| 491 |
c endif |
| 492 |
220 CONTINUE 449. |
| 493 |
AJ(J,21)=AJ(J,21)+ATX*DSIG(L) 450. |
| 494 |
BJ(J,21)=BJ(J,21)+BTX*DSIG(L) 451. |
| 495 |
CJ(J,21)=CJ(J,21)+CTX*DSIG(L) 452. |
| 496 |
AJ(J,63)=AJ(J,63)+AQ*DSIG(L) 453. |
| 497 |
BJ(J,63)=BJ(J,63)+BQ*DSIG(L) 454. |
| 498 |
CJ(J,63)=CJ(J,63)+CQ*DSIG(L) 455. |
| 499 |
AJL(J,L,1)=AJL(J,L,1)+TPI 456. |
| 500 |
AJL(J,L,2)=AJL(J,L,2)+PHIPI 457. |
| 501 |
AJL(J,L,3)=AJL(J,L,3)+QPI 458. |
| 502 |
AJL(J,L,17)=AJL(J,L,17)+THPI 459. |
| 503 |
AJL(J,L,18)=AJL(J,L,18)+RHPI 460. |
| 504 |
AJL(J,L,54)=AJL(J,L,54)+TPRIM2(J,L)*PK(1,J,L)**2. 460.1 |
| 505 |
230 CONTINUE 461. |
| 506 |
C**** 462. |
| 507 |
C**** NORTHWARD GRADIENT OF TEMPERATURE: TROPOSPHERIC AND STRATOSPHERIC 463. |
| 508 |
C**** 464. |
| 509 |
C**** MEAN TROPOSPHERIC NORTHWARD TEMPERATURE GRADIENT 465. |
| 510 |
DO 340 L=1,LTM 466. |
| 511 |
ADTDL=0. 467. |
| 512 |
BDTDL=0. 468. |
| 513 |
CDTDL=0. 469. |
| 514 |
DO 335 I=1,IMAX 470. |
| 515 |
PLAND=FDATA(I,J,2) 471. |
| 516 |
POICE=ODATA(I,J,2)*(1.-PLAND) 472. |
| 517 |
POCEAN=(1.-PLAND)-POICE 473. |
| 518 |
ADTDL=ADTDL+(TX(I,JP1,L)-TX(I,JM1,L))*POCEAN 474. |
| 519 |
BDTDL=BDTDL+(TX(I,JP1,L)-TX(I,JM1,L))*PLAND 475. |
| 520 |
CDTDL=CDTDL+(TX(I,JP1,L)-TX(I,JM1,L))*POICE 476. |
| 521 |
335 CONTINUE 477. |
| 522 |
IF(.NOT.POLE) GO TO 338 478. |
| 523 |
DO 336 I=2,IM 479. |
| 524 |
ADTDL=ADTDL+(TX(I,JP1,L)-TX(I,JM1,L))*POCEAN 480. |
| 525 |
BDTDL=BDTDL+(TX(I,JP1,L)-TX(I,JM1,L))*PLAND 481. |
| 526 |
CDTDL=CDTDL+(TX(I,JP1,L)-TX(I,JM1,L))*POICE 482. |
| 527 |
336 CONTINUE 483. |
| 528 |
ADTDL=ADTDL*2./FIM 484. |
| 529 |
BDTDL=BDTDL*2./FIM 485. |
| 530 |
CDTDL=CDTDL*2./FIM 486. |
| 531 |
338 AJ(J,36)=AJ(J,36)+ADTDL*DSIG(L) 487. |
| 532 |
BJ(J,36)=BJ(J,36)+BDTDL*DSIG(L) 488. |
| 533 |
340 CJ(J,36)=CJ(J,36)+CDTDL*DSIG(L) 489. |
| 534 |
C**** MEAN STRATOSPHERIC NORTHWARD TEMPERATURE GRADIENT 490. |
| 535 |
IF (LS1.GT.LM) GO TO 380 491. |
| 536 |
DO 370 L=LS1,LM 492. |
| 537 |
ADTDL=0. 493. |
| 538 |
BDTDL=0. 494. |
| 539 |
CDTDL=0. 495. |
| 540 |
DO 350 I=1,IM 496. |
| 541 |
PLAND=FDATA(I,J,2) 497. |
| 542 |
POICE=ODATA(I,J,2)*(1.-PLAND) 498. |
| 543 |
POCEAN=(1.-PLAND)-POICE 499. |
| 544 |
ADTDL=ADTDL+(TX(I,JP1,L)-TX(I,JM1,L))*POCEAN 500. |
| 545 |
BDTDL=BDTDL+(TX(I,JP1,L)-TX(I,JM1,L))*PLAND 501. |
| 546 |
CDTDL=CDTDL+(TX(I,JP1,L)-TX(I,JM1,L))*POICE 502. |
| 547 |
350 CONTINUE 503. |
| 548 |
IF(.NOT.POLE) GO TO 360 504. |
| 549 |
ADTDL=ADTDL*2./FIM 505. |
| 550 |
BDTDL=BDTDL*2./FIM 506. |
| 551 |
CDTDL=CDTDL*2./FIM 507. |
| 552 |
360 AJ(J,35)=AJ(J,35)+ADTDL*DSIG(L) 508. |
| 553 |
BJ(J,35)=BJ(J,35)+BDTDL*DSIG(L) 509. |
| 554 |
370 CJ(J,35)=CJ(J,35)+CDTDL*DSIG(L) 510. |
| 555 |
380 CONTINUE 511. |
| 556 |
C**** 512. |
| 557 |
C**** STATIC STABILITIES: TROPOSPHERIC AND STRATOSPHERIC 513. |
| 558 |
C**** 514. |
| 559 |
C**** OLD TROPOSPHERIC STATIC STABILITY 515. |
| 560 |
ASS=0. 516. |
| 561 |
BSS=0. 517. |
| 562 |
CSS=0. 518. |
| 563 |
DO 390 I=1,IMAX 519. |
| 564 |
JR=J |
| 565 |
PLAND=FDATA(I,J,2) 521. |
| 566 |
POICE=ODATA(I,J,2)*(1.-PLAND) 522. |
| 567 |
POCEAN=(1.-PLAND)-POICE 523. |
| 568 |
SS=(T(I,J,LTM)-T(I,J,1))/(PHI(I,J,LTM)-PHI(I,J,1)+1.E-12) 524. |
| 569 |
ASS=ASS+SS*POCEAN 525. |
| 570 |
BSS=BSS+SS*PLAND 526. |
| 571 |
CSS=CSS+SS*POICE 527. |
| 572 |
C 528. |
| 573 |
390 AIJ(I,J,31)=AIJ(I,J,31)+SS 529. |
| 574 |
AJ(J,25)=AJ(J,25)+ASS 530. |
| 575 |
BJ(J,25)=BJ(J,25)+BSS 531. |
| 576 |
CJ(J,25)=CJ(J,25)+CSS 532. |
| 577 |
C**** OLD STRATOSPHERIC STATIC STABILITY 533. |
| 578 |
ASS=0. 534. |
| 579 |
BSS=0. 535. |
| 580 |
CSS=0. 536. |
| 581 |
DO 440 I=1,IMAX 537. |
| 582 |
JR=J |
| 583 |
PLAND=FDATA(I,J,2) 539. |
| 584 |
POICE=ODATA(I,J,2)*(1.-PLAND) 540. |
| 585 |
POCEAN=(1.-PLAND)-POICE 541. |
| 586 |
SS=(T(I,J,LM)-T(I,J,LTM))/((PHI(I,J,LM)-PHI(I,J,LTM))+1.E-5) 542. |
| 587 |
ASS=ASS+SS*POCEAN 543. |
| 588 |
BSS=BSS+SS*PLAND 544. |
| 589 |
CSS=CSS+SS*POICE 545. |
| 590 |
C 546. |
| 591 |
440 CONTINUE 547. |
| 592 |
AJ(J,24)=AJ(J,24)+ASS 548. |
| 593 |
BJ(J,24)=BJ(J,24)+BSS 549. |
| 594 |
CJ(J,24)=CJ(J,24)+CSS 550. |
| 595 |
C**** 551. |
| 596 |
C**** NUMBERS ACCUMULATED FOR THE RADIATION EQUILIBRIUM LAYERS 552. |
| 597 |
C**** 553. |
| 598 |
DO 470 LR=1,3 554. |
| 599 |
TRI(LR)=0. 555. |
| 600 |
DO 460 I=1,IMAX 556. |
| 601 |
460 TRI(LR)=TRI(LR)+RQT(I,J,LR) 557. |
| 602 |
470 ASJL(J,LR,1)=ASJL(J,LR,1)+(TRI(LR)-273.16*IMAX) 558. |
| 603 |
PHIRI=0. 559. |
| 604 |
DO 480 I=1,IMAX 560. |
| 605 |
480 PHIRI=PHIRI+(PHI(I,J,LM)+RGAS*.5*(TX(I,J,LM)+RQT(I,J,1)) 561. |
| 606 |
* *DLOG((SIG(LM)*P(I,J)+PTOP)/PRQ1)) 562. |
| 607 |
ASJL(J,1,2)=ASJL(J,1,2)+PHIRI 563. |
| 608 |
PHIRI=PHIRI+RGAS*.5*(TRI(1)+TRI(2))*DLNP12 564. |
| 609 |
ASJL(J,2,2)=ASJL(J,2,2)+PHIRI 565. |
| 610 |
PHIRI=PHIRI+RGAS*.5*(TRI(2)+TRI(3))*DLNP23 566. |
| 611 |
ASJL(J,3,2)=ASJL(J,3,2)+PHIRI 567. |
| 612 |
490 CONTINUE 568. |
| 613 |
C**** 569. |
| 614 |
C**** OUTSIDE J LOOP FOR NON-POLAR PRIMARY GRID ROWS 570. |
| 615 |
C**** 571. |
| 616 |
DO 550 J=2,JMM1 572. |
| 617 |
DXYPJ=DXYP(J) 573. |
| 618 |
ROSSX=DYP(J)/(DXYPJ*SINP(J)) 574. |
| 619 |
ELX=1./SINP(J) 575. |
| 620 |
PTORQX=COSP(J)*DYP(J)/DXYPJ 576. |
| 621 |
C**** NUMBERS ACCUMULATED EXCEPT AT THE POLES 577. |
| 622 |
ARIT=0. 578. |
| 623 |
BRIT=0. 579. |
| 624 |
CRIT=0. 580. |
| 625 |
AUTMAX=0. 581. |
| 626 |
BUTMAX=0. 582. |
| 627 |
CUTMAX=0. 583. |
| 628 |
ALT=0. 584. |
| 629 |
BLT=0. 585. |
| 630 |
CLT=0. 586. |
| 631 |
ARIS=0. 587. |
| 632 |
BRIS=0. 588. |
| 633 |
CRIS=0. 589. |
| 634 |
AUSMAX=0. 590. |
| 635 |
BUSMAX=0. 591. |
| 636 |
CUSMAX=0. 592. |
| 637 |
ALS=0. 593. |
| 638 |
BLS=0. 594. |
| 639 |
CLS=0. 595. |
| 640 |
IM1=IM 596. |
| 641 |
DO 520 I=1,IM 597. |
| 642 |
JR=J |
| 643 |
PLAND=FDATA(I,J,2) 599. |
| 644 |
POICE=ODATA(I,J,2)*(1.-PLAND) 600. |
| 645 |
POCEAN=(1.-PLAND)-POICE 601. |
| 646 |
SP=P(I,J) 602. |
| 647 |
C**** NUMBERS ACCUMULATED OVER THE TROPOSPHERE FOR ODD LEVELS 603. |
| 648 |
UMAX=0. 604. |
| 649 |
UL=0. 605. |
| 650 |
DO 500 L=1,LTM 606. |
| 651 |
UA(L)=U(IM1,J+1,L)+U(I,J+1,L)+U(IM1,J,L)+U(I,J,L) 607. |
| 652 |
UAMAX=ABS(UA(L)) 608. |
| 653 |
IF(UAMAX.GT.UMAX) UMAX=UAMAX 609. |
| 654 |
UL=UL+UA(L)*DSIG(L) 610. |
| 655 |
500 CONTINUE 611. |
| 656 |
DTH=T(I,J,LTM)-T(I,J,1) 612. |
| 657 |
IF(DTH.LT.0.) DTH=0. 613. |
| 658 |
DLNTH=DLOG(T(I,J,LTM)/T(I,J,1)) 613.5 |
| 659 |
IF (DLNTH.LT.0.) DLNTH=0. 613.6 |
| 660 |
DLNP=DLOG((SIG(1)*SP+PTOP)/(SIG(LTM)*SP+PTOP)) 614. |
| 661 |
DU=UA(LTM)-UA(1) 615. |
| 662 |
DV=(V(IM1,J+1,LTM)+V(I,J+1,LTM)+V(IM1,J,LTM)+V(I,J,LTM))- 616. |
| 663 |
* (V(IM1,J+1,1)+V(I,J+1,1)+V(IM1,J,1)+V(I,J,1)) 617. |
| 664 |
RI=DTH*DLNP/(DU*DU+DV*DV+1.E-6) 618. |
| 665 |
ARIT=ARIT+RI*POCEAN 619. |
| 666 |
BRIT=BRIT+RI*PLAND 620. |
| 667 |
CRIT=CRIT+RI*POICE 621. |
| 668 |
C 622. |
| 669 |
AUTMAX=AUTMAX+UMAX*POCEAN 623. |
| 670 |
BUTMAX=BUTMAX+UMAX*PLAND 624. |
| 671 |
CUTMAX=CUTMAX+UMAX*POICE 625. |
| 672 |
C 626. |
| 673 |
EL=SQRT(DLNTH/DLNP) 627. |
| 674 |
ALT=ALT+EL*POCEAN 628. |
| 675 |
BLT=BLT+EL*PLAND 629. |
| 676 |
CLT=CLT+EL*POICE 630. |
| 677 |
C 631. |
| 678 |
UMAX=0. 632. |
| 679 |
IF (LS1.GT.LM) GO TO 512 ! NEEDED FOR RUNS WITHOUT A STRATOSPHERE 633. |
| 680 |
DO 510 L=LS1,LM 634. |
| 681 |
UA(L)=U(IM1,J+1,L)+U(I,J+1,L)+U(IM1,J,L)+U(I,J,L) 635. |
| 682 |
UAMAX=ABS(UA(L)) 636. |
| 683 |
IF(UAMAX.GT.UMAX) UMAX=UAMAX 637. |
| 684 |
510 UL=UL+UA(L)*DSIG(L) 638. |
| 685 |
512 CONTINUE 639. |
| 686 |
DTH=T(I,J,LM)-T(I,J,LTM) 640. |
| 687 |
IF(DTH.LT.0.) DTH=0. 640.5 |
| 688 |
DLNTH=DLOG(T(I,J,LM)/T(I,J,LTM)) 641. |
| 689 |
IF (DLNTH.LT.0.) DLNTH=0. 641.5 |
| 690 |
DLNP=DLOG((SIG(LTM)*SP+PTOP)/(SIG(LM)*SP+PTOP)) 642. |
| 691 |
DU=UA(LM)-UA(LTM) 643. |
| 692 |
DV=(V(IM1,J+1,LM)+V(I,J+1,LM)+V(IM1,J,LM)+V(I,J,LM))- 644. |
| 693 |
* (V(IM1,J+1,LTM)+V(I,J+1,LTM)+V(IM1,J,LTM)+V(I,J,LTM)) 645. |
| 694 |
RI=DTH*DLNP/(DU*DU+DV*DV+1.E-6) 646. |
| 695 |
ARIS=ARIS+RI*POCEAN 647. |
| 696 |
BRIS=BRIS+RI*PLAND 648. |
| 697 |
CRIS=CRIS+RI*POICE 649. |
| 698 |
C 650. |
| 699 |
AUSMAX=AUSMAX+UMAX*POCEAN 651. |
| 700 |
BUSMAX=BUSMAX+UMAX*PLAND 652. |
| 701 |
CUSMAX=CUSMAX+UMAX*POICE 653. |
| 702 |
C 654. |
| 703 |
EL=SQRT(DLNTH/(DLNP)) 655. |
| 704 |
ALS=ALS+EL*POCEAN 656. |
| 705 |
BLS=BLS+EL*PLAND 657. |
| 706 |
CLS=CLS+EL*POICE 658. |
| 707 |
C 659. |
| 708 |
520 IM1=I 660. |
| 709 |
! AJ(J,27)=AJ(J,27)+ARIT 661. |
| 710 |
! BJ(J,27)=BJ(J,27)+BRIT 662. |
| 711 |
! CJ(J,27)=CJ(J,27)+CRIT 663. |
| 712 |
c AJ(J,29)=AJ(J,29)+AUTMAX*ROSSX 664. |
| 713 |
c BJ(J,29)=BJ(J,29)+BUTMAX*ROSSX 665. |
| 714 |
c CJ(J,29)=CJ(J,29)+CUTMAX*ROSSX 666. |
| 715 |
c AJ(J,38)=AJ(J,38)+ALT*ELX 667. |
| 716 |
c BJ(J,38)=BJ(J,38)+BLT*ELX 668. |
| 717 |
c CJ(J,38)=CJ(J,38)+CLT*ELX 669. |
| 718 |
c AJ(J,26)=AJ(J,26)+ARIS 670. |
| 719 |
c BJ(J,26)=BJ(J,26)+BRIS 671. |
| 720 |
c CJ(J,26)=CJ(J,26)+CRIS 672. |
| 721 |
c AJ(J,28)=AJ(J,28)+AUSMAX*ROSSX 673. |
| 722 |
c BJ(J,28)=BJ(J,28)+BUSMAX*ROSSX 674. |
| 723 |
c CJ(J,28)=CJ(J,28)+CUSMAX*ROSSX 675. |
| 724 |
c AJ(J,37)=AJ(J,37)+ALS*ELX 676. |
| 725 |
c BJ(J,37)=BJ(J,37)+BLS*ELX 677. |
| 726 |
c CJ(J,37)=CJ(J,37)+CLS*ELX 678. |
| 727 |
550 CONTINUE 679. |
| 728 |
C**** 680. |
| 729 |
C**** MEAN TROPOSPHERIC LAPSE RATES: MOIST CONVECTIVE, ACTUAL, 681. |
| 730 |
C**** DRY ADIABATIC 682. |
| 731 |
C**** 683. |
| 732 |
QLH=LHE 684. |
| 733 |
X=RGAS*LHE*LHE/(SHA*461.5) 685. |
| 734 |
DO 570 J=1,JM 686. |
| 735 |
IMAX=IM 687. |
| 736 |
IF(J.EQ.1 .OR. J.EQ.JM) IMAX=IM 688. |
| 737 |
DO 570 L=1,LTM 689. |
| 738 |
AGAMM=0. 690. |
| 739 |
BGAMM=0. 691. |
| 740 |
CGAMM=0. 692. |
| 741 |
AGAMX=0. 693. |
| 742 |
BGAMX=0. 694. |
| 743 |
CGAMX=0. 695. |
| 744 |
DO 560 I=1,IMAX 696. |
| 745 |
PLAND=FDATA(I,J,2) 697. |
| 746 |
POICE=ODATA(I,J,2)*(1.-PLAND) 698. |
| 747 |
POCEAN=(1.-PLAND)-POICE 699. |
| 748 |
PRT=(SIG(L)*P(I,J)+PTOP)*RGAS*TX(I,J,L) 700. |
| 749 |
ESEPS=QSAT(TX(I,J,L),1.,QLH) 701. |
| 750 |
GAM=(PRT+LHE*ESEPS)/(PRT+X*ESEPS/TX(I,J,L)) 702. |
| 751 |
AGAMM=AGAMM+GAM*POCEAN 703. |
| 752 |
BGAMM=BGAMM+GAM*PLAND 704. |
| 753 |
CGAMM=CGAMM+GAM*POICE 705. |
| 754 |
IF(L.EQ.1) GO TO 560 706. |
| 755 |
GAM=(TX(I,J,L-1)-TX(I,J,L))/(PHI(I,J,L)-PHI(I,J,L-1)) 707. |
| 756 |
AGAMX=AGAMX+GAM*POCEAN 708. |
| 757 |
BGAMX=BGAMX+GAM*PLAND 709. |
| 758 |
CGAMX=CGAMX+GAM*POICE 710. |
| 759 |
560 CONTINUE 711. |
| 760 |
AJ(J,65)=AJ(J,65)+DSIG(L)*AGAMM 712. |
| 761 |
BJ(J,65)=BJ(J,65)+DSIG(L)*BGAMM 713. |
| 762 |
CJ(J,65)=CJ(J,65)+DSIG(L)*CGAMM 714. |
| 763 |
IF(L.EQ.1) GO TO 570 715. |
| 764 |
AJ(J,64)=AJ(J,64)+DSIGO(L-1)*AGAMX 716. |
| 765 |
BJ(J,64)=BJ(J,64)+DSIGO(L-1)*BGAMX 717. |
| 766 |
CJ(J,64)=CJ(J,64)+DSIGO(L-1)*CGAMX 718. |
| 767 |
570 CONTINUE 719. |
| 768 |
C**** DRY ADIABATIC LAPSE RATE 720. |
| 769 |
GAMD=.0098 721. |
| 770 |
DO 600 J=2,JMM1 722. |
| 771 |
X=SINP(J)*GRAV/(COSP(J)*RGAS*2.*DLAT) 723. |
| 772 |
AGAMC=0. 724. |
| 773 |
BGAMC=0. 725. |
| 774 |
CGAMC=0. 726. |
| 775 |
DO 590 I=1,IM 727. |
| 776 |
PLAND=FDATA(I,J,2) 728. |
| 777 |
POICE=ODATA(I,J,2)*(1.-PLAND) 729. |
| 778 |
POCEAN=(1.-PLAND)-POICE 730. |
| 779 |
DT2=0. 731. |
| 780 |
T2=0. 732. |
| 781 |
DO 580 L=1,LTM 733. |
| 782 |
DT2=DT2+DSIG(L)*(TX(I,J+1,L)-TX(I,J-1,L)) 734. |
| 783 |
580 T2=T2+DSIG(L)*TX(I,J,L) 735. |
| 784 |
GAM=GAMD+X*DT2/T2 736. |
| 785 |
AGAMC=AGAMC+GAM*POCEAN 737. |
| 786 |
BGAMC=BGAMC+GAM*PLAND 738. |
| 787 |
590 CGAMC=CGAMC+GAM*POICE 739. |
| 788 |
AJ(J,66)=AJ(J,66)+AGAMC 740. |
| 789 |
BJ(J,66)=BJ(J,66)+BGAMC 741. |
| 790 |
600 CJ(J,66)=CJ(J,66)+CGAMC 742. |
| 791 |
C**** 743. |
| 792 |
C**** MOMENTUM, KINETIC ENERGY, NORTHWARD TRANSPORTS, ANGULAR MOMENTUM 744. |
| 793 |
C**** 745. |
| 794 |
DO 640 J=2,JM 746. |
| 795 |
P4I=0. 747. |
| 796 |
I=IM 748. |
| 797 |
DO 610 IP1=1,IM 749. |
| 798 |
P4=P(I,J-1)+P(IP1,J-1)+P(I,J)+P(IP1,J) 750. |
| 799 |
P4I=P4I+P4 751. |
| 800 |
AIJ(I,J,8)=AIJ(I,J,8)+P4 752. |
| 801 |
AIJ(I,J,39)=AIJ(I,J,39)+U(I,J,JET) 753. |
| 802 |
AIJ(I,J,40)=AIJ(I,J,40)+V(I,J,JET) 754. |
| 803 |
610 I=IP1 755. |
| 804 |
APJ(J,2)=APJ(J,2)+P4I 756. |
| 805 |
DO 640 L=1,LM 757. |
| 806 |
PU4I=0. 758. |
| 807 |
PV4I=0. 759. |
| 808 |
PWW4I=0. 760. |
| 809 |
PT16I=0. 761. |
| 810 |
PTV16I=0. 762. |
| 811 |
PZ16I=0. 763. |
| 812 |
PZV16I=0. 764. |
| 813 |
PQ16I=0. 765. |
| 814 |
PQV16I=0. 766. |
| 815 |
PWWV4I=0. 767. |
| 816 |
PUV4I=0. 768. |
| 817 |
I=IM 769. |
| 818 |
DO 620 IP1=1,IM 770. |
| 819 |
P4=P(I,J-1)+P(IP1,J-1)+P(I,J)+P(IP1,J) 771. |
| 820 |
PU4I=PU4I+P4*U(I,J,L) 772. |
| 821 |
PV4I=PV4I+P4*V(I,J,L) 773. |
| 822 |
PWW4I=PWW4I+P4*(U(I,J,L)*U(I,J,L)+V(I,J,L)*V(I,J,L)) 774. |
| 823 |
PWWV4I=PWWV4I+P4*(U(I,J,L)*U(I,J,L)+V(I,J,L)*V(I,J,L))*V(I,J,L) 775. |
| 824 |
PUV4I=PUV4I+P4*U(I,J,L)*V(I,J,L) 776. |
| 825 |
T4=TX(I,J-1,L)+TX(IP1,J-1,L)+TX(I,J,L)+TX(IP1,J,L) 777. |
| 826 |
PT16I=PT16I+P4*T4 778. |
| 827 |
PTV16I=PTV16I+P4*T4*V(I,J,L) 779. |
| 828 |
Z4=PHI(I,J-1,L)+PHI(IP1,J-1,L)+PHI(I,J,L)+PHI(IP1,J,L) 780. |
| 829 |
PZ16I=PZ16I+P4*Z4 781. |
| 830 |
PZV16I=PZV16I+P4*Z4*V(I,J,L) 782. |
| 831 |
Q4=Q(I,J-1,L)+Q(IP1,J-1,L)+Q(I,J,L)+Q(IP1,J,L) 783. |
| 832 |
PQ16I=PQ16I+P4*Q4 784. |
| 833 |
PQV16I=PQV16I+P4*Q4*V(I,J,L) 785. |
| 834 |
AIJ(I,J,20)=AIJ(I,J,20)+P4*(SHA*T4+Z4)*V(I,J,L)*DSIG(L)*DXV(J) 786. |
| 835 |
AIJL(I,J,L,1)=AIJL(I,J,L,1)+P4*U(I,J,L) 787. |
| 836 |
AIJL(I,J,L,2)=AIJL(I,J,L,2)+P4*V(I,J,L) 788. |
| 837 |
AIJL(I,J,L,3)=AIJL(I,J,L,3)+P4*(SHA*T4+Z4) 789. |
| 838 |
620 I=IP1 790. |
| 839 |
C C C C C C C C C C C C C C C 790.5 |
| 840 |
IF(COEK.EQ.0.) GO TO 609 790.51 |
| 841 |
FLUXT=VTH(J,L)*P4*4.*P1000 790.52 |
| 842 |
C ********** |
| 843 |
c FLUXSH=VQ(J,L)*P4*4. 790.53 |
| 844 |
c |
| 845 |
c VQ transport of Q by eddies |
| 846 |
c VQHD transport of Q by horizontal diffusion |
| 847 |
c |
| 848 |
FLUXSH=(VQ(J,L)+VQHD(J,L))*P4*4. 790.53 |
| 849 |
c |
| 850 |
C ********** |
| 851 |
PTV16I=PTV16I+FLUXT*FIM 790.54 |
| 852 |
PQV16I=PQV16I+FLUXSH*FIM 790.55 |
| 853 |
PUV4I=PUV4I+.5*(VU(J,L)+VU(J-1,L))*P4 790.56 |
| 854 |
609 CONTINUE 790.57 |
| 855 |
AJL(J,L,4)=AJL(J,L,4)+PU4I 791. |
| 856 |
AJL(J,L,5)=AJL(J,L,5)+PV4I 792. |
| 857 |
AJL(J,L,14)=AJL(J,L,14)+VV(J,L) 793. |
| 858 |
AJL(J,L,15)=AJL(J,L,15)+PWW4I 794. |
| 859 |
AJL(J,L,20)=AJL(J,L,20)+PT16I*PV4I/P4I 795. |
| 860 |
AJL(J,L,21)=AJL(J,L,21)+PTV16I 796. |
| 861 |
AJL(J,L,22)=AJL(J,L,22)+PZ16I*PV4I/P4I 797. |
| 862 |
AJL(J,L,23)=AJL(J,L,23)+PZV16I 798. |
| 863 |
AJL(J,L,24)=AJL(J,L,24)+PQ16I*PV4I/P4I 799. |
| 864 |
AJL(J,L,25)=AJL(J,L,25)+PQV16I 800. |
| 865 |
c AJL(J,L,26) is used to calculate change of KIN. EN. |
| 866 |
c due to eddy transport |
| 867 |
c AJL(J,L,26)=AJL(J,L,26)+PWW4I*PV4I/P4I 801. |
| 868 |
c |
| 869 |
AJL(J,L,27)=AJL(J,L,27)+PWWV4I 802. |
| 870 |
AJL(J,L,48)=AJL(J,L,48)+PU4I*PV4I/P4I 803. |
| 871 |
AJL(J,L,49)=AJL(J,L,49)+PUV4I 804. |
| 872 |
AJL(J,L,55)=AJL(J,L,55)+VQHD(J,L)*P4*4.*FIM |
| 873 |
640 CONTINUE 805. |
| 874 |
C**** 806. |
| 875 |
DO 655 J=1,JM 807. |
| 876 |
IMAX=IM 808. |
| 877 |
IF (J.EQ.1 .OR. J.EQ.JM) IMAX=1 809. |
| 878 |
SPI=0. 810. |
| 879 |
DO 645 I=1,IMAX 811. |
| 880 |
SPI=SPI+P(I,J) 812. |
| 881 |
645 CONTINUE 813. |
| 882 |
C**** 814. |
| 883 |
C**** EVEN LEVEL GEOPOTENTIALS, VERTICAL WINDS AND VERTICAL TRANSPORTS 815. |
| 884 |
C**** 816. |
| 885 |
DO 655 L=1,LMM1 817. |
| 886 |
SDI=0. 818. |
| 887 |
WI=0. 819. |
| 888 |
PZI=0. 820. |
| 889 |
SDZI=0. 821. |
| 890 |
PDSE2I=0. 822. |
| 891 |
SDDS2I=0. 823. |
| 892 |
PQ2I=0. 824. |
| 893 |
SDQ2I=0. 825. |
| 894 |
DO 650 I=1,IMAX 826. |
| 895 |
JR=J |
| 896 |
PLAND=FDATA(I,J,2) 828. |
| 897 |
SDI=SDI+SD(I,J,L) 829. |
| 898 |
PE=SIGE(L+1)*P(I,J)+PTOP 830. |
| 899 |
PKE=EXPBYK(PE) 831. |
| 900 |
THETA=THBAR(T(I,J,L+1),T(I,J,L)) 832. |
| 901 |
W(I,J,L)=SD(I,J,L)*THETA*PKE/PE 833. |
| 902 |
PHIE(I,J,L)=PHI(I,J,L)+SHA*THETA*(PK(I,J,L)-PKE) 834. |
| 903 |
WI=WI+W(I,J,L) 835. |
| 904 |
PZI=PZI+PHIE(I,J,L)*P(I,J) 836. |
| 905 |
SDZI=SDZI+PHIE(I,J,L)*SD(I,J,L) 837. |
| 906 |
PDSE2I=PDSE2I+(SHA*(TX(I,J,L)+TX(I,J,L+1))+2.*PHIE(I,J,L))*P(I,J) 838. |
| 907 |
SDDS2I=SDDS2I+(SHA*(TX(I,J,L)+TX(I,J,L+1))+2.*PHIE(I,J,L))* 839. |
| 908 |
* SD(I,J,L) 840. |
| 909 |
PQ2I=PQ2I+(Q(I,J,L)*Q(I,J,L+1)/(Q(I,J,L)+Q(I,J,L+1)+1.E-20))* 841. |
| 910 |
* P(I,J) 842. |
| 911 |
SDQ2I=SDQ2I+(Q(I,J,L)*Q(I,J,L+1)/(Q(I,J,L)+Q(I,J,L+1)+ 843. |
| 912 |
* 1.E-20))*SD(I,J,L) 844. |
| 913 |
650 CONTINUE 845. |
| 914 |
C C C C C C C C C C C C C C C 845.5 |
| 915 |
IF(COEK.EQ.0.) GO TO 289 845.51 |
| 916 |
FLUXT=WTH(J,L)*PA(J) *DXYP(J)*SHA*2.*P1000 845.52 |
| 917 |
FLUXS=WQ(J,L)*PA(J)*DXYP(J)*.5 845.53 |
| 918 |
SDDS2I=SDDS2I+FLUXT*CMAX 845.54 |
| 919 |
SDQ2I=SDQ2I+FLUXS*CMAX 845.55 |
| 920 |
289 CONTINUE 845.56 |
| 921 |
SDMEAN(J,L)=SDI*BYIM 846. |
| 922 |
AJL(J,L,6)=AJL(J,L,6)+WI 847. |
| 923 |
AJL(J,L,34)=AJL(J,L,34)+(SDZI-PZI*SDI/SPI) 848. |
| 924 |
AJL(J,L,30)=AJL(J,L,30)+PDSE2I*SDI/SPI 849. |
| 925 |
AJL(J,L,31)=AJL(J,L,31)+SDDS2I 850. |
| 926 |
AJL(J,L,32)=AJL(J,L,32)+PQ2I*SDI/SPI 851. |
| 927 |
AJL(J,L,33)=AJL(J,L,33)+SDQ2I 852. |
| 928 |
655 CONTINUE 853. |
| 929 |
C**** 854. |
| 930 |
C**** VERTICAL TRANSPORT OF KINETIC ENERGY AND ANGULAR MOMENTUM 855. |
| 931 |
C**** 856. |
| 932 |
C**** FILL IN AND/OR DOUBLE SD AND SDMEAN AT THE POLES 857. |
| 933 |
DO 657 L=1,LMM1 858. |
| 934 |
SDMEAN(1,L)=2.*FIM*SDMEAN(1,L) 859. |
| 935 |
SDMEAN(JM,L)=2.*FIM*SDMEAN(JM,L) 860. |
| 936 |
SDSP=2.*SD(1,1,L) 861. |
| 937 |
SDNP=2.*SD(1,JM,L) 862. |
| 938 |
DO 657 I=1,IM 863. |
| 939 |
SD(I,1,L)=SDSP 864. |
| 940 |
657 SD(I,JM,L)=SDNP 865. |
| 941 |
DO 670 J=2,JM 866. |
| 942 |
AMA=RADIUS*OMEGA*COSV(J) 867. |
| 943 |
DO 670 L=1,LMM1 868. |
| 944 |
C TKEM=0. 869. |
| 945 |
TKET=0. 870. |
| 946 |
UM=0. 871. |
| 947 |
UT=0. 872. |
| 948 |
I=IM 873. |
| 949 |
DO 660 IP1=1,IM 874. |
| 950 |
SDU=SD(I,J,L)+SD(IP1,J,L)+SD(I,J-1,L)+SD(IP1,J-1,L) 875. |
| 951 |
UE=U(I,J,L)+U(I,J,L+1) 876. |
| 952 |
TKE=UE*UE+(V(I,J,L)+V(I,J,L+1))*(V(I,J,L)+V(I,J,L+1)) 877. |
| 953 |
C TKEM=TKEM+TKE 878. |
| 954 |
TKET=TKET+TKE*SDU 879. |
| 955 |
UM=UM+UE 880. |
| 956 |
UT=UT+UE*SDU 881. |
| 957 |
660 I=IP1 882. |
| 958 |
AJL(J,L,35)=AJL(J,L,35)+TKET 883. |
| 959 |
AJL(J,L,36)=AJL(J,L,36)+8.*WU(J,L) 884. |
| 960 |
AJL(J,L,37)=AJL(J,L,37)+(UT+4*AMA*FIM*(SDMEAN(J,L)+SDMEAN(J-1,L))) 885. |
| 961 |
670 CONTINUE 886. |
| 962 |
C**** 887. |
| 963 |
C**** AVAILABLE POTENTIAL ENERGY 888. |
| 964 |
C**** 889. |
| 965 |
C**** SET UP FOR CALCULATION 890. |
| 966 |
DO 710 L=1,LM 891. |
| 967 |
710 GMEAN(L)=0. 892. |
| 968 |
DO 740 J=1,JM 893. |
| 969 |
IMAX=IM 894. |
| 970 |
IF (J.EQ.1 .OR. J.EQ.JM) IMAX=1 895. |
| 971 |
DO 720 I=1,IMAX 896. |
| 972 |
720 SQRTP(I)=SQRT(P(I,J)) 897. |
| 973 |
C**** GMEAN CALCULATED FOR EACH LAYER, THJL, THSQJL ARRAYS FILLED 898. |
| 974 |
DO 730 L=1,LM 899. |
| 975 |
LDN=LDNA(L) 900. |
| 976 |
LUP=LUPA(L) 901. |
| 977 |
THJL(J,L)=0. 902. |
| 978 |
THSQJL(J,L)=0. 903. |
| 979 |
DO 730 I=1,IMAX 904. |
| 980 |
THJL(J,L)=THJL(J,L)+T(I,J,L)*SQRTP(I) 905. |
| 981 |
THSQJL(J,L)=THSQJL(J,L)+T(I,J,L)*T(I,J,L)*P(I,J) 906. |
| 982 |
730 GMEAN(L)=GMEAN(L)+(SIG(L)*P(I,J)+PTOP)*(T(I,J,LUP)-T(I,J,LDN))* 907. |
| 983 |
* DXYP(J)/(P(I,J)*PK(I,J,L)) 908. |
| 984 |
740 CONTINUE 909. |
| 985 |
C**** CALCULATE APE 910. |
| 986 |
DO 760 L=1,LM 911. |
| 987 |
LP1=LUPA(L) 912. |
| 988 |
LM1=LDNA(L) 913. |
| 989 |
THJL(1,L)=THJL(1,L)*FIM 914. |
| 990 |
THJL(JM,L)=THJL(JM,L)*FIM 915. |
| 991 |
THSQJL(1,L)=THSQJL(1,L)*FIM 916. |
| 992 |
THSQJL(JM,L)=THSQJL(JM,L)*FIM 917. |
| 993 |
THGM=0. 918. |
| 994 |
DO 750 J=1,JM 919. |
| 995 |
750 THGM=THGM+THJL(J,L)*DXYP(J) 920. |
| 996 |
THGM=THGM/AREAG 921. |
| 997 |
GMEANL=GMEAN(L)/((SIG(LM1)-SIG(LP1))*AREAG) 922. |
| 998 |
DO 760 J=1,JM 923. |
| 999 |
760 AJL(J,L,16)=AJL(J,L,16)+(THSQJL(J,L)-2.*THJL(J,L)*THGM+THGM*THGM* 924. |
| 1000 |
* FIM)/GMEANL 925. |
| 1001 |
C**** 926. |
| 1002 |
C**** OMEGA'*ALPHA' ; BAROCLINIC EKE GENERATION 927. |
| 1003 |
C**** 928. |
| 1004 |
c IF(JM.NE.24.OR.IM.EQ.1) GO TO 850 978. |
| 1005 |
850 CONTINUE 1022. |
| 1006 |
C**** 1023. |
| 1007 |
C**** ELIASSEN PALM FLUX 1024. |
| 1008 |
C**** 1025. |
| 1009 |
C**** NORTHWARD TRANSPORT 1026. |
| 1010 |
DO 868 J=2,JM 1027. |
| 1011 |
BYDXYV=1./DXYV(J) 1028. |
| 1012 |
I=IM 1029. |
| 1013 |
DO 862 IP1=1,IM 1030. |
| 1014 |
PDA(I)=.5*((P(I,J)+P(IP1,J))*DXYS(J)+(P(I,J-1)+P(IP1,J-1))* 1031. |
| 1015 |
* DXYN(J-1)) 1032. |
| 1016 |
PSEC(I)=PDA(I)*BYDXYV 1033. |
| 1017 |
862 I=IP1 1034. |
| 1018 |
DO 868 L=1,LM 1035. |
| 1019 |
DUDP=0. 1036. |
| 1020 |
DTHDP=0. 1037. |
| 1021 |
UMN=0. 1038. |
| 1022 |
THMN=0. 1039. |
| 1023 |
LDN=LDNA(L) 1040. |
| 1024 |
LUP=LUPA(L) 1041. |
| 1025 |
I=IM 1042. |
| 1026 |
DO 864 IP1=1,IM 1043. |
| 1027 |
DUDP=DUDP+U(I,J,LUP)-U(I,J,LDN) 1044. |
| 1028 |
DTHDP=DTHDP+T(I,J,LUP)+T(I,J-1,LUP)-T(I,J,LDN)-T(I,J-1,LDN) 1045. |
| 1029 |
UMN=UMN+U(I,J,L) 1046. |
| 1030 |
THMN=THMN+T(I,J,L)+T(I,J-1,L) 1047. |
| 1031 |
THSEC(I)=T(I,J,L)+T(IP1,J,L)+T(I,J-1,L)+T(IP1,J-1,L) 1048. |
| 1032 |
864 I=IP1 1049. |
| 1033 |
UMN=UMN*BYIM 1050. |
| 1034 |
THMN=2.*THMN/FIM 1051. |
| 1035 |
FPHI=0. 1052. |
| 1036 |
SMALL=.0002*FIM*T(1,J,L) 1053. |
| 1037 |
IF (DTHDP.LT.SMALL) DTHDP=SMALL 1055. |
| 1038 |
DO 866 I=1,IM 1056. |
| 1039 |
866 FPHI=FPHI+PSEC(I)*(-VU(J,L)+(VTH(J,L)+VTH(J+1,L))*P1000 1057. |
| 1040 |
* *DUDP/DTHDP) 1058. |
| 1041 |
868 AJL(J,L,41)=AJL(J,L,41)+FPHI 1059. |
| 1042 |
C**** VERTICAL TRANSPORT 1060. |
| 1043 |
DO 878 J=2,JMM1 1061. |
| 1044 |
DO 878 L=1,LMM1 1062. |
| 1045 |
THMN=0. 1063. |
| 1046 |
SDMN=0. 1064. |
| 1047 |
DTHDP=0. 1065. |
| 1048 |
DO 872 I=1,IM 1066. |
| 1049 |
DTHDP=DTHDP+T(I,J,L+1)-T(I,J,L) 1067. |
| 1050 |
THMN=THMN+T(I,J,L+1)+T(I,J,L) 1068. |
| 1051 |
872 SDMN=SDMN+SD(I,J,L) 1069. |
| 1052 |
SMALL=.0001*FIM*T(1,J,L+1) 1070. |
| 1053 |
IF (DTHDP.LT.SMALL) DTHDP=SMALL 1072. |
| 1054 |
THMN=THMN/FIM 1073. |
| 1055 |
SDMN=SDMN/FIM 1074. |
| 1056 |
DUDX=0. 1075. |
| 1057 |
PVTHP=0. 1076. |
| 1058 |
SDPU=0. 1077. |
| 1059 |
IM1=IM 1078. |
| 1060 |
DO 874 I=1,IM 1079. |
| 1061 |
DUDX=DUDX+DXV(J+1)*(U(I,J+1,L)+U(I,J+1,L+1))-DXV(J)* 1080. |
| 1062 |
* (U(I,J,L)+U(I,J,L+1)) 1081. |
| 1063 |
UPE=U(IM1,J,L)+U(IM1,J+1,L)+U(I,J,L)+U(I,J+1,L)+ 1082. |
| 1064 |
* U(IM1,J,L+1)+U(IM1,J+1,L+1)+U(I,J,L+1)+U(I,J+1,L+1) 1083. |
| 1065 |
VPE=V(IM1,J,L)+V(IM1,J+1,L)+V(I,J,L)+V(I,J+1,L)+ 1084. |
| 1066 |
* V(IM1,J,L+1)+V(IM1,J+1,L+1)+V(I,J,L+1)+V(I,J+1,L+1) 1085. |
| 1067 |
PVTHP=PVTHP+P(I,J)*8.*(VTH(J,L)+VTH(J+1,L))*P1000 1086. |
| 1068 |
SDPU=SDPU+8.*WU(J,L) 1087. |
| 1069 |
874 IM1=I 1088. |
| 1070 |
AJL(J,L,44)=AJL(J,L,44)+(.5*FIM*F(J)-.25*DUDX)*DSIGO(L)*PVTHP 1089. |
| 1071 |
* /DTHDP + SDPU 1090. |
| 1072 |
878 CONTINUE 1091. |
| 1073 |
C**** 1092. |
| 1074 |
C**** POTENTIAL VORTICITY 1093. |
| 1075 |
C**** 1094. |
| 1076 |
C**** 1133. |
| 1077 |
C**** LAGRANGIAN MEAN STEAM FUNCTION 1134. |
| 1078 |
C**** 1135. |
| 1079 |
C**** ACCUMULATE TIME USED IN DIAGA 1169. |
| 1080 |
CALL CLOCKS (MEND) 1170. |
| 1081 |
MINC=MBEGIN-MEND 1171. |
| 1082 |
MDIAG=MDIAG+MINC 1172. |
| 1083 |
MDYN=MDYN-MINC 1173. |
| 1084 |
C 1174. |
| 1085 |
RETURN 1175. |
| 1086 |
997 FORMAT (' DIAGNOSTICS ACCUMULATED ',12I4,15X,2I7) 1176. |
| 1087 |
999 FORMAT (' DTHETA/DP IS TOO SMALL AT J=',I4,' L=',I4,2F15.6) 1177. |
| 1088 |
END 1178. |
| 1089 |
SUBROUTINE DIAG1(NOCLM) 1501. |
| 1090 |
C**** 1502. |
| 1091 |
C**** THIS SUBROUTINE PRODUCES AREA WEIGHTED STATISTICS OF 1503. |
| 1092 |
C**** 1504. |
| 1093 |
C K N 1505. |
| 1094 |
C**** 1506. |
| 1095 |
C***1 1 SOLAR RADIATION INCIDENT ON PLANET (W/M**2) 1507. |
| 1096 |
C**** 1508. |
| 1097 |
C**1A 2/1 PLANETARY ALBEDO (10**-2) 1509. |
| 1098 |
C**1B 72/1 PLANETARY ALBEDO VISUAL (10**-2) 1510. |
| 1099 |
C**1C 73/1 PLANETARY ALBEDO NEAR IR (10**-2) 1511. |
| 1100 |
C**1D 6/5 GROUND ALBEDO (10**-2) 1512. |
| 1101 |
C**1E 74/1 GROUND ALBEDO VISUAL (10**-2) 1513. |
| 1102 |
C**1F 75/1 GROUND ALBEDO NEAR IR (10**-2) 1514. |
| 1103 |
C**1G 76/1 ATMOSPHERIC ALBEDO VISUAL (10**-2) 1515. |
| 1104 |
C**1H 77/1 ATMOSPHERIC ALBEDO NEAR IR (10**-2) 1516. |
| 1105 |
C**1I 78/1 ATMOSPHERIC ABSORPTION VISUAL (10**-2) 1517. |
| 1106 |
C**1J 79/1 ATMOSPHERIC ABSORPTION NEAR IR (10**-2) 1518. |
| 1107 |
C**** 1519. |
| 1108 |
C***2 2 SOLAR RADIATION ABSORBED BY PLANET (W/M**2) 1520. |
| 1109 |
C***3 3 SOLAR RADIATION ABSORBED BELOW PTOP (W/M**2) 1521. |
| 1110 |
C***4 4 SOLAR RADIATION ABSORBED BY ATMOSPHERE (W/M**2) 1522. |
| 1111 |
C***5 5 SOLAR RADIATION INCIDENT ON GROUND (W/M**2) 1523. |
| 1112 |
C***6 6 SOLAR RADIATION ABSORBED BY GROUND (W/M**2) 1524. |
| 1113 |
C***7 7 THERMAL RADIATION EMITTED BY PLANET (W/M**2) 1525. |
| 1114 |
C***8 8 THERMAL RADIATION AT PTOP (W/M**2) 1526. |
| 1115 |
C***9 9 THERMAL RADIATION EMITTED BY GROUND (W/M**2) 1527. |
| 1116 |
C**10 67 THERMAL RADIATION INCIDENT ON GROUND (W/M**2) 1528. |
| 1117 |
C**** 1529. |
| 1118 |
C**11 55 BRIGHTNESS TEMPERATURE THROUGH WINDOW REGION (K-273.16) 1530. |
| 1119 |
C**** 10 NET RADIATION ABSORBED BY PLANET (W/M**2) 1531. |
| 1120 |
C**** 11 NET RADIATION ABSORBED BELOW PTOP (W/M**2) 1532. |
| 1121 |
C**** 12 NET RADIATION ABSORBED BY GROUND (W/M**2) 1533. |
| 1122 |
C**** 13 SENSIBLE HEAT FLUX INTO THE GROUND (W/M**2) 1534. |
| 1123 |
C**** 14 EVAPORATION HEAT FLUX INTO THE GROUND (W/M**2) 1535. |
| 1124 |
C**** 39 PRECIPITATION HEAT FLUX INTO THE GROUND (W/M**2) 1536. |
| 1125 |
C**** 40 HEAT RUNOFF FROM FIRST GROUND LAYER (W/M**2) 1537. |
| 1126 |
C**** 44 NET HEATING AT Z0 (W/M**2) 1538. |
| 1127 |
C**** 42 CONDUCTION AT -Z1 (W/M**2) 1539. |
| 1128 |
C**** 1540. |
| 1129 |
C**21 41 HEAT WATER DUFFUSION AT -Z1 (W/M**2) 1541. |
| 1130 |
C**** 16 NET HEATING AT -Z1 (W/M**2) 1542. |
| 1131 |
C**** 43 HEAT RUNOFF FROM SECOND GROUND LAYER (W/M**2) 1543. |
| 1132 |
C**** 15 CONDUCTION AT -Z1-Z2 (W/M**2) 1544. |
| 1133 |
C**** 56 NET HEATING AT -Z1-Z2 (W/M**2) 1545. |
| 1134 |
C**** 18 MEAN TEMPERATURE OF FIRST GROUND LAYER (.1 K-273.16) 1546. |
| 1135 |
C**** 17 MEAN TEMPERATURE OF SECOND GROUND LAYER (.1 K-273.16) 1547. |
| 1136 |
C**** 23 SURFACE AIR TEMPERATURE (.1 K-273.16) 1548. |
| 1137 |
C**** 22 FIRST LAYER AIR TEMPERATURE (.1 K-273.16) 1549. |
| 1138 |
C**** 21 COMPOSITE AIR TEMPERATURE (.1 K-273.16) 1550. |
| 1139 |
C**** 1551. |
| 1140 |
C**31 35 STRATO TEMPERATURE CHANGE PER DEGREE LATITUDE (10**-2 K) 1552. |
| 1141 |
C**** 36 TROPO TEMPERATURE CHANGE PER DEGREE LATITUDE (10**-2 K) 1553. |
| 1142 |
C**** 24 STRATOSPHERIC STATIC STABILITY (10**-3 K/M) 1554. |
| 1143 |
C**** 25 TROPOSPHERIC STATIC STABILITY (10**-3 K/M) 1555. |
| 1144 |
C**** 26 STRATOSPHERIC RICHARDSON NUMBER (1) 1556. |
| 1145 |
C**** 27 TROPOSPHERIC RICHARDSON NUMBER (1) 1557. |
| 1146 |
C**** 28 STRATOSPHERIC ROSSBY NUMBER (1) 1558. |
| 1147 |
C**** 29 TROPOSPHERIC ROSSBY NUMBER (1) 1559. |
| 1148 |
C**** 37 L IN THE STRATOSPHERE (10**5 M) 1560. |
| 1149 |
C**** 38 L IN THE TROPOSPHERE (10**5 M) 1561. |
| 1150 |
C**** 1562. |
| 1151 |
C**41 64 GAM (10**-3 K/M) 1563. |
| 1152 |
C**** 65 GAMM (10**-3 K/M) 1564. |
| 1153 |
C**** 66 GAMC (10**-3 K/M) 1565. |
| 1154 |
C**** 57 INTEGRATED SUPER-SATURATION CLOUD COVER (10**-2) 1566. |
| 1155 |
C**** 58 INTEGRATED MOIST CONVECTIVE CLOUD COVER (10**-2) 1567. |
| 1156 |
C**** 59 INTEGRATED TOTAL CLOUD COVER (10**-2) 1568. |
| 1157 |
C**** 60 MOIST CONVECTIVE CLOUD DEPTH (100 N) 1569. |
| 1158 |
C**** 61 SUPER SATURATION PRECIPITATION (KG/M**2/86400 S) 1570. |
| 1159 |
C**** 62 MOIST CONVECTIVE PRECIPITATION (KG/M**2/86400 S) 1571. |
| 1160 |
C**** 20 PRECIPITATION (KG/M**2/86400 S) 1572. |
| 1161 |
C**** 1573. |
| 1162 |
C**51 19 EVAPORATION (KG/M**2/86400 S) 1574. |
| 1163 |
C**** 63 WATER CONTENT OF ATMOSPHERE (KG/M**2) 1575. |
| 1164 |
C**** 45 WATER DIFFUSION AT -Z1 (KG/M**2/86400 S) 1576. |
| 1165 |
C**** 54 WATER RUNOFF FOR FIRST GROUND LAYER (KG/M**2/86400 S) 1577. |
| 1166 |
C**** 46 NET WATER INTO THE FIRST GROUND LAYER (KG/M**2/86400 S) 1578. |
| 1167 |
C**** 47 WATER RUNOFF FOR SECOND GROUND LAYER (KG/M**2/86400 S) 1579. |
| 1168 |
C**** 48 NET WATER INTO THE SECOND GROUND LAYER (KG/M**2/86400 S) 1580. |
| 1169 |
C**** 49 WATER CONTAINED IN FIRST GROUND LAYER (KG/M**2) 1581. |
| 1170 |
C**** 50 ICE CONTAINED IN FIRST GROUND LAYER (KG/M**2) 1582. |
| 1171 |
C**** 51 WATER CONTAINED IN SECOND GROUND LAYER (KG/M**2) 1583. |
| 1172 |
C**** 1584. |
| 1173 |
C**61 52 ICE CONTAINED IN SECOND GROUND LAYER (KG/M**2) 1585. |
| 1174 |
C**** 53 SNOW DEPTH (KG/M**2) 1586. |
| 1175 |
C**** 31 SNOW COVER (10**-2) 1587. |
| 1176 |
C**** 30 OCEAN ICE COVER (10**-2) 1588. |
| 1177 |
C**** 1589. |
| 1178 |
#include "BD2G04.COM" 1590. |
| 1179 |
LOGICAL NOCLM |
| 1180 |
COMMON U,V,T,P,Q 1591. |
| 1181 |
DIMENSION ABCJ(JM0,80,3) 1594. |
| 1182 |
EQUIVALENCE (AJ(1,1),ABCJ(1,1,1)) 1595. |
| 1183 |
C **** CLEAR SKY |
| 1184 |
common/clrsk/CLEAR(JM0),NCLR(JM0),AJCLR(JM0,12),BJCLR(JM0,12), |
| 1185 |
* CJCLR(JM0,12) |
| 1186 |
integer CLEAR |
| 1187 |
C AJCLR |
| 1188 |
C 1 SW INC AT P0 RD (AJ(1)) |
| 1189 |
C 2 SW ABS BELOW P0 RD (AJ(2)) |
| 1190 |
C 3 SW ABS BELOW P1 RD (AJ(3)) |
| 1191 |
C 4 SW ABS AT Z0 RD (AJ(6)) |
| 1192 |
C 5 SW INC AT Z0 RD (AJ(5)) |
| 1193 |
C 6 LW INC AT Z0 RD (AJ(67)) |
| 1194 |
C 7 NET LW AT Z0 SF (AJ(9)) |
| 1195 |
C 8 NET LW AT P0 RD (AJ(7)) |
| 1196 |
C 9 NET LW AT P1 RD (AJ(8)) |
| 1197 |
C 10 NET RAD AT P0 DG (AJ(10)) |
| 1198 |
C 11 NET RAD AT P1 DG (AJ(11)) |
| 1199 |
C 12 NET RAD AT Z0 DG (AJ(12)) |
| 1200 |
dimension ABCJCL(JM0,12,3) |
| 1201 |
EQUIVALENCE (AJCLR(1,1),ABCJCL(1,1,1)) |
| 1202 |
C **** CLEAR SKY |
| 1203 |
C |
| 1204 |
DIMENSION JLAT(46),SAREA(46),SPOCEN(46),SPOICE(46),SPLAND(46), 1596. |
| 1205 |
* S1(46),MLAT(46),FLAT(46),MHEM(2),FHEM(2),WTA(4),WTB(4),WTC(4), 1597. |
| 1206 |
* INDEX(70),INNUM(10),INDEN(10),IA(72),SCALE(72) 1598. |
| 1207 |
C**** 1599. |
| 1208 |
CHARACTER*16 TERAIN(5)/' (GLOBAL)',' (LAND)',' (OCEAN)',1600. |
| 1209 |
* ' (OCEAN ICE)',' (REGIONS)'/ 1601. |
| 1210 |
CHARACTER*16 TITLE(72),TITLE1(36),TITLE2(36),TITLEA(10) 1602. |
| 1211 |
EQUIVALENCE (TITLE(1),TITLE1(1)),(TITLE(37),TITLE2(1)) 1603. |
| 1212 |
DATA TITLE1/ 1604. |
| 1213 |
1 ' INC SW(WT/M**2)', '0SW ABS BELOW P0', ' SW ABS BELOW P1', 1605. |
| 1214 |
4 ' SW ABS BY ATMOS', ' SW INC ON Z0 ', ' SW ABS AT Z0 ', 1606. |
| 1215 |
7 '0NET LW AT P0 ', ' NET LW AT P1 ', ' NET LW AT Z0 ', 1607. |
| 1216 |
O '0NET RAD AT P0 ', ' NET RAD AT P1 ', ' NET RAD AT Z0 ', 1608. |
| 1217 |
3 '0SENSBL HEAT FLX', ' EVAPOR HEAT FLX', ' CONDC AT -Z1-Z2', 1609. |
| 1218 |
6 ' NET HEAT AT -Z1', ' TG2 (.1 C) ', '0TG1 (.1 C) ', 1610. |
| 1219 |
9 ' EVAPOR (MM/DAY)', ' PRECIP (MM/DAY)', ' T AIR (.1 C) ', 1611. |
| 1220 |
2 ' T1 (.1 C) ', '0T SURF (.1 C) ', 1612. |
| 1221 |
! * '1STAT STB(STRAT)',' STAT STB(TROPO)','0RICH NUM(STRAT)', 1613. |
| 1222 |
! * ' RICH NUM(TROPO)',' ROSS NUM(STRAT)',' ROSS NUM(TROPO)', 1614. |
| 1223 |
* '1STAT STB(STRAT)',' STAT STB(TROPO)','0TH2M (DEGREE)', 1613. |
| 1224 |
* ' RICH NUM(SURF )',' ROSS NUM(STRAT)',' ROSS NUM(TROPO)', 1614. |
| 1225 |
* ' OCEAN ICE COVER','0SNOW COVER',' TAU L ',' TAU F', 1615. |
| 1226 |
4 ' SURF. FRICTION ', '0DT/DLAT(STRAT) ', ' DT/DLAT(TROPO) '/ 1616. |
| 1227 |
DATA TITLE2/ 1617. |
| 1228 |
7 ' L(STRAT)(10**5)', ' L(TROP) (10**5)', ' PRECIP HEAT FLX', 1618. |
| 1229 |
O ' HEAT RUNOFF G1 ', ' HT WTR DIFS -Z1', '0CONDUCTN AT -Z1', 1619. |
| 1230 |
3 '0HEAT RUNOFF G2 ', ' NET HEAT AT Z0 ', '0WTR DIFS AT -Z1', 1620. |
| 1231 |
6 ' NET WTR INTO G1', '0WATER RUNOFF G2', ' NET WTR INTO G2', 1621. |
| 1232 |
9 '0WATER IN G1 ', ' ICE IN G1 ', ' WATER IN G2 ', 1622. |
| 1233 |
2 ' ICE IN G2 ', ' SNOW DEPTH ', ' WATER RUNOFF G1', 1623. |
| 1234 |
5 ' LW WINDOW BTEMP', ' NET HEAT -Z1-Z2', '0TOT SUP SAT CLD', 1624. |
| 1235 |
8 ' TOT MST CNV CLD', ' TOTAL CLD COVER', ' MC CLD DPTH(MB)', 1625. |
| 1236 |
* '0SS PRECIP(MM/D)', ' MC PRECIP(MM/D)', ' H2O OF ATM (MM)', 1626. |
| 1237 |
4 '0GAM(K/KM) ', ' GAMM(K/KM) ', ' GAMC(K/KM) ', 1627. |
| 1238 |
* ' LW INC ON Z0',5*' '/ 1628. |
| 1239 |
DATA TITLEA/' PLANETARY ALBDO',' PLAN ALB VISUAL', 1629. |
| 1240 |
* ' PLAN ALB NEARIR', ' SURFACE G ALBDO', ' SURF ALB VISUAL', 1630. |
| 1241 |
* ' SURF ALB NEARIR', '0ATMO ALB VISUAL', ' ATMO ALB NEARIR', 1631. |
| 1242 |
* ' ATMO ABS VISUAL', ' ATMO ABS NEARIR'/ 1632. |
| 1243 |
CHARACTER*16 TITCLR(12) |
| 1244 |
data TITCLR/ |
| 1245 |
1 ' INC SW(WT/M**2)', '0SW ABS BELOW P0', ' SW ABS BELOW P1', |
| 1246 |
4 ' SW ABS AT Z0 ', ' SW INC ON Z0 ', ' LW INC ON Z0', |
| 1247 |
7 '0NET LW AT Z0 ', ' NET LW AT P0 ', ' NET LW AT P1 ', |
| 1248 |
* '0NET RAD AT P0 ', ' NET RAD AT P1 ', ' NET RAD AT Z0 '/ |
| 1249 |
C**** 1633. |
| 1250 |
DATA WTA/1.,0.,1.,0./, WTB/1.,1.,0.,0./, WTC/1.,0.,0.,1./ 1634. |
| 1251 |
DATA INDEX/1,2,3,4,5,6,7,8,9,67, 55,10,11,12,13,14,39,40,44,42, 1635. |
| 1252 |
* 41,16,43,15,56,18,17,23,22,21, 35,36,24,25,26,27,28,29,37,38, 1636. |
| 1253 |
* 64,65,66,57,58,59,60,61,62,20, 19,63,45,54,46,47,48,49,50,51, 1637. |
| 1254 |
* 52,53,31,30,32,33,34,3*0/ 1638. |
| 1255 |
DATA INNUM/2,72,73,6,74,75,76,77,78,79/, INDEN/3*1,5,6*1/ 1639. |
| 1256 |
C**** IA: 1 CONDENSATION, 2 RADIATION, 3 SURFACE, 4 DIAGA, 0 UNUSED 1640. |
| 1257 |
DATA IA/6*2, 2,2,1,2,2,1, 6*1, 1,1,4,4,3,4, 5*4,1, 6*4, 1641. |
| 1258 |
c * 4,4,4*1, 6*1, 6*1, 2,1,4*2, 1,1,4*4, 2,5*0/ 1642. |
| 1259 |
* 1,1,4*1, 6*1, 6*1, 2,1,4*2, 1,1,4*4, 2,5*0/ |
| 1260 |
DATA SCALE/6*1., 6*1., 4*1.,2*10., 2*1.,4*10., 6*100., 1643. |
| 1261 |
* 6*100., 6*1., 6*1., 6*1., 2*1.,3*100.,1., 6*1., 6*1./ 1644. |
| 1262 |
c DATA IFIRST/1/ 1645. |
| 1263 |
DATA INQTAB/1,51,3,4,5,6,7,8,48,49, |
| 1264 |
&14,15,16,21,23,25,26,88,32,33, |
| 1265 |
&34,36,39,77,78,79,11,24,89,52, |
| 1266 |
&92,102,12/ |
| 1267 |
c &101,99,30/ |
| 1268 |
DATA IFIRST/1/ |
| 1269 |
c print *,' DIAG1',' IFIRST=',IFIRST |
| 1270 |
c print*,'IDACC',IDACC |
| 1271 |
c print *,' DT=',DT,' NDYN=',NDYN |
| 1272 |
c print *,' INQTAB' |
| 1273 |
c print *,INQTAB |
| 1274 |
IF(IFIRST.NE.1) GO TO 100 1646. |
| 1275 |
print *,INQTAB |
| 1276 |
IA(32)=1 |
| 1277 |
IA(33)=1 |
| 1278 |
IA(34)=1 |
| 1279 |
c print*,'IDACC',IDACC |
| 1280 |
c print *,' IA' |
| 1281 |
c do i=1,72 |
| 1282 |
c print *,i,IA(i) |
| 1283 |
c enddo |
| 1284 |
IFIRST=0 1647. |
| 1285 |
C**** INITIALIZE CERTAIN QUANTITIES (KD1M LE 69) 1648. |
| 1286 |
KD1M=67 1649. |
| 1287 |
INC=1+JMM1/24 1650. |
| 1288 |
DTSRCE=DT*NDYN 1651. |
| 1289 |
DTCNDS=DT*NCNDS 1652. |
| 1290 |
JMHALF=JM/2 1653. |
| 1291 |
DO 10 JR=1,46 1654. |
| 1292 |
10 SAREA(JR)=0. 1655. |
| 1293 |
DO 30 J=1,JM 1656. |
| 1294 |
S1(J)=IM 1657. |
| 1295 |
SPLAND(J)=0. 1658. |
| 1296 |
DO 20 I=1,IM 1659. |
| 1297 |
SPLAND(J)=SPLAND(J)+FDATA(I,J,2) 1660. |
| 1298 |
JR=J |
| 1299 |
20 SAREA(JR)=SAREA(JR)+DXYP(J) 1662. |
| 1300 |
30 JLAT(J)=INT(LAT(J)*360./TWOPI+100.5)-100 1663. |
| 1301 |
S1(1)=1. 1664. |
| 1302 |
S1(JM)=1. 1665. |
| 1303 |
SPLAND(1)=FDATA(1,1,2) 1666. |
| 1304 |
SPLAND(JM)=FDATA(1,JM,2) 1667. |
| 1305 |
SCALE(9)=1./DTSRCE 1668. |
| 1306 |
SCALE(12)=1./DTSRCE 1669. |
| 1307 |
SCALE(13)=1./DTSRCE 1670. |
| 1308 |
SCALE(14)=1./DTSRCE 1671. |
| 1309 |
SCALE(15)=1./DTSRCE 1672. |
| 1310 |
SCALE(16)=1./DTSRCE 1673. |
| 1311 |
SCALE(19)=SDAY/DTSRCE 1674. |
| 1312 |
SCALE(20)=100.*SDAY/(DTCNDS*GRAV) 1675. |
| 1313 |
SCALE(24)=1.E3*GRAV*EXPBYK(1000.) 1676. |
| 1314 |
SCALE(25)=SCALE(24) 1677. |
| 1315 |
SCALE(26)=16.*RGAS 1678. |
| 1316 |
SCALE(27)=16.*RGAS 1679. |
| 1317 |
SCALE(28)=.25/(2.*OMEGA) 1680. |
| 1318 |
SCALE(29)=.25/(2.*OMEGA) 1681. |
| 1319 |
if(NOCLM)then |
| 1320 |
SCALE(31)=SCALE(31)/IDACC(3) |
| 1321 |
endif |
| 1322 |
SCALE(35)=.5E2*JMM1/((SIGE(LS1)-SIGE(LM+1)+1.E-12)*180.) 1682. |
| 1323 |
SCALE(36)=.5E2*JMM1/((SIGE(1)-SIGE(LS1))*180.) 1683. |
| 1324 |
c SCALE(37)=1.E-5*SQRT(RGAS)/(2.*OMEGA) 1684. |
| 1325 |
c SCALE(37)=0.5 |
| 1326 |
SCALE(37)=1.0/float(NSURF) |
| 1327 |
SCALE(28)=SCALE(37) 1685. |
| 1328 |
c 38 Total stress TAUL+ROOF STRESS |
| 1329 |
SCALE(38)=1.0 |
| 1330 |
c For T2m |
| 1331 |
SCALE(26)=SCALE(23) 1685. |
| 1332 |
IA(26)=IA(23) |
| 1333 |
c For T2m |
| 1334 |
c For RIGS |
| 1335 |
SCALE(27)=SCALE(37) 1685. |
| 1336 |
IA(27)=IA(37) |
| 1337 |
c For RIGS |
| 1338 |
SCALE(39)=1./DTSRCE 1686. |
| 1339 |
SCALE(40)=1./DTSRCE 1687. |
| 1340 |
SCALE(41)=1./DTSRCE 1688. |
| 1341 |
SCALE(42)=1./DTSRCE 1689. |
| 1342 |
SCALE(43)=1./DTSRCE 1690. |
| 1343 |
SCALE(44)=1./DTSRCE 1691. |
| 1344 |
SCALE(45)=SDAY/DTSRCE 1692. |
| 1345 |
if(.not.NOCLM)then |
| 1346 |
c 43 is SWUP at Z0 from CLM |
| 1347 |
SCALE(43)=1.0 |
| 1348 |
c 45 is LWUP at Z0 from CLM |
| 1349 |
SCALE(45)=1.0 |
| 1350 |
c 16 is vetclm from CLM |
| 1351 |
SCALE(16)=SDAY |
| 1352 |
c 41 is sevclm from CLM |
| 1353 |
SCALE(41)=SDAY |
| 1354 |
c 42 is cevclm from CLM |
| 1355 |
SCALE(42)=SDAY |
| 1356 |
endif |
| 1357 |
SCALE(46)=SDAY/DTSRCE |
| 1358 |
SCALE(47)=SDAY/DTSRCE 1693. |
| 1359 |
SCALE(48)=SDAY/DTSRCE 1694. |
| 1360 |
SCALE(54)=SDAY/DTSRCE 1695. |
| 1361 |
SCALE(56)=1./DTSRCE 1696. |
| 1362 |
SCALE(61)=SCALE(20) 1697. |
| 1363 |
SCALE(62)=SCALE(20) 1698. |
| 1364 |
SCALE(63)=100./GRAV 1699. |
| 1365 |
SCALE(64)=1.E3*GRAV/(SIG(1)-SIG(LTM)) 1700. |
| 1366 |
SCALE(65)=1.E3*.0098/(SIGE(1)-SIGE(LTM+1)) 1701. |
| 1367 |
SCALE(66)=1.E3 1702. |
| 1368 |
c ============== 020996 |
| 1369 |
c Andrei want me to do this |
| 1370 |
if(NSURF.eq.2)then |
| 1371 |
SCALE(32)=5.0 |
| 1372 |
SCALE(33)=5.0 |
| 1373 |
c 0.5*10 |
| 1374 |
else |
| 1375 |
SCALE(32)=10.0 |
| 1376 |
SCALE(33)=10.0 |
| 1377 |
endif |
| 1378 |
c====================== |
| 1379 |
SCALE(34)=10. |
| 1380 |
C**** CALCULATE THE DERIVED QUANTITIES 1703. |
| 1381 |
100 BYA1=1./(IDACC(1)+1.E-20) 1704. |
| 1382 |
c print *,' DIAG1 100' |
| 1383 |
A2BYA1=FLOAT(IDACC(2))/FLOAT(IDACC(1)) 1705. |
| 1384 |
A1BYA2=IDACC(1)/(IDACC(2)+1.E-20) 1706. |
| 1385 |
c print *,' DTSRCE=',DTSRCE,' A1BYA2=',A1BYA2,' A2BYA1=',A2BYA1 |
| 1386 |
DO 210 J=1,JM 1722. |
| 1387 |
c print *,' 210 J=',J |
| 1388 |
SPOICE(J)=CJ(J,30)*BYA1 1723. |
| 1389 |
SPOCEN(J)=S1(J)-SPLAND(J)-SPOICE(J) 1724. |
| 1390 |
c AJ(J,17)=AJ(J,18) 1725. |
| 1391 |
AJ(J,60)=IDACC(2)*SPOCEN(J)*AJ(J,80)/(AJ(J,58)+1.E-20) 1726. |
| 1392 |
BJ(J,60)=IDACC(2)*SPLAND(J)*BJ(J,80)/(BJ(J,58)+1.E-20) 1727. |
| 1393 |
c if(CJ(J,58).gt.1e-10)then |
| 1394 |
CJ(J,60)=IDACC(2)*SPOICE(J)*CJ(J,80)/(CJ(J,58)+1.E-20) 1728. |
| 1395 |
c else |
| 1396 |
c CJ(J,60)=0. |
| 1397 |
c endif |
| 1398 |
DO 210 M=1,3 1729. |
| 1399 |
c print *,' 210 M=',M |
| 1400 |
ABCJ(J,4,M)=ABCJ(J,2,M)-ABCJ(J,6,M) 1730. |
| 1401 |
c ABCJ(J,7,M)=ABCJ(J,70,M)+A2BYA1*ABCJ(J,9,M)/DTSRCE 1731. |
| 1402 |
c ABCJ(J,8,M)=ABCJ(J,71,M)+A2BYA1*ABCJ(J,9,M)/DTSRCE 1732. |
| 1403 |
ABCJ(J,10,M)=ABCJ(J,2,M)+ABCJ(J,7,M) 1733. |
| 1404 |
ABCJ(J,11,M)=ABCJ(J,3,M)+ABCJ(J,8,M) 1734. |
| 1405 |
ABCJ(J,12,M)=A1BYA2*ABCJ(J,6,M)*DTSRCE+ABCJ(J,9,M) 1735. |
| 1406 |
C CLEAR SKY |
| 1407 |
ABCJCL(J,10,M)=ABCJCL(J,2,M)+ABCJCL(J,8,M) |
| 1408 |
ABCJCL(J,11,M)=ABCJCL(J,3,M)+ABCJCL(J,9,M) |
| 1409 |
CCC ABCJCL(J,7,M)=ABCJCL(J,7,M)/(A1BYA2*DTSRCE) |
| 1410 |
ABCJCL(J,12,M)=ABCJCL(J,4,M)+ABCJCL(J,7,M) |
| 1411 |
C CLEAR SKY |
| 1412 |
if(NOCLM) then |
| 1413 |
ABCJ(J,16,M)=ABCJ(J,41,M)+ABCJ(J,42,M) 1736. |
| 1414 |
endif |
| 1415 |
ABCJ(J,20,M)=ABCJ(J,61,M)+ABCJ(J,62,M) 1737. |
| 1416 |
if(NOCLM)then |
| 1417 |
ABCJ(J,44,M)=ABCJ(J,12,M)+ABCJ(J,13,M)+ABCJ(J,14,M) 1738. |
| 1418 |
* +ABCJ(J,39,M)-ABCJ(J,40,M) 1739. |
| 1419 |
else |
| 1420 |
ABCJ(J,44,M)=ABCJ(J,12,M)+ABCJ(J,13,M)+ABCJ(J,14,M) 1738. |
| 1421 |
endif |
| 1422 |
c ABCJ(J,46,M)=ABCJ(J,20,M)*SCALE(20)-(ABCJ(J,19,M)+ABCJ(J,45,M) 1740. |
| 1423 |
c * +ABCJ(J,54,M))*SCALE(19) 1741. |
| 1424 |
ABCJ(J,48,M)=ABCJ(J,45,M)-ABCJ(J,47,M) 1742. |
| 1425 |
ABCJ(J,56,M)=ABCJ(J,15,M)+ABCJ(J,43,M) 1743. |
| 1426 |
210 CONTINUE 1744. |
| 1427 |
IHOUR0=TOFDY0+.5 1745. |
| 1428 |
IHOUR=TOFDAY+.5 1746. |
| 1429 |
TAUDIF=TAU-TAU0 1747. |
| 1430 |
C**** 1748. |
| 1431 |
C**** LOOP OVER SURFACE TYPES: GLOBAL, LAND, OCEAN, AND OCEAN ICE 1749. |
| 1432 |
C**** 1750. |
| 1433 |
DO 500 M=1,4 1751. |
| 1434 |
c print *,' do 500 M=',M |
| 1435 |
c WRITE (6,901) XLABEL 1752. |
| 1436 |
c WRITE (6,902) TERAIN(M),IDAY0,IHOUR0,JDATE0,JMNTH0,JYEAR0,TAU0, 1753. |
| 1437 |
c * IDAY,IHOUR,JDATE,JMONTH,JYEAR,TAU,TAUDIF 1754. |
| 1438 |
c WRITE (6,903) (JLAT(JM+INC-J),J=INC,JM,INC) 1755. |
| 1439 |
c WRITE (6,905) 1756. |
| 1440 |
DO 490 K=1,KD1M 1757. |
| 1441 |
c print *,' do 490 K=',K |
| 1442 |
N=INDEX(K) 1758. |
| 1443 |
IACC=IDACC(IA(N)) 1759. |
| 1444 |
if(K.eq.-16.and.M.eq.2) then |
| 1445 |
print *,' DD2' |
| 1446 |
print *,' N=',N,' IACC=',IACC,' SCALE',SCALE(N) |
| 1447 |
print *,TITLE(n),' M=',M |
| 1448 |
print *,' BJ(J,N)=',BJ(J,N) |
| 1449 |
endif |
| 1450 |
GSUM=0. 1760. |
| 1451 |
GWT=0. 1761. |
| 1452 |
DO 320 JHEMI=1,2 1762. |
| 1453 |
c if(N.eq.60) then |
| 1454 |
cprint *,' N=',N,' JHEMI=',JHEMI |
| 1455 |
c endif |
| 1456 |
HSUM=0. 1763. |
| 1457 |
HWT=0. 1764. |
| 1458 |
DO 310 JH=1,JMHALF 1765. |
| 1459 |
J=(JHEMI-1)*JMHALF+JH 1766. |
| 1460 |
QJ=(AJ(J,N)*WTA(M)+BJ(J,N)*WTB(M)+CJ(J,N)*WTC(M))*SCALE(N) 1767. |
| 1461 |
if(N.eq.-60) then |
| 1462 |
print *,AJ(J,N),BJ(J,N),CJ(J,N) |
| 1463 |
print *,CJ(J,80),CJ(J,58) |
| 1464 |
endif |
| 1465 |
WTJ=(SPOCEN (J)*WTA(M)+SPLAND(J)*WTB(M)+SPOICE(J)*WTC(M))*IACC 1768. |
| 1466 |
FLAT(J)=QJ/(WTJ+1.E-20) 1769. |
| 1467 |
MLAT(J)=INT(FLAT(J)+10000.5)-10000 1770. |
| 1468 |
HSUM=HSUM+QJ*DXYP(J) 1771. |
| 1469 |
310 HWT=HWT+WTJ*DXYP(J) 1772. |
| 1470 |
if(K.eq.-16.and.M.eq.2) then |
| 1471 |
print *,' FLAT(J)=',FLAT(J) |
| 1472 |
endif |
| 1473 |
if(N.eq.-60) then |
| 1474 |
print *,' HSUM=',HSUM |
| 1475 |
print *,' HWT=',HWT |
| 1476 |
endif |
| 1477 |
FHEM(JHEMI)=HSUM/(HWT+1.E-20) 1773. |
| 1478 |
GSUM=GSUM+HSUM 1774. |
| 1479 |
320 GWT=GWT+HWT 1775. |
| 1480 |
if(N.eq.-60) then |
| 1481 |
print *,' GSUM=',GSUM |
| 1482 |
print *,' GWT=',GWT |
| 1483 |
endif |
| 1484 |
FGLOB=GSUM/(GWT+1.E-20) 1776. |
| 1485 |
IF(M.EQ.1) CALL KEYD1 (N,FGLOB,FHEM(2)) 1777. |
| 1486 |
DO 323 J=1,JM 1778. |
| 1487 |
323 GBUDG(J,K,M)=FLAT(J) 1779. |
| 1488 |
GBUDG(JM+1,K,M)=FHEM(1) 1780. |
| 1489 |
GBUDG(JM+2,K,M)=FHEM(2) 1781. |
| 1490 |
GBUDG(JM+3,K,M)=FGLOB 1782. |
| 1491 |
if(K.eq.-16.and.M.eq.2) then |
| 1492 |
print *,' GSUM=',GSUM,' GWT=',GWT |
| 1493 |
print *,' FGLOB=',FGLOB |
| 1494 |
endif |
| 1495 |
c GO TO (350,350,350,350,350,350, 350,350,350,350,350,350, 1783. |
| 1496 |
c * 350,350,350,350,350,350, 340,340,350,350,350,350, 1784. |
| 1497 |
c * 340,350,350,340,340,350, 350,350,350,350,350,350, 1785. |
| 1498 |
c * 350,350,350,350,350,350, 350,350,340,340,340,340, 1786. |
| 1499 |
c * 350,350,350,350,350,340, 350,350,350,350,350,350, 1787. |
| 1500 |
c * 340,340,350,340,340,340, 350,340,350,350,350,350),N 1788. |
| 1501 |
c 340 WRITE (6,906) TITLE(N),FGLOB,FHEM(2),FHEM(1), 1789. |
| 1502 |
c * (FLAT(JM+INC-J),J=INC,JM,INC) 1790. |
| 1503 |
c GO TO 490 1791. |
| 1504 |
c 350 WRITE (6,907) TITLE(N),FGLOB,FHEM(2),FHEM(1), 1792. |
| 1505 |
c * (MLAT(JM+INC-J),J=INC,JM,INC) 1793. |
| 1506 |
if(K.NE.14) go to 491 |
| 1507 |
DO 570 KCL=1,12 |
| 1508 |
N=KCL |
| 1509 |
GSUM=0. |
| 1510 |
GWT=0. |
| 1511 |
DO 520 JHEMI=1,2 |
| 1512 |
HSUM=0. |
| 1513 |
HWT=0. |
| 1514 |
DO 510 JH=1,JMHALF |
| 1515 |
J=(JHEMI-1)*JMHALF+JH |
| 1516 |
IACC=NCLR(J) |
| 1517 |
IACC=IDACC(IA(1)) |
| 1518 |
QJ=(AJCLR(J,N)*WTA(M)+BJCLR(J,N)*WTB(M)+CJCLR(J,N)*WTC(M)) |
| 1519 |
WTJ=(SPOCEN (J)*WTA(M)+SPLAND(J)*WTB(M)+SPOICE(J)*WTC(M))*IACC |
| 1520 |
FLAT(J)=QJ/(WTJ+1.E-20) |
| 1521 |
MLAT(J)=INT(FLAT(J)+10000.5)-10000 |
| 1522 |
HSUM=HSUM+QJ*DXYP(J) |
| 1523 |
510 HWT=HWT+WTJ*DXYP(J) |
| 1524 |
FHEM(JHEMI)=HSUM/(HWT+1.E-20) |
| 1525 |
GSUM=GSUM+HSUM |
| 1526 |
520 GWT=GWT+HWT |
| 1527 |
cprint *,' GSUM=',GSUM |
| 1528 |
cprint *,' GWT=',GWT |
| 1529 |
FGLOB=GSUM/(GWT+1.E-20) |
| 1530 |
DO 453 J=1,JM |
| 1531 |
453 GBUDG(J,KCL+KD1M+10,M)=FLAT(J) |
| 1532 |
GBUDG(JM+1,KCL+KD1M+10,M)=FHEM(1) |
| 1533 |
GBUDG(JM+2,KCL+KD1M+10,M)=FHEM(2) |
| 1534 |
GBUDG(JM+3,KCL+KD1M+10,M)=FGLOB |
| 1535 |
c WRITE (6,907) TITCLR(N),FGLOB,FHEM(2),FHEM(1), |
| 1536 |
c * (MLAT(JM+INC-J),J=INC,JM,INC) |
| 1537 |
570 CONTINUE |
| 1538 |
491 IF(N.NE.1) GO TO 490 1794. |
| 1539 |
C**** CALCULATE AND PRINT ALBEDOS 1795. |
| 1540 |
400 DO 430 KA=1,10 1796. |
| 1541 |
cprint *,' KA=',KA |
| 1542 |
NN=INNUM(KA) 1797. |
| 1543 |
ND=INDEN(KA) 1798. |
| 1544 |
AMULT=1. 1799. |
| 1545 |
IF(KA.LE.1.OR.KA.EQ.4) AMULT=-1. 1800. |
| 1546 |
GSUM=0. 1801. |
| 1547 |
GSUM2=0. 1802. |
| 1548 |
DO 420 JHEMI=1,2 1803. |
| 1549 |
HSUM=0. 1804. |
| 1550 |
HSUM2=0. 1805. |
| 1551 |
DO 410 JH=1,JMHALF 1806. |
| 1552 |
J=(JHEMI-1)*JMHALF+JH 1807. |
| 1553 |
QNUM=AJ(J,NN)*WTA(M)+BJ(J,NN)*WTB(M)+CJ(J,NN)*WTC(M) 1808. |
| 1554 |
QDEN=AJ(J,ND)*WTA(M)+BJ(J,ND)*WTB(M)+CJ(J,ND)*WTC(M) 1809. |
| 1555 |
FLAT(J)=AMULT*(100.* QNUM/(QDEN +1.E-20)-50.)+50. 1810. |
| 1556 |
MLAT(J)=FLAT(J)+.5 1811. |
| 1557 |
HSUM=HSUM+QNUM*DXYP(J) 1812. |
| 1558 |
410 HSUM2=HSUM2+QDEN*DXYP(J) 1813. |
| 1559 |
FHEM(JHEMI)=50.5+AMULT*(100.*HSUM/(HSUM2+1.E-20)-50.) 1814. |
| 1560 |
GSUM=GSUM+HSUM 1815. |
| 1561 |
420 GSUM2=GSUM2+HSUM2 1816. |
| 1562 |
cprint *,' GSUM=',GSUM |
| 1563 |
cprint *,' GSUM2=',GSUM2 |
| 1564 |
FGLOB=50.5+AMULT*(100.*GSUM/(GSUM2+1.E-20)-50.) 1817. |
| 1565 |
IF(M.EQ.1.AND.KA.EQ.1) CALL KEYD1A (FGLOB) 1818. |
| 1566 |
DO 423 J=1,JM 1819. |
| 1567 |
423 GBUDG(J,KA+KD1M,M)=FLAT(J) 1820. |
| 1568 |
GBUDG(JM+1,KA+KD1M,M)=FHEM(1) 1821. |
| 1569 |
GBUDG(JM+2,KA+KD1M,M)=FHEM(2) 1822. |
| 1570 |
GBUDG(JM+3,KA+KD1M,M)=FGLOB 1823. |
| 1571 |
c WRITE (6,907) TITLEA(KA),FGLOB,FHEM(2),FHEM(1), 1824. |
| 1572 |
c * (MLAT(JM+INC-J),J=INC,JM,INC) 1825. |
| 1573 |
430 CONTINUE 1826. |
| 1574 |
490 CONTINUE 1827. |
| 1575 |
c WRITE (6,903) (JLAT(JM+INC-J),J=INC,JM,INC) 1828. |
| 1576 |
c WRITE (6,905) 1829. |
| 1577 |
c DO 495 LSKIP=1,20 1830. |
| 1578 |
c 495 WRITE (6,920) 1831. |
| 1579 |
500 CONTINUE 1832. |
| 1580 |
C**** 1833. |
| 1581 |
C**** PRODUCE REGIONAL STATISTICS 1834. |
| 1582 |
C**** 1835. |
| 1583 |
RETURN 1876. |
| 1584 |
C**** 1877. |
| 1585 |
901 FORMAT ('1',33A4) 1878. |
| 1586 |
902 FORMAT ('0** BUDGETS',A16,' ** DAY',I5,', HR',I2,' (',I2,A5, 1879. |
| 1587 |
* I4,')',F8.0,' TO DAY',I5,', HR',I2,' (',I2,A5,I4,')', 1880. |
| 1588 |
* F8.0,' DIF',F5.0,' HR') 1881. |
| 1589 |
903 FORMAT ('0',131('-')/20X,'G NH SH ',24I4) 1882. |
| 1590 |
904 FORMAT (A16,3I6,2X,24I4) 1883. |
| 1591 |
905 FORMAT (1X,131('-')) 1884. |
| 1592 |
906 FORMAT (A16,3F6.1,2X,24F4.1) 1885. |
| 1593 |
907 FORMAT (A16,3F6.1,2X,24I4) 1886. |
| 1594 |
908 FORMAT ('0',17X,'WEST MID- EAST SOU. GRN- MID- NOR. WEST SIBR SOU.1887. |
| 1595 |
* CHNA IND. AUS. NOR. SOU. AFR. AFR. AMZN NOR. MID- NOR. WEST EAST'1888. |
| 1596 |
* /18X,'U.S. U.S. U.S. CNDA LAND EUR. RUSS SIBR PLAT CHNA DSRT DSRT1889. |
| 1597 |
* DSRT SHRA SHRA SAHL RAIN RAIN ATL. ATL. PAC. PAC. PAC. '/1X, 1890. |
| 1598 |
* 131('-')) 1891. |
| 1599 |
909 FORMAT (A16,1X,23I5) 1892. |
| 1600 |
910 FORMAT (A16,1X,23F5.1) 1893. |
| 1601 |
920 FORMAT (1X) 1894. |
| 1602 |
END 1895. |
| 1603 |
BLOCK DATA a1 2001. |
| 1604 |
C**** 2002. |
| 1605 |
C**** TITLES FOR SUBROUTINE DIAG2 2003. |
| 1606 |
C**** 2004. |
| 1607 |
COMMON/D2TTL/TITLE1,TITLE2,TITLE3, 2005. |
| 1608 |
* TITLE4,TITLE5,TITLE6,TITLE7,TITLE8,TITLE9,TITLEA,TITLEB,TITLEC 2006. |
| 1609 |
* ,TITLEN |
| 1610 |
C * ,LINECT,JMHALF,INC,IHOUR0,IHOUR,TAUDIF 2007. |
| 1611 |
CHARACTER*64 TITLE1(13)/ 2008. |
| 1612 |
C**** 1-13 2009. |
| 1613 |
1'TEMPERATURE (DEGREES CENTIGRADE)', 2010. |
| 1614 |
*'HEIGHT (HUNDREDS OF METERS)', 2011. |
| 1615 |
3'SPECIFIC HUMIDITY (10**-5 KG H2O/KG AIR)', 2012. |
| 1616 |
*'RELATIVE HUMIDITY (PERCENT)', 2013. |
| 1617 |
*'ZONAL WIND (U COMPONENT) (TENTHS OF METERS/SECOND)', 2014. |
| 1618 |
6'MERIDIONAL WIND (V COMPONENT) (HUNDREDTHS OF METERS/SECOND)', 2015. |
| 1619 |
*'STREAM FUNCTION (10**9 KILOGRAMS/SECOND)', 2017. |
| 1620 |
8'VERTICAL VELOCITY (10**-5 METERS/SECOND)', 2018. |
| 1621 |
9'BAROCLINIC EDDY KINETIC ENERGY GEN. (10**-1 WATTS/M**2/SIGMA)', 2019. |
| 1622 |
*'VERTICAL MASS EXCHANGE FROM MOIST CONVECTION (10**9 KG/SECOND)', 2021. |
| 1623 |
*'SOLAR RADIATION HEATING RATE (HUNDREDTHS OF DEGREES KELVIN/DAY)',2023. |
| 1624 |
*'THERMAL RADIATION COOLING RATE (HUNDREDTHS OF DEGREES K/DAY)', 2025. |
| 1625 |
*'TOTAL RADIATION COOLING RATE (10**13 WATTS/UNIT SIGMA)'/ 2027. |
| 1626 |
CHARACTER*64 TITLE2(8)/ 2028. |
| 1627 |
C**** 14-21 2029. |
| 1628 |
4'HEATING BY LARGE SCALE CONDENSATION (10**13 WATTS/UNIT/SIGMA)', 2030. |
| 1629 |
5'HEATING BY DRY CONVECTION (10**13 WATTS/UNIT SIGMA)', 2032. |
| 1630 |
6' HEATING BY MOIST CONVECTION (10**13 WATTS/UNIT SIGMA)', 2033. |
| 1631 |
7'STANDING EDDY KINETIC ENERGY (10**4 JOULES/M**2/UNIT SIGMA)', 2035. |
| 1632 |
8'EDDY MERIDIONAL WIND VARIANCE (METER**2/SEC**2) ', 2037. |
| 1633 |
9'TOTAL KINETIC ENERGY (10**4 JOULES/M**2/UNIT SIGMA)', 2038. |
| 1634 |
O'AVAILABLE POTENTIAL ENERGY (10**5 JOULES/M**2/UNIT SIGMA)', 2039. |
| 1635 |
1'POTENTIAL TEMPERATURE (DEGREES KELVIN)'/ 2041. |
| 1636 |
CHARACTER*64 TITLE3(7)/ 2042. |
| 1637 |
C**** 22-28 2043. |
| 1638 |
2'NOR. TRANS. OF DRY STAT. ENERGY BY STAND. EDDIES(10**14 W/DSIG)',2044. |
| 1639 |
3'NORTH. TRANS. OF DRY STATIC ENERGY BY EDDIES (10**14 W/DSIG)', 2046. |
| 1640 |
4'TOTAL NORTH. TRANSPORT OF DRY STATIC ENERGY (10**15 W/DSIG)', 2048. |
| 1641 |
5'NORTHWARD TRANSPORT OF LATENT HEAT BY EDDIES (10**13 W/DSIG)', 2050. |
| 1642 |
6'TOTAL NORTHWARD TRANSPORT OF LATENT HEAT (10**14 W/UNIT SIG)', 2052. |
| 1643 |
7'NORTH. TRANSPORT OF STATIC ENERGY BY EDDIES (10**14 W/DSIGMA)', 2054. |
| 1644 |
8'TOTAL NORTHWARD TRANSPORT OF STATIC ENERGY (10**15 W/DSIGMA)'/ 2056. |
| 1645 |
CHARACTER*64 TITLE4(5)/ 2058. |
| 1646 |
C**** 29-33 2059. |
| 1647 |
9'NORTH. TRANSPORT OF KINETIC ENERGY BY EDDIES (10**12 W/DSIG)', 2060. |
| 1648 |
O'TOTAL NORTHWARD TRANSPORT OF KINETIC ENERGY (10**12 W/DSIG)', 2062. |
| 1649 |
1'NORTH. TRANS. OF ANG. MOMENTUM BY STAND. EDDIES (10**18 J/DSIG)',2064. |
| 1650 |
2'NORTH. TRANS. OF ANG. MOMENTUM BY EDDIES (10**18 J/DSIGMA)', 2066. |
| 1651 |
3'TOTAL NORTHWARD TRANSPORT OF ANG. MOMENTUM (10**19 J/DSIG)'/ 2068. |
| 1652 |
CHARACTER*64 TITLE5(6)/ 2070. |
| 1653 |
C**** 34-39 2071. |
| 1654 |
4'VERT. TRANS. OF DRY STATIC ENERGY BY EDDIES (10*12 WATTS)', 2072. |
| 1655 |
5'TOTAL LARGE SCALE VERT. TRANS. OF DRY STAT. ENER.(10**14 WATTS)',2074. |
| 1656 |
6'VERTICAL TRANSPORT OF LATENT HEAT BY EDDIES (10**12 WATTS)', 2076. |
| 1657 |
7'TOTAL LARGE SCALE VERT. TRANS. OF LATENT HEAT (10**13 WATTS)', 2078. |
| 1658 |
8'VERTICAL TRANSPORT OF STATIC ENERGY BY EDDIES (10**13 WATTS)', 2080. |
| 1659 |
9'TOTAL LARGE SCALE VERT. TRANS. OF STATIC ENERGY (10**14 W)'/ 2082. |
| 1660 |
CHARACTER*64 TITLE6(4)/ 2084. |
| 1661 |
C**** 40-43 2085. |
| 1662 |
O'VERTICAL TRANSPORT OF KINETIC ENERGY BY EDDIES (10**11 WATTS)', 2086. |
| 1663 |
1'TOTAL LARGE SCALE VERT. TRANS. OF KINETIC ENERGY (10**11 WATTS)',2088. |
| 1664 |
2'VERT. TRANS. OF ANG. MOMENTUM BY EDDIES (10**16 JOULES)', 2090. |
| 1665 |
3'TOTAL LARGE SCALE VERT. TRANS. OF ANG. MOMENTUM (10**18 JOULES)'/2091. |
| 1666 |
CHARACTER*64 TITLE7(9)/ 2093. |
| 1667 |
C**** 44-52 2094. |
| 1668 |
4'CHANGE OF ANG. MOMENTUM BY DRY CONVEC (10**18 J/UNIT SIGMA)', 2095. |
| 1669 |
5'CHANGE OF ANG. MOMENTUM BY MOIST CONV (10**18 J/UNIT SIGMA)', 2097. |
| 1670 |
6'CHANGE OF ANG. MOMENTUM BY DIFFUSION (10**18 J/UNIT SIGMA)', 2099. |
| 1671 |
C 7'U WIND AVERAGED OVER I=5-9 (TENTHS OF METERS/SECOND)', 2101. |
| 1672 |
7'NORTHWARD ELIASSEN-PALM FLUX (10**17 JOULES/UNIT SIGMA)', 2102. |
| 1673 |
c 8,'V WIND AVERAGED OVER I=5-9 (TENTHS OF METERS/SECOND)', 2103. |
| 1674 |
c 9'VERTICAL VELOCITY FOR I=5-9 (10**-5 METERS/SECOND)', 2104. |
| 1675 |
8'SHORTWAVE RADIATION FLUX (W/M**2)', |
| 1676 |
9'LONGWAVE RADIATION FLUX (W/M**2)', |
| 1677 |
C O'U WIND AVERAGED OVER I=35-3 (TENTHS OF METERS/SECOND)', 2105. |
| 1678 |
O'VERTICAL ELIASSEN-PALM FLUX (10**17 JOULES)', 2106. |
| 1679 |
c 1'V WIND AVERAGED OVER I=35-3 (TENTHS OF METERS/SECOND)', 2107. |
| 1680 |
c 2'VERTICAL VELOCITY FOR I=35-3 (10**-5 METERS/SECOND)'/ 2108. |
| 1681 |
1'SHORTWAVE RADIATION FLUX CLEAR SKY (W/M**2)', |
| 1682 |
2'LONGWAVE RADIATION FLUX CLEAR SKY (W/M**2)'/ |
| 1683 |
CHARACTER*64 TITLE8(8)/ 2109. |
| 1684 |
C**** 53-60 2110. |
| 1685 |
3'POTENTIAL VORTICITY (10**-6 K/(MB-S))', 2111. |
| 1686 |
4'NORTHWARD TRANSPORT OF Q-G POT. VORTICITY (10**18 J/DSIG)', 2112. |
| 1687 |
5'P-K BY PRESSURE GRADIENT FORCE (10**-1 W/M**2/UNIT SIGMA)', 2114. |
| 1688 |
6'Q-G POT. VORTICITY CHANGE OVER LATITUDES (10**-12 1/(SEC-M))', 2116. |
| 1689 |
7'LAGRANGIAN MEANSTREAM FUNCTION (10**9 KILOGRAMS/SECOND)', 2118. |
| 1690 |
8'DYNAMIC CONVERGENCE OF EDDY GEOPOTENTIAL (.1 W/M**2/DSIGMA)', 2119. |
| 1691 |
9'REFRACTION INDEX FOR WAVE NUMBER 1 (10**-8 PER M**2)', 2121. |
| 1692 |
O'REFRACTION INDEX FOR WAVE NUMBER 2 (10**-8 PER M**2)'/ 2123. |
| 1693 |
CHARACTER*64 TITLE9(12)/ 2125. |
| 1694 |
C**** 61-72 2126. |
| 1695 |
1'ZONAL WIND (U COMPONENT) FOR J=11-13 (METERS/SECOND)', 2127. |
| 1696 |
2'MERIDIONAL WIND (V COMPONENT) FOR J=11-13 (METERS/SECOND)', 2128. |
| 1697 |
3'VERTICAL VELOCITY FOR J=11-13 (10**-4 METERS/SEDOND)', 2130. |
| 1698 |
4'TEMPERATURE FOR J=11-13 (DEGREES CENTIGRADE)', 2131. |
| 1699 |
5'RELATIVE HUMIDITY FOR J=11-13 (PERCENT)', 2132. |
| 1700 |
6'MOIST CONVECTIVE HEATING FOR J=11-13 (10**13 W/UNIT SIGMA)', 2133. |
| 1701 |
7'TOTAL RADIATIVE COOLING FOR J=11-13 (10**13 W/UNIT SIGMA)', 2135. |
| 1702 |
8' ', 2137. |
| 1703 |
9'VERTICAL VELOCITY AT J=19 (10**-4 METERS/SECOND)', 2138. |
| 1704 |
O'TEMPERATURE AT J=19 (DEGREES CENTIGRADE)', 2139. |
| 1705 |
1'TOTAL RADIATIVE COOLING AT J=19 (10**13 W/UNIT SIGMA)', 2140. |
| 1706 |
2'ZONAL WIND AT J=19 (METERS/SECOND)'/ 2142. |
| 1707 |
CHARACTER*64 TITLEA(11)/ 2143. |
| 1708 |
C**** 73-83 2144. |
| 1709 |
3'VERTICAL VELOCITY AT J=21 (10**-4 METERS/SECOND)', 2145. |
| 1710 |
4'TEMPERATURE AT J=21 (DEGREES CENTIGRADE)', 2146. |
| 1711 |
5'TOTAL RADIATIVE COOLING AT J=21 (10**13 W/UNIT SIGMA)', 2147. |
| 1712 |
6'ZONAL WIND AT J=21 (METERS/SECOND)', 2149. |
| 1713 |
7'TOTAL CLOUD COVER (.1 * %)', 2150. |
| 1714 |
8'SUPER SATURATION CLOUD COVER (.1 * %)', 2151. |
| 1715 |
9'MOIST CONVECTIVE CLOUD COVER (.1 * %)', 2152. |
| 1716 |
O'AMPLITUDE OF GEOPOTENTIAL HEIGHT FOR WAVE NUMBER 1 (METERS)', 2153. |
| 1717 |
1'AMPLITUDE OF GEOPOTENTIAL HEIGHT FOR WAVE NUMBER 2 (METERS)', 2155. |
| 1718 |
2'AMPLITUDE OF GEOPOTENTIAL HEIGHT FOR WAVE NUMBER 3 (METERS)', 2157. |
| 1719 |
3'AMPLITUDE OF GEOPOTENTIAL HEIGHT FOR WAVE NUMBER 4 (METERS)'/ 2159. |
| 1720 |
CHARACTER*64 TITLEB(9)/ 2161. |
| 1721 |
C**** 84-92 2162. |
| 1722 |
4'PHASE OF GEOPOTENTIAL HEIGHT FOR WAVE NUMBER 1 (DEG WEST LONG)', 2163. |
| 1723 |
5'PHASE OF GEOPOTENTIAL HEIGHT FOR WAVE NUMBER 2 (DEG WEST LONG)', 2165. |
| 1724 |
6'PHASE OF GEOPOTENTIAL HEIGHT FOR WAVE NUMBER 3 (DEG WEST LONG)', 2167. |
| 1725 |
7'PHASE OF GEOPOTENTIAL HEIGHT FOR WAVE NUMBER 4 (DEG WEST LONG)', 2169. |
| 1726 |
8'NORTH. TRANS. OF SENSIBLE HEAT BY EDDIES (10**14 W/DSIGMA)', 2171. |
| 1727 |
9'TOTAL NORTHWARD TRANSPORT OF SENSIBLE HEAT (10**15 W/DSIGMA)', 2173. |
| 1728 |
O'VERT. TRANS. OF GEOPOTENTIAL ENERGY BY EDDIES (10**12 WATTS)', 2175. |
| 1729 |
1'TOTAL LARGE SCALE VERT. TRANS. OF GEOPOTEN. ENER. (10**14 W)', 2177. |
| 1730 |
2'SUBGRID SCALE TEMPERATURE VARIANCE (DEGREE**2) '/ 2179. |
| 1731 |
CHARACTER*64 TITLEC(6)/ 2181. |
| 1732 |
C**** 93-98 2182. |
| 1733 |
3'DYNAMIC CONVERGENCE OF DRY STATIC ENERGY (10**14 W/INIT SIG)', 2183. |
| 1734 |
4'DIVERGENCE OF THE ELIASSEN-PALM FLUX (10**17 J/UNIT SIGMA)', 2185. |
| 1735 |
5'REFRACTION INDEX FOR WAVE NUMBER 3 (10**-8 PER METWR**2)', 2187. |
| 1736 |
6'REFRACTION INDEX FOR WAVE NUMBER 6 (10**-8 PER METER**2)', 2189. |
| 1737 |
9'REFRACTION INDEX FOR WAVE NUMBER 9 (10**-8 PER METER**2)', 2191. |
| 1738 |
8'CHANGE OF PHASE HEATING BY MOIST CONVECTION (10*13 W/DSIG)'/ 2193. |
| 1739 |
CHARACTER*64 TITLEN(5)/ |
| 1740 |
C 99-103 |
| 1741 |
9' TRANSPORT OF LATENT HEAT BY HOR. DIFF.', |
| 1742 |
O' GHANGE OF KIN. ENERGY DUE TO EDDIES', |
| 1743 |
1' GHANGE OF SPEC. HUM. BY MOIST CONVECTION ', |
| 1744 |
2' TEMPERATURE VARIANCE', |
| 1745 |
3' '/ |
| 1746 |
END 2195. |
| 1747 |
SUBROUTINE DIAG2 2201. |
| 1748 |
#include "BD2G04.COM" 2202. |
| 1749 |
COMMON/SPEC2/KMT,KINC,COEK 2202.1 |
| 1750 |
COMMON U,V,T,P,Q 2203. |
| 1751 |
COMMON/WORK2/SENDEG(72,46),CN(2,37),BYP(46),BYPV(46),BYDXYV(46), 2204. |
| 1752 |
* AX(JM0,36),ARQX(JM0,3),BX(JM0,36),CX(JM0,36),DX(JM0,36), 2205. |
| 1753 |
* AMPLTD(JM0,8,4),PHASE(JM0,8,4) 2206. |
| 1754 |
COMMON/D2COM/JLAT(46,2),WTJ(46,2,2), 2207. |
| 1755 |
* LINECT,JMHALF,INC,IHOUR0,IHOUR,I25,TAUDIF 2208. |
| 1756 |
common/nqt/NQMAPS |
| 1757 |
DIMENSION PL(39),PLE(36),ONES(46),BYDSIG(36),BYDPS(3),BYD2SG(36), 2209. |
| 1758 |
* BYPKS(3),DACOSV(46),BYDXYP(46),DXYPPO(46),ONESPO(46),DXCOSV(46),2210. |
| 1759 |
* BYDAPO(46),PMB(7),MW(5),ITIT(5) 2211. |
| 1760 |
DATA ITIT/59,60,95,96,97/ 2212. |
| 1761 |
DATA MW/1,2,3,6,9/ 2213. |
| 1762 |
DATA PMB/999.9,850.,700.,500.,300.,100.,30./ 2214. |
| 1763 |
DATA ONES/46*1./ 2215. |
| 1764 |
C**** INITIALIZE CERTAIN QUANTITIES 2216. |
| 1765 |
NQMAPS=0 |
| 1766 |
INC=1+JMM1/24 2217. |
| 1767 |
JMHALF=JM/2 2218. |
| 1768 |
BYIM=1./FIM 2219. |
| 1769 |
BY100G=.01/GRAV 2220. |
| 1770 |
SHA=RGAS/KAPA 2221. |
| 1771 |
DTCNDS=NCNDS*DT 2222. |
| 1772 |
P1000K=EXPBYK(1000.) 2223. |
| 1773 |
KM=0 2224. |
| 1774 |
DO 5 K=1,7 2225. |
| 1775 |
IF (PTOP.GT.PMB(K)) GO TO 6 2226. |
| 1776 |
5 KM=KM+1 2227. |
| 1777 |
6 ELOFIM=.5*TWOPI-TWOPI/FIM 2228. |
| 1778 |
DO 20 L=1,LM 2229. |
| 1779 |
LUP=L+1 2230. |
| 1780 |
LDN=L-1 2231. |
| 1781 |
IF(L.EQ.LM) LUP=LM 2232. |
| 1782 |
IF(L.EQ.1) LDN=1 2233. |
| 1783 |
BYD2SG(L)=1./(SIG(LUP)-SIG(LDN)) 2234. |
| 1784 |
BYDSIG(L)=1./DSIG(L) 2235. |
| 1785 |
20 PL(L)=SIG(L)*(PSF-PTOP)+PTOP 2236. |
| 1786 |
PL(LM+1)=.75*PTOP 2237. |
| 1787 |
PL(LM+2)=.35*PTOP 2238. |
| 1788 |
PL(LM+3)=.1*PTOP 2239. |
| 1789 |
BYDPS(1)=1./(.5*PTOP) 2240. |
| 1790 |
BYDPS(2)=1./(.3*PTOP) 2241. |
| 1791 |
BYDPS(3)=1./(.2*PTOP) 2242. |
| 1792 |
BYPKS(1)=1./(.75*PTOP)**KAPA 2243. |
| 1793 |
BYPKS(2)=1./(.35*PTOP)**KAPA 2244. |
| 1794 |
BYPKS(3)=1./(.1*PTOP)**KAPA 2245. |
| 1795 |
DO 30 L=1,LM 2246. |
| 1796 |
30 PLE(L)=SIGE(L+1)*(PSF-PTOP)+PTOP 2247. |
| 1797 |
DO 40 J=1,JM 2248. |
| 1798 |
DXYPPO(J)=DXYP(J) 2249. |
| 1799 |
BYDXYP(J)=1./DXYP(J) 2250. |
| 1800 |
BYDAPO(J)=BYDXYP(J) 2251. |
| 1801 |
ONESPO(J)=1. 2252. |
| 1802 |
JLAT(J,1)=INT(.5+(J-1.0)*180./JMM1)-90 2253. |
| 1803 |
JLAT(J,2)=INT(.5+(J-1.5)*180./JMM1)-90 2254. |
| 1804 |
WTJ(J,1,1)=1. 2255. |
| 1805 |
40 WTJ(J,2,1)=2.*FIM*DXYP(J)/AREAG 2256. |
| 1806 |
DXYPPO(JM)=DXYP(JM)*FIM 2257. |
| 1807 |
DXYPPO(1)=DXYP(1)*FIM 2258. |
| 1808 |
BYDAPO(1)=BYDAPO(1)*FIM 2259. |
| 1809 |
BYDAPO(JM)=BYDAPO(JM)*FIM 2260. |
| 1810 |
ONESPO(1)=FIM 2261. |
| 1811 |
ONESPO(JM)=FIM 2262. |
| 1812 |
DO 50 J=2,JM 2263. |
| 1813 |
DXCOSV(J)=DXV(J)*COSV(J) 2264. |
| 1814 |
DACOSV(J)=DXYV(J)*COSV(J) 2265. |
| 1815 |
BYDXYV(J)=1./DXYV(J) 2266. |
| 1816 |
WTJ(J,1,2)=1. 2267. |
| 1817 |
50 WTJ(J,2,2)=2.*FIM*DXYV(J)/AREAG 2268. |
| 1818 |
WTJ(JMHALF+1,1,2)=.5 2269. |
| 1819 |
WTJ(JMHALF+1,2,2)=WTJ(JMHALF+1,2,2)/2. 2270. |
| 1820 |
IHOUR0=TOFDY0+.5 2271. |
| 1821 |
IHOUR=TOFDAY+.5 2272. |
| 1822 |
TAUDIF=TAU-TAU0 2273. |
| 1823 |
LINECT=65 2274. |
| 1824 |
c WRITE (6,901) 2275. |
| 1825 |
BYIAC3=1./(IDACC(1)+1.E-20) 2276. |
| 1826 |
BYIARD=1./(IDACC(2)+1.E-20) 2277. |
| 1827 |
BYIADA=1./(IDACC(4)+1.E-20) 2278. |
| 1828 |
BYIMDA=BYIADA*BYIM 2279. |
| 1829 |
FIMDA=IDACC(4)*FIM 2280. |
| 1830 |
SCLRH=100.*IDACC(4)/IDACC(1) |
| 1831 |
SCLTV=IDACC(4)/IDACC(1) |
| 1832 |
DO 120 J=1,JM 2281. |
| 1833 |
BYP(J)=1./(APJ(J,1)+1.E-20) 2282. |
| 1834 |
120 BYPV(J)=1./(APJ(J,2)+1.E-20) 2283. |
| 1835 |
C**** 2284. |
| 1836 |
C**** PROGNOSTIC QUANTITIES 2285. |
| 1837 |
C**** 2286. |
| 1838 |
C**** TEMPERATURE, HEIGHT, SPECIFIC HUMIDITY, AND RELATIVE HUMIDITY 2287. |
| 1839 |
CALL JLMAPS (1,PL,AJL,ONES,BYP,ONES,LM,2,1, 2288. |
| 1840 |
* ASJL,BYIMDA,ONESPO,ONES) 2289. |
| 1841 |
SCALES=BYIMDA*BY100G 2290. |
| 1842 |
CALL JLMAPS (2,PL,AJL(1,1,2),BY100G,BYP,ONES,LM,2,1, 2291. |
| 1843 |
* ASJL(1,1,2),SCALES,ONESPO,ONES) 2292. |
| 1844 |
CALL JLMAP (3,PL,AJL(1,1,3),1.E5,BYP,ONES,LM,2,1) 2293. |
| 1845 |
CALL JLMAP (100,PL,AJL(1,1,56),1.E5,BYP,ONES,LM,2,1) |
| 1846 |
c change of KIN. EN. due to eddy |
| 1847 |
c CALL JLMAP (100,PL,AJL(1,1,26),1.E1,BYP,ONES,LM,2,1) |
| 1848 |
c change of KIN. EN. due to eddy |
| 1849 |
CALL JLMAP (101,PL,AJL(1,1,57),1.E5,BYP,ONES,LM,2,1) |
| 1850 |
CALL JLMAP (4,PL,AJL(1,1,18),100.,BYP,ONES,LM,2,1) 2294. |
| 1851 |
c print *,' DIAGA2 AJL=',AJL(12,1,58),AJL(12,1,58)/IDACC(1) |
| 1852 |
c print *,BYP(12),AJL(12,1,58)*BYP(12),APJ(12,1),APJ(12,1)/IDACC(1) |
| 1853 |
c print *,IDACC(4),APJ(12,1)/IDACC(4) |
| 1854 |
C=== CALL JLMAP (102,PL,AJL(1,1,58),SCLRH,BYP,ONES,LM,2,1) |
| 1855 |
CALL JLMAP (102,PL,AJL(1,1,59),SCLTV,BYP,ONES,LM,2,1) |
| 1856 |
C**** U WIND, V WIND, AND STREAM FUNCTION 2295. |
| 1857 |
CALL JLMAP (5,PL,AJL(1,1,4),1.E1,BYPV,ONES,LM,2,2) 2296. |
| 1858 |
CALL JLMAP (6,PL,AJL(1,1,5),1.E2,BYPV,ONES,LM,2,2) 2297. |
| 1859 |
DO 220 J=2,JM 2298. |
| 1860 |
AX(J,1)=AJL(J,1,5)*DSIG(1) 2299. |
| 1861 |
DO 220 L=2,LM 2301. |
| 1862 |
220 AX(J,L)=AX(J,L-1)+AJL(J,L,5)*DSIG(L) 2303. |
| 1863 |
SCALE=25.E-9*BYIADA/GRAV 2304. |
| 1864 |
CALL JLMAP (7,PLE,AX,SCALE,DXV,ONES,LM,2,2) 2305. |
| 1865 |
C**** VERTICAL VELOCITY AND MASS FLUX MOIST CONVECTION 2307. |
| 1866 |
SCALE=-1.E5*BYIADA*RGAS/(FIM*GRAV) 2308. |
| 1867 |
CALL JLMAP (8,PLE,AJL(1,1,6),SCALE,BYDAPO,ONES,LMM1,2,1) 2309. |
| 1868 |
SCALE=100.E-9*BYIAC3/(GRAV*DTCNDS) 2310. |
| 1869 |
CALL JLMAP (10,PLE,AJL(1,1,8),SCALE,DXYPPO,ONES,LMM1,1,1) 2311. |
| 1870 |
C**** 2312. |
| 1871 |
C**** RADIATION, CONDENSATION AND CONVECTION 2313. |
| 1872 |
C**** 2314. |
| 1873 |
C**** SOLAR AND THERMAL RADIATION HEATING 2315. |
| 1874 |
SCALE=100.E-2*GRAV*SDAY*IDACC(4)*BYIARD/SHA 2316. |
| 1875 |
C SCALE for 100e-2 degree/day |
| 1876 |
SCALES=100.E-2*GRAV*SDAY*BYIM*BYIARD/SHA 2317. |
| 1877 |
CALL JLMAPS (11,PL,AJL(1,1,9),SCALE,BYP,BYDSIG,LM,2,1, 2318. |
| 1878 |
* ASJL(1,1,3),SCALES,ONESPO,BYDPS) 2319. |
| 1879 |
SCALES=-SCALES 2320. |
| 1880 |
SCALE=-SCALE 2321. |
| 1881 |
CALL JLMAPS (12,PL,AJL(1,1,10),SCALE,BYP,BYDSIG,LM,2,1, 2322. |
| 1882 |
* ASJL(1,1,4),SCALES,ONESPO,BYDPS) 2323. |
| 1883 |
DO 250 J=1,JM 2324. |
| 1884 |
DO 240 LS=1,3 2325. |
| 1885 |
240 ARQX(J,LS)=ASJL(J,LS,3)+ASJL(J,LS,4) 2326. |
| 1886 |
DO 250 L=1,LM 2327. |
| 1887 |
250 AX(J,L)=AJL(J,L,9)+AJL(J,L,10) 2328. |
| 1888 |
SCALE=-1.E-13*BYIARD 2329. |
| 1889 |
SCALES=SCALE*(PSF-PTOP) 2330. |
| 1890 |
CALL JLMAPS (13,PL,AX,SCALE,DXYPPO,BYDSIG,LM,1,1, 2331. |
| 1891 |
* ARQX,SCALES,DXYPPO,BYDPS) 2332. |
| 1892 |
C**** SOLAR AND THERMAL RADIATION FLUXES |
| 1893 |
|
| 1894 |
SCALE=BYIARD |
| 1895 |
CALL JLMAP (48,PL,AJL(1,1,42),SCALE,ONES,ONES,LM,2,1) |
| 1896 |
CALL JLMAP (49,PL,AJL(1,1,43),SCALE,ONES,ONES,LM,2,1) |
| 1897 |
CALL JLMAP (51,PL,AJL(1,1,45),SCALE,ONES,ONES,LM,2,1) |
| 1898 |
CALL JLMAP (52,PL,AJL(1,1,46),SCALE,ONES,ONES,LM,2,1) |
| 1899 |
|
| 1900 |
C**** TOTAL, SUPER SATURATION, AND CONVECTIVE CLOUD COVER 2333. |
| 1901 |
SCALE=1000.*BYIARD*BYIM 2334. |
| 1902 |
CALL JLMAP (77,PL,AJL(1,1,19),SCALE,ONESPO,ONES,LM,2,1) 2335. |
| 1903 |
CALL JLMAP (78,PL,AJL(1,1,28),SCALE,ONESPO,ONES,LM,2,1) 2336. |
| 1904 |
CALL JLMAP (79,PL,AJL(1,1,29),SCALE,ONESPO,ONES,LM,2,1) 2337. |
| 1905 |
C**** SUBGRID SCALE TEMPERATURE DEVIATION 2338. |
| 1906 |
SCALE=1.00*BYIADA 2339. |
| 1907 |
CALL JLMAP (92,PL,AJL(1,1,54),SCALE,ONES,ONES,LM,2,1) 2340. |
| 1908 |
C**** HEATING BY LARGE SCALE CONDENSATION AND DRY AND MOIST CONVECTION 2341. |
| 1909 |
C and vert. diff. |
| 1910 |
C SCALE for 10**13W/( UNIT SIGMA) |
| 1911 |
SCALE=100.E-13*SHA*BYIAC3/(GRAV*DTCNDS) 2342. |
| 1912 |
c CALL JLMAP (14,PL,AJL(1,1,11),SCALE,DXYPPO,ONES,LM,1,1) 2343. |
| 1913 |
c CALL JLMAP (15,PL,AJL(1,1,12),SCALE,DXYPPO,ONES,LM,1,1) 2344. |
| 1914 |
c CALL JLMAP (16,PL,AJL(1,1,13),SCALE,DXYPPO,ONES,LM,1,1) 2345. |
| 1915 |
cc CALL JLMAP (99,PL,AJL(1,1,55),SCALE,DXYPPO,ONES,LM,1,1) |
| 1916 |
c SCALE for 0.01K/DAY |
| 1917 |
SCALE=100.*SDAY*IDACC(4)*BYIAC3/DTCNDS |
| 1918 |
CALL JLMAP (14,PL,AJL(1,1,11),SCALE,BYP,ONES,LM,2,1) |
| 1919 |
CALL JLMAP (15,PL,AJL(1,1,12),SCALE,BYP,ONES,LM,2,1) |
| 1920 |
CALL JLMAP (16,PL,AJL(1,1,13),SCALE,BYP,ONES,LM,2,1) |
| 1921 |
c CALL JLMAP (99,PL,AJL(1,1,55),SCALE,BYP,ONES,LM,2,1) |
| 1922 |
C**** 2347. |
| 1923 |
C**** CALCULATIONS FOR STANDING EDDIES 2348. |
| 1924 |
C**** 2349. |
| 1925 |
IF(SKIPSE.EQ.1.) GO TO 282 2350. |
| 1926 |
DO 255 J=2,JM 2351. |
| 1927 |
DO 255 L=1,LM 2352. |
| 1928 |
AX(J,L)=0. 2353. |
| 1929 |
BX(J,L)=0. 2354. |
| 1930 |
255 CX(J,L)=0. 2355. |
| 1931 |
DO 280 J=2,JM 2356. |
| 1932 |
DO 260 I=1,IM 2357. |
| 1933 |
260 SENDEG(I,J)=0. 2358. |
| 1934 |
DO 280 L=1,LM 2359. |
| 1935 |
PU4TI=0. 2360. |
| 1936 |
PV4TI=0. 2361. |
| 1937 |
DE16TI=0. 2362. |
| 1938 |
SKE4I=0. 2363. |
| 1939 |
SNDEGI=0. 2364. |
| 1940 |
SNAM4I=0. 2365. |
| 1941 |
DO 270 I=1,IM 2366. |
| 1942 |
PU4TI=PU4TI+AIJL(I,J,L,1) 2367. |
| 1943 |
PV4TI=PV4TI+AIJL(I,J,L,2) 2368. |
| 1944 |
DE16TI=DE16TI+AIJL(I,J,L,3) 2369. |
| 1945 |
SKE4I=SKE4I+(AIJL(I,J,L,1)*AIJL(I,J,L,1) 2370. |
| 1946 |
* +AIJL(I,J,L,2)*AIJL(I,J,L,2))/AIJ(I,J,8) 2371. |
| 1947 |
SNDEGI=SNDEGI+(AIJL(I,J,L,3)*AIJL(I,J,L,2)/AIJ(I,J,8)) 2372. |
| 1948 |
SENDEG(I,J)=SENDEG(I,J) 2373. |
| 1949 |
* +DSIG(L)*(AIJL(I,J,L,3)*AIJL(I,J,L,2)/AIJ(I,J,8)) 2374. |
| 1950 |
SNAM4I=SNAM4I+AIJL(I,J,L,1)*AIJL(I,J,L,2)/AIJ(I,J,8) 2375. |
| 1951 |
270 CONTINUE 2376. |
| 1952 |
AX(J,L)=SKE4I-(PU4TI*PU4TI+PV4TI*PV4TI)/APJ(J,2) 2377. |
| 1953 |
SZNDEG=DE16TI*PV4TI/APJ(J,2) 2378. |
| 1954 |
BX(J,L)=SNDEGI-SZNDEG 2379. |
| 1955 |
SZNDEG=SZNDEG*DSIG(L)/FIM 2380. |
| 1956 |
DO 275 I=1,IM 2381. |
| 1957 |
275 SENDEG(I,J)=SENDEG(I,J)-SZNDEG 2382. |
| 1958 |
280 CX(J,L)=SNAM4I-PU4TI*PV4TI/APJ(J,2) 2383. |
| 1959 |
C**** 2384. |
| 1960 |
C**** ENERGY 2385. |
| 1961 |
C**** 2386. |
| 1962 |
C**** STANDING EDDY, EDDY, AND TOTAL KINETIC ENERGY 2387. |
| 1963 |
282 SCALE=12.5E-4*BYIMDA/GRAV 2388. |
| 1964 |
285 DO 288 L=1,LM 2391. |
| 1965 |
DO 288 J=2,JM 2392. |
| 1966 |
288 AX(J,L)=AJL(J,L,14) 2393. |
| 1967 |
c CALL JLMAP (18,PL,AX,BYIMDA,ONES,ONES,LM,2,2) 2394. |
| 1968 |
C |
| 1969 |
DO L=1,LM |
| 1970 |
DO J=2,JM |
| 1971 |
AX(J,L)=AJL(J,L,15) |
| 1972 |
enddo |
| 1973 |
enddo |
| 1974 |
c CALL JLMAP (19,PL,AX,BYIMDA,ONES,ONES,LM,2,2) |
| 1975 |
CALL JLMAP (19,PL,AX,SCALE,ONES,ONES,LM,2,2) |
| 1976 |
C**** AVAILABLE POTENTIAL ENERGY, POTENTIAL TEMPERATURE AND VORTICITY 2396. |
| 1977 |
SCALE=50.E-5*RGAS*BYIMDA/GRAV 2397. |
| 1978 |
CALL JLMAP (20,PL,AJL(1,1,16),SCALE,ONES,ONES,LM,2,1) 2398. |
| 1979 |
DO 298 LR=1,3 2399. |
| 1980 |
DO 298 J=1,JM 2400. |
| 1981 |
298 ARQX(J,LR)=ASJL(J,LR,1)*BYIMDA*ONESPO(J)+273.16 2401. |
| 1982 |
CALL JLMAPS (21,PL,AJL(1,1,17),P1000K,BYP,ONES,LM,2,1, 2402. |
| 1983 |
* ARQX,P1000K,ONES,BYPKS) 2403. |
| 1984 |
C**** 2406. |
| 1985 |
C**** NORTHWARD TRANSPORTS 2407. |
| 1986 |
C**** 2408. |
| 1987 |
C**** NORTHWARD TRANSPORT OF SENSIBLE HEAT BY EDDIES 2409. |
| 1988 |
SCALE=6.25E-14*SHA*BYIADA/GRAV 2410. |
| 1989 |
DO 302 L=1,LM 2411. |
| 1990 |
DO 302 J=2,JM 2412. |
| 1991 |
302 AX(J,L)=AJL(J,L,21)-AJL(J,L,20) 2413. |
| 1992 |
CALL JLMAP (88,PL,AX,SCALE,DXV,ONES,LM,1,2) 2414. |
| 1993 |
c Total NORTHWARD TRANSPORT OF SENSIBLE HEAT |
| 1994 |
do L=1,LM |
| 1995 |
do J=2,Jm |
| 1996 |
AX(J,L)=AJL(J,L,21) |
| 1997 |
end do |
| 1998 |
end do |
| 1999 |
SCALE=6.25E-15*SHA*BYIADA/GRAV |
| 2000 |
CALL JLMAP (89,PL,AX,SCALE,DXV,ONES,LM,1,2) |
| 2001 |
c |
| 2002 |
C**** NORTHWARD TRANSPORT OF DRY STATIC ENERGY BY STANDING EDDIES, 2415. |
| 2003 |
C**** EDDIES, AND TOTAL 2416. |
| 2004 |
SCALE=6.25E-14*BYIADA/GRAV 2417. |
| 2005 |
IF(SKIPSE.EQ.1.) GO TO 320 2418. |
| 2006 |
CALL JLMAP (22,PL,BX,SCALE,DXV,ONES,LM,1,2) 2419. |
| 2007 |
320 DO 330 L=1,LM 2420. |
| 2008 |
DO 330 J=2,JM 2421. |
| 2009 |
AX(J,L)=SHA*(AJL(J,L,21)-AJL(J,L,20))+(AJL(J,L,23)-AJL(J,L,22)) 2422. |
| 2010 |
330 BX(J,L)=SHA*AJL(J,L,21)+AJL(J,L,23) 2423. |
| 2011 |
CALL JLMAP (23,PL,AX,SCALE,DXV,ONES,LM,1,2) 2424. |
| 2012 |
SCALE=SCALE*.1 2425. |
| 2013 |
CALL JLMAP (24,PL,BX,SCALE,DXV,ONES,LM,1,2) 2426. |
| 2014 |
C**** NORTHWARD TRANSPORT OF LATENT HEAT BY EDDIES AND TOTAL 2427. |
| 2015 |
DO 336 L=1,LM 2428. |
| 2016 |
DO 336 J=2,JM 2429. |
| 2017 |
DX(J,L)=AJL(J,L,25)-AJL(J,L,24) 2430. |
| 2018 |
336 AX(J,L)=AX(J,L)+LHE*DX(J,L) 2431. |
| 2019 |
SCALE=6.25E-13*LHE*BYIADA/GRAV 2433. |
| 2020 |
CALL JLMAP (25,PL,DX,SCALE,DXV,ONES,LM,1,2) 2434. |
| 2021 |
SCALE=SCALE*.1 2435. |
| 2022 |
CALL JLMAP (26,PL,AJL(1,1,25),SCALE,DXV,ONES,LM,1,2) 2436. |
| 2023 |
C NORTHWARD TRANSPORT OF LATENT HEAT BY HOR. DIFF. |
| 2024 |
c |
| 2025 |
CALL JLMAP (99,PL,AJL(1,1,55),SCALE,DXV,ONES,LM,1,2) |
| 2026 |
c |
| 2027 |
C**** NORTHWARD TRANSPORT OF STATIC ENERGY BY EDDIES AND TOTAL 2437. |
| 2028 |
DO 340 L=1,LM 2437.11 |
| 2029 |
DO 340 J=2,JM 2437.12 |
| 2030 |
340 DX(J,L)=BX(J,L)+LHE*AJL(J,L,25) 2437.13 |
| 2031 |
SCALE=6.25E-14*BYIADA/GRAV 2438. |
| 2032 |
CALL JLMAP (27,PL,AX,SCALE,DXV,ONES,LM,1,2) 2439. |
| 2033 |
SCALE=SCALE*.1 2440. |
| 2034 |
CALL JLMAP (28,PL,DX,SCALE,DXV,ONES,LM,1,2) 2441. |
| 2035 |
C**** NORTHWARD TRANSPORT OF KINETIC ENERGY 2442. |
| 2036 |
SCALE=6.25E-12*BYIADA/GRAV |
| 2037 |
CALL JLMAP (30,PL,AJL(1,1,27),SCALE,DXV,ONES,LM,1,2) |
| 2038 |
C**** NOR. TRANS. OF ANG. MOMENTUM BY STANDING EDDIES, EDDIES AND TOTAL 2445. |
| 2039 |
SCALE=25.E-18*RADIUS*BYIADA/GRAV 2446. |
| 2040 |
IF(SKIPSE.EQ.1.) GO TO 350 2447. |
| 2041 |
CALL JLMAP (31,PL,CX,SCALE,DXCOSV,ONES,LM,1,2) 2448. |
| 2042 |
350 DO 360 L=1,LM 2449. |
| 2043 |
DO 360 J=2,JM 2450. |
| 2044 |
CX(J,L)=AJL(J,L,49)-AJL(J,L,48) 2451. |
| 2045 |
360 DX(J,L)=AJL(J,L,49)+RADIUS*OMEGA*COSV(J)*AJL(J,L,5) 2452. |
| 2046 |
CALL JLMAP (32,PL,CX,SCALE,DXCOSV,ONES,LM,1,2) 2453. |
| 2047 |
SCALE=.1*SCALE 2454. |
| 2048 |
CALL JLMAP (33,PL,DX,SCALE,DXCOSV,ONES,LM,1,2) 2455. |
| 2049 |
C**** NOR. TRANSPORT OF QUASI-GEOSTROPHIC POT. VORTICITY BY EDDIES 2456. |
| 2050 |
C**** 2501. |
| 2051 |
C**** VERTICAL TRANSPORTS 2502. |
| 2052 |
C**** 2503. |
| 2053 |
C**** VERTICAL TRANSPORT OF GEOPOTENTIAL ENERGY BY EDDIES 2504. |
| 2054 |
C**** VERTICAL TRANSPORT OF DRY STATIC ENERGY BY EDDIES AND TOTAL 2507. |
| 2055 |
DO 390 L=1,LMM1 2508. |
| 2056 |
DO 390 J=1,JM 2509. |
| 2057 |
AX(J,L)=AJL(J,L,31)-AJL(J,L,30) 2510. |
| 2058 |
390 BX(J,L)=AJL(J,L,33)-AJL(J,L,32) 2511. |
| 2059 |
SCALE=-50.E-12*BYIADA/GRAV 2512. |
| 2060 |
CALL JLMAP (34,PLE,AX,SCALE,ONESPO,ONES,LMM1,1,1) 2513. |
| 2061 |
SCALE=SCALE*.01 2514. |
| 2062 |
CALL JLMAP (35,PLE,AJL(1,1,31),SCALE,ONESPO,ONES,LMM1,1,1) 2515. |
| 2063 |
C**** VERTICAL TRANSPORT OF LATENT HEAT BY EDDIES AND TOTAL 2516. |
| 2064 |
SCALE=-200.E-12*LHE*BYIADA/GRAV 2517. |
| 2065 |
CALL JLMAP (36,PLE,BX,SCALE,ONESPO,ONES,LMM1,1,1) 2518. |
| 2066 |
SCALE=SCALE*.1 2519. |
| 2067 |
CALL JLMAP (37,PLE,AJL(1,1,33),SCALE,ONESPO,ONES,LMM1,1,1) 2520. |
| 2068 |
C**** VERTICAL TRANSPORT OF STATIC ENERGY BY EDDIES AND TOTAL 2521. |
| 2069 |
DO 420 L=1,LMM1 2522. |
| 2070 |
DO 420 J=1,JM 2523. |
| 2071 |
AX(J,L)=AX(J,L)+4.*LHE*BX(J,L) 2524. |
| 2072 |
420 BX(J,L)=AJL(J,L,31)+4.*LHE*AJL(J,L,33) 2525. |
| 2073 |
SCALE=-50.E-13*BYIADA/GRAV 2526. |
| 2074 |
CALL JLMAP (38,PLE,AX,SCALE,ONESPO,ONES,LMM1,1,1) 2527. |
| 2075 |
SCALE=SCALE*.1 2528. |
| 2076 |
CALL JLMAP (39,PLE,BX,SCALE,ONESPO,ONES,LMM1,1,1) 2529. |
| 2077 |
C**** VERTICAL TRANSPORT OF KINETIC ENERGY 2530. |
| 2078 |
C**** VERTICAL TRANSPORT OF ANGULAR MOMENTUM BY LARGE SCALE MOTIONS 2533. |
| 2079 |
SCALE=-12.5E-16*RADIUS*BYIADA/GRAV 2534. |
| 2080 |
CALL JLMAP (42,PLE,AJL(1,1,36),SCALE,COSV,ONES,LMM1,1,2) 2535. |
| 2081 |
SCALE=1.E-2*SCALE 2536. |
| 2082 |
CALL JLMAP (43,PLE,AJL(1,1,37),SCALE,COSV,ONES,LMM1,1,2) 2537. |
| 2083 |
C**** VERTICAL TRANSPORT OF ANGULAR MOMENTUM BY SMALL SCALE MOTIONS 2538. |
| 2084 |
SCALE=100.E-18*RADIUS*BYIAC3/(GRAV*DTCNDS) 2539. |
| 2085 |
CALL JLMAP (44,PL,AJL(1,1,38),SCALE,DACOSV,ONES,LM,1,2) 2540. |
| 2086 |
CALL JLMAP (45,PL,AJL(1,1,39),SCALE,DACOSV,ONES,LM,1,2) 2541. |
| 2087 |
C CALL JLMAP (46,PL,AJL(1,1,40),SCALE,DACOSV,BYDSIG,LM,1,2) 2542. |
| 2088 |
IF(JM.NE.24) GO TO 425 2543. |
| 2089 |
IF(IM.EQ.1) GO TO 425 2543.5 |
| 2090 |
C**** 2544. |
| 2091 |
C**** MERIDIONAL LUNES 2545. |
| 2092 |
C**** 2546. |
| 2093 |
C**** U, V AND W VELOCITY FOR I=5-9 2547. |
| 2094 |
SCALE=.2E+1*BYIADA 2548. |
| 2095 |
C CALL JLMAP (47,PL,AJL(1,1,41),SCALE,ONES,ONES,LM,2,2) 2549. |
| 2096 |
c CALL JLMAP (48,PL,AJL(1,1,42),SCALE,ONES,ONES,LM,2,2) 2550. |
| 2097 |
c SCALE2=-1.E5*BYIADA*RGAS/(5.*GRAV) 2551. |
| 2098 |
c CALL JLMAP (49,PLE,AJL(1,1,43),SCALE2,BYDXYP,ONES,LMM1,2,1) 2552. |
| 2099 |
C**** U, V AND W VELOCITY FOR I=35-3 2553. |
| 2100 |
C CALL JLMAP (50,PL,AJL(1,1,44),SCALE,ONES,ONES,LM,2,2) 2554. |
| 2101 |
c CALL JLMAP (51,PL,AJL(1,1,45),SCALE,ONES,ONES,LM,2,2) 2555. |
| 2102 |
c CALL JLMAP (52,PLE,AJL(1,1,46),SCALE2,BYDXYP,ONES,LMM1,2,1) 2556. |
| 2103 |
C**** 2557. |
| 2104 |
C**** LATITUDINAL ZONES 2558. |
| 2105 |
C**** 2559. |
| 2106 |
C**** U, V AND W VELOCITY FOR J=11-13 VS. LONGITUDE 2560. |
| 2107 |
SCALE=BYIADA/3. 2561. |
| 2108 |
CALL ILMAP (61,PL,AIL(1,1,1),SCALE,ONES,LM,2,2) 2562. |
| 2109 |
C CALL ILMAP (62,PL,AIL(1,1,2),SCALE,ONES,LM,2,2) 2563. |
| 2110 |
SCALE =-1.E4*BYIADA*RGAS/(GRAV*(DXYP(11)+DXYP(12)+DXYP(13))) 2564. |
| 2111 |
CALL ILMAP (63,PLE,AIL(1,1,3),SCALE,ONES,LMM1,2,1) 2565. |
| 2112 |
C**** TEMPERATURE, RELATIVE HUMIDITY, MOIS CONVECTIVE HEATING, AND 2566. |
| 2113 |
C**** RADIATIVE COOLING FOR J=11-13 VS. LONGITUDE 2567. |
| 2114 |
SCALE=BYIADA/3. 2568. |
| 2115 |
CALL ILMAP (64,PL,AIL(1,1,4),SCALE,ONES,LM,2,1) 2569. |
| 2116 |
SCALE=1.E2*SCALE 2570. |
| 2117 |
CALL ILMAP (65,PL,AIL(1,1,5),SCALE,ONES,LM,2,1) 2571. |
| 2118 |
SCALE=100.E-13*SHA*BYIAC3/(GRAV*DTCNDS) 2572. |
| 2119 |
CALL ILMAP (66,PL,AIL(1,1,6),SCALE,ONES,LM,1,1) 2573. |
| 2120 |
SCALE=-1.E-13*BYIARD 2574. |
| 2121 |
CALL ILMAP (67,PL,AIL(1,1,7),SCALE,BYDSIG,LM,1,1) 2575. |
| 2122 |
C**** AT J=19: W VELOCITY, TEMPERATURE, RADIATION, AND U VELOCITY 2576. |
| 2123 |
C SCALE =-1.E4*BYIADA*RGAS/(GRAV* DXYP(19)) 2577. |
| 2124 |
C CALL ILMAP (69,PLE,AIL(1,1,9),SCALE,ONES,LMM1,2,1) 2578. |
| 2125 |
CALL ILMAP (70,PL,AIL(1,1,10),BYIADA,ONES,LM,2,1) 2579. |
| 2126 |
C SCALE=-1.E-13*BYIARD 2580. |
| 2127 |
C CALL ILMAP (71,PL,AIL(1,1,11),SCALE,BYDSIG,LM,1,1) 2581. |
| 2128 |
SCALE=BYIADA/2. 2582. |
| 2129 |
CALL ILMAP (72,PL,AIL(1,1,12),SCALE,ONES,LM,2,2) 2583. |
| 2130 |
C**** AT J=21: W VELOCITY, TEMPERATURE, RADIATION, AND U VELOCITY 2584. |
| 2131 |
C SCALE =-1.E4*BYIADA*RGAS/(GRAV* DXYP(21)) 2585. |
| 2132 |
C CALL ILMAP (73,PLE,AIL(1,1,13),SCALE,ONES,LMM1,2,1) 2586. |
| 2133 |
C CALL ILMAP (74,PL,AIL(1,1,14),BYIADA,ONES,LM,2,1) 2587. |
| 2134 |
C SCALE=-1.E-13*BYIARD 2588. |
| 2135 |
C CALL ILMAP (75,PL,AIL(1,1,15),SCALE,BYDSIG,LM,1,1) 2589. |
| 2136 |
C SCALE=BYIADA/2. 2590. |
| 2137 |
C CALL ILMAP (76,PL,AIL(1,1,16),SCALE,ONES,LM,2,2) 2591. |
| 2138 |
425 CONTINUE 2591.5 |
| 2139 |
C**** 2592. |
| 2140 |
C**** ELIASSEN-PALM FLUX : NORTHWARD, VERTICAL, DIVERGENCE 2593. |
| 2141 |
C**** 2594. |
| 2142 |
SCALE=100.E-17*BYIADA*RADIUS/GRAV 2595. |
| 2143 |
DXCVS=DXCOSV(2) 2599. |
| 2144 |
DO 540 J=2,JMM1 2600. |
| 2145 |
BDN=0. 2601. |
| 2146 |
DXCVN=DXCOSV(J+1) 2603. |
| 2147 |
DO 530 L=1,LM 2604. |
| 2148 |
BUP=AJL(J,L,44)*COSP(J) 2605. |
| 2149 |
AX(J,L)=AJL(J+1,L,41)*DXCVN-AJL(J,L,41)*DXCVS+ 2606. |
| 2150 |
* .125*(BUP-BDN)/DSIG(L) 2607. |
| 2151 |
530 BDN=BUP 2608. |
| 2152 |
540 DXCVS=DXCVN 2609. |
| 2153 |
DO 550 L=1,LM 2610. |
| 2154 |
AX(1,L)=0. 2611. |
| 2155 |
550 AX(JM,L)=0. 2612. |
| 2156 |
CALL JLMAP(94,PL,AX,SCALE,ONES,ONES,LM,1,1) 2613. |
| 2157 |
C**** 2614. |
| 2158 |
C**** 2615. |
| 2159 |
C**** D/DY OF QUASI-GEOSTROPHIC POTENTIAL VORTICITY 2616. |
| 2160 |
C**** 2617. |
| 2161 |
IF(KMT.EQ.1) RETURN 2617.5 |
| 2162 |
AMA=2.*OMEGA/RADIUS 2618. |
| 2163 |
PTOPI=PTOP*FIMDA 2619. |
| 2164 |
DO 580 L=1,LM 2620. |
| 2165 |
LUP=L+1 2621. |
| 2166 |
IF (L.EQ.LM) LUP=LM 2622. |
| 2167 |
LDN=L-1 2623. |
| 2168 |
IF (L.EQ.1) LDN=1 2624. |
| 2169 |
DO 570 J=2,JMM1 2625. |
| 2170 |
AX(J,L)=F(J)*AJL(J,L,17)/(DXYP(J)*(AJL(J,L,1)*BYP(J)+273.16) * 2626. |
| 2171 |
* (AJL(J,LUP,17)-AJL(J,LDN,17))+1.E-20) 2627. |
| 2172 |
BX(J,L)=((AJL(J,LUP,1)*BYP(J)+273.16)/(APJ(J,1)*SIG(LUP)+PTOPI)- 2628. |
| 2173 |
* (AJL(J,LDN,1)*BYP(J)+273.16)/(APJ(J,1)*SIG(LDN)+PTOPI))*BYP(J) 2629. |
| 2174 |
CX(J,L)=(AJL(J,L,4)*BYPV(J)*DXV(J)- 2630. |
| 2175 |
* AJL(J+1,L,4)*BYPV(J+1)*DXV(J+1))/DXYP(J) 2631. |
| 2176 |
570 CONTINUE 2632. |
| 2177 |
DX(2,L)=0. 2633. |
| 2178 |
DX(JM,L)=0. 2634. |
| 2179 |
DO 580 J=3,JMM1 2635. |
| 2180 |
DX(J,L)=AMA*COSV(J) + (CX(J,L)-CX(J-1,L) + 2636. |
| 2181 |
* .125*(AX(J,L)+AX(J-1,L))*APJ(J,2)*(.25*APJ(J,2)*SIG(L)+PTOPI)* 2637. |
| 2182 |
* (BX(J,L)-BX(J-1,L)))/DYV(3) 2638. |
| 2183 |
580 CONTINUE 2639. |
| 2184 |
CALL JLMAP(56,PL,DX,1.E12,ONES,ONES,LM,2,2) 2640. |
| 2185 |
C**** 2641. |
| 2186 |
C**** REFRACTION INDICES FOR WAVES 1 AND 2 2642. |
| 2187 |
C**** 2643. |
| 2188 |
DO 590 L=1,LM 2644. |
| 2189 |
AX(2,L)=0. 2645. |
| 2190 |
AX(JM,L)=0. 2646. |
| 2191 |
LUP=L+1 2647. |
| 2192 |
LDN=L-1 2648. |
| 2193 |
IF(L.EQ.LM) LUP=LM 2649. |
| 2194 |
IF(L.EQ.1) LDN=1 2650. |
| 2195 |
DO 590 J=3,JMM1 2651. |
| 2196 |
GBYF=GRAV*DXYP(J)/F(J) 2652. |
| 2197 |
SQNBYF=-GBYF*GBYF*(SIG(L)+PTOP*BYP(J)*FIMDA)* 2653. |
| 2198 |
* (AJL(J,LUP,17)-AJL(J,LDN,17))*BYD2SG(L)/ 2654. |
| 2199 |
* (RGAS*(AJL(J,L,1)*BYP(J)+273.16)*(AJL(J,L,17)+1.E-20)) 2655. |
| 2200 |
BX(J,L)=SQNBYF 2656. |
| 2201 |
590 CX(J,L)=DX(J,L)*APJ(J,2)/AJL(J,L,4) 2657. |
| 2202 |
DO 605 M=1,5 2658. |
| 2203 |
SQM=MW(M)*MW(M) 2659. |
| 2204 |
DO 600 J=3,JMM1 2660. |
| 2205 |
BYRCOS=1./(RADIUS*RADIUS*COSV(J)*COSV(J)) 2661. |
| 2206 |
DO 600 L=1,LM 2662. |
| 2207 |
BYHSQ=1./(3434.*(AJL(J,L,1)*BYP(J)+273.16)**2) 2663. |
| 2208 |
600 AX(J,L)=BX(J,L)*(CX(J,L)-SQM*BYRCOS)-BYHSQ 2664. |
| 2209 |
IT=ITIT(M) 2665. |
| 2210 |
605 CALL JLMAP(IT,PL,AX,1.E8,ONES,ONES,LM,2,2) 2666. |
| 2211 |
C**** 2667. |
| 2212 |
C**** FOURIER ANALYSIS OF GEOPOTENTIAL HEIGHTS FOR WAVE NUMBERS 1 TO 4, 2668. |
| 2213 |
C**** AMPLITUDE AND PHASE 2669. |
| 2214 |
C**** 2670. |
| 2215 |
c LSKIPM=LINECT-63 2671. |
| 2216 |
c DO 810 LSKIP=1,LSKIPM 2672. |
| 2217 |
c 810 WRITE (6,920) 2673. |
| 2218 |
c LINECT=63 2674. |
| 2219 |
DO 620 K=1,KM 2675. |
| 2220 |
DO 610 N=1,4 2676. |
| 2221 |
AMPLTD(1,K,N)=0. 2677. |
| 2222 |
AMPLTD(JM,K,N)=0. 2678. |
| 2223 |
PHASE(1,K,N)=0. 2679. |
| 2224 |
610 PHASE(JM,K,N)=0. 2680. |
| 2225 |
DO 620 J=2,JMM1 2681. |
| 2226 |
CALL GETAN (AIJ(1,J,8+K),CN) 2682. |
| 2227 |
DO 620 N=1,4 2683. |
| 2228 |
AMPLTD(J,K,N)=SQRT(CN(1,N+1)*CN(1,N+1)+CN(2,N+1)*CN(2,N+1)) 2684. |
| 2229 |
PHASE(J,K,N)=(ATAN2(CN(2,N+1),CN(1,N+1))-TWOPI)/N+ELOFIM 2685. |
| 2230 |
IF(PHASE(J,K,N).LE.-.5*TWOPI) PHASE(J,K,N)=PHASE(J,K,N)+TWOPI 2686. |
| 2231 |
PHASE(J,K,N)=-PHASE(J,K,N) 2687. |
| 2232 |
620 CONTINUE 2688. |
| 2233 |
SCALE=BYIADA/GRAV 2689. |
| 2234 |
DO 630 N=1,4 2690. |
| 2235 |
630 CALL JLMAP (79+N,PMB,AMPLTD(1,1,N),SCALE,ONES,ONES,KM,2,1) 2691. |
| 2236 |
SCALE=360./TWOPI 2692. |
| 2237 |
DO 640 N=1,4 2693. |
| 2238 |
640 CALL JLMAP (83+N,PMB,PHASE(1,1,N),SCALE,ONES,ONES,KM,2,1) 2694. |
| 2239 |
c LSKIPM=64-LINECT 2695. |
| 2240 |
c DO 860 LSKIP=1,LSKIPM 2696. |
| 2241 |
c 860 WRITE (6,920) 2697. |
| 2242 |
RETURN 2698. |
| 2243 |
901 FORMAT (/////// 2699. |
| 2244 |
* '010**14 WATTS = .2067 * 10**19 CALORIES/DAY'/ 2700. |
| 2245 |
* '010**18 JOULES = .864 * 10**30 GM*CM**2/SEC/DAY'/ 2701. |
| 2246 |
* '0ALL NORTHWARD TRANSPORTS ARE PER UNIT SIGMA') 2702. |
| 2247 |
920 FORMAT (1X) 2703. |
| 2248 |
END 2704. |
| 2249 |
SUBROUTINE JLMAP (NT,PL,AX,SCALE,SCALEJ,SCALEL,LMAX,JWT,J1) 2801. |
| 2250 |
#include "BD2G04.COM" 2802. |
| 2251 |
COMMON U,V,T,P,Q 2803. |
| 2252 |
COMMON/WORK4/MLAT(46),FLAT(46),ASUM(46),FHEM(2),HSUM(2) 2806. |
| 2253 |
COMMON/D2COM/JLAT(46,2),WTJ(46,2,2), 2807. |
| 2254 |
* LINECT,JMHALF,INC,IHOUR0,IHOUR,I25,TAUDIF 2808. |
| 2255 |
COMMON/D2TTL/TITLE(1) 2808.1 |
| 2256 |
common/nqt/NQMAPS |
| 2257 |
DIMENSION AX(JM0,*),ARQX(JM0,*) 2809. |
| 2258 |
DIMENSION PL(*),SCALEJ(*),SCALEL(*),SCALJR(*),SCALLR(*) 2810. |
| 2259 |
CHARACTER*4 DASH,WORD(4),TITLE*64 2810.1 |
| 2260 |
DATA DASH/'----'/,WORD/'SUM','MEAN',' ','.1*'/ 2811. |
| 2261 |
C**** 2812. |
| 2262 |
C**** PRODUCE A LATITUDE BY LAYER TABLE OF THE ARRAY A 2813. |
| 2263 |
C**** 2814. |
| 2264 |
10 LINECT=LINECT+LMAX+7 2815. |
| 2265 |
c IF(LINECT.LE.63) GO TO 20 2816. |
| 2266 |
c LSKIPM=64-LINECT+LMAX+7 2817. |
| 2267 |
c DO 15 LSKIP=1,LSKIPM 2818. |
| 2268 |
c 15 WRITE (6,920) 2819. |
| 2269 |
JY0=JYEAR0-1900 2820. |
| 2270 |
JY=JYEAR-1900 2821. |
| 2271 |
c WRITE (6,907) (XLABEL(K),K=1,27),JDATE0,JMNTH0,JY0,JDATE,JMONTH,JY2822. |
| 2272 |
c LINECT=LMAX+8 2823. |
| 2273 |
c 20 WRITE (6,901) TITLE(NT),(DASH,J=J1,JM,INC) 2824. |
| 2274 |
c WRITE (6,904) WORD(JWT),(JLAT(JM+J1-J,J1),J=J1,JM,INC) 2825. |
| 2275 |
c WRITE (6,905) (DASH,J=J1,JM,INC) 2826. |
| 2276 |
J0=J1-1 2827. |
| 2277 |
100 SDSIG=1.-SIGE(LMAX+1) 2828. |
| 2278 |
DO 110 J=J1,JM 2829. |
| 2279 |
110 ASUM(J)=0. 2830. |
| 2280 |
HSUM(1)=0. 2831. |
| 2281 |
HSUM(2)=0. 2832. |
| 2282 |
GSUM=0. 2833. |
| 2283 |
SUMFAC=1. 2834. |
| 2284 |
IWORD=3 2835. |
| 2285 |
IF(NT.NE.1.AND.NT.NE.24.AND.NT.NE.26.AND.NT.NE.28.AND.NT.NE.33) 2836. |
| 2286 |
* GO TO 112 2837. |
| 2287 |
SUMFAC=10. 2838. |
| 2288 |
IWORD=4 2839. |
| 2289 |
112 DO 140 LX=1,LMAX 2840. |
| 2290 |
L=1+LMAX-LX 2841. |
| 2291 |
FGLOB=0. 2842. |
| 2292 |
DO 130 JHEMI=1,2 2843. |
| 2293 |
FHEM(JHEMI)=0. 2844. |
| 2294 |
DO 120 JH=1,JMHALF 2845. |
| 2295 |
J=(JHEMI-1)*(JMHALF-J0)+JH+J0 2846. |
| 2296 |
FLAT(J)=AX(J,L)*SCALE*SCALEJ(J)*SCALEL(L) 2847. |
| 2297 |
MLAT(J)=INT(FLAT(J)+10000.5)-10000 2848. |
| 2298 |
115 ASUM(J)=ASUM(J)+FLAT(J)*DSIG(L)/SDSIG 2849. |
| 2299 |
120 FHEM(JHEMI)=FHEM(JHEMI)+FLAT(J)*WTJ(J,JWT,J1) 2850. |
| 2300 |
130 FGLOB=FGLOB+FHEM(JHEMI)/JWT 2851. |
| 2301 |
if(NT.eq.-102)then |
| 2302 |
print *,' JLMAP NT=',NT |
| 2303 |
print *,AX(12,1),SCALE,SCALEJ(12) |
| 2304 |
print *,SCALEL(1),SCALEL(LM) |
| 2305 |
endif |
| 2306 |
c WRITE (6,902) PL(L),FGLOB,FHEM(2),FHEM(1), 2852. |
| 2307 |
c * (MLAT(JM+J1-J),J=J1,JM,INC) 2853. |
| 2308 |
do 136 INDEXQ=1,NQTAB |
| 2309 |
IF(INQTAB(INDEXQ).NE.NT) GO TO 136 2860. |
| 2310 |
if(L.eq.-1)then |
| 2311 |
print *,' INDEXQ=',INDEXQ,INQTAB(INDEXQ) |
| 2312 |
print *,' NT=',nt |
| 2313 |
print *,TITLE( NT) |
| 2314 |
endif |
| 2315 |
J1QT(INDEXQ)=J1 |
| 2316 |
DO 134 J=J1,JM 2861. |
| 2317 |
134 QTABLE(J,L,INDEXQ)=FLAT(J) 2862. |
| 2318 |
QTABLE(JM+1,L,INDEXQ)=FHEM(1) 2863. |
| 2319 |
QTABLE(JM+2,L,INDEXQ)=FHEM(2) 2864. |
| 2320 |
QTABLE(JM+3,L,INDEXQ)=FGLOB 2865. |
| 2321 |
136 CONTINUE |
| 2322 |
IF(NT.EQ.5) CALL KEYD2J (L,FLAT) 2854. |
| 2323 |
IF(NT.EQ.7) CALL KEYD2S (L,FLAT) 2855. |
| 2324 |
HSUM(1)=HSUM(1)+FHEM(1)*SUMFAC*DSIG(L)/SDSIG 2866. |
| 2325 |
HSUM(2)=HSUM(2)+FHEM(2)*SUMFAC*DSIG(L)/SDSIG 2867. |
| 2326 |
140 GSUM=GSUM+FGLOB*SUMFAC*DSIG(L)/SDSIG 2868. |
| 2327 |
ASUM(JMHALF+1)=ASUM(JMHALF+1)/J1 2869. |
| 2328 |
DO 150 J=J1,JM 2870. |
| 2329 |
150 MLAT(J)=INT(ASUM(J)*SUMFAC+10000.5)-10000 2871. |
| 2330 |
c WRITE (6,905) (DASH,J=J1,JM,INC) 2872. |
| 2331 |
IF(NT.GE.80.AND.NT.LE.87) RETURN 2873. |
| 2332 |
c WRITE (6,903) WORD(IWORD),GSUM,HSUM(2),HSUM(1), 2874. |
| 2333 |
c * (MLAT(JM+J1-J),J=J1,JM,INC) 2875. |
| 2334 |
do 146 INDEXQ=1,NQTAB |
| 2335 |
IF(INQTAB(INDEXQ).NE.NT) GO TO 146 2860. |
| 2336 |
c print *,' JLMAP NT=',NT |
| 2337 |
c J1QT(INDEXQ)=J1 |
| 2338 |
L=LM0+1 |
| 2339 |
c print *,' LM=',L |
| 2340 |
DO 144 J=J1,JM 2861. |
| 2341 |
144 QTABLE(J,L,INDEXQ)=ASUM(J)*SUMFAC |
| 2342 |
QTABLE(JM+1,L,INDEXQ)=HSUM(1) 2863. |
| 2343 |
QTABLE(JM+2,L,INDEXQ)=HSUM(2) 2864. |
| 2344 |
QTABLE(JM+3,L,INDEXQ)=GSUM 2865. |
| 2345 |
146 CONTINUE |
| 2346 |
IF(NT.EQ.1) CALL KEYD2T (GSUM,ASUM) 2876. |
| 2347 |
IF(NT.EQ.18) CALL KEYD2K (ASUM) 2877. |
| 2348 |
IF(NT.GE.22.AND.NT.LE.33) CALL KEYD2N (NT,ASUM,SUMFAC) 2878. |
| 2349 |
c IF(NT.GE.34) RETURN 2879. |
| 2350 |
if(NT.le.43.or.NT.eq.77.or.NT.eq.78.or.NT.eq.79 |
| 2351 |
* .or.(NT.ge.88.and.NT.le.92))then |
| 2352 |
NQMAPS=NQMAPS+1 |
| 2353 |
if(NQMAPS.gt.57) then |
| 2354 |
print *,' NQMAPS GT 57',NQMAPS |
| 2355 |
stop |
| 2356 |
endif |
| 2357 |
INQMAP(NQMAPS)=NT |
| 2358 |
DO 180 J=J1,JM |
| 2359 |
180 QMAPS(J,NQMAPS)=ASUM(J)*SUMFAC |
| 2360 |
QMAPS(JM+1,NQMAPS)=HSUM(1) |
| 2361 |
QMAPS(JM+2,NQMAPS)=HSUM(2) |
| 2362 |
QMAPS(JM+3,NQMAPS)=GSUM |
| 2363 |
end if |
| 2364 |
RETURN 2885. |
| 2365 |
C**** 2886. |
| 2366 |
ENTRY JLMAPS (NT,PL,AX,SCALE,SCALEJ,SCALEL,LMAX,JWT,J1, 2887. |
| 2367 |
* ARQX,SCALER,SCALJR,SCALLR) 2888. |
| 2368 |
c LINECT=LINECT+LMAX+10 2889. |
| 2369 |
c IF(LINECT.LE.63) GO TO 200 2890. |
| 2370 |
c LSKIPM=64-LINECT+LMAX+10 2891. |
| 2371 |
c DO 190 LSKIP=1,LSKIPM 2892. |
| 2372 |
c 190 WRITE (6,920) 2893. |
| 2373 |
c JY0=JYEAR0-1900 2894. |
| 2374 |
c JY=JYEAR-1900 2895. |
| 2375 |
c WRITE (6,907) (XLABEL(K),K=1,27),JDATE0,JMNTH0,JY0,JDATE,JMONTH,JY2896. |
| 2376 |
c LINECT=LMAX+11 2897. |
| 2377 |
c 200 J0=J1-1 2898. |
| 2378 |
C**** PRODUCE UPPER STRATOSPHERE NUMBERS FIRST 2899. |
| 2379 |
c WRITE (6,901) TITLE(NT),(DASH,J=J1,JM,INC) 2900. |
| 2380 |
c WRITE (6,904) WORD(JWT),(JLAT(JM+J1-J,J1),J=J1,JM,INC) 2901. |
| 2381 |
c WRITE (6,905) (DASH,J=J1,JM,INC) 2902. |
| 2382 |
c DO 230 LX=1,3 2903. |
| 2383 |
c L=4-LX 2904. |
| 2384 |
c FGLOB=0. 2905. |
| 2385 |
c DO 220 JHEMI=1,2 2906. |
| 2386 |
c FHEM(JHEMI)=0. 2907. |
| 2387 |
c DO 210 JH=1,JMHALF 2908. |
| 2388 |
c J=(JHEMI-1)*(JMHALF-J0)+JH-J0 2909. |
| 2389 |
c FLATJ=ARQX(J,L)*SCALER*SCALJR(J)*SCALLR(L) 2910. |
| 2390 |
c MLAT(J)=INT(FLATJ+10000.5)-10000 2911. |
| 2391 |
c 210 FHEM(JHEMI)=FHEM(JHEMI)+FLATJ*WTJ(J,JWT,J1) 2912. |
| 2392 |
c 220 FGLOB=FGLOB+FHEM(JHEMI)/JWT 2913. |
| 2393 |
c 230 WRITE (6,902) PL(L+LM),FGLOB,FHEM(2),FHEM(1), 2914. |
| 2394 |
c * (MLAT(JM+J1-J),J=J1,JM,INC) 2915. |
| 2395 |
GO TO 100 2916. |
| 2396 |
901 FORMAT ('0',30X,A64/1X,30('-'),24A4) 2917. |
| 2397 |
902 FORMAT (F6.1,3F8.1,1X,24I4) 2918. |
| 2398 |
903 FORMAT (A6,3F8.1,1X,24I4) 2919. |
| 2399 |
904 FORMAT (' P(MB) ',A4,' G NH SH ',24I4) 2920. |
| 2400 |
905 FORMAT (1X,30('-'),24A4) 2921. |
| 2401 |
907 FORMAT ('1',27A4,I4,1X,A3,I3,' TO',I3,1X,A3,I3) 2922. |
| 2402 |
920 FORMAT (1X) 2923. |
| 2403 |
END 2924. |
| 2404 |
SUBROUTINE ILMAP (NT,PL,AX,SCALE,SCALEL,LMAX,JWT,ISHIFT) 3001. |
| 2405 |
#include "BD2G04.COM" 3002. |
| 2406 |
COMMON U,V,T,P,Q 3003. |
| 2407 |
COMMON/WORK4/MLON(72),ASUM(72) 3004. |
| 2408 |
COMMON/D2TTL/TITLE(1) 3005. |
| 2409 |
COMMON/D2COM/JLAT(46,2),WTJ(46,2,2), 3005.1 |
| 2410 |
* LINECT,JMHALF,INC,IHOUR0,IHOUR,I25,TAUDIF 3006. |
| 2411 |
DIMENSION AX(36,*) 3007. |
| 2412 |
DIMENSION PL(*),SCALEL(*) 3008. |
| 2413 |
CHARACTER*4 DASH,WORD(2),TITLE*64 3008.1 |
| 2414 |
DATA DASH/'----'/,WORD/'SUM','MEAN'/ 3009. |
| 2415 |
C**** 3010. |
| 2416 |
C**** PRODUCE A LONGITUDE BY LAYER TABLE OF THE ARRAY A 3011. |
| 2417 |
C**** 3012. |
| 2418 |
RETURN 3045. |
| 2419 |
901 FORMAT ('0',30X,A64/1X,14('-'),36A3) 3046. |
| 2420 |
902 FORMAT (F6.1,F8.1,1X,36I3) 3047. |
| 2421 |
903 FORMAT (F14.1,1X,36I3) 3048. |
| 2422 |
904 FORMAT (' P(MB)',4X,A4,1X,36I3) 3049. |
| 2423 |
905 FORMAT (1X,14('-'),36A3) 3050. |
| 2424 |
906 FORMAT (' P(MB)',4X,A4,I2,8I3,I4,26I3) 3051. |
| 2425 |
907 FORMAT ('1',27A4,I4,1X,A3,I3,' TO',I3,1X,A3,I3) 3052. |
| 2426 |
920 FORMAT (1X) 3053. |
| 2427 |
END 3054. |
| 2428 |
BLOCK DATA a2 3201. |
| 2429 |
C**** 3202. |
| 2430 |
C**** TITLES FOR SUBROUTINE DIAG7 3203. |
| 2431 |
C**** 3204. |
| 2432 |
COMMON/D7COM/TITLE1,TITLE2 3205. |
| 2433 |
CHARACTER*64 TITLE1(6)/ 3206. |
| 2434 |
C**** 1-6 3207. |
| 2435 |
*'WAVE POWER FOR U NEAR 850 MB AND EQUATOR (DAY*(M/S)**2)', 3208. |
| 2436 |
*'WAVE POWER FOR V NEAR 850 MB AND EQUATOR (DAY*(M/S)**2)', 3210. |
| 2437 |
*'WAVE POWER FOR U NEAR 300 MB AND EQUATOR (10 DAY*(M/S)**2)', 3212. |
| 2438 |
*'WAVE POWER FOR V NEAR 300 MB AND EQUATOR (DAY*(M/S)**2)', 3214. |
| 2439 |
*'WAVE POWER FOR U NEAR 50 MB AND EQUATOR (10 DAY*(M/S)**2)', 3216. |
| 2440 |
*'WAVE POWER FOR V NEAR 50 MB AND EQUATOR (DAY*(M/S)**2)'/ 3218. |
| 2441 |
CHARACTER*64 TITLE2(6)/ 3220. |
| 2442 |
C**** 7-12 3221. |
| 2443 |
*'WAVE POWER FOR PHI AT 922 MB AND 50 DEG NORTH (10**3 DAY*M**2)', 3222. |
| 2444 |
*'WAVE POWER FOR PHI AT 700 MB AND 50 DEG NORTH (10**3 DAY*M**2)', 3224. |
| 2445 |
*'WAVE POWER FOR PHI AT 500 MB AND 50 DEG NORTH (10**3 DAY*M**2)', 3226. |
| 2446 |
*'WAVE POWER FOR PHI AT 300 MB AND 50 DEG NORTH (10**3 DAY*M**2)', 3228. |
| 2447 |
*'WAVE POWER FOR PHI AT 100 MB AND 50 DEG NORTH (10**4 DAY*M**2)', 3230. |
| 2448 |
*'WAVE POWER FOR PHI AT 10 MB AND 50 DEG NORTH (10**4 DAY*M**2)'/ 3232. |
| 2449 |
END 3234. |
| 2450 |
SUBROUTINE DIAG7A 3401. |
| 2451 |
C**** 3402. |
| 2452 |
C**** THIS SUBROUTINE ACCUMULATES A TIME SEQUENCE FOR SELECTED 3403. |
| 2453 |
C**** QUANTITIES AND FROM THAT PRINTS A TABLE OF WAVE FREQUENCIES. 3404. |
| 2454 |
C**** 3405. |
| 2455 |
#include "BD2G04.COM" 3406. |
| 2456 |
COMMON U,V,T,P,Q 3407. |
| 2457 |
COMMON/WORK3/PHI(IM0,JM0,LM0),HTRD(36,6) 3408. |
| 2458 |
c COMMON/WORK4/CN(2,37),POWER(120),IPOWER(41),FPE(31) 3409. |
| 2459 |
COMMON/WORK4/CN(2,37),POWER(120),FPE(31),IPOWER(41) |
| 2460 |
COMMON/D7COM/TITLE 3410. |
| 2461 |
CHARACTER*64 TITLE(12) 3411. |
| 2462 |
DIMENSION JLKDEX(6),SCALE(12),PMB(6),GHT(6) 3412. |
| 2463 |
DATA KM,PMB/6,922.,700.,500.,300.,100.,10./ 3413. |
| 2464 |
DATA NMAX/9/,KQMAX/12/,MMAX/12/,NUAMAX/120/,NUBMAX/15/ 3414. |
| 2465 |
DATA SCALE/1.,1., .1,1., .1,1., 4*1.E-3,1.E-4,1.E-5/ 3415. |
| 2466 |
DATA GHT/500.,2600.,5100.,8500.,15400.,30000./ 3416. |
| 2467 |
DATA IFIRST/1/ 3417. |
| 2468 |
RETURN 3463. |
| 2469 |
C**** 3464. |
| 2470 |
ENTRY DIAG7P 3465. |
| 2471 |
RETURN 3540. |
| 2472 |
C**** 3541. |
| 2473 |
901 FORMAT ('0',30X,A64,8X,'*1/60 (1/DAY)'/' PERIOD EASTWARD--', 3542. |
| 2474 |
* 35('---')/' N -2 *-3 -3.3 -4 -5 -6 -73543. |
| 2475 |
*.5 -10-12-15-20-30-60 60 30 20 15 12 10 7.5 6 5 3544. |
| 2476 |
* 4* VAR ERR'/' --',40('---')) 3545. |
| 2477 |
902 FORMAT (I2,41I3,I4,I4) 3546. |
| 2478 |
903 FORMAT (' --',40('---')/(1X,13F10.4)) 3547. |
| 2479 |
907 FORMAT ('1',27A4,I4,1X,A3,I3,' T0',I3,1X,A3,I3) 3548. |
| 2480 |
911 FORMAT ('0',30X,A64,8X,'*1/60 (1/DAY)'/' PERIOD EASTWARD--', 3549. |
| 2481 |
* 35('---')/ ' N *-4 -5 -6 -7.5 -10-123550. |
| 2482 |
*-15-20-30-60 60 30 20 15 12 10 7.5 6 5 4 3551. |
| 2483 |
* 3.3 3* 2 VAR ERR'/' --',40('---')) 3552. |
| 2484 |
920 FORMAT(1X) 3553. |
| 2485 |
END 3554. |
| 2486 |
SUBROUTINE MEM (SERIES,ITM,MMAX,NUAMAX,NUBMAX,POWER,FPE,VAR,PNU) 3801. |
| 2487 |
DIMENSION C(1800),S(1800),B1(62),B2(62),A(12), 3802. |
| 2488 |
* AA(11),P(13) 3803. |
| 2489 |
DIMENSION SERIES(*),POWER(*),FPE(*) 3804. |
| 2490 |
C**DOUBLE PRECISION 3805. |
| 2491 |
c REAL*8 PI,ARG,PP,POWERX,P,C,S 3806. |
| 2492 |
REAL PI,ARG,PP,POWERX,P,C,S |
| 2493 |
c COMPLEX*16 CI,CSUM,SS,A,AA,B1,B2,ANOM,ADEN 3807. |
| 2494 |
COMPLEX CI,CSUM,SS,A,AA,B1,B2,ANOM,ADEN |
| 2495 |
COMPLEX SERIES 3808. |
| 2496 |
PI=3.141592653589793D0 3809. |
| 2497 |
CI=DCMPLX(0.D0,1.D0) 3810. |
| 2498 |
MMAXP1=MMAX+1 3811. |
| 2499 |
C**COSINE AND SINE FUNCTION 3812. |
| 2500 |
NUMAX=NUAMAX*NUBMAX 3813. |
| 2501 |
DO 20 NU=1,NUMAX 3814. |
| 2502 |
ARG=2.0*PI*DFLOAT(NU)/DFLOAT(NUMAX) 3815. |
| 2503 |
C(NU)=DCOS(ARG) 3816. |
| 2504 |
20 S(NU)=DSIN(ARG) 3817. |
| 2505 |
50 PP=0.0 3818. |
| 2506 |
DO 60 I=1,ITM 3819. |
| 2507 |
60 PP=PP+SERIES(I)*CONJG(SERIES(I)) 3820. |
| 2508 |
P(1)=PP/FLOAT(ITM) 3821. |
| 2509 |
VAR=P(1) 3822. |
| 2510 |
M=1 3823. |
| 2511 |
B1(1)=SERIES(1) 3824. |
| 2512 |
B2(ITM-1)=SERIES(ITM) 3825. |
| 2513 |
ITMM1=ITM-1 3826. |
| 2514 |
DO 70 I=2,ITMM1 3827. |
| 2515 |
B1(I)=SERIES(I) 3828. |
| 2516 |
70 B2(I-1)=SERIES(I) 3829. |
| 2517 |
GO TO 80 3830. |
| 2518 |
100 DO 110 I=1,M 3831. |
| 2519 |
110 AA(I)=A(I) 3832. |
| 2520 |
M=M+1 3833. |
| 2521 |
ITMMM=ITM-M 3834. |
| 2522 |
DO 120 I=1,ITMMM 3835. |
| 2523 |
B1(I)=B1(I)-DCONJG(AA(M-1))*B2(I) 3836. |
| 2524 |
120 B2(I)=B2(I+1)-AA(M-1)*B1(I+1) 3837. |
| 2525 |
80 ANOM=DCMPLX(0.D0,0.D0) 3838. |
| 2526 |
ADEN=DCMPLX(0.D0,0.D0) 3839. |
| 2527 |
ITMMM=ITM-M 3840. |
| 2528 |
DO 90 I=1,ITMMM 3841. |
| 2529 |
ANOM=ANOM+DCONJG(B1(I))*B2(I) 3842. |
| 2530 |
90 ADEN=ADEN+B1(I)*DCONJG(B1(I))+B2(I)*DCONJG(B2(I)) 3843. |
| 2531 |
A(M)=(ANOM+ANOM)/ADEN 3844. |
| 2532 |
P(M+1)=P(M)*(1.0-DCONJG(A(M))*A(M)) 3845. |
| 2533 |
IF(M.EQ.1) GO TO 100 3846. |
| 2534 |
130 MM1=M-1 3847. |
| 2535 |
DO 140 I=1,MM1 3848. |
| 2536 |
140 A(I)=AA(I)-A(M)*DCONJG(AA(M-I)) 3849. |
| 2537 |
IF (M.LT.MMAX) GO TO 100 3850. |
| 2538 |
C**FINAL PREDICTION ERROR 3851. |
| 2539 |
DO 150 M=1,MMAXP1 3852. |
| 2540 |
150 FPE(M)=P(M)*FLOAT(ITM+M-1)/FLOAT(ITM-M+1) 3853. |
| 2541 |
DO 180 NUA=1,NUAMAX 3854. |
| 2542 |
POWERX=0. 3855. |
| 2543 |
C**FREQUENCY BAND AVERAGE 3856. |
| 2544 |
DO 170 NUB=1,NUBMAX 3857. |
| 2545 |
NU=NUB+NUA*NUBMAX+(NUMAX-3*NUBMAX-1)/2 3858. |
| 2546 |
CSUM=1. 3859. |
| 2547 |
DO 160 M=1,MMAX 3860. |
| 2548 |
NUTM=MOD(NU*M-1,NUMAX)+1 3861. |
| 2549 |
160 CSUM=CSUM-A(M)*(C(NUTM)-CI*S(NUTM)) 3862. |
| 2550 |
170 POWERX=POWERX+P(MMAXP1)/(CSUM*DCONJG(CSUM)) 3863. |
| 2551 |
POWER(NUA)=.5*POWERX/FLOAT(NUBMAX) 3864. |
| 2552 |
180 CONTINUE 3865. |
| 2553 |
PNU=0.0 3866. |
| 2554 |
DO 210 L=1,NUAMAX 3867. |
| 2555 |
210 PNU=PNU+POWER(L) 3868. |
| 2556 |
PNU=PNU/(.5*NUAMAX) 3869. |
| 2557 |
RETURN 3870. |
| 2558 |
END 3871. |
| 2559 |
BLOCK DATA a3 4001. |
| 2560 |
C**** 4002. |
| 2561 |
C**** TITLES, LEGENDS AND CHARACTERS FOR DIAG3 4003. |
| 2562 |
C**** 4004. |
| 2563 |
! |
| 2564 |
! --- Chien Wang some time before 080200 |
| 2565 |
! To make this work with PGF90: original size of common |
| 2566 |
! block was wrong |
| 2567 |
! |
| 2568 |
CHARACTER ACHAR*38,BCHAR*23,CCHAR*38,DCHAR*37,ECHAR*38 4091. |
| 2569 |
character*32 TITLE1, TITLE2, TITLE3 |
| 2570 |
character*40 legnd1, legnd2 |
| 2571 |
COMMON/D3COM/TITLE1(3,6),TITLE2(3,6),TITLE3(3,4), 4005. |
| 2572 |
* LEGND1(10),LEGND2(11),ACHAR,BCHAR,CCHAR, 4006. |
| 2573 |
* DCHAR,ECHAR |
| 2574 |
! COMMON/D3COM/TITLE1(3,6),TITLE2(3,6),TITLE3(3,4), 4005. |
| 2575 |
! * LEGND1(10),LEGND2(11),ACHAR,BCHAR,CCHAR, 4006. |
| 2576 |
! * DCHAR,ECHAR 4007. |
| 2577 |
! CHARACTER*3 TITLE1,TITLE2,TITLE3 |
| 2578 |
! CHARACTER*40 LEGND1,LEGND2 |
| 2579 |
! |
| 2580 |
C**** 4008. |
| 2581 |
c CHARACTER*32 TITLE1/ 4009. |
| 2582 |
DATA TITLE1/ |
| 2583 |
1 'TOPOGRAPHY (METERS)', 4010. |
| 2584 |
* 'LAND COVERAGE ', 4010.5 |
| 2585 |
* 'OCEAN ICE COVERAGE', 4010.6 |
| 2586 |
* 'SNOW COVERAGE ', 4011. |
| 2587 |
* 'SNOW DEPTH (MM H2O)', 4011.5 |
| 2588 |
* 'LAND ICE AND FROST COVERAGE', 4012. |
| 2589 |
C 4013. |
| 2590 |
7 'PRECIPITATION (MM/DAY)', 4014. |
| 2591 |
* 'EVAPORATION (MM/DAY)', 4014.5 |
| 2592 |
* 'SENSIBLE HEAT FLUX (WATTS/M**2)', 4015. |
| 2593 |
* 'GROUND WETNESS ', 4015.5 |
| 2594 |
* 'GROUND RUNOFF (MM/DAY)', 4016. |
| 2595 |
* 'GROUND TEMPERATURE (DEGREES C)', 4017. |
| 2596 |
C 4018. |
| 2597 |
3 'SURFACE CROSS ISOBAR ANGLE (DEG)', 4019. |
| 2598 |
* 'JET SPEED (METERS/SEC', 4019.5 |
| 2599 |
* 'SURFACE WIND SPEED (METERS/SEC)', 4020. |
| 2600 |
* 'SURF. CROSS ISOBAR ADJ. ANGLE', 4021. |
| 2601 |
* 'JET DIRECTION (CW NOR)', 4021.5 |
| 2602 |
* 'SURFACE WIND DIRECTION (CW NOR) '/ 4022. |
| 2603 |
c CHARACTER*32 TITLE2/ 4023. |
| 2604 |
DATA TITLE2/ |
| 2605 |
9 'TOTAL CLOUD COVER', 4024. |
| 2606 |
* 'CONVECTIVE CLOUD COVER', 4024.5 |
| 2607 |
* 'CLOUD TOP PRESSURE (MB)', 4025. |
| 2608 |
* 'LOW LEVEL CLOUDINESS', 4025.5 |
| 2609 |
* 'MIDDLE LEVEL CLOUDINESS', 4026. |
| 2610 |
* 'HIGH LEVEL CLOUDINESS', 4027. |
| 2611 |
C 4028. |
| 2612 |
5 'NET RAD. OF PLANET (WATTS/M**2)', 4029. |
| 2613 |
* 'NET RADIATION AT Z0 (WATTS/M**2)', 4030. |
| 2614 |
* 'BRIGHTNESS TEMP THRU WNDW(DEG C)', 4030.5 |
| 2615 |
* 'PLANETARY ALBEDO', 4031. |
| 2616 |
* 'GROUND ALBEDO ', 4031.5 |
| 2617 |
* 'VISUAL ALBEDO ', 4032. |
| 2618 |
C 4033. |
| 2619 |
1 'NET THRML RADIATION (WATTS/M**2)', 4034. |
| 2620 |
* 'NET HEAT AT Z0 (WATTS/M**2)', 4035. |
| 2621 |
* 'TROP STATIC STABILITY (DEG K/KM)', 4035.5 |
| 2622 |
* 'TOTAL NT DRY STAT ENR(10**14 WT)', 4036. |
| 2623 |
* 'NT DRY STAT ENR BY ST ED(E14 WT)', 4037. |
| 2624 |
* 'NT DRY STAT ENR BY TR ED(E14 WT)'/ 4038. |
| 2625 |
c CHARACTER*32 TITLE3/ 4039. |
| 2626 |
DATA TITLE3/ |
| 2627 |
7 '850 MB HEIGHT (METERS-1500)', 4040. |
| 2628 |
* '700 MB HEIGHT (METERS-3000)', 4041. |
| 2629 |
* '500 MB HEIGHT (METERS-5600)', 4042. |
| 2630 |
* '300 MB HEIGHT (METERS-9500)', 4043. |
| 2631 |
* '100 MB HEIGHT (METERS-16400)', 4044. |
| 2632 |
* ' 30 MB HEIGHT (METERS-24000)', 4045. |
| 2633 |
C 4046. |
| 2634 |
3 'THICKNESS TEMPERATURE 1000-850', 4047. |
| 2635 |
* 'THICKNESS TEMPERATURE 850-700', 4048. |
| 2636 |
* 'THICKNESS TEMPERATURE 700-500', 4049. |
| 2637 |
* 'THICKNESS TEMPERATURE 500-300', 4050. |
| 2638 |
* 'THICKNESS TEMPERATURE 300-100', 4051. |
| 2639 |
* 'THICKNESS TEMPERATURE 100-30'/ 4052. |
| 2640 |
C**** 4063. |
| 2641 |
c CHARACTER*40 LEGND1/ 4064. |
| 2642 |
DATA LEGND1/ |
| 2643 |
* '0=0,1=5...9=45,A=50...K=100', 4065. |
| 2644 |
* '0=0...9=90,A=100...I=180...R=270', 4066. |
| 2645 |
* '1=.5...9=4.5,A=5...Z=17.5,+=MORE', 4067. |
| 2646 |
* '1=1...9=9,A=10...Z=35,+=MORE', 4068. |
| 2647 |
* '1=2...9=18,A=20...Z=70,+=MORE', 4069. |
| 2648 |
C 4070. |
| 2649 |
* '1=50...9=450,A=500...Z=1750,+=MORE', 4071. |
| 2650 |
* '1=100...9=900,A=1000...Z=3500,+=MORE', 4072. |
| 2651 |
* ' ', 4073. |
| 2652 |
* 'A=1...Z=26,3=30...9=90,+=100-150,*=MORE', 4074. |
| 2653 |
* '0=0,A=.1...Z=2.6,3=3...9=9,+=10-15'/ 4075. |
| 2654 |
c CHARACTER*40 LEGND2/ 4076. |
| 2655 |
DATA LEGND2/ |
| 2656 |
* '-=LESS,Z=-78...0=0...9=27,+=MORE', 4077. |
| 2657 |
* '-=LESS,Z=-260...0=0...9=90,+=MORE', 4078. |
| 2658 |
* '-=LESS,Z=-520...0=0...9=180,+=MORE', 4079. |
| 2659 |
* '-=LESS,Z=-1300...0=0...9=450,+=MORE', 4080. |
| 2660 |
* '-=LESS,Z=-2600...0=0...9=900,+=MORE', 4081. |
| 2661 |
C 4082. |
| 2662 |
* '-=LESS,Z=-3900...0=0...9=1350,+=MORE', 4083. |
| 2663 |
* '-=LESS,Z=-5200...0=0...9=1800,+=MORE', 4084. |
| 2664 |
* '-=LESS,9=-.9...0=0,A=.1...Z=2.6,+=MORE', 4085. |
| 2665 |
* '-=LESS,9=-45...0=0,A=5...K=45...+=MORE', 4086. |
| 2666 |
* '-=LESS,9=-90...0=0,A=10...Z=260,+=MORE', 4087. |
| 2667 |
C 4088. |
| 2668 |
* '-=LESS,9=-180...A=20...Z=520,+=MORE'/ 4089. |
| 2669 |
C**** 4090. |
| 2670 |
CHARACTER ACHAR*38,BCHAR*23,CCHAR*38,DCHAR*37,ECHAR*38 4091. |
| 2671 |
DATA ACHAR/' 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ+'/ 4092. |
| 2672 |
DATA BCHAR/' 0123456789ABCDEFGHIJKX'/ 4095. |
| 2673 |
DATA CCHAR/'-9876543210ABCDEFGHIJKLMNOPQRSTUVWXYZ+'/ 4097. |
| 2674 |
DATA DCHAR/' 0ABCDEFGHIJKLMNOPQRSTUVWXYZ3456789+*'/ 4100. |
| 2675 |
DATA ECHAR/'-ZYXWVUTSRQPONMLKJIHGFEDCBA0123456789+'/ 4103. |
| 2676 |
END 4106. |
| 2677 |
SUBROUTINE DIAG3 4201. |
| 2678 |
C**** 4202. |
| 2679 |
C**** THIS SUBROUTINE PRODUCES LATITUDE BY LONGITUDE MAPS OF 4203. |
| 2680 |
C**** 4204. |
| 2681 |
C K IND IDACC 4205. |
| 2682 |
C**** 4206. |
| 2683 |
C***1 TOPOGRAPHY (M) 4207. |
| 2684 |
C***2 LAND COVERAGE (10**-2) 4208. |
| 2685 |
C***3 1 OCEAN ICE COVERAGE (10**-2) 4 4209. |
| 2686 |
C**** 2 SNOW COVERAGE (10**-2) 4 4210. |
| 2687 |
C**** 3 SNOW DEPTH (KG H2O/M**2) 4211. |
| 2688 |
C***6 29 LAND ICE AND FROST COVERAGE (PERCENT) 4212. |
| 2689 |
C**** 4213. |
| 2690 |
C***7 5 PRECIPITATION (KG/M**2/86400 S) 1 4214. |
| 2691 |
C**** 6 EVAPORATION (KG/M**2/86400 S) 1 4215. |
| 2692 |
C***9 4 SENSIBLE HEAT FLUX (WATTS/METER**2) 4216. |
| 2693 |
C**10 7 BETA, GROUND WETNESS (10**-2) 3 4217. |
| 2694 |
C**11 32 GROUND RUNOFF FROM SURFACE (KG/M**2/86400 S) 1 4218. |
| 2695 |
C**12 28 FIRST LAYER GROUND TEMPERATURE (K-273.16) 1 4219. |
| 2696 |
C**** 4220. |
| 2697 |
C**13 46 ALPHA0, SURFACE CROSS ISOBAR ANGLE (DEG) 1 4221. |
| 2698 |
C**14 39,40 JET SPEED (M/S) 4 4222. |
| 2699 |
C**15 36,37 SURFACE WIND SPEED (M/S) 3 4223. |
| 2700 |
C**16 34 SURFACE CROSS ISOBAR ADJUSTMENT ANGLE (DEG) 1 4224. |
| 2701 |
C**17 39,40 JET DIRECTION (CLOCKWISE FROM NORTH) 0 4225. |
| 2702 |
C**18 36,37 SURFACE WIND DIRECTION (CLOCKWISE FROM NORTH) 0 4226. |
| 2703 |
C**** 4227. |
| 2704 |
C**19 19 TOTAL CLOUD COVERAGE (PERCENT) 4228. |
| 2705 |
C**20 17 CLOUD COVERAGE FROM MOIST CONVECTION (PERCENT) 4229. |
| 2706 |
C**21 18/19 CLOUD TOP PRESSURE (MILLIBARS) 4230. |
| 2707 |
C**22 41 LOW LEVEL CLOUDINESS (PERCENT) 4231. |
| 2708 |
C**23 42 RMIDDLE LEVEL CLOUDINESS (PERCENT) 4232. |
| 2709 |
C**24 43 HIGH LEVEL CLOUDINESS (PERCENT) 4233. |
| 2710 |
C**** 4234. |
| 2711 |
C**25 21+24 RADIATION BALANCE OF PLANET (WATTS/METER**2) 4235. |
| 2712 |
C**26 22 RADIATION BALANCE OF GROUND (WATTS/METER**2) 4236. |
| 2713 |
C**27 44 BRIGHTNESS TEMPERATURE THROUGH WINDOW REGION (K-273.16) 4237. |
| 2714 |
C**28 24/25 PLANETARY ALBEDO (PERCENT) 4238. |
| 2715 |
C**29 26/27 GROUND ALBEDO (PERCENT) 4239. |
| 2716 |
C**30 45/25 VISUAL ALBEDO (PERCENT) 4240. |
| 2717 |
C**** 4241. |
| 2718 |
C**31 21 NET THERMAL RADIATION (WATTA/METER**2) 4242. |
| 2719 |
C**32 23 NET HEAT AT GROUND (WATTS/METER**2) 4243. |
| 2720 |
C**33 31 TROPOSPHERIC STATIC STABILITY 4244. |
| 2721 |
C**34 20 TOTAL NORTH. TRANS. OF DRY STATIC ENERGY (10**14 WATTS) 4245. |
| 2722 |
C**35 STAND. EDDY NORTH. TRANS. OF DRY STATIC ENERGY (10**14 WATTS)4246. |
| 2723 |
C**36 TRANS. EDDY NORTH. TRANS. OF DRY STATIC ENERGY (10**14 WATTS)4247. |
| 2724 |
C**** 4248. |
| 2725 |
C**37 10 850 MB GEOPOTENTIAL HEIGHT (METERS-1500) 4249. |
| 2726 |
C**** 11 700 MB GEOPOTENTIAL HEIGHT (METERS-3000) 4250. |
| 2727 |
C**** 12 500 MB GEOPOTENTIAL HEIGHT (METERS-5600) 4251. |
| 2728 |
C**** 13 300 MB GEOPOTENTIAL HEIGHT (METERS-9500) 4252. |
| 2729 |
C**** 14 100 MB GEOPOTENTIAL HEIGHT (METERS-16400) 4253. |
| 2730 |
C**** 15 30 MB GEOPOTENTIAL HEIGHT (METERS-24000) 4254. |
| 2731 |
C**** 4255. |
| 2732 |
C**43 9,10 THICKNESS TEMPERATURE FROM 1000 TO 850 MB (DEGREES CENT.) 4256. |
| 2733 |
C**** 10,11 THICKNESS TEMPERATURE FROM 850 TO 700 MB (DEGREES CENT.) 4257. |
| 2734 |
C**** 11,12 THICKNESS TEMPERATURE FROM 700 TO 500 MB (DEGREES CENT.) 4258. |
| 2735 |
C**** 12,13 THICKNESS TEMPERATURE FROM 500 TO 300 MB (DEGREES CENT.) 4259. |
| 2736 |
C**** 13,14 THICKNESS TEMPERATURE FROM 300 TO 100 MB (DEGREES CENT.) 4260. |
| 2737 |
C**** 14,15 THICKNESS TEMPERATURE FROM 100 TO 30 MB (DEGREES CENT.) 4261. |
| 2738 |
#include "BD2G04.COM" 4277. |
| 2739 |
COMMON U,V,T,P,Q 4278. |
| 2740 |
COMMON/WORK2/ENDE16(72,46,2), 4279. |
| 2741 |
* FLAT(3),FGLOBE(3),MLAT(3),MGLOBE(3),GNUM(3),GDEN(3) 4280. |
| 2742 |
! |
| 2743 |
! --- Chien Wang 080200 |
| 2744 |
! to make this peace of code work with PGF90 |
| 2745 |
! |
| 2746 |
CHARACTER*32 TITLE*32 |
| 2747 |
CHARACTER*4 LEGEND |
| 2748 |
CHARACTER ACHAR,BCHAR,CCHAR,DCHAR,ECHAR |
| 2749 |
COMMON/D3COM/TITLE(03,16),LEGEND(10,21),ACHAR(38),BCHAR(23), |
| 2750 |
* CCHAR(38),DCHAR(37),ECHAR(38) |
| 2751 |
! COMMON/D3COM/TITLE(03,16),LEGEND(10,21),ACHAR(38),BCHAR(23), 4281. |
| 2752 |
! * CCHAR(38),DCHAR(37),ECHAR(38) 4282. |
| 2753 |
! |
| 2754 |
C**** ACHAR/ ,0,1,...,8,9,A,B,...,Y,Z,+/ 4285. |
| 2755 |
C**** BCHAR/ ,0,1,...,8,9,A,B,...,K,X/ 4286. |
| 2756 |
C**** CCHAR/-,9,8,...,1,0,A,B,...,Y,Z,+/ 4287. |
| 2757 |
C**** DCHAR/ ,0,A,B,...,Y,Z,3,4,...,8,9,+,*/ 4288. |
| 2758 |
C**** ECHAR/-,Z,Y,...,B,A,0,1,...,8,9,+/ 4289. |
| 2759 |
CHARACTER*1 LINE(72,3),LONGTD(36) 4290. |
| 2760 |
DIMENSION IND(48),IA(48),ILEG(3,16),SCALE(48),FAC(48),JGRID(48), 4291. |
| 2761 |
* PMB(7),GHT(7) 4292. |
| 2762 |
DATA LINE/216*' '/,LONGTD/'+',35*' '/ 4293. |
| 2763 |
DATA IND/3*1,2,3,29, 5, 6, 4, 7,32,28, 46,39,36,34,39,36, 4294. |
| 2764 |
* 19,17,18,41,42,43, 21,22,44,24,26,45, 21,23,31,20, 1, 2, 4295. |
| 2765 |
* 10,11,12,13,14,15, 9,10,11,12,13,14/ 4296. |
| 2766 |
DATA IA/0,0,4*4, 1, 1, 1, 3, 1, 1, 3, 4, 3, 3, 0, 0, 4298. |
| 2767 |
* 2, 2, 0, 2, 2, 2, 2, 1, 2, 0, 0, 0, 2, 1, 4, 4, 4, 4, 4299. |
| 2768 |
* 12*4/ 4300. |
| 2769 |
DATA ILEG/7,3*1,9,1, 10,10,12, 1,18,11, 19, 5, 3,19, 2, 2, 4301. |
| 2770 |
* 1, 1, 6, 1, 1, 1, 13,20,11, 1, 1, 1, 13,13, 3,20,20,18, 4302. |
| 2771 |
* 12,13,14,15,15,16, 11,11,11,11,11,11/ 4303. |
| 2772 |
DATA SCALE/1.,3*100.,1.,100., 3*1.,100.,2*1., 6*1., 4305. |
| 2773 |
* 2*100.,1.,3*100., 3*1.,3*100., 2*1.,2.,15*1./ 4306. |
| 2774 |
DATA FAC/.01,3*.2,1.,.2, 2*10.,.1,.2,10.,.3333333, 4307. |
| 2775 |
* .2,.5,2.,.2,2*.1, 2*.2,.02,3*.2, .05,.1,.3333333,3*.2, 4308. |
| 2776 |
* 2*.05,2.,2*.1,10., .1,.05,.02,.01,.01,.006666667, 6*.3333333/ 4309. |
| 2777 |
DATA JGRID/19*1,2,15*1,2,2,1,2,2,8*1/ 4311. |
| 2778 |
DATA PMB/1000.,850.,700.,500.,300.,100.,30./ 4312. |
| 2779 |
DATA GHT/0.,1500.,3000.,5600.,9500.,16400.,24000./ 4313. |
| 2780 |
C**** INITIALIZE CERTAIN QUANTITIES 4314. |
| 2781 |
SHA=RGAS/KAPA 4315. |
| 2782 |
INC=1+JMM1/24 4316. |
| 2783 |
ILINE=36*INC 4317. |
| 2784 |
IQ1=1+IM/(4*INC) 4318. |
| 2785 |
LONGTD(IQ1)=LONGTD(1) 4319. |
| 2786 |
IQ2=1+IM/(2*INC) 4320. |
| 2787 |
LONGTD(IQ2)=LONGTD(1) 4321. |
| 2788 |
IQ3=1+3*IM/(4*INC) 4322. |
| 2789 |
LONGTD(IQ3)=LONGTD(1) 4323. |
| 2790 |
BYIM=1./FIM 4324. |
| 2791 |
DTSRCE=NDYN*DT 4325. |
| 2792 |
DTCNDS=NCNDS*DT 4326. |
| 2793 |
SCALE(7)=SDAY/DTCNDS 4329. |
| 2794 |
SCALE(8)=SDAY/DTSRCE 4330. |
| 2795 |
SCALE(9)=1./DTSRCE 4331. |
| 2796 |
SCALE(11)=SDAY/DTSRCE 4332. |
| 2797 |
SCALE(13)=360./TWOPI 4333. |
| 2798 |
SCALE(16)=360./TWOPI 4334. |
| 2799 |
SCALE(26)=1./DTSRCE 4335. |
| 2800 |
SCALE(32)=1./DTSRCE 4336. |
| 2801 |
SCALE(33)=1.E3*GRAV*EXPBYK(1000.) 4337. |
| 2802 |
SCALE(34)=6.25E-14/GRAV 4338. |
| 2803 |
SCALE(35)=SCALE(34) 4339. |
| 2804 |
SCALE(36)=SCALE(34) 4340. |
| 2805 |
DO 70 M=37,42 4341. |
| 2806 |
70 SCALE(M)=1./GRAV 4342. |
| 2807 |
DO 80 M=43,48 4343. |
| 2808 |
80 SCALE(M)=1./(RGAS*DLOG(PMB(M-42)/PMB(M-41))) 4344. |
| 2809 |
C**** 4348. |
| 2810 |
IHOUR0=TOFDY0+.5 4349. |
| 2811 |
IHOUR = TOFDAY + .5 4350. |
| 2812 |
TAUDIF=TAU-TAU0 4351. |
| 2813 |
BYIADA=1./(IDACC(4)+1.E-20) 4352. |
| 2814 |
C**** 4366. |
| 2815 |
160 NDIAG3=46 4367. |
| 2816 |
DO 180 N=1,NDIAG3 4368. |
| 2817 |
IF(JGRID(N).EQ.2) GO TO 180 4369. |
| 2818 |
DO 170 I=1,IM 4370. |
| 2819 |
AIJ(I,1,N)=AIJ(1,1,N) 4371. |
| 2820 |
170 AIJ(I,JM,N)=AIJ(1,JM,N) 4372. |
| 2821 |
180 CONTINUE 4373. |
| 2822 |
DO 610 KPAGE=1,10 4374. |
| 2823 |
IF(KPAGE.GE.7) GO TO 690 4375. |
| 2824 |
c WRITE (6,901) XLABEL 4376. |
| 2825 |
c WRITE (6,902) IDAY0,IHOUR0,JDATE0,JMNTH0,JYEAR0,TAU0,IDAY,IHOUR, 4377. |
| 2826 |
c * JDATE,JMONTH,JYEAR,TAU,TAUDIF 4378. |
| 2827 |
DO 610 KROW=1,2 4379. |
| 2828 |
KR=2*(KPAGE-1)+KROW 4380. |
| 2829 |
IF(KR.GT.16) GO TO 690 4381. |
| 2830 |
c WRITE (6,903) (TITLE(K,KR),K=1,03) 4382. |
| 2831 |
DO 200 KCOLMN=1,3 4383. |
| 2832 |
FGLOBE(KCOLMN)=0. 4384. |
| 2833 |
GNUM(KCOLMN)=0. 4385. |
| 2834 |
200 GDEN(KCOLMN)=0. 4386. |
| 2835 |
DO 550 JX=1,JM,INC 4387. |
| 2836 |
J=1+JM-JX 4388. |
| 2837 |
DO 510 KCOLMN=1,3 4389. |
| 2838 |
FLATK=0. 4390. |
| 2839 |
K=3*KR+KCOLMN-3 4391. |
| 2840 |
INDEX=IND(K) 4392. |
| 2841 |
BYIACC=1./(IDACC(IA(K))+1.E-20) 4393. |
| 2842 |
GO TO (320,340,400,400,440,400, 440,440,460,400,420,460, 4394. |
| 2843 |
* 420,300,300,420,240,240, 400,400,260,400,400,400, 4395. |
| 2844 |
* 220,420,460,260,260,260, 460,460,380,610,610,610, 4396. |
| 2845 |
* 610,610,610,610,610,610, 610,610,610,610,610,610),K 4397. |
| 2846 |
C**** SUM OF TWO ARRAYS 4399. |
| 2847 |
220 DO 230 I=1,IM 4400. |
| 2848 |
A=(AIJ(I,J,21)+AIJ(I,J,24))*SCALE(K)*BYIACC 4401. |
| 2849 |
FLATK=FLATK+A 4402. |
| 2850 |
N=28.5+A*FAC(K) 4403. |
| 2851 |
IF (N.LT.1 ) N=1 4404. |
| 2852 |
IF (N.GT.38) N=38 4405. |
| 2853 |
230 LINE(I,KCOLMN)=ECHAR(N) 4406. |
| 2854 |
GO TO 500 4407. |
| 2855 |
C**** WIND DIRECTION 4408. |
| 2856 |
240 IF(J.EQ.1) GO TO 500 4409. |
| 2857 |
DO 250 I=1,IM 4410. |
| 2858 |
A=360.*ATAN2(AIJ(I,J,INDEX)+1.E-20,AIJ(I,J,INDEX+1)+1.E-20)/TWOPI 4411. |
| 2859 |
FLATK=FLATK+A 4412. |
| 2860 |
N=2.5+A*FAC(K) 4413. |
| 2861 |
IF(N.LT.2) N=N+36 4414. |
| 2862 |
250 LINE(I,KCOLMN)=ACHAR(N) 4415. |
| 2863 |
GO TO 500 4416. |
| 2864 |
C**** RATIO OF 2 ARRAYS (MAINLY FOR ALBEDO) 4417. |
| 2865 |
260 FNUM=0. 4418. |
| 2866 |
FDEN=0. 4419. |
| 2867 |
INDEX2=INDEX+1 4420. |
| 2868 |
IF (INDEX.EQ.45) INDEX2=25 4421. |
| 2869 |
DO 270 I=1,IM 4422. |
| 2870 |
A=SCALE(K)*AIJ(I,J,INDEX)/(AIJ(I,J,INDEX2)+1.E-20) 4423. |
| 2871 |
IF(INDEX.EQ.24 .OR. INDEX.EQ.26) A=100.-A 4424. |
| 2872 |
FNUM=FNUM+AIJ(I,J,INDEX) 4425. |
| 2873 |
FDEN=FDEN+AIJ(I,J,INDEX2) 4426. |
| 2874 |
N=2.5+A*FAC(K) 4427. |
| 2875 |
IF(A*FAC(K).GE.20.) N=23 4428. |
| 2876 |
IF(AIJ(I,J,INDEX2).LE.0.) N=1 4429. |
| 2877 |
270 LINE(I,KCOLMN)=ACHAR(N) 4430. |
| 2878 |
FLAT(KCOLMN)=SCALE(K)*FNUM/(FDEN+1.E-20) 4431. |
| 2879 |
IF(INDEX.EQ.24 .OR. INDEX.EQ.26) FLAT(KCOLMN)=100.-FLAT(KCOLMN) 4432. |
| 2880 |
MLAT(KCOLMN)=FLAT(KCOLMN)+.5 4433. |
| 2881 |
GNUM(KCOLMN)=GNUM(KCOLMN)+FNUM*DXYP(J) 4434. |
| 2882 |
GDEN(KCOLMN)=GDEN(KCOLMN)+FDEN*DXYP(J) 4435. |
| 2883 |
IF(J.GT.INC) GO TO 510 4436. |
| 2884 |
FGLOBE(KCOLMN)=SCALE(K)*GNUM(KCOLMN)/(GDEN(KCOLMN)+1.E-20) 4437. |
| 2885 |
IF(INDEX.EQ.24.OR.INDEX.EQ.26) FGLOBE(KCOLMN)=100.-FGLOBE(KCOLMN) 4438. |
| 2886 |
FGLOBE(KCOLMN)=FGLOBE(KCOLMN)*AREAG/(FIM*INC) 4439. |
| 2887 |
GO TO 510 4440. |
| 2888 |
C**** STANDING AND TRANSIENT EDDY NORTHWARD TRANSPORTS OF DSE 4441. |
| 2889 |
C 280 IF (SKIPSE.EQ.1.) GO TO 510 4442. |
| 2890 |
C DO 290 I=1,IM 4443. |
| 2891 |
C A=ENDE16(I,J,INDEX)*SCALE(K)*BYIACC 4444. |
| 2892 |
C FLATK=FLATK+A 4445. |
| 2893 |
C N=11.5+A*FAC(K) 4446. |
| 2894 |
C IF(N.LT.1) N=1 4447. |
| 2895 |
C IF(N.GT.38) N=38 4448. |
| 2896 |
C 290 LINE(I,KCOLMN)=CCHAR(N) 4449. |
| 2897 |
C FLAT(KCOLMN)=FLATK 4450. |
| 2898 |
C DAREA=DXYV(J) 4451. |
| 2899 |
C GO TO 505 4452. |
| 2900 |
C**** MAGNITUDE OF TWO PERPENDICULAR COMPONENTS 4453. |
| 2901 |
300 IF(J.EQ.1) GO TO 500 4454. |
| 2902 |
DO 310 I=1,IM 4455. |
| 2903 |
A=SQRT(AIJ(I,J,INDEX)**2+AIJ(I,J,INDEX+1)**2)*SCALE(K)*BYIACC 4456. |
| 2904 |
FLATK=FLATK+A 4457. |
| 2905 |
N=2.5+A*FAC(K) 4458. |
| 2906 |
IF(N.GT.38) N=38 4459. |
| 2907 |
310 LINE(I,KCOLMN)=ACHAR(N) 4460. |
| 2908 |
GO TO 500 4461. |
| 2909 |
C**** SURFACE TOPOGRAPHY 4462. |
| 2910 |
320 DO 330 I=1,IM 4463. |
| 2911 |
ZS=FDATA(I,J,1)/GRAV 4464. |
| 2912 |
FLATK=FLATK+ZS 4465. |
| 2913 |
N=2.5+.01*ZS 4466. |
| 2914 |
IF (ZS.LE.0.) N=1 4467. |
| 2915 |
IF(N.GT.38) N=38 4468. |
| 2916 |
330 LINE(I,KCOLMN)=ACHAR(N) 4469. |
| 2917 |
GO TO 500 4470. |
| 2918 |
C**** LAND COVERAGE 4471. |
| 2919 |
340 DO 350 I=1,IM 4472. |
| 2920 |
PLAND=FDATA(I,J,2)*100. 4473. |
| 2921 |
FLATK=FLATK+PLAND 4474. |
| 2922 |
N=2.5+PLAND*.2 4475. |
| 2923 |
IF(PLAND.LE.0.) N=1 4476. |
| 2924 |
IF(PLAND.GE.100.) N=23 4477. |
| 2925 |
350 LINE(I,KCOLMN)=BCHAR(N) 4478. |
| 2926 |
GO TO 500 4479. |
| 2927 |
C**** THICKNESS TEMPERATURES 4480. |
| 2928 |
C 360 DO 370 I=1,IM 4481. |
| 2929 |
C A=((AIJ(I,J,INDEX+1)-AIJ(I,J,INDEX))*BYIACC 4482. |
| 2930 |
C * +(GHT(INDEX-7)-GHT(INDEX-8))*GRAV)*SCALE(K)-273.16 4483. |
| 2931 |
C FLATK=FLATK+A 4484. |
| 2932 |
C N=28.5+A*FAC(K) 4485. |
| 2933 |
C IF(N.LT.1) N=1 4486. |
| 2934 |
C IF(N.GT.38) N=38 4487. |
| 2935 |
C 370 LINE(I,KCOLMN)=ECHAR(N) 4488. |
| 2936 |
C GO TO 500 4489. |
| 2937 |
C**** POSITIVE QUANTITIES UNIFORMLY SCALED 4490. |
| 2938 |
380 DO 390 I=1,IM 4491. |
| 2939 |
A=AIJ(I,J,INDEX)*SCALE(K)*BYIACC 4492. |
| 2940 |
FLATK=FLATK+A 4493. |
| 2941 |
N=2.5+A*FAC(K) 4494. |
| 2942 |
IF(A.EQ.0.) N=1 4495. |
| 2943 |
IF(N.GT.38) N=38 4496. |
| 2944 |
390 LINE(I,KCOLMN)=ACHAR(N) 4497. |
| 2945 |
GO TO 500 4498. |
| 2946 |
C**** PERCENTAGES 4499. |
| 2947 |
400 DO 410 I=1,IM 4500. |
| 2948 |
A=AIJ(I,J,INDEX)*SCALE(K)*BYIACC 4501. |
| 2949 |
FLATK=FLATK+A 4502. |
| 2950 |
N=2.5+A*FAC(K) 4503. |
| 2951 |
IF(A.LE.0.) N=1 4504. |
| 2952 |
IF(A*FAC(K).GE.20.) N=23 4505. |
| 2953 |
410 LINE(I,KCOLMN)=BCHAR(N) 4506. |
| 2954 |
GO TO 500 4507. |
| 2955 |
C**** SIGNED QUANTITIES UNIFORMLY SCALED (LETTERS +, NUMBERS -) 4508. |
| 2956 |
420 DO 430 I=1,IM 4509. |
| 2957 |
A=AIJ(I,J,INDEX)*SCALE(K)*BYIACC 4510. |
| 2958 |
FLATK=FLATK+A 4511. |
| 2959 |
N=11.5+A*FAC(K) 4512. |
| 2960 |
IF(N.LT.1) N=1 4513. |
| 2961 |
IF(N.GT.38) N=38 4514. |
| 2962 |
430 LINE(I,KCOLMN)=CCHAR(N) 4515. |
| 2963 |
IF(K.EQ.34) FLATK=FLATK*FIM 4516. |
| 2964 |
GO TO 500 4517. |
| 2965 |
C**** PRECIPITATION AND EVAPORATION 4518. |
| 2966 |
440 DO 450 I=1,IM 4519. |
| 2967 |
A=AIJ(I,J,INDEX)*SCALE(K)*BYIACC 4520. |
| 2968 |
FLATK=FLATK+A 4521. |
| 2969 |
N=1 4522. |
| 2970 |
IF(A.LE.0.) GO TO 450 4523. |
| 2971 |
N=2.5+A*FAC(K) 4524. |
| 2972 |
IF(N.GT.28) N=(N+263)/10 4525. |
| 2973 |
IF(N.GT.35) N=(N+180)/6 4526. |
| 2974 |
IF(N.GT.37) N=37 4527. |
| 2975 |
450 LINE(I,KCOLMN)=DCHAR(N) 4528. |
| 2976 |
GO TO 500 4529. |
| 2977 |
C**** SIGNED QUANTITIES UNIFORMLY SCALED (NUMBERS +, LETTERS -) 4530. |
| 2978 |
460 DO 470 I=1,IM 4531. |
| 2979 |
A=AIJ(I,J,INDEX)*SCALE(K)*BYIACC 4532. |
| 2980 |
FLATK=FLATK+A 4533. |
| 2981 |
N=28.5+A*FAC(K) 4534. |
| 2982 |
IF (N.LT.1 ) N=1 4535. |
| 2983 |
IF (N.GT.38) N=38 4536. |
| 2984 |
470 LINE(I,KCOLMN)=ECHAR(N) 4537. |
| 2985 |
GO TO 500 4538. |
| 2986 |
C**** POSITIVE QUANTITIES NON-UNIFORMLY SCALED 4539. |
| 2987 |
C 480 DO 490 I=1,IM 4540. |
| 2988 |
C A=AIJ(I,J,INDEX)*SCALE(K)*BYIACC 4541. |
| 2989 |
C FLATK=FLATK+A 4542. |
| 2990 |
C N=2.5+A*FAC(K) 4543. |
| 2991 |
C IF(N.GE.13) N=(N+123)/10 4544. |
| 2992 |
C IF(N.GT.38) N=38 4545. |
| 2993 |
C 490 LINE(I,KCOLMN)=ACHAR(N) 4546. |
| 2994 |
500 FLAT(KCOLMN)=FLATK*BYIM 4547. |
| 2995 |
MLAT(KCOLMN)=INT(FLAT(KCOLMN)+10000.5)-10000 4548. |
| 2996 |
DAREA=DXYP(J) 4549. |
| 2997 |
IF(JGRID(INDEX).EQ.2) DAREA=DXYV(J) 4550. |
| 2998 |
505 FGLOBE(KCOLMN)=FGLOBE(KCOLMN)+FLAT(KCOLMN)*DAREA 4551. |
| 2999 |
510 CONTINUE 4552. |
| 3000 |
GO TO 530 |
| 3001 |
GO TO (524,520, 520,520, 520,520, 521,520, 526,520, 526,524, 4553. |
| 3002 |
* 527,527, 520,520, 527,527, 527,527),KR 4554. |
| 3003 |
520 WRITE (6,910) (FLAT(KC),(LINE(I,KC),I=1,ILINE,INC),KC=1,3) 4555. |
| 3004 |
GO TO 530 4556. |
| 3005 |
521 WRITE (6,911) (FLAT(KC),(LINE(I,KC),I=1,ILINE,INC),KC=1,2), 4557. |
| 3006 |
* MLAT(3),(LINE(I,3),I=1,ILINE,INC) 4558. |
| 3007 |
GO TO 530 4559. |
| 3008 |
524 WRITE (6,914) MLAT(1),(LINE(I,1),I=1,ILINE,INC), 4560. |
| 3009 |
* (FLAT(KC),(LINE(I,KC),I=1,ILINE,INC),KC=2,3) 4561. |
| 3010 |
GO TO 530 4562. |
| 3011 |
526 WRITE (6,916) (MLAT(KC),(LINE(I,KC),I=1,ILINE,INC),KC=1,2), 4563. |
| 3012 |
* FLAT(3),(LINE(I,3),I=1,ILINE,INC) 4564. |
| 3013 |
GO TO 530 4565. |
| 3014 |
527 WRITE (6,917) (MLAT(KC),(LINE(I,KC),I=1,ILINE,INC),KC=1,3) 4566. |
| 3015 |
530 CONTINUE 4567. |
| 3016 |
550 CONTINUE 4575. |
| 3017 |
DO 555 KC=1,3 4576. |
| 3018 |
FGLOBE(KC)=FGLOBE(KC)*FIM*INC/AREAG 4577. |
| 3019 |
555 MGLOBE(KC)=INT(FGLOBE(KC)+10000.5)-10000 4578. |
| 3020 |
GO TO 600 |
| 3021 |
GO TO (574,570, 570,570, 570,570, 571,570, 577,570, 576,570, 4579. |
| 3022 |
* 577,577, 570,570, 577,577, 577,577),KR 4580. |
| 3023 |
570 WRITE (6,910) (FGLOBE(KC),LONGTD,KC=1,3) 4581. |
| 3024 |
GO TO 610 4582. |
| 3025 |
571 WRITE (6,911) FGLOBE(1),LONGTD,FGLOBE(2),LONGTD,MGLOBE(3),LONGTD 4583. |
| 3026 |
GO TO 600 4584. |
| 3027 |
574 WRITE (6,914) MGLOBE(1),LONGTD,FGLOBE(2),LONGTD,FGLOBE(3),LONGTD 4585. |
| 3028 |
GO TO 600 4586. |
| 3029 |
576 WRITE (6,916) MGLOBE(1),LONGTD,MGLOBE(2),LONGTD,FGLOBE(3),LONGTD 4587. |
| 3030 |
GO TO 600 4588. |
| 3031 |
577 WRITE (6,917) (MGLOBE(KC),LONGTD,KC=1,3) 4589. |
| 3032 |
600 WRITE (6,909) ((LEGEND(K,ILEG(KCOLMN,KR)),K=1,10),KCOLMN=1,2), 4590. |
| 3033 |
* (LEGEND(K,ILEG(3,KR)),K=1,9) 4590.1 |
| 3034 |
610 CONTINUE 4591. |
| 3035 |
690 CONTINUE 4592. |
| 3036 |
C**** 4593. |
| 3037 |
C**** PRODUCE FULL PAGE I,J MAPS 4594. |
| 3038 |
C**** 4595. |
| 3039 |
c WRITE(6,901)XLABEL 4596. |
| 3040 |
c WRITE(6,902)IDAY0,IHOUR0,JDATE0,JMNTH0,JYEAR0,TAU0,IDAY,IHOUR, 4597. |
| 3041 |
c * JDATE,JMONTH,JYEAR,TAU,TAUDIF 4598. |
| 3042 |
CALL IJMAP (1,AIJ(1,1,38),BYIADA,JM,IO,IM) 4599. |
| 3043 |
BYIAC3=1./(IDACC(3)+1.E-20) 4600. |
| 3044 |
c WRITE(6,901)XLABEL 4601. |
| 3045 |
c WRITE(6,902)IDAY0,IHOUR0,JDATE0,JMNTH0,JYEAR0,TAU0,IDAY,IHOUR, 4602. |
| 3046 |
c * JDATE,JMONTH,JYEAR,TAU,TAUDIF 4603. |
| 3047 |
CALL IJMAP (2,AIJ(1,1,35),BYIAC3,JM,IO,IM) 4604. |
| 3048 |
C WRITE(6,901)XLABEL 4605. |
| 3049 |
C WRITE(6,902)IDAY0,IHOUR0,JDATE0,JMNTH0,JYEAR0,TAU0,IDAY,IHOUR, 4606. |
| 3050 |
C * JDATE,JMONTH,JYEAR,TAU,TAUDIF 4607. |
| 3051 |
C CALL IJMAP (4,AIJ(1,1,8),BYIADA,JM,IO,IM) 4608. |
| 3052 |
C WRITE(6,901)XLABEL 4609. |
| 3053 |
C WRITE(6,902)IDAY0,IHOUR0,JDATE0,JMNTH0,JYEAR0,TAU0,IDAY,IHOUR, 4610. |
| 3054 |
C * JDATE,JMONTH,JYEAR,TAU,TAUDIF 4611. |
| 3055 |
C CALL IJMAP (5,AIJ(1,1,33),BYIADA,JM,IO,IM) 4612. |
| 3056 |
RETURN 4613. |
| 3057 |
C**** 4614. |
| 3058 |
901 FORMAT ('1',33A4) 4615. |
| 3059 |
902 FORMAT ('0',16X,'DAY',I5,', HR',I2,' (',I2,A5,I4,')',F8.0, 4616. |
| 3060 |
* ' TO DAY',I5,', HR',I2,' (',I2,A5,I4,')',F8.0, 4617. |
| 3061 |
* ' DIF',F5.0,' HR') 4618. |
| 3062 |
903 FORMAT ('0',6X,A32,13X,A32,13X,A32) 4619. |
| 3063 |
906 FORMAT ('+',6X,36A1,9X,36A1,9X,36A1) 4620. |
| 3064 |
909 FORMAT (7X,10A4,5X,10A4,5X,9A4) 4621. |
| 3065 |
910 FORMAT (1X,F5.1,1X,36A1,F8.1,1X,36A1,F8.1,1X,36A1) 4622. |
| 3066 |
911 FORMAT (1X,F5.1,1X,36A1,F8.1,1X,36A1,I8,1X,36A1) 4623. |
| 3067 |
914 FORMAT (1X,I5,1X,36A1,F8.1,1X,36A1,F8.1,1X,36A1) 4624. |
| 3068 |
916 FORMAT (1X,I5,1X,36A1,I8,1X,36A1,F8.1,1X,36A1) 4625. |
| 3069 |
917 FORMAT (1X,I5,1X,36A1,I8,1X,36A1,I8,1X,36A1) 4626. |
| 3070 |
END 4627. |
| 3071 |
SUBROUTINE IJMAP (NT,ARRAY,BYIACC,JM,IO,IM) 4801. |
| 3072 |
DIMENSION C31(36,24),LON(72),LAT(46),ARRAY(IM,JM) 4802. |
| 3073 |
CHARACTER*1 LINE(3,72),IDX(12),BLANK,TITLE(5)*48 4803. |
| 3074 |
DATA IDX/'0','1','2','3','4','5','6','7','8','9','-','*'/ 4804. |
| 3075 |
DATA BLANK/' '/ 4805. |
| 3076 |
C DATA LINE/216*' '/ 4806. |
| 3077 |
DATA TITLE/ 4807. |
| 3078 |
C**** 4808. |
| 3079 |
C**** THIS SUBROUTINE PRODUCES NUMERICAL LATITUDE BY LONGITUDE MAPS OF 4809. |
| 3080 |
C**** 4810. |
| 3081 |
* 'SEA LEVEL PRESSURE (MB-1000)', 4811. |
| 3082 |
* 'SURFACE TEMPERATURE (DEGREES C)', 4812. |
| 3083 |
* 'INSTANTANEOUS 850 MB HEIGHTS (DEKAMETERS-100)', 4813. |
| 3084 |
* 'SEA LEVEL PRESSURE (MB-1000) (USING T1)', 4814. |
| 3085 |
* 'SURFACE TEMPERATURE (DEG C) (LAPSE RATE FROM T1'/ 4815. |
| 3086 |
DATA IFIRST/1/ 4815.1 |
| 3087 |
IF(IFIRST.NE.1) GO TO 455 4815.11 |
| 3088 |
IFIRST=0 4815.12 |
| 3089 |
C**** 4815.2 |
| 3090 |
C**** INITIALIZE CERTAIN QUANTITIES 4815.21 |
| 3091 |
C**** 4815.22 |
| 3092 |
KA=2 4815.24 |
| 3093 |
c IO=36 4815.241 |
| 3094 |
c JM=24 4815.242 |
| 3095 |
c IM=1 4815.243 |
| 3096 |
print *,' FROM IJMAP JM=',JM,' IM=',IM,' IO=',IO |
| 3097 |
BYIM=1./IM 4815.25 |
| 3098 |
INC=1+(JM-1)/24 4815.26 |
| 3099 |
ISTEP=INC*2 4815.27 |
| 3100 |
IE=36*INC 4815.28 |
| 3101 |
LON(1)=-180 4815.29 |
| 3102 |
LD=360/IO 4815.3 |
| 3103 |
DO 400 I=2,IO 4815.31 |
| 3104 |
400 LON(I)=LON(I-1)+LD 4815.32 |
| 3105 |
DO 450 J=1,JM 4815.33 |
| 3106 |
450 LAT(JM-J+1)=INT(.5+(J-1.0)*180./(JM-1))-90 4815.34 |
| 3107 |
455 CONTINUE 4815.35 |
| 3108 |
C**** 4816. |
| 3109 |
c WRITE(6,900) TITLE(NT) 4817. |
| 3110 |
c WRITE (6,910) (I,I=1,IE,INC) 4818. |
| 3111 |
DO 300 JX=1,JM 4819. |
| 3112 |
FLAT=0. 4820. |
| 3113 |
J=1+JM-JX 4821. |
| 3114 |
DO 250 I=1,IM 4822. |
| 3115 |
A=ARRAY(I,J)*BYIACC 4823. |
| 3116 |
FLAT=FLAT+A 4824. |
| 3117 |
IF (A.LT.999.5.OR.A.GE.-99.5) GO TO 140 4825. |
| 3118 |
DO 100 K=1,3 4826. |
| 3119 |
100 LINE(K,I)=IDX(12) 4827. |
| 3120 |
GO TO 250 4828. |
| 3121 |
140 DO 150 K=1,3 4829. |
| 3122 |
150 LINE(K,I)=BLANK 4830. |
| 3123 |
JA=NINT(A) 4831. |
| 3124 |
IA=IABS(JA) 4832. |
| 3125 |
IF(IA.GT.99) GO TO 210 4833. |
| 3126 |
IF(IA-9) 230,230,220 4834. |
| 3127 |
210 LINE(1,I)=IDX(IA/100+1) 4835. |
| 3128 |
IA=MOD(IA,100) 4836. |
| 3129 |
220 LINE(2,I)=IDX(IA/10+1) 4837. |
| 3130 |
IA=MOD(IA,10) 4838. |
| 3131 |
230 LINE(3,I)=IDX(IA+1) 4839. |
| 3132 |
IF(JA.GE.0) GO TO 250 4840. |
| 3133 |
IF(JA+9) 240,245,245 4841. |
| 3134 |
240 LINE(1,I)=IDX(11) 4842. |
| 3135 |
GO TO 250 4843. |
| 3136 |
245 LINE(2,I)=IDX(11) 4844. |
| 3137 |
250 CONTINUE 4845. |
| 3138 |
FLAT=FLAT*BYIM 4846. |
| 3139 |
c WRITE (6,920) LAT(JX),J,((LINE(K,I),K=1,3),I=1,IE,INC),FLAT 4847. |
| 3140 |
c 300 IF(JM.LE.24) WRITE (6,940) 4856. |
| 3141 |
c WRITE (6,930) (LON(I),I=1,IM,ISTEP) 4857. |
| 3142 |
300 continue |
| 3143 |
RETURN 4874. |
| 3144 |
900 FORMAT('0',45X,A48) 4875. |
| 3145 |
910 FORMAT('0LAT J/I ',36I3,5X,'MEAN'//) 4876. |
| 3146 |
920 FORMAT(2I4,3X,108A1,F9.2) 4877. |
| 3147 |
925 FORMAT('+',10X,108A1) 4878. |
| 3148 |
930 FORMAT('0 LONG ',18I6) 4879. |
| 3149 |
940 FORMAT(' ') 4880. |
| 3150 |
END 4881. |
| 3151 |
BLOCK DATA a4 5001. |
| 3152 |
C**** 5002. |
| 3153 |
C**** TITLES FOR SUBROUTINE DIAG9 5003. |
| 3154 |
C**** 5004. |
| 3155 |
COMMON/D9COM/TITLE1,TITLE2,TITLE3,TITLE4 5005. |
| 3156 |
CHARACTER*32 TITLE1(11)/ 5006. |
| 3157 |
* ' INSTANTANE AM (10**9 J*S/M**2) ', 5007. |
| 3158 |
* ' CHANGE OF AM BY ADVECTION ', 5008. |
| 3159 |
* ' CHANGE OF AM BY CORIOLIS FORCE ', 5009. |
| 3160 |
* ' CHANGE OF AM BY ADVEC + COR ', 5010. |
| 3161 |
* ' CHANGE OF AM BY PRESSURE GRAD ', 5011. |
| 3162 |
* ' CHANGE OF AM BY DYNAMICS ', 5012. |
| 3163 |
* ' CHANGE OF AM BY SURFACE FRIC ', 5013. |
| 3164 |
* ' CHANGE OF AM BY STRATOS DRAG ', 5014. |
| 3165 |
* ' CHANGE OF AM BY FILTER ', 5015. |
| 3166 |
* ' CHANGE OF AM BY DAILY RESTOR ', 5016. |
| 3167 |
* ' SUM OF CHANGES (10**2 J/M**2) '/ 5017. |
| 3168 |
CHARACTER*32 TITLE2(12)/ 5018. |
| 3169 |
* '0INSTANTANEOUS KE (10**3 J/M**2)', 5019. |
| 3170 |
* ' CHANGE OF KE BY ADVECTION ', 5020. |
| 3171 |
* ' CHANGE OF KE BY CORIOLIS FORCE ', 5021. |
| 3172 |
* ' CHANGE OF KE BY ADVEC + COR ', 5022. |
| 3173 |
* ' CHANGE OF KE BY PRESSURE GRAD ', 5023. |
| 3174 |
* ' CHANGE OF KE BY DYNAMICS ', 5024. |
| 3175 |
* ' CHANGE OF KE BY MOIST CONVEC ', 5025. |
| 3176 |
* ' CHANGE OF KE BY SURF + DRY CONV', 5026. |
| 3177 |
* ' CHANGE OF KE BY STRATOS DRAG ', 5027. |
| 3178 |
* ' CHANGE OF KE BY FILTER ', 5028. |
| 3179 |
* ' CHANGE OF KE BY DAILY RESTOR ', 5029. |
| 3180 |
* ' SUM OF CHANGES (10**-3 W/M**2) '/ 5030. |
| 3181 |
CHARACTER*32 TITLE3(5)/ 5031. |
| 3182 |
* ' INSTANTANEOUS MASS (KG/M**2) ', 5032. |
| 3183 |
* ' CHANGE OF MASS BY DYNAMICS ', 5033. |
| 3184 |
* ' CHANGE OF MASS BY FILTER ', 5034. |
| 3185 |
* ' CHANGE OF MASS BY DAILY RESTOR ', 5035. |
| 3186 |
* ' SUM CHANGES (10**-8 KG/S/M**2) '/ 5036. |
| 3187 |
CHARACTER*32 TITLE4(8)/ 5037. |
| 3188 |
* '0INSTANTANE TPE (10**5 J/M**2) ', 5038. |
| 3189 |
* ' CHANGE OF TPE BY DYNAMICS ', 5039. |
| 3190 |
* ' CHANGE OF TPE BY CONDENSATION ', 5040. |
| 3191 |
* ' CHANGE OF TPE BY RADIATION ', 5041. |
| 3192 |
* ' CHANGE OF TPE BY SURFACE INTER ', 5042. |
| 3193 |
* ' CHANGE OF TPE BY FILTER ', 5043. |
| 3194 |
* ' CHANGE OF TPE BY DAILY RESTOR ', 5044. |
| 3195 |
* ' SUM OF CHANGES (10**-2 W/M**2) '/ 5045. |
| 3196 |
END 5046. |
| 3197 |
SUBROUTINE DIAG9A (M) 5201. |
| 3198 |
C**** 5202. |
| 3199 |
C**** THIS DIAGNOSTIC ROUTINE KEEPS TRACK OF THE CONSERVATION 5203. |
| 3200 |
C**** PROPERTIES OF ANGULAR MOMENTUM, KINETIC ENERGY, MASS, AND 5204. |
| 3201 |
C**** TOTAL POTENTIAL ENERGY 5205. |
| 3202 |
C**** 5206. |
| 3203 |
#include "BD2G04.COM" 5207. |
| 3204 |
COMMON U,V,T,P,Q 5208. |
| 3205 |
DIMENSION UX(IO0,JM0,1),VX(IO0,JM0,1) 5209. |
| 3206 |
COMMON/WORK1/PIT(IM0,JM0),SD(IM0,JM0,LM0-1),PK(IM0,JM0,LM0) 5210. |
| 3207 |
COMMON/WORK2/JLATP(46),JLATV(46),SCALE(36),FGLOB(36),FHEM(2,36), 5211. |
| 3208 |
* MLAT(46,36),MAREA(46) 5212. |
| 3209 |
COMMON/WORK4/PI(46),AM(46),RKE(46),RMASS(46),TPE(46) 5213. |
| 3210 |
COMMON/WORK5/DUT(IO0,JM0,LM0),DVT(IO0,JM0,LM0) 5214. |
| 3211 |
COMMON/D9COM/TITLE(36) 5215. |
| 3212 |
INTEGER NAMOFM(8)/1,6,1,1,7,8,9,10/ 5216. |
| 3213 |
INTEGER NKEOFM(8)/1,17,18,1,19,20,21,22/ 5217. |
| 3214 |
INTEGER NMSOFM(8)/1,25,1,1,1,1,26,27/ 5218. |
| 3215 |
INTEGER NPEOFM(8)/1,30,31,32,33,1,34,35/ 5219. |
| 3216 |
CHARACTER*4 HEMIS(2)/' SH ',' NH '/,DASH/'----'/,TITLE*32 5220. |
| 3217 |
C**** 5221. |
| 3218 |
C**** THE PARAMETER M INDICATES WHEN DIAG9A IS BEING CALLED 5222. |
| 3219 |
C**** M=1 INITIALIZE CURRENT A.M., K.E., MASS, AND T.P.E. 5223. |
| 3220 |
C**** 2 AFTER DYNAMICS 5224. |
| 3221 |
C**** 3 AFTER CONDENSATION 5225. |
| 3222 |
C**** 4 AFTER RADIATION 5226. |
| 3223 |
C**** 5 AFTER SURFACE INTERACTION AND DRY CONVECTION 5227. |
| 3224 |
C**** 6 AFTER STRATOSPHERIC DRAG 5228. |
| 3225 |
C**** 7 AFTER FILTER 5229. |
| 3226 |
C**** 8 AFTER DAILY RESTORATION 5230. |
| 3227 |
C**** 5231. |
| 3228 |
RETURN 5332. |
| 3229 |
C**** 5333. |
| 3230 |
C**** 5334. |
| 3231 |
ENTRY DIAG9D (M,DT1,UX,VX) 5335. |
| 3232 |
CALL CLOCKS (MBEGIN) 5336. |
| 3233 |
C**** 5337. |
| 3234 |
C**** THE PARAMETER M INDICATES WHEN DIAG9D IS BEING CALLED 5338. |
| 3235 |
C**** M=1 AFTER ADVECTION IN DYNAMICS 5339. |
| 3236 |
C**** 2 AFTER CORIOLIS FORCE IN DYNAMICS 5340. |
| 3237 |
C**** 3 AFTER PRESSURE GRADIENT FORCE IN DYNAMICS 5341. |
| 3238 |
C**** 5342. |
| 3239 |
RETURN 5390. |
| 3240 |
C**** 5391. |
| 3241 |
C**** 5392. |
| 3242 |
ENTRY DIAG9P 5393. |
| 3243 |
C**** 5394. |
| 3244 |
C**** THIS ENTRY PRODUCES TABLES OF CONSERVATION QUANTITIES 5395. |
| 3245 |
C**** 5396. |
| 3246 |
NFILTR=NDYN 5396.1 |
| 3247 |
DO 720 J=1,JM 5397. |
| 3248 |
JLATP(J)=INT(.5+(J-1.)*180./JMM1)-90 5398. |
| 3249 |
720 JLATV(J)=INT(.5+(J-1.5)*180./JMM1)-90 5399. |
| 3250 |
C**** CALCULATE SCALEING FACTORS 5400. |
| 3251 |
DTSRCE=DT*NDYN 5401. |
| 3252 |
SCALE(1)=100.E-9*RADIUS/GRAV 5402. |
| 3253 |
SCALE(2)=100.E-2*RADIUS/(GRAV*IDACC(1)*DTSRCE+1.E-20) 5403. |
| 3254 |
SCALE(3)=SCALE(2) 5404. |
| 3255 |
SCALE(4)=SCALE(2) 5405. |
| 3256 |
SCALE(5)=SCALE(2) 5406. |
| 3257 |
SCALE(6)=100.E-2*RADIUS/(DTSRCE*GRAV*IDACC(1)+1.E-20) 5407. |
| 3258 |
SCALE(7)=SCALE(6) 5408. |
| 3259 |
SCALE(8)=SCALE(6) 5409. |
| 3260 |
SCALE(9)=100.E-2*RADIUS/(NFILTR*DT*GRAV*IDACC(10)+1.E-20) 5410. |
| 3261 |
SCALE(10)=100.E-2*RADIUS/(SDAY*GRAV*(IDAY-IDAY0)+1.E-20) 5411. |
| 3262 |
SCALE(11)=1. 5412. |
| 3263 |
SCALE(12)=25.E-3/GRAV 5413. |
| 3264 |
SCALE(13)=100.E3/(DTSRCE*GRAV*IDACC(1)+1.E-20) 5414. |
| 3265 |
SCALE(14)=SCALE(13) 5415. |
| 3266 |
SCALE(15)=SCALE(13) 5416. |
| 3267 |
SCALE(16)=SCALE(13) 5417. |
| 3268 |
SCALE(17)=25.E3/(DTSRCE*GRAV*IDACC(1)+1.E-20) 5418. |
| 3269 |
SCALE(18)=SCALE(17) 5419. |
| 3270 |
SCALE(19)=SCALE(17) 5420. |
| 3271 |
SCALE(20)=SCALE(17) 5421. |
| 3272 |
SCALE(21)=25.E3/(NFILTR*DT*GRAV*IDACC(10)+1.E-20) 5422. |
| 3273 |
SCALE(22)=25.E3/(SDAY*GRAV*(IDAY-IDAY0)+1.E-20) 5423. |
| 3274 |
SCALE(23)=1. 5424. |
| 3275 |
SCALE(24)=100.E0/GRAV 5425. |
| 3276 |
SCALE(25)=100.E8/(DTSRCE*GRAV*IDACC(1)+1.E-20) 5426. |
| 3277 |
SCALE(26)=100.E8/(NFILTR*DT*GRAV*IDACC(10)+1.E-20) 5427. |
| 3278 |
SCALE(27)=100.E8/(SDAY*GRAV*(IDAY-IDAY0)+1.E-20) 5428. |
| 3279 |
SCALE(28)=1. 5429. |
| 3280 |
SCALE(29)=100.E-5/GRAV 5430. |
| 3281 |
SCALE(30)=100.E2/(DTSRCE*GRAV*IDACC(1)+1.E-20) 5431. |
| 3282 |
SCALE(31)=SCALE(30) 5432. |
| 3283 |
SCALE(32)=SCALE(30) 5433. |
| 3284 |
SCALE(33)=SCALE(30) 5434. |
| 3285 |
SCALE(34)=100.E2/(NFILTR*DT*GRAV*IDACC(10)+1.E-20) 5435. |
| 3286 |
SCALE(35)=100.E2/(SDAY*GRAV*(IDAY-IDAY0)+1.E-20) 5436. |
| 3287 |
SCALE(36)=1. 5437. |
| 3288 |
C**** CALCULATE SUMMED QUANTITIES 5438. |
| 3289 |
DO 740 J=1,JM 5439. |
| 3290 |
CONSRV(J,4)=CONSRV(J,2)+CONSRV(J,3) 5440. |
| 3291 |
CONSRV(J,11)=CONSRV(J,6)*SCALE(6)+CONSRV(J,7)*SCALE(7) 5441. |
| 3292 |
* +CONSRV(J,8)*SCALE(8)+CONSRV(J,9)*SCALE(9) 5442. |
| 3293 |
* +CONSRV(J,10)*SCALE(10) 5443. |
| 3294 |
CONSRV(J,15)=CONSRV(J,13)+CONSRV(J,14) 5444. |
| 3295 |
CONSRV(J,23)=CONSRV(J,17)*SCALE(17)+CONSRV(J,18)*SCALE(18) 5445. |
| 3296 |
* +CONSRV(J,19)*SCALE(19)+CONSRV(J,20)*SCALE(20) 5446. |
| 3297 |
* +CONSRV(J,21)*SCALE(21)+CONSRV(J,22)*SCALE(22) 5447. |
| 3298 |
CONSRV(J,28)=CONSRV(J,25)*SCALE(25)+CONSRV(J,26)*SCALE(26) 5448. |
| 3299 |
* +CONSRV(J,27)*SCALE(27) 5449. |
| 3300 |
740 CONSRV(J,36)=CONSRV(J,30)*SCALE(30)+CONSRV(J,31)*SCALE(31) 5450. |
| 3301 |
* +CONSRV(J,32)*SCALE(32)+CONSRV(J,33)*SCALE(33) 5451. |
| 3302 |
* +CONSRV(J,34)*SCALE(34)+CONSRV(J,35)*SCALE(35) 5452. |
| 3303 |
C**** CALCULATE FINAL ANGULAR MOMENTUM 5453. |
| 3304 |
JEQ=1+JM/2 5454. |
| 3305 |
JEQM1=JEQ-1 5455. |
| 3306 |
DO 760 N=1,11 5456. |
| 3307 |
FEQ=CONSRV(JEQ,N)*SCALE(N)*COSV(JEQ) 5457. |
| 3308 |
FGLOB(N)=FEQ 5458. |
| 3309 |
FHEM(1,N)=.5*FEQ 5459. |
| 3310 |
FHEM(2,N)=.5*FEQ 5460. |
| 3311 |
MLAT(JEQ,N)=INT(FEQ/(FIM*DXYV(JEQ))+1000000.5)-1000000 5461. |
| 3312 |
DO 750 JSH=2,JEQM1 5462. |
| 3313 |
JNH=2+JM-JSH 5463. |
| 3314 |
FSH=CONSRV(JSH,N)*SCALE(N)*COSV(JSH) 5464. |
| 3315 |
FNH=CONSRV(JNH,N)*SCALE(N)*COSV(JNH) 5465. |
| 3316 |
FGLOB(N)=FGLOB(N)+(FSH+FNH) 5466. |
| 3317 |
FHEM(1,N)=FHEM(1,N)+FSH 5467. |
| 3318 |
FHEM(2,N)=FHEM(2,N)+FNH 5468. |
| 3319 |
MLAT(JSH,N)=INT(FSH/(FIM*DXYV(JSH))+1000000.5)-1000000 5469. |
| 3320 |
750 MLAT(JNH,N)=INT(FNH/(FIM*DXYV(JNH))+1000000.5)-1000000 5470. |
| 3321 |
FGLOB(N)=FGLOB(N)/AREAG 5471. |
| 3322 |
FHEM(1,N)=FHEM(1,N)/(.5*AREAG) 5472. |
| 3323 |
760 FHEM(2,N)=FHEM(2,N)/(.5*AREAG) 5473. |
| 3324 |
C**** CALCULATE FINAL KINETIC ENERGY 5474. |
| 3325 |
DO 780 N=12,23 5475. |
| 3326 |
FEQ=CONSRV(JEQ,N)*SCALE(N) 5476. |
| 3327 |
FGLOB(N)=FEQ 5477. |
| 3328 |
FHEM(1,N)=.5*FEQ 5478. |
| 3329 |
FHEM(2,N)=.5*FEQ 5479. |
| 3330 |
MLAT(JEQ,N)=INT(FEQ/(FIM*DXYV(JEQ))+1000000.5)-1000000 5480. |
| 3331 |
DO 770 JSH=2,JEQM1 5481. |
| 3332 |
JNH=2+JM-JSH 5482. |
| 3333 |
FSH=CONSRV(JSH,N)*SCALE(N) 5483. |
| 3334 |
FNH=CONSRV(JNH,N)*SCALE(N) 5484. |
| 3335 |
FGLOB(N)=FGLOB(N)+(FSH+FNH) 5485. |
| 3336 |
FHEM(1,N)=FHEM(1,N)+FSH 5486. |
| 3337 |
FHEM(2,N)=FHEM(2,N)+FNH 5487. |
| 3338 |
MLAT(JSH,N)=INT(FSH/(FIM*DXYV(JSH))+1000000.5)-1000000 5488. |
| 3339 |
770 MLAT(JNH,N)=INT(FNH/(FIM*DXYV(JNH))+1000000.5)-1000000 5489. |
| 3340 |
FGLOB(N)=FGLOB(N)/AREAG 5490. |
| 3341 |
FHEM(1,N)=FHEM(1,N)/(.5*AREAG) 5491. |
| 3342 |
780 FHEM(2,N)=FHEM(2,N)/(.5*AREAG) 5492. |
| 3343 |
C**** CALCUALTE FINAL MASS AND TOTAL POTENTIAL ENERGY 5493. |
| 3344 |
DO 800 N=24,36 5494. |
| 3345 |
FGLOB(N)=0. 5495. |
| 3346 |
FHEM(1,N)=0. 5496. |
| 3347 |
FHEM(2,N)=0. 5497. |
| 3348 |
DO 790 JSH=1,JEQM1 5498. |
| 3349 |
JNH=1+JM-JSH 5499. |
| 3350 |
FSH=CONSRV(JSH,N)*SCALE(N) 5500. |
| 3351 |
FNH=CONSRV(JNH,N)*SCALE(N) 5501. |
| 3352 |
FGLOB(N)=FGLOB(N)+(FSH+FNH)*DXYP(JSH) 5502. |
| 3353 |
FHEM(1,N)=FHEM(1,N)+FSH*DXYP(JSH) 5503. |
| 3354 |
FHEM(2,N)=FHEM(2,N)+FNH*DXYP(JNH) 5504. |
| 3355 |
MLAT(JSH,N)=INT(FSH/FIM+1000000.5)-1000000 5505. |
| 3356 |
790 MLAT(JNH,N)=INT(FNH/FIM+1000000.5)-1000000 5506. |
| 3357 |
FGLOB(N)=FGLOB(N)/AREAG 5507. |
| 3358 |
FHEM(1,N)=FHEM(1,N)/(.5*AREAG) 5508. |
| 3359 |
800 FHEM(2,N)=FHEM(2,N)/(.5*AREAG) 5509. |
| 3360 |
AGLOB=1.E-10*AREAG 5510. |
| 3361 |
AHEM=1.E-10*(.5*AREAG) 5511. |
| 3362 |
C**** LOOP OVER HEMISPHERES 5512. |
| 3363 |
INC=1+JMM1/24 5513. |
| 3364 |
IHOUR0=TOFDY0+.5 5514. |
| 3365 |
IHOUR=TOFDAY+.5 5515. |
| 3366 |
TAUDIF=TAU-TAU0 5516. |
| 3367 |
DO 870 JHEMIX=1,2 5517. |
| 3368 |
JHEMI=3-JHEMIX 5518. |
| 3369 |
c WRITE (6,901) XLABEL 5519. |
| 3370 |
c WRITE (6,902) IDAY0,IHOUR0,JDATE0,JMNTH0,JYEAR0,TAU0,IDAY,IHOUR, 5520. |
| 3371 |
c * JDATE,JMONTH,JYEAR,TAU,TAUDIF 5521. |
| 3372 |
JP1=1+(JHEMI-1)*(JEQ-1) 5522. |
| 3373 |
JPM=JHEMI*(JEQ-1) 5523. |
| 3374 |
JV1=2+(JHEMI-1)*(JEQ-2) 5524. |
| 3375 |
JVM=JEQ+(JHEMI-1)*(JEQ-2) 5525. |
| 3376 |
C**** PRODUCE TABLES FOR ANGULAR MOMENTUM AND KINETIC ENERGY 5526. |
| 3377 |
c WRITE (6,903) (DASH,J=JV1,JVM,INC) 5527. |
| 3378 |
c WRITE (6,904) HEMIS(JHEMI),(JLATV(JV1+JVM-JX),JX=JV1,JVM,INC) 5528. |
| 3379 |
c WRITE (6,903) (DASH,J=JV1,JVM,INC) 5529. |
| 3380 |
c DO 820 N=1,23 5530. |
| 3381 |
c 820 WRITE (6,905) TITLE(N),FGLOB(N),FHEM(JHEMI,N), 5531. |
| 3382 |
c * (MLAT(JV1+JVM-JX,N),JX=JV1,JVM,INC) 5532. |
| 3383 |
DO 830 J=JV1,JVM 5533. |
| 3384 |
830 MAREA(J)=1.E-10*FIM*DXYV(J)+.5 5534. |
| 3385 |
c WRITE (6,906) AGLOB,AHEM,(MAREA(JV1+JVM-JX),JX=JV1,JVM,INC) 5535. |
| 3386 |
C**** PRODUCE TABLES FOR MASS AND TOTAL POTENTIAL ENERGY 5536. |
| 3387 |
c WRITE (6,907) 5537. |
| 3388 |
c WRITE (6,903) (DASH,J=JP1,JPM,INC) 5538. |
| 3389 |
c WRITE (6,904) HEMIS(JHEMI),(JLATP(JP1+JPM-JX),JX=JP1,JPM,INC) 5539. |
| 3390 |
c WRITE (6,903) (DASH,J=JP1,JPM,INC) 5540. |
| 3391 |
c DO 840 N=24,36 5541. |
| 3392 |
c 840 WRITE (6,905) TITLE(N),FGLOB(N),FHEM(JHEMI,N), 5542. |
| 3393 |
c * (MLAT(JP1+JPM-JX,N),JX=JP1,JPM,INC) 5543. |
| 3394 |
DO 850 J=JP1,JPM 5544. |
| 3395 |
850 MAREA(J)=1.E-10*FIM*DXYP(J)+.5 5545. |
| 3396 |
c WRITE (6,906) AGLOB,AHEM,(MAREA(JP1+JPM-JX),JX=JP1,JPM,INC) 5546. |
| 3397 |
c DO 860 LSKIP=1,10 5547. |
| 3398 |
c 860 WRITE (6,920) 5548. |
| 3399 |
870 CONTINUE 5549. |
| 3400 |
RETURN 5550. |
| 3401 |
C**** 5551. |
| 3402 |
901 FORMAT ('1',33A4) 5552. |
| 3403 |
902 FORMAT ('0CONSERVATION QUANTITIES DAY',I5,', HR',I2,' (',I2, 5553. |
| 3404 |
* A5,I4,')',F8.0,' TO DAY',I5,', HR',I2,' (',I2,A5,I4,')', 5554. |
| 3405 |
* F8.0,' DIF',F5.0,' HR'/) 5555. |
| 3406 |
903 FORMAT (1X,25('--'),13(A4,'--')) 5556. |
| 3407 |
904 FORMAT (35X,'GLOBAL',A7,2X,13I6) 5557. |
| 3408 |
905 FORMAT (A32,2F9.2,1X,13I6) 5558. |
| 3409 |
906 FORMAT ('0AREA (10**10 M**2)',F22.1,F9.1,1X,13I6) 5559. |
| 3410 |
907 FORMAT ('0') 5560. |
| 3411 |
920 FORMAT (1X) 5561. |
| 3412 |
END 5562. |
| 3413 |
SUBROUTINE DIAG5A (M25,NDT) 6001. |
| 3414 |
C**** 6002. |
| 3415 |
C**** THIS DIAGNOSTICS ROUTINE PRODUCES A SPECTRAL ANALYSIS OF KINETIC 6003. |
| 3416 |
C**** AND AVAILABLE POTENTIAL ENERGIES AND THEIR TRANSFER RATES BY 6004. |
| 3417 |
C**** VARIOUS ATMOSPHERIC PROCESSES. 6005. |
| 3418 |
C**** 6006. |
| 3419 |
C**** THE PARAMETER M25 INDICATES WHAT IS STORED IN SPECA(N,M25,KSPHER),6007. |
| 3420 |
C**** IT ALSO INDICATES WHEN DIAG5A IS BEING CALLED. 6008. |
| 3421 |
C**** M=1 MEAN STANDING KINETIC ENERGY BEFORE SOURCES 6009. |
| 3422 |
C**** 2 MEAN KINETIC ENERGY BEFORE DYNAMICS 6010. |
| 3423 |
C**** 3 MEAN POTENTIAL ENERGY 6011. |
| 3424 |
C**** 4 CONVERSION OF K.E. BY ADVECTION AFTER ADVECTION 6012. |
| 3425 |
C**** 5 CONVERSION OF K.E. BY CORIOLIS FORCE AFTER CORIOLIS TERM 6013. |
| 3426 |
C**** 6 CONVERSION FROM P.E. INTO K.E. AFTER PRESS GRAD FORC6014. |
| 3427 |
C**** 7 CHANGE OF K.E. BY DYNAMICS AFTER DYNAMICS 6015. |
| 3428 |
C**** 8 CHANGE OF P.E. BY DYNAMICS 6016. |
| 3429 |
C**** 9 CHANGE OF K.E. BY CONDENSATION AFTER CONDENSATION 6017. |
| 3430 |
C**** 10 CHANGE OF P.E. BY CONDENSATION 6018. |
| 3431 |
C**** 11 CHANGE OF P.E. BY RADIATION AFTER RADIATION 6019. |
| 3432 |
C**** 12 CHANGE OF K.E. BY SURFACE AFTER SURFACE 6020. |
| 3433 |
C**** 13 CHANGE OF P.E. BY SURFACE 6021. |
| 3434 |
C**** 14 CHANGE OF K.E. BY FILTER AFTER FILTER 6022. |
| 3435 |
C**** 15 CHANGE OF P.E. BY FILTER 6023. |
| 3436 |
C**** 16 CHANGE OF K.E. BY DAILY AFTER DAILY 6024. |
| 3437 |
C**** 17 CHANGE OF P.E. BY DAILY 6025. |
| 3438 |
C**** 18 UNUSED 6026. |
| 3439 |
C**** 19 LAST KINETIC ENERGY 6027. |
| 3440 |
C**** 20 LAST POTENTIAL ENERGY 6028. |
| 3441 |
C**** 6029. |
| 3442 |
#include "BD2G04.COM" 6030. |
| 3443 |
COMMON U,V,T,P,Q 6031. |
| 3444 |
REAL KE 6032. |
| 3445 |
c REAL*8 TPE,SUMI,SUMT 6033. |
| 3446 |
COMMON/WORK1/PIT(IM0,JM0),SD(IM0,JM0,LM0-1),PK(IM0,JM0,LM0) 6034. |
| 3447 |
COMMON/WORK5/DUT(IO0,JM0,LM0),DVT(IO0,JM0,LM0), |
| 3448 |
& FCUV(2,19,JM0,LM0,2), 6035. |
| 3449 |
* FC(2,37),KE(37,8),APE(37,8),VAR(37,4),TPE(2),X(72), 6036. |
| 3450 |
* SQRTM(72,46),SQRTP(72,46),THJSP(36),THJNP(36),THGM(36), 6037. |
| 3451 |
* SCALE(20),MN(20),F0(20),FNSUM(20) 6038. |
| 3452 |
DIMENSION UX(IO0,JM0,*) 6039. |
| 3453 |
DIMENSION MTPEOF(20),MAPEOF(8) 6040. |
| 3454 |
CHARACTER*8 LATITD(4)/'SOUTHERN','NORTHERN',' EQUATOR','45 NORTH'/6041. |
| 3455 |
CHARACTER*16 SPHERE(2)/'STRATOSPHERE','TROPOSPHERE'/ 6042. |
| 3456 |
DATA MTPEOF/0,0,1,0,0,0,0,2,0,3, 4,0,5,0,6,0,7,0,0,8/ 6043. |
| 3457 |
DATA MAPEOF/3,8,10,11,13,15,17,20/,IZERO/0/ 6044. |
| 3458 |
NM=1+IM/2 6045. |
| 3459 |
NM8=296 6046. |
| 3460 |
JEQ=1+JM/2 6047. |
| 3461 |
JEQM1=JEQ-1 6048. |
| 3462 |
J45N=2.+.75*JMM1 6049. |
| 3463 |
FIO=IO 6049.5 |
| 3464 |
IJL2=IM*JM*LM*2 6050. |
| 3465 |
SHA=RGAS/KAPA 6051. |
| 3466 |
MKE=M25 6052. |
| 3467 |
MAPE=M25 6053. |
| 3468 |
C**** 6054. |
| 3469 |
C**** KSPHER=1 SOUTHERN STRATOSPHERE 3 NORTHERN STRATOSPHERE 6055. |
| 3470 |
C**** 2 SOUTHERN TROPOSPHERE 4 NORTHERN TROPOSPHERE 6056. |
| 3471 |
C**** 6057. |
| 3472 |
C**** 5 EQUATORIAL STRATOSPHERE 7 45 DEG NORTH STRATOSPHERE 6058. |
| 3473 |
C**** 6 EQUATORIAL TROPOSPHERE 8 45 DEG NORTH TROPOSPHERE 6059. |
| 3474 |
C**** 6060. |
| 3475 |
GO TO (200,200,810,100,100, 100,200,810,205,810, 6061. |
| 3476 |
* 296,205,810,205,810, 205,810,810,810,810),M25 6062. |
| 3477 |
C**** 6063. |
| 3478 |
C**** KINETIC ENERGY 6064. |
| 3479 |
C**** 6065. |
| 3480 |
C**** TRANSFER RATES FOR KINETIC ENERGY IN THE DYNAMICS 6066. |
| 3481 |
100 CALL CLOCKS (MBEGIN) 6067. |
| 3482 |
DO 110 N=1,NM8 6068. |
| 3483 |
110 KE(N,1)=0. 6069. |
| 3484 |
DO 170 L=1,LM 6070. |
| 3485 |
KSPHER=2 6071. |
| 3486 |
IF (L.GE.LS1) KSPHER=1 6072. |
| 3487 |
DO 170 J=2,JM 6073. |
| 3488 |
DO 170 K=IZERO,LM,LM 6074. |
| 3489 |
CALL GETAN(DUT(1,J,L+K),FC) 6075. |
| 3490 |
DO 120 N=1,NM 6076. |
| 3491 |
120 X(N)=.5*FIM*(FC(1,N)*FCUV(1,N,J,L+K,1)+FC(2,N)*FCUV(2,N,J,L+K,1)) 6077. |
| 3492 |
X(1)=X(1)+X(1) 6078. |
| 3493 |
X(NM)=X(NM)+X(NM) 6079. |
| 3494 |
IF (J.EQ.JEQ) GO TO 150 6080. |
| 3495 |
DO 130 N=1,NM 6081. |
| 3496 |
130 KE(N,KSPHER)=KE(N,KSPHER)+X(N)*DSIG(L) 6082. |
| 3497 |
IF (J.NE.J45N) GO TO 170 6083. |
| 3498 |
DO 140 N=1,NM 6084. |
| 3499 |
140 KE(N,KSPHER+4)=KE(N,KSPHER+4)+X(N)*DSIG(L) 6085. |
| 3500 |
GO TO 170 6086. |
| 3501 |
150 DO 160 N=1,NM 6087. |
| 3502 |
KE(N,KSPHER+4)=KE(N,KSPHER+4)+X(N)*DSIG(L) 6088. |
| 3503 |
KE(N,KSPHER)=KE(N,KSPHER)+.5D0*X(N)*DSIG(L) 6089. |
| 3504 |
160 KE(N,KSPHER+2)=KE(N,KSPHER+2)+.5D0*X(N)*DSIG(L) 6090. |
| 3505 |
IF (K.EQ.LM) KSPHER=KSPHER+2 6091. |
| 3506 |
170 CONTINUE 6092. |
| 3507 |
DO 180 KS=1,8 6093. |
| 3508 |
DO 180 N=1,NM 6094. |
| 3509 |
180 SPECA(N,MKE,KS)=SPECA(N,MKE,KS)+KE(N,KS)/NDT 6095. |
| 3510 |
CALL CLOCKS (MEND) 6096. |
| 3511 |
MINC=MBEGIN-MEND 6097. |
| 3512 |
MDIAG=MDIAG+MINC 6098. |
| 3513 |
MDYN=MDYN-MINC 6099. |
| 3514 |
RETURN 6100. |
| 3515 |
C**** MASS FOR KINETIC ENERGY 6101. |
| 3516 |
200 I=IM 6102. |
| 3517 |
DO 202 J=2,JM 6103. |
| 3518 |
DO 202 IP1=1,IM 6104. |
| 3519 |
SQRTM(I,J)=SQRT(.5*((P(I,J)+P(IP1,J))*DXYS(J)+(P(I,J-1)+ 6105. |
| 3520 |
* P(IP1,J-1))*DXYN(J-1))) 6106. |
| 3521 |
202 I=IP1 6107. |
| 3522 |
C**** 6108. |
| 3523 |
205 MAPE=MKE+1 6109. |
| 3524 |
DO 206 N=1,NM8 6110. |
| 3525 |
206 KE(N,1)=0. 6111. |
| 3526 |
C**** CURRENT KINETIC ENERGY 6112. |
| 3527 |
DO 240 L=1,LM 6113. |
| 3528 |
KSPHER=2 6114. |
| 3529 |
IF(L.GE.LS1) KSPHER=1 6115. |
| 3530 |
DO 240 J=2,JM 6116. |
| 3531 |
DO 240 K=IZERO,LM,LM 6117. |
| 3532 |
DO 210 I=1,IO 6118. |
| 3533 |
210 X(I)=U(1,J,L+K)*SQRTM(1,J) 6119. |
| 3534 |
c CALL FRTR (X) 6120. |
| 3535 |
DO 215 N=1,NM 6120.5 |
| 3536 |
215 IF(IM.EQ.1) X(N)=X(N)/FIO 6120.6 |
| 3537 |
IF(J.EQ.JEQ) GO TO 225 6121. |
| 3538 |
DO 220 N=1,NM 6122. |
| 3539 |
220 KE(N,KSPHER)=KE(N,KSPHER)+X(N)*DSIG(L) 6123. |
| 3540 |
IF(J.NE.J45N) GO TO 240 6124. |
| 3541 |
DO 222 N=1,NM 6125. |
| 3542 |
222 KE(N,KSPHER+4)=KE(N,KSPHER+4)+X(N)*DSIG(L) 6126. |
| 3543 |
GO TO 240 6127. |
| 3544 |
225 DO 230 N=1,NM 6128. |
| 3545 |
KE(N,KSPHER+4)=KE(N,KSPHER+4)+X(N)*DSIG(L) 6129. |
| 3546 |
KE(N,KSPHER)=KE(N,KSPHER)+.5D0*X(N)*DSIG(L) 6130. |
| 3547 |
230 KE(N,KSPHER+2)=KE(N,KSPHER+2)+.5D0*X(N)*DSIG(L) 6131. |
| 3548 |
IF(K.EQ.LM) KSPHER=KSPHER+2 6132. |
| 3549 |
240 CONTINUE 6133. |
| 3550 |
IF (NDT.EQ.0) GO TO 260 6134. |
| 3551 |
C**** TRANSFER RATES AS DIFFERENCES OF KINETIC ENERGY 6135. |
| 3552 |
DO 250 KS=1,8 6136. |
| 3553 |
DO 250 N=1,NM 6137. |
| 3554 |
250 SPECA(N,MKE,KS)=SPECA(N,MKE,KS)+(KE(N,KS)-SPECA(N,19,KS))/NDT 6138. |
| 3555 |
260 DO 270 KS=1,8 6139. |
| 3556 |
DO 270 N=1,NM 6140. |
| 3557 |
270 SPECA(N,19,KS)=KE(N,KS) 6141. |
| 3558 |
C**** 6142. |
| 3559 |
C**** POTENTIAL ENERGY 6143. |
| 3560 |
C**** 6144. |
| 3561 |
IF(DOPK.EQ.-1.) GO TO 296 6145. |
| 3562 |
C**** COMPUTE SQRTP = SQRT(P) AND PK = P**KAPA 6146. |
| 3563 |
SQRTP1=SQRT(P(1,1)) 6147. |
| 3564 |
SQRTPM=SQRT(P(1,JM)) 6148. |
| 3565 |
DO 290 J=2,JMM1 6149. |
| 3566 |
DO 290 I=1,IM 6150. |
| 3567 |
290 SQRTP(I,J)=SQRT(P(I,J)) 6151. |
| 3568 |
DO 292 I=1,IM 6152. |
| 3569 |
SQRTP(I,1)=SQRTP1 6153. |
| 3570 |
292 SQRTP(I,JM)=SQRTPM 6154. |
| 3571 |
IF(DOPK.EQ.0.) GO TO 296 6155. |
| 3572 |
DO 294 L=1,LM 6156. |
| 3573 |
DO 294 J=1,JM 6157. |
| 3574 |
DO 294 I=1,IM 6158. |
| 3575 |
294 PK(I,J,L)=EXPBYK(SIG(L)*P(I,J)+PTOP) 6159. |
| 3576 |
296 DOPK=-1. 6160. |
| 3577 |
DO 298 N=1,NM8 6161. |
| 3578 |
298 APE(N,1)=0. 6162. |
| 3579 |
C**** CURRENT AVAILABLE POTENTIAL ENERGY 6163. |
| 3580 |
LUP=0 6164. |
| 3581 |
300 LUP=LUP+1 6165. |
| 3582 |
THJSP(LUP)=T(1,1,LUP)*SQRTP(1,1) 6166. |
| 3583 |
THJNP(LUP)=T(1,JM,LUP)*SQRTP(1,JM) 6167. |
| 3584 |
THGSUM=FIM*(THJSP(LUP)*DXYP(1)+THJNP(LUP)*DXYP(JM)) 6168. |
| 3585 |
DO 320 J=2,JMM1 6169. |
| 3586 |
THJSUM=0. 6170. |
| 3587 |
DO 310 I=1,IM 6171. |
| 3588 |
310 THJSUM=THJSUM+T(I,J,LUP)*SQRTP(I,J) 6172. |
| 3589 |
320 THGSUM=THGSUM+THJSUM*DXYP(J) 6173. |
| 3590 |
THGM(LUP)=THGSUM/AREAG 6174. |
| 3591 |
IF(LUP.GE.2) GO TO 350 6175. |
| 3592 |
LDN=LUP 6176. |
| 3593 |
L=LUP 6177. |
| 3594 |
GO TO 300 6178. |
| 3595 |
350 DO 360 JHEMI=1,2 6179. |
| 3596 |
DO 360 N=1,NM 6180. |
| 3597 |
360 VAR(N,JHEMI)=0. 6181. |
| 3598 |
VAR(1,1)=.5*(THJSP(L)-THGM(L))**2*DXYP(1)*FIM 6182. |
| 3599 |
VAR(1,2)=.5*(THJNP(L)-THGM(L))**2*DXYP(JM)*FIM 6183. |
| 3600 |
GMEAN=((THJSP(LUP)-THJSP(LDN))*DXYP(1)*(SIG(L)*P(1,1)+PTOP)/ 6184. |
| 3601 |
* (SQRTP1*P(1,1)*PK(1,1,L)) + (THJNP(LUP)-THJNP(LDN))*DXYP(JM)* 6185. |
| 3602 |
* (SIG(L)*P(1,JM)+PTOP)/(SQRTPM*P(1,JM)*PK(1,JM,L)))*FIM 6186. |
| 3603 |
JHEMI=1 6187. |
| 3604 |
DO 388 J=2,JMM1 6188. |
| 3605 |
GMSUM=0. 6189. |
| 3606 |
DO 370 I=1,IO 6190. |
| 3607 |
370 X(I)=T(1,J,L)*SQRTP(1,J)-THGM(L) 6191. |
| 3608 |
c INDEX=J+24*(LUP-1) 6191.5 |
| 3609 |
INDEX=J+JM*(LUP-1) |
| 3610 |
GMSUM=FIO*(T(INDEX,1,1)-T(1,J,LDN))*(SIG(L)*P(1,J)+PTOP)/ 6192. |
| 3611 |
* (P(1,J)*PK(1,J,L)) 6193. |
| 3612 |
GMEAN=GMEAN+GMSUM*DXYP(J)/FIO 6194. |
| 3613 |
c CALL FRTR (X) 6195. |
| 3614 |
DO 375 N=1,NM 6195.5 |
| 3615 |
375 IF(IM.EQ.1) X(N)=X(N)/FIO 6195.6 |
| 3616 |
DO 380 N=1,NM 6196. |
| 3617 |
380 VAR(N,JHEMI)=VAR(N,JHEMI)+X(N)*DXYP(J) 6197. |
| 3618 |
IF(J.NE.JEQ-1) GO TO 384 6198. |
| 3619 |
DO 382 N=1,NM 6199. |
| 3620 |
382 VAR(N,3)=X(N)*DXYP(J) 6200. |
| 3621 |
JHEMI=2 6201. |
| 3622 |
384 IF(J.NE.J45N-1) GO TO 388 6202. |
| 3623 |
DO 386 N=1,NM 6203. |
| 3624 |
386 VAR(N,4)=X(N)*DXYP(J) 6204. |
| 3625 |
388 CONTINUE 6205. |
| 3626 |
GMEAN=DSIG(L)*AREAG*(SIG(LDN)-SIG(LUP))/GMEAN 6206. |
| 3627 |
KS=2 6207. |
| 3628 |
IF(L.GE.LS1) KS=1 6208. |
| 3629 |
DO 400 JHEMI=1,4 6209. |
| 3630 |
DO 390 N=1,NM 6210. |
| 3631 |
390 APE(N,KS)=APE(N,KS)+VAR(N,JHEMI)*GMEAN 6211. |
| 3632 |
400 KS=KS+2 6212. |
| 3633 |
IF(L.EQ.LM) GO TO 450 6213. |
| 3634 |
LDN=L 6214. |
| 3635 |
L=LUP 6215. |
| 3636 |
IF(LUP.LT.LM) GO TO 300 6216. |
| 3637 |
GO TO 350 6217. |
| 3638 |
C**** CURRENT TOTAL POTENTIAL ENERGY 6218. |
| 3639 |
450 DO 480 JHEMI=1,2 6219. |
| 3640 |
JP=1+JMM1*(JHEMI-1) 6220. |
| 3641 |
SUMT=0. 6221. |
| 3642 |
DO 455 L=1,LM 6222. |
| 3643 |
455 SUMT=SUMT+T(1,JP,L)*PK(1,JP,L)*DSIG(L) 6223. |
| 3644 |
TPE(JHEMI)=FIM*DXYP(JP)*(FDATA(1,JP,1)*(P(1,JP)+PTOP)+ 6224. |
| 3645 |
* SUMT*SHA*P(1,JP)) 6225. |
| 3646 |
DO 480 JH=2,JEQM1 6226. |
| 3647 |
J=JH+(JEQM1-1)*(JHEMI-1) 6227. |
| 3648 |
SUMI=0. 6228. |
| 3649 |
DO 470 I=1,IM 6229. |
| 3650 |
SUMT=0. 6230. |
| 3651 |
DO 460 L=1,LM 6231. |
| 3652 |
460 SUMT=SUMT+T(I,J,L)*PK(I,J,L)*DSIG(L) 6232. |
| 3653 |
470 SUMI=SUMI+FDATA(I,J,1)*(P(I,J)+PTOP)+SUMT*SHA*P(I,J) 6233. |
| 3654 |
480 TPE(JHEMI)=TPE(JHEMI)+SUMI*DXYP(J) 6234. |
| 3655 |
IF (NDT.EQ.0) GO TO 520 6235. |
| 3656 |
MTPE=MTPEOF(MAPE) 6236. |
| 3657 |
C**** TRANSFER RATES AS DIFFERENCES FOR POTENTIAL ENERGY 6237. |
| 3658 |
DO 510 KS=1,8 6238. |
| 3659 |
DO 510 N=1,NM 6239. |
| 3660 |
510 SPECA(N,MAPE,KS)=SPECA(N,MAPE,KS)+(APE(N,KS)-SPECA(N,20,KS))/NDT 6240. |
| 3661 |
ATPE(MTPE,1)=ATPE(MTPE,1)+(TPE(1)-ATPE(8,1))/NDT 6241. |
| 3662 |
ATPE(MTPE,2)=ATPE(MTPE,2)+(TPE(2)-ATPE(8,2))/NDT 6242. |
| 3663 |
520 DO 530 KS=1,8 6243. |
| 3664 |
DO 530 N=1,NM 6244. |
| 3665 |
530 SPECA(N,20,KS)=APE(N,KS) 6245. |
| 3666 |
ATPE(8,1)=TPE(1) 6246. |
| 3667 |
ATPE(8,2)=TPE(2) 6247. |
| 3668 |
CALL CLOCKS (MNOW) 6248. |
| 3669 |
MDIAG=MDIAG+MLAST-MNOW 6249. |
| 3670 |
MLAST=MNOW 6250. |
| 3671 |
IF(M25.NE.2) RETURN 6251. |
| 3672 |
C**** ACCUMULATE MEAN KINETIC ENERGY AND MEAN POTENTIAL ENERGY 6252. |
| 3673 |
IDACC(7)=IDACC(7)+1 6253. |
| 3674 |
DO 550 KS=1,8 6254. |
| 3675 |
DO 550 N=1,NM 6255. |
| 3676 |
SPECA(N,2,KS)=SPECA(N,2,KS)+KE(N,KS) 6256. |
| 3677 |
550 SPECA(N,3,KS)=SPECA(N,3,KS)+APE(N,KS) 6257. |
| 3678 |
ATPE(1,1)=ATPE(1,1)+TPE(1) 6258. |
| 3679 |
ATPE(1,2)=ATPE(1,2)+TPE(2) 6259. |
| 3680 |
RETURN 6260. |
| 3681 |
C**** 6261. |
| 3682 |
ENTRY DIAG5F(UX) 6262. |
| 3683 |
C**** FOURIER COEFFICIENTS FOR CURRENT WIND FIELD 6263. |
| 3684 |
C**** 6264. |
| 3685 |
CALL CLOCKS (MBEGIN) 6265. |
| 3686 |
DO 590 K=IZERO,LM,LM 6266. |
| 3687 |
DO 590 L=1,LM 6267. |
| 3688 |
DO 590 J=2,JM 6268. |
| 3689 |
590 CALL GETAN(UX(1,J,L+K),FCUV(1,1,J,L+K,1)) 6269. |
| 3690 |
IDACC(6)=IDACC(6)+1 6270. |
| 3691 |
CALL CLOCKS (MEND) 6271. |
| 3692 |
MINC=MBEGIN-MEND 6272. |
| 3693 |
MDIAG=MDIAG+MINC 6273. |
| 3694 |
MDYN=MDYN-MINC 6274. |
| 3695 |
RETURN 6275. |
| 3696 |
C**** 6276. |
| 3697 |
ENTRY DIAG5P 6277. |
| 3698 |
C**** THIS ENTRY PRINTS THE SPECTRAL ANALYSIS TABLES 6278. |
| 3699 |
C**** 6279. |
| 3700 |
NM=1+IM/2 6280. |
| 3701 |
IF(SKIPSE.GE.1.) GO TO 600 6281. |
| 3702 |
JEQ=1+JM/2 6282. |
| 3703 |
J45N=2.+.75*JMM1 6283. |
| 3704 |
FIO=IO 6283.5 |
| 3705 |
C**** 6284. |
| 3706 |
C**** STANDING KINETIC ENERGY 6285. |
| 3707 |
C**** 6286. |
| 3708 |
DO 710 K=1,8 6287. |
| 3709 |
DO 710 N=1,NM 6288. |
| 3710 |
710 SPECA(N,1,K)=0. 6289. |
| 3711 |
DO 770 L=1,LM 6290. |
| 3712 |
KSPHER=2 6291. |
| 3713 |
IF(L.GE.LS1) KSPHER=1 6292. |
| 3714 |
DO 770 J=2,JM 6293. |
| 3715 |
FACTOR=DSIG(L)*FIM*DXYV(J)/APJ(J,2) 6294. |
| 3716 |
DO 770 K=IZERO,LM,LM 6295. |
| 3717 |
DO 720 I=1,IO 6296. |
| 3718 |
720 X(I)=AIJL(1,J,L+K,1) 6297. |
| 3719 |
c CALL FRTR (X) 6298. |
| 3720 |
DO 725 N=1,NM 6298.5 |
| 3721 |
725 IF(IM.EQ.1) X(N)=X(N)/FIO 6298.6 |
| 3722 |
IF(J.EQ.JEQ) GO TO 750 6299. |
| 3723 |
DO 730 N=1,NM 6300. |
| 3724 |
730 SPECA(N,1,KSPHER)=SPECA(N,1,KSPHER)+X(N)*FACTOR 6301. |
| 3725 |
IF(J.NE.J45N) GO TO 770 6302. |
| 3726 |
DO 740 N=1,NM 6303. |
| 3727 |
740 SPECA(N,1,KSPHER+4)=SPECA(N,1,KSPHER+4)+X(N)*FACTOR 6304. |
| 3728 |
GO TO 770 6305. |
| 3729 |
750 DO 760 N=1,NM 6306. |
| 3730 |
SPECA(N,1,KSPHER+4)=SPECA(N,1,KSPHER+4)+X(N)*FACTOR 6307. |
| 3731 |
SPECA(N,1,KSPHER)=SPECA(N,1,KSPHER)+.5*X(N)*FACTOR 6308. |
| 3732 |
760 SPECA(N,1,KSPHER+2)=SPECA(N,1,KSPHER+2)+.5*X(N)*FACTOR 6309. |
| 3733 |
IF(K.EQ.LM) KSPHER=KSPHER+2 6310. |
| 3734 |
770 CONTINUE 6311. |
| 3735 |
C**** 6312. |
| 3736 |
600 SCALE(1)=25.E-17/(GRAV*IDACC(4)+1.E-20) 6313. |
| 3737 |
SCALE(19)=100.E-17/GRAV 6314. |
| 3738 |
SCALE(20)=SCALE(19)*RGAS 6315. |
| 3739 |
SCALE(2)=SCALE(19)/(IDACC(7)+1.E-20) 6316. |
| 3740 |
SCALE(3)=SCALE(2)*RGAS 6317. |
| 3741 |
SCALE(4)=100.E-12/(GRAV*DT*IDACC(6)+1.E-20) 6318. |
| 3742 |
SCALE(5)=SCALE(4) 6319. |
| 3743 |
SCALE(6)=SCALE(4) 6320. |
| 3744 |
SCALE(7)=100.E-12/(GRAV*DT*(IDACC(7)+1.E-20)) 6321. |
| 3745 |
SCALE(8)=SCALE(7)*RGAS 6322. |
| 3746 |
SCALE(9)=100.E-12/(GRAV*DT*(IDACC(8)+1.E-20)) 6323. |
| 3747 |
SCALE(10)=SCALE(9)*RGAS 6324. |
| 3748 |
SCALE(11)=SCALE(10) 6325. |
| 3749 |
SCALE(12)=SCALE(9) 6326. |
| 3750 |
SCALE(13)=SCALE(10) 6327. |
| 3751 |
SCALE(14)=100.E-12/(GRAV*DT*(IDACC(10)+1.E-20)) 6328. |
| 3752 |
SCALE(15)=SCALE(14)*RGAS 6329. |
| 3753 |
SCALE(16)=100.E-12/(GRAV*DT*(IDAY-IDAY0+1.E-20)) 6330. |
| 3754 |
SCALE(17)=SCALE(16)*RGAS 6331. |
| 3755 |
SCALE(18)=0. 6332. |
| 3756 |
IUNITJ=17 6333. |
| 3757 |
IUNITW=12 6334. |
| 3758 |
IHOUR0=TOFDY0+.5 6335. |
| 3759 |
IHOUR=TOFDAY+.5 6336. |
| 3760 |
DO 690 KPAGE=1,4 6337. |
| 3761 |
C**** WRITE HEADINGS 6338. |
| 3762 |
c WRITE (6,901) XLABEL 6339. |
| 3763 |
c WRITE (6,902) IDAY0,IHOUR0,JDATE0,JMNTH0,JYEAR0,IDAY,IHOUR,JDATE, 6340. |
| 3764 |
c * JMONTH,JYEAR,IUNITJ,IUNITW 6341. |
| 3765 |
DO 670 KROW=1,2 6342. |
| 3766 |
c IF(JM.GE.25.AND.KROW.EQ.2) WRITE (6,901) 6343. |
| 3767 |
c WRITE (6,903) LATITD(KPAGE),SPHERE(KROW) 6344. |
| 3768 |
KSPHER=2*(KPAGE-1)+KROW 6345. |
| 3769 |
C**** WRITE KINETIC AND AVAILABLE POTENTIAL ENERGY BY WAVE NUMBER 6346. |
| 3770 |
C DO 610 M=1,20 6347. |
| 3771 |
C F0(M)=SPECA(1,M,KSPHER)*SCALE(M) 6348. |
| 3772 |
C MN(M)=INT(F0(M)+100000.5)-100000 6349. |
| 3773 |
C 610 FNSUM(M)=0. 6350. |
| 3774 |
C WRITE (6,904) MN 6351. |
| 3775 |
IF(IM.EQ.1) GO TO 635 6351.5 |
| 3776 |
DO 630 N=2,NM 6352. |
| 3777 |
KSPHER=2*(KPAGE-1)+KROW 6353. |
| 3778 |
DO 620 M=1,20 6354. |
| 3779 |
FNM=SPECA(N,M,KSPHER)*SCALE(M) 6355. |
| 3780 |
MN(M)=INT(FNM+100000.5)-100000 6356. |
| 3781 |
620 FNSUM(M)=FNSUM(M)+FNM 6357. |
| 3782 |
NM1=N-1 6358. |
| 3783 |
IF(KSPHER.LT.8) GO TO 630 6359. |
| 3784 |
FN26=SPECA(N,2,6)*SCALE(2) 6360. |
| 3785 |
FN28=SPECA(N,2,8)*SCALE(2) 6361. |
| 3786 |
CALL KEYD5A (NM1,FN26,FN28) 6362. |
| 3787 |
c 630 WRITE (6,905) NM1,MN 6363. |
| 3788 |
630 continue |
| 3789 |
635 CONTINUE 6363.5 |
| 3790 |
DO 640 M=1,20 6364. |
| 3791 |
640 MN(M)=INT(FNSUM(M)+100000.5)-100000 6365. |
| 3792 |
c WRITE (6,906) MN 6366. |
| 3793 |
DO 650 M=1,20 6367. |
| 3794 |
650 MN(M)=INT(FNSUM(M)+F0(M)+100000.5)-100000 6368. |
| 3795 |
c WRITE (6,907) MN 6369. |
| 3796 |
670 CONTINUE 6370. |
| 3797 |
IF(KPAGE.GE.3) GO TO 690 6371. |
| 3798 |
C**** WRITE TOTAL POTENTIAL ENERGY 6372. |
| 3799 |
DO 680 MTPE=1,8 6373. |
| 3800 |
MAPE=MAPEOF(MTPE) 6374. |
| 3801 |
680 MN(MTPE)=INT(ATPE(MTPE,KPAGE)*SCALE(MAPE)/RGAS+1000000.5) 6375. |
| 3802 |
* -1000000 6376. |
| 3803 |
c WRITE (6,909) (MN(MTPE),MTPE=1,8) 6377. |
| 3804 |
IF(KPAGE.NE.2) GO TO 690 6378. |
| 3805 |
DO 685 M=1,20 6379. |
| 3806 |
685 SCALE(M)=SCALE(M)*10. 6380. |
| 3807 |
IUNITJ=16 6381. |
| 3808 |
IUNITW=11 6382. |
| 3809 |
690 CONTINUE 6383. |
| 3810 |
RETURN 6384. |
| 3811 |
C**** 6385. |
| 3812 |
810 WRITE (6,910) M25 6386. |
| 3813 |
STOP 29 6387. |
| 3814 |
901 FORMAT ('1',33A4) 6388. |
| 3815 |
902 FORMAT ('0** SPECTRAL ANALYSIS ** DAY',I5,', HR',I2,' (',I2, 6389. |
| 3816 |
* A5,I4,') TO DAY',I5,', HR',I2,' (',I2,A5,I4, 6390. |
| 3817 |
* ') UNITS 10**',I2,' JOULES AND 10**',I2,' WATTS') 6391. |
| 3818 |
903 FORMAT ('0',50X,A8,A9,A8/ 6392. |
| 3819 |
* 13X,'MEAN',19X,'DYNAMICS',25X,'SOURCES',16X,'FILTER',8X, 6393. |
| 3820 |
* 'DAILY',16X,'LAST'/ 6394. |
| 3821 |
*' N SKE KE APE KADV KCOR P-K KDYN PDYN ', 6395. |
| 3822 |
* 'KCNDS PCNDS PRAD KSURF PSURF KFIL PFIL KGMP PGMP', 6396. |
| 3823 |
* 12X,'KE APE') 6397. |
| 3824 |
904 FORMAT ( '0 0',I7,I5,I6,I8,4I6,I8,I6,I7,2I6,I7,I6,I7,2I6,I8,I6/) 6398. |
| 3825 |
905 FORMAT ( I4,I7,I5,I6,I8,4I6,I8,I6,I7,2I6,I7,I6,I7,2I6,I8,I6) 6399. |
| 3826 |
906 FORMAT (' EDDY',I6,I5,I6,I8,4I6,I8,I6,I7,2I6,I7,I6,I7,2I6,I8,I6) 6400. |
| 3827 |
907 FORMAT ('0TOTL',I6,I5,I6,I8,4I6,I8,I6,I7,2I6,I7,I6,I7,2I6,I8,I6) 6401. |
| 3828 |
908 FORMAT ('0') 6402. |
| 3829 |
909 FORMAT (/'0TPE',I18,I32,I14,I7,I12,2I13,I20) 6403. |
| 3830 |
910 FORMAT ('0INCORRECT VALUE OF M WHEN CALLING DIAG5A. M=',I5) 6404. |
| 3831 |
END 6405. |
| 3832 |
BLOCK DATA a5 7001. |
| 3833 |
C**** 7002. |
| 3834 |
C**** TITLES FOR SUBROUTINE DIAG6 7003. |
| 3835 |
C**** 7004. |
| 3836 |
COMMON/D6COM/TITLE 7005. |
| 3837 |
CHARACTER*8 TITLE(50)/ 7006. |
| 3838 |
* '0INC SW ',' P ALBD ',' G ALBD ',' ABS ATM',' E CNDS ', 7007. |
| 3839 |
* '0SRF PRS',' PT 5 ',' PT 4 ',' PT 3 ',' PT 2 ', 7008. |
| 3840 |
* ' PT 1 ',' TS ',' TG1 ','0Q 5 ',' Q 4 ', 7009. |
| 3841 |
* ' Q 3 ',' Q 2 ',' Q 1 ',' QS ',' QG ', 7010. |
| 3842 |
* '0CLD 6 ',' CLD 5 ',' CLD 4 ',' CLD 3 ',' CLD 2 ', 7011. |
| 3843 |
* ' CLD 1 ',' COVER ','0SW ON G',' LW AT G',' SNSB HT', 7012. |
| 3844 |
* ' LAT HT ',' HEAT Z0','0UG*10 ',' VG*10 ',' WG*10 ', 7013. |
| 3845 |
* ' US*10 ',' VS*10 ',' WS*10 ',' ALPHA0 ','0RIS1*E2', 7014. |
| 3846 |
* ' RIGS*E2',' CDM*E4 ',' CDH*E4 ',' DGS*10 ',' EDS1*10', 7015. |
| 3847 |
* '0PPBL ',' DC FREQ',' LDC*10 ','0PRC*10 ',' EVP*10 '/ 7016. |
| 3848 |
END 7017. |
| 3849 |
SUBROUTINE DIAG6 7201. |
| 3850 |
C**** 7202. |
| 3851 |
C**** THIS SUBROUTINE PRINTS THE DIURNAL CYCLE OF SOME QUANTITIES 7203. |
| 3852 |
C**** 7204. |
| 3853 |
#include "BD2G04.COM" 7205. |
| 3854 |
COMMON U,V,T,P,Q 7206. |
| 3855 |
DIMENSION SCALE(50),MHOUR(25) 7207. |
| 3856 |
COMMON/D6COM/TITLE(50) 7208. |
| 3857 |
CHARACTER*8 TITLE 7208.1 |
| 3858 |
DATA SCALE/1.,2*100.,2*1., 5*1., 3*1.,2*1.E5, 5*1.E5, 7209. |
| 3859 |
* 5*100., 2*100.,3*1., 2*1.,3*10., 3*10.,1.,100., 7210. |
| 3860 |
* 100.,2*1.E4,2*10., 1.,100.,10.,2*1./ 7211. |
| 3861 |
C**** 7212. |
| 3862 |
IF(IDAY.LE.IDAY0) RETURN 7213. |
| 3863 |
DTCNDS=NCNDS*DT 7214. |
| 3864 |
DTSURF=NDYN*DT/NSURF 7215. |
| 3865 |
BYIDAC=1./(IDAY-IDAY0) 7216. |
| 3866 |
SCALE(5)=100.*RGAS/(KAPA*GRAV*DTCNDS) 7217. |
| 3867 |
SCALE(28)=1./DTSURF 7218. |
| 3868 |
SCALE(29)=1./DTSURF 7219. |
| 3869 |
SCALE(30)=1./DTSURF 7220. |
| 3870 |
SCALE(31)=1./DTSURF 7221. |
| 3871 |
SCALE(32)=1./DTSURF 7222. |
| 3872 |
SCALE(39)=360./TWOPI 7223. |
| 3873 |
SCALE(49)=100.*100.*SDAY/(DTCNDS*GRAV) 7224. |
| 3874 |
SCALE(50)=100.*SDAY/DTSURF 7225. |
| 3875 |
C**** 7226. |
| 3876 |
DO 500 KR=1,4 7227. |
| 3877 |
JY0=JYEAR0-1900 7228. |
| 3878 |
JY=JYEAR-1900 7229. |
| 3879 |
c WRITE (6,901) (XLABEL(K),K=1,27),JDATE0,JMNTH0,JY0,JDATE,JMONTH,JY7230. |
| 3880 |
c WRITE (6,903) NAMD6(KR),IJD6(1,KR),IJD6(2,KR),(I,I=1,24) 7231. |
| 3881 |
DO 500 KQ=1,50 7232. |
| 3882 |
IF(KQ.EQ.48) GO TO 200 7233. |
| 3883 |
C**** NORMAL QUANTITIES 7234. |
| 3884 |
AVE=0. 7235. |
| 3885 |
DO 120 IH=1,24 7236. |
| 3886 |
AVE=AVE+ADAILY(IH,KQ,KR) 7237. |
| 3887 |
120 MHOUR(IH)=INT(ADAILY(IH,KQ,KR)*SCALE(KQ)*BYIDAC+100000.5)-100000 7238. |
| 3888 |
MHOUR(25)=INT(AVE/24.*SCALE(KQ)*BYIDAC+100000.5)-100000 7239. |
| 3889 |
GO TO 500 7240. |
| 3890 |
C**** RATIO OF TWO QUANTITIES 7241. |
| 3891 |
200 AVEN=0. 7242. |
| 3892 |
AVED=0. 7243. |
| 3893 |
DO 220 IH=1,24 7244. |
| 3894 |
AVEN=AVEN+ADAILY(IH,KQ,KR) 7245. |
| 3895 |
AVED=AVED+ADAILY(IH,KQ-1,KR) 7246. |
| 3896 |
220 MHOUR(IH)=ADAILY(IH,KQ,KR)*SCALE(KQ)/(ADAILY(IH,KQ-1,KR)+1.E-20) 7247. |
| 3897 |
* +.5 7248. |
| 3898 |
MHOUR(25)=AVEN*SCALE(KQ)/(AVED+1.E-20)+.5 7249. |
| 3899 |
c 500 WRITE (6,904) TITLE(KQ),MHOUR 7250. |
| 3900 |
500 continue |
| 3901 |
RETURN 7251. |
| 3902 |
C**** 7252. |
| 3903 |
901 FORMAT ('1',27A4,I4,1X,A3,I3,' TO',I3,1X,A3,I3) 7253. |
| 3904 |
903 FORMAT ('0',A4,I2,',',I2,' ',I2,23I5,' AVE') 7254. |
| 3905 |
904 FORMAT (2A4,25I5) 7255. |
| 3906 |
END 7256. |
| 3907 |
SUBROUTINE DIAG4A 8001. |
| 3908 |
C**** 8002. |
| 3909 |
C**** THIS SUBROUTINE PRODUCES A TIME HISTORY OF ENERGIES 8003. |
| 3910 |
C**** 8004. |
| 3911 |
#include "BD2G04.COM" 8005. |
| 3912 |
COMMON U,V,T,P,Q 8006. |
| 3913 |
COMMON/WORK1/SUM(20),IK(20) 8007. |
| 3914 |
DIMENSION SCALE(20),EHIST(20) 8010. |
| 3915 |
IF(IDACC(4).LE.0.OR.IDACC(7).LE.0) RETURN 8011. |
| 3916 |
JEQ=2.+.5*JMM1 8012. |
| 3917 |
NM=1+IM/2 8013. |
| 3918 |
C**** 8014. |
| 3919 |
C**** LOAD ENERGIES INTO TIME HISTORY ARRAY 8015. |
| 3920 |
C**** 8016. |
| 3921 |
IDACC5=IDACC(5)+1 8017. |
| 3922 |
IF(SKIPSE.EQ.1.) GO TO 540 8018. |
| 3923 |
C**** CALCULATE CURRENT SEKE 8019. |
| 3924 |
BYIADA=1./IDACC(4) 8020. |
| 3925 |
DO 530 L=1,LM 8021. |
| 3926 |
KS=5 8022. |
| 3927 |
IF (L.GE.LS1) KS=15 8023. |
| 3928 |
DO 530 J=2,JM 8024. |
| 3929 |
PU4TI=0. 8025. |
| 3930 |
PV4TI=0. 8026. |
| 3931 |
SKE4I=0. 8027. |
| 3932 |
DO 510 I=1,IM 8028. |
| 3933 |
PU4TI=PU4TI+AIJL(I,J,L,1) 8029. |
| 3934 |
PV4TI=PV4TI+AIJL(I,J,L,2) 8030. |
| 3935 |
510 SKE4I=SKE4I+(AIJL(I,J,L,1)*AIJL(I,J,L,1) 8031. |
| 3936 |
* +AIJL(I,J,L,2)*AIJL(I,J,L,2))/AIJ(I,J,8) 8032. |
| 3937 |
SEKE=(SKE4I-(PU4TI*PU4TI+PV4TI*PV4TI)/APJ(J,2))*DXYV(J)*BYIADA 8033. |
| 3938 |
IF(J.EQ.JEQ) GO TO 520 8034. |
| 3939 |
ENERGY(KS,IDACC5)=ENERGY(KS,IDACC5)+SEKE*DSIG(L) 8035. |
| 3940 |
GO TO 530 8036. |
| 3941 |
520 ENERGY(KS,IDACC5)=ENERGY(KS,IDACC5)+.5*SEKE*DSIG(L) 8037. |
| 3942 |
ENERGY(KS+1,IDACC5)=ENERGY(KS+1,IDACC5)+.5*SEKE*DSIG(L) 8038. |
| 3943 |
IF(K.EQ.2) KS=KS+1 8039. |
| 3944 |
530 CONTINUE 8040. |
| 3945 |
C**** OTHER ENERGIES COME FROM LATEST SPECTRAL ANALYSIS 8041. |
| 3946 |
540 ENERGY(1,IDACC5)=SPECA(1,19,2) 8042. |
| 3947 |
ENERGY(2,IDACC5)=SPECA(1,19,4) 8043. |
| 3948 |
ENERGY(7,IDACC5)=SPECA(1,20,2) 8044. |
| 3949 |
ENERGY(8,IDACC5)=SPECA(1,20,4) 8045. |
| 3950 |
ENERGY(11,IDACC5)=SPECA(1,19,1) 8046. |
| 3951 |
ENERGY(12,IDACC5)=SPECA(1,19,3) 8047. |
| 3952 |
ENERGY(17,IDACC5)=SPECA(1,20,1) 8048. |
| 3953 |
ENERGY(18,IDACC5)=SPECA(1,20,3) 8049. |
| 3954 |
IF(IM.EQ.1) GO TO 955 8049.5 |
| 3955 |
DO 550 N=2,NM 8050. |
| 3956 |
ENERGY(3,IDACC5)=ENERGY(3,IDACC5)+SPECA(N,19,2) 8051. |
| 3957 |
ENERGY(4,IDACC5)=ENERGY(4,IDACC5)+SPECA(N,19,4) 8052. |
| 3958 |
ENERGY(9,IDACC5)=ENERGY(9,IDACC5)+SPECA(N,20,2) 8053. |
| 3959 |
ENERGY(10,IDACC5)=ENERGY(10,IDACC5)+SPECA(N,20,4) 8054. |
| 3960 |
ENERGY(13,IDACC5)=ENERGY(13,IDACC5)+SPECA(N,19,1) 8055. |
| 3961 |
ENERGY(14,IDACC5)=ENERGY(14,IDACC5)+SPECA(N,19,3) 8056. |
| 3962 |
ENERGY(19,IDACC5)=ENERGY(19,IDACC5)+SPECA(N,20,1) 8057. |
| 3963 |
550 ENERGY(20,IDACC5)=ENERGY(20,IDACC5)+SPECA(N,20,3) 8058. |
| 3964 |
955 CONTINUE 8058.5 |
| 3965 |
IDACC(5)=IDACC5 8059. |
| 3966 |
RETURN 8060. |
| 3967 |
C**** 8061. |
| 3968 |
ENTRY DIAG4 8062. |
| 3969 |
C**** THIS ENTRY PRODUCES A TIME HISTORY TABLE OF ENERGIES 8063. |
| 3970 |
C**** 8064. |
| 3971 |
IDACC5=IDACC(5) 8065. |
| 3972 |
IF(IDACC5.LE.0) RETURN 8066. |
| 3973 |
SCALE(1)=100.E-18/GRAV 8067. |
| 3974 |
SCALE(2)=SCALE(1) 8068. |
| 3975 |
SCALE(3)=SCALE(1) 8069. |
| 3976 |
SCALE(4)=SCALE(1) 8070. |
| 3977 |
SCALE(5)=.125*SCALE(1) 8071. |
| 3978 |
SCALE(6)=SCALE(5) 8072. |
| 3979 |
SCALE(7)=SCALE(1)*RGAS 8073. |
| 3980 |
SCALE(8)=SCALE(7) 8074. |
| 3981 |
SCALE(9)=SCALE(7) 8075. |
| 3982 |
SCALE(10)=SCALE(7) 8076. |
| 3983 |
SCALE(11)=SCALE(1) 8077. |
| 3984 |
SCALE(12)=SCALE(1) 8078. |
| 3985 |
SCALE(13)=SCALE(1) 8079. |
| 3986 |
SCALE(14)=SCALE(1) 8080. |
| 3987 |
SCALE(15)=SCALE(5) 8081. |
| 3988 |
SCALE(16)=SCALE(5) 8082. |
| 3989 |
SCALE(17)=SCALE(7) 8083. |
| 3990 |
SCALE(18)=SCALE(7) 8084. |
| 3991 |
SCALE(19)=SCALE(7) 8085. |
| 3992 |
SCALE(20)=SCALE(7) 8086. |
| 3993 |
C**** 8087. |
| 3994 |
IHOUR0=TOFDY0+.5 8088. |
| 3995 |
IHOUR=TOFDAY+.5 8089. |
| 3996 |
c WRITE (6,901) XLABEL 8090. |
| 3997 |
c WRITE (6,902) IDAY0,IHOUR0,JDATE0,JMNTH0,JYEAR0,IDAY,IHOUR,JDATE, 8091. |
| 3998 |
c * JMONTH,JYEAR 8092. |
| 3999 |
DO 110 K=1,20 8093. |
| 4000 |
110 SUM(K)=0. 8094. |
| 4001 |
c WRITE (6,903) 8095. |
| 4002 |
DTAUD4=DT*NDA4/3600. 8096. |
| 4003 |
TAUX=TAU0+DT*NCNDS/3600. 8097. |
| 4004 |
DO 200 I=1,IDACC5 8098. |
| 4005 |
IDAYX=(TAUX+.001)/24. 8099. |
| 4006 |
TOFDYX=TAUX-24.*IDAYX 8100. |
| 4007 |
DO 150 K=1,20 8101. |
| 4008 |
IK(K)=ENERGY(K,I)*SCALE(K)+.5 8102. |
| 4009 |
150 SUM(K)=SUM(K)+ENERGY(K,I) 8103. |
| 4010 |
c WRITE (6,904) IDAYX,TOFDYX,IK 8104. |
| 4011 |
200 TAUX=TAUX+DTAUD4 8105. |
| 4012 |
DO 250 K=1,20 8106. |
| 4013 |
EHIST(K)=SUM(K)*SCALE(K)/IDACC5 8107. |
| 4014 |
250 IK(K)=EHIST(K)+.5 8108. |
| 4015 |
c WRITE (6,905) IK 8109. |
| 4016 |
LSKIPM=54-IDACC5 8110. |
| 4017 |
c DO 260 LSKIP=1,LSKIPM 8111. |
| 4018 |
c 260 WRITE (6,920) 8112. |
| 4019 |
CALL KEYD4 (IK) 8113. |
| 4020 |
RETURN 8114. |
| 4021 |
C**** 8115. |
| 4022 |
901 FORMAT ('1',33A4) 8116. |
| 4023 |
902 FORMAT ('0** ENERGY HISTORY ** DAY',I5,', HR',I3,' (',I2,A5,I5, 8117. |
| 4024 |
* ') TO DAY',I5,', HR',I3,' (',I2,A5,I5, 8118. |
| 4025 |
* ') UNITS OF 10**18 JOULES') 8119. |
| 4026 |
903 FORMAT ('0',15X,21('-'),' TROPOSPHERE ',22('-'),5X,21('-'), 8120. |
| 4027 |
* ' STRATOSPHERE ',21('-')/8X,2(11X,'ZKE',8X,'EKE',7X,'SEKE',9X, 8121. |
| 4028 |
* 'ZPE',10X,'EPE')/3X,'DAY HOUR SH NH SH NH SH NH8122. |
| 4029 |
* SH NH SH NH SH NH SH NH SH NH S8123. |
| 4030 |
*H NH SH NH'/1X,132('=')) 8124. |
| 4031 |
904 FORMAT (I6,F6.1,1X,3(I6,I5),2(I7,I6),2X,3(I6,I5),2(I7,I6)) 8125. |
| 4032 |
905 FORMAT (1X,132('=')/8X,'MEAN ',3(I6,I5),2(I7,I6),2X,3(I6,I5), 8126. |
| 4033 |
* 2(I7,I6)) 8127. |
| 4034 |
920 FORMAT (1X) 8128. |
| 4035 |
END 8129. |
| 4036 |
SUBROUTINE DIAG8(IPFLAG) 8601. |
| 4037 |
RETURN 8602. |
| 4038 |
ENTRY ENQJOB 8603. |
| 4039 |
RETURN 8604. |
| 4040 |
END 8605. |
| 4041 |
SUBROUTINE DIAG10(IPFLAG) 8801. |
| 4042 |
RETURN 8802. |
| 4043 |
END 8803. |
| 4044 |
SUBROUTINE DIAGKS 9001. |
| 4045 |
C**** 9002. |
| 4046 |
C**** THIS SUBROUTINE PRODUCES A SUMMARY OF KEY NUMBERS CALCULATED IN 9003. |
| 4047 |
C**** OTHER DIAGNOSTIC SUBROUTINES 9004. |
| 4048 |
C**** 9005. |
| 4049 |
C**** CONTENTS OF KEYNR 9006. |
| 4050 |
C**** 1 MONTH 9007. |
| 4051 |
C**** 2 TOTAL CLOUD COVER (PERCENT) 9008. |
| 4052 |
C**** 3 SNOW COVER--NORTHERN HEMSIPHERE (PERCENT) 9009. |
| 4053 |
C**** 4 ICE COVER--NORTHERN HEMISPHERE (PERCENT) 9010. |
| 4054 |
C**** 5 PLANETARY ALBEDO (PERCENT) 9011. |
| 4055 |
C**** 6 SOLAR RADIATION ABSORBED BY ATMOSPHERE (WT/M**2) 9012. |
| 4056 |
C**** 7 SOLAR RADIATION ABSORBED BY PLANET (WT/M**2) 9013. |
| 4057 |
C**** 8 NET HEAT AT GROUND (WT/M**2) 9014. |
| 4058 |
C**** 8 ANGULAR MOMENTUM PER UNIT AREA (10**10 J*SEC/M**2) 9015. |
| 4059 |
C**** 9 EVAPORATION (.1 MM/DAY) 9016. |
| 4060 |
C**** 9 PRECIPITATION (.1 MM/DAY) 9017. |
| 4061 |
C**** 10 SENSIBLE HEAT FLUX INTO GROUND (ABS.VALUE) 9018. |
| 4062 |
C**** 11 LATENT HEAT FLUX INTO GROUND (ABS.VALUE) 9019. |
| 4063 |
C**** 12 MEAN GROUND TEMPERATURE (DEGREES K) 9020. |
| 4064 |
C**** 13 MEAN GLOBAL ATMOSPHERIC TEMPERATURE (DEGREES K) 9021. |
| 4065 |
C**** 14 MERID. TEMPERATURE GRADIENT (N.HEMISPHERE) 9022. |
| 4066 |
C**** 15 MERID. TEMPERATURE GRADIENT (S.HEMISPHERE) 9023. |
| 4067 |
C**** 16 MEAN TROPOSPHERIC EKE-NORTHERN HEMISPHERE 9024. |
| 4068 |
C**** 17 MEAN TROPOSPHERIC EKE-SOUTHERNN HEMISPHERE 9025. |
| 4069 |
C**** 18 MEAN TROPOSPHERIC ZKE-NORTHERN HEMISPHERE 9026. |
| 4070 |
C**** 19 MEAN TROPOSPHERIC ZKE-SOUTHERN HEMISPHERE 9027. |
| 4071 |
C**** 20 MEAN TROPOSPHERIC EPE-NORTHERN HEMISPHERE 9028. |
| 4072 |
C**** 21 MEAN TROPOSPHERIC ZPE-NORTHERN HEMISPHERE 9029. |
| 4073 |
C**** 22 MEAN EDDY KINETIC ENERGY AT EQUATOR 9030. |
| 4074 |
C**** 23 MAX. MEAN EDDY KINETIC ENERGY IN MID NORTH LATITUDES 9031. |
| 4075 |
C**** 24 MAX. ZONAL WIND (U COMPONENT) IN TROPOSPHERE (NH), M/SEC 9032. |
| 4076 |
C**** 25 LATITUDE CORRESPONDING TO 24 9033. |
| 4077 |
C**** 26 MAX. ZONAL WIND (U COMPONENT) IN TROPOSPHERE (SH), M/SEC 9034. |
| 4078 |
C**** 27 LATITUDE CORRESPONDING TO 26 9035. |
| 4079 |
C**** 28-30: 29 IS LARGEST VALUE OF STREAM FUNCTION, POSITIVE OR 9036. |
| 4080 |
C**** NEGATIVE; 28 AND 30 ARE THE MAGNITUDES OF THE LARGEST VALUES OF9037. |
| 4081 |
C**** OPPOSITE SIGN TO THE NORTH AND SOUTH RESPECTIVELY 9038. |
| 4082 |
C**** 31 EKE 'SLOPE' AT EQUATOR, TROPOSPHERE (10**16 JOULES) 9039. |
| 4083 |
C**** 32 EKE 'SLOPE' AT 45 DEGREES NORTH, TROPOSPHERE (10**16 JOULES) 9040. |
| 4084 |
C**** 33-39 REFER TO NORTHERN HEMISPHERE ONLY 9041. |
| 4085 |
C**** 33 MAX.NORTHWARD TRANS. OF DRY STATIC ENERGY BY STANDING EDDIES 9042. |
| 4086 |
C**** 34 MAX.NORTHWARD TRANS. OF DRY STATIC ENERGY BY EDDIES 9043. |
| 4087 |
C**** 35 MAX. TOTAL NORTH. TRANS. OF DRY STATIC ENERGY 9044. |
| 4088 |
C**** 36 MAX.NORTHWARD TRANS. OF STATIC ENERGY BY EDDIES 9045. |
| 4089 |
C**** 37 MAX.TOTAL NORTH. TRANS. OF STATIC ENERGY 9046. |
| 4090 |
C**** 38 LATITUDE CORRESPONDING TO 37 9047. |
| 4091 |
C**** 39 MAX. NORTH. TRANS. OF ANGULAR MOMENTUM BY STANDING EDDIES 9048. |
| 4092 |
C**** 40 MAX. NORTH. TRANS. OF ANGULAR MOMENTUM BY EDDIES 9049. |
| 4093 |
C**** 41 MAX. TOTAL NORTH. TRANS. OF ANGULAR MOMENTUM 9050. |
| 4094 |
C**** 42 LATITUDE CORRESPONDING TO 41 9051. |
| 4095 |
C**** 9052. |
| 4096 |
#include "BD2G04.COM" 9053. |
| 4097 |
COMMON U,V,T,P,Q 9054. |
| 4098 |
c 7/27/04 |
| 4099 |
c DIMENSION KEYDS(20) |
| 4100 |
DIMENSION KEYDS(42) |
| 4101 |
COMMON/WORK4/FKEY(46,36) 9057. |
| 4102 |
COMMON/D2COM/JLAT(46,2) 9058. |
| 4103 |
C COMMON/KEYS/KEYNR(42,50) 9059. |
| 4104 |
DIMENSION ASUM(*),FLAT(*),IK(*) 9060. |
| 4105 |
CHARACTER*4 IC,JAN,CKEYNR(42,50) 9060.1 |
| 4106 |
EQUIVALENCE (CKEYNR,KEYNR) 9060.2 |
| 4107 |
DATA IC/'IC'/,JAN/'JAN'/ 9061. |
| 4108 |
C**** 9062. |
| 4109 |
C**** ENTRIES CALLED FROM DIAG1 9063. |
| 4110 |
C**** 9064. |
| 4111 |
ENTRY KEYD1 (N,FGLOB,FNH) 9065. |
| 4112 |
GO TO ( 100,100,100,110,100, 100,100,100,100,115, 9066. |
| 4113 |
* 100,100,120,125,100, 100,100,130,100,135, 100,100,100,100,100, 9067. |
| 4114 |
* 100,100,100,100,140, 145,100,100,100,100, 100,100,100,100,100, 9068. |
| 4115 |
* 100,100,100,150,100, 100,100,100,100,100, 100,100,100,100,100, 9069. |
| 4116 |
* 100,100,100,155),N 9070. |
| 4117 |
100 RETURN 9071. |
| 4118 |
110 KEYNR(6,KEYCT)=INT(FGLOB+.5) 9072. |
| 4119 |
RETURN 9073. |
| 4120 |
115 KEYNR(7,KEYCT)=INT(FGLOB+.5) 9074. |
| 4121 |
RETURN 9075. |
| 4122 |
120 KEYNR(10,KEYCT)=INT(.5-FGLOB) 9076. |
| 4123 |
RETURN 9077. |
| 4124 |
125 KEYNR(11,KEYCT)=INT(.5-FGLOB) 9078. |
| 4125 |
RETURN 9079. |
| 4126 |
130 KEYNR(12,KEYCT)=INT(.1*FGLOB+.5) 9080. |
| 4127 |
RETURN 9081. |
| 4128 |
135 KEYNR(9,KEYCT)=INT(10.*FGLOB+.5) 9082. |
| 4129 |
RETURN 9083. |
| 4130 |
140 KEYNR(4,KEYCT)=INT(FNH+.5) 9084. |
| 4131 |
RETURN 9085. |
| 4132 |
145 KEYNR(3,KEYCT)=INT(FNH+.5) 9086. |
| 4133 |
RETURN 9087. |
| 4134 |
150 KEYNR(8,KEYCT)=INT(FGLOB+100000.5)-100000 9088. |
| 4135 |
RETURN 9089. |
| 4136 |
155 KEYNR(2,KEYCT)=INT(FGLOB+.5) 9090. |
| 4137 |
RETURN 9091. |
| 4138 |
C**** 9092. |
| 4139 |
ENTRY KEYD1A (FGLOB) 9093. |
| 4140 |
KEYNR(5,KEYCT)=INT(10.*FGLOB+.5) 9094. |
| 4141 |
RETURN 9095. |
| 4142 |
C**** 9096. |
| 4143 |
C**** ENTRIES CALLED FROM DIAG2 VIA JLMAP 9097. |
| 4144 |
C**** 9098. |
| 4145 |
ENTRY KEYD2T (GSUM,ASUM) 9099. |
| 4146 |
C**** TEMPERATURES 9100. |
| 4147 |
JEQ=2.+.5*JMM1 9101. |
| 4148 |
TEQ=.5*(ASUM(JEQ-1)+ASUM(JEQ)) 9102. |
| 4149 |
X60=TWOPI/(12.*DLAT) 9103. |
| 4150 |
J60=.5+X60 9104. |
| 4151 |
A=DXYP(J60+1)*(X60+.5-J60) 9105. |
| 4152 |
TSOU=ASUM(J60+1)*A 9106. |
| 4153 |
TNOR=ASUM(JM-J60)*A 9107. |
| 4154 |
DO 210 J=1,J60 9108. |
| 4155 |
A=A+DXYP(J) 9109. |
| 4156 |
TSOU=TSOU+ASUM(J)*DXYP(J) 9110. |
| 4157 |
210 TNOR=TNOR+ASUM(JM+1-J)*DXYP(J) 9111. |
| 4158 |
KEYNR(14,KEYCT)=INT(TEQ-TNOR/A+.5) 9112. |
| 4159 |
KEYNR(15,KEYCT)=INT(TEQ-TSOU/A+.5) 9113. |
| 4160 |
KEYNR(13,KEYCT)=INT(.1*GSUM-.5) 9114. |
| 4161 |
RETURN 9115. |
| 4162 |
C**** 9116. |
| 4163 |
ENTRY KEYD2J (L,FLAT) 9117. |
| 4164 |
C**** JET STREAMS 9118. |
| 4165 |
IF(L.LT.LM) GO TO 220 9119. |
| 4166 |
DO 216 LL=1,LM 9120. |
| 4167 |
IF((PSF-PTOP)*SIG(LL)+PTOP.LT.200.) GO TO 218 9121. |
| 4168 |
216 CONTINUE 9122. |
| 4169 |
218 LMAX=LL-1 9123. |
| 4170 |
220 IF(L.GT.LMAX) RETURN 9124. |
| 4171 |
USLM=-999999. 9125. |
| 4172 |
DO 222 J=3,JEQ 9126. |
| 4173 |
IF(FLAT(J).LT.USLM) GO TO 222 9127. |
| 4174 |
USLM=FLAT(J) 9128. |
| 4175 |
JMAX=J 9129. |
| 4176 |
222 CONTINUE 9130. |
| 4177 |
CEPT=.5*(FLAT(JMAX-1)-FLAT(JMAX+1))/ 9131. |
| 4178 |
* (FLAT(JMAX-1)-2.*FLAT(JMAX)+FLAT(JMAX+1)) 9132. |
| 4179 |
LSLM=INT((JMAX-1.5+CEPT)*DLAT*360/TWOPI+.5)-90 9133. |
| 4180 |
UNLM=-999999. 9134. |
| 4181 |
DO 224 J=JEQ,JMM1 9135. |
| 4182 |
IF(FLAT(J).LT.UNLM) GO TO 224 9136. |
| 4183 |
UNLM=FLAT(J) 9137. |
| 4184 |
JMAX=J 9138. |
| 4185 |
224 CONTINUE 9139. |
| 4186 |
CEPT=.5*(FLAT(JMAX-1)-FLAT(JMAX+1))/ 9140. |
| 4187 |
* (FLAT(JMAX-1)-2.*FLAT(JMAX)+FLAT(JMAX+1)) 9141. |
| 4188 |
LNLM=INT((JMAX-1.5+CEPT)*DLAT*360/TWOPI+.5)-90 9142. |
| 4189 |
IF(L.LT.LMAX) GO TO 226 9143. |
| 4190 |
USM=USLM 9144. |
| 4191 |
LSM=LSLM 9145. |
| 4192 |
UNM=UNLM 9146. |
| 4193 |
LNM=LNLM 9147. |
| 4194 |
RETURN 9148. |
| 4195 |
226 IF(USLM.LT.USM) GO TO 228 9149. |
| 4196 |
USM=USLM 9150. |
| 4197 |
LSM=LSLM 9151. |
| 4198 |
228 IF(UNLM.LT.UNM) GO TO 230 9152. |
| 4199 |
UNM=UNLM 9153. |
| 4200 |
LNM=LNLM 9154. |
| 4201 |
230 IF(L.NE.1) RETURN 9155. |
| 4202 |
KEYNR(24,KEYCT)=.1*UNM+.5 9156. |
| 4203 |
KEYNR(25,KEYCT)=LNM 9157. |
| 4204 |
KEYNR(26,KEYCT)=.1*USM+.5 9158. |
| 4205 |
KEYNR(27,KEYCT)=-LSM 9159. |
| 4206 |
C**** 9160. |
| 4207 |
ENTRY KEYD2S (L,FLAT) 9161. |
| 4208 |
C**** STREAM FUNCTION 9162. |
| 4209 |
DO 290 J=2,JM 9163. |
| 4210 |
290 FKEY(J,L)=FLAT(J) 9164. |
| 4211 |
IF(L.NE.1) RETURN 9165. |
| 4212 |
300 SAVE=0. 9166. |
| 4213 |
HS=0. 9167. |
| 4214 |
HN=0. 9168. |
| 4215 |
DO 310 K=1,LM 9169. |
| 4216 |
DO 310 I=2,JM 9170. |
| 4217 |
CHECK=ABS(FKEY(I,K)) 9171. |
| 4218 |
IF(CHECK.LT.SAVE) GO TO 310 9172. |
| 4219 |
SAVE=CHECK 9173. |
| 4220 |
INDEX=I 9174. |
| 4221 |
KNDEX=K 9175. |
| 4222 |
310 CONTINUE 9176. |
| 4223 |
SAVE=FKEY(INDEX,KNDEX) 9177. |
| 4224 |
ISIGN=1 9178. |
| 4225 |
IF(SAVE.GT.0.0) ISIGN=-1 9179. |
| 4226 |
IF(INDEX.LT.4) GO TO 325 9180. |
| 4227 |
IEND=INDEX-1 9181. |
| 4228 |
DO 320 K=1,LM 9182. |
| 4229 |
DO 320 I=2,IEND 9183. |
| 4230 |
CHECK=FKEY(I,K)*ISIGN 9184. |
| 4231 |
320 IF(CHECK.GT.HS)HS=CHECK 9185. |
| 4232 |
325 CONTINUE 9186. |
| 4233 |
IF(INDEX.GT.(JM-2))GO TO 335 9187. |
| 4234 |
JSTART=INDEX+1 9188. |
| 4235 |
DO 330 K=1,LM 9189. |
| 4236 |
DO 330 I=JSTART,JM 9190. |
| 4237 |
CHECK=FKEY(I,K)*ISIGN 9191. |
| 4238 |
330 IF(CHECK.GT.HN)HN=CHECK 9192. |
| 4239 |
335 CONTINUE 9193. |
| 4240 |
KEYNR(28,KEYCT)=ABS(HN)+0.5 9194. |
| 4241 |
KEYNR(29,KEYCT)=INT(SAVE+10000.5 )-10000 9195. |
| 4242 |
KEYNR(30,KEYCT)=ABS(HS)+0.5 9196. |
| 4243 |
RETURN 9197. |
| 4244 |
C**** 9198. |
| 4245 |
ENTRY KEYD2K (ASUM) 9199. |
| 4246 |
C**** EDDY KINETIC ENERGY 9200. |
| 4247 |
KEYNR(22,KEYCT)=INT(ASUM(JEQ)+.5) 9201. |
| 4248 |
BIG=-99999. 9202. |
| 4249 |
I35=2.+JMM1*125./180. 9203. |
| 4250 |
I70=2.+JMM1*160./180. 9204. |
| 4251 |
DO 440 I=I35,I70 9205. |
| 4252 |
IF(ASUM(I).LT.BIG) GO TO 440 9206. |
| 4253 |
BIG=ASUM(I) 9207. |
| 4254 |
440 CONTINUE 9208. |
| 4255 |
KEYNR(23,KEYCT)=INT(BIG+.5) 9209. |
| 4256 |
RETURN 9210. |
| 4257 |
C**** 9211. |
| 4258 |
ENTRY KEYD2N (NT,ASUM,SUMFAC) 9212. |
| 4259 |
C**** NORTHWARD TRANSPORTS 9213. |
| 4260 |
500 BIG=-99999. 9214. |
| 4261 |
JEQP1=JEQ+1 9215. |
| 4262 |
DO 510 I=JEQP1,JM 9216. |
| 4263 |
IF(ASUM(I).LT.BIG) GO TO 510 9217. |
| 4264 |
BIG=ASUM(I) 9218. |
| 4265 |
INDEX=I 9219. |
| 4266 |
510 CONTINUE 9220. |
| 4267 |
BIG=BIG*SUMFAC 9221. |
| 4268 |
NTDIF=NT-21 9222. |
| 4269 |
GO TO (392,392,392,390,390,396,394,390,390,400,400,398),NTDIF 9223. |
| 4270 |
390 CONTINUE 9224. |
| 4271 |
392 KEYNR(NT+11,KEYCT)=INT(BIG+.5) 9225. |
| 4272 |
RETURN 9226. |
| 4273 |
394 KEYNR(38,KEYCT)=JLAT(INDEX,2) 9227. |
| 4274 |
396 KEYNR(NT+9,KEYCT)=INT(BIG+.5) 9228. |
| 4275 |
RETURN 9229. |
| 4276 |
398 KEYNR(42,KEYCT)=JLAT(INDEX,2) 9230. |
| 4277 |
400 KEYNR(NT+8,KEYCT)=INT(BIG+.5) 9231. |
| 4278 |
RETURN 9232. |
| 4279 |
C**** 9233. |
| 4280 |
C**** ENTRY CALLED FROM DIAG4 9234. |
| 4281 |
C**** 9235. |
| 4282 |
ENTRY KEYD4 (IK) 9236. |
| 4283 |
KEYNR(16,KEYCT)=(IK(4)+IK(14)+5)/10 9237. |
| 4284 |
KEYNR(17,KEYCT)=(IK(3)+IK(13)+5)/10 9238. |
| 4285 |
KEYNR(18,KEYCT)=(IK(2)+IK(12)+5)/10 9239. |
| 4286 |
KEYNR(19,KEYCT)=(IK(1)+IK(11)+5)/10 9240. |
| 4287 |
KEYNR(20,KEYCT)=(IK(10)+IK(20)+5)/10 9241. |
| 4288 |
KEYNR(21,KEYCT)=(IK(8)+IK(18)+5)/10 9242. |
| 4289 |
RETURN 9243. |
| 4290 |
C**** 9244. |
| 4291 |
C**** ENTRY CALLED FROM DIAG5 9245. |
| 4292 |
ENTRY KEYD5A(NM1,FK1,FK2) 9246. |
| 4293 |
C**** SPECTRAL ANALYSIS 9247. |
| 4294 |
C**** CALCULATES THE 'SLOPE' OF THE MEAN KINETIC ENERGY FOR THE TROPO- 9248. |
| 4295 |
C**** SPHERE AT THE EQUATOR AND AT 45 DEGREES NORTH. SLOPE IS DEFINED 9249. |
| 4296 |
C**** AS (LNR/LN2)*10 WHERE R IS THE RATIO OF THE AVERAGE KE IN WAVE 9250. |
| 4297 |
C**** NUMBERS 7, 8 AND 9 TO WAVE NUMBERS 11, 12 AND 13. 9251. |
| 4298 |
NM1M6=NM1-6 9252. |
| 4299 |
GO TO (601,602,602,600,605,606,607),NM1M6 9253. |
| 4300 |
600 RETURN 9254. |
| 4301 |
601 FEQLO=FK1 9255. |
| 4302 |
F45LO=FK2 9256. |
| 4303 |
RETURN 9257. |
| 4304 |
602 FEQLO=FEQLO+FK1 9258. |
| 4305 |
F45LO=F45LO+FK2 9259. |
| 4306 |
RETURN 9260. |
| 4307 |
605 FEQHI=FK1 9261. |
| 4308 |
F45HI=FK2 9262. |
| 4309 |
RETURN 9263. |
| 4310 |
606 FEQHI=FEQHI+FK1 9264. |
| 4311 |
F45HI=F45HI+FK2 9265. |
| 4312 |
RETURN 9266. |
| 4313 |
607 FEQHI=FEQHI+FK1+1.E-20 9267. |
| 4314 |
REQ=FEQLO/FEQHI 9268. |
| 4315 |
KEYNR(31,KEYCT)=10.*DLOG(REQ+1.E-20)/DLOG(1.5)+.5 9269. |
| 4316 |
F45HI=F45HI+FK2+1.E-20 9270. |
| 4317 |
R45=F45LO/F45HI 9271. |
| 4318 |
KEYNR(32,KEYCT)=10.*DLOG(R45+1.E-20)/DLOG(1.5)+.5 9272. |
| 4319 |
RETURN 9273. |
| 4320 |
C**** 9274. |
| 4321 |
ENTRY DIAGKN 9275. |
| 4322 |
C**** PRINTS THE TABLE OF KEY NUMBERS 9276. |
| 4323 |
C**** 9277. |
| 4324 |
IHOUR0=TOFDY0+.5 9278. |
| 4325 |
IHOUR=TOFDAY+.5 9279. |
| 4326 |
TAUDIF=TAU-TAU0 9280. |
| 4327 |
if(KEYCT.gt.50)then |
| 4328 |
print *,'1 KEYCT=',KEYCT |
| 4329 |
stop |
| 4330 |
endif |
| 4331 |
CKEYNR(1,KEYCT)=JMNTH0 9281. |
| 4332 |
IF(KEYCT.EQ.1) CKEYNR(1,KEYCT)=IC 9282. |
| 4333 |
IF(KEYCT.GE.2.AND.CKEYNR(1,KEYCT-1).EQ.JMNTH0) KEYCT=KEYCT-1 9283. |
| 4334 |
if(JYEAR0.ne.JYEAR)then |
| 4335 |
JYRPR=JYEAR-KEYCT/12 |
| 4336 |
WRITE(6,901) XLABEL 9284. |
| 4337 |
WRITE(6,910) IDAY0,IHOUR0,JDATE0,JMNTH0,JYEAR0,TAU0,IDAY,IHOUR, 9285. |
| 4338 |
* JDATE,JMONTH,JYEAR,TAU,TAUDIF 9286. |
| 4339 |
WRITE(6,902) 9287. |
| 4340 |
DO 810 I=1,KEYCT 9288. |
| 4341 |
c IF(CKEYNR(1,I).EQ.JAN) WRITE (6,905) 9289. |
| 4342 |
IF(CKEYNR(1,I).EQ.JAN) THEN |
| 4343 |
c print *,JYRPR |
| 4344 |
JYRPR=JYRPR+1 |
| 4345 |
ENDIF |
| 4346 |
810 WRITE (6,905) (KEYNR(K,I),K=1,42) 9290. |
| 4347 |
WRITE (6,915) 9291. |
| 4348 |
end if |
| 4349 |
DO 815 K=1,42 9292. |
| 4350 |
815 KEYDS(K)=KEYNR(K,KEYCT) 9293. |
| 4351 |
KEYCT=KEYCT+1 9294. |
| 4352 |
KEYMAX=49 9295. |
| 4353 |
IF(CKEYNR(1,1).NE.IC) KEYMAX=48 9296. |
| 4354 |
IF(KEYCT.LE.KEYMAX) RETURN 9297. |
| 4355 |
C**** ROLL UP KEY NUMBERS 1 YEAR AT A TIME 9298. |
| 4356 |
DO 820 K=1,36 9299. |
| 4357 |
DO 820 I=1,42 9300. |
| 4358 |
820 KEYNR(I,K)=KEYNR(I,K+KEYMAX-36) 9301. |
| 4359 |
DO 880 K=37,50 9302. |
| 4360 |
880 KEYNR(2,K)=0 9303. |
| 4361 |
KEYCT=37 9304. |
| 4362 |
RETURN 9305. |
| 4363 |
901 FORMAT('1',33A4) 9306. |
| 4364 |
902 FORMAT ('0',7X,'NH NH AL AB NT NT PR T T-OF-ATM EKE ZK9307. |
| 4365 |
*E EKE JET-STREAMS STREAM-FN EKE NOR-TRAN NOR-TRAN NO9308. |
| 4366 |
*RTH-TRANS'/ 9309. |
| 4367 |
* 5X,'CL SN OI BE BY RD HT EC SN LAT OF GL GRAD ----- ---9310. |
| 4368 |
*-- EPE ZPE ------ NORTH SOUTH --------- SLOPE DRY-STAT STAT-ENR AN9311. |
| 4369 |
*G MOMENTM'/ 9312. |
| 4370 |
* 5X,'CV CV CV DO AT P0 Z0 IP HT HT GD OB NH SH NH SH NH 9313. |
| 4371 |
*SH NH NH EQ ML VL LT VL LT NH MAX SH EQ 45 SE ED TL ED TL LT SE9314. |
| 4372 |
* ED TL LT'/) 9315. |
| 4373 |
905 FORMAT (1X,A3,2I3,I2,I4,5I3,I4,I3,I4,6I3,2I4,I3,I4,5I3,I4,13I3) 9316. |
| 4374 |
910 FORMAT ('0',15X,'DAY',I5,', HR',I3,' (',I2,A5,I5,')',F8.1, 9317. |
| 4375 |
* ' TO DAY',I5,', HR',I3,' (',I2,A5,I5,')',F8.1,' DIF', 9318. |
| 4376 |
* F6.1,' HR',7X,I5,I5) 9319. |
| 4377 |
915 FORMAT('0') 9320. |
| 4378 |
END 9321. |
Parent Directory
| 
Revision Log
| 
Revision Graph