1. C**** 2. C**** C071D.S Fortran source code for Diagnostics 2000/08/15 3. C**** 4. C**** NASA/GISS Climate Model III Programmed by: 5. C**** Gary L. Russell 6. C**** NASA/Goddard Space Flight Center Reto A. Ruedy 7. C**** Institute for Space Studies Gavin A. Schmidt 8. C**** 2880 Broadway, New York, NY 10025 Jean A. Lerner 9. C**** U.S.A. 10. C**** 4001. SUBROUTINE DIAGCP 4002. C**** 4003. C**** DIAGCP produces tables of changes of conserved quantities 4004. C**** 4005. INCLUDE 'C070.COM' 4006. CHARACTER*32 TITLE 4007. COMMON /WORK01/ SCALE(KCON),FLAT(-2:JM,KCON),AREATO(-2:JM), 4008. * AREAGR(-2:JM),AREAGI(-2:JM),AREALA(-2:JM),AREAOC(-2:JM) 4009. COMMON /DCONCB/ TITLE(KCON) 4010. C**** 4011. TIMDIF = IDACC(1)*DTS/SDAY 4012. C**** 4013. C**** Calculate areas for the different latitude bands 4014. C**** 4015. JINC = -(JM+11)/12 4016. JEQ = JM/2 4017. DO 10 J=-1,JM 4018. AREATO(J) = 0. 4019. AREAGR(J) = 0. 4020. AREAGI(J) = 0. 4021. AREALA(J) = 0. 4022. 10 AREAOC(J) = 0. 4023. DO 30 J=1,JM 4024. AREATO(J) = AREATO(J) + DXYP(J)*IM 4025. DO 20 I=1,IM 4026. AREAGR(J) = AREAGR(J) + DXYP(J)*FGRND(I,J) 4027. AREAGI(J) = AREAGI(J) + DXYP(J)*FGICE(I,J) 4028. AREALA(J) = AREALA(J) + DXYP(J)*FLAKE(I,J) 4029. 20 AREAOC(J) = AREAOC(J) + DXYP(J)*FOCEAN(I,J) 4029.5 30 IF(.not.QOCEAN) AREALA(J) = AREALA(J) + AREAOC(J) 4030. DO 40 JSH=1,JEQ 4031. JNH = 1+JM-JSH 4032. AREATO( 0) = AREATO( 0) + AREATO(JSH) 4033. AREAGR( 0) = AREAGR( 0) + AREAGR(JSH) 4034. AREAGI( 0) = AREAGI( 0) + AREAGI(JSH) 4035. AREALA( 0) = AREALA( 0) + AREALA(JSH) 4036. AREAOC( 0) = AREAOC( 0) + AREAOC(JSH) 4037. AREATO(-1) = AREATO(-1) + AREATO(JNH) 4038. AREAGR(-1) = AREAGR(-1) + AREAGR(JNH) 4039. AREAGI(-1) = AREAGI(-1) + AREAGI(JNH) 4040. AREALA(-1) = AREALA(-1) + AREALA(JNH) 4041. 40 AREAOC(-1) = AREAOC(-1) + AREAOC(JNH) 4042. AREATO(-2) = AREATO(-1) + AREATO(0) 4043. AREAGR(-2) = AREAGR(-1) + AREAGR(0) 4044. AREAGI(-2) = AREAGI(-1) + AREAGI(0) 4045. AREALA(-2) = AREALA(-1) + AREALA(0) 4046. AREAOC(-2) = AREAOC(-1) + AREAOC(0) 4047. C**** 4048. C**** Atmosphere 4049. C**** 4049.5 IF(.not.QATMO) GO TO 200 4050. C**** Angular Momentum 4051. SCALE( 1) = .5d-9*RADIUS 4052. SCALE( 2) = .5d-2*RADIUS/(DTS*IDACC(1)) 4053. SCALE( 3) = SCALE(2) 4054. SCALE( 4) = SCALE(2) 4055. SCALE( 5) = SCALE(2) 4056. SCALE( 6) = SCALE(2) 4057. SCALE( 7) = SCALE(2) 4058. SCALE( 8) = SCALE(2) 4059. SCALE( 9) = SCALE(2) 4060. C**** Kinetic Energy 4061. SCALE(10) = .25d-3 4062. SCALE(11) = 1.d3/(DTS*IDACC(1)) 4063. SCALE(12) = SCALE(11) 4064. SCALE(13) = SCALE(11)*.25 4065. SCALE(14) = SCALE(13) 4066. SCALE(15) = SCALE(13) 4067. SCALE(16) = SCALE(13) 4068. SCALE(17) = SCALE(13) 4069. SCALE(18) = SCALE(13) 4070. SCALE(19) = SCALE(13) 4071. C**** Air Mass 4072. SCALE(20) = 1. 4073. SCALE(21) = 1.d8/(DTS*IDACC(1)) 4074. SCALE(22) = SCALE(21) 4075. SCALE(23) = SCALE(21) 4076. SCALE(24) = SCALE(21) 4077. SCALE(25) = SCALE(21) 4078. C**** Total Potential Energy 4079. SCALE(26) = 1.d-5 4080. SCALE(27) = 1.d2/(DTS*IDACC(1)) 4081. SCALE(28) = SCALE(27) 4082. SCALE(29) = SCALE(27) 4083. SCALE(30) = SCALE(27) 4084. SCALE(31) = SCALE(27) 4085. C**** Potential Enthalpy 4086. SCALE(32) = 1.d-5*101325.**RKAP 4087. SCALE(33) = 1.d2*101325.**RKAP/(DTS*IDACC(1)) 4088. SCALE(34) = SCALE(33) 4089. SCALE(35) = SCALE(33) 4090. SCALE(36) = SCALE(33) 4091. SCALE(37) = SCALE(33) 4092. C**** Water Vapor Mass 4093. SCALE(38) = 1.d2 4094. SCALE(39) = 1.d8/(DTS*IDACC(1)) 4095. SCALE(40) = SCALE(39) 4096. SCALE(41) = SCALE(39) 4097. SCALE(42) = SCALE(39) 4098. C**** Calculate sum of changes 4099. DO 110 J=1,JM 4100. CONSRV(J, 9) = CONSRV(J, 4)+CONSRV(J, 5)+CONSRV(J, 6)+CONSRV(J, 7) 4101. * +CONSRV(J, 8) 4102. CONSRV(J,19) = CONSRV(J,13)+CONSRV(J,14)+CONSRV(J,15)+CONSRV(J,16) 4103. * +CONSRV(J,17)+CONSRV(J,18) 4104. CONSRV(J,25) = CONSRV(J,21)+CONSRV(J,22)+CONSRV(J,23)+CONSRV(J,24) 4105. CONSRV(J,31) = CONSRV(J,27)+CONSRV(J,28)+CONSRV(J,29)+CONSRV(J,30) 4106. CONSRV(J,37) = CONSRV(J,33)+CONSRV(J,34)+CONSRV(J,35)+CONSRV(J,36) 4107. 110 CONSRV(J,42) = CONSRV(J,39)+CONSRV(J,40)+CONSRV(J,41) 4108. C**** Write heading for Atmospheric diagnostics 4109. WRITE (6,911) LABEL,JYEAR0,JMON0,JDATE0,JHOUR0, 4110. * JYEAR,JMON,JDATE,JHOUR,IHOUR,IDAY,TIMDIF 4111. WRITE (6,912) 'Atmosphere',(NINT(RLAT(J)*360./TWOPI),J=JM,1,JINC) 4112. DO 150 N=1,42 4113. C**** Multiply conserved quantities by area when necessary 4114. DO 120 J=1,JM 4115. FLAT(J,N) = CONSRV(J,N)*DXYP(J) 4116. 120 IF(N.eq.2 .or. N.eq.3 .or. N.eq.11 .or. N.eq.12 .or. N.ge.26) 4117. * FLAT(J,N) = CONSRV(J,N) 4118. C**** Calculate hemispheric sums 4119. FLAT( 0,N) = 0. 4120. FLAT(-1,N) = 0. 4121. DO 130 JSH=1,JEQ 4122. JNH = 1+JM-JSH 4123. FLAT( 0,N) = FLAT( 0,N) + FLAT(JSH,N) 4124. 130 FLAT(-1,N) = FLAT(-1,N) + FLAT(JNH,N) 4125. FLAT(-2,N) = FLAT(-1,N) + FLAT(0 ,N) 4126. C**** Scale quantities and divide by area 4127. DO 140 J=-2,JM 4128. 140 FLAT(J,N) = FLAT(J,N)*SCALE(N)/AREATO(J) 4129. C**** Print properly scaled quantity 4130. 150 WRITE (6,917) TITLE(N),(FLAT(J,N) ,J=-2,0), 4131. * (NINT(FLAT(J,N)),J=JM,1,JINC) 4132. C**** Print areas 4133. WRITE (6,918) (AREATO(J)*1.D-10 ,J=-2,0), 4134. * (NINT(AREATO(J)*1.D-10),J=JM,1,JINC) 4135. C**** 4136. C**** Ground 4137. C**** 4137.5 200 IF(.not.QGRND) GO TO 500 4138. C**** Ground Water Mass 4139. RHOW = 1000. 4140. SCALE(43) = 1.d2*RHOW 4141. SCALE(44) = 1.d8*RHOW/(DTS*IDACC(1)) 4142. SCALE(45) = SCALE(44) 4143. SCALE(46) = SCALE(44) 4144. C**** Ground Energy 4145. SCALE(47) = 1.d-5 4146. SCALE(48) = 1.d2/(DTS*IDACC(1)) 4147. SCALE(49) = SCALE(48) 4148. SCALE(50) = SCALE(48) 4149. C**** Calculate sum of changes 4150. DO 210 J=1,JM 4151. CONSRV(J,46) = CONSRV(J,44) + CONSRV(J,45) 4152. 210 CONSRV(J,50) = CONSRV(J,48) + CONSRV(J,49) 4153. C**** Write heading for Ground diagnostics 4154. WRITE (6,911) LABEL,JYEAR0,JMON0,JDATE0,JHOUR0, 4155. * JYEAR,JMON,JDATE,JHOUR,IHOUR,IDAY,TIMDIF 4156. WRITE (6,912) 'Ground ',(NINT(RLAT(J)*360./TWOPI),J=JM,1,JINC) 4157. DO 250 N=43,50 4158. C**** Multiply conserved quantities by area 4159. DO 220 J=1,JM 4160. 220 FLAT(J,N) = CONSRV(J,N)*DXYP(J) 4161. C**** Calculate hemispheric sums 4162. FLAT( 0,N) = 0. 4163. FLAT(-1,N) = 0. 4164. DO 230 JSH=1,JEQ 4165. JNH = 1+JM-JSH 4166. FLAT( 0,N) = FLAT( 0,N) + FLAT(JSH,N) 4167. 230 FLAT(-1,N) = FLAT(-1,N) + FLAT(JNH,N) 4168. FLAT(-2,N) = FLAT(-1,N) + FLAT(0 ,N) 4169. C**** Scale quantities and divide by area 4170. DO 240 J=-2,JM 4171. 240 FLAT(J,N) = FLAT(J,N)*SCALE(N)/(AREAGR(J)+1.D-20) 4172. C**** Print properly scaled quantity 4173. 250 WRITE (6,917) TITLE(N),(FLAT(J,N) ,J=-2,0), 4174. * (NINT(FLAT(J,N)),J=JM,1,JINC) 4175. C**** Print areas 4176. WRITE (6,918) (AREAGR(J)*1.D-10 ,J=-2,0), 4177. * (NINT(AREAGR(J)*1.D-10),J=JM,1,JINC) 4178. C**** 4179. C**** Glacial Ice Mass 4180. C**** 4181. SCALE(51) = 1.d2 4182. SCALE(52) = 1.d8/(DTS*IDACC(1)) 4183. SCALE(53) = SCALE(52) 4184. SCALE(54) = SCALE(52) 4185. C**** Glacial Ice Energy 4186. SCALE(55) = 1.d-5 4187. SCALE(56) = 1.d2/(DTS*IDACC(1)) 4188. SCALE(57) = SCALE(56) 4189. SCALE(58) = SCALE(56) 4190. C**** Calculate sum of changes 4191. DO 310 J=1,JM 4192. CONSRV(J,54) = CONSRV(J,52) + CONSRV(J,53) 4193. 310 CONSRV(J,58) = CONSRV(J,56) + CONSRV(J,57) 4194. C**** Write heading for Glacial Ice diagnostics 4195. WRITE (6,912) 'Glacial Ic',(NINT(RLAT(J)*360./TWOPI),J=JM,1,JINC) 4196. DO 350 N=51,58 4197. C**** Multiply conserved quantities by area 4198. DO 320 J=1,JM 4199. 320 FLAT(J,N) = CONSRV(J,N)*DXYP(J) 4200. C**** Calculate hemispheric sums 4201. FLAT( 0,N) = 0. 4202. FLAT(-1,N) = 0. 4203. DO 330 JSH=1,JEQ 4204. JNH = 1+JM-JSH 4205. FLAT( 0,N) = FLAT( 0,N) + FLAT(JSH,N) 4206. 330 FLAT(-1,N) = FLAT(-1,N) + FLAT(JNH,N) 4207. FLAT(-2,N) = FLAT(-1,N) + FLAT(0 ,N) 4208. C**** Scale quantities and divide by area 4209. DO 340 J=-2,JM 4210. 340 FLAT(J,N) = FLAT(J,N)*SCALE(N)/(AREAGI(J)+1.D-20) 4211. C**** Print properly scaled quantity 4212. 350 WRITE (6,917) TITLE(N),(FLAT(J,N) ,J=-2,0), 4213. * (NINT(FLAT(J,N)),J=JM,1,JINC) 4214. C**** Print areas 4215. WRITE (6,918) (AREAGI(J)*1.d-10, J=-2,0), 4216. * (NINT(AREAGI(J)*1.d-10),J=JM,1,JINC) 4217. C**** 4218. C**** Lake Mass 4219. C**** 4220. SCALE(59) = 1.d2 4221. SCALE(60) = 1.d8/(DTS*IDACC(1)) 4222. SCALE(61) = SCALE(60) 4223. SCALE(62) = SCALE(60) 4224. SCALE(63) = SCALE(60) 4225. SCALE(64) = SCALE(60) 4226. C**** Lake Energy 4227. SCALE(65) = 1.d-5 4228. SCALE(66) = 1.d2/(DTS*IDACC(1)) 4229. SCALE(67) = SCALE(66) 4230. SCALE(68) = SCALE(66) 4231. SCALE(69) = SCALE(66) 4232. SCALE(70) = SCALE(66) 4233. C**** Calculate sum of changes 4234. DO 410 J=1,JM 4235. CONSRV(J,64) = CONSRV(J,60)+CONSRV(J,61)+CONSRV(J,62)+CONSRV(J,63) 4236. 410 CONSRV(J,70) = CONSRV(J,66)+CONSRV(J,67)+CONSRV(J,68)+CONSRV(J,69) 4237. C**** Write heading for Lake diagnostics 4238. WRITE (6,912) 'Lakes ',(NINT(RLAT(J)*360./TWOPI),J=JM,1,JINC) 4239. DO 450 N=59,70 4240. C**** Copy conserved quantities to FLAT 4241. DO 420 J=1,JM 4242. 420 FLAT(J,N) = CONSRV(J,N) 4243. C**** Calculate hemispheric sums 4244. FLAT( 0,N) = 0. 4245. FLAT(-1,N) = 0. 4246. DO 430 JSH=1,JEQ 4247. JNH = 1+JM-JSH 4248. FLAT( 0,N) = FLAT( 0,N) + FLAT(JSH,N) 4249. 430 FLAT(-1,N) = FLAT(-1,N) + FLAT(JNH,N) 4250. FLAT(-2,N) = FLAT(-1,N) + FLAT(0 ,N) 4251. C**** Scale quantities and divide by area 4252. DO 440 J=-2,JM 4253. 440 FLAT(J,N) = FLAT(J,N)*SCALE(N)/(AREALA(J)+1.d-20) 4254. C**** Print properly scaled quantity 4255. 450 WRITE (6,917) TITLE(N),(FLAT(J,N) ,J=-2,0), 4256. * (NINT(FLAT(J,N)),J=JM,1,JINC) 4257. C**** Print areas 4258. WRITE (6,918) (AREALA(J)*1.d-10 ,J=-2,0), 4259. * (NINT(AREALA(J)*1.d-10),J=JM,1,JINC) 4261. C**** 4262. C**** Ocean 4263. C**** 4263.5 500 IF(.not.QOCEAN) RETURN 4264. C**** Ocean Angular Momentum 4265. SCALE(71) = .5d-12*RADIUS 4266. SCALE(72) = .5d-2*RADIUS/(DTS*IDACC(1)) 4267. SCALE(73) = SCALE(72) 4268. SCALE(74) = SCALE(72) 4269. SCALE(75) = SCALE(72) 4270. SCALE(76) = SCALE(72) 4271. SCALE(77) = SCALE(72) 4271.1 SCALE(78) = SCALE(72) 4272. C**** Ocean Kinetic Energy 4273. SCALE(79) = .25 4274. SCALE(80) = .25d6/(DTS*IDACC(1)) 4275. SCALE(81) = SCALE(80) 4276. SCALE(82) = SCALE(80) 4277. SCALE(83) = SCALE(80) 4278. SCALE(84) = SCALE(80) 4279. SCALE(85) = SCALE(80) 4279.1 SCALE(86) = SCALE(80) 4280. C**** Ocean Mass 4281. SCALE(87) = 1.d-2 4282. SCALE(88) = 1.d8/(DTS*IDACC(1)) 4283. SCALE(89) = SCALE(88) 4284. SCALE(90) = SCALE(88) 4285. SCALE(91) = SCALE(88) 4286. SCALE(92) = SCALE(88) 4287. SCALE(93) = SCALE(88) 4288. SCALE(94) = SCALE(88) 4289. C**** Ocean Potential Enthalpy 4290. SCALE( 95) = 1.d-6 4291. SCALE( 96) = 1.d2/(DTS*IDACC(1)) 4292. SCALE( 97) = SCALE(96) 4293. SCALE( 98) = SCALE(96) 4294. SCALE( 99) = SCALE(96) 4295. SCALE(100) = SCALE(96) 4296. SCALE(101) = SCALE(96) 4297. SCALE(102) = SCALE(96) 4298. SCALE(103) = SCALE(96) 4299. C**** Ocean Salt 4300. SCALE(104) = 1.d-1 4301. SCALE(105) = 1.d8/(DTS*IDACC(1)) 4302. SCALE(106) = SCALE(105) 4303. SCALE(107) = SCALE(105) 4304. SCALE(108) = SCALE(105) 4305. C**** Calculate sum of changes 4306. DO 510 J=1,JM 4307. CONSRV(J, 78) = CONSRV(J,72) + CONSRV(J,73) + CONSRV(J,74) + 4308. * CONSRV(J,75) + CONSRV(J,76) + CONSRV(J,77) 4309. CONSRV(J, 86) = CONSRV(J,80) + CONSRV(J,81) + CONSRV(J,82) + 4310. * CONSRV(J,83) + CONSRV(J,84) + CONSRV(J,85) 4311. CONSRV(J, 94) = CONSRV(J,88) + CONSRV(J,89) + CONSRV(J,90) + 4312. * CONSRV(J,91) + CONSRV(J,92) + CONSRV(J,93) 4313. CONSRV(J,103) = CONSRV(J,96) + CONSRV(J,97) + CONSRV(J,98) + 4314. * CONSRV(J,99) + CONSRV(J,100)+ CONSRV(J,101)+ 4315. * CONSRV(J,102) 4316. 510 CONSRV(J,108) = CONSRV(J,105) + CONSRV(J,106) + CONSRV(J,107) 4317. C**** Write heading for Ocean diagnostics 4318. WRITE (6,911) LABEL,JYEAR0,JMON0,JDATE0,JHOUR0, 4319. * JYEAR,JMON,JDATE,JHOUR,IHOUR,IDAY,TIMDIF 4320. WRITE (6,912) 'Ocean ',(NINT(RLAT(J)*360./TWOPI),J=JM,1,JINC) 4321. DO 550 N=71,108 4322. C**** Multiply conserved quantities by area when necessary 4323. DO 520 J=1,JM 4324. FLAT(J,N) = CONSRV(J,N)*DXYP(J) 4325. 520 IF(N.ge.95) FLAT(J,N) = CONSRV(J,N) 4326. C**** Calculate hemispheric sums 4327. FLAT( 0,N) = 0. 4328. FLAT(-1,N) = 0. 4329. DO 530 JSH=1,JEQ 4330. JNH = 1+JM-JSH 4331. FLAT( 0,N) = FLAT( 0,N) + FLAT(JSH,N) 4332. 530 FLAT(-1,N) = FLAT(-1,N) + FLAT(JNH,N) 4333. FLAT(-2,N) = FLAT(-1,N) + FLAT(0 ,N) 4334. C**** Scale quantities and divide by area 4335. DO 540 J=-2,JM 4336. 540 FLAT(J,N) = FLAT(J,N)*SCALE(N)/(AREAOC(J)+1.d-20) 4337. C**** Print properly scaled quantity 4338. 550 WRITE (6,917) TITLE(N),(FLAT(J,N) ,J=-2,0), 4339. * (NINT(FLAT(J,N)),J=JM,1,JINC) 4340. C**** Print areas 4341. WRITE (6,918) (AREAOC(J)*1.d-10 ,J=-2,0), 4342. * (NINT(AREAOC(J)*1.d-10),J=JM,1,JINC) 4343. C**** 4344. C**** Sea Ice 4345. C**** 4346. C**** Sea Ice Mass 4347. SCALE(109) = 1.d2 4348. SCALE(110) = 1.d8/(DTS*IDACC(1)) 4349. SCALE(111) = SCALE(110) 4350. SCALE(112) = SCALE(110) 4351. SCALE(113) = SCALE(110) 4352. SCALE(114) = SCALE(110) 4353. SCALE(115) = SCALE(110) 4353.1 SCALE(116) = SCALE(110) 4354. C**** Sea Ice Energy 4355. SCALE(117) = 1.d-5 4356. SCALE(118) = 1.d2/(DTS*IDACC(1)) 4357. SCALE(119) = SCALE(118) 4358. SCALE(120) = SCALE(118) 4359. SCALE(121) = SCALE(118) 4360. SCALE(122) = SCALE(118) 4361. SCALE(123) = SCALE(118) 4361.1 SCALE(124) = SCALE(118) 4362. C**** Calculate sum of changes 4363. DO 610 J=1,JM 4364. CONSRV(J,116) = CONSRV(J,110) + CONSRV(J,111) + CONSRV(J,112) + 4365. * CONSRV(J,113) + CONSRV(J,114) + CONSRV(J,115) 4366. 610 CONSRV(J,124) = CONSRV(J,118) + CONSRV(J,119) + CONSRV(J,120) + 4367. * CONSRV(J,121) + CONSRV(J,122) + CONSRV(J,123) 4368. C**** Write heading for Sea Ice diagnostics 4369. WRITE (6,911) LABEL,JYEAR0,JMON0,JDATE0,JHOUR0, 4370. * JYEAR,JMON,JDATE,JHOUR,IHOUR,IDAY,TIMDIF 4371. WRITE (6,912) 'Sea Ice ',(NINT(RLAT(J)*360./TWOPI),J=JM,1,JINC) 4372. DO 650 N=109,124 4373. C**** Multiply conserved quantities by area when necessary 4374. DO 620 J=1,JM 4375. 620 FLAT(J,N) = CONSRV(J,N)*DXYP(J) 4376. C**** Calculate hemispheric sums 4377. FLAT( 0,N) = 0. 4378. FLAT(-1,N) = 0. 4379. DO 630 JSH=1,JEQ 4380. JNH = 1+JM-JSH 4381. FLAT( 0,N) = FLAT( 0,N) + FLAT(JSH,N) 4382. 630 FLAT(-1,N) = FLAT(-1,N) + FLAT(JNH,N) 4383. FLAT(-2,N) = FLAT(-1,N) + FLAT(0 ,N) 4384. C**** Scale quantities and divide by area 4385. DO 640 J=-2,JM 4386. 640 FLAT(J,N) = FLAT(J,N)*SCALE(N)/(AREAOC(J)+1.d-20) 4387. C**** Print properly scaled quantity 4388. 650 WRITE (6,917) TITLE(N),(FLAT(J,N) ,J=-2,0), 4389. * (NINT(FLAT(J,N)),J=JM,1,JINC) 4390. C**** Print areas 4391. WRITE (6,918) (AREAOC(J)*1.d-10 ,J=-2,0), 4392. * (NINT(AREAOC(J)*1.d-10),J=JM,1,JINC) 4393. C**** 4394. C**** Ice Bergs 4395. C**** 4396. C**** Ice Berg Mass 4397. SCALE(125) = 1.d4 4398. SCALE(126) = 1.d8/(DTS*IDACC(1)) 4399. SCALE(127) = SCALE(126) 4400. SCALE(128) = SCALE(126) 4401. SCALE(129) = SCALE(126) 4401.1 SCALE(130) = SCALE(126) 4402. C**** Ice Berg Energy 4403. SCALE(131) = 1.d-3 4404. SCALE(132) = 1.d2/(DTS*IDACC(1)) 4405. SCALE(133) = SCALE(132) 4406. SCALE(134) = SCALE(132) 4407. SCALE(135) = SCALE(132) 4407.1 SCALE(136) = SCALE(132) 4408. C**** Calculate sum of changes 4409. DO 710 J=1,JM 4410. CONSRV(J,130) = CONSRV(J,126) + CONSRV(J,127) + CONSRV(J,128) + 4410.1 + CONSRV(J,129) 4411. 710 CONSRV(J,136) = CONSRV(J,132) + CONSRV(J,133) + CONSRV(J,134) + 4411.1 + CONSRV(J,135) 4412. C**** Write heading for Ice Berg diagnostics 4413. WRITE (6,912) 'Ice Bergs ',(NINT(RLAT(J)*360./TWOPI),J=JM,1,JINC) 4414. DO 750 N=125,136 4415. C**** Copy conserved quantities to FLAT 4416. DO 720 J=1,JM 4417. 720 FLAT(J,N) = CONSRV(J,N) 4418. C**** Calculate hemispheric sums 4419. FLAT( 0,N) = 0. 4420. FLAT(-1,N) = 0. 4421. DO 730 JSH=1,JEQ 4422. JNH = 1+JM-JSH 4423. FLAT( 0,N) = FLAT( 0,N) + FLAT(JSH,N) 4424. 730 FLAT(-1,N) = FLAT(-1,N) + FLAT(JNH,N) 4425. FLAT(-2,N) = FLAT(-1,N) + FLAT(0 ,N) 4426. C**** Scale quantities and divide by area 4427. DO 740 J=-2,JM 4428. 740 FLAT(J,N) = FLAT(J,N)*SCALE(N)/(AREAOC(J)+1.d-20) 4429. C**** Print properly scaled quantity 4430. 750 WRITE (6,917) TITLE(N),(FLAT(J,N) ,J=-2,0), 4431. * (NINT(FLAT(J,N)),J=JM,1,JINC) 4432. C**** Print areas 4433. WRITE (6,918) (AREAOC(J)*1.d-10 ,J=-2,0), 4434. * (NINT(AREAOC(J)*1.d-10),J=JM,1,JINC) 4435. RETURN 4436. C**** 4437. 911 FORMAT ('1',A132 / 4438. * '0Conservation Quantities From:',I6,A6,I2,', Hr',I3, 4439. * 6X,'To:',I6,A6,I2,', Hr',I3,I11,I9,6X,'Dif:',F7.2,' Days') 4440. 912 FORMAT ('0',33('----') / 4441. * 1X,A10,25X,'Global N.Hem. S.Hem. ',12I6 / 1X,33('----')) 4442. 917 FORMAT (A32,1X,3F9.2,1X,12I6) 4443. 918 FORMAT ('0Area (10^10 m^2)',16X,3F9.2,1X,12I6) 4444. END 4500. 4501. BLOCK DATA CONSBD 4502. C**** 4503. C**** Titles for subroutine DIAGC 4504. C**** 4506. CHARACTER*32 TITLEA,TITLEL,TITLEO 4507. COMMON /DCONCB/ TITLEA(1:42),TITLEL(43:70),TITLEO(71:144) 4510. C**** 4511. DATA TITLEA / ! Atmosphere: 4512. 1 ' Instantan AM (10^9 J*s/m^2) ', ! Angular Momentum 4513. 2 ' Change of AM by ADVEC + CORIOL ', 4514. 3 ' Change of AM by PRESSURE GRAD ', 4515. 4 ' Change of AM by DYNAMICS ', 4516. 5 ' Change of AM by BINOMIAL FILTER', 4517. 6 ' Change of AM by SURFAC + CONDEN', 4518. 7 ' Change of AM by STRATOS DRAG ', 4519. 8 ' Change of AM by DAILY ', 4520. 9 ' Sum of AM changes (10^2 J/m^2) ', 4521. 1O '0Instantan KE (10^3 J/m^2) ', ! Kinetic Energy 4523. 11 ' Change of KE by ADVEC + CORIOL ', 4524. 12 ' Change of KE by PRESSURE GRAD ', 4525. 13 ' Change of KE by DYNAMICS ', 4526. 14 ' Change of KE by BINOMIAL FILTER', 4527. 15 ' Change of KE by MOIST CONVEC ', 4528. 16 ' Change of KE by SURF + DRY CONV', 4529. 17 ' Change of KE by STRATOS DRAG ', 4530. 18 ' Change of KE by DAILY ', 4531. 19 ' Sum KE changes (10^-3 W/m^2) ', 4532. 2O '0Instantan MASS (kg/m^2) ', ! Mass 4534. 21 ' Change of MASS by DYNAMICS ', 4535. 22 ' Change of MASS by CONDENSATION ', 4536. 23 ' Change of MASS by SURF EVAPORA ', 4537. 24 ' Change of MASS by DAILY ', 4538. 25 ' Sum changes (10^-8 kg/s*m^2) ', 4539. 26 '0Instantan SE (10^5 J/m^2) ', ! Static Energy 4540. 27 ' Change of SE by DYNAMICS ', 4541. 28 ' Change of SE by CONDENSATION ', 4542. 29 ' Change of SE by RADIATION ', 4543. 3O ' Change of SE by SURFACE INTER ', 4545. 31 ' Sum SE changes (10^-2 W/m^2) ', 4546. 32 '0Instantan PE (10^5 J/m^2) ', ! Potential Enthalpy 4547. 33 ' Change of PE by DYNAMICS ', 4548. 34 ' Change of PE by CONDENSATION ', 4549. 35 ' Change of PE by RADIATION ', 4550. 36 ' Change of PE by SURFACE INTER ', 4551. 37 ' Sum PE changes (10^-2 W/m^2) ', 4552. 38 '0Instantan VAPOR (10^-2 kg/m^2) ', ! Water Vapor Mass 4553. 39 ' Change of VAPOR by DYNAMICS ', 4554. 4O ' Change of VAPOR by CONDENSATION', 4556. 41 ' Change of VAPOR by SURF EVAPORA', 4557. 42 ' Sum changes (10^-8 KG/S*M^2) '/ 4557.5 DATA TITLEL / ! Ground: 4558. 43 '0Instantan WATER (10^-2 kg/m^2) ', ! Water Mass 4559. 44 ' Change of WATER by PRECIPITATN ', 4560. 45 ' Change of WATER by SURF EVAPORA', 4561. 46 ' Sum changes (10^-8 kg/s*m^2) ', 4562. 47 '0Instantan ENERGY (10^5 J/m^2) ', ! Energy 4563. 48 ' Change of ENERGY by PRECIPITATN', 4564. 49 ' Change of ENERGY by SURF FLUXES', 4565. 5O ' Sum ENRG change (10^-2 W/m^2) ', 4566. C**** ! Glacial Ice: 4567. 51 '0Instantan WATER (10^-2 kg/m^2) ', ! Water Mass 4568. 52 ' Change of WATER by PRECIPITATN ', 4569. 53 ' Change of WATER by SURF EVAPORA', 4570. 54 ' Sum changes (10^-8 kg/s*m^2) ', 4571. 55 '0Instantan ENERGY (10^5 J/m^2) ', ! Energy 4572. 56 ' Change of ENERGY by PRECIPITATN', 4573. 57 ' Change of ENERGY by SURF FLUXES', 4574. 58 ' Sum ENRG change (10^-2 W/m^2) ', 4574.5 C**** ! Lakes and Rivers: 4575. 59 '0Instantan WATER (10^-2 kg/m^2) ', ! Water Mass 4576. 6O ' Change of WATER by PRECIPITATN ', 4578. 61 ' Change of WATER by SURF EVAPORA', 4579. 62 ' Change of WATER by RIVER FLOW ', 4580. 63 ' Change of WATER by OCLIM ', 4581. 64 ' Sum changes (10^-8 kg/s*m^2) ', 4582. 65 '0Instantan ENERGY (10^5 J/m^2) ', ! Energy 4583. 66 ' Change of ENERGY by PRECIPITATN', 4584. 67 ' Change of ENERGY by SURF FLUXES', 4585. 68 ' Change of ENERGY by RIVER FLOW ', 4586. 69 ' Change of ENERGY by OCLIM ', 4587. 7O ' Sum ENRG change (10^-2 W/m^2) '/ 4588. DATA TITLEO / ! Ocean: 4589. 71 '0Instantan AM (10^12 J*s/m^2) ', ! Angular Momentum 4590. 72 ' Change of AM by DYNAMICS + STRA', 4591. 73 ' Change of AM by BINOMIAL FILTER', 4591.5 74 ' Change of AM by WATER EXCHANGE ', 4592. 75 ' Change of AM by OSTRES ', 4593. 76 ' Change of AM by CONVEC + MIXING', 4594. 77 ' Change of AM by BOTTM+SIDE DRAG', 4595. 78 ' Sum AM changes (10^2 J/m^2) ', 4596. 79 '0Instantan KE (J/m^2) ', ! Kinetic Energy 4597. 8O ' Change of KE by DYNAMICS + STRA', 4598. 81 ' Change of KE by BINOMIAL FILTER', 4598.5 82 ' Change of KE by WATER EXCHANGE ', 4600. 83 ' Change of KE by OSTRES ', 4601. 84 ' Chnage of KE by CONVEC + MIXING', 4602. 85 ' Change of KE by BOTTM+SIDE DRAG', 4603. 86 ' Sum KE changes (10^-6 W/m^2) ', 4604. 87 '0Instantan MASS (10^2 kg/m^2) ', ! Mass 4605. 88 ' Change of MASS by DYNAM + STRAI', 4606. 89 ' Change of MASS by PRECIPITATION', 4607. 9O ' Change of MASS by SEAICE RUNOFF', 4608. 91 ' Change of MASS by OSOURC ', 4609. 92 ' Change of MASS by RIVER FLOW ', 4611. 93 ' Change of MASS by SEA ICE MELT ', 4612. 94 ' Sum changes (10^-8 kg/s*m^2) ', 4613. 95 '0Instantan PE (10^6 J/M^2) ', ! Potential Enthalpy 4614. 96 ' Change of PE by DYNAM + STRAITS', 4615. 97 ' Change of PE by PRECIPITATION ', 4616. 98 ' Change of PE by SEAICE RUNOFF ', 4617. 99 ' Change of PE by OSOURC ', 4618. 10O ' Change of PE by CONVEV + MIXING', 4619. 101 ' Change of PE by RIVER FLOW ', 4620. 102 ' Change of PE by SEA ICE MELT ', 4622. 103 ' Sum PE changes (10^-2 W/m^2) ', 4623. 104 '0Instantan SALT (10^1 kg/m^2) ', ! Salt 4624. 105 ' Change of SALT by DYNAM + STRAI', 4625. 106 ' Change of SALT by OSOURC ', 4626. 107 ' Change of SALT by SEA ICE MELT ', 4627. 108 ' Sum changes (10^-8 kg/s*m^2) ', 4627.5 C**** ! Sea Ice: 4628. 109 ' Instantan MASS (10^-2 kg/m^2) ', ! Ice Mass 4629. 11O ' Change of MASS by ADVEC + STRAI', 4630. 111 ' Change of MASS by PRECIPITATION', 4631. 112 ' Change of MASS by SEAICE EVAP ', 4633. 113 ' Change of MASS by OSOURC FREEZE', 4633.5 114 ' Change of MASS by CALVING ', 4634. 115 ' Change of MASS by SEA ICE MELT ', 4635. 116 ' Sum changes (10^-8 kg/s*m^2) ', 4636. 117 '0Instantan ENRG (10^5 J/m^2) ', ! Energy 4637. 118 ' Change of ENRG by ADVEC + STRAI', 4638. 119 ' Change of ENRG by PRECIPITATION', 4639. 12O ' Change of ENRG by SEAICE FLUXES', 4640. 121 ' Change of ENRG by OSOURC FREEZE', 4640.5 122 ' Change of ENRG by CALVING ', 4641. 123 ' Change of ENRG by SEA ICE MELT ', 4642. 124 ' Sum ENRG change (10^-2 W/m^2) ', 4643. C**** ! Ice Bergs 4644. 125 ' Instantan MASS (10^-4 kg/m^2) ', ! Ice Berg Mass 4645. 126 ' Change of MASS by TRANSPORT ', 4646. 127 ' Change of MASS by CREATION ', 4646.5 128 ' Change of MASS by CALVING ', 4647. 129 ' Change of MASS by MELTING ', 4648. 13O ' Sum changes (10^-8 kg/s*m^2) ', 4649. 131 '0Instantan ENRG (10^3 J/m^2) ', ! Energy 4650. 132 ' Change of ENRG by TRANSPORT ', 4651. 133 ' Change of ENRG by CREATION ', 4651.5 134 ' Change of ENRG by CALVING ', 4652. 135 ' Change of ENRG by MELTING ', 4653. 136 ' Sum ENRG change (10^-2 W/m^2) ', 4654. 137 8*' '/ 4655. END 5000. 5001. SUBROUTINE DIAGJ 5002. C**** 5003. C**** DIAGJ prints diagnostics that are only a function of latitude. 5004. C**** The global and hemispheric values are area weighted. 5005. C**** 5006. C**** N AJ(N) 5007. C**** - ----- 5008. C***1 1 Solar radiation incident on planet (W/m^2) 5008.5 C**** 5009. C**1A 2/1 Planetary albedo (%) 5010. C**** 72/1 Planetary albedo in visual (%) 5011. C**1C 73/1 PLANETARY ALBEDO NEAR IR (10**-2) 5012. C**1D 6/5 GROUND ALBEDO (10**-2) 5013. C**1E 74/1 GROUND ALBEDO VISUAL (10**-2) 5014. C**1F 75/1 GROUND ALBEDO NEAR IR (10**-2) 5015. C**** 5016. C**1G 76/1 ATMOSPHERIC ALBEDO VISUAL (10**-2) 5017. C**1H 77/1 ATMOSPHERIC ALBEDO NEAR IR (10**-2) 5018. C**1I 78/1 ATMOSPHERIC ABSORPTION VISUAL (10**-2) 5019. C**1J 79/1 ATMOSPHERIC ABSORPTION NEAR IR (10**-2) 5020. C**** 5021. C***2 2 = 4+6 Solar radiation absorbed by planet (W/m^2) 5022. C***3 3 Solar radiation absorbed below MSTRAT (W/m^2) 5023. C***4 4 SOLAR RADIATION ABSORBED BY ATMOSPHERE (W/m**2) 5024. C***5 5 SOLAR RADIATION INCIDENT ON GROUND (W/m**2) 5025. C***6 6 SOLAR RADIATION ABSORBED BY GROUND (W/m**2) 5026. C**** 5027. C**** 7 = 9+70 THERMAL RADIATION EMITTED BY PLANET (W/m^2) 5028. C**** 8 = 9+71 THERMAL RADIATION AT MSTRAT (W/m^2) 5029. C**** 9 THERMAL RADIATION EMITTED BY GROUND (W/m**2) 5030. C**11 67 THERMAL RADIATION INCIDENT ON GROUND (W/m**2) 5031. C**** 55 BRIGHTNESS TEMPERATURE THROUGH WINDOW REGION (C) 5032. C**** 5033. C**** 10 = 2+7 NET RADIATION ABSORBED BY PLANET (W/m^2) 5034. C**** 11 = 3+8 NET RADIATION ABSORBED BELOW MSTRAT (W/m**2) 5035. C**** 32 Net radiation absorbed by dynamical atmosphere (W/mę) 5036. C**** 12 = 6+9 Net radiation absorbed by ground (W/m^2) 5037. C**** 5038. C**** 13 SENSIBLE HEAT FLUX INTO THE GROUND (W/m**2) 5039. C**** 14 EVAPORATION HEAT FLUX INTO THE GROUND (W/m**2) 5040. C**** 21 Geopotential energy flux from evaporation (W/mę) 5041. C**** 40 Sum of downward surface heat fluxes (W/mę) 5042. C**** 5042.1 C**** 42 Surface energy into lakes (W/m^2) 5042.2 C**** 47 Deep energy runoff into lakes (W/mę) 5042.3 C**** 5042.4 C**** 46 Draw glacial ice energy up or freeze sea water (W/m^2) 5042.5 C**** 15 Conduction from ice to water at ice bottom (W/mę) 5042.6 C**** 25 River flow energy (enthalpy + geopotential) (W/m^2) 5042.7 C**** 5043. C**** 39 PRECIPITATION HEAT FLUX INTO THE GROUND (W/m**2) 5044. C**** 22 Geopotential energy flux from precipitation (W/mę) 5045. C**** 24 Total precipitation energy fluxes (W/mę) 5047. C**** 41 Runoff energy from excess precipitation to lakes (W/mę) 5049. C**** 5050. C**** 45 Push glacial ice energy down or melt sea ice (W/m^2) 5053. C**** 5053.5 C**** 43 Air temperature of upper half of layer 1 (.1űC) 5053.6 C**** 44 Air temperature of lower half of layer 1 (.1űC) 5053.7 C**** 23 SURFACE AIR TEMPERATURE (.1 C) 5054. C**** 18 MEAN TEMPERATURE OF FIRST GROUND LAYER (.1 C) 5055. C**** 17 MEAN TEMPERATURE OF SECOND GROUND LAYER (.1 C) 5056. C**** 16 Ocean temperature of third layer (.1 C) 5057. C**** 5057.1 C**** 48 Surface wind speed (.1 m/s) 5057.2 C**** 64 Specific volume of surface layer (.01 m^3/kg) 5057.3 C**** 65 Richardson number between ground and surface (* 100) 5057.4 C**** 66 Drag coefficient for momentum (* 10^5) 5057.5 C**** 35 Cross isobar angle (ű) 5058. C**** 5059. C**** 68 VERTICALLY INTEGRATED OPTICAL DEPTH (.1) 5060. C**** 69 TOTAL CLOUD COVER (%) 5061. C**** 58 = 57/69 CLOUD TOP PRESSURE (mb) 5062. C**** 60 = 59/69 CLOUD TOP TEMPERATURE (K) 5063. C**** 5064. C**** 61 SUPER SATURATION PRECIPITATION (kg/m**2*day) 5065. C**** 62 MOIST CONVECTIVE PRECIPITATION (kg/m**2*day) 5066. C**** 20 PRECIPITATION (kg/m**2*day) 5066.1 C**** 33 Source runoff from excess precip to lakes (kg/męday) 5066.2 C**** 5066.3 C**** 36 Push glacial ice down or melt sea ice (mm/day) 5066.4 C**** 5067. C**** 19 EVAPORATION (kg/m**2*day) 5070. C**** 34 Source runoff from snow melting and dew to lakes (kg/męday) 5071. C**** 38 Deep layer runoff into lakes (kg/męday) 5071.5 C**** 5072. C**** 37 Evap and ice melt draws ice from below model (kg/męday) 5073. C**** 54 River flow mass (mm/day) 5074. C**** 5074.1 C**** 26 Specific humidity of upper half of layer 1 (* 10^5) 5074.2 C**** 27 Specific humidity of lower half of layer 1 (* 10^5) 5074.3 C**** 28 Specific humidity of surface layer (* 10^5) 5074.4 C**** 29 Saturated specific humidity of ground temperature (* 10^5) 5074.5 C**** 5075. C**** 63 WATER CONTENT OF ATMOSPHERE (kg/m**2) 5076. C**** 49 Water on canopy (kg/mę) 5077. C**** 50 Water in ground layer 1 (kg/mę) 5078. C**** 51 Water in ground layer 2 (kg/mę) 5079. C**** 52 Water in ground layer 3 (kg/mę) 5080. C**** 53 SNOW DEPTH (kg/m^2) 5081. C**** 5082. C**** 31 SNOW COVER (%) 5083. C**** 30 OCEAN ICE COVER (%) 5084. C**** 5085. INCLUDE 'C070.COM' 5086. PARAMETER (KMAX=66) 5087. INTEGER*4 JLAT(JM),ILAT(JM),INDEX(KMAX),IA(72),INNUM(10),INDEN(10) 5089. REAL*8 AF(JM,KAJ,6) 5090. REAL*8 SF(JM,6),QAF(6,9),SCALE(72),FLAT(JM),FHEM(2) 5091. CHARACTER*16 TERAIN(9), TITLE(KAJ),TITLEA(10) 5091.5 COMMON /BUDGCB/ FJNL(JM,0:KAJ,9) 5092. EQUIVALENCE (AF,AJ) 5093. C**** 5094. DATA TERAIN/' Global',' Ground',' Glacial Ice', 5095. * ' Open Lake',' Lake Ice',' Lakes', 5096. * ' Open Ocean',' Sea Ice',' Oceans'/ 5097. DATA TITLE/ 5098. 1 ' INC SW (W/m**2)', '0SW ABS BELOW P0', ' SW ABS BELOW P1', 5099. 4 ' SW ABS BY ATMOS', ' SW INC ON Z0 ', ' SW ABS AT Z0 ', 5100. 7 '0NET LW AT P0 ', ' NET LW AT P1 ', ' NET LW AT Z0 ', 5101. 1O '0NET RAD AT P0 ', ' NET RAD AT P1 ', ' NET RAD AT Z0 ', 5102. 13 '0SENSBL HEAT FLX', ' EVAPOR HEAT FLX', ' CONDUC ICE/OCEN', 5103. 16 ' TG3 ', ' TG2 ', ' TG1 ', 5104. 19 '0EVAPOR (MM/DAY)', ' PRECIP (MM/DAY)', ' GEOPOT ENRG FLX', 5105. 22 ' GEOPOT ENRG FLX', ' T SURF (.1 C) ', ' SUM PR ENRG FLX', 5106. 25 ' RIVER FLOW ENRG', '0SP HUM LAY 1 UP', ' SP HUM LAY 1 DN', 5107. 28 ' SP HUM SURF*1E4', ' SAT SP HUM GRND', ' OCEAN ICE COVER', 5108. 31 '0SNOW COVER (%) ', ' NET RAD ABS ATM', ' RUN PREC to LAK', 5109. 34 ' RUN SURF to LAK', ' CROSS ISO ANGLE', '0PUSH ICE DOWN ', 5110. 37 '0DRAW ICE UP ', ' RUN DEEP to LAK', '0PRECIP HEAT FLX', 5111. 4O ' SUM SURF FLUXES', ' ERUN PREC to LK', '0ERUN SURF to LK', 5112. 43 '0PT AIR LAY 1 UP', ' PT AIR LAY 1 DN', '0PUSH ICE ERG DN', 5113. 46 '0DRAW ICE ERG UP', ' ERUN DEEP to LK', '0SURF WIND SP*10', 5114. 49 ' WATER of CANOPY', ' WATER in G1 ', ' WATER in G2 ', 5115. 52 ' TG4 ', ' SNOW DEP(kg/m2)', ' RIVER FLOW MASS', 5116. 55 ' LW WINDOW B TEM', '*SR Abs Z0 to P1', '*CldTopP*CldCov ', 5117. 58 ' CLD TOP PRS(mb)', '*CldTopT*CldCov ', ' CLD TOP TEM (K)', 5118. 61 '0SS PRECIP ', ' MC PRECIP ', '0VAPOR IN ATMOS ', 5119. 64 ' SPEC VOL * 100 ', ' RICH NUM * 100 ', ' DRAG COEF * 1E4', 5120. 67 ' LW INC ON Z0 ', '0OPT DEPTH (.1) ', ' TOTAL CLOUD COV', 5121. 7O '*TR Abs Z0 to P0', '*TR Abs Z0 to Z1', '*PLAN ALB VISUAL', 5121.1 73 '*PLAN ALB NEARIR', '*SURF ALB VISUAL', '*SURF ALB NEARIR', 5121.2 76 '*ATMO ALB VISUAL', '*ATMO ALB NEARIR', '*ATMO ABS VISUAL', 5121.3 79 '*ATMO ABS NEARIR', '*ATMO ALB NEARIR'/ 5121.8 DATA TITLEA / 5122. 1 '0PLANETARY ALBDO', ' PLAN ALB VISUAL', ' PLAN ALB NEARIR', 5123. 4 ' SURF ALB A2/A1', ' SURF ALB VISUAL', ' SURF ALB NEARIR', 5124. 7 '0ATMO ALB VISUAL', ' ATMO ALB NEARIR', ' ATMO ABS VISUAL', 5125. 1O ' ATMO ABS NEARIR'/ 5126. C**** 5127. DATA QAF / 6*1., 1.,0.,0.,0.,0.,0., 0.,1.,0.,0.,0.,0., 5127.1 * 0.,0.,1.,0.,0.,0., 0.,0.,0.,1.,0.,0., 0.,0.,1.,1.,0.,0., 5127.2 * 0.,0.,0.,0.,1.,0., 0.,0.,0.,0.,0.,1., 0.,0.,0.,0.,1.,1./ 5129. DATA INDEX /1, 2,3,4,5,6, 7,8,9,67,55, 10,11,32,12, 5130. * 13,14,22,40, 42,47, 46,15,25, 39,21,24,41, 45, 5131. * 43,44,23,18,17,16,52, 48,64,65,66,35, 68,69,58,60, 5132. * 61,62,20,33,36, 19,34,38, 37,54, 26,27,28,29, 5132.1 * 63,49,50,51,53, 31,30/ 5133. DATA INNUM/2,72,73,6,74,75,76,77,78,79/, INDEN/3*1,5,6*1/ 5134. C**** IA: 1 sources, 2 radiation, 3 surface, 4 DIAGA, 5 ocean prog 5135. DATA IA/5*2, 1,2,2,1,2, 2,1,1,1,1, 1,1,1,1,1, 1,1,1,1,1, 5136. 26 1,1,1,1,1, 1,1,1,1,1, 1,1,1,1,1, 1,1,1,1,1, 1,1,1,1,1, 5137. 51 1,1,1,1,2, 1,2,2,2,2, 1,1,4,1,1, 1,2,2,2,0, 0,0/ 5138. DATA SCALE/5*1., 5*1., 5*1., 3*10.,2*1., 2*1.,10.,1.,100., 5139. 26 5*100., 100.,4*1., 5*1., 5*1., 5*1., 5140. 51 1.,10.,3*1., 1.,0.,1.,0.,1., 5*1., 2*1.,10.,100.,1., 2*1./ 5141. C**** Initialize unchanging parameters 5142. INC = 1+(JM-1)/24 5143. JMHALF= JM/2 5143.5 SCALE( 6) = 1./DTS 5144. SCALE( 9) = 1./DTS 5145. SCALE(12) = 1./DTS 5146. SCALE(13) = 1./DTS 5147. SCALE(14) = 1./DTS 5148. SCALE(15) = 1./DTS 5149. SCALE(19) = NDAY 5150. SCALE(20) = NDAY 5151. SCALE(21) = GRAV/DTS 5152. SCALE(22) = GRAV/DTS 5153. SCALE(23) = 10./NSURF 5154. SCALE(24) = 1./DTS 5154.1 SCALE(25) = 1./DTS 5154.2 SCALE(26) = 1.D4/NSURF 5154.3 SCALE(27) = 1.D4/NSURF 5154.4 SCALE(28) = 1.D4/NSURF 5154.5 SCALE(29) = 1.D4/NSURF 5155. SCALE(33) = NDAY 5156. SCALE(34) = NDAY 5157. SCALE(35) = 360./(TWOPI*NSURF) 5158. SCALE(36) = NDAY 5159. SCALE(37) = NDAY 5160. SCALE(38) = NDAY 5161. SCALE(39) = 1./DTS 5162. SCALE(40) = 1./DTS 5163. SCALE(41) = 1./DTS 5164. SCALE(42) = 1./DTS 5165. SCALE(43) = 10./NSURF 5166. SCALE(44) = 10./NSURF 5167. SCALE(45) = 1./DTS 5168. SCALE(46) = 1./DTS 5169. SCALE(47) = 1./DTS 5169.1 SCALE(48) = 10./NSURF 5169.9 SCALE(54) = NDAY 5171. SCALE(61) = SCALE(20) 5172. SCALE(62) = SCALE(20) 5172.1 SCALE(64) = 100./NSURF 5172.2 SCALE(65) = 100./NSURF 5172.3 SCALE(66) = 1.D4/NSURF 5173. C**** Sum surface type fractions 5173.1 LMTER = 9 5173.2 IF(.not.QOCEAN) then 5173.3 LMTER = 6 5173.4 DO 5 L=4,6 5173.5 DO 5 K=1,6 5173.6 5 QAF(K,L) = QAF(K,L) + QAF(K,L+3) 5173.7 endif 5174. DO 10 J=1,JM 5175. JLAT(J) = NINT(RLAT(J)*360./TWOPI) 5176. DO 10 L=1,6 5177. 10 SF(J,L) = 0. 5178. DO 20 J=2,JM-1 5179. DO 20 I=1,IM 5180. SF(J,1) = SF(J,1) + FGRND(I,J) 5181. SF(J,2) = SF(J,2) + FGICE(I,J) 5182. SF(J,3) = SF(J,3) + FLAKE(I,J) 5183. 20 SF(J,5) = SF(J,5) + FOCEAN(I,J) 5184. SF(1,2) = 1. 5186. SF(JM,5)= 1. 5187. DO 30 J=2,JM 5188. SF(J,4) = DJ(J,30)/IDACC(1) 5189. SF(J,3) = SF(J,3) - SF(J,4) 5190. SF(J,6) = FJ(J,30)/IDACC(1) 5191. 30 SF(J,5) = SF(J,5) - SF(J,6) 5196. C**** Fill in constant diagnostics 5197. DO 110 J=1,JM 5198. BJ(J,50) = IDACC(1)*SF(J,2)*ACE1I 5199. DJ(J,50) = IDACC(1)*SF(J,4)*ACE1I 5200. FJ(J,50) = IDACC(1)*SF(J,6)*ACE1I 5201. 110 BJ(J,51) = IDACC(1)*SF(J,2)*ACE2GI 5202. C**** Calculate derived diagnostics 5203. A2BYA1 = IDACC(2)/FLOAT(IDACC(1)) 5204. DO 120 J=1,JM 5205. CJ(J,15) = - DJ(J,15) 5206. CJ(J,33) = - DJ(J,33) - BJ(J,33) 5207. CJ(J,34) = - DJ(J,34) - BJ(J,34) - AJ(J,34) 5207.5 CJ(J,36) = - DJ(J,36) 5207.6 CJ(J,37) = - DJ(J,37) 5208. CJ(J,38) = - DJ(J,38) - BJ(J,38) - AJ(J,38) 5209. CJ(J,41) = - DJ(J,41) - BJ(J,41) 5210. CJ(J,42) = - DJ(J,42) - BJ(J,42) - AJ(J,42) 5210.5 CJ(J,45) = - DJ(J,45) 5210.6 CJ(J,46) = - DJ(J,46) 5211. CJ(J,47) = - DJ(J,47) - BJ(J,47) - AJ(J,47) 5212. EJ(J,15) = - FJ(J,15) 5213. EJ(J,33) = - FJ(J,33) 5214. EJ(J,34) = - FJ(J,34) 5214.5 EJ(J,36) = - FJ(J,36) 5214.6 EJ(J,37) = - FJ(J,37) 5215. EJ(J,38) = - FJ(J,38) 5216. EJ(J,41) = - FJ(J,41) 5217. EJ(J,42) = - FJ(J,42) 5217.5 EJ(J,45) = - FJ(J,45) 5217.6 EJ(J,46) = - FJ(J,46) 5218. EJ(J,47) = - FJ(J,47) 5219. DO 120 L=1,6 5220. AF(J, 2,L) = AF(J, 4,L) + AF(J,6,L)*A2BYA1/DTS 5221. AF(J, 3,L) = AF(J,56,L) + AF(J,6,L)*A2BYA1/DTS 5223. AF(J, 7,L) = AF(J,70,L) + AF(J,9,L)*A2BYA1/DTS 5224. AF(J, 8,L) = AF(J,71,L) + AF(J,9,L)*A2BYA1/DTS 5225. AF(J,10,L) = AF(J, 2,L) + AF(J,7,L) 5226. AF(J,11,L) = AF(J, 3,L) + AF(J,8,L) 5226.1 AF(J,12,L) = AF(J, 6,L) + AF(J,9,L) 5226.5 AF(J,24,L) = AF(J,39,L) + AF(J,21,L)*GRAV 5226.6 AF(J,40,L) = AF(J,13,L) + AF(J,14,L) + AF(J,22,L)*GRAV 5227. AF(J,62,L) = AF(J,20,L) - AF(J,61,L) 5228. AF(J,58,L) = IDACC(2)*SF(J,L)*AF(J,57,L) / (AF(J,69,L)+1.d-20) 5229. 120 AF(J,60,L) = IDACC(2)*SF(J,L)*AF(J,59,L) / (AF(J,69,L)+1.d-20) 5230. C**** Calculate column water vapor of atmosphere from AIJL(9) 5231. DO 140 J=1,JM 5232. IMAX=IM 5233. IF(J.eq.1 .or. J.eq.JM) IMAX=1 5234. AJ(J,63) = 0. 5235. BJ(J,63) = 0. 5236. CJ(J,63) = 0. 5237. DJ(J,63) = 0. 5238. EJ(J,63) = 0. 5239. FJ(J,63) = 0. 5240. DO 140 I=1,IMAX 5241. SQ0M = 0. 5242. DO 130 L=1,LMA 5243. 130 SQ0M = SQ0M + AIJL(I,J,L,9) 5244. RSIM = AIJ(I,J,1)/IDACC(1) 5245. AJ(J,63) = AJ(J,63) + SQ0M*BYDXYP(J)*FGRND(I,J) 5246. BJ(J,63) = BJ(J,63) + SQ0M*BYDXYP(J)*FGICE(I,J) 5247. CJ(J,63) = CJ(J,63) + SQ0M*BYDXYP(J)*FLAKE(I,J)*(1.-RSIM) 5248. DJ(J,63) = DJ(J,63) + SQ0M*BYDXYP(J)*FLAKE(I,J)*RSIM 5249. EJ(J,63) = EJ(J,63) + SQ0M*BYDXYP(J)*FOCEAN(I,J)*(1.-RSIM) 5250. 140 FJ(J,63) = FJ(J,63) + SQ0M*BYDXYP(J)*FOCEAN(I,J)*RSIM 5251. TIMDIF = IDACC(1)*DTS/SDAY 5252. C**** 5253. C**** Loop over terrain types 5254. C**** 5255. DO 500 L=1,LMTER 5256. WRITE (6,930) LABEL 5257. WRITE (6,931) TERAIN(L),JYEAR0,JMON0,JDATE0,JHOUR0, 5258. * JYEAR,JMON,JDATE,JHOUR,IHOUR,IDAY,TIMDIF 5259. WRITE (6,932) (JLAT(J),J=JM,1,-INC) 5260. WRITE (6,933) 5261. DO 490 K=1,KMAX 5262. N=INDEX(K) 5263. IACC = IDACC(IA(N)) 5264. QGLO = 0. 5265. WGLO = 0. 5266. DO 320 JHEMI=1,2 5267. QHEM = 0. 5268. WHEM = 0. 5269. DO 310 JH=1,JMHALF 5270. J=(JHEMI-1)*JMHALF+JH 5271. QLAT = (AJ(J,N)*QAF(1,L) + BJ(J,N)*QAF(2,L) + 5272. * CJ(J,N)*QAF(3,L) + DJ(J,N)*QAF(4,L) + 5273. * EJ(J,N)*QAF(5,L) + FJ(J,N)*QAF(6,L))*SCALE(N) 5274. WLAT = (SF(J,1)*QAF(1,L) + SF(J,2)*QAF(2,L) + 5275. * SF(J,3)*QAF(3,L) + SF(J,4)*QAF(4,L) + 5276. * SF(J,5)*QAF(5,L) + SF(J,6)*QAF(6,L))*IACC 5277. FLAT(J) = QLAT/(WLAT+1.d-20) 5278. ILAT(J) = NINT(FLAT(J)) 5279. QHEM = QHEM + QLAT*DXYP(J) 5280. WHEM = WHEM + WLAT*DXYP(J) 5281. IF(J.eq.1 .or. J.eq.JM) QHEM = QHEM + QLAT*DXYP(J)*(IM-1) 5282. IF(J.eq.1 .or. J.eq.JM) WHEM = WHEM + WLAT*DXYP(J)*(IM-1) 5282.5 FJNL(J,0,L) = WLAT 5282.6 FJNL(J,N,L) = FLAT(J) 5283. 310 CONTINUE 5284. FHEM(JHEMI) = QHEM/(WHEM+1.d-20) 5285. QGLO = QGLO + QHEM 5286. 320 WGLO = WGLO + WHEM 5287. FGLO = QGLO/(WGLO+1.d-20) 5289. GO TO (360,360,360,360,360, 360,360,360,360,360, 5290. 11 360,360,360,360,350, 360,360,360,350,350, 5291. 21 350,340,360,350,350, 360,360,360,360,370, 5292. 31 370,360,350,350,360, 350,350,350,350,360, 5293. 41 350,350,360,360,350, 350,350,360,360,360, 5294. 51 360,360,360,350,360, 999,999,360,999,360, 5295. 61 350,350,360,360,360, 360,360,360,360,999, 999,999),N 5296. 340 WRITE (6,934) TITLE(N),FGLO,FHEM(2),FHEM(1),(FLAT(J),J=JM,1,-INC) 5297. GO TO 490 5298. 350 WRITE (6,935) TITLE(N),FGLO,FHEM(2),FHEM(1),(FLAT(J),J=JM,1,-INC) 5299. GO TO 490 5299.5 370 WRITE (6,937) TITLE(N),FGLO,FHEM(2),FHEM(1),(ILAT(J),J=JM,1,-INC) 5299.6 GO TO 490 5300. 360 WRITE (6,936) TITLE(N),FGLO,FHEM(2),FHEM(1),(ILAT(J),J=JM,1,-INC) 5301. IF(N.ne.1) GO TO 490 5302. C**** 5303. C**** Calculate and Print Albedos 5304. C**** 5305. 400 DO 430 KA=1,10 5306. NN=INNUM(KA) 5307. ND=INDEN(KA) 5309. QGLO = 0. 5310. WGLO = 0. 5311. DO 420 JHEMI=1,2 5312. QHEM = 0. 5313. WHEM = 0. 5314. DO 410 JH=1,JMHALF 5315. J=(JHEMI-1)*JMHALF+JH 5316. QLAT = AJ(J,NN)*QAF(1,L) + BJ(J,NN)*QAF(2,L) + 5317. * CJ(J,NN)*QAF(3,L) + DJ(J,NN)*QAF(4,L) + 5318. * EJ(J,NN)*QAF(5,L) + FJ(J,NN)*QAF(6,L) 5319. WLAT = AJ(J,ND)*QAF(1,L) + BJ(J,ND)*QAF(2,L) + 5320. * CJ(J,ND)*QAF(3,L) + DJ(J,ND)*QAF(4,L) + 5321. * EJ(J,ND)*QAF(5,L) + FJ(J,ND)*QAF(6,L) 5322. FLAT(J) = 100.*QLAT/(WLAT+1.d-20) 5323. IF(KA.eq.1) FLAT(J) = 100.-FLAT(J) 5323.1 IF(KA.eq.4) FLAT(J) = 100.-FLAT(J)*A2BYA1/DTS 5324. ILAT(J) = NINT(FLAT(J)) 5325. QHEM = QHEM + QLAT*DXYP(J) 5326. WHEM = WHEM + WLAT*DXYP(J) 5327. IF(J.eq.1 .or. J.eq.JM) QHEM = QHEM + QLAT*DXYP(J)*(IM-1) 5328. IF(J.eq.1 .or. J.eq.JM) WHEM = WHEM + WLAT*DXYP(J)*(IM-1) 5329. 410 CONTINUE 5330. FHEM(JHEMI) = 100.*QHEM/(WHEM+1.d-20) 5331. IF(KA.eq.1) FHEM(JHEMI) = 100.-FHEM(JHEMI) 5331.1 IF(KA.eq.4) FHEM(JHEMI) = 100.-FHEM(JHEMI)*A2BYA1/DTS 5332. QGLO = QGLO + QHEM 5333. 420 WGLO = WGLO + WHEM 5334. FGLO = 100.*QGLO/(WGLO+1.d-20) 5335. IF(KA.eq.1) FGLO = 100.-FGLO 5335.1 IF(KA.eq.4) FGLO = 100.-FGLO*A2BYA1/DTS 5337. WRITE (6,936) 5338. * TITLEA(KA),FGLO,FHEM(2),FHEM(1),(ILAT(J),J=JM,1,-INC) 5339. 430 CONTINUE 5340. 490 CONTINUE 5341. WRITE (6,932) (JLAT(J),J=JM,1,-INC) 5342. WRITE (6,933) 5343. 500 CONTINUE 5344. RETURN 5345. C**** 5346. 930 FORMAT ('1',A132) 5347. 931 FORMAT ('0** BUDGETS',A13,'** From:',I6,A6,I2,', Hr',I3, 5348. * 6X,'To:',I6,A6,I2,', Hr',I3,I11,I9,6X,'Dif:',F7.2,' Days') 5349. 932 FORMAT ('0',132('-') / 18X,'Global N.Hem. S.Hem. ',24I4) 5350. 933 FORMAT ( 1X,132('-')) 5351. 934 FORMAT (A16,3F8.3,1X,24F4.1) 5352. 935 FORMAT (A16,3F8.4,1X,24F4.1) 5353. 936 FORMAT (A16,3F8.3,1X,24I4) 5354. 937 FORMAT (A16,3F8.4,1X,24I4) 5355. 999 END