1. C**** 2. C**** C070D.S Fortran source code for diagnostics 2003/11/25 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**** 11. SUBROUTINE DIAGA 12. C**** 13. C**** DIAGA accumulates some diagnostics, and is called from within 14. C**** the atmospheric dynamics leap frog scheme 15. C**** 16. INCLUDE 'C070.COM' 18. PARAMETER (OMEGA=TWOPI*366./(365.*SDAY)) 19. COMMON /FLUXCB/ MU(IM,JM,LMA),MV(IM,JM,LMA),MW(IM,JM,LMA-1) 20. COMMON /WORK02/ W(IM,JM,LMA) 21. COMMON /WORK04/ MWM(JM,LMA-1),TRI(3) 22. C**** 24. CALL TIMER0 25. IDACC(4) = IDACC(4) + 1 26. C**** 27. C**** OUTSIDE J LOOP FOR ALL PRIMARY GRID ROWS 28. C**** 29. DO 490 J=1,JM 30. IMAX=IM 31. IF(J.eq.1 .or. J.eq.JM) IMAX=1 37. C**** Accumulate diagnostic for radiation euilibrium layers 38. DO 470 LQ=1,3 39. TRI(LQ) = 0. 40. DO 460 I=1,IMAX 41. 460 TRI(LQ) = TRI(LQ) + RQT(I,J,LQ)/SHCD 42. 470 AQJL(J,LQ,1) = AQJL(J,LQ,1) + (TRI(LQ)-273.16*IMAX) 43. 490 CONTINUE 44. C**** 45. C**** MOMENTUM AND KINETIC ENERGY AT PRIMARY GRID ROWS 46. C**** 47. I=IM 48. DO 610 L=1,LMA 49. DO 610 J=1,JM 50. M2I = 0. 51. MUI = 0. 52. MUUI = 0. 53. DO 604 IP1=1,IM 54. M2I = M2I + MA(I,J,L)+MA(IP1,J,L) 55. MUI = MUI + MU(I,J,L) 56. MUUI = MUUI + MU(I,J,L)*UA(I,J,L) 57. 604 I=IP1 58. AJL(J,L, 6) = AJL(J,L, 6) + (MUI/DYP(J))**2/M2I 59. AJL(J,L, 7) = AJL(J,L, 7) + MUUI/DYP(J) 60. 610 CONTINUE 61. C**** 62. C**** MOMENTUM, KINETIC ENERGY, NORTHWARD TRANSPORTS, AND ANGULAR 63. C**** MOMENTUM AT SECONDARY GRID ROWS 64. C**** 65. DO 640 J=1,JM-1 66. DO 640 L=1,LMA 67. M2I = 0. 68. MVI = 0. 69. MVVI = 0. 70. M2WWI = 0. 71. MVWWI = 0. 72. M2U4I = 0. 73. MVU4I = 0. 74. IM1=IM 75. DO 620 I=1,IM 76. M2 = MA(I,J,L)+MA(I,J+1,L) 77. M2I = M2I + M2 78. MVI = MVI + MV(I,J,L) 79. MVVI = MVVI + MV(I,J,L)*VA(I,J,L) 80. UU = .25*(UA(IM1,J,L)*UA(IM1,J,L) + UA(I,J,L)*UA(I,J,L) + 81. * UA(IM1,J+1,L)*UA(IM1,J+1,L) + UA(I,J+1,L)*UA(I,J+1,L)) 82. M2WWI = M2WWI + M2*(UU+VA(I,J,L)*VA(I,J,L)) 83. MVWWI = MVWWI + MV(I,J,L)*(UU+VA(I,J,L)*VA(I,J,L)) 84. U4 = UA(IM1,J,L)+UA(I,J,L)+UA(IM1,J+1,L)+UA(I,J+1,L) 85. M2U4I = M2U4I + M2*U4 86. MVU4I = MVU4I + MV(I,J,L)*U4 87. 620 IM1=I 88. AJL(J ,L, 6) = AJL(J ,L, 6) + (MVI/DXV(J))**2/M2I 89. AJL(J+1,L, 6) = AJL(J+1,L, 6) + (MVI/DXV(J))**2/M2I 90. AJL(J ,L, 7) = AJL(J ,L, 7) + .5*MVVI/DXV(J) 91. AJL(J+1,L, 7) = AJL(J+1,L, 7) + .5*MVVI/DXV(J) 92. AJL(J,L, 8) = AJL(J,L, 8) + M2WWI*MVI/M2I 93. AJL(J,L, 9) = AJL(J,L, 9) + MVWWI 94. AJL(J,L, 4) = AJL(J,L, 4) + M2U4I*MVI/M2I 95. AJL(J,L, 5) = AJL(J,L, 5) + MVU4I 96. 640 CONTINUE 97. C**** 98. C**** VERTICAL TRANSPORT OF KINETIC ENERGY AND ANGULAR MOMENTUM 99. C**** 100. DO 690 L=1,LMA-1 101. IM1=IM 102. DO 670 J=2,JM-1 103. AMA = RADIUS*OMEGA*COSP(J) 104. TKE = 0. 105. UM = 0. 106. UMW = 0. 107. DO 660 I=1,IM 108. TKE = TKE + MW(I,J,L)*( 109. * (UA(IM1,J,L)+UA(IM1,J,L+1))**2+(UA(I,J,L)+UA(I,J,L+1))**2 + 110. * (VA(I,J-1,L)+VA(I,J-1,L+1))**2+(VA(I,J,L)+VA(I,J,L+1))**2) 111. UM = UM + (UA(I,J,L)+UA(I,J,L+1)) 112. UMW = UMW + MW(I,J,L)* 113. * (UA(IM1,J,L)+UA(IM1,J,L+1)+UA(I,J,L)+UA(I,J,L+1)) 114. 660 IM1=I 115. AJL(J,L, 1) = AJL(J,L, 1) + TKE 116. AJL(J,L, 2) = AJL(J,L, 2) + (UMW-2.*MWM(J,L)*UM) 117. 670 AJL(J,L, 3) = AJL(J,L, 3) + (UMW+4.*AMA*IM*MWM(J,L)) 118. C**** Calculations at the poles 119. VKES = 0. 120. VKEN = 0. 121. DO 680 I=1,IM 122. VKES = VKES + (VA(I,1,L)+VA(I,1,L+1))**2 123. 680 VKEN = VKEN + (VA(I,JM-1,L)+VA(I,JM-1,L+1))**2 124. AJL( 1,L, 1) = AJL( 1,L, 1) + IM*MW(1, 1,L)*2.*VKES 125. AJL(JM,L, 1) = AJL(JM,L, 1) + IM*MW(1,JM,L)*2.*VKEN 126. 690 CONTINUE 127. C**** 128. CALL TIMER1 (MDIAG) 129. RETURN 130. END 1000. 1001. SUBROUTINE DIAGCA (K) 1002. C**** 1003. C**** DIAGCA accumulates the atmospheric changes in Angular Momentum, 1004. C**** Kinetic Energy, Mass, Total Potential Energy, Potential Enthalpy, 1005. C**** and Water Vapor Mass caused by different physical processes. 1006. C**** 1007. INCLUDE 'C070.COM' 1008. INTEGER*4 NMSOFK(12),NAMOFK(12),NKEOFK(12),NTEOFK(12),NPEOFK(12), 1009. * NWVOFK(12), MBEGIN,MEND 1010. REAL*8 AM(JM),RKE(JM),AMASS(JM),TPE(JM),PE(JM),VAPOR(JM) 1011. PARAMETER (AREAG=2.*TWOPI*RADIUS*RADIUS, 1012. * OMEGA=TWOPI*366./(365.*SDAY), TKF=273.16) 1013. COMMON /WORK00/ PKDN(IM,JM,LMA),PKUP(IM,JM,LMA),MSUM(IM,JM) 1014. COMMON /WORK03/ DUM(IM,JM,LMA),DVM(IM,JM,LMA) 1015. COMMON /WORK05/ CONV(IM,JM,LMA) 1016. C**** 1017. DATA NMSOFK / 20,21, 1,22, 1,23, 1, 1, 1, 1, 1,24/, 1018. * NAMOFK / 1, 4, 5, 1, 1, 6, 7, 1, 1, 1, 1, 1/, 1019. * NKEOFK / 10,13,14,15, 1,16,17, 1, 1, 1, 1, 1/, 1020. * NTEOFK / 26,27, 1,28,29,30, 1, 1, 1, 1, 1, 1/, 1021. * NPEOFK / 32,33, 1,34,35,36, 1, 1, 1, 1, 1, 1/, 1022. * NWVOFK / 38,39, 1,40, 1,41, 1, 1, 1, 1, 1, 1/ 1023. CALL TIMER0 1024. C**** Calculate PK = P**RKAP, integrate pressures from top down 1025. IF(QPK) GO TO 90 1026. DO 10 I=IM,IM*(JM-1)+1 1027. MSUM(I,1) = MSTRAT 1029. DO 10 L=LMA,1,-1 1030. MSUM(I,1) = MSUM(I,1) + MA(I,1,L) 1031. PKDN(I,1,L) = (GRAV*(MSUM(I,1)-MA(I,1,L)*.25))**RKAP 1032. 10 PKUP(I,1,L) = (GRAV*(MSUM(I,1)-MA(I,1,L)*.75))**RKAP 1033. DO 20 I=1,IM 1034. MSUM(I, 1) = MSUM(IM,1) 1035. MSUM(I,JM) = MSUM(1,JM) 1036. DO 20 L=1,LMA 1037. PKDN(I, 1,L) = PKDN(IM,1,L) 1038. PKDN(I,JM,L) = PKDN(1,JM,L) 1039. PKUP(I, 1,L) = PKUP(IM,1,L) 1040. 20 PKUP(I,JM,L) = PKUP(1,JM,L) 1041. QPK = .TRUE. 1042. C**** 1043. C**** The parameter K indicates when DIAGCA is being called: 1044. C**** K=1 initialize current A.M., K.E., Mass, T.P.E., P.E., and Vapor 1045. C**** 4 after MSTCNV, CONDSE, PRECGI, PRECOL, PRECLI 1046. C**** 5 after RADIA 1047. C**** 6 after SURFCE, GLAICE, OLAKE, LAKICE, DRYCNV 1048. C**** 7 after ASDRAG 1049. C**** 2 after ADynam 1050. C**** 3 after AABFIL 1051. C**** 12 after DAILY 1052. C**** 1053. 90 GO TO (100,100,200,100,400,100,200,695,695,695,695,100),K 1054. C**** 1055. C**** Air Mass per unit area (kg/m**2) 1056. C**** 1057. 100 DO 110 J=2,JM-1 1058. AMASS(J) = 0. 1059. DO 110 I=1,IM 1060. 110 AMASS(J) = AMASS(J) + MSUM(I,J) 1061. AMASS(1) = MSUM(1, 1)*IM 1062. AMASS(JM)= MSUM(1,JM)*IM 1063. NI=NMSOFK(1) 1064. IF(K.le.1) GO TO 180 1065. NC=NMSOFK(K) 1066. DO 170 J=1,JM 1067. 170 CONSRV(J,NC) = CONSRV(J,NC) + (AMASS(J)-MSTRAT*IM-CONSRV(J,NI)) 1068. 180 DO 190 J=1,JM 1069. 190 CONSRV(J,NI) = AMASS(J)-MSTRAT*IM 1069.7 IF(K.eq.12) GO TO 695 1069.71 C**** 1069.72 C**** Water Vapor Mass (kg) 1069.73 C**** 1069.74 DO 610 J=1,JM 1069.75 IMAX=IM 1069.76 IF(J.eq.1 .or. J.eq.JM) IMAX=1 1069.77 VAPOR(J) = 0. 1069.78 DO 610 L=1,LMA 1069.79 DO 610 I=1,IMAX 1069.8 610 VAPOR(J) = VAPOR(J) + Q0M(I,J,L) 1069.81 VAPOR(1) = VAPOR( 1)*IM 1069.82 VAPOR(JM)= VAPOR(JM)*IM 1069.83 NI=NWVOFK(1) 1069.84 IF(K.le.1) GO TO 680 1069.85 NC=NWVOFK(K) 1069.86 DO 670 J=1,JM 1069.87 670 CONSRV(J,NC) = CONSRV(J,NC) + (VAPOR(J)-CONSRV(J,NI)) 1069.88 680 DO 690 J=1,JM 1069.89 690 CONSRV(J,NI) = VAPOR(J) 1070. IF(K.eq.4) GO TO 300 1071. C**** 1072. C**** Angular Momentum divided by radius and area (2*kg/s*m) 1073. C**** 1074. 200 NM = NMSOFK(1) 1075. DO 230 J=2,JM-1 1076. UMIL = 0. 1077. I=IM 1078. DO 210 L=1,LMA 1079. DO 210 IP1=1,IM 1080. UMIL = UMIL + UA(I,J,L)*(MA(I,J,L)+MA(IP1,J,L)) 1081. 210 I=IP1 1082. 230 AM(J) = UMIL*COSP(J) + 1083. * CONSRV(J,NM)*RADIUS*OMEGA*(COSV(J-1)*COSV(J-1)+COSV(J)*COSV(J)) 1084. DO 250 J=1,JM,JM-1 1085. UMIL = 0. 1086. DO 240 L=1,LMA 1087. 240 UMIL = UMIL + UA(1,J,L)*MA(1,J,L) 1088. 250 AM(J) = UMIL*COSP(J)*IM*2. + 1089. * CONSRV(J,NM)*RADIUS*OMEGA*(COSV(J-1)*COSV(J-1)+COSV(J)*COSV(J)) 1090. NI=NAMOFK(1) 1091. IF(K.le.1) GO TO 280 1092. NC=NAMOFK(K) 1093. DO 270 J=1,JM 1094. 270 CONSRV(J,NC) = CONSRV(J,NC) + (AM(J)-CONSRV(J,NI)) 1095. 280 DO 290 J=1,JM 1096. 290 CONSRV(J,NI) = AM(J) 1097. C**** 1098. C**** Kinetic Energy per unit area (4*J/m**2) 1099. C**** 1100. 300 DO 310 J=2,JM-1 1101. RKE(J) = 0. 1102. I=IM 1103. DO 310 L=1,LMA 1104. DO 310 IP1=1,IM 1105. RKE(J) = RKE(J) + ((MA(I,J,L)+MA(IP1,J,L))*UA(I,J,L)*UA(I,J,L) + 1106. * MA(I,J,L)*(VA(I,J-1,L)*VA(I,J-1,L) + VA(I,J,L)*VA(I,J,L))) 1107. 310 I=IP1 1108. RKE(1) = 0. 1109. RKE(JM)= 0. 1110. DO 340 L=1,LMA 1111. RKEIS = UA(1, 1,L)*UA(1, 1,L)*IM 1112. RKEIN = UA(1,JM,L)*UA(1,JM,L)*IM 1113. DO 330 I=1,IM 1114. RKEIS = RKEIS + VA(I, 1 ,L)*VA(I, 1 ,L) 1115. 330 RKEIN = RKEIN + VA(I,JM-1,L)*VA(I,JM-1,L) 1116. RKE(1) = RKE(1) + RKEIS*MA(1, 1,L) 1117. 340 RKE(JM)= RKE(JM)+ RKEIN*MA(1,JM,L) 1118. RKE(1) = 2.*RKE(1) 1119. RKE(JM)= 2.*RKE(JM) 1120. NI=NKEOFK(1) 1121. IF(K.le.1) GO TO 380 1122. NC=NKEOFK(K) 1123. DO 370 J=1,JM 1124. 370 CONSRV(J,NC) = CONSRV(J,NC) + (RKE(J)-CONSRV(J,NI)) 1125. 380 DO 390 J=1,JM 1126. 390 CONSRV(J,NI) = RKE(J) 1127. IF(K.eq.3 .or. K.eq.7) GO TO 695 1128. C**** 1129. C**** Total Potential Energy (J) 1130. C**** 1131. 400 DO 450 J=1,JM 1132. IMAX=IM 1133. IF(J.eq.1 .or. J.eq.JM) IMAX=1 1134. TPEIL = 0. 1135. DO 430 L=1,LMA 1136. DO 430 I=1,IMAX 1137. 430 TPEIL = TPEIL + (H0M(I,J,L)-.5*HZM(I,J,L))*PKDN(I,J,L) + 1137.1 * (H0M(I,J,L)+.5*HZM(I,J,L))*PKUP(I,J,L) 1138. SGEOI = 0. 1139. DO 440 I=1,IMAX 1140. 440 SGEOI = SGEOI + ZATMO(I,J)*MSUM(I,J) 1141. 450 TPE(J) = TPEIL*.5 + SGEOI*GRAV*DXYP(J) 1142. TPE(1) = TPE( 1)*IM 1143. TPE(JM)= TPE(JM)*IM 1143.5 C DO 460 J=1,JM 1143.6 C 460 TPE(J) = TPE(J) - AMASS(J)*SHCD*TKF 1143.7 C * + VAPOR(J)*(ELHE-(SHCV-SHCD)*TKF 1144. NI=NTEOFK(1) 1145. IF(K.le.1) GO TO 480 1146. NC=NTEOFK(K) 1147. DO 470 J=1,JM 1148. 470 CONSRV(J,NC) = CONSRV(J,NC) + (TPE(J)-CONSRV(J,NI)) 1149. 480 DO 490 J=1,JM 1150. 490 CONSRV(J,NI) = TPE(J) 1151. C**** 1152. C**** Potential Enthalpy (J) 1153. C**** 1154. DO 530 J=1,JM 1155. IMAX=IM 1156. IF(J.eq.1 .or. J.eq.JM) IMAX=1 1157. PE(J) = 0. 1158. DO 530 L=1,LMA 1159. DO 530 I=1,IMAX 1160. 530 PE(J) = PE(J) + H0M(I,J,L) 1161. PE(1) = PE( 1)*IM 1162. PE(JM)= PE(JM)*IM 1163. NI=NPEOFK(1) 1164. IF(K.le.1) GO TO 580 1165. NC=NPEOFK(K) 1166. DO 570 J=1,JM 1167. 570 CONSRV(J,NC) = CONSRV(J,NC) + (PE(J)-CONSRV(J,NI)) 1168. 580 DO 590 J=1,JM 1169. 590 CONSRV(J,NI) = PE(J) 1190. C**** 1191. 695 CALL TIMER1 (MDIAG) 1192. RETURN 1193. C**** 1194. C**** 1195. ENTRY DIAGCD (K,DT1) 1196. CALL TIMER0 1197. C**** 1198. C**** The parameter K indicates when DIAGCD is being called 1199. C**** K=1 after Advection in the Dynamics 1200. C**** 2 after Pressure Gradient Force in the Dynamics 1201. C**** 1202. C**** Change of Relative Angular Momentum divided by RADIUS 1203. C**** (2*kg*m/s) and U component of Kinetic Energy (kg*m**2/s**2) 1204. DO 720 J=2,JM-1 1205. DUMIL = 0. 1206. RKEIL = 0. 1207. DO 710 L=1,LMA 1208. DO 710 I=1,IM 1209. DUMIL = DUMIL + DUM(I,J,L) 1210. 710 RKEIL = RKEIL + DUM(I,J,L)*UA(I,J,L) 1211. CONSRV(J,K+ 1) = CONSRV(J,K+ 1) + DUMIL*COSP(J)*2. 1212. 720 CONSRV(J,K+10) = CONSRV(J,K+10) + RKEIL 1213. C**** Change of V component of Kinetic Energy (kg*m**2/s**2) 1214. DO 740 J=1,JM-1 1215. RKEIL = 0. 1216. DO 730 L=1,LMA 1217. DO 730 I=1,IM 1218. 730 RKEIL = RKEIL + DVM(I,J,L)*VA(I,J,L) 1219. CONSRV(J ,K+10) = CONSRV(J ,K+10) + RKEIL*RAMVN(J ) 1220. 740 CONSRV(J+1,K+10) = CONSRV(J+1,K+10) + RKEIL*RAMVS(J+1) 1221. IF(K.NE.1) GO TO 810 1222. C**** Change of Relative Angular Momentum divided by RADIUS 1223. C**** (2*kg*m/s) and Kinetic Energy (kg*m**2/s**2) at poles 1224. DO 770 J=1,JM,JM-1 1225. DUMIL = 0. 1226. RKEIL = 0. 1227. DO 760 L=1,LMA 1228. DUMI = 0. 1229. DO 750 I=1,IM 1230. 750 DUMI = DUMI + DUM(I,J,L) 1231. DUMIL = DUMIL + DUMI 1232. 760 RKEIL = RKEIL + DUMI*UA(1,J,L) 1233. CONSRV(J,K+ 1) = CONSRV(J,K+ 1) + DUMIL*COSP(J)*2. 1234. 770 CONSRV(J,K+10) = CONSRV(J,K+10) + RKEIL 1235. C**** Change of Angular Momentum (2*kg*m/s) by advection of mass 1236. DO 790 J=2,JM-1 1237. CONVIL = 0. 1238. DO 780 L=1,LMA 1239. DO 780 I=1,IM 1240. 780 CONVIL = CONVIL + CONV(I,J,L) 1241. 790 CONSRV(J,2) = CONSRV(J,2) + 1242. * CONVIL*DT1*RADIUS*OMEGA*(COSV(J-1)*COSV(J-1)+COSV(J)*COSV(J)) 1243. CONVLS = 0. 1244. CONVLN = 0. 1245. DO 800 L=1,LMA 1246. CONVLS = CONVLS + CONV (IM,1,L) 1247. 800 CONVLN = CONVLN + CONV (1,JM,L) 1248. CONSRV(1,2) = CONSRV(1,2) + 1249. * CONVLS*IM*DT1*RADIUS*OMEGA*COSV(1)*COSV(1) 1250. CONSRV(JM,2) = CONSRV(JM,2) + 1251. * CONVLN*IM*DT1*RADIUS*OMEGA*COSV(JM-1)*COSV(JM-1) 1252. C**** 1253. 810 CALL TIMER1 (MDIAG) 1254. RETURN 1255. END 2001. SUBROUTINE DIAGCG (K) 2002. C**** 2003. C**** DIAGCG accumulates the ground and glacial ice changes in 2004. C**** Mass and Energy caused by different physical processes. 2005. C**** 2006. INCLUDE 'C070.COM' 2007. PARAMETER (RHOW=1000.) 2009. INTEGER*4 NGMOFK(10),NGEOFK(10), NIMOFK(10),NIEOFK(10) 2010. REAL*8 GRMASS(JM),GRENRG(JM), GIMASS(JM),GIENRG(JM) 2011. C**** 2012. C**** GRNDCB WBG,WVG Water mass in bare ground, vegetation (m) 2013. C**** HBG,HVG Energy in bare ground, vegetation (J/m^2) 2014. C**** 2015. C**** GICECB MGI Mass of glacial ice of layer 1 (kg/m^2) 2016. C**** HGI Enthalpy minus latent heat of glacial ice (J/m^2) 2017. C**** 2018. DATA NGMOFK / 43, 1, 1, 44, 1, 45, 1, 1, 1, 1/, 2019. * NGEOFK / 47, 1, 1, 48, 1, 49, 1, 1, 1, 1/, 2020. * NIMOFK / 51, 1, 1, 52, 1, 53, 1, 1, 1, 1/, 2021. * NIEOFK / 55, 1, 1, 56, 1, 57, 1, 1, 1, 1/ 2022. C**** 2023. C**** The parameter K indicates when DIAGCG is being called: 2024. C**** K=1 initialize current Water Mass and Energy 2025. C**** 4 after PREGGI 2026. C**** 6 after SURFCE, GLAICE 2027. C**** 2028. CALL TIMER0 2029. C**** 2030. C**** Ground Water Mass per unit area (kg/m^2) 2031. C**** 2032. DO 110 J=2,JM-1 2033. GRMASS(J) = 0. 2034. GRENRG(J) = 0. 2035. DO 110 I=1,IM 2036. IF(FGRND(I,J).le.0.) GO TO 110 2037. FBARE = FVEG(I,J,1) +FVEG(I,J,10) 2038. WATRBG = WBG(I,J,1) + WBG(I,J,2) + WBG(I,J,3) + 2039. * WBG(I,J,4) + WBG(I,J,5) + WBG(I,J,6) 2040. WATRVG = WVG(I,J,0) + WVG(I,J,1) + WVG(I,J,2) + WVG(I,J,3) + 2041. * WVG(I,J,4) + WVG(I,J,5) + WVG(I,J,6) 2042. GRMASS(J) = GRMASS(J) + 2043. * FGRND(I,J)*(FBARE*WATRBG+(1.-FBARE)*WATRVG) 2044. GRENRG(J) = GRENRG(J) + 2045. * FGRND(I,J)*(FBARE*WATRBG+(1.-FBARE)*WATRVG)*ZATMO(I,J) 2046. 110 CONTINUE 2047. C GRMASS(1) = 0. 2048. C GRMASS(JM)= 0. 2049. NI=NGMOFK(1) 2050. IF(K.le.1) GO TO 180 2051. NC=NGMOFK(K) 2052. DO 170 J=2,JM-1 2053. 170 CONSRV(J,NC) = CONSRV(J,NC) + (GRMASS(J)-CONSRV(J,NI)) 2054. 180 DO 190 J=2,JM-1 2055. 190 CONSRV(J,NI) = GRMASS(J) 2056. C**** 2057. C**** Ground Energy per unit area (J/m^2) 2058. C**** 2059. DO 210 J=2,JM-1 2060. GRENRG(J) = GRAV*RHOW*GRENRG(J) 2061. DO 210 I=1,IM 2062. IF(FGRND(I,J).le.0.) GO TO 210 2063. FBARE = FVEG(I,J,1) +FVEG(I,J,10) 2064. HEATBG = HBG(I,J,1) + HBG(I,J,2) + HBG(I,J,3) + 2065. * HBG(I,J,4) + HBG(I,J,5) + HBG(I,J,6) 2066. HEATVG = HVG(I,J,0) + HVG(I,J,1) + HVG(I,J,2) + HVG(I,J,3) + 2067. * HVG(I,J,4) + HVG(I,J,5) + HVG(I,J,6) 2068. GRENRG(J) = GRENRG(J) + 2069. * FGRND(I,J)*(FBARE*HEATBG+(1.-FBARE)*HEATVG) 2070. 210 CONTINUE 2071. C GRENRG(1) = 0. 2072. C GRENRG(JM)= 0. 2073. NI=NGEOFK(1) 2074. IF(K.le.1) GO TO 280 2075. NC=NGEOFK(K) 2076. DO 270 J=2,JM-1 2077. 270 CONSRV(J,NC) = CONSRV(J,NC) + (GRENRG(J)-CONSRV(J,NI)) 2078. 280 DO 290 J=2,JM-1 2079. 290 CONSRV(J,NI) = GRENRG(J) 2080. C**** 2081. C**** Glacial Ice Mass per unit area (kg/m^2) 2082. C**** 2083. DO 310 J=2,JM-1 2084. GIMASS(J) = 0. 2085. GIENRG(J) = 0. 2086. DO 310 I=1,IM 2087. GIMASS(J) = GIMASS(J) + FGICE(I,J)*(MGI(I,J)+ACE2GI) 2088. 310 GIENRG(J) = GIENRG(J) + FGICE(I,J)*(MGI(I,J)+ACE2GI)*ZATMO(I,J) 2089. GIMASS(1) = IM*(MGI(1,1)+ACE2GI) 2090. GIENRG(1) = IM*(MGI(1,1)+ACE2GI)*ZATMO(1,1) 2091. GIMASS(JM)= 0. 2092. NI=NIMOFK(1) 2093. IF(K.le.1) GO TO 380 2094. NC=NIMOFK(K) 2095. DO 370 J=1,JM 2096. 370 CONSRV(J,NC) = CONSRV(J,NC) + (GIMASS(J)-CONSRV(J,NI)) 2097. 380 DO 390 J=1,JM 2098. 390 CONSRV(J,NI) = GIMASS(J) 2099. C**** 2100. C**** Glacial Ice Energy per unit area (J/m^2) 2101. C**** 2102. DO 410 J=2,JM-1 2103. GIENRG(J) = GIENRG(J)*GRAV 2104. DO 410 I=1,IM 2105. 410 GIENRG(J) = GIENRG(J) + FGICE(I,J)* 2105.1 * (HGI(I,J,1)+HGI(I,J,2)+HGI(I,J,3)+HGI(I,J,4)) 2106. GIENRG(1) = GIENRG(1)*GRAV + IM* 2106.1 * (HGI(1,1,1)+HGI(1,1,2)+HGI(1,1,3)+HGI(1,1,4)) 2107. GIENRG(JM)= 0. 2108. NI=NIEOFK(1) 2109. IF(K.le.1) GO TO 480 2110. NC=NIEOFK(K) 2111. DO 470 J=1,JM 2112. 470 CONSRV(J,NC) = CONSRV(J,NC) + (GIENRG(J)-CONSRV(J,NI)) 2113. 480 DO 490 J=1,JM 2114. 490 CONSRV(J,NI) = GIENRG(J) 2115. C**** 2116. CALL TIMER1 (MDIAG) 2117. RETURN 2118. END 2500. 2501. SUBROUTINE DIAGCL (K) 2502. C**** 2503. C**** DIAGCL accumulates the lake and lake ice changes in 2504. C**** Mass and Energy caused by different physical processes. 2505. C**** 2506. INCLUDE 'C070.COM' 2507. INTEGER*4 NLMOFK(12),NLEOFK(12) 2508. REAL*8 MASS(JM),ENRG(JM) 2508.1 DATA MASS(JM),ENRG(JM) /0.,0./ 2509. C**** 2510. C**** OCENCB MO Liquid lake mass above sill depth (kg) 2511. C**** G0M Liquid lake energy abve sill depth (J) 2511.1 C**** 2511.2 C**** SICECB RSI Ratio of lake ice to water 2511.3 C**** MSI Mass of lake ice (kg/m^2) 2511.4 C**** HSI Enthalpy minus latent energy of lake ice (J/m^2) 2512. C**** 2513. DATA NLMOFK / 59, 1, 1, 60, 1, 61, 1, 1, 62, 1, 1, 63/, 2514. * NLEOFK / 65, 1, 1, 66, 1, 67, 1, 1, 68, 1, 1, 69/ 2515. C**** 2516. C**** The parameter K indicates when DIAGCL is being called: 2517. C**** K=1 initialize current Water Mass and Energy 2518. C**** 4 after PRECOL, PREGLI 2519. C**** 6 after OLAKE, LAKICE 2520. C**** 9 after RIVERF 2521. C**** 12 after OCLIM 2522. C**** 2523. CALL TIMER0 2524. C**** 2525. C**** Lake Mass above the sill depth (kg) 2526. C**** 2527. DO 110 J=2,JM-1 2528. MASS(J) = 0. 2529. ENRG(J) = 0. 2530. DO 110 I=1,IM 2531. IF(FOCEAN(I,J).gt.0.) GO TO 110 2532. MASS(J) = MASS(J) + 2533. + (MO(I,J,1)+FWATER(I,J)*RSI(I,J)*(MSI(I,J,1)+MSI(I,J,2))*DXYP(J)) 2534. ENRG(J) = ENRG(J) + ZATMO(I,J)* 2535. * (MO(I,J,1)+FWATER(I,J)*RSI(I,J)*(MSI(I,J,1)+MSI(I,J,2))*DXYP(J)) 2536. 110 CONTINUE 2537. MASS(1) = IM* MO(1,1,1) 2539.5 ENRG(1) = MASS(1) *ZATMO(1,1) 2541. NI=NLMOFK(1) 2542. IF(K.le.1) GO TO 180 2543. NC=NLMOFK(K) 2544. DO 170 J=1,JM 2545. 170 CONSRV(J,NC) = CONSRV(J,NC) + (MASS(J)-CONSRV(J,NI)) 2546. 180 DO 190 J=1,JM 2547. 190 CONSRV(J,NI) = MASS(J) 2548. C**** 2549. C**** Lake Energy above the sill depth (J) 2550. C**** 2551. DO 210 J=2,JM-1 2552. ENRG(J) = ENRG(J)*GRAV 2553. DO 210 I=1,IM 2554. IF(FOCEAN(I,J).gt.0.) GO TO 210 2555. ENRG(J) = ENRG(J) + G0M(I,J,1) + FWATER(I,J)*RSI(I,J)*DXYP(J)* 2556. * (HSI(I,J,1)+HSI(I,J,2)+HSI(I,J,3)+HSI(I,J,4)) 2557. 210 CONTINUE 2558. ENRG(1) = ENRG(1)*GRAV + IM* G0M(1,1,1) 2561. NI=NLEOFK(1) 2562. IF(K.le.1) GO TO 280 2563. NC=NLEOFK(K) 2564. DO 270 J=1,JM 2565. 270 CONSRV(J,NC) = CONSRV(J,NC) + (ENRG(J)-CONSRV(J,NI)) 2566. 280 DO 290 J=1,JM 2567. 290 CONSRV(J,NI) = ENRG(J) 2568. C**** 2569. CALL TIMER1 (MDIAG) 2570. RETURN 2571. END 3000. 3001. SUBROUTINE DIAGCO (K) 3002. C**** 3003. C**** DIAGCO accumulates the ocean changes in Angular Momentum, 3004. C**** Kinetic Energy, Mass, Potential Enthalpy, and Salt 3005. C**** caused by different physical processes. 3006. C**** 3007. INCLUDE 'C070.COM' 3008. PARAMETER (OMEGA=TWOPI*366./(365.*SDAY)) 3009. INTEGER*4 NOMOFK(12),NAMOFK(12),NKEOFK(12),NOEOFK(12),NOSOFK(12) 3010. REAL*8 OMASS(JM),AM(JM),RKE(JM),OPE(JM),OSALT(JM) 3011. C**** 3012. DATA NOMOFK / 87, 88, 1, 89, 90, 91, 1, 1, 92, 1, 93, 1/, 3013. * NAMOFK / 71, 72, 73, 1, 74, 74, 75, 76, 1, 77, 74, 1/, 3014. * NKEOFK / 79, 80, 81, 1, 82, 82, 83, 84, 1, 85, 82, 1/, 3015. * NOEOFK / 95, 96, 1, 97, 98, 99, 1,100,101, 1,102, 1/, 3016. * NOSOFK /104,105, 1, 1,107,106, 1, 1, 1, 1,107, 1/ 3017. C**** 3018. C**** The parameter K indicates when DIAGCO is being called: 3019. C**** K=1 initialize current A.M., K.E., Mass, Energy, and Salt 3021. C**** 9 after RIVERF 3022. C**** 4 after PRECOO, PRECSI 3022.5 C**** 5 after SEAICE 3022.6 C**** 7 after OSTRES 3023. C**** 6 after OSOURC 3024. C**** 8 after OCONV 3026. C**** 10 after OBDRAG, OCOAST 3026.5 C**** 2 after ODynam, STrait 3026.6 C**** 3 after OABFIL 3027. C**** 11 after MELTSI, MELTIB 3028. C**** 3029. CALL TIMER0 3030. GO TO (100,100,200,100,100,100,200,200,100,200,100,100),K 3031. C**** 3032. C**** Ocean Mass per unit area (kg/m^2) 3033. C**** 3034. 100 DO 110 J=2,JM 3035. IMAX=IM 3036. IF(J.eq.JM) IMAX=1 3037. OMASS(J) = 0. 3038. DO 110 I=1,IMAX 3039. DO 110 L=1,LMM(I,J) 3040. 110 OMASS(J) = OMASS(J) + MO(I,J,L) 3041. OMASS(JM)= OMASS(JM)*IM 3042. NI=NOMOFK(1) 3043. IF(K.le.1) GO TO 180 3044. NC=NOMOFK(K) 3045. DO 170 J=2,JM 3046. 170 CONSRV(J,NC) = CONSRV(J,NC) + (OMASS(J)-CONSRV(J,NI)) 3047. 180 DO 190 J=2,JM 3048. 190 CONSRV(J,NI) = OMASS(J) 3049. IF(K.eq.4 .or. K.eq.9) GO TO 400 3050. C**** 3051. C**** Ocean Angular Momentum divided by radius and area (2*kg/s*m) 3052. C**** 3053. 200 NM = NOMOFK(1) 3054. DO 230 J=2,JM-1 3055. UMIL = 0. 3056. I=IM 3057. DO 220 IP1=1,IM 3058. DO 210 L=1,LMU(I,J) 3059. 210 UMIL = UMIL + UO(I,J,L)*(MO(I,J,L)+MO(IP1,J,L)) 3060. 220 I=IP1 3061. 230 AM(J) = UMIL*COSP(J) + 3062. * CONSRV(J,NM)*RADIUS*OMEGA*(COSV(J-1)*COSV(J-1)+COSV(J)*COSV(J)) 3063. UMIL = 0. 3064. DO 240 L=1,LMU(1,JM) 3065. 240 UMIL = UMIL + UO(1,JM,L)*MO(1,JM,L) 3066. AM(JM) = UMIL*COSP(JM)*IM*2. + 3067. * CONSRV(JM,NM)*RADIUS*OMEGA*COSV(JM-1)*COSV(JM-1) 3068. NI=NAMOFK(1) 3069. IF(K.le.1) GO TO 280 3070. NC=NAMOFK(K) 3071. DO 270 J=2,JM 3072. 270 CONSRV(J,NC) = CONSRV(J,NC) + (AM(J)-CONSRV(J,NI)) 3073. 280 DO 290 J=2,JM 3074. 290 CONSRV(J,NI) = AM(J) 3075. C**** 3076. C**** Ocean Kinetic Energy per unit area (4*J/m**2) 3077. C**** 3078. DO 320 J=2,JM-1 3079. RKE(J) = 0. 3080. I=IM 3081. DO 320 IP1=1,IM 3082. DO 310 L=1,LMM(I,J) 3083. 310 RKE(J) = RKE(J) + ((MO(I,J,L)+MO(IP1,J,L))*UO(I,J,L)*UO(I,J,L) + 3084. * MO(I,J,L)*(VO(I,J-1,L)*VO(I,J-1,L) + VO(I,J,L)*VO(I,J,L))) 3085. 320 I=IP1 3086. RKE(1) = 0. 3087. RKE(JM)= 0. 3088. DO 340 L=1,LMO 3089. RKEIN = UO(1,JM,L)*UO(1,JM,L)*IM 3090. DO 330 I=1,IM 3091. 330 RKEIN = RKEIN + VO(I,JM-1,L)*VO(I,JM-1,L) 3092. 340 RKE(JM)= RKE(JM)+ RKEIN*MO(1,JM,L) 3093. RKE(JM)= RKE(JM)*2. 3094. NI=NKEOFK(1) 3095. IF(K.le.1) GO TO 380 3096. NC=NKEOFK(K) 3097. DO 370 J=2,JM 3098. 370 CONSRV(J,NC) = CONSRV(J,NC) + (RKE(J)-CONSRV(J,NI)) 3099. 380 DO 390 J=2,JM 3100. 390 CONSRV(J,NI) = RKE(J) 3101. IF(K.eq.3 .or. K.eq.7 .or. K.eq.10) GO TO 600 3102. C**** 3103. C**** Ocean Potential Enthalpy (J) 3104. C**** 3105. 400 DO 410 J=2,JM 3106. IMAX=IM 3107. IF(J.eq.JM) IMAX=1 3108. OPE(J) = 0. 3109. DO 410 I=1,IMAX 3110. DO 410 L=1,LMM(I,J) 3111. 410 OPE(J) = OPE(J) + G0M(I,J,L)*FOCEAN(I,J) 3112. OPE(JM)= OPE(JM)*IM 3112.1 C DO 420 J=33,34 3112.2 C DO 420 L=1,LMM(47,J) 3112.3 C 420 OPE(J) = OPE(J) + MO(47,J,L)*ZATMO(47,J)*GRAV ! Caspian Sea 3113. NI=NOEOFK(1) 3114. IF(K.le.1) GO TO 480 3115. NC=NOEOFK(K) 3116. DO 470 J=2,JM 3117. 470 CONSRV(J,NC) = CONSRV(J,NC) + (OPE(J)-CONSRV(J,NI)) 3118. 480 DO 490 J=2,JM 3119. 490 CONSRV(J,NI) = OPE(J) 3120. IF(K.eq.4 .or. K.eq.8 .or. K.eq.9) GO TO 600 3120.1 IF(K.ge.5) GO TO 600 ! no salt in sea ice 3121. C**** 3122. C**** Ocean Salt (kg) 3123. C**** 3124. DO 510 J=2,JM 3125. IMAX=IM 3126. IF(J.eq.JM) IMAX=1 3127. OSALT(J) = 0. 3128. DO 510 I=1,IMAX 3129. DO 510 L=1,LMM(I,J) 3130. 510 OSALT(J) = OSALT(J) + S0M(I,J,L) 3131. OSALT(JM)= OSALT(JM)*IM 3132. NI=NOSOFK(1) 3133. IF(K.le.1) GO TO 580 3134. NC=NOSOFK(K) 3135. DO 570 J=2,JM 3136. 570 CONSRV(J,NC) = CONSRV(J,NC) + (OSALT(J)-CONSRV(J,NI)) 3137. 580 DO 590 J=2,JM 3138. 590 CONSRV(J,NI) = OSALT(J) 3139. C**** 3140. 600 CALL TIMER1 (MDIAG) 3141. RETURN 3142. END 3500. 3501. SUBROUTINE DIAGCI (K) 3502. C**** 3503. C**** DIAGCI accumulates Sea Ice and Ice Berg changes in Ice Mass and 3504. C**** Energy caused by different physical processes. 3505. C**** 3506. INCLUDE 'C070.COM' 3507. INTEGER*4 NIMOFK(12),NIEOFK(12), NBMOFK(12),NBEOFK(12) 3507.1 LOGICAL*4 QSHELF 3508. REAL*8 SIMASS(JM),SIENRG(JM), BIMASS(JM),BIENRG(JM) 3508.5 COMMON /RIVRCB/ RATE(IM,JM), IFLOW(IM,JM),JFLOW(IM,JM), 3508.6 * KDIREC(IM,JM), QSHELF(IM,JM) 3509. C**** 3510. DATA NIMOFK /109,110, 1,111,112,113, 1, 1,114, 1,115, 1/, 3511. * NIEOFK /117,118, 1,119,120,121, 1, 1,122, 1,123, 1/, 3511.5 * NBMOFK /125,126, 1, 1, 1,127, 1, 1,128, 1,129, 1/, 3511.6 * NBEOFK /131,132, 1, 1, 1,133, 1, 1,134, 1,135, 1/ 3512. C**** 3513. C**** The parameter K indicates when DIAGCI is being called: 3514. C**** K=1 initialize current Mass, Energy, and Salt 3515. C**** 2 after ADVSI, STADVI, MOVEIB 3516. C**** 4 after PRECSI 3517. C**** 5 after SEAICE 3518. C**** 6 after OSOURC, CREAIB 3518.5 C**** 9 after CALVEI 3519. C**** 11 after MELTSI, MELTIB 3520. C**** 3521. CALL TIMER0 3522. C**** 3523. C**** Sea Ice Mass per unit area (kg/m^2) 3524. C**** 3525. DO 110 J=2,JM-1 3526. SIMASS(J) = 0. 3527. DO 110 I=1,IM 3528. 110 SIMASS(J) = SIMASS(J)+(MSI(I,J,1)+MSI(I,J,2))*RSI(I,J)*FOCEAN(I,J) 3529. SIMASS(JM)= (MSI(1,JM,1)+MSI(1,JM,2))*RSI(1,JM)*IM 3530. NI=NIMOFK(1) 3531. IF(K.le.1) GO TO 180 3532. NC=NIMOFK(K) 3533. DO 170 J=2,JM 3534. 170 CONSRV(J,NC) = CONSRV(J,NC) + (SIMASS(J)-CONSRV(J,NI)) 3535. 180 DO 190 J=2,JM 3536. 190 CONSRV(J,NI) = SIMASS(J) 3537. C**** 3538. C**** Sea Ice Energy per unit area (J/m^2) 3539. C**** 3540. DO 210 J=2,JM-1 3541. SIENRG(J) = 0. 3542. DO 210 I=1,IM 3543. 210 SIENRG(J) = SIENRG(J) + FOCEAN(I,J)*RSI(I,J)* 3543.1 * (HSI(I,J,1)+HSI(I,J,2)+HSI(I,J,3)+HSI(I,J,4)) 3544. SIENRG(JM)= IM*RSI(1,JM)* 3544.1 * (HSI(1,JM,1)+HSI(1,JM,2)+HSI(1,JM,3)+HSI(1,JM,4)) 3545. NI=NIEOFK(1) 3546. IF(K.le.1) GO TO 280 3547. NC=NIEOFK(K) 3548. DO 270 J=2,JM 3549. 270 CONSRV(J,NC) = CONSRV(J,NC) + (SIENRG(J)-CONSRV(J,NI)) 3550. 280 DO 290 J=2,JM 3551. 290 CONSRV(J,NI) = SIENRG(J) 3552. IF(K.eq.4 .or. K.eq.5) GO TO 400 3553. C**** 3554. C**** Ice Berg Mass (kg) and Ice Berg Energy 3555. C**** 3556. DO 310 J=2,JM 3557. BIMASS(J) = 0. 3558. 310 BIENRG(J) = 0. 3558.1 C**** Ice mass and energy calved directly from grounded ice 3558.2 DO 320 J=JM/12,JM/6+1 ! southern oceans only 3558.3 DO 320 I=1,IM 3558.4 IF(FOCEAN(I,J).le.0. .or. QSHELF(I,J) .or. MGI(I,J).le.0.) 3558.5 * GO TO 320 3558.6 BIMASS(J) = BIMASS(J) + MGI(I,J) 3558.7 BIENRG(J) = BIENRG(J) + HGI(I,J,1) 3558.8 320 continue 3558.9 C**** Moving ice berg mass and energy 3559. DO 330 N=1,NBERG 3560. J = BERGJ(N) + 1. 3561. BIMASS(J) = BIMASS(J) + BERGM(N) 3562. 330 BIENRG(J) = BIENRG(J) + BERGH(N) 3563. NIM=NBMOFK(1) 3564. NIE=NBEOFK(1) 3565. IF(K.le.1) GO TO 380 3566. NCM=NBMOFK(K) 3567. NCE=NBEOFK(K) 3568. DO 370 J=2,JM 3569. CONSRV(J,NCM) = CONSRV(J,NCM) + (BIMASS(J)-CONSRV(J,NIM)) 3570. 370 CONSRV(J,NCE) = CONSRV(J,NCE) + (BIENRG(J)-CONSRV(J,NIE)) 3571. 380 DO 390 J=2,JM 3572. CONSRV(J,NIM) = BIMASS(J) 3573. 390 CONSRV(J,NIE) = BIENRG(J) 3574. C**** 3575. 400 CALL TIMER1 (MDIAG) 3576. RETURN 3577. END 4000. 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),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 20 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) 4030. DO 30 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. 30 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) = 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) = CONSRV(J,N) 4118. C**** Calculate hemispheric sums 4119. FLAT( 0) =0. 4120. FLAT(-1) =0. 4121. DO 130 JSH=1,JEQ 4122. JNH = 1+JM-JSH 4123. FLAT( 0) = FLAT( 0) + FLAT(JSH) 4124. 130 FLAT(-1) = FLAT(-1) + FLAT(JNH) 4125. FLAT(-2) = FLAT(-1) + FLAT(0) 4126. C**** Scale quantities and divide by area 4127. DO 140 J=-2,JM 4128. 140 FLAT(J) = FLAT(J)*SCALE(N)/AREATO(J) 4129. C**** Print properly scaled quantity 4130. 150 WRITE (6,917) TITLE(N),(FLAT(J) ,J=-2,0), 4131. * (NINT(FLAT(J)),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) = CONSRV(J,N)*DXYP(J) 4161. C**** Calculate hemispheric sums 4162. FLAT( 0) =0. 4163. FLAT(-1) =0. 4164. DO 230 JSH=1,JEQ 4165. JNH = 1+JM-JSH 4166. FLAT( 0) = FLAT( 0) + FLAT(JSH) 4167. 230 FLAT(-1) = FLAT(-1) + FLAT(JNH) 4168. FLAT(-2) = FLAT(-1) + FLAT(0) 4169. C**** Scale quantities and divide by area 4170. DO 240 J=-2,JM 4171. 240 FLAT(J) = FLAT(J)*SCALE(N)/(AREAGR(J)+1.D-20) 4172. C**** Print properly scaled quantity 4173. 250 WRITE (6,917) TITLE(N),(FLAT(J) ,J=-2,0), 4174. * (NINT(FLAT(J)),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) = CONSRV(J,N)*DXYP(J) 4200. C**** Calculate hemispheric sums 4201. FLAT( 0) =0. 4202. FLAT(-1) =0. 4203. DO 330 JSH=1,JEQ 4204. JNH = 1+JM-JSH 4205. FLAT( 0) = FLAT( 0) + FLAT(JSH) 4206. 330 FLAT(-1) = FLAT(-1) + FLAT(JNH) 4207. FLAT(-2) = FLAT(-1) + FLAT(0) 4208. C**** Scale quantities and divide by area 4209. DO 340 J=-2,JM 4210. 340 FLAT(J) = FLAT(J)*SCALE(N)/(AREAGI(J)+1.D-20) 4211. C**** Print properly scaled quantity 4212. 350 WRITE (6,917) TITLE(N),(FLAT(J) ,J=-2,0), 4213. * (NINT(FLAT(J)),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) = CONSRV(J,N) 4243. C**** Calculate hemispheric sums 4244. FLAT( 0) =0. 4245. FLAT(-1) =0. 4246. DO 430 JSH=1,JEQ 4247. JNH = 1+JM-JSH 4248. FLAT( 0) = FLAT( 0) + FLAT(JSH) 4249. 430 FLAT(-1) = FLAT(-1) + FLAT(JNH) 4250. FLAT(-2) = FLAT(-1) + FLAT(0) 4251. C**** Scale quantities and divide by area 4252. DO 440 J=-2,JM 4253. 440 FLAT(J) = FLAT(J)*SCALE(N)/(AREALA(J)+1.d-20) 4254. C**** Print properly scaled quantity 4255. 450 WRITE (6,917) TITLE(N),(FLAT(J) ,J=-2,0), 4256. * (NINT(FLAT(J)),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) = CONSRV(J,N)*DXYP(J) 4325. 520 IF(N.ge.95) FLAT(J) = CONSRV(J,N) 4326. C**** Calculate hemispheric sums 4327. FLAT( 0) =0. 4328. FLAT(-1) =0. 4329. DO 530 JSH=1,JEQ 4330. JNH = 1+JM-JSH 4331. FLAT( 0) = FLAT( 0) + FLAT(JSH) 4332. 530 FLAT(-1) = FLAT(-1) + FLAT(JNH) 4333. FLAT(-2) = FLAT(-1) + FLAT(0) 4334. C**** Scale quantities and divide by area 4335. DO 540 J=-2,JM 4336. 540 FLAT(J) = FLAT(J)*SCALE(N)/(AREAOC(J)+1.d-20) 4337. C**** Print properly scaled quantity 4338. 550 WRITE (6,917) TITLE(N),(FLAT(J) ,J=-2,0), 4339. * (NINT(FLAT(J)),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) = CONSRV(J,N)*DXYP(J) 4376. C**** Calculate hemispheric sums 4377. FLAT( 0) =0. 4378. FLAT(-1) =0. 4379. DO 630 JSH=1,JEQ 4380. JNH = 1+JM-JSH 4381. FLAT( 0) = FLAT( 0) + FLAT(JSH) 4382. 630 FLAT(-1) = FLAT(-1) + FLAT(JNH) 4383. FLAT(-2) = FLAT(-1) + FLAT(0) 4384. C**** Scale quantities and divide by area 4385. DO 640 J=-2,JM 4386. 640 FLAT(J) = FLAT(J)*SCALE(N)/(AREAOC(J)+1.d-20) 4387. C**** Print properly scaled quantity 4388. 650 WRITE (6,917) TITLE(N),(FLAT(J) ,J=-2,0), 4389. * (NINT(FLAT(J)),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) = CONSRV(J,N) 4418. C**** Calculate hemispheric sums 4419. FLAT( 0) =0. 4420. FLAT(-1) =0. 4421. DO 730 JSH=1,JEQ 4422. JNH = 1+JM-JSH 4423. FLAT( 0) = FLAT( 0) + FLAT(JSH) 4424. 730 FLAT(-1) = FLAT(-1) + FLAT(JNH) 4425. FLAT(-2) = FLAT(-1) + FLAT(0) 4426. C**** Scale quantities and divide by area 4427. DO 740 J=-2,JM 4428. 740 FLAT(J) = FLAT(J)*SCALE(N)/(AREAOC(J)+1.d-20) 4429. C**** Print properly scaled quantity 4430. 750 WRITE (6,917) TITLE(N),(FLAT(J) ,J=-2,0), 4431. * (NINT(FLAT(J)),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) ', 4520.5 C 10 4521. O '0Instantan KE (10^3 J/m^2) ', ! Kinetic Energy 4523. 1 ' Change of KE by ADVEC + CORIOL ', 4524. 2 ' Change of KE by PRESSURE GRAD ', 4525. 3 ' Change of KE by DYNAMICS ', 4526. 4 ' Change of KE by BINOMIAL FILTER', 4527. 5 ' Change of KE by MOIST CONVEC ', 4528. 6 ' Change of KE by SURF + DRY CONV', 4529. 7 ' Change of KE by STRATOS DRAG ', 4530. 8 ' Change of KE by DAILY ', 4531. 9 ' Sum KE changes (10^-3 W/m^2) ', 4531.5 C 20 4532. O '0Instantan MASS (kg/m^2) ', ! Mass 4534. 1 ' Change of MASS by DYNAMICS ', 4535. 2 ' Change of MASS by CONDENSATION ', 4536. 3 ' Change of MASS by SURF EVAPORA ', 4537. 4 ' Change of MASS by DAILY ', 4538. 5 ' Sum changes (10^-8 kg/s*m^2) ', 4538.5 C 26 4539. 6 '0Instantan SE (10^5 J/m^2) ', ! Static Energy 4540. 7 ' Change of SE by DYNAMICS ', 4541. 8 ' Change of SE by CONDENSATION ', 4542. 9 ' Change of SE by RADIATION ', 4543. O ' Change of SE by SURFACE INTER ', 4544. C 31 4545. 1 ' Sum SE changes (10^-2 W/m^2) ', 4546. 2 '0Instantan PE (10^5 J/m^2) ', ! Potential Enthalpy 4547. 3 ' Change of PE by DYNAMICS ', 4548. 4 ' Change of PE by CONDENSATION ', 4549. 5 ' Change of PE by RADIATION ', 4550. 6 ' Change of PE by SURFACE INTER ', 4551. 7 ' Sum PE changes (10^-2 W/m^2) ', 4551.5 C 38 4552. 8 '0Instantan VAPOR (10^-2 kg/m^2) ', ! Water Vapor Mass 4553. 9 ' Change of VAPOR by DYNAMICS ', 4554. O ' Change of VAPOR by CONDENSATION', 4556. 1 ' Change of VAPOR by SURF EVAPORA', 4557. 2 ' Sum changes (10^-8 KG/S*M^2) '/ 4557.5 DATA TITLEL / ! Ground: 4558. 3 '0Instantan WATER (10^-2 kg/m^2) ', ! Water Mass 4559. 4 ' Change of WATER by PRECIPITATN ', 4560. 5 ' Change of WATER by SURF EVAPORA', 4561. 6 ' Sum changes (10^-8 kg/s*m^2) ', 4562. 7 '0Instantan ENERGY (10^5 J/m^2) ', ! Energy 4563. 8 ' Change of ENERGY by PRECIPITATN', 4564. 9 ' Change of ENERGY by SURF FLUXES', 4565. O ' Sum ENRG change (10^-2 W/m^2) ', 4566. C 51 ! Glacial Ice: 4567. 1 '0Instantan WATER (10^-2 kg/m^2) ', ! Water Mass 4568. 2 ' Change of WATER by PRECIPITATN ', 4569. 3 ' Change of WATER by SURF EVAPORA', 4570. 4 ' Sum changes (10^-8 kg/s*m^2) ', 4571. 5 '0Instantan ENERGY (10^5 J/m^2) ', ! Energy 4572. 6 ' Change of ENERGY by PRECIPITATN', 4573. 7 ' Change of ENERGY by SURF FLUXES', 4574. 8 ' Sum ENRG change (10^-2 W/m^2) ', 4574.5 C 59 ! Lakes and Rivers: 4575. 9 '0Instantan WATER (10^-2 kg/m^2) ', ! Water Mass 4576. O ' Change of WATER by PRECIPITATN ', 4578. 1 ' Change of WATER by SURF EVAPORA', 4579. 2 ' Change of WATER by RIVER FLOW ', 4580. 3 ' Change of WATER by OCLIM ', 4581. 4 ' Sum changes (10^-8 kg/s*m^2) ', 4582. 5 '0Instantan ENERGY (10^5 J/m^2) ', ! Energy 4583. 6 ' Change of ENERGY by PRECIPITATN', 4584. 7 ' Change of ENERGY by SURF FLUXES', 4585. 8 ' Change of ENERGY by RIVER FLOW ', 4586. 9 ' Change of ENERGY by OCLIM ', 4587. O ' Sum ENRG change (10^-2 W/m^2) '/ 4588. DATA TITLEO / ! Ocean: 4589. 1 '0Instantan AM (10^12 J*s/m^2) ', ! Angular Momentum 4590. 2 ' Change of AM by DYNAMICS + STRA', 4591. 3 ' Change of AM by BINOMIAL FILTER', 4591.5 4 ' Change of AM by WATER EXCHANGE ', 4592. 5 ' Change of AM by OSTRES ', 4593. 6 ' Change of AM by CONVEC + MIXING', 4594. 7 ' Change of AM by BOTTM+SIDE DRAG', 4595. 8 ' Sum AM changes (10^2 J/m^2) ', 4595.5 C 79 4596. 9 '0Instantan KE (J/m^2) ', ! Kinetic Energy 4597. O ' Change of KE by DYNAMICS + STRA', 4598. 1 ' Change of KE by BINOMIAL FILTER', 4598.5 2 ' Change of KE by WATER EXCHANGE ', 4600. 3 ' Change of KE by OSTRES ', 4601. 4 ' Chnage of KE by CONVEC + MIXING', 4602. 5 ' Change of KE by BOTTM+SIDE DRAG', 4603. 6 ' Sum KE changes (10^-6 W/m^2) ', 4603.5 C 87 4604. 7 '0Instantan MASS (10^2 kg/m^2) ', ! Mass 4605. 8 ' Change of MASS by DYNAM + STRAI', 4606. 9 ' Change of MASS by PRECIPITATION', 4607. O ' Change of MASS by SEAICE RUNOFF', 4608. 1 ' Change of MASS by OSOURC ', 4609. 2 ' Change of MASS by RIVER FLOW ', 4611. 3 ' Change of MASS by SEA ICE MELT ', 4612. 4 ' Sum changes (10^-8 kg/s*m^2) ', 4612.5 C 95 4613. 5 '0Instantan PE (10^6 J/M^2) ', ! Potential Enthalpy 4614. 6 ' Change of PE by DYNAM + STRAITS', 4615. 7 ' Change of PE by PRECIPITATION ', 4616. 8 ' Change of PE by SEAICE RUNOFF ', 4617. 9 ' Change of PE by OSOURC ', 4618. O ' Change of PE by CONVEV + MIXING', 4619. 1 ' Change of PE by RIVER FLOW ', 4620. 2 ' Change of PE by SEA ICE MELT ', 4622. 3 ' Sum PE changes (10^-2 W/m^2) ', 4622.5 C 104 4623. 4 '0Instantan SALT (10^1 kg/m^2) ', ! Salt 4624. 5 ' Change of SALT by DYNAM + STRAI', 4625. 6 ' Change of SALT by OSOURC ', 4626. 7 ' Change of SALT by SEA ICE MELT ', 4627. 8 ' Sum changes (10^-8 kg/s*m^2) ', 4627.5 C 109 ! Sea Ice: 4628. 9 ' Instantan MASS (10^-2 kg/m^2) ', ! Ice Mass 4629. O ' Change of MASS by ADVEC + STRAI', 4630. 1 ' Change of MASS by PRECIPITATION', 4631. 2 ' Change of MASS by SEAICE EVAP ', 4633. 3 ' Change of MASS by OSOURC FREEZE', 4633.5 4 ' Change of MASS by CALVING ', 4634. 5 ' Change of MASS by SEA ICE MELT ', 4635. 6 ' Sum changes (10^-8 kg/s*m^2) ', 4635.5 C 117 4636. 7 '0Instantan ENRG (10^5 J/m^2) ', ! Energy 4637. 8 ' Change of ENRG by ADVEC + STRAI', 4638. 9 ' Change of ENRG by PRECIPITATION', 4639. O ' Change of ENRG by SEAICE FLUXES', 4640. 1 ' Change of ENRG by OSOURC FREEZE', 4640.5 2 ' Change of ENRG by CALVING ', 4641. 3 ' Change of ENRG by SEA ICE MELT ', 4642. 4 ' Sum ENRG change (10^-2 W/m^2) ', 4643. C 125 ! Ice Bergs 4644. 5 ' Instantan MASS (10^-4 kg/m^2) ', ! Ice Berg Mass 4645. 6 ' Change of MASS by TRANSPORT ', 4646. 7 ' Change of MASS by CREATION ', 4646.5 8 ' Change of MASS by CALVING ', 4647. 9 ' Change of MASS by MELTING ', 4648. O ' Sum changes (10^-8 kg/s*m^2) ', 4648.5 C 131 4649. 1 '0Instantan ENRG (10^3 J/m^2) ', ! Energy 4650. 2 ' Change of ENRG by TRANSPORT ', 4651. 3 ' Change of ENRG by CREATION ', 4651.5 4 ' Change of ENRG by CALVING ', 4652. 5 ' Change of ENRG by MELTING ', 4653. 6 ' Sum ENRG change (10^-2 W/m^2) ', 4654. 7 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 (LMTER=9,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,LMTER),SCALE(72),FLAT(JM),FHEM(2) 5091. CHARACTER*16 TERAIN(9), TITLE(KAJ),TITLEA(10) 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. O '0NET RAD AT P0 ', ' NET RAD AT P1 ', ' NET RAD AT Z0 ', 5102. 3 '0SENSBL HEAT FLX', ' EVAPOR HEAT FLX', ' CONDUC ICE/OCEN', 5103. 6 ' TG3 ', ' TG2 ', ' TG1 ', 5104. 9 '0EVAPOR (MM/DAY)', ' PRECIP (MM/DAY)', ' GEOPOT ENRG FLX', 5105. 2 ' GEOPOT ENRG FLX', ' T SURF (.1 C) ', ' SUM PR ENRG FLX', 5106. 5 ' RIVER FLOW ENRG', '0SP HUM LAY 1 UP', ' SP HUM LAY 1 DN', 5107. 8 ' SP HUM SURF*1E4', ' SAT SP HUM GRND', ' OCEAN ICE COVER', 5107.5 C 31 5108. 1 '0SNOW COVER (%) ', ' NET RAD ABS ATM', ' RUN PREC to LAK', 5109. 4 ' RUN SURF to LAK', ' CROSS ISO ANGLE', '0PUSH ICE DOWN ', 5110. 7 '0DRAW ICE UP ', ' RUN DEEP to LAK', '0PRECIP HEAT FLX', 5111. O ' SUM SURF FLUXES', ' ERUN PREC to LK', '0ERUN SURF to LK', 5112. 3 '0PT AIR LAY 1 UP', ' PT AIR LAY 1 DN', '0PUSH ICE ERG DN', 5113. 6 '0DRAW ICE ERG UP', ' ERUN DEEP to LK', '0SURF WIND SP*10', 5114. 9 ' WATER of CANOPY', ' WATER in G1 ', ' WATER in G2 ', 5115. 2 ' TG4 ', ' SNOW DEP(kg/m2)', ' RIVER FLOW MASS', 5116. 5 ' LW WINDOW B TEM', '*SR Abs Z0 to P1', '*CldTopP*CldCov ', 5117. 8 ' CLD TOP PRS(mb)', '*CldTopT*CldCov ', ' CLD TOP TEM (K)', 5117.5 C 61 5118. 1 '0SS PRECIP ', ' MC PRECIP ', '0VAPOR IN ATMOS ', 5119. 4 ' SPEC VOL * 100 ', ' RICH NUM * 100 ', ' DRAG COEF * 1E4', 5120. 7 ' LW INC ON Z0 ', '0OPT DEPTH (.1) ', ' TOTAL CLOUD COV', 5121. O '*TR Abs Z0 to P0', '*TR Abs Z0 to Z1', '*PLAN ALB VISUAL', 5121.1 3 '*PLAN ALB NEARIR', '*SURF ALB VISUAL', '*SURF ALB NEARIR', 5121.2 6 '*ATMO ALB VISUAL', '*ATMO ALB NEARIR', '*ATMO ABS VISUAL', 5121.3 9 '*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. O ' 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. 6 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. 1 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. 6 5*100., 100.,4*1., 5*1., 5*1., 5*1., 5140. 1 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 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 5276.5 IF(WLAT.le.0) QLAT = 0 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) 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. 1 360,360,360,360,350, 360,360,360,350,350, 5291. 2 350,340,360,350,350, 360,360,360,360,370, 5292. 3 370,360,350,350,360, 350,350,350,350,360, 5293. 4 350,350,360,360,350, 350,350,360,360,360, 5294. 5 360,360,360,350,360, 999,999,360,999,360, 5295. 6 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) 5321.5 IF(WLAT.le.0) QLAT = 0 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 7000. 7001. BLOCK DATA DIURBD 7002. C**** 7003. C**** Titles for subroutine DIAGD 7004. C**** 7005. CHARACTER*8 TITLE 7006. COMMON /DDAYCB/ TITLE(50) 7007. DATA TITLE/ 7008. * '0INC SW ',' P ALBD ',' G ALBD ',' ABS ATM',' E CNDS ', 7009. * '0SRF PRS',' PT 5 ',' PT 4 ',' PT 3 ',' PT 2 ', 7010. * ' PT 1 ',' TS ',' TG1 ','0Q 5 ',' Q 4 ', 7011. * ' Q 3 ',' Q 2 ',' Q 1 ',' QS ',' QG ', 7012. * '0CLD 6 ',' CLD 5 ',' CLD 4 ',' CLD 3 ',' CLD 2 ', 7013. * ' CLD 1 ',' COVER ','0SW ON G',' LW AT G',' SNSB HT', 7014. * ' LAT HT ',' HEAT Z0','0UG*10 ',' VG*10 ',' WG*10 ', 7015. * ' US*10 ',' VS*10 ',' WS*10 ',' ALPHA0 ','0RIS1*E2', 7016. * ' RIGS*E2',' CDM*E4 ',' CDH*E4 ',' DGS*10 ',' EDS1*10', 7017. * '0PPBL ',' DC FREQ',' LDC*10 ','0PRC*10 ',' EVP*10 '/ 7018. END 7100. 7101. SUBROUTINE DIAGD 7102. C**** 7103. C**** DIAGD prints the Diurnal cycle of several quantities 7104. C**** 7105. INCLUDE 'C070.COM' 7106. INTEGER*4 NDIURN(0:24) 7106.5 REAL*8 SCALE(50),DIURN(0:24) 7107. CHARACTER*8 TITLE 7108. COMMON /DDAYCB/ TITLE(50) 7109. DATA SCALE/1.,2*100.,2*1., .01,4*1., 3*1.,2*1.E5, 5*1.E5, 7110. * 5*100., 2*100.,3*1., 2*1.,3*10., 3*10.,1.,100., 7111. * 100.,2*1.E4,2*10., .01,100.,10.,2*1./ 7112. C**** 7114. DTSURF = DTS/NSURF 7115. TIMDIF = IDACC(1)*DTS/SDAY 7116. IF(TIMDIF.LT.1.) RETURN 7118. SCALE( 5) = 1./DTS 7119. SCALE(28) = 1./DTSURF 7120. SCALE(29) = 1./DTSURF 7121. SCALE(30) = 1./DTSURF 7122. SCALE(31) = 1./DTSURF 7123. SCALE(32) = 1./DTSURF 7124. SCALE(39) = 360./TWOPI 7125. SCALE(49) = 1.E2*NDAY 7126. SCALE(50) = 1.E2*SDAY/DTSURF 7127. C**** 7128. DO 90 KR=1,4 7128.5 I=IJDD(1,KR) 7129. J=IJDD(2,KR) 7130. WRITE (6,901) LABEL(1:100),JYEAR0,JMON0,JDATE0,JYEAR,JMON,JDATE 7132. WRITE (6,902) NAMDD(KR),IJDD(1,KR),J,(IH,IH=0,23) 7133. SCALE( 7) = IDACC(1)/(DXYP(J)*AIJL(I,J,5,1)*SHCD) 7134. SCALE( 8) = IDACC(1)/(DXYP(J)*AIJL(I,J,4,1)*SHCD) 7135. SCALE( 9) = IDACC(1)/(DXYP(J)*AIJL(I,J,3,1)*SHCD) 7136. SCALE(10) = IDACC(1)/(DXYP(J)*AIJL(I,J,2,1)*SHCD) 7137. SCALE(11) = IDACC(1)/(DXYP(J)*AIJL(I,J,1,1)*SHCD) 7138. SCALE(14) = 1.E5*IDACC(1)/(DXYP(J)*AIJL(I,J,5,1)) 7139. SCALE(15) = 1.E5*IDACC(1)/(DXYP(J)*AIJL(I,J,4,1)) 7140. SCALE(16) = 1.E5*IDACC(1)/(DXYP(J)*AIJL(I,J,3,1)) 7141. SCALE(17) = 1.E5*IDACC(1)/(DXYP(J)*AIJL(I,J,2,1)) 7142. SCALE(18) = 1.E5*IDACC(1)/(DXYP(J)*AIJL(I,J,1,1)) 7143. DO 90 KQ=1,50 7144. IF(KQ.eq.48) GO TO 20 7145. C**** Normal quantities 7146. AVE = 0. 7147. DO 10 IH=0,23 7148. AVE = AVE + ADAILY(IH,KQ,KR) 7149. 10 DIURN(IH) = ADAILY(IH,KQ,KR)*SCALE(KQ)*24./IDACC(1) 7150. DIURN(24) = AVE*SCALE(KQ)/IDACC(1) 7151. GO TO 50 7152. C**** Ratio of two quantities 7153. 20 AVEN = 0. 7154. AVED = 0. 7155. DO 30 IH=0,23 7156. AVEN = AVEN + ADAILY(IH,KQ,KR) 7157. AVED = AVED + ADAILY(IH,KQ-1,KR) 7158. 30 DIURN(IH) = ADAILY(IH,KQ,KR)*SCALE(KQ)/(ADAILY(IH,KQ-1,KR)+1.d-20) 7159. DIURN(24) = AVEN*SCALE(KQ)/(AVED+1.d-20) 7160. C**** 7161. 50 DO 60 IS=0,24 7162. 60 NDIURN(IS) = NINT(DIURN(IS)) 7163. 90 WRITE (6,909) TITLE(KQ),NDIURN 7164. RETURN 7165. C**** 7166. 901 FORMAT ('1',A100,I8,A5,I2,' to',I6,A5,I2) 7167. 902 FORMAT ('0',A4,I2,',',I2,' ',I2,23I5,' AVE') 7168. 909 FORMAT (A8,25I5) 7169. END