module_ra_gfdleta.F
References to this file elsewhere.
1 !WRF:MODEL_RA:RADIATION
2 !
3 #define FERRIER_GFDL
4 MODULE MODULE_RA_GFDLETA
5 USE MODULE_CONFIGURE,ONLY : GRID_CONFIG_REC_TYPE
6 USE MODULE_MODEL_CONSTANTS
7 #ifdef FERRIER_GFDL
8 USE MODULE_MP_ETANEW, ONLY : &
9 & RHgrd,T_ICE,FPVS,QAUT0,XMImax,XMIexp,MDImin,MDImax,MASSI, &
10 & FLARGE1,FLARGE2,NLImin,NLImax
11 #endif
12 INTEGER,PARAMETER :: NL=81
13 INTEGER,PARAMETER :: NBLY=15
14 REAL,PARAMETER :: RTHRESH=1.E-15,RTD=1./DEGRAD
15
16 INTEGER, SAVE, DIMENSION(3) :: LTOP
17 REAL , SAVE, DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4
18 REAL , SAVE, DIMENSION(NL) :: PRGFDL
19 REAL , SAVE :: AB15WD,SKO2D,SKC1R,SKO3R
20
21 REAL , SAVE :: EM1(28,180),EM1WDE(28,180),TABLE1(28,180), &
22 TABLE2(28,180),TABLE3(28,180),EM3(28,180), &
23 SOURCE(28,NBLY), DSRCE(28,NBLY)
24
25 REAL ,SAVE, DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW,EM3V
26 REAL ,SAVE :: R1,RSIN1,RCOS1,RCOS2
27 ! Created by CO2 initialization
28 REAL, SAVE, ALLOCATABLE, DIMENSION(:,:) :: CO251,CDT51,CDT58,C2D51,&
29 C2D58,CO258
30 REAL, SAVE, ALLOCATABLE, DIMENSION(:) :: STEMP,GTEMP,CO231,CO238, &
31 C2D31,C2D38,CDT31,CDT38, &
32 CO271,CO278,C2D71,C2D78, &
33 CDT71,CDT78
34 REAL, SAVE, ALLOCATABLE, DIMENSION(:) :: CO2M51,CO2M58,CDTM51,CDTM58, &
35 C2DM51,C2DM58
36 CHARACTER(256) :: ERRMESS
37
38 ! Used by CO2 initialization
39 ! COMMON/PRESS/PA(109)
40 ! COMMON/TRAN/ TRANSA(109,109)
41 ! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
42 REAL ,SAVE, DIMENSION(109) :: PA, XA, CA, ETA, SEXPV
43 REAL ,SAVE, DIMENSION(109,109) :: TRANSA
44 REAL ,SAVE :: CORE,UEXP,SEXP
45
46 EQUIVALENCE (EM1V(1),EM1(1,1)),(EM1VW(1),EM1WDE(1,1))
47 EQUIVALENCE (EM3V(1),EM3(1,1))
48 EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), &
49 (T4(1),TABLE3(1,1))
50 REAL,SAVE,DIMENSION(4) :: PTOPC
51 !
52 !--- Used for Gaussian look up tables
53 !
54 REAL, PRIVATE,PARAMETER :: XSDmax=3.1, DXSD=.01
55 INTEGER, PRIVATE,PARAMETER :: NXSD=XSDmax/DXSD
56 REAL, DIMENSION(NXSD),PRIVATE,SAVE :: AXSD
57 REAL, PRIVATE :: RSQR
58 LOGICAL, PRIVATE,SAVE :: SDprint=.FALSE.
59
60
61 #ifndef FERRIER_GFDL
62 REAL, PRIVATE, PARAMETER :: RHgrd=1.0
63 REAL, PRIVATE, PARAMETER :: T_ice=-40.0
64 #endif
65
66 !
67 !--- Important parameters for cloud properties - see extensive comments in
68 ! DO 580 loop within subroutine RADTN
69 !
70 REAL, PARAMETER :: &
71 & TRAD_ice=0.5*T_ice & !--- Very tunable parameter
72 &, ABSCOEF_W=800. & !--- Very tunable parameter
73 &, ABSCOEF_I=500. & !--- Very tunable parameter
74 &, SECANG=-1.66 & !--- Very tunable parameter
75 !! &, SECANG=-0.75 & !--- Very tunable parameter
76 &, CLDCOEF_LW=1.5 & !--- Enhance LW cloud depths
77 &, ABSCOEF_LW=SECANG*CLDCOEF_LW & !--- Final factor for cloud emissivities
78 &, Qconv=0.1e-3 & !--- Very tunable parameter
79 &, CTauCW=ABSCOEF_W*Qconv &
80 &, CTauCI=ABSCOEF_I*Qconv
81 !
82
83 CONTAINS
84
85 !-----------------------------------------------------------------------
86 SUBROUTINE GFDLETAINIT(EMISS,SFULL,SHALF,PPTOP, &
87 & JULYR,MONTH,IDAY,GMT, &
88 & CONFIG_FLAGS,ALLOWED_TO_READ, &
89 & IDS, IDE, JDS, JDE, KDS, KDE, &
90 & IMS, IME, JMS, JME, KMS, KME, &
91 & ITS, ITE, JTS, JTE, KTS, KTE )
92 !-----------------------------------------------------------------------
93 IMPLICIT NONE
94 !-----------------------------------------------------------------------
95 TYPE (GRID_CONFIG_REC_TYPE) :: CONFIG_FLAGS
96 INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
97 & ,IMS,IME,JMS,JME,KMS,KME &
98 & ,ITS,ITE,JTS,JTE,KTS,KTE
99 INTEGER,INTENT(IN) :: JULYR,MONTH,IDAY
100 REAL,INTENT(IN) :: GMT,PPTOP
101 REAL,DIMENSION(KMS:KME),INTENT(IN) :: SFULL, SHALF
102 REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: EMISS
103 LOGICAL,INTENT(IN) :: ALLOWED_TO_READ
104 !
105 INTEGER :: I,IHRST,J,N
106 REAL :: PCLD,XSD,PI,SQR2PI
107 REAL :: SSLP=1013.25
108 REAL, PARAMETER :: PTOP_HI=150.,PTOP_MID=350.,PTOP_LO=642., &
109 & PLBTM=105000.
110 !-----------------------------------------------------------------------
111 !***********************************************************************
112 !-----------------------------------------------------------------------
113 !
114 !*** INITIALIZE DIAGNOSTIC LOW,MIDDLE,HIGH CLOUD LAYER PRESSURE LIMITS.
115 !
116 LTOP(1)=0
117 LTOP(2)=0
118 LTOP(3)=0
119 !
120 DO N=1,KTE
121 PCLD=(SSLP-PPTOP*10.)*SHALF(N)+PPTOP*10.
122 IF(PCLD>=PTOP_LO)LTOP(1)=N
123 IF(PCLD>=PTOP_MID)LTOP(2)=N
124 IF(PCLD>=PTOP_HI)LTOP(3)=N
125 ! PRINT *,N,PCLD,SHALF(N),PSTAR,PPTOP
126 ENDDO
127 !***
128 !*** ASSIGN THE PRESSURES FOR CLOUD DOMAIN BOUNDARIES
129 !***
130 PTOPC(1)=PLBTM
131 PTOPC(2)=PTOP_LO*100.
132 PTOPC(3)=PTOP_MID*100.
133 PTOPC(4)=PTOP_HI*100.
134 !
135 !*** USE CALL TO CONRAD FOR DIRECT READ OF CO2 FUNCTIONS
136 !*** OTHERWISE CALL CO2O3.
137 !
138 IF(ALLOWED_TO_READ)THEN
139 IF(CONFIG_FLAGS%CO2TF==1)THEN
140 CALL CO2O3(SFULL,SHALF,PPTOP,KME-KMS,KME-KMS+1,KME-KMS+2)
141 ELSE
142 CALL CONRAD(KDS,KDE,KMS,KME,KTS,KTE)
143 ENDIF
144 !
145 CALL O3CLIM
146 CALL TABLE
147 IHRST=NINT(GMT)
148 ! WRITE(0,*)'into solard ',gmt,ihrst
149 CALL SOLARD(IHRST,IDAY,MONTH,JULYR)
150 ENDIF
151 !
152 !*** FOR NOW, GFDL RADIATION ASSUMES EMISSIVITY = 1.0
153 !
154 DO J=JTS,JTE
155 DO I=ITS,ITE
156 EMISS(I,J) = 1.0
157 ENDDO
158 ENDDO
159 !
160 !--- Calculate the area under the Gaussian curve at the start of the
161 !--- model run and build the look up table AXSD
162 !
163 PI=ACOS(-1.)
164 SQR2PI=SQRT(2.*PI)
165 RSQR=1./SQR2PI
166 DO I=1,NXSD
167 XSD=REAL(I)*DXSD
168 AXSD(I)=GAUSIN(XSD)
169 if (SDprint) print *,'I, XSD, AXSD =',I,XSD,AXSD(I)
170 ENDDO
171 !! !***
172 !! !*** MESO STANDARD DEVIATION OF EK AND MAHRT'S CLOUD COVER ALOGRITHM
173 !! !***
174 !! SDM=-0.03-0.00015*DX+0.02*LOG(DX) ! meso SD
175 !! if (SDprint) print *,'DX, SDM=',DX,SDM
176 ! if (SDprint) print *, &
177 ! & 'RHgrd,T_ICE,NLImin,NLImax,FLARGE1,FLARGE2,MDImin,MDImax=',&
178 ! & RHgrd,T_ICE,NLImin,NLImax,FLARGE1,FLARGE2,MDImin,MDImax
179 !
180 !-----------------------------------------------------------------------
181 END SUBROUTINE GFDLETAINIT
182 !-----------------------------------------------------------------------
183 !
184 !------------------------------------------------------------------
185 ! urban related variable are added to arguments of etara
186 !---------------------------------------------------------------------
187 !
188 !-----------------------------------------------------------------------
189 SUBROUTINE ETARA(DT,THRATEN,THRATENLW,THRATENSW,CLDFRA,PI3D &
190 & ,XLAND,P8W,DZ8W,RHO_PHY,P_PHY,T &
191 & ,QV,QW,QI,QS &
192 & ,TSK2D,GLW,RSWIN,GSW,RSWINC &
193 & ,RSWTOA,RLWTOA,CZMEAN &
194 & ,GLAT,GLON,HTOP,HBOT,HTOPR,HBOTR,ALBEDO,CUPPT &
195 & ,VEGFRA,SNOW,G,GMT &
196 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
197 & ,NSTEPRA,NPHS,ITIMESTEP &
198 & ,XTIME,JULIAN &
199 & ,COSZ_URB2D,OMG_URB2D & ! urban
200 & ,JULYR,JULDAY,GFDL_LW,GFDL_SW &
201 & ,CFRACL,CFRACM,CFRACH &
202 & ,ACFRST,NCFRST,ACFRCV,NCFRCV &
203 & ,IDS,IDE,JDS,JDE,KDS,KDE &
204 & ,IMS,IME,JMS,JME,KMS,KME &
205 & ,ITS,ITE,JTS,JTE,KTS,KTE)
206 !-----------------------------------------------------------------------
207 IMPLICIT NONE
208 !-----------------------------------------------------------------------
209 INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
210 & ,IMS,IME,JMS,JME,KMS,KME &
211 & ,ITS,ITE,JTS,JTE,KTS,KTE,ITIMESTEP &
212 & ,NPHS,NSTEPRA
213
214 INTEGER,INTENT(IN) :: julyr,julday
215 INTEGER,INTENT(INOUT),DIMENSION(ims:ime,jms:jme) :: NCFRST & !Added
216 ,NCFRCV !Added
217 REAL,INTENT(IN) :: DT,GMT,G,XTIME,JULIAN
218
219 REAL,INTENT(INOUT),DIMENSION(ims:ime, kms:kme, jms:jme):: &
220 THRATEN,THRATENLW,THRATENSW,CLDFRA !Added CLDFRA
221 REAL,INTENT(IN),DIMENSION(ims:ime, kms:kme, jms:jme)::p8w,dz8w, &
222 & rho_phy, &
223 & p_phy, &
224 & PI3D
225 REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme):: ALBEDO,SNOW, &
226 & TSK2D,VEGFRA, &
227 & XLAND
228 REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme):: GLAT,GLON
229 REAL, INTENT(INOUT), DIMENSION(ims:ime, jms:jme):: HTOP,HBOT,HTOPR,HBOTR,CUPPT
230 REAL, INTENT(INOUT), DIMENSION(ims:ime, jms:jme):: RSWTOA, & !Added
231 & RLWTOA, & !Added
232 & ACFRST, & !Added
233 & ACFRCV
234 REAL,INTENT(INOUT),DIMENSION(ims:ime, jms:jme):: GLW,GSW
235 REAL,INTENT(OUT),DIMENSION(ims:ime, jms:jme):: CZMEAN &
236 & ,RSWIN,RSWINC &
237 & ,CFRACL,CFRACM,CFRACH
238 REAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: QS,QV, &
239 & QW,T
240 LOGICAL, INTENT(IN) :: gfdl_lw,gfdl_sw
241 REAL, OPTIONAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: QI
242
243 REAL, DIMENSION(its:ite, kms:kme, jts:jte):: PFLIP,QIFLIP,QFLIP, &
244 & QWFLIP,TFLIP
245 REAL, DIMENSION(its:ite, kms:kme, jts:jte)::P8WFLIP,PHYD
246 REAL, DIMENSION(its:ite, kts:kte, jts:jte)::TENDS,TENDL
247 REAL, DIMENSION(ims:ime, jms:jme):: CUTOP,CUBOT
248 INTEGER :: IDAT(3),Jmonth,Jday
249 INTEGER :: I,J,K,KFLIP,IHRST
250
251 !-------------------------------------------------
252 ! urban related variables are added to declaration
253 !-------------------------------------------------
254 REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme) :: COSZ_URB2D !urban
255 REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme) :: OMG_URB2D !urban
256 ! begin debugging radiation
257 integer :: imd,jmd
258 real :: FSWrat
259 ! end debugging radiation
260 !-----------------------------------------------------------------------
261 !***********************************************************************
262 !-----------------------------------------------------------------------
263 IF(GFDL_LW.AND.GFDL_SW )GO TO 100
264 !
265 DO J=JMS,JME
266 DO K=KMS,KME
267 DO I=IMS,IME
268 CLDFRA(I,K,J)=0.
269 ENDDO
270 ENDDO
271 ENDDO
272 ! NEED HYDROSTATIC PRESSURE HERE (MONOTONIC CHANGE WITH HEIGHT)
273 DO J=JTS,JTE
274 DO I=ITS,ITE
275 PHYD(I,KTS,J)=P8W(I,KTS,J)
276 ENDDO
277 ENDDO
278 !
279 DO J=JTS,JTE
280 DO K=KTS,KTE
281 DO I=ITS,ITE
282 PHYD(I,K+1,J)=PHYD(I,K,J)-G*RHO_PHY(I,K,J)*DZ8W(I,K,J)
283 ENDDO
284 ENDDO
285 ENDDO
286 !
287 DO K=KMS,KME
288 KFLIP=KME+1-K
289 DO J=JTS,JTE
290 DO I=ITS,ITE
291 P8WFLIP(I,K,J)=PHYD(I,KFLIP,J)
292 ENDDO
293 ENDDO
294 ENDDO
295 !
296 !- Note that the effects of rain are ignored in this radiation package (BSF 2005-01-25)
297 !
298 DO K=KTS,KTE
299 KFLIP=KTE+1-K
300 DO J=JTS,JTE
301 DO I=ITS,ITE
302 TFLIP (I,K,J)=T(I,KFLIP,J)
303 QFLIP (I,K,J)=MAX(0.,QV(I,KFLIP,J)/(1.+QV(I,KFLIP,J)))
304 QWFLIP(I,K,J)=MAX(QW(I,KFLIP,J),0.) !Modified
305 ! Note that QIFLIP will contain QS+QI if both are passed in, otherwise just QS
306 ! Eta MP now outputs QS instead of QI (JD 2006-05-12)
307 QIFLIP(I,K,J)=MAX(QS(I,KFLIP,J),0.) !Added QS
308 IF(PRESENT(QI))QIFLIP(I,K,J)=QIFLIP(I,K,J)+QI(I,KFLIP,J) !Added QI
309 ! PFLIP (I,K,J)=P_PHY(I,KFLIP,J)
310 !
311 !*** USE MONOTONIC HYDROSTATIC PRESSURE INTERPOLATED TO MID-LEVEL
312 !
313 PFLIP(I,K,J)=0.5*(P8WFLIP(I,K,J)+P8WFLIP(I,K+1,J))
314 ENDDO
315 ENDDO
316 ENDDO
317 !
318 DO J=JTS,JTE
319 DO I=ITS,ITE
320 CUBOT(I,J)=KTE+1-HBOT(I,J)
321 CUTOP(I,J)=KTE+1-HTOP(I,J)
322 ENDDO
323 ENDDO
324 !
325 CALL CAL_MON_DAY(JULDAY,JULYR,JMONTH,JDAY)
326 !
327 IDAT(1)=JMONTH
328 IDAT(2)=JDAY
329 IDAT(3)=JULYR
330 IHRST =NINT(GMT)
331
332 !-----------------------------------------------------------------------
333 CALL RADTN (DT,TFLIP,QFLIP,QWFLIP,QIFLIP, &
334 & PFLIP,P8WFLIP,XLAND,TSK2D, &
335 & GLAT,GLON,CUTOP,CUBOT,ALBEDO,CUPPT, &
336 & ACFRCV,NCFRCV,ACFRST,NCFRST, &
337 & VEGFRA,SNOW,GLW,GSW,RSWIN,RSWINC, &
338 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
339 & IDAT,IHRST,XTIME,JULIAN, &
340 & NSTEPRA,NSTEPRA,NPHS,ITIMESTEP, &
341 & TENDS,TENDL,CLDFRA,RSWTOA,RLWTOA,CZMEAN, &
342 & CFRACL,CFRACM,CFRACH, &
343 ! & COSZ2D,OMG2D, & !urban
344 & COSZ_URB2D,OMG_URB2D, & !urban
345 & IDS,IDE,JDS,JDE,KDS,KDE, &
346 & IMS,IME,JMS,JME,KMS,KME, &
347 & ITS,ITE,JTS,JTE,KTS,KTE )
348 !-----------------------------------------------------------------------
349 ! begin debugging radiation
350 ! imd=(ims+ime)/2
351 ! jmd=(jms+jme)/2
352 ! FSWrat=0.
353 ! if (RSWIN(imd,jmd) .gt. 0.) &
354 ! FSWrat=(RSWIN(imd,jmd)-GSW(imd,jmd))/RSWIN(imd,jmd)
355 ! write(6,"(2a,2i5,5f9.2,f8.4,i3,2f8.4)") &
356 ! '{rad4 imd,jmd,GSW,RSWIN,RSWOUT=RSWIN-GSW,RSWINC,GLW,' &
357 ! ,'ACFRCV,NCFRCV,ALBEDO,RSWOUT/RSWIN = ' &
358 ! ,imd,jmd, GSW(imd,jmd),RSWIN(imd,jmd) &
359 ! ,RSWIN(imd,jmd)-GSW(imd,jmd),RSWINC(imd,jmd),GLW(imd,jmd) &
360 ! ,ACFRCV(imd,jmd),NCFRCV(imd,jmd),ALBEDO(imd,jmd),FSWrat
361 ! end debugging radiation
362 !
363 !--- Need to save LW & SW tendencies since radiation calculates both and this block
364 ! is skipped when GFDL SW is called, both only if GFDL LW is also called
365 !
366 IF(GFDL_LW)THEN
367 DO J=JTS,JTE
368 DO K = KTS,KTE
369 KFLIP=KTE+1-K
370 DO I=ITS,ITE
371 THRATENLW(I,K,J)=TENDL(I,KFLIP,J)/PI3D(I,K,J)
372 THRATENSW(I,K,J)=TENDS(I,KFLIP,J)/PI3D(I,K,J)
373 THRATEN(I,K,J) =THRATEN(I,K,J) + THRATENLW(I,K,J)
374 ENDDO
375 ENDDO
376 ENDDO
377 ENDIF
378 !
379 !*** THIS ASSUMES THAT LONGWAVE IS CALLED FIRST IN THE RADIATION_DRIVER.
380 ! Only gets executed if a different LW scheme (not GFDL) is called
381 !
382 IF(GFDL_SW)THEN
383 DO J=JTS,JTE
384 DO K=KTS,KTE
385 KFLIP=KTE+1-K
386 DO I=ITS,ITE
387 THRATENSW(I,K,J)=TENDS(I,KFLIP,J)/PI3D(I,K,J)
388 ENDDO
389 ENDDO
390 ENDDO
391 ENDIF
392 !
393 !*** RESET ACCUMULATED CONVECTIVE CLOUD TOP/BOT AND CONVECTIVE PRECIP
394 !*** FOR NEXT INTERVAL BETWEEN RADIATION CALLS
395 !
396 DO J=JTS,JTE
397 DO I=ITS,ITE
398 ! SAVE VALUE USED BY RADIATION BEFORE RESETTING HTOP AND HBOT
399 HBOTR(I,J)=HBOT(I,J)
400 HTOPR(I,J)=HTOP(I,J)
401 HBOT(I,J)=REAL(KTE+1)
402 HTOP(I,J)=0.
403 CUPPT(I,J)=0.
404 ENDDO
405 ENDDO
406 !
407 100 IF(GFDL_SW)THEN
408 DO J=JTS,JTE
409 DO K=KTS,KTE
410 KFLIP=KTE+1-K
411 DO I=ITS,ITE
412 THRATEN(I,K,J)=THRATEN(I,K,J)+THRATENSW(I,K,J)
413 ENDDO
414 ENDDO
415 ENDDO
416 ENDIF
417 !
418 END SUBROUTINE ETARA
419 !
420 !-----------------------------------------------------------------------
421 SUBROUTINE RADTN(DT,T,Q,QCW,QICE, &
422 & PFLIP,P8WFLIP,XLAND,TSK2D, &
423 & GLAT,GLON,CUTOP,CUBOT,ALB,CUPPT, &
424 & ACFRCV,NCFRCV,ACFRST,NCFRST, &
425 & VEGFRC,SNO,GLW,GSW,RSWIN,RSWINC, &
426 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
427 & IDAT,IHRST,XTIME,JULIAN, &
428 & NRADS,NRADL,NPHS,NTSD, &
429 & TENDS,TENDL,CLDFRA,RSWTOA,RLWTOA,CZMEAN, &
430 & CFRACL,CFRACM,CFRACH, &
431 & COSZ_URB2D,OMG_URB2D, & !urban
432 & ids,ide, jds,jde, kds,kde, &
433 & ims,ime, jms,jme, kms,kme, &
434 & its,ite, jts,jte, kts,kte )
435 !-----------------------------------------------------------------------
436 IMPLICIT NONE
437 !-----------------------------------------------------------------------
438
439 ! GLAT : geodetic latitude in radians of the mass points on the computational grid.
440
441 ! CZEN : instantaneous cosine of the solar zenith angle.
442
443 ! CUTOP : (REAL) model layer number that is highest in the atmosphere
444 ! in which convective cloud occurred since the previous call to the
445 ! radiation driver.
446
447 ! CUBOT : (REAL) model layer number that is lowest in the atmosphere
448 ! in which convective cloud occurred since the previous call to the
449 ! radiation driver.
450
451 ! ALB : is no longer used in the operational radiation. Prior to 24 July 2001
452 ! ALB was the climatological albedo that was modified within RADTN to
453 ! account for vegetation fraction and snow.
454 !
455 ! ALB : reintroduced as the dynamic albedo from LSM
456
457 ! CUPPT: accumulated convective precipitation (meters) since the
458 ! last call to the radiation.
459
460 ! TSK2D : skin temperature
461
462 ! IHE and IHW are relative location indices needed to locate neighboring
463 ! points on the Eta's Arakawa E grid since arrays are indexed locally on
464 ! each MPI task rather than globally. IHE refers to the adjacent grid
465 ! point (a V point) to the east of the mass point being considered. IHW
466 ! is the adjacent grid point to the west of the given mass point.
467
468 ! IRAD is a relic from older code that is no longer needed.
469
470 ! ACFRCV : sum of the convective cloud fractions that were computed
471 ! during each call to the radiation between calls to the subroutines that
472 ! do the forecast output.
473
474 ! NCFRCV : the total number of times in which the convective cloud
475 ! fraction was computed to be greater than zero in the radiation between
476 ! calls to the output routines. In the post-processor, ACFRCV is divided
477 ! by NCFRCV to yield an average convective cloud fraction.
478
479 ! ACFRST and NCFRST are the analogs for stratiform cloud cover.
480
481 ! VEGFRC is the fraction of the gridbox with vegetation.
482
483 ! LVL holds the number of model layers that lie below the ground surface
484 ! at each point. Clearly for sigma coordinates LVL is zero everywhere.
485
486 ! CTHK : an assumed maximum thickness of stratiform clouds currently set
487 ! to 20000 Pascals. I think this is relevant for computing "low",
488 ! "middle", and "high" cloud fractions which are post-processed but which
489 ! do not feed back into the integration.
490
491 ! IDAT : a 3-element integer array holding the month, day, and year,
492 ! respectively, of the date for the start time of the free forecast.
493
494 ! ABCFF : holds coefficients for various absorption bands. You can see
495 ! where they are set in GFDLRD.F.
496
497 ! LTOP : a 3-element integer array holding the model layer that is at or
498 ! immediately below the specified pressure levels for the tops
499 ! of "high" (15000 Pa), "middle" (35000 Pa), and "low" (64200 Pa)
500 ! stratiform clouds. These are for the diagnostic cloud layers
501 ! needed in the output but not in the integration.
502
503 ! NRADS : integer number of fundamental timesteps (our smallest
504 ! timestep, i.e., the one for inertial gravity wave adjustment)
505 ! between updates of the shortwave tendencies.
506
507 ! NRADL : integer number of fundamental timesteps between updates of
508 ! the longwave tendencies.
509
510 ! NTSD : integer counter of the fundamental timesteps that have
511 ! elapsed since the start of the forecast.
512
513 ! GLW : incoming longwave radiation at the surface
514 ! GSW : NET (down minus up, or incoming minus outgoing) all-sky shortwave radiation at the surface
515 ! RSWIN : total (clear + cloudy sky) incoming (downward) solar radiation at the surface
516 ! RSWINC : clear sky incoming (downward) solar radiation at the surface
517
518 ! TENDS,TENDL : shortwave,longwave (respectively) temperature tendency
519
520 ! CLDFRA : 3D cloud fraction
521
522 ! RSWTOA, RLWTOA : outgoing shortwave, longwave (respectively) fluxes at top of atmosphere
523
524 ! CZMEAN : time-average cosine of the zenith angle
525
526 ! CFRACL,CFRACM,CFRACH : low, middle, & high (diagnosed) cloud fractions
527
528 ! XTIME : time since simulation start (minutes)
529
530 ! JULIAN: Day of year (0.0 at 00Z Jan 1st)
531
532 !**********************************************************************
533 !****************************** NOTE **********************************
534 !**********************************************************************
535 !*** DUE TO THE RESETTING OF CONVECTIVE PRECIP AND CONVECTIVE CLOUD
536 !*** TOPS AND BOTTOMS, SHORTWAVE MUST NOT BE CALLED LESS FREQUENTLY
537 !*** THAN LONGWAVE.
538 !**********************************************************************
539 !****************************** NOTE **********************************
540 !**********************************************************************
541 !-----------------------------------------------------------------------
542 ! INTEGER, PARAMETER :: NL=81
543 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
544 & ims,ime, jms,jme, kms,kme , &
545 & its,ite, jts,jte, kts,kte
546 INTEGER, INTENT(IN) :: NRADS,NRADL,NTSD,NPHS
547 ! LOGICAL, INTENT(IN) :: RESTRT
548 REAL , INTENT(IN) :: DT,XTIME,JULIAN
549 ! REAL , INTENT(IN), DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4
550 INTEGER, INTENT(IN), DIMENSION(3) :: IDAT
551 !-----------------------------------------------------------------------
552 INTEGER :: LM1,LP1,LM
553 INTEGER, INTENT(IN) :: IHRST
554 ! REAL, INTENT(IN), DIMENSION(NL) :: PRGFDL
555 !
556 REAL, PARAMETER :: EPSQ1=1.E-5,EPSQ=1.E-12,EPSO3=1.E-10,H0=0. &
557 &, H1=1.,HALF=.5,T0C=273.15,CUPRATE=24.*1000.,HPINC=HALF*1.E1 &
558 !------------------------ For Clouds ----------------------------------
559 &, CLFRmin=0.01, TAUCmax=4.161 &
560 !--- Parameters used for new cloud cover scheme
561 &, XSDmin=-XSDmax, DXSD1=-DXSD, STSDM=0.01, CVSDM=.04 &
562 &, DXSD2=HALF*DXSD, DXSD2N=-DXSD2, PCLDY=0.25
563 !
564 INTEGER, PARAMETER :: NB=12,KSMUD=0
565 INTEGER,PARAMETER :: K15=SELECTED_REAL_KIND(15)
566 REAL (KIND=K15) :: DDX,EEX,PROD
567 ! REAL, INTENT(IN) :: SKO3R,AB15WD,SKC1R,SKO2D
568 !-----------------------------------------------------------------------
569 LOGICAL :: SHORT,LONG
570 LOGICAL :: BITX,BITY,BITZ,BITW,BIT1,BIT2,BITC,BITCP1,BITSP1
571 LOGICAL, SAVE :: CNCLD=.TRUE.
572 LOGICAL :: NEW_CLOUD
573 !-----------------------------------------------------------------------
574 REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: XLAND,TSK2D
575 REAL, INTENT(IN), DIMENSION(its:ite, kms:kme, jts:jte):: Q,QCW, &
576 & QICE,T, &
577 & PFLIP, &
578 & P8WFLIP
579
580 ! REAL, INTENT(IN), DIMENSION(28,180) :: TABLE1,TABLE2,TABLE3,EM3,EM1,EM1WDE
581 REAL, INTENT(OUT), DIMENSION(ims:ime, jms:jme):: GLW,GSW,CZMEAN &
582 & ,RSWIN,RSWINC & !Added
583 & ,CFRACL,CFRACM &
584 & ,CFRACH
585 REAL, INTENT(OUT),DIMENSION(ims:ime,kms:kme,jms:jme) :: CLDFRA !added
586
587 ! REAL, INTENT(IN), DIMENSION(kms:kme) :: ETAD
588 ! REAL, INTENT(IN), DIMENSION(kms:kme) :: AETA
589 !-----------------------------------------------------------------------
590 REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: CUTOP,CUBOT,CUPPT
591 REAL, INTENT(IN ), DIMENSION(ims:ime,jms:jme) :: ALB,SNO
592 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
593 REAL, INTENT(IN ), DIMENSION(ims:ime,jms:jme) :: GLAT,GLON
594 !-----------------------------------------------------------------------
595 REAL, DIMENSION(ims:ime,jms:jme) :: CZEN
596 INTEGER, DIMENSION(its:ite, jts:jte):: LMH
597 !-----------------------------------------------------------------------
598 ! INTEGER,INTENT(IN), DIMENSION(jms:jme) :: IHE,IHW
599 !-----------------------------------------------------------------------
600 REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: ACFRCV,ACFRST &
601 ,RSWTOA,RLWTOA
602 INTEGER,INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: NCFRCV,NCFRST
603 !-----------------------------------------------------------------------
604 REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: VEGFRC
605 REAL, INTENT(INOUT),DIMENSION(its:ite,kts:kte,jts:jte) :: TENDL,&
606 & TENDS
607 !-----------------------------------------------------------------------
608 REAL :: CTHK(3)
609 DATA CTHK/20000.0,20000.0,20000.0/
610
611 REAL,DIMENSION(10),SAVE :: CC,PPT
612 !-----------------------------------------------------------------------
613 REAL,SAVE :: ABCFF(NB)
614 INTEGER,DIMENSION(its:ite,jts:jte) :: LVL
615 REAL, DIMENSION(its:ite, jts:jte):: PDSL,FNE,FSE,TL
616 REAL, DIMENSION( 0:kte) :: CLDAMT
617 REAL, DIMENSION(its:ite,3):: CLDCFR
618 INTEGER, DIMENSION(its:ite,3):: MBOT,MTOP
619 REAL, DIMENSION(its:ite) :: PSFC,TSKN,ALBEDO,XLAT,COSZ, &
620 & SLMSK,FLWUP, &
621 & FSWDN,FSWUP,FSWDNS,FSWUPS,FLWDNS, &
622 & FLWUPS,FSWDNSC
623
624 REAL, DIMENSION(its:ite,kts:kte) :: PMID,TMID
625 REAL, DIMENSION(its:ite,kts:kte) :: QMID,THMID,OZN,POZN
626 REAL, DIMENSION(its:ite,jts:jte) :: TOT
627
628 REAL, DIMENSION(its:ite,kts:kte+1) :: PINT,EMIS,CAMT
629 INTEGER,DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP
630 INTEGER,DIMENSION(its:ite) :: NCLDS,KCLD
631 REAL, DIMENSION(its:ite) :: TAUDAR
632 REAL, DIMENSION(its:ite,NB,kts:kte+1) ::RRCL,TTCL
633
634 REAL, DIMENSION(its:ite,kts:kte):: CSMID,CCMID,QWMID,QIMID
635 !! & ,QOVRCST ! Added
636 REAL,SAVE :: P400=40000.
637 INTEGER,SAVE :: NFILE=14
638
639 !-----------------------------------------------------------------------
640 REAL :: CLSTP,TIME,DAYI,HOUR,ADDL,RANG
641 REAL :: TIMES,EXNER,APES,SNOFAC,CCLIMIT,CLIMIT,P1,P2,CC1,CC2
642 REAL :: PMOD,CLFR1,CTAU,WV,ARG,CLDMAX
643 REAL :: CL1,CL2,CR1,DPCL,QSUM,PRS1,PRS2,DELP,TCLD,DD,EE,AA,FF
644 REAL :: BB,GG,FCTR,PDSLIJ,CFRAVG,SNOMM
645 REAL :: THICK,CONVPRATE,CLFR,ESAT,QSAT,RHUM,QCLD
646 REAL :: RHtot,RRHO,FLARGE,FSMALL,DSNOW,SDM,QPCLDY,DIFCLD
647 REAL :: TauC,CTauL,CTauS, CFSmax,CFCmax
648 INTEGER :: I,J,MYJS,MYJE,MYIS,MYIE,NTSPH,NRADPP,ITIMSW,ITIMLW, &
649 & JD,II
650 INTEGER :: L,N,LML,LVLIJ,IR,KNTLYR,LL,NC,L400,NMOD,LTROP,IWKL
651 INTEGER :: LCNVB,LCNVT
652 INTEGER :: NLVL,MALVL,LLTOP,LLBOT,KBT2,KTH1,KBT1,KTH2,KTOP1,KFLIP
653 INTEGER :: NBAND,NCLD,LBASE,NKTP,NBTM,KS,MYJS1,MYJS2,MYJE2,MYJE1
654
655 !-------------------------------------------------
656 ! urban related variables are added to declaration
657 !-------------------------------------------------
658 REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme) :: COSZ_URB2D !urban
659 REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme) :: OMG_URB2D !urban
660
661 INTEGER :: INDEXS,IXSD
662 DATA CC/0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0/
663 DATA PPT/0.,.14,.31,.70,1.6,3.4,7.7,17.,38.,85./
664 DATA ABCFF/2*4.0E-5,.002,.035,.377,1.95,9.40,44.6,190.,989., &
665 & 2706.,39011./
666 ! begin debugging radiation
667 integer :: imd,jmd, Jndx
668 real :: FSWrat
669 imd=(ims+ime)/2
670 jmd=(jms+jme)/2
671 ! end debugging radiation
672 !
673 !=======================================================================
674 !
675 MYJS=jts
676 MYJE=jte
677 MYIS=its
678 MYIE=ite
679 MYJS1=jts !????
680 MYJE1=jte
681 MYJS2=jts
682 MYJE2=jte
683 LM=kte
684 LM1=LM-1
685 LP1=LM+1
686 !
687 DO J=JTS,JTE
688 DO I=ITS,ITE
689 LMH(I,J)=KME-1
690 LVL(I,J)=0
691 ENDDO
692 ENDDO
693 !**********************************************************************
694 !*** THE FOLLOWING CODE IS EXECUTED EACH TIME THE RADIATION IS CALLED.
695 !**********************************************************************
696 !----------------------CONVECTION--------------------------------------
697 ! NRADPP IS THE NUMBER OF TIME STEPS TO ACCUMULATE CONVECTIVE PRECIP
698 ! FOR RADIATION
699 ! NOTE: THIS WILL NOT WORK IF NRADS AND NRADL ARE DIFFERENT UNLESS
700 ! THEY ARE INTEGER MULTIPLES OF EACH OTHER
701 ! CLSTP IS THE NUMBER OF HOURS OF THE ACCUMULATION PERIOD
702 !
703 NTSPH=NINT(3600./DT)
704 NRADPP=MIN(NRADS,NRADL)
705 CLSTP=1.0*NRADPP/NTSPH
706 CONVPRATE=CUPRATE/CLSTP
707 !----------------------CONVECTION--------------------------------------
708 !***
709 !*** STATE WHETHER THE SHORT OR LONGWAVE COMPUTATIONS ARE TO BE DONE.
710 !***
711 SHORT=.TRUE.
712 LONG=.TRUE.
713 ITIMSW=0
714 ITIMLW=0
715 IF(SHORT)ITIMSW=1
716 IF(LONG) ITIMLW=1
717 !***
718 !*** FIND THE MEAN COSINE OF THE SOLAR ZENITH ANGLE
719 !*** BETWEEN THE CURRENT TIME AND THE NEXT TIME RADIATION IS
720 !*** CALLED. ONLY AVERAGE IF THE SUN IS ABOVE THE HORIZON.
721 !***
722 ! TIME=NTSD*DT
723 TIME=XTIME*60.
724 !-----------------------------------------------------------------------
725 CALL ZENITH(TIME,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN, &
726 & MYIS,MYIE,MYJS,MYJE, &
727 & ids,ide, jds,jde, kds,kde, &
728 & ims,ime, jms,jme, kms,kme, &
729 & its,ite, jts,jte, kts,kte, &
730 & OMG_URB2d=OMG_URB2D ) !Optional urban
731 !-----------------------------------------------------------------------
732 ! write(0,*)'1st ZEN ',TIME,DAYI,HOUR,IDAT,IHRST,CZEN(ITS,JTS)
733 ADDL=0.
734 IF(MOD(IDAT(3),4).EQ.0)ADDL=1.
735 RANG=PI2*(DAYI-RLAG)/(365.+ADDL)
736 RSIN1=SIN(RANG)
737 RCOS1=COS(RANG)
738 RCOS2=COS(2.*RANG)
739 !
740 !-----------------------------------------------------------------------
741 IF(SHORT)THEN
742 DO J=MYJS,MYJE
743 DO I=MYIS,MYIE
744 CZMEAN(I,J)=0.
745 TOT(I,J)=0.
746 ENDDO
747 ENDDO
748 !
749 DO II=0,NRADS,NPHS
750 TIMES=XTIME*60.+II*DT
751 CALL ZENITH(TIMES,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN, &
752 & MYIS,MYIE,MYJS,MYJE, &
753 & ids,ide, jds,jde, kds,kde, &
754 & ims,ime, jms,jme, kms,kme, &
755 & its,ite, jts,jte, kts,kte, &
756 & OMG_URB2D) !Optional urban
757 ! write(0,*)'2nd ZEN ',TIMES,DAYI,HOUR,IDAT,IHRST,CZEN(ITS,JTS),&
758 ! & II,NRADS,NPHS,NTSD,DT
759 DO J=MYJS,MYJE
760 DO I=MYIS,MYIE
761 IF(CZEN(I,J).GT.0.)THEN
762 CZMEAN(I,J)=CZMEAN(I,J)+CZEN(I,J)
763 TOT(I,J)=TOT(I,J)+1.
764 ENDIF
765 ENDDO
766 ENDDO
767 ENDDO
768 DO J=MYJS,MYJE
769 DO I=MYIS,MYIE
770 IF(TOT(I,J).GT.0.)CZMEAN(I,J)=CZMEAN(I,J)/TOT(I,J)
771 ENDDO
772 ENDDO
773 ENDIF
774
775 !--------------------------------------------
776 ! COSZ2D is calculated for urban
777 !--------------------------------------------
778 DO J=MYJS,MYJE !urban
779 DO I=MYIS,MYIE !urban
780 if(present(COSZ_URB2D)) COSZ_URB2D(I,J)=CZEN(I,J) !urban
781 ENDDO !urban
782 ENDDO !urban
783 !
784 !
785 !*** Do not modify pressure for ozone concentrations below the top layer
786 !***
787 DO L=2,LM
788 DO I=MYIS,MYIE
789 POZN(I,L)=H1
790 ENDDO
791 ENDDO
792 !-----------------------------------------------------------------------
793 !
794 !***********************************************************************
795 !*** THIS IS THE BEGINNING OF THE PRIMARY LOOP THROUGH THE DOMAIN
796 !***********************************************************************
797 ! *********************
798 DO 700 J = MYJS, MYJE
799 ! *********************
800 !
801 DO 125 L=1,LM
802 DO I=MYIS,MYIE
803 TMID(I,L)=T(I,1,J)
804 QMID(I,L)=EPSQ
805 QWMID(I,L)=0.
806 QIMID(I,L)=0.
807 CSMID(I,L)=0.
808 CCMID(I,L)=0.
809 OZN(I,L)=EPSO3
810 TENDS(I,L,J)=0.
811 TENDL(I,L,J)=0.
812 ENDDO
813 125 CONTINUE
814 !
815 DO 140 N=1,3
816 DO I=MYIS,MYIE
817 CLDCFR(I,N)=0.
818 MTOP(I,N)=0
819 MBOT(I,N)=0
820 ENDDO
821 140 CONTINUE
822 !***
823 !*** FILL IN WORKING ARRAYS WHERE VALUES AT L=LM ARE THOSE THAT
824 !*** ARE ACTUALLY AT ETA LEVEL L=LMH.
825 !***
826 DO 200 I=MYIS,MYIE
827 ! IR=IRAD(I)
828 LML=LMH(I,J)
829 LVLIJ=LVL(I,J)
830 !
831 DO L=1,LML
832 PMID(I,L+LVLIJ)=PFLIP(I,L,J)
833 PINT(I,L+LVLIJ+1)=P8WFLIP(I,L+1,J)
834 EXNER=(1.E5/PMID(I,L+LVLIJ))**RCP
835 TMID(I,L+LVLIJ)=T(I,L,J)
836 THMID(I,L+LVLIJ)=T(I,L,J)*EXNER
837 QMID(I,L+LVLIJ)=MAX(EPSQ, Q(I,L,J))
838 !--- Note that rain is ignored, only effects from cloud water and
839 ! ice (cloud ice + snow) are considered
840 QWMID(I,L+LVLIJ)=QCW(I,L,J)
841 QIMID(I,L+LVLIJ)=QICE(I,L,J)
842 ENDDO
843 !***
844 !*** FILL IN ARTIFICIAL VALUES ABOVE THE TOP OF THE DOMAIN.
845 !*** PRESSURE DEPTHS OF THESE LAYERS IS 1 HPA.
846 !*** TEMPERATURES ABOVE ARE ALREADY ISOTHERMAL WITH (TRUE) LAYER 1.
847 !***
848 IF(LVLIJ.GT.0)THEN
849 KNTLYR=0
850 !
851 DO L=LVLIJ,1,-1
852 KNTLYR=KNTLYR+1
853 PMID(I,L)=P8WFLIP(I,1,J)-REAL(2*KNTLYR-1)*HPINC
854 PINT(I,L+1)=PMID(I,L)+HPINC
855 EXNER=(1.E5/PMID(I,L))**RCP
856 THMID(I,L)=TMID(I,L)*EXNER
857 ENDDO
858 ENDIF
859 !
860 IF(LVLIJ.EQ.0) THEN
861 PINT(I,1)=P8WFLIP(I,1,J)
862 ELSE
863 PINT(I,1)=PMID(I,1)-HPINC
864 ENDIF
865 200 CONTINUE
866 !***
867 !*** FILL IN THE SURFACE PRESSURE, SKIN TEMPERATURE, GEODETIC LATITUDE,
868 !*** ZENITH ANGLE, SEA MASK, AND ALBEDO. THE SKIN TEMPERATURE IS
869 !*** NEGATIVE OVER WATER.
870 !***
871 DO 250 I=MYIS,MYIE
872 PSFC(I)=P8WFLIP(I,KME,J)
873 APES=(PSFC(I)*1.E-5)**RCP
874 ! TSKN(I)=THS(I,J)*APES*(1.-2.*SM(I,J))
875 IF((XLAND(I,J)-1.5).GT.0.)THEN
876 TSKN(I)=-TSK2D(I,J)
877 ELSE
878 TSKN(I)=TSK2D(I,J)
879 ENDIF
880
881 ! TSKN(I)=THS(I,J)*APES*(1.-2.*(XLAND(I,J)-1.))
882 ! SLMSK(I)=SM(I,J)
883 SLMSK(I)=XLAND(I,J)-1.
884 !
885 ! SNO(I,J)=AMAX1(SNO(I,J),0.)
886 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
887 SNOMM=AMAX1(SNO(I,J),0.)
888 SNOFAC=AMIN1(SNOMM/0.02, 1.0)
889 !!!! ALBEDO(I)=ALB(I,J)+(1.0-0.01*VEGFRC(I,J))*SNOFAC*(SNOALB-ALB(I,J))
890 ALBEDO(I)=ALB(I,J)
891 !
892 XLAT(I)=GLAT(I,J)*RTD
893 COSZ(I)=CZMEAN(I,J)
894 250 CONTINUE
895 !-----------------------------------------------------------------------
896 !--- COMPUTE GRID-SCALE CLOUD COVER FOR RADIATION (Ferrier, Nov '04)
897 !
898 !--- Assumes Gaussian-distributed probability density functions (PDFs) for
899 ! total relative humidity (RHtot) within the grid for convective and
900 ! grid-scale cloud processes. The standard deviation of RHtot is assumed
901 ! to be larger for convective clouds than grid-scale (stratiform) clouds.
902 !-----------------------------------------------------------------------
903 !
904 DO I=MYIS,MYIE
905 LML=LMH(I,J)
906 LVLIJ=LVL(I,J)
907 DO 255 L=1,LML
908 LL=L+LVLIJ
909 WV=QMID(I,LL)/(1.-QMID(I,LL)) !--- Water vapor mixing ratio
910 QCLD=QWMID(I,LL)+QIMID(I,LL) !--- Total cloud water + ice mixing ratio
911 IF (QCLD .LE. EPSQ) GO TO 255 !--- Skip if no condensate is present
912 CLFR=H0
913 WV=QMID(I,LL)/(1.-QMID(I,LL)) !--- Water vapor mixing ratio
914
915 !
916 !--- Saturation vapor pressure w/r/t water ( >=0C ) or ice ( <0C )
917 !
918 #ifdef FERRIER_GFDL
919 ESAT=1000.*FPVS(TMID(I,LL)) !--- Saturation vapor pressure (Pa)
920 #else
921 ESAT=FPVS_new(TMID(I,LL)) !--- Saturation vapor pressure (Pa)
922 #endif
923 QSAT=EP_2*ESAT/(PMID(I,LL)-ESAT) !--- Saturation mixing ratio
924 RHUM=WV/QSAT !--- Relative humidity
925 !
926 !--- Revised cloud cover parameterization (temporarily ignore rain)
927 !
928 RHtot=(WV+QCLD)/QSAT !--- Total relative humidity
929 !! !
930 !! !--- QOVRCST is the amount of cloud condensate associated with full
931 !! ! overcast, PCLDY is an arbitrary factor for partial cloudiness
932 !! !
933 !! TCLD=TMID(I,LL)-T0C !--- Air temp in deg C
934 !! RRHO=(R_D*TMID(I,LL)*(1.+EP_1*QMID(I,LL)))/PMID(I,LL)
935 !! IF (TCLD .GE. 0.) THEN
936 !! QOVRCST(I,LL)=QAUT0*RRHO
937 !! ELSE
938 !! IF (TCLD.GE.-8. .AND. TCLD.LE.-3.) THEN
939 !! FLARGE=FLARGE1
940 !! ELSE
941 !! FLARGE=FLARGE2
942 !! ENDIF
943 !! FSMALL=(1.-FLARGE)/FLARGE
944 !! DSNOW=XMImax*EXP(XMIexp*TCLD)
945 !! INDEXS=MAX(MDImin, MIN(MDImax, INT(DSNOW)))
946 !! QOVRCST(I,LL)=NLImax*( FSMALL*MASSI(MDImin) &
947 !! & +MASSI(INDEXS) )*RRHO
948 !! ENDIF !--- End IF (TCLD .GE. 0.)
949 !! QOVRCST(I,LL)=PCLDY*QOVRCST(I,LL)
950 LCNVT=NINT(CUTOP(I,J))+LVLIJ
951 LCNVT=MIN(LM,LCNVT)
952 LCNVB=NINT(CUBOT(I,J))+LVLIJ
953 LCNVB=MIN(LM,LCNVB)
954 IF (LL.GE.LCNVT .AND. LL.LE.LCNVB) THEN
955 SDM=CVSDM
956 ELSE
957 SDM=STSDM
958 ENDIF
959 ARG=(RHtot-RHgrd)/SDM
960 IF (ARG.LE.DXSD2 .AND. ARG.GE.DXSD2N) THEN
961 CLFR=HALF
962 ELSE IF (ARG .GT. DXSD2) THEN
963 IF (ARG .GE. XSDmax) THEN
964 CLFR=H1
965 ELSE
966 IXSD=INT(ARG/DXSD+HALF)
967 IXSD=MIN(NXSD, MAX(IXSD,1))
968 CLFR=HALF+AXSD(IXSD)
969 if (SDprint) &
970 & write(6,"(a,3i3,i4,f8.4,f7.4,2f6.3,f7.3,f6.1,f6.0)") &
971 & 'I,LL,J,IXSD,ARG,SDM,CLFR,RHtot,QSAT,T,P=', I,LL,J,IXSD,ARG,SDM,CLFR,RHtot &
972 & ,1000.*QSAT,TCLD,.01*PMID(I,LL)
973 ENDIF !--- End IF (ARG .GE. XSDmax)
974 ELSE
975 IF (ARG .LE. XSDmin) THEN
976 CLFR=H0
977 ELSE
978 IXSD=INT(ARG/DXSD1+HALF)
979 IXSD=MIN(NXSD, MAX(IXSD,1))
980 CLFR=HALF-AXSD(IXSD)
981 if (SDprint) &
982 & write(6,"(a,3i3,i4,f8.4,f7.4,2f6.3,f7.3,f6.1,f6.0)") &
983 & 'I,LL,J,IXSD,ARG,SDM,CLFR,RHtot,QSAT,T,P=', I,LL,J,IXSD,ARG,SDM,CLFR,RHtot &
984 & ,1000.*QSAT,TCLD,.01*PMID(I,LL)
985 IF (CLFR .LT. CLFRmin) CLFR=H0
986 ENDIF !--- End IF (ARG .LE. XSDmin)
987 ENDIF !--- IF (ARG.LE.DXSD2 .AND. ARG.GE.DXSD2N)
988 CSMID(I,LL)=CLFR
989 !! !
990 !! !--- Here the condensate is adjusted to be only over the cloudy area
991 !! !
992 !! IF (CLFR.GT.0. .AND. QCLD.LE.0.) THEN
993 !! !
994 !! !--- Put in modest amounts of cloud water & cloud ice for partially cloudy grids
995 !! !
996 !! QPCLDY=MIN(.01*QSAT, QOVRCST(I,LL))
997 !! IF (TCLD .GE. H0) THEN
998 !! QWMID(I,LL)=QPCLDY
999 !! ELSE
1000 !! QIMID(I,LL)=QPCLDY
1001 !! ENDIF
1002 !! ENDIF !--- End IF (CLFR.GT.0. .AND. QCLD.LE.0.)
1003 255 CONTINUE !--- End DO L=1,LML
1004 ENDDO !--- End DO I=MYIS,MYIE
1005 !
1006 !***********************************************************************
1007 !****************** END OF GRID-SCALE CLOUD FRACTIONS ****************
1008 !
1009 !--- COMPUTE CONVECTIVE CLOUD COVER FOR RADIATION
1010 !
1011 !--- The parameterization of Slingo (1987, QJRMS, Table 1, p. 904) is
1012 ! used for convective cloud fraction as a function of precipitation
1013 ! rate. Cloud fractions have been increased by 20% for each rainrate
1014 ! interval so that shallow, nonprecipitating convection is ascribed a
1015 ! constant cloud fraction of 0.1 (Ferrier, Feb '02).
1016 !***********************************************************************
1017 !
1018 IF (CNCLD) THEN
1019 DO I=MYIS,MYIE
1020 !
1021 !*** CLOUD TOPS AND BOTTOMS COME FROM CUCNVC
1022 ! Convective clouds need to be at least 2 model layers thick
1023 !
1024 IF (CUBOT(I,J)-CUTOP(I,J) .GT. 1.0) THEN
1025 !--- Compute convective cloud fractions if appropriate (Ferrier, Feb '02)
1026 CLFR=CC(1)
1027 PMOD=CUPPT(I,J)*CONVPRATE
1028 IF (PMOD .GT. PPT(1)) THEN
1029 DO NC=1,10
1030 IF(PMOD.GT.PPT(NC)) NMOD=NC
1031 ENDDO
1032 IF (NMOD .GE. 10) THEN
1033 CLFR=CC(10)
1034 ELSE
1035 CC1=CC(NMOD)
1036 CC2=CC(NMOD+1)
1037 P1=PPT(NMOD)
1038 P2=PPT(NMOD+1)
1039 CLFR=CC1+(CC2-CC1)*(PMOD-P1)/(P2-P1)
1040 ENDIF !--- End IF (NMOD .GE. 10) ...
1041 CLFR=MIN(H1, CLFR)
1042 ENDIF !--- End IF (PMOD .GT. PPT(1)) ...
1043 !
1044 !*** ADD LVL TO BE CONSISTENT WITH OTHER WORKING ARRAYS
1045 !
1046 LVLIJ=LVL(I,J)
1047 LCNVT=NINT(CUTOP(I,J))+LVLIJ
1048 LCNVT=MIN(LM,LCNVT)
1049 LCNVB=NINT(CUBOT(I,J))+LVLIJ
1050 LCNVB=MIN(LM,LCNVB)
1051 !! !
1052 !! !---- For debugging
1053 !! !
1054 !! WRITE(6,"(2(A,I3),2(A,I2),2(A,F5.2),2(A,I2),A,F6.4)")
1055 !! & ' J=',J,' I=',I,' LCNVB=',LCNVB,' LCNVT=',LCNVT
1056 !! &, ' CUBOT=',CUBOT(I,J),' CUTOP=',CUTOP(I,J)
1057 !! &,' LVL=',LVLIJ,' LMH=',LMH(I,J),' CCMID=',CLFR
1058 !! !
1059 !
1060 !--- Build in small amounts of subgrid-scale convective condensate
1061 ! (simple assumptions), but only if the convective cloud fraction
1062 ! exceeds that of the grid-scale cloud fraction
1063 !
1064 DO LL=LCNVT,LCNVB
1065 ARG=MAX(H0, H1-CSMID(I,LL))
1066 CCMID(I,LL)=MIN(ARG,CLFR)
1067 ENDDO !--- End DO LL=LCNVT,LCNVB
1068 ENDIF !--- IF (CUBOT(I,J)-CUTOP(I,J) .GT. 1.0) ...
1069 ENDDO !--- End DO I loop
1070 ENDIF !--- End IF (CNCLD) ...
1071 !
1072 !*********************************************************************
1073 !*************** END OF CONVECTIVE CLOUD FRACTIONS *****************
1074 !*********************************************************************
1075 !***
1076 !*** DETERMINE THE FRACTIONAL CLOUD COVERAGE FOR HIGH, MID
1077 !*** AND LOW OF CLOUDS FROM THE CLOUD COVERAGE AT EACH LEVEL
1078 !***
1079 !*** NOTE: THIS IS FOR DIAGNOSTICS ONLY!!!
1080 !***
1081 !***
1082 DO 500 I=MYIS,MYIE
1083 !!
1084 DO L=0,LM
1085 CLDAMT(L)=0.
1086 ENDDO
1087 !!
1088 !!*** NOW GOES LOW, MIDDLE, HIGH
1089 !!
1090 DO 480 NLVL=1,3
1091 CLDMAX=0.
1092 MALVL=LM
1093 LLTOP=LM+1-LTOP(NLVL)+LVL(I,J)
1094 !!***
1095 !!*** GO TO THE NEXT CLOUD LAYER IF THE TOP OF THE CLOUD-TYPE IN
1096 !!*** QUESTION IS BELOW GROUND OR IS IN THE LOWEST LAYER ABOVE GROUND.
1097 !!***
1098 IF(LLTOP.GE.LM)GO TO 480
1099 !!
1100 IF(NLVL.GT.1)THEN
1101 LLBOT=LM+1-LTOP(NLVL-1)-1+LVL(I,J)
1102 LLBOT=MIN(LLBOT,LM1)
1103 ELSE
1104 LLBOT=LM1
1105 ENDIF
1106 !!
1107 DO 435 L=LLTOP,LLBOT
1108 CLDAMT(L)=AMAX1(CSMID(I,L),CCMID(I,L))
1109 IF(CLDAMT(L).GT.CLDMAX)THEN
1110 MALVL=L
1111 CLDMAX=CLDAMT(L)
1112 ENDIF
1113 435 CONTINUE
1114 !!*********************************************************************
1115 !! NOW, CALCULATE THE TOTAL CLOUD FRACTION IN THIS PRESSURE DOMAIN
1116 !! USING THE METHOD DEVELOPED BY Y.H., K.A.C. AND A.K. (NOV., 1992).
1117 !! IN THIS METHOD, IT IS ASSUMED THAT SEPERATED CLOUD LAYERS ARE
1118 !! RADOMLY OVERLAPPED AND ADJACENT CLOUD LAYERS ARE MAXIMUM OVERLAPPED.
1119 !! VERTICAL LOCATION OF EACH TYPE OF CLOUD IS DETERMINED BY THE THICKEST
1120 !! CONTINUING CLOUD LAYERS IN THE DOMAIN.
1121 !!*********************************************************************
1122 CL1=0.0
1123 CL2=0.0
1124 KBT1=LLBOT
1125 KBT2=LLBOT
1126 KTH1=0
1127 KTH2=0
1128 !!
1129 DO 450 LL=LLTOP,LLBOT
1130 L=LLBOT-LL+LLTOP
1131 BIT1=.FALSE.
1132 CR1=CLDAMT(L)
1133 BITX=(PINT(I,L).GE.PTOPC(NLVL+1)).AND. &
1134 & (PINT(I,L).LT.PTOPC(NLVL)).AND. &
1135 & (CLDAMT(L).GT.0.0)
1136 BIT1=BIT1.OR.BITX
1137 IF(.NOT.BIT1)GO TO 450
1138 !!***
1139 !!*** BITY=T: FIRST CLOUD LAYER; BITZ=T:CONSECUTIVE CLOUD LAYER
1140 !!*** NOTE: WE ASSUME THAT THE THICKNESS OF EACH CLOUD LAYER IN THE
1141 !!*** DOMAIN IS LESS THAN 200 MB TO AVOID TOO MUCH COOLING OR
1142 !!*** HEATING. SO WE SET CTHK(NLVL)=200*E2. BUT THIS LIMIT MAY
1143 !!*** WORK WELL FOR CONVECTIVE CLOUDS. MODIFICATION MAY BE
1144 !!*** NEEDED IN THE FUTURE.
1145 !!***
1146 BITY=BITX.AND.(KTH2.LE.0)
1147 BITZ=BITX.AND.(KTH2.GT.0)
1148 !!
1149 IF(BITY)THEN
1150 KBT2=L
1151 KTH2=1
1152 ENDIF
1153 !!
1154 IF(BITZ)THEN
1155 KTOP1=KBT2-KTH2+1
1156 DPCL=PMID(I,KBT2)-PMID(I,KTOP1)
1157 IF(DPCL.LT.CTHK(NLVL))THEN
1158 KTH2=KTH2+1
1159 ELSE
1160 KBT2=KBT2-1
1161 ENDIF
1162 ENDIF
1163 IF(BITX)CL2=AMAX1(CL2,CR1)
1164 !!***
1165 !!*** AT THE DOMAIN BOUNDARY OR SEPARATED CLD LAYERS, RANDOM OVERLAP.
1166 !!*** CHOOSE THE THICKEST OR THE LARGEST FRACTION AMT AS THE CLD
1167 !!*** LAYER IN THAT DOMAIN.
1168 !!***
1169 BIT2=.FALSE.
1170 BITY=BITX.AND.(CLDAMT(L-1).LE.0.0.OR. &
1171 PINT(I,L-1).LT.PTOPC(NLVL+1))
1172 BITZ=BITY.AND.CL1.GT.0.0
1173 BITW=BITY.AND.CL1.LE.0.0
1174 BIT2=BIT2.OR.BITY
1175 IF(.NOT.BIT2)GO TO 450
1176 !!
1177 IF(BITZ)THEN
1178 KBT1=INT((CL1*KBT1+CL2*KBT2)/(CL1+CL2))
1179 KTH1=INT((CL1*KTH1+CL2*KTH2)/(CL1+CL2))+1
1180 CL1=CL1+CL2-CL1*CL2
1181 ENDIF
1182 !!
1183 IF(BITW)THEN
1184 KBT1=KBT2
1185 KTH1=KTH2
1186 CL1=CL2
1187 ENDIF
1188 !!
1189 IF(BITY)THEN
1190 KBT2=LLBOT
1191 KTH2=0
1192 CL2=0.0
1193 ENDIF
1194 450 CONTINUE
1195 !
1196 CLDCFR(I,NLVL)=AMIN1(1.0,CL1)
1197 MTOP(I,NLVL)=MIN(KBT1,KBT1-KTH1+1)
1198 MBOT(I,NLVL)=KBT1
1199 480 CONTINUE
1200 500 CONTINUE
1201
1202 !***
1203 !*** SET THE UN-NEEDED TAUDAR TO ONE
1204 !***
1205 DO I=MYIS,MYIE
1206 TAUDAR(I)=1.0
1207 ENDDO
1208 !----------------------------------------------------------------------
1209 ! NOW, CALCULATE THE CLOUD RADIATIVE PROPERTIES AFTER DAVIS (1982),
1210 ! HARSHVARDHAN ET AL (1987) AND Y.H., K.A.C. AND A.K. (1993).
1211 !
1212 ! UPDATE: THE FOLLOWING PARTS ARE MODIFIED, AFTER Y.T.H. (1994), TO
1213 ! CALCULATE THE RADIATIVE PROPERTIES OF CLOUDS ON EACH MODEL
1214 ! LAYER. BOTH CONVECTIVE AND STRATIFORM CLOUDS ARE USED
1215 ! IN THIS CALCULATIONS.
1216 !
1217 ! QINGYUN ZHAO 95-3-22
1218 !
1219 !----------------------------------------------------------------------
1220 !
1221 !***
1222 !*** INITIALIZE ARRAYS FOR USES LATER
1223 !***
1224
1225 DO 600 I=MYIS,MYIE
1226 LML=LMH(I,J)
1227 LVLIJ=LVL(I,J)
1228 !
1229 !***
1230 !*** NOTE: LAYER=1 IS THE SURFACE, AND LAYER=2 IS THE FIRST CLOUD
1231 !*** LAYER ABOVE THE SURFACE AND SO ON.
1232 !***
1233 EMIS(I,1)=1.0
1234 KTOP(I,1)=LP1
1235 KBTM(I,1)=LP1
1236 CAMT(I,1)=1.0
1237 KCLD(I)=2
1238 !
1239 DO NBAND=1,NB
1240 RRCL(I,NBAND,1)=0.0
1241 TTCL(I,NBAND,1)=1.0
1242 ENDDO
1243 !
1244 DO 510 L=2,LP1
1245 CAMT(I,L)=0.0
1246 KTOP(I,L)=1
1247 KBTM(I,L)=1
1248 EMIS(I,L)=0.0
1249 !
1250 DO NBAND=1,NB
1251 RRCL(I,NBAND,L)=0.0
1252 TTCL(I,NBAND,L)=1.0
1253 ENDDO
1254 510 CONTINUE
1255
1256 !### End changes so far
1257 !***
1258 !*** NOW CALCULATE THE AMOUNT, TOP, BOTTOM AND TYPE OF EACH CLOUD LAYER
1259 !*** CLOUD TYPE=1: STRATIFORM CLOUD
1260 !*** TYPE=2: CONVECTIVE CLOUD
1261 !*** WHEN BOTH CONVECTIVE AND STRATIFORM CLOUDS EXIST AT THE SAME POINT,
1262 !*** SELECT CONVECTIVE CLOUD WITH THE HIGHER CLOUD FRACTION.
1263 !*** CLOUD LAYERS ARE SEPARATED BY TOTAL ABSENCE OF CLOUDINESS.
1264 !*** NOTE: THERE IS ONLY ONE CONVECTIVE CLOUD LAYER IN ONE COLUMN.
1265 !*** KTOP AND KBTM ARE THE TOP AND BOTTOM OF EACH CLOUD LAYER IN TERMS
1266 !*** OF MODEL LEVEL.
1267 !***
1268 NEW_CLOUD=.TRUE.
1269 !
1270 DO L=2,LML
1271 LL=LML-L+1+LVLIJ !-- Model layer
1272 CLFR=MAX(CCMID(I,LL),CSMID(I,LL)) !-- Cloud fraction in layer
1273 CLFR1=MAX(CCMID(I,LL+1),CSMID(I,LL+1)) !-- Cloud fraction in lower layer
1274 !-------------------
1275 IF (CLFR .GE. CLFRMIN) THEN
1276 !--- Cloud present at level
1277 IF (NEW_CLOUD) THEN
1278 !--- New cloud layer
1279 IF(L==2.AND.CLFR1>=CLFRmin)THEN
1280 KBTM(I,KCLD(I))=LL+1
1281 CAMT(I,KCLD(I))=CLFR1
1282 ELSE
1283 KBTM(I,KCLD(I))=LL
1284 CAMT(I,KCLD(I))=CLFR
1285 ENDIF
1286 NEW_CLOUD=.FALSE.
1287 ELSE
1288 !--- Existing cloud layer
1289 CAMT(I,KCLD(I))=AMAX1(CAMT(I,KCLD(I)), CLFR)
1290 ENDIF ! End IF (NEW_CLOUD .EQ. 0) ...
1291 ELSE IF (CLFR1 .GE. CLFRMIN) THEN
1292 !--- Cloud is not present at level but did exist at lower level, then ...
1293 IF (L .EQ. 2) THEN
1294 !--- For the case of ground fog
1295 KBTM(I,KCLD(I))=LL+1
1296 CAMT(I,KCLD(I))=CLFR1
1297 ENDIF
1298 KTOP(I,KCLD(I))=LL+1
1299 NEW_CLOUD=.TRUE.
1300 KCLD(I)=KCLD(I)+1
1301 CAMT(I,KCLD(I))=0.0
1302 ENDIF
1303 !-------------------
1304 ENDDO !--- End DO L loop
1305 !***
1306 !*** THE REAL NUMBER OF CLOUD LAYERS IS (THE FIRST IS THE GROUND;
1307 !*** THE LAST IS THE SKY):
1308 !***
1309 NCLDS(I)=KCLD(I)-2
1310 NCLD=NCLDS(I)
1311 !***
1312 !*** NOW CALCULATE CLOUD RADIATIVE PROPERTIES
1313 !***
1314 IF(NCLD.GE.1)THEN
1315 !***
1316 !*** NOTE: THE FOLLOWING CALCULATIONS, THE UNIT FOR PRESSURE IS MB!!!
1317 !***
1318 DO 580 NC=2,NCLD+1
1319 !
1320 TauC=0. !--- Total optical depth for each cloud layer (solar & longwave)
1321 QSUM=0.0
1322 NKTP=LP1
1323 NBTM=0
1324 BITX=CAMT(I,NC).GE.CLFRMIN
1325 NKTP=MIN(NKTP,KTOP(I,NC))
1326 NBTM=MAX(NBTM,KBTM(I,NC))
1327 !
1328 DO LL=NKTP,NBTM
1329 IF(LL.GE.KTOP(I,NC).AND.LL.LE.KBTM(I,NC).AND.BITX)THEN
1330 PRS1=PINT(I,LL)*0.01
1331 PRS2=PINT(I,LL+1)*0.01
1332 DELP=PRS2-PRS1
1333 TCLD=TMID(I,LL)-T0C
1334 QSUM=QSUM+QMID(I,LL)*DELP*(PRS1+PRS2) &
1335 & /(120.1612*SQRT(TMID(I,LL)))
1336 !
1337 !***********************************************************************
1338 !**** IMPORTANT NOTES concerning input cloud optical properties ******
1339 !***********************************************************************
1340 !
1341 !--- The simple optical depth parameterization from eq. (1) of Harshvardhan
1342 ! et al. (1989, JAS, p. 1924; hereafter referred to as HRCD by authorship)
1343 ! is used for convective cloud properties with some simple changes.
1344 !
1345 !--- The optical depth Tau is Tau=CTau*DELP, where values of CTau are
1346 ! described below.
1347 ! 1) CTau=0.08*(Qc/Q0) for cloud water mixing ratio (Qc), where
1348 ! Q0 is assumed to be the threshold mixing ratio for "thick anvils",
1349 ! as noted in the 2nd paragraph after eq. (1) in Harshvardhan et al.
1350 ! (1989). A value of Q0=0.1 g/kg is assumed based on experience w/
1351 ! cloud observations, and it is intended only to be a crude scaling
1352 ! factor for "order of magnitude" effects. The functional dependence
1353 ! on mixing ratio is based on Stephens (1978, JAS, p. 2124, eq. 7).
1354 ! Result: CTau=800.*Qc => note that the "800." factor is referred to
1355 ! as an absorption coefficient
1356 ! 2) For an assumed value of Q0=1 g/kg for "thick anvils", then
1357 ! CTau=80.*Qc, or an absorption coefficient that is an order of
1358 ! magnitude less.
1359 ! => ABSCOEF_W can vary from 100. to 1000. !!
1360 ! 3) From p. 3105 of Dudhia (1989), values of
1361 ! 0.14 (m**2/g) * 1000 (g/kg) / 9.81 (m/s**2) = 14.27 /Pa
1362 ! => 14.27 (/Pa) * 100 (Pa/mb) = 1427 /mb
1363 ! 4) From Dudhia's SW radiation, ABSCOEF_W ~ 1000. after units conversion
1364 ! 5) Again from p. 3105 of Dudhia (1989), he notes that ice absorption
1365 ! coefficients are roughly half those of cloud water, it was decided
1366 ! to keep this simple and assume half that of water.
1367 ! => ABSCOEF_I=0.5*ABSCOEF_W
1368 !
1369 !--- For convection, the following is assumed:
1370 ! 1) A characteristic water/ice mixing ratio (Qconv)
1371 ! 2) A temperature threshold for water or ice (TRAD_ice)
1372 !
1373 !-----------------------------------------------------------------------
1374 !
1375 CTau=0.
1376 !-- For crude estimation of convective cloud optical depths
1377 IF (CCMID(I,LL) .GE. CLFRmin) THEN
1378 IF (TCLD .GE. TRAD_ice) THEN
1379 CTau=CTauCW !--- Convective cloud water
1380 ELSE
1381 CTau=CTauCI !--- Convective ice
1382 ENDIF
1383 ! CTau=CTau*CCMID(I,LL) !--- Reduce by convective cloud fraction
1384 ENDIF
1385 !
1386 !-- For crude estimation of grid-scale cloud optical depths
1387 !
1388 !-- => The following 2 lines were intended to reduce cloud optical depths further
1389 ! than what's parameterized in the NAM and what's theoretically justified
1390 ! CTau=CTau+CSMID(I,LL)* &
1391 ! & ( ABSCOEF_W*QWMID(I,LL)+ABSCOEF_I*QIMID(I,LL) )
1392 CTau=CTau+ABSCOEF_W*QWMID(I,LL)+ABSCOEF_I*QIMID(I,LL)
1393 TauC=TauC+DELP*CTau
1394 ENDIF !--- End IF(LL.GE.KTOP(I,NC) ....
1395 ENDDO !--- End DO LL
1396 !
1397 IF(BITX)EMIS(I,NC)=1.0-EXP(ABSCOEF_LW*TauC)
1398 IF(QSUM.GE.EPSQ1)THEN
1399 !
1400 DO 570 NBAND=1,NB
1401 IF(BITX)THEN
1402 PROD=ABCFF(NBAND)*QSUM
1403 DDX=TauC/(TauC+PROD)
1404 EEX=1.0-DDX
1405 IF(ABS(EEX).GE.1.E-8)THEN
1406 DD=DDX
1407 EE=EEX
1408 FF=1.0-DD*0.85
1409 AA=MIN(50.0,SQRT(3.0*EE*FF)*TauC)
1410 AA=EXP(-AA)
1411 BB=FF/EE
1412 GG=SQRT(BB)
1413 DD=(GG+1.0)*(GG+1.0)-(GG-1.0)*(GG-1.0)*AA*AA
1414 RRCL(I,NBAND,NC)=MAX(0.1E-5,(BB-1.0)*(1.0-AA*AA)/DD)
1415 TTCL(I,NBAND,NC)=AMAX1(0.1E-5,4.0*GG*AA/DD)
1416 ENDIF
1417 ENDIF
1418 570 CONTINUE
1419 ENDIF
1420 580 CONTINUE
1421 !
1422 ENDIF
1423 !
1424 600 CONTINUE
1425 !*********************************************************************
1426 !****************** COMPUTE OZONE AT MIDLAYERS *********************
1427 !*********************************************************************
1428 !
1429 !*** MODIFY PRESSURE AT THE TOP MODEL LAYER TO ACCOUNT FOR THE TOTAL
1430 !*** OZONE FROM MODEL TOP (PINT_1) TO THE TOP OF THE ATMOSPHERE (0 MB)
1431 !
1432 DO I=MYIS,MYIE
1433 FCTR=PINT(I,2)/(PINT(I,2)-PINT(I,1))
1434 POZN(I,1)=FCTR*(PMID(I,1)-PINT(I,1))
1435 ENDDO
1436 !
1437 CALL OZON2D(LM,POZN,XLAT,OZN, &
1438 MYIS,MYIE, &
1439 ids,ide, jds,jde, kds,kde, &
1440 ims,ime, jms,jme, kms,kme, &
1441 its,ite, jts,jte, kts,kte )
1442 !
1443 !***
1444 !*** NOW THE VARIABLES REQUIRED BY RADFS HAVE BEEN CALCULATED.
1445 !***
1446 !----------------------------------------------------------------------
1447 !***
1448 !*** CALL THE GFDL RADIATION DRIVER
1449 !***
1450 !***
1451 Jndx=J
1452 CALL RADFS &
1453 & (PSFC,PMID,PINT,QMID,TMID,OZN,TSKN,SLMSK,ALBEDO,XLAT &
1454 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
1455 &, CAMT,KTOP,KBTM,NCLDS,EMIS,RRCL,TTCL &
1456 &, COSZ,TAUDAR,1 &
1457 &, 1,0 &
1458 &, ITIMSW,ITIMLW &
1459 &, TENDS(ITS,KTS,J),TENDL(ITS,KTS,J) &
1460 &, FLWUP,FSWUP,FSWDN,FSWDNS,FSWUPS,FLWDNS,FLWUPS,FSWDNSC &
1461 &, ids,ide, jds,jde, kds,kde &
1462 &, ims,ime, jms,jme, kms,kme &
1463 ! begin debugging radiation
1464 &, its,ite, jts,jte, kts,kte &
1465 &, imd,jmd, Jndx )
1466 ! end debugging radiation
1467 !----------------------------------------------------------------------
1468 IF(LONG)THEN
1469 !
1470 !-- All fluxes in W/m**2
1471 !--- GLW => downward longwave at the surface (formerly RLWIN)
1472 !--- RLWTOA => outgoing longwave at the top of the atmosphere
1473 !-- Note: RLWOUT & SIGT4 have been removed because they are no longer being used!
1474 !
1475 DO I=MYIS,MYIE
1476 GLW(I,J)=FLWDNS(I)
1477 RLWTOA(I,J)=FLWUP(I)
1478 ENDDO
1479 ENDIF
1480 !
1481 IF(SHORT)THEN
1482 !
1483 !-- All fluxes in W/m**2
1484 !--- GSW => NET shortwave at the surface
1485 !--- RSWIN => incoming shortwave at the surface (all sky)
1486 !--- RSWINC => clear-sky incoming shortwave at the surface
1487 !--- RSWTOA => outgoing (reflected) shortwave at the top of the atmosphere
1488 !
1489 DO I=MYIS,MYIE
1490 GSW(I,J)=FSWDNS(I)-FSWUPS(I)
1491 RSWIN(I,J) =FSWDNS(I)
1492 RSWINC(I,J)=FSWDNSC(I)
1493 RSWTOA(I,J)=FSWUP(I)
1494 ENDDO
1495 ENDIF
1496 !
1497 !*** ARRAYS ACFRST AND ACFRCV ACCUMULATE AVERAGE STRATIFORM AND
1498 !*** CONVECTIVE CLOUD FRACTIONS, RESPECTIVELY.
1499 !*** ACCUMLATE THESE VARIABLES ONLY ONCE PER RADIATION CALL.
1500 !
1501 !*** ASSUME RANDOM OVERLAP BETWEEN LOW, MIDDLE, & HIGH LAYERS.
1502 !
1503 !*** UPDATE NEW 3D CLOUD FRACTION (CLDFRA)
1504 !
1505 DO I=MYIS,MYIE
1506 CFRACL(I,J)=CLDCFR(I,1)
1507 CFRACM(I,J)=CLDCFR(I,2)
1508 CFRACH(I,J)=CLDCFR(I,3)
1509 IF(CNCLD)THEN
1510 CFSmax=0. !-- Maximum cloud fraction (stratiform component)
1511 CFCmax=0. !-- Maximum cloud fraction (convective component)
1512 DO L=1,LMH(I,J)
1513 LL=L+LVL(I,J)
1514 CFSmax=MAX(CFSmax, CSMID(I,LL) )
1515 CFCmax=MAX(CFCmax, CCMID(I,LL) )
1516 ENDDO
1517 ACFRST(I,J)=ACFRST(I,J)+CFSmax
1518 NCFRST(I,J)=NCFRST(I,J)+1
1519 ACFRCV(I,J)=ACFRCV(I,J)+CFCmax
1520 NCFRCV(I,J)=NCFRCV(I,J)+1
1521 ELSE
1522 !--- Count only locations with grid-scale cloudiness, ignore convective clouds
1523 ! (option not used, but if so set to the total cloud fraction)
1524 CFRAVG=1.-(1.-CFRACL(I,J))*(1.-CFRACM(I,J))*(1.-CFRACH(I,J))
1525 ACFRST(I,J)=ACFRST(I,J)+CFRAVG
1526 NCFRST(I,J)=NCFRST(I,J)+1
1527 ENDIF
1528 !--- Flip 3D cloud fractions in the vertical and save time
1529 LML=LMH(I,J)
1530 DO L=1,LML
1531 LL=LML-L+1+LVL(I,J)
1532 CLDFRA(I,L,J)=MAX(CCMID(I,LL),CSMID(I,LL))
1533 ENDDO
1534 ENDDO !-- I index
1535 !***
1536 !*** THIS ROW IS FINISHED. GO TO NEXT
1537 !***
1538 ! *********************
1539 700 CONTINUE
1540 ! *********************
1541 !----------------------------------------------------------------------
1542 !***
1543 !*** CALLS TO RADIATION THIS TIME STEP ARE COMPLETE.
1544 !***
1545 !----------------------------------------------------------------------
1546 ! begin debugging radiation
1547 ! FSWrat=0.
1548 ! if (RSWIN(imd,jmd) .gt. 0.) &
1549 ! FSWrat=(RSWIN(imd,jmd)-GSW(imd,jmd))/RSWIN(imd,jmd)
1550 ! write(6,"(2a,2i5,7f9.2)") &
1551 ! '{rad3 imd,jmd,GSW,RSWIN,RSWOUT=RSWIN-GSW,RSWINC,GLW,' &
1552 ! ,'ALBEDO,RSWOUT/RSWIN = '&
1553 ! ,imd,jmd, GSW(imd,jmd),RSWIN(imd,jmd) &
1554 ! ,RSWIN(imd,jmd)-GSW(imd,jmd),RSWINC(imd,jmd),GLW(imd,jmd) &
1555 ! ,ALB(imd,jmd),FSWrat
1556 ! end debugging radiation
1557 !----------------------------------------------------------------------
1558 !
1559 !--- Need to save LW & SW tendencies since radiation calculates both and this block
1560
1561 END SUBROUTINE RADTN
1562
1563 !----------------------------------------------------------------------
1564
1565 REAL FUNCTION GAUSIN(xsd)
1566 REAL, PARAMETER :: crit=1.e-3
1567 REAL A1,A2,RN,B1,B2,B3,SUM
1568 !
1569 ! This function calculate area under the Gaussian curve between mean
1570 ! and xsd # of standard deviation (03/22/2004 Hsin-mu Lin)
1571 !
1572 a1=xsd*RSQR
1573 a2=exp(-0.5*xsd**2)
1574 rn=1.
1575 b1=1.
1576 b2=1.
1577 b3=1.
1578 sum=1.
1579 do while (b2 .gt. crit)
1580 rn=rn+1.
1581 b2=xsd**2/(2.*rn-1.)
1582 b3=b1*b2
1583 sum=sum+b3
1584 b1=b3
1585 enddo
1586 GAUSIN=a1*a2*sum
1587 RETURN
1588 END FUNCTION GAUSIN
1589
1590 !----------------------------------------------------------------------
1591
1592 SUBROUTINE ZENITH(TIMES,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN, &
1593 MYIS,MYIE,MYJS,MYJE, &
1594 IDS,IDE, JDS,JDE, KDS,KDE, &
1595 IMS,IME, JMS,JME, KMS,KME, &
1596 ITS,ITE, JTS,JTE, KTS,KTE, &
1597 OMG_URB2D) !Optional urban
1598 !----------------------------------------------------------------------
1599 IMPLICIT NONE
1600 !----------------------------------------------------------------------
1601 INTEGER, INTENT(IN) :: IDS,IDE, JDS,JDE, KDS,KDE , &
1602 IMS,IME, JMS,JME, KMS,KME , &
1603 ITS,ITE, JTS,JTE, KTS,KTE
1604 INTEGER, INTENT(IN) :: MYJS,MYJE,MYIS,MYIE
1605
1606 REAL, INTENT(IN) :: TIMES
1607 REAL, INTENT(OUT) :: HOUR,DAYI
1608 INTEGER, INTENT(IN) :: IHRST
1609
1610 INTEGER, INTENT(IN), DIMENSION(3) :: IDAT
1611 REAL, INTENT(IN), DIMENSION(IMS:IME,JMS:JME) :: GLAT,GLON
1612 REAL, INTENT(OUT), DIMENSION(IMS:IME,JMS:JME) :: CZEN
1613 REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme) :: OMG_URB2D !Optional urban
1614
1615 REAL, PARAMETER :: GSTC1=24110.54841,GSTC2=8640184.812866, &
1616 GSTC3=9.3104E-2,GSTC4=-6.2E-6, &
1617 PI=3.1415926,PI2=2.*PI,PIH=0.5*PI, &
1618 !#$ DEG2RD=1.745329E-2,OBLIQ=23.440*DEG2RD, &
1619 DEG2RD=3.1415926/180.,OBLIQ=23.440*DEG2RD, &
1620 ZEROJD=2451545.0
1621
1622 REAL :: DAY,YFCTR,ADDDAY,STARTYR,DATJUL,DIFJD,SLONM, &
1623 ANOM,SLON,DEC,RA,DATJ0,TU,STIM0,SIDTIM,HRANG
1624 REAL :: HRLCL,SINALT
1625 INTEGER :: KMNTH,KNT,IDIFYR,J,I
1626 LOGICAL :: LEAP
1627 !-----------------------------------------------------------------------
1628 !-----------------------------------------------------------------------
1629 INTEGER :: MONTH (12)
1630 !-----------------------------------------------------------------------
1631 DATA MONTH/31,28,31,30,31,30,31,31,30,31,30,31/
1632 !***********************************************************************
1633 ! SAVE MONTH
1634 DAY=0.
1635 LEAP=.FALSE.
1636 IF(MOD(IDAT(3),4).EQ.0)THEN
1637 MONTH(2)=29
1638 LEAP=.TRUE.
1639 ENDIF
1640 IF(IDAT(1).GT.1)THEN
1641 KMNTH=IDAT(1)-1
1642 DO 10 KNT=1,KMNTH
1643 DAY=DAY+REAL(MONTH(KNT))
1644 10 CONTINUE
1645 ENDIF
1646 !***
1647 !*** CALCULATE EXACT NUMBER OF DAYS FROM BEGINNING OF YEAR TO
1648 !*** FORECAST TIME OF INTEREST
1649 !***
1650 DAY=DAY+REAL(IDAT(2)-1)+(REAL(IHRST)+TIMES/3600.)/24.
1651 DAYI=REAL(INT(DAY)+1)
1652 HOUR=(DAY-DAYI+1.)*24.
1653 YFCTR=2000.-IDAT(3)
1654 !-----------------------------------------------------------------------
1655 !***
1656 !*** FIND CELESTIAL LONGITUDE OF THE SUN THEN THE SOLAR DECLINATION AND
1657 !*** RIGHT ASCENSION.
1658 !***
1659 !-----------------------------------------------------------------------
1660 IDIFYR=IDAT(3)-2000
1661 !***
1662 !*** FIND JULIAN DATE OF START OF THE RELEVANT YEAR
1663 !*** ADDING IN LEAP DAYS AS NEEDED
1664 !***
1665 IF(IDIFYR.LT.0)THEN
1666 ADDDAY=REAL(IDIFYR/4)
1667 ELSE
1668 ADDDAY=REAL((IDIFYR+3)/4)
1669 ENDIF
1670 STARTYR=ZEROJD+IDIFYR*365.+ADDDAY-0.5
1671 !***
1672 !*** THE JULIAN DATE OF THE TIME IN QUESTION
1673 !***
1674 DATJUL=STARTYR+DAY
1675 !
1676 !*** DIFFERENCE OF ACTUAL JULIAN DATE FROM JULIAN DATE
1677 !*** AT 00H 1 January 2000
1678 !
1679 DIFJD=DATJUL-ZEROJD
1680 !
1681 !*** MEAN GEOMETRIC LONGITUDE OF THE SUN
1682 !
1683 SLONM=(280.460+0.9856474*DIFJD)*DEG2RD+YFCTR*PI2
1684 !
1685 !*** THE MEAN ANOMOLY
1686 !
1687 ANOM=(357.528+0.9856003*DIFJD)*DEG2RD
1688 !
1689 !*** APPARENT GEOMETRIC LONGITUDE OF THE SUN
1690 !
1691 SLON=SLONM+(1.915*SIN(ANOM)+0.020*SIN(2.*ANOM))*DEG2RD
1692 IF(SLON.GT.PI2)SLON=SLON-PI2
1693 !
1694 !*** DECLINATION AND RIGHT ASCENSION
1695 !
1696 DEC=ASIN(SIN(SLON)*SIN(OBLIQ))
1697 RA=ACOS(COS(SLON)/COS(DEC))
1698 IF(SLON.GT.PI)RA=PI2-RA
1699 !***
1700 !*** FIND THE GREENWICH SIDEREAL TIME THEN THE LOCAL SOLAR
1701 !*** HOUR ANGLE.
1702 !***
1703 DATJ0=STARTYR+DAYI-1.
1704 TU=(DATJ0-2451545.)/36525.
1705 STIM0=GSTC1+TU*(GSTC2+GSTC3*TU+GSTC4*TU*TU)
1706 SIDTIM=STIM0/3600.+YFCTR*24.+1.00273791*HOUR
1707 SIDTIM=SIDTIM*15.*DEG2RD
1708 IF(SIDTIM.LT.0.)SIDTIM=SIDTIM+PI2
1709 IF(SIDTIM.GT.PI2)SIDTIM=SIDTIM-PI2
1710 HRANG=SIDTIM-RA
1711 !
1712 DO 100 J=MYJS,MYJE
1713 DO 100 I=MYIS,MYIE
1714 ! HRLCL=HRANG-GLON(I,J)
1715 HRLCL=HRANG+GLON(I,J)+PI2
1716 !***
1717 !*** THE ZENITH ANGLE IS THE COMPLEMENT OF THE ALTITUDE THUS THE
1718 !*** COSINE OF THE ZENITH ANGLE EQUALS THE SINE OF THE ALTITUDE.
1719 !***
1720 SINALT=SIN(DEC)*SIN(GLAT(I,J))+COS(DEC)*COS(HRLCL)* &
1721 COS(GLAT(I,J))
1722 IF(SINALT.LT.0.)SINALT=0.
1723 CZEN(I,J)=SINALT
1724 if(present(OMG_URB2D))OMG_URB2D(I,J)=HRLCL !urban
1725 100 CONTINUE
1726 !***
1727 !*** IF THE FORECAST IS IN A DIFFERENT YEAR THAN THE START TIME,
1728 !*** RESET DAYI TO THE PROPER DAY OF THE NEW YEAR (IT MUST NOT BE
1729 !*** RESET BEFORE THE SOLAR ZENITH ANGLE IS COMPUTED).
1730 !***
1731 IF(DAYI.GT.365.)THEN
1732 IF(.NOT.LEAP)THEN
1733 DAYI=DAYI-365.
1734 ELSEIF(LEAP.AND.DAYI.GT.366.)THEN
1735 DAYI=DAYI-366.
1736 ENDIF
1737 ENDIF
1738 !
1739 END SUBROUTINE ZENITH
1740 !-----------------------------------------------------------------------
1741
1742 SUBROUTINE OZON2D (LK,POZN,XLAT,QO3, &
1743 MYIS,MYIE, &
1744 ids,ide, jds,jde, kds,kde, &
1745 ims,ime, jms,jme, kms,kme, &
1746 its,ite, jts,jte, kts,kte )
1747 !----------------------------------------------------------------------
1748 IMPLICIT NONE
1749 !----------------------------------------------------------------------
1750 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
1751 ims,ime, jms,jme, kms,kme , &
1752 its,ite, jts,jte, kts,kte
1753 INTEGER, INTENT(IN) :: LK,MYIS,MYIE
1754 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: POZN
1755 REAL, INTENT(IN), DIMENSION(its:ite) :: XLAT
1756 REAL, INTENT(INOUT), DIMENSION(its:ite,kts:kte) :: QO3
1757 !----------------------------------------------------------------------
1758 INTEGER, PARAMETER :: NL=81,NLP1=NL+1,LNGTH=37*NL
1759
1760 ! REAL, INTENT(IN), DIMENSION(37,NL) :: XDUO3N,XDO3N4,XDO3N2,XDO3N3
1761 ! REAL, INTENT(IN), DIMENSION(NL) :: PRGFDL
1762 !----------------------------------------------------------------------
1763 !----------------------------------------------------------------------
1764 INTEGER,DIMENSION(its:ite) :: JJROW
1765 REAL, DIMENSION(its:ite) :: TTHAN
1766 REAL, DIMENSION(its:ite,NL) :: QO3O3
1767
1768 INTEGER :: I,K,NUMITR,ILOG,IT,NHALF
1769 REAL :: TH2,DO3V,DO3VP,APHI,APLO
1770 !----------------------------------------------------------------------
1771 DO I=MYIS,MYIE
1772 TH2=0.2*XLAT(I)
1773 JJROW(I)=19.001-TH2
1774 TTHAN(I)=(19-JJROW(I))-TH2
1775 ENDDO
1776 !
1777 !*** SEASONAL AND SPATIAL INTERPOLATION DONE BELOW.
1778 !
1779 DO K=1,NL
1780 DO I=MYIS,MYIE
1781 DO3V=XDUO3N(JJROW(I),K)+RSIN1*XDO3N2(JJROW(I),K) &
1782 +RCOS1*XDO3N3(JJROW(I),K) &
1783 +RCOS2*XDO3N4(JJROW(I),K)
1784 DO3VP=XDUO3N(JJROW(I)+1,K)+RSIN1*XDO3N2(JJROW(I)+1,K) &
1785 +RCOS1*XDO3N3(JJROW(I)+1,K) &
1786 +RCOS2*XDO3N4(JJROW(I)+1,K)
1787 !
1788 !*** NOW LATITUDINAL INTERPOLATION
1789 !*** AND CONVERT O3 INTO MASS MIXING RATIO (ORIG DATA MPY BY 1.E4)
1790 !
1791 QO3O3(I,K)=1.E-4*(DO3V+TTHAN(I)*(DO3VP-DO3V))
1792 ENDDO
1793 ENDDO
1794 !***
1795 !*** VERTICAL INTERPOLATION FOR EACH GRIDPOINT (LINEAR IN LN P)
1796 !***
1797 NUMITR=0
1798 ILOG=NL
1799 20 CONTINUE
1800 ILOG=(ILOG+1)/2
1801 IF(ILOG.EQ.1)GO TO 25
1802 NUMITR=NUMITR+1
1803 GO TO 20
1804 25 CONTINUE
1805 !
1806 DO 60 K=1,LK
1807 !
1808 NHALF=(NL+1)/2
1809 DO I=MYIS,MYIE
1810 JJROW(I)=NHALF
1811 ENDDO
1812 !
1813 DO 40 IT=1,NUMITR
1814 NHALF=(NHALF+1)/2
1815 DO I=MYIS,MYIE
1816 IF(POZN(I,K).LT.PRGFDL(JJROW(I)-1))THEN
1817 JJROW(I)=JJROW(I)-NHALF
1818 ELSEIF(POZN(I,K).GE.PRGFDL(JJROW(I)))THEN
1819 JJROW(I)=JJROW(I)+NHALF
1820 ENDIF
1821 JJROW(I)=MIN(JJROW(I),NL)
1822 JJROW(I)=MAX(JJROW(I),2)
1823 ENDDO
1824 40 CONTINUE
1825 !
1826 DO 50 I=MYIS,MYIE
1827 IF(POZN(I,K).LT.PRGFDL(1))THEN
1828 QO3(I,K)=QO3O3(I,1)
1829 ELSE IF(POZN(I,K).GT.PRGFDL(NL))THEN
1830 QO3(I,K)=QO3O3(I,NL)
1831 ELSE
1832 APLO=ALOG(PRGFDL(JJROW(I)-1))
1833 APHI=ALOG(PRGFDL(JJROW(I)))
1834 QO3(I,K)=QO3O3(I,JJROW(I))+(ALOG(POZN(I,K))-APHI)/ &
1835 (APLO-APHI)* &
1836 (QO3O3(I,JJROW(I)-1)-QO3O3(I,JJROW(I)))
1837 ENDIF
1838 50 CONTINUE
1839 !
1840 60 CONTINUE
1841
1842 END SUBROUTINE OZON2D
1843 !-----------------------------------------------------------------------
1844
1845 ! SUBROUTINE ZERO2(ARRAY, &
1846 ! ids,ide, jds,jde, kds,kde, &
1847 ! ims,ime, jms,jme, kms,kme, &
1848 ! its,ite, jts,jte, kts,kte )
1849 !----------------------------------------------------------------------
1850 !IMPLICIT NONE
1851 !----------------------------------------------------------------------
1852 ! INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
1853 ! ims,ime, jms,jme, kms,kme , &
1854 ! its,ite, jts,jte, kts,kte
1855 ! REAL, INTENT(INOUT), DIMENSION(its:ite,jts:jte) :: ARRAY
1856 ! INTEGER :: I,J
1857 !----------------------------------------------------------------------
1858 ! DO J=jts,jte
1859 ! DO I=its,ite
1860 ! ARRAY(I,J)=0.
1861 ! ENDDO
1862 ! ENDDO
1863
1864 ! END SUBROUTINE ZERO2
1865
1866 !----------------------------------------------------------------
1867
1868 SUBROUTINE O3INT(PHALF,DDUO3N,DDO3N2,DDO3N3,DDO3N4, &
1869 ids,ide, jds,jde, kds,kde, &
1870 ims,ime, jms,jme, kms,kme, &
1871 its,ite, jts,jte, kts,kte )
1872 !----------------------------------------------------------------------
1873 IMPLICIT NONE
1874 !----------------------------------------------------------------------
1875 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
1876 ims,ime, jms,jme, kms,kme , &
1877 its,ite, jts,jte, kts,kte
1878
1879 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
1880 ! . . . .
1881 ! SUBPROGRAM: O3INT COMPUTE ZONAL MEAN OZONE FOR ETA LYRS
1882 ! PRGMMR: KENNETH CAMPANA ORG: W/NMC23 DATE: 89-07-07
1883 ! MICHAEL BALDWIN ORG: W/NMC22 DATE: 92-06-08
1884 !
1885 ! ABSTRACT: THIS CODE WRITTEN AT GFDL...
1886 ! CALCULATES SEASONAL ZONAL MEAN OZONE,EVERY 5 DEG OF LATITUDE,
1887 ! FOR CURRENT MODEL VERTICAL COORDINATE. OUTPUT DATA IN G/G * 1.E4
1888 ! CODE IS CALLED ONLY ONCE.
1889 !
1890 ! PROGRAM HISTORY LOG:
1891 ! 84-01-01 FELS AND SCHWARZKOPF,GFDL.
1892 ! 89-07-07 K. CAMPANA - ADAPTED STAND-ALONE CODE FOR IN-LINE USE.
1893 ! 92-06-08 M. BALDWIN - UPDATE TO RUN IN ETA MODEL
1894 !
1895 ! USAGE: CALL O3INT(O3,SIGL) OLD
1896 ! INPUT ARGUMENT LIST:
1897 ! PHALF - MID LAYER PRESSURE (K=LM+1 IS MODEL SURFACE)
1898 ! OUTPUT ARGUMENT LIST:
1899 ! DDUO3N - ZONAL MEAN OZONE DATA IN ALL MODEL LAYERS (G/G*1.E4)
1900 ! DDO3N2 DIMENSIONED(L,N),WHERE L(=37) IS LATITUDE BETWEEN
1901 ! DDO3N3 N AND S POLES,N=NUM OF VERTICAL LYRS(K=1 IS TOP LYR)
1902 ! DDO3N4 AND SEASON-WIN,SPR,SUM,FALL.
1903 ! IN COMMON
1904 !
1905 ! OUTPUT FILES:
1906 ! OUTPUT - PRINT FILE.
1907 !
1908 ! ATTRIBUTES:
1909 ! LANGUAGE: FORTRAN 200.
1910 !
1911 !$$$
1912 !.... PROGRAM O3INT FROM DAN SCHWARZKOPF-GETS ZONAL MEAN O3
1913 !.. OUTPUT O3 IS WINTER,SPRING,SUMMER,FALL (NORTHERN HEMISPHERE)
1914 !-----------------------------------------------------------------------
1915 ! INCLUDE "parmeta"
1916 !-----------------------------------------------------------------------
1917 ! *********************************************************
1918
1919 INTEGER :: N,NP,NP2,NM1
1920
1921 ! PARAMETER (N=LM,NP=N+1,NP2=N+2,NM1=N-1)
1922 ! *********************************************************
1923 !-----------------------------------------------------------------------
1924 !***
1925 !*** SEASONAL CLIMATOLOGIES OF O3 (OBTAINED FROM A PREVIOUSLY RUN
1926 !*** CODE WHICH INTERPOLATES O3 TO USER VERTICAL COORDINATE).
1927 !*** DEFINED AS 5 DEG LAT MEANS N.P.->S.P.
1928 !***
1929 REAL, INTENT(OUT), DIMENSION(37,kte):: DDUO3N,DDO3N2,DDO3N3,DDO3N4
1930
1931 ! C O M M O N /SAVMEM/
1932 ! ...WINTER.... ...SPRING.... ...SUMMER.... ....FALL.....
1933 ! 1 DDUO3N(37,LM), DDO3N2(37,LM), DDO3N3(37,LM), DDO3N4(37,LM)
1934 ! ..... K.CAMPANA OCTOBER 1988
1935 !CCC DIMENSION T41(NP2,2),O3O3(37,N,4)
1936 ! DIMENSION SIGL(N)
1937 ! *********************************************************
1938 REAL :: QI(82)
1939 REAL :: DDUO3(19,kts:kte),RO31(10,41),RO32(10,41),DUO3N(19,41)
1940 REAL :: TEMPN(19)
1941 REAL :: O3HI(10,25),O3LO1(10,16),O3LO2(10,16),O3LO3(10,16), &
1942 O3LO4(10,16)
1943 REAL :: O3HI1(10,16),O3HI2(10,9),PH1(45),PH2(37),P1(48),P2(33)
1944 REAL :: O35DEG(37,kts:kte)
1945 REAL :: RSTD(81),RO3(10,41),RO3M(10,40),RBAR(kts:kte),RDATA(81), &
1946 PHALF(kts:kte+1),P(81),PH(82)
1947
1948 INTEGER :: NKK,NK,NKP,K,L,NCASE,ITAPE,IPLACE,NKMM,NKM,KI,KK,KQ,JJ,KEN
1949 REAL :: O3RD,O3TOT,O3DU
1950
1951 EQUIVALENCE (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17))
1952 EQUIVALENCE (PH1(1),PH(1)),(PH2(1),PH(46))
1953 EQUIVALENCE (P1(1),P(1)),(P2(1),P(49))
1954 DATA PH1/ 0., &
1955 0.1027246E-04, 0.1239831E-04, 0.1491845E-04, 0.1788053E-04, &
1956 0.2135032E-04, 0.2540162E-04, 0.3011718E-04, 0.3558949E-04, &
1957 0.4192172E-04, 0.4922875E-04, 0.5763817E-04, 0.6729146E-04, &
1958 0.7834518E-04, 0.9097232E-04, 0.1053635E-03, 0.1217288E-03, &
1959 0.1402989E-03, 0.1613270E-03, 0.1850904E-03, 0.2119495E-03, &
1960 0.2423836E-03, 0.2768980E-03, 0.3160017E-03, 0.3602623E-03, &
1961 0.4103126E-03, 0.4668569E-03, 0.5306792E-03, 0.6026516E-03, &
1962 0.6839018E-03, 0.7759249E-03, 0.8803303E-03, 0.9987843E-03, &
1963 0.1133178E-02, 0.1285955E-02, 0.1460360E-02, 0.1660001E-02, &
1964 0.1888764E-02, 0.2151165E-02, 0.2452466E-02, 0.2798806E-02, &
1965 0.3197345E-02, 0.3656456E-02, 0.4185934E-02, 0.4797257E-02/
1966 DATA PH2/ &
1967 0.5503893E-02, 0.6321654E-02, 0.7269144E-02, 0.8368272E-02, &
1968 0.9644873E-02, 0.1112946E-01, 0.1285810E-01, 0.1487354E-01, &
1969 0.1722643E-01, 0.1997696E-01, 0.2319670E-01, 0.2697093E-01, &
1970 0.3140135E-01, 0.3660952E-01, 0.4274090E-01, 0.4996992E-01, &
1971 0.5848471E-01, 0.6847525E-01, 0.8017242E-01, 0.9386772E-01, &
1972 0.1099026E+00, 0.1286765E+00, 0.1506574E+00, 0.1763932E+00, &
1973 0.2065253E+00, 0.2415209E+00, 0.2814823E+00, 0.3266369E+00, &
1974 0.3774861E+00, 0.4345638E+00, 0.4984375E+00, 0.5697097E+00, &
1975 0.6490189E+00, 0.7370409E+00, 0.8344896E+00, 0.9421190E+00, &
1976 0.1000000E+01/
1977 DATA P1/ &
1978 0.9300000E-05, 0.1129521E-04, 0.1360915E-04, 0.1635370E-04, &
1979 0.1954990E-04, 0.2331653E-04, 0.2767314E-04, 0.3277707E-04, &
1980 0.3864321E-04, 0.4547839E-04, 0.5328839E-04, 0.6234301E-04, &
1981 0.7263268E-04, 0.8450696E-04, 0.9793231E-04, 0.1133587E-03, &
1982 0.1307170E-03, 0.1505832E-03, 0.1728373E-03, 0.1982122E-03, &
1983 0.2266389E-03, 0.2592220E-03, 0.2957792E-03, 0.3376068E-03, &
1984 0.3844381E-03, 0.4379281E-03, 0.4976965E-03, 0.5658476E-03, &
1985 0.6418494E-03, 0.7287094E-03, 0.8261995E-03, 0.9380076E-03, &
1986 0.1063498E-02, 0.1207423E-02, 0.1369594E-02, 0.1557141E-02, &
1987 0.1769657E-02, 0.2015887E-02, 0.2295520E-02, 0.2620143E-02, &
1988 0.2989651E-02, 0.3419469E-02, 0.3909867E-02, 0.4481491E-02, &
1989 0.5135272E-02, 0.5898971E-02, 0.6774619E-02, 0.7799763E-02/
1990 DATA P2/ &
1991 0.8978218E-02, 0.1036103E-01, 0.1195488E-01, 0.1382957E-01, &
1992 0.1599631E-01, 0.1855114E-01, 0.2151235E-01, 0.2501293E-01, &
1993 0.2908220E-01, 0.3390544E-01, 0.3952926E-01, 0.4621349E-01, &
1994 0.5403168E-01, 0.6330472E-01, 0.7406807E-01, 0.8677983E-01, &
1995 0.1015345E+00, 0.1189603E+00, 0.1391863E+00, 0.1630739E+00, &
1996 0.1908004E+00, 0.2235461E+00, 0.2609410E+00, 0.3036404E+00, &
1997 0.3513750E+00, 0.4055375E+00, 0.4656677E+00, 0.5335132E+00, &
1998 0.6083618E+00, 0.6923932E+00, 0.7845676E+00, 0.8875882E+00, &
1999 0.1000000E+01/
2000 DATA O3HI1/ &
2001 .55,.50,.45,.45,.40,.35,.35,.30,.30,.30, &
2002 .55,.51,.46,.47,.42,.38,.37,.36,.35,.35, &
2003 .55,.53,.48,.49,.44,.42,.41,.40,.38,.38, &
2004 .60,.55,.52,.52,.50,.47,.46,.44,.42,.41, &
2005 .65,.60,.55,.56,.53,.52,.50,.48,.45,.45, &
2006 .75,.65,.60,.60,.55,.55,.55,.50,.48,.47, &
2007 .80,.75,.75,.75,.70,.70,.65,.63,.60,.60, &
2008 .90,.85,.85,.80,.80,.75,.75,.74,.72,.71, &
2009 1.10,1.05,1.00,.90,.90,.90,.85,.83,.80,.80, &
2010 1.40,1.30,1.25,1.25,1.25,1.20,1.15,1.10,1.05,1.00, &
2011 1.7,1.7,1.6,1.6,1.6,1.6,1.6,1.6,1.5,1.5, &
2012 2.1,2.0,1.9,1.9,1.9,1.8,1.8,1.8,1.7,1.7, &
2013 2.4,2.3,2.2,2.2,2.2,2.1,2.1,2.1,2.0,2.0, &
2014 2.7,2.5,2.5,2.5,2.5,2.5,2.4,2.4,2.3,2.3, &
2015 2.9,2.8,2.7,2.7,2.7,2.7,2.7,2.7,2.6,2.6, &
2016 3.1,3.1,3.0,3.0,3.0,3.0,3.0,3.0,2.9,2.8/
2017 DATA O3HI2/ &
2018 3.3,3.4,3.4,3.6,3.7,3.9,4.0,4.1,4.0,3.8, &
2019 3.6,3.8,3.9,4.2,4.7,5.3,5.6,5.7,5.5,5.2, &
2020 4.1,4.3,4.7,5.2,6.0,6.7,7.0,6.8,6.4,6.2, &
2021 5.4,5.7,6.0,6.6,7.3,8.0,8.4,7.7,7.1,6.7, &
2022 6.7,6.8,7.0,7.6,8.3,10.0,9.6,8.2,7.5,7.2, &
2023 9.2,9.3,9.4,9.6,10.3,10.6,10.0,8.5,7.7,7.3, &
2024 12.6,12.1,12.0,12.1,11.7,11.0,10.0,8.6,7.8,7.4, &
2025 14.2,13.5,13.1,12.8,11.9,10.9,9.8,8.5,7.8,7.5, &
2026 14.3,14.0,13.4,12.7,11.6,10.6,9.3,8.4,7.6,7.3/
2027 DATA O3LO1/ &
2028 14.9,14.2,13.3,12.5,11.2,10.3,9.5,8.6,7.5,7.4, &
2029 14.5,14.1,13.0,11.8,10.5,9.8,9.2,7.9,7.4,7.4, &
2030 11.8,11.5,10.9,10.5,9.9,9.6,8.9,7.5,7.2,7.2, &
2031 7.3,7.7,7.8,8.4,8.4,8.5,7.9,7.4,7.1,7.1, &
2032 4.1,4.4,5.3,6.6,6.9,7.5,7.4,7.2,7.0,6.9, &
2033 1.8,1.9,2.5,3.3,4.5,5.8,6.3,6.3,6.4,6.1, &
2034 0.4,0.5,0.8,1.2,2.7,3.6,4.6,4.7,5.0,5.2, &
2035 .10,.15,.20,.50,1.4,2.1,3.0,3.2,3.5,3.9, &
2036 .07,.10,.12,.30,1.0,1.4,1.8,1.9,2.3,2.5, &
2037 .06,.08,.10,.15,.60,.80,1.4,1.5,1.5,1.6, &
2038 .05,.05,.06,.09,.20,.40,.70,.80,.90,.90, &
2039 .05,.05,.06,.08,.10,.13,.20,.25,.30,.40, &
2040 .05,.05,.05,.06,.07,.07,.08,.09,.10,.13, &
2041 .05,.05,.05,.05,.06,.06,.06,.06,.07,.07, &
2042 .05,.05,.05,.05,.05,.05,.05,.06,.06,.06, &
2043 .04,.04,.04,.04,.04,.04,.04,.05,.05,.05/
2044 DATA O3LO2/ &
2045 14.8,14.2,13.8,12.2,11.0,9.8,8.5,7.8,7.4,6.9, &
2046 13.2,13.0,12.5,11.3,10.4,9.0,7.8,7.5,7.0,6.6, &
2047 10.6,10.6,10.7,10.1,9.4,8.6,7.5,7.0,6.5,6.1, &
2048 7.0,7.3,7.5,7.5,7.5,7.3,6.7,6.4,6.0,5.8, &
2049 3.8,4.0,4.7,5.0,5.2,5.9,5.8,5.6,5.5,5.5, &
2050 1.4,1.6,2.4,3.0,3.7,4.1,4.6,4.8,5.1,5.0, &
2051 .40,.50,.90,1.2,2.0,2.7,3.2,3.6,4.3,4.1, &
2052 .07,.10,.20,.30,.80,1.4,2.1,2.4,2.7,3.0, &
2053 .06,.07,.09,.15,.30,.70,1.2,1.4,1.6,2.0, &
2054 .05,.05,.06,.12,.15,.30,.60,.70,.80,.80, &
2055 .04,.05,.06,.08,.09,.15,.30,.40,.40,.40, &
2056 .04,.04,.05,.055,.06,.09,.12,.13,.15,.15, &
2057 .03,.03,.045,.052,.055,.06,.07,.07,.06,.07, &
2058 .03,.03,.04,.051,.052,.052,.06,.06,.05,.05, &
2059 .02,.02,.03,.05,.05,.05,.04,.04,.04,.04, &
2060 .02,.02,.02,.04,.04,.04,.03,.03,.03,.03/
2061 DATA O3LO3/ &
2062 14.5,14.0,13.5,11.3,11.0,10.0,9.0,8.3,7.5,7.3, &
2063 13.5,13.2,12.5,11.1,10.4,9.7,8.2,7.8,7.4,6.8, &
2064 10.8,10.9,11.0,10.4,10.0,9.6,7.9,7.5,7.0,6.7, &
2065 7.3,7.5,7.8,8.5,9.0,8.5,7.7,7.4,6.9,6.5, &
2066 4.1,4.5,5.3,6.2,7.3,7.7,7.3,7.0,6.6,6.4, &
2067 1.8,2.0,2.2,3.8,4.3,5.6,6.2,6.2,6.4,6.2, &
2068 .30,.50,.60,1.5,2.8,3.7,4.5,4.7,5.5,5.6, &
2069 .09,.10,.15,.60,1.2,2.1,3.0,3.5,4.0,4.3, &
2070 .06,.08,.10,.30,.60,1.1,1.9,2.2,2.9,3.0, &
2071 .04,.05,.06,.15,.45,.60,1.1,1.3,1.6,1.8, &
2072 .04,.04,.04,.08,.20,.30,.55,.60,.75,.90, &
2073 .04,.04,.04,.05,.06,.10,.12,.15,.20,.25, &
2074 .04,.04,.03,.04,.05,.06,.07,.07,.07,.08, &
2075 .03,.03,.04,.05,.05,.05,.05,.05,.05,.05, &
2076 .03,.03,.03,.04,.04,.04,.05,.05,.04,.04, &
2077 .02,.02,.02,.04,.04,.04,.04,.04,.03,.03/
2078 DATA O3LO4/ &
2079 14.2,13.8,13.2,12.5,11.7,10.5,8.6,7.8,7.5,6.6, &
2080 12.5,12.4,12.2,11.7,10.8,9.8,7.8,7.2,6.5,6.1, &
2081 10.6,10.5,10.4,10.1,9.6,9.0,7.1,6.8,6.1,5.9, &
2082 7.0,7.4,7.9,7.8,7.6,7.3,6.2,6.1,5.8,5.6, &
2083 4.2,4.6,5.1,5.6,5.9,5.9,5.9,5.8,5.6,5.3, &
2084 2.1,2.3,2.6,2.9,3.5,4.3,4.8,4.9,5.1,5.1, &
2085 0.7,0.8,1.0,1.5,2.0,2.8,3.5,3.6,3.7,4.0, &
2086 .15,.20,.40,.50,.60,1.4,2.1,2.2,2.3,2.5, &
2087 .08,.10,.15,.25,.30,.90,1.2,1.3,1.4,1.6, &
2088 .07,.08,.10,.14,.20,.50,.70,.90,.90,.80, &
2089 .05,.06,.08,.12,.14,.20,.35,.40,.60,.50, &
2090 .05,.05,.08,.09,.09,.09,.11,.12,.15,.18, &
2091 .04,.05,.06,.07,.07,.08,.08,.08,.08,.08, &
2092 .04,.04,.05,.07,.07,.07,.07,.07,.06,.05, &
2093 .02,.02,.04,.05,.05,.05,.05,.05,.04,.04, &
2094 .02,.02,.03,.04,.04,.04,.04,.04,.03,.03/
2095
2096 !!!!!
2097 ! PSS=101325.
2098 ! PDIF=PSS-PT
2099 !
2100 ! DO L=1,LM1
2101 ! PHALF(L+1)=AETA(L)*PDIF+PT
2102 ! ENDDO
2103 !
2104 ! PHALF(1)=0.
2105 ! PHALF(LP1)=PSS
2106 !!!!
2107 N=kte;NP=N+1;NP2=N+2;NM1=N-1
2108
2109 NKK=41
2110 NK=81
2111 NKP=NK+1
2112 DO 24 K=1,NP
2113 ! 24 PHALF(K)=PHALF(K)*1.0E 03
2114 24 PHALF(K)=PHALF(K)*0.01*1.0E+03
2115 ! 24 PSTD(K)=PSTD(K+1)*1.0E 03
2116 DO 25 K=1,NK
2117 PH(K)=PH(K)*1013250.
2118 25 P(K)=P(K)*1013250.
2119 PH(NKP)=PH(NKP)*1013250.
2120 !KAC WRITE (6,3) PH
2121 !KAC WRITE (6,3) P
2122 ! WRITE (6,3) (PHALF(K),K=1,NP)
2123 ! WRITE (6,3) (PSTD(K),K=1,NP)
2124 !***LOAD ARRAYS RO31,RO32,AS IN DICKS PGM.
2125 DO 1010 K=1,25
2126 DO 1010 L=1,10
2127 RO31(L,K)=O3HI(L,K)
2128 RO32(L,K)=O3HI(L,K)
2129 1010 CONTINUE
2130 !
2131 DO 3000 NCASE=1,4
2132 ITAPE=NCASE+50
2133 IPLACE=2
2134 IF (NCASE.EQ.2) IPLACE=4
2135 IF (NCASE.EQ.3) IPLACE=1
2136 IF (NCASE.EQ.4) IPLACE=3
2137 !***NCASE=1: SPRING (IN N.H.)
2138 !***NCASE=2: FALL (IN N.H.)
2139 !***NCASE=3: WINTER (IN N.H.)
2140 !***NCASE=4: SUMMER (IN N.H.)
2141 IF (NCASE.EQ.1.OR.NCASE.EQ.2) THEN
2142 DO 1011 K=26,41
2143 DO 1011 L=1,10
2144 RO31(L,K)=O3LO1(L,K-25)
2145 RO32(L,K)=O3LO2(L,K-25)
2146 1011 CONTINUE
2147 ENDIF
2148 IF (NCASE.EQ.3.OR.NCASE.EQ.4) THEN
2149 DO 1031 K=26,41
2150 DO 1031 L=1,10
2151 RO31(L,K)=O3LO3(L,K-25)
2152 RO32(L,K)=O3LO4(L,K-25)
2153 1031 CONTINUE
2154 ENDIF
2155 DO 30 KK=1,NKK
2156 DO 31 L=1,10
2157 DUO3N(L,KK)=RO31(11-L,KK)
2158 31 DUO3N(L+9,KK)=RO32(L,KK)
2159 DUO3N(10,KK)=.5*(RO31(1,KK)+RO32(1,KK))
2160 30 CONTINUE
2161 !***FOR NCASE=2 OR NCASE=4,REVERSE LATITUDE ARRANGEMENT OF CORR. SEASON
2162 IF (NCASE.EQ.2.OR.NCASE.EQ.4) THEN
2163 DO 1024 KK=1,NKK
2164 DO 1025 L=1,19
2165 TEMPN(L)=DUO3N(20-L,KK)
2166 1025 CONTINUE
2167 DO 1026 L=1,19
2168 DUO3N(L,KK)=TEMPN(L)
2169 1026 CONTINUE
2170 1024 CONTINUE
2171 ENDIF
2172 !***DUO3N NOW IS O3 PROFILE FOR APPROPRIATE SEASON,AT STD. PRESSURE
2173 ! LEVELS
2174 !KAC WRITE (6,800) DUO3N
2175 !***BEGIN LATITUDE (10 DEG) LOOP
2176 DO 33 L=1,19
2177 DO 22 KK=1,NKK
2178 22 RSTD(KK)=DUO3N(L,KK)
2179 NKM=NK-1
2180 NKMM=NK-3
2181 ! BESSELS HALF-POINT INTERPOLATION FORMULA
2182 DO 60 K=4,NKMM,2
2183 KI=K/2
2184 60 RDATA(K)=.5*(RSTD(KI)+RSTD(KI+1))-(RSTD(KI+2)-RSTD(KI+1)-RSTD(KI)+ &
2185 RSTD(KI-1))/16.
2186 RDATA(2)=.5*(RSTD(2)+RSTD(1))
2187 RDATA(NKM)=.5*(RSTD(NKK)+RSTD(NKK-1))
2188 ! PUT UNCHANGED DATA INTO NEW ARRAY
2189 DO 61 K=1,NK,2
2190 KQ=(K+1)/2
2191 61 RDATA(K)=RSTD(KQ)
2192 !---NOTE TO NMC: THIS WRITE IS COMMENTED OUT TO REDUCE PRINTOUT
2193 ! WRITE (6,798) RDATA
2194 ! CALCULATE LAYER-MEAN OZONE MIXING RATIO FOR EACH MODEL LEVEL
2195 DO 99 KK=1,N
2196 RBAR(KK)=0.
2197 ! LOOP TO CALCULATE SUMS TO GET LAYER OZONE MEAN
2198 DO 98 K=1,NK
2199 IF(PH(K+1).LT.PHALF(KK)) GO TO 98
2200 IF(PH(K).GT.PHALF(KK+1)) GO TO 98
2201 IF(PH(K+1).LT.PHALF(KK+1).AND.PH(K).LT.PHALF(KK)) RBAR(KK)=RBAR(KK &
2202 )+RDATA(K)*(PH(K+1)-PHALF(KK))
2203 IF(PH(K+1).LT.PHALF(KK+1).AND.PH(K).GE.PHALF(KK)) RBAR(KK)=RBAR(KK &
2204 )+RDATA(K)*(PH(K+1)-PH(K))
2205 IF(PH(K+1).GT.PHALF(KK+1).AND.PH(K).GT.PHALF(KK)) RBAR(KK)=RBAR(KK &
2206 )+RDATA(K)*(PHALF(KK+1)-PH(K))
2207 98 CONTINUE
2208 RBAR(KK)=RBAR(KK)/(PHALF(KK+1)-PHALF(KK))
2209 IF(RBAR(KK).GT..0000) GO TO 99
2210 ! CODE TO COVER CASE WHEN MODEL RESOLUTION IS SO FINE THAT NO VALUE
2211 ! OF P(K) IN THE OZONE DATA ARRAY FALLS BETWEEN PHALF(KK+1) AND
2212 ! PHALF(KK). PROCEDURE IS TO SIMPLY GRAB THE NEAREST VALUE FROM
2213 ! RDATA
2214 DO 29 K=1,NK
2215 IF(PH(K).LT.PHALF(KK).AND.PH(K+1).GE.PHALF(KK+1)) RBAR(KK)=RDATA(K)
2216 29 CONTINUE
2217 99 CONTINUE
2218 ! CALCULATE TOTAL OZONE
2219 O3RD=0.
2220 DO 89 KK=1,80
2221 89 O3RD=O3RD+RDATA(KK)*(PH(KK+1)-PH(KK))
2222 O3RD=O3RD+RDATA(81)*(P(81)-PH(81))
2223 O3RD=O3RD/980.
2224 O3TOT=0.
2225 DO 88 KK=1,N
2226 88 O3TOT=O3TOT+RBAR(KK)*(PHALF(KK+1)-PHALF(KK))
2227 O3TOT=O3TOT/980.
2228 ! UNITS ARE MICROGRAMS/CM**2
2229 O3DU=O3TOT/2.144
2230 ! O3DU UNITS ARE DOBSON UNITS (10**-3 ATM-CM)
2231 !--NOTE TO NMC: THIS IS COMMENTED OUT TO SAVE PRINTOUT
2232 ! WRITE (6,796) O3RD,O3TOT,O3DU
2233 DO 23 KK=1,N
2234 23 DDUO3(L,KK)=RBAR(KK)*.01
2235 33 CONTINUE
2236 !***END OF LATITUDE LOOP
2237 !
2238 !***CREATE 5 DEG OZONE QUANTITIES BY LINEAR INTERPOLATION OF
2239 ! 10 DEG VALUES
2240 DO 1060 KK=1,N
2241 DO 1061 L=1,19
2242 O35DEG(2*L-1,KK)=DDUO3(L,KK)
2243 1061 CONTINUE
2244 DO 1062 L=1,18
2245 O35DEG(2*L,KK)=0.5*(DDUO3(L,KK)+DDUO3(L+1,KK))
2246 1062 CONTINUE
2247 1060 CONTINUE
2248 !***OUTPUT TO UNIT (ITAPE) THE OZONE VALUES FOR LATER USE
2249 !O222 ***************************************************
2250 !C WRITE (66) O35DEG
2251 IF (IPLACE.EQ.1) THEN
2252 DO 302 JJ=1,37
2253 DO 302 KEN=1,N
2254 DDUO3N(JJ,KEN) = O35DEG(JJ,KEN)
2255 302 CONTINUE
2256 ELSE IF (IPLACE.EQ.2) THEN
2257 DO 312 JJ=1,37
2258 DO 312 KEN=1,N
2259 DDO3N2(JJ,KEN) = O35DEG(JJ,KEN)
2260 312 CONTINUE
2261 ELSE IF (IPLACE.EQ.3) THEN
2262 DO 322 JJ=1,37
2263 DO 322 KEN=1,N
2264 DDO3N3(JJ,KEN) = O35DEG(JJ,KEN)
2265 322 CONTINUE
2266 ELSE IF (IPLACE.EQ.4) THEN
2267 DO 332 JJ=1,37
2268 DO 332 KEN=1,N
2269 DDO3N4(JJ,KEN) = O35DEG(JJ,KEN)
2270 332 CONTINUE
2271 END IF
2272 !O222 ***************************************************
2273 3000 CONTINUE
2274 !***END OF LOOP OVER CASES
2275 RETURN
2276 1 FORMAT(10F4.2)
2277 2 FORMAT(10X,E14.7,1X,E14.7,1X,E14.7,1X,E14.7,1X)
2278 3 FORMAT(10E12.5)
2279 797 FORMAT(10F7.2)
2280 799 FORMAT(19F6.4)
2281 800 FORMAT(19F6.2)
2282 102 FORMAT(' O3 IPLACE=',I4)
2283 1033 FORMAT(19F6.5)
2284 101 FORMAT(5X,1H*,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5, &
2285 1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,)
2286
2287 END SUBROUTINE O3INT
2288 !----------------------------------------------------------------
2289
2290 SUBROUTINE CLO89(CLDFAC,CAMT,NCLDS,KBTM,KTOP &
2291 , ids,ide, jds,jde, kds,kde &
2292 , ims,ime, jms,jme, kms,kme &
2293 , its,ite, jts,jte, kts,kte )
2294 !----------------------------------------------------------------------
2295 IMPLICIT NONE
2296 !----------------------------------------------------------------------
2297 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
2298 ims,ime, jms,jme, kms,kme , &
2299 its,ite, jts,jte, kts,kte
2300 !----------------------------------------------------------------------
2301
2302 ! ************************************************************
2303 ! * *
2304 ! * THIS SUBROUTINE WAS MODIFIED TO BE USED IN THE ETA MODEL *
2305 ! * *
2306 ! * Q. ZHAO 95-3-22 *
2307 ! * *
2308 ! ************************************************************
2309
2310 REAL, INTENT(OUT),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC
2311 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: CAMT
2312 INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP
2313 INTEGER, INTENT(IN), DIMENSION(its:ite) :: NCLDS
2314
2315 REAL, DIMENSION(kts:kte+1,kts:kte+1,64) :: CLDIPT
2316 REAL, DIMENSION(kts:kte+1) :: CLDROW
2317 INTEGER:: IQ,ITOP,I,J,JTOP,IR,IP,K1,K2,KB,K,KP,KT,NC
2318 REAL :: XCLD
2319
2320 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE
2321
2322 ! DIMENSION CLDIPT(LP1,LP1, 64 )
2323 ! DIMENSION NCLDS(IDIM1:IDIM2),KTOP(IDIM1:IDIM2,LP1), &
2324 ! KBTM(IDIM1:IDIM2,LP1)
2325 ! DIMENSION CLDROW(LP1)
2326 ! DIMENSION CAMT(IDIM1:IDIM2,LP1),CLDFAC(IDIM1:IDIM2,LP1,LP1)
2327
2328 L=kte
2329 LP1=L+1; LP2=L+2; LP3=L+3
2330 LM1=L-1; LM2=L-2; LM3=L-3
2331 MYIS=its; MYIE=ite
2332
2333 !
2334 DO 1 IQ=MYIS,MYIE,64
2335 ITOP=IQ+63
2336 IF(ITOP.GT.MYIE) ITOP=MYIE
2337 JTOP=ITOP-IQ+1
2338 DO 11 IP=1,JTOP
2339 IR=IQ+IP-1
2340 IF (NCLDS(IR).EQ.0) THEN
2341 DO 25 J=1,LP1
2342 DO 25 I=1,LP1
2343 CLDIPT(I,J,IP)=1.
2344 25 CONTINUE
2345 ENDIF
2346 IF (NCLDS(IR).GE.1) THEN
2347 XCLD=1.-CAMT(IR,2)
2348 K1=KTOP(IR,2)+1
2349 K2=KBTM(IR,2)
2350 DO 27 J=1,LP1
2351 CLDROW(J)=1.
2352 27 CONTINUE
2353 DO 29 J=1,K2
2354 CLDROW(J)=XCLD
2355 29 CONTINUE
2356 KB=MAX(K1,K2+1)
2357 DO 33 K=KB,LP1
2358 DO 33 KP=1,LP1
2359 CLDIPT(KP,K,IP)=CLDROW(KP)
2360 33 CONTINUE
2361 DO 37 J=1,LP1
2362 CLDROW(J)=1.
2363 37 CONTINUE
2364 DO 39 J=K1,LP1
2365 CLDROW(J)=XCLD
2366 39 CONTINUE
2367 KT=MIN(K1-1,K2)
2368 DO 43 K=1,KT
2369 DO 43 KP=1,LP1
2370 CLDIPT(KP,K,IP)=CLDROW(KP)
2371 43 CONTINUE
2372 IF(K2+1.LE.K1-1) THEN
2373 DO 31 J=K2+1,K1-1
2374 DO 31 I=1,LP1
2375 CLDIPT(I,J,IP)=1.
2376 31 CONTINUE
2377 ELSE IF(K1.LE.K2) THEN
2378 DO 32 J=K1,K2
2379 DO 32 I=1,LP1
2380 CLDIPT(I,J,IP)=XCLD
2381 32 CONTINUE
2382 ENDIF
2383 ENDIF
2384
2385 IF (NCLDS(IR).GE.2) THEN
2386 DO 21 NC=2,NCLDS(IR)
2387 XCLD=1.-CAMT(IR,NC+1)
2388 K1=KTOP(IR,NC+1)+1
2389 K2=KBTM(IR,NC+1)
2390 DO 47 J=1,LP1
2391 CLDROW(J)=1.
2392 47 CONTINUE
2393 DO 49 J=1,K2
2394 CLDROW(J)=XCLD
2395 49 CONTINUE
2396 KB=MAX(K1,K2+1)
2397 DO 53 K=KB,LP1
2398 DO 53 KP=1,LP1
2399 CLDIPT(KP,K,IP)=CLDIPT(KP,K,IP)*CLDROW(KP)
2400 53 CONTINUE
2401 DO 57 J=1,LP1
2402 CLDROW(J)=1.
2403 57 CONTINUE
2404 DO 59 J=K1,LP1
2405 CLDROW(J)=XCLD
2406 59 CONTINUE
2407 KT=MIN(K1-1,K2)
2408 DO 63 K=1,KT
2409 DO 63 KP=1,LP1
2410 CLDIPT(KP,K,IP)=CLDIPT(KP,K,IP)*CLDROW(KP)
2411 63 CONTINUE
2412 IF(K1.LE.K2) THEN
2413 DO 52 J=K1,K2
2414 DO 52 I=1,LP1
2415 CLDIPT(I,J,IP)=CLDIPT(I,J,IP)*XCLD
2416 52 CONTINUE
2417 ENDIF
2418 21 CONTINUE
2419 ENDIF
2420 11 CONTINUE
2421 DO 71 J=1,LP1
2422 DO 71 I=1,LP1
2423 DO 71 IP=1,JTOP
2424 IR=IQ+IP-1
2425 CLDFAC(IR,I,J)=CLDIPT(I,J,IP)
2426 71 CONTINUE
2427 1 CONTINUE
2428
2429 END SUBROUTINE CLO89
2430 !----------------------------------------------------------------
2431 ! SUBROUTINE LWR88(HEATRA,GRNFLX,TOPFLX, &
2432 ! PRESS,TEMP,RH2O,QO3,CLDFAC, &
2433 ! CAMT,NCLDS,KTOP,KBTM, &
2434 !! BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, &
2435 ! BO3RND,AO3RND, &
2436 ! APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
2437 ! ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR, &
2438 ! GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8, &
2439 ! P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF, &
2440 ! TEN,HP1,FOUR,HM1EZ,SKO3R, &
2441 ! AB15WD,SKC1R,RADCON,QUARTR,TWO, &
2442 ! HM6666M2,HMP66667,HMP5, HP166666,H41666M2, &
2443 ! RADCON1,H16E1, H28E1,H44194M2,H1P41819,SKO2D, &
2444 ! ids,ide, jds,jde, kds,kde, &
2445 ! ims,ime, jms,jme, kms,kme, &
2446 ! its,ite, jts,jte, kts,kte )
2447
2448 SUBROUTINE LWR88(HEATRA,GRNFLX,TOPFLX, &
2449 PRESS,TEMP,RH2O,QO3,CLDFAC, &
2450 CAMT,NCLDS,KTOP,KBTM, &
2451 ! BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, &
2452 BO3RND,AO3RND, &
2453 APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
2454 ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR, &
2455 GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8, &
2456 P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF, &
2457 TEN,HP1,FOUR,HM1EZ, &
2458 RADCON,QUARTR,TWO, &
2459 HM6666M2,HMP66667,HMP5, HP166666,H41666M2, &
2460 RADCON1,H16E1, H28E1,H44194M2,H1P41819, &
2461 ids,ide, jds,jde, kds,kde, &
2462 ims,ime, jms,jme, kms,kme, &
2463 its,ite, jts,jte, kts,kte )
2464 !---------------------------------------------------------------------
2465 IMPLICIT NONE
2466 !----------------------------------------------------------------------
2467 ! INTEGER, PARAMETER :: NBLY=15
2468
2469 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
2470 ims,ime, jms,jme, kms,kme , &
2471 its,ite, jts,jte, kts,kte
2472 REAL, INTENT(IN) :: ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR
2473 REAL, INTENT(IN) :: GINV,H3M4,BETINW,RATH2OMW,GP0INV
2474 REAL, INTENT(IN) :: P0XZP8,P0XZP2,H3M3,P0,H1M3
2475 REAL, INTENT(IN) :: H1M2,H25E2,B0,B1,B2,B3,HAF
2476 ! REAL, INTENT(IN) :: TEN,HP1,FOUR,HM1EZ,SKO3R
2477 REAL, INTENT(IN) :: TEN,HP1,FOUR,HM1EZ
2478 ! REAL, INTENT(IN) :: AB15WD,SKC1R,RADCON,QUARTR,TWO
2479 REAL, INTENT(IN) :: RADCON,QUARTR,TWO
2480 REAL, INTENT(IN) :: HM6666M2,HMP66667,HMP5, HP166666,H41666M2
2481 ! REAL, INTENT(IN) :: RADCON1,H16E1, H28E1,H44194M2,H1P41819,SKO2D
2482 REAL, INTENT(IN) :: RADCON1,H16E1, H28E1,H44194M2,H1P41819
2483 !----------------------------------------------------------------------
2484 REAL, INTENT(IN), DIMENSION(3) :: BO3RND,AO3RND
2485 ! REAL,INTENT(IN),DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW
2486 ! REAL, INTENT(IN), DIMENSION(5040) :: EM3V
2487 REAL,INTENT(IN),DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
2488 BCOMB,BETACM
2489
2490 REAL, INTENT(IN),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC
2491 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: CAMT
2492 INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP
2493 INTEGER, INTENT(IN), DIMENSION(its:ite) :: NCLDS
2494
2495 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: PRESS,TEMP
2496 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: RH2O,QO3
2497 REAL, INTENT(OUT), DIMENSION(its:ite,kts:kte) :: HEATRA
2498 REAL, INTENT(OUT), DIMENSION(its:ite) :: GRNFLX,TOPFLX
2499
2500 ! REAL, DIMENSION(kts:kte+1,kts:kte+1,64) :: CLDIPT
2501
2502 ! Include co2 data from a file, which needs to have exactly vertical
2503 ! dimension of the model.
2504
2505
2506 !!! ??? co2 table
2507 ! REAL, DIMENSION(kts:kte+1,kts:kte+1) :: CO251,CDT51,CDT58,C2D51,&
2508 ! C2D58,CO258
2509 ! REAL, DIMENSION(kts:kte+1) :: STEMP,GTEMP,CO231,CO238, &
2510 ! C2D31,C2D38,CDT31,CDT38, &
2511 ! CO271,CO278,C2D71,C2D78, &
2512 ! CDT71,CDT78
2513 ! REAL, DIMENSION(kts:kte) :: CO2M51,CO2M58,CDTM51,CDTM58, &
2514 ! C2DM51,C2DM58
2515 !!! end co2 table
2516
2517 ! REAL, DIMENSION(kts:kte+1) :: CLDROW
2518
2519 REAL, DIMENSION(its:ite,kts:kte+1) :: TEXPSL,TOTPHI,TOTO3,CNTVAL,&
2520 TPHIO3,TOTVO2,TSTDAV,TDAV, &
2521 VSUM3,CO2R1,D2CD21,DCO2D1, &
2522 CO2R2,D2CD22,DCO2D2,CO2SP1,&
2523 CO2SP2,CO2R,DCO2DT,D2CDT2, &
2524 TLSQU,DIFT
2525 REAL, DIMENSION(its:ite,kts:kte) :: DELP2,DELP,CO2NBL,&
2526 QH2O,VV,VAR1,VAR2,VAR3,VAR4
2527 REAL, DIMENSION(its:ite,kts:kte+1) :: P,T
2528 REAL, DIMENSION(its:ite,kts:kte) :: CO2MR,CO2MD,CO2M2D
2529 REAL, DIMENSION(its:ite,kts:kte*2+1):: EMPL
2530
2531 REAL, DIMENSION(its:ite) :: EMX1,EMX2,VSUM1,VSUM2,A1,A2
2532 REAL, DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CO21
2533
2534 ! COMMON/CO2BD3/CO251(LP1,LP1),CO258(LP1,LP1),CDT51(LP1,LP1),
2535 ! DIMENSION CO21(IDIM1:IDIM2,LP1,LP1),CO2NBL(IDIM1:IDIM2,L)
2536 ! DIMENSION CO2R(IDIM1:IDIM2,LP1),DIFT(IDIM1:IDIM2,LP1)
2537 ! 1 CO2M2D(IDIM1:IDIM2,L)
2538 ! DIMENSION CO2MR(IDIM1:IDIM2,L),CO2MD(IDIM1:IDIM2,L),
2539 ! 2 CO2M58(L),CDTM51(L),CDTM58(L),C2DM51(L),C2DM58(L),
2540 ! 1 CDT58(LP1,LP1),C2D51(LP1,LP1),C2D58(LP1,LP1),CO2M51(L),
2541 ! COMMON / CO2BD2 / CO231(LP1),CO238(LP1),CDT31(LP1),
2542 ! 1 CDT38(LP1),C2D31(LP1),C2D38(LP1)
2543 ! DIMENSION CO2R1(IDIM1:IDIM2,LP1),DCO2D1(IDIM1:IDIM2,LP1)
2544 ! DIMENSION D2CD21(IDIM1:IDIM2,LP1),D2CD22(IDIM1:IDIM2,LP1)
2545 ! 3 STEMP(LP1),GTEMP(LP1),B0,B1,B2,B3
2546 ! 1 VV(IDIM1:IDIM2,L),VSUM3(IDIM1:IDIM2,LP1),VSUM1(IDIM1:IDIM2),
2547 ! 2 VSUM2(IDIM1:IDIM2)
2548 ! DIMENSION TDAV(IDIM1:IDIM2,LP1),TSTDAV(IDIM1:IDIM2,LP1),
2549 ! LLP1=LL+1, LL = 2L
2550 ! EMX2(IDIM1:IDIM2),EMPL(IDIM1:IDIM2,LLP1)
2551 ! DIMENSION TPHIO3(IDIM1:IDIM2,LP1),
2552 ! DIMENSION TEXPSL(IDIM1:IDIM2,LP1)
2553 ! DIMENSION QH2O(IDIM1:IDIM2,L)
2554 ! DIMENSION DELP2(IDIM1:IDIM2,L)
2555 ! DIMENSION VAR1(IDIM1:IDIM2,L),VAR2(IDIM1:IDIM2,L),
2556 ! 1 VAR3(IDIM1:IDIM2,L),VAR4(IDIM1:IDIM2,L)
2557 ! 1 VV(IDIM1:IDIM2,L)
2558 ! DIMENSION CNTVAL(IDIM1:IDIM2,LP1)
2559 ! DIMENSION TOTO3(IDIM1:IDIM2,LP1)
2560 ! DIMENSION EMX1(IDIM1:IDIM2),
2561
2562 ! DIMENSION PRESS(IDIM1:IDIM2,LP1),TEMP(IDIM1:IDIM2,LP1), &
2563 ! RH2O(IDIM1:IDIM2,L),QO3(IDIM1:IDIM2,L)
2564 ! DIMENSION HEATRA(IDIM1:IDIM2,L),GRNFLX(IDIM1:IDIM2), &
2565 ! TOPFLX(IDIM1:IDIM2)
2566
2567 !
2568 !
2569 !****COMPUTE FLUX PRESSURES (P) AND DIFFERENCES (DELP2,DELP)
2570 !****COMPUTE FLUX LEVEL TEMPERATURES (T) AND CONTINUUM TEMPERATURE
2571 ! CORRECTIONS (TEXPSL)
2572
2573 INTEGER :: K, I,KP
2574 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL
2575
2576 L=kte
2577 LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1
2578 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L
2579 MYIS=its; MYIE=ite
2580
2581
2582 DO 103 K=2,L
2583 DO 103 I=MYIS,MYIE
2584 P(I,K)=HAF*(PRESS(I,K-1)+PRESS(I,K))
2585 T(I,K)=HAF*(TEMP(I,K-1)+TEMP(I,K))
2586 103 CONTINUE
2587 DO 105 I=MYIS,MYIE
2588 P(I,1)=ZERO
2589 P(I,LP1)=PRESS(I,LP1)
2590 T(I,1)=TEMP(I,1)
2591 T(I,LP1)=TEMP(I,LP1)
2592 105 CONTINUE
2593 DO 107 K=1,L
2594 DO 107 I=MYIS,MYIE
2595 DELP2(I,K)=P(I,K+1)-P(I,K)
2596 DELP(I,K)=ONE/DELP2(I,K)
2597 107 CONTINUE
2598 !****COMPUTE ARGUMENT FOR CONT.TEMP.COEFF.
2599 ! (THIS IS 1800.(1./TEMP-1./296.))
2600 DO 125 K=1,LP1
2601 DO 125 I=MYIS,MYIE
2602 TEXPSL(I,K)=H18E3/TEMP(I,K)-H6P08108
2603 !...THEN TAKE EXPONENTIAL
2604 TEXPSL(I,K)=EXP(TEXPSL(I,K))
2605 125 CONTINUE
2606 !***COMPUTE OPTICAL PATHS FOR H2O AND O3, USING THE DIFFUSIVITY
2607 ! APPROXIMATION FOR THE ANGULAR INTEGRATION (1.66). OBTAIN THE
2608 ! UNWEIGHTED VALUES(VAR1,VAR3) AND THE WEIGHTED VALUES(VAR2,VAR4).
2609 ! THE QUANTITIES H3M4(.0003) AND H3M3(.003) APPEARING IN THE VAR2 AND
2610 ! VAR4 EXPRESSIONS ARE THE APPROXIMATE VOIGT CORRECTIONS FOR H2O AND
2611 ! O3,RESPECTIVELY.
2612 !
2613 DO 131 K=1,L
2614 DO 131 I=MYIS,MYIE
2615 QH2O(I,K)=RH2O(I,K)*DIFFCTR
2616 !---VV IS THE LAYER-MEAN PRESSURE (IN ATM),WHICH IS NOT THE SAME AS
2617 ! THE LEVEL PRESSURE (PRESS)
2618 VV(I,K)=HAF*(P(I,K+1)+P(I,K))*P0INV
2619 VAR1(I,K)=DELP2(I,K)*QH2O(I,K)*GINV
2620 VAR3(I,K)=DELP2(I,K)*QO3(I,K)*DIFFCTR*GINV
2621 VAR2(I,K)=VAR1(I,K)*(VV(I,K)+H3M4)
2622 VAR4(I,K)=VAR3(I,K)*(VV(I,K)+H3M3)
2623 ! COMPUTE OPTICAL PATH FOR THE H2O CONTINUUM, USING ROBERTS COEFFS.
2624 ! (BETINW),AND TEMP. CORRECTION (TEXPSL). THE DIFFUSIVITY FACTOR
2625 ! (WHICH CANCELS OUT IN THIS EXPRESSION) IS ASSUMED TO BE 1.66. THE
2626 ! USE OF THE DIFFUSIVITY FACTOR HAS BEEN SHOWN TO BE A SIGNIFICANT
2627 ! SOURCE OF ERROR IN THE CONTINUUM CALCS.,BUT THE TIME PENALTY OF
2628 ! AN ANGULAR INTEGRATION IS SEVERE.
2629 !
2630 CNTVAL(I,K)=TEXPSL(I,K)*RH2O(I,K)*VAR2(I,K)*BETINW/ &
2631 (RH2O(I,K)+RATH2OMW)
2632 131 CONTINUE
2633 ! COMPUTE SUMMED OPTICAL PATHS FOR H2O,O3 AND CONTINUUM
2634 DO 201 I=MYIS,MYIE
2635 TOTPHI(I,1)=ZERO
2636 TOTO3(I,1)=ZERO
2637 TPHIO3(I,1)=ZERO
2638 TOTVO2(I,1)=ZERO
2639 201 CONTINUE
2640 DO 203 K=2,LP1
2641 DO 203 I=MYIS,MYIE
2642 TOTPHI(I,K)=TOTPHI(I,K-1)+VAR2(I,K-1)
2643 TOTO3(I,K)=TOTO3(I,K-1)+VAR3(I,K-1)
2644 TPHIO3(I,K)=TPHIO3(I,K-1)+VAR4(I,K-1)
2645 TOTVO2(I,K)=TOTVO2(I,K-1)+CNTVAL(I,K-1)
2646 203 CONTINUE
2647 !---EMX1 IS THE ADDITIONAL PRESSURE-SCALED MASS FROM PRESS(L) TO
2648 ! P(L). IT IS USED IN NEARBY LAYER AND EMISS CALCULATIONS.
2649 !---EMX2 IS THE ADDITIONAL PRESSURE-SCALED MASS FROM PRESS(L) TO
2650 ! P(LP1). IT IS USED IN CALCULATIONS BETWEEN FLUX LEVELS L AND LP1.
2651 !
2652 DO 801 I=MYIS,MYIE
2653 EMX1(I)=QH2O(I,L)*PRESS(I,L)*(PRESS(I,L)-P(I,L))*GP0INV
2654 EMX2(I)=QH2O(I,L)*PRESS(I,L)*(P(I,LP1)-PRESS(I,L))*GP0INV
2655 801 CONTINUE
2656 !---EMPL IS THE PRESSURE SCALED MASS FROM P(K) TO PRESS(K) (INDEX 2-LP1)
2657 ! OR TO PRESS(K+1) (INDEX LP2-LL)
2658 DO 811 K=1,L
2659 DO 811 I=MYIS,MYIE
2660 EMPL(I,K+1)=QH2O(I,K)*P(I,K+1)*(P(I,K+1)-PRESS(I,K))*GP0INV
2661 811 CONTINUE
2662 DO 812 K=1,LM1
2663 DO 812 I=MYIS,MYIE
2664 EMPL(I,LP2+K-1)=QH2O(I,K+1)*P(I,K+1)*(PRESS(I,K+1)-P(I,K+1)) &
2665 *GP0INV
2666 812 CONTINUE
2667 DO 821 I=MYIS,MYIE
2668 EMPL(I,1)=VAR2(I,L)
2669 EMPL(I,LLP1)=EMPL(I,LL)
2670 821 CONTINUE
2671 !***COMPUTE WEIGHTED TEMPERATURE (TDAV) AND PRESSURE (TSTDAV) INTEGRALS
2672 ! FOR USE IN OBTAINING TEMP. DIFFERENCE BET. SOUNDING AND STD.
2673 ! TEMP. SOUNDING (DIFT)
2674 DO 161 I=MYIS,MYIE
2675 TSTDAV(I,1)=ZERO
2676 TDAV(I,1)=ZERO
2677 161 CONTINUE
2678 DO 162 K=1,LP1
2679 DO 162 I=MYIS,MYIE
2680 VSUM3(I,K)=TEMP(I,K)-STEMP(K)
2681 162 CONTINUE
2682 DO 163 K=1,L
2683 DO 165 I=MYIS,MYIE
2684 VSUM2(I)=GTEMP(K)*DELP2(I,K)
2685 VSUM1(I)=VSUM2(I)*VSUM3(I,K)
2686 TSTDAV(I,K+1)=TSTDAV(I,K)+VSUM2(I)
2687 TDAV(I,K+1)=TDAV(I,K)+VSUM1(I)
2688 165 CONTINUE
2689 163 CONTINUE
2690 !
2691 !****EVALUATE COEFFICIENTS FOR CO2 PRESSURE INTERPOLATION (A1,A2)
2692 DO 171 I=MYIS,MYIE
2693 A1(I)=(PRESS(I,LP1)-P0XZP8)/P0XZP2
2694 A2(I)=(P0-PRESS(I,LP1))/P0XZP2
2695 171 CONTINUE
2696 !***PERFORM CO2 PRESSURE INTERPOLATION ON ALL INPUTTED TRANSMISSION
2697 ! FUNCTIONS AND TEMP. DERIVATIVES
2698 !---SUCCESSIVELY COMPUTING CO2R,DCO2DT AND D2CDT2 IS DONE TO SAVE
2699 ! STORAGE (AT A SLIGHT LOSS IN COMPUTATION TIME)
2700 DO 184 K=1,LP1
2701 DO 184 I=MYIS,MYIE
2702 CO2R1(I,K)=A1(I)*CO231(K)+A2(I)*CO238(K)
2703 D2CD21(I,K)=H1M3*(A1(I)*C2D31(K)+A2(I)*C2D38(K))
2704 DCO2D1(I,K)=H1M2*(A1(I)*CDT31(K)+A2(I)*CDT38(K))
2705 CO2R2(I,K)=A1(I)*CO271(K)+A2(I)*CO278(K)
2706 D2CD22(I,K)=H1M3*(A1(I)*C2D71(K)+A2(I)*C2D78(K))
2707 DCO2D2(I,K)=H1M2*(A1(I)*CDT71(K)+A2(I)*CDT78(K))
2708 184 CONTINUE
2709 DO 190 K=1,L
2710 DO 190 I=MYIS,MYIE
2711 CO2MR(I,K)=A1(I)*CO2M51(K)+A2(I)*CO2M58(K)
2712 CO2MD(I,K)=H1M2*(A1(I)*CDTM51(K)+A2(I)*CDTM58(K))
2713 CO2M2D(I,K)=H1M3*(A1(I)*C2DM51(K)+A2(I)*C2DM58(K))
2714 190 CONTINUE
2715 !***COMPUTE CO2 TEMPERATURE INTERPOLATIONS FOR ALL BANDS,USING DIFT
2716 !
2717 ! THE CASE WHERE K=1 IS HANDLED FIRST. WE ARE NOW REPLACING
2718 ! 3-DIMENSIONAL ARRAYS BY 2-D ARRAYS, TO SAVE SPACE. THUS THIS
2719 ! CALCULATION IS FOR (I,KP,1)
2720 DO 211 KP=2,LP1
2721 DO 211 I=MYIS,MYIE
2722 DIFT(I,KP)=TDAV(I,KP)/TSTDAV(I,KP)
2723 211 CONTINUE
2724 DO 212 I=MYIS,MYIE
2725 CO21(I,1,1)=1.0
2726 CO2SP1(I,1)=1.0
2727 CO2SP2(I,1)=1.0
2728 212 CONTINUE
2729 DO 215 KP=2,LP1
2730 DO 215 I=MYIS,MYIE
2731 !---CALCULATIONS FOR KP>1 FOR K=1
2732 CO2R(I,KP)=A1(I)*CO251(KP,1)+A2(I)*CO258(KP,1)
2733 DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(KP,1)+A2(I)*CDT58(KP,1))
2734 D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(KP,1)+A2(I)*C2D58(KP,1))
2735 CO21(I,KP,1)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ &
2736 HAF*DIFT(I,KP)*D2CDT2(I,KP))
2737 !---CALCULATIONS FOR (EFFECTIVELY) KP=1,K>KP. THESE USE THE
2738 ! SAME VALUE OF DIFT DUE TO SYMMETRY
2739 CO2R(I,KP)=A1(I)*CO251(1,KP)+A2(I)*CO258(1,KP)
2740 DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(1,KP)+A2(I)*CDT58(1,KP))
2741 D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(1,KP)+A2(I)*C2D58(1,KP))
2742 CO21(I,1,KP)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ &
2743 HAF*DIFT(I,KP)*D2CDT2(I,KP))
2744 215 CONTINUE
2745 ! THE TRANSMISSION FUNCTIONS USED IN SPA88 MAY BE COMPUTED NOW.
2746 !---(IN THE 250 LOOP,DIFT REALLY SHOULD BE (I,1,K), BUT DIFT IS
2747 ! INVARIANT WITH RESPECT TO K,KP,AND SO (I,1,K)=(I,K,1))
2748 DO 250 K=2,LP1
2749 DO 250 I=MYIS,MYIE
2750 CO2SP1(I,K)=CO2R1(I,K)+DIFT(I,K)*(DCO2D1(I,K)+HAF*DIFT(I,K)* &
2751 D2CD21(I,K))
2752 CO2SP2(I,K)=CO2R2(I,K)+DIFT(I,K)*(DCO2D2(I,K)+HAF*DIFT(I,K)* &
2753 D2CD22(I,K))
2754 250 CONTINUE
2755 !
2756 ! NEXT THE CASE WHEN K=2...L
2757 DO 220 K=2,L
2758 DO 222 KP=K+1,LP1
2759 DO 222 I=MYIS,MYIE
2760 DIFT(I,KP)=(TDAV(I,KP)-TDAV(I,K))/ &
2761 (TSTDAV(I,KP)-TSTDAV(I,K))
2762 CO2R(I,KP)=A1(I)*CO251(KP,K)+A2(I)*CO258(KP,K)
2763 DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(KP,K)+A2(I)*CDT58(KP,K))
2764 D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(KP,K)+A2(I)*C2D58(KP,K))
2765 CO21(I,KP,K)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ &
2766 HAF*DIFT(I,KP)*D2CDT2(I,KP))
2767 CO2R(I,KP)=A1(I)*CO251(K,KP)+A2(I)*CO258(K,KP)
2768 DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(K,KP)+A2(I)*CDT58(K,KP))
2769 D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(K,KP)+A2(I)*C2D58(K,KP))
2770 CO21(I,K,KP)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ &
2771 HAF*DIFT(I,KP)*D2CDT2(I,KP))
2772 222 CONTINUE
2773 220 CONTINUE
2774 ! FINALLY THE CASE WHEN K=KP,K=2..LP1
2775 DO 206 K=2,LP1
2776 DO 206 I=MYIS,MYIE
2777 DIFT(I,K)=HAF*(VSUM3(I,K)+VSUM3(I,K-1))
2778 CO2R(I,K)=A1(I)*CO251(K,K)+A2(I)*CO258(K,K)
2779 DCO2DT(I,K)=H1M2*(A1(I)*CDT51(K,K)+A2(I)*CDT58(K,K))
2780 D2CDT2(I,K)=H1M3*(A1(I)*C2D51(K,K)+A2(I)*C2D58(K,K))
2781 CO21(I,K,K)=CO2R(I,K)+DIFT(I,K)*(DCO2DT(I,K)+ &
2782 HAF*DIFT(I,K)*D2CDT2(I,K))
2783 206 CONTINUE
2784 !--- WE AREN'T DOING NBL TFS ON THE 100 CM-1 BANDS .
2785 DO 260 K=1,L
2786 DO 260 I=MYIS,MYIE
2787 CO2NBL(I,K)=CO2MR(I,K)+VSUM3(I,K)*(CO2MD(I,K)+HAF* &
2788 VSUM3(I,K)*CO2M2D(I,K))
2789 260 CONTINUE
2790 !***COMPUTE TEMP. COEFFICIENT BASED ON T(K) (SEE REF.2)
2791 DO 264 K=1,LP1
2792 DO 264 I=MYIS,MYIE
2793 IF (T(I,K).LE.H25E2) THEN
2794 TLSQU(I,K)=B0+(T(I,K)-H25E2)* &
2795 (B1+(T(I,K)-H25E2)* &
2796 (B2+B3*(T(I,K)-H25E2)))
2797 ELSE
2798 TLSQU(I,K)=B0
2799 ENDIF
2800 264 CONTINUE
2801 !***APPLY TO ALL CO2 TFS
2802 DO 280 K=1,LP1
2803 DO 282 KP=1,LP1
2804 DO 282 I=MYIS,MYIE
2805 CO21(I,KP,K)=CO21(I,KP,K)*(ONE-TLSQU(I,KP))+TLSQU(I,KP)
2806 282 CONTINUE
2807 280 CONTINUE
2808 DO 284 K=1,LP1
2809 DO 286 I=MYIS,MYIE
2810 CO2SP1(I,K)=CO2SP1(I,K)*(ONE-TLSQU(I,1))+TLSQU(I,1)
2811 CO2SP2(I,K)=CO2SP2(I,K)*(ONE-TLSQU(I,1))+TLSQU(I,1)
2812 286 CONTINUE
2813 284 CONTINUE
2814 DO 288 K=1,L
2815 DO 290 I=MYIS,MYIE
2816 CO2NBL(I,K)=CO2NBL(I,K)*(ONE-TLSQU(I,K))+TLSQU(I,K)
2817 290 CONTINUE
2818 288 CONTINUE
2819 ! CALL FST88(HEATRA,GRNFLX,TOPFLX, &
2820 ! QH2O,PRESS,P,DELP,DELP2,TEMP,T, &
2821 ! CLDFAC,NCLDS,KTOP,KBTM,CAMT, &
2822 ! CO21,CO2NBL,CO2SP1,CO2SP2, &
2823 ! VAR1,VAR2,VAR3,VAR4,CNTVAL, &
2824 ! TOTO3,TPHIO3,TOTPHI,TOTVO2, &
2825 ! EMX1,EMX2,EMPL, &
2826 !
2827 ! BO3RND,AO3RND, &
2828 !! T1,T2,T4 , EM1V,EM1VW, EM3V, &
2829 ! APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
2830 ! TEN,HP1,HAF,ONE,FOUR,HM1EZ,SKO3R, &
2831 ! AB15WD,SKC1R,RADCON,QUARTR,TWO, &
2832 ! HM6666M2,HMP66667,HMP5, &
2833 ! HP166666,H41666M2,RADCON1, &
2834 ! H16E1, H28E1, H25E2, H44194M2,H1P41819, &
2835 ! SKO2D, &
2836 ! ids,ide, jds,jde, kds,kde, &
2837 ! ims,ime, jms,jme, kms,kme, &
2838 ! its,ite, jts,jte, kts,kte )
2839
2840 CALL FST88(HEATRA,GRNFLX,TOPFLX, &
2841 QH2O,PRESS,P,DELP,DELP2,TEMP,T, &
2842 CLDFAC,NCLDS,KTOP,KBTM,CAMT, &
2843 CO21,CO2NBL,CO2SP1,CO2SP2, &
2844 VAR1,VAR2,VAR3,VAR4,CNTVAL, &
2845 TOTO3,TPHIO3,TOTPHI,TOTVO2, &
2846 EMX1,EMX2,EMPL, &
2847 !
2848 BO3RND,AO3RND, &
2849 ! T1,T2,T4 , EM1V,EM1VW, EM3V, &
2850 APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
2851 TEN,HP1,HAF,ONE,FOUR,HM1EZ, &
2852 RADCON,QUARTR,TWO, &
2853 HM6666M2,HMP66667,HMP5, &
2854 HP166666,H41666M2,RADCON1, &
2855 H16E1, H28E1, H25E2, H44194M2,H1P41819, &
2856 ids,ide, jds,jde, kds,kde, &
2857 ims,ime, jms,jme, kms,kme, &
2858 its,ite, jts,jte, kts,kte )
2859
2860 END SUBROUTINE LWR88
2861 !---------------------------------------------------------------------
2862 ! SUBROUTINE FST88(HEATRA,GRNFLX,TOPFLX, &
2863 ! QH2O,PRESS,P,DELP,DELP2,TEMP,T, &
2864 ! CLDFAC,NCLDS,KTOP,KBTM,CAMT, &
2865 ! CO21,CO2NBL,CO2SP1,CO2SP2, &
2866 ! VAR1,VAR2,VAR3,VAR4,CNTVAL, &
2867 ! TOTO3,TPHIO3,TOTPHI,TOTVO2, &
2868 ! EMX1,EMX2,EMPL, &
2869 ! BO3RND,AO3RND, &
2870 !! T1,T2,T4 , EM1V,EM1VW, EM3V, &
2871 ! APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
2872 ! TEN,HP1,HAF,ONE,FOUR,HM1EZ,SKO3R, &
2873 ! AB15WD,SKC1R,RADCON,QUARTR,TWO, &
2874 ! HM6666M2,HMP66667,HMP5, &
2875 ! HP166666,H41666M2,RADCON1, &
2876 ! H16E1, H28E1, H25E2, H44194M2,H1P41819, &
2877 ! SKO2D, &
2878 ! ids,ide, jds,jde, kds,kde, &
2879 ! ims,ime, jms,jme, kms,kme, &
2880 ! its,ite, jts,jte, kts,kte )
2881
2882 SUBROUTINE FST88(HEATRA,GRNFLX,TOPFLX, &
2883 QH2O,PRESS,P,DELP,DELP2,TEMP,T, &
2884 CLDFAC,NCLDS,KTOP,KBTM,CAMT, &
2885 CO21,CO2NBL,CO2SP1,CO2SP2, &
2886 VAR1,VAR2,VAR3,VAR4,CNTVAL, &
2887 TOTO3,TPHIO3,TOTPHI,TOTVO2, &
2888 EMX1,EMX2,EMPL, &
2889 BO3RND,AO3RND, &
2890 ! T1,T2,T4 , EM1V,EM1VW, EM3V, &
2891 APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
2892 TEN,HP1,HAF,ONE,FOUR,HM1EZ, &
2893 RADCON,QUARTR,TWO, &
2894 HM6666M2,HMP66667,HMP5, &
2895 HP166666,H41666M2,RADCON1, &
2896 H16E1, H28E1, H25E2, H44194M2,H1P41819, &
2897 ids,ide, jds,jde, kds,kde, &
2898 ims,ime, jms,jme, kms,kme, &
2899 its,ite, jts,jte, kts,kte )
2900 !---------------------------------------------------------------------
2901 IMPLICIT NONE
2902 !----------------------------------------------------------------------
2903 ! INTEGER, PARAMETER :: NBLY=15
2904
2905 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
2906 ims,ime, jms,jme, kms,kme , &
2907 its,ite, jts,jte, kts,kte
2908
2909 ! REAL, INTENT(IN) :: TEN,HP1,HAF,ONE,FOUR,HM1EZ,SKO3R
2910 REAL, INTENT(IN) :: TEN,HP1,HAF,ONE,FOUR,HM1EZ
2911 ! REAL, INTENT(IN) :: AB15WD,SKC1R,RADCON,QUARTR,TWO
2912 REAL, INTENT(IN) :: RADCON,QUARTR,TWO
2913 REAL, INTENT(IN) :: HM6666M2,HMP66667,HMP5
2914 REAL, INTENT(IN) :: HP166666,H41666M2,RADCON1,H16E1, H28E1
2915 ! REAL, INTENT(IN) :: H25E2,H44194M2,H1P41819,SKO2D
2916 REAL, INTENT(IN) :: H25E2,H44194M2,H1P41819
2917
2918 REAL,INTENT(IN),DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
2919 BCOMB,BETACM
2920
2921 ! REAL, INTENT(IN), DIMENSION(5040) :: T1,T2,T4,EM1V,EM1VW
2922 ! REAL, INTENT(IN), DIMENSION(5040) :: EM3V
2923 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte*2+1) :: EMPL
2924 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: TOTO3,TPHIO3,TOTPHI,CNTVAL,&
2925 CO2SP1,CO2SP2
2926
2927 REAL, INTENT(IN),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC
2928 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: CAMT,TOTVO2
2929 INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP
2930 INTEGER, INTENT(IN), DIMENSION(its:ite) :: NCLDS
2931 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: QH2O
2932 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: PRESS,TEMP
2933 REAL, INTENT(OUT), DIMENSION(its:ite,kts:kte) :: HEATRA
2934 REAL, INTENT(OUT), DIMENSION(its:ite) :: GRNFLX,TOPFLX
2935 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: P,T
2936 REAL, INTENT(INOUT), DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CO21
2937 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: CO2NBL,DELP2, &
2938 DELP,&
2939 VAR1,VAR2,VAR3,VAR4
2940 REAL, INTENT(IN), DIMENSION(3) :: BO3RND,AO3RND
2941 REAL, INTENT(IN), DIMENSION(its:ite) :: EMX1,EMX2
2942
2943 REAL, DIMENSION(its:ite,kts:kte*2+1) :: TPL,EMD,ALP,C,CSUB,CSUB2
2944 REAL, DIMENSION(its:ite,kts:kte*2+1) :: C2
2945 INTEGER, DIMENSION(its:ite,kts:kte+1) :: IXO
2946 REAL, DIMENSION(its:ite,kts:kte+1) :: VTMP3,FXO,DT,FXOE2,DTE2, &
2947 SS1,CSOUR,TC,OSS,CSS,DTC,SS2,&
2948 AVEPHI,E1CTS1,E1FLX, &
2949 E1CTW1,DSORC,EMISS,FAC1,&
2950 TO3SP,OVER1D,CNTTAU,TOTEVV,&
2951 CO2SP,FLX,AVMO3, &
2952 AVPHO3,AVVO2,CONT1D,TO31D,EMISDG,&
2953 DELPR1
2954 REAL, DIMENSION(its:ite,kts:kte+1) :: EMISSB,DELPR2,CONTDG,TO3DG,HEATEM,&
2955 VSUM1,FLXNET,Z1
2956
2957 REAL, DIMENSION(its:ite,kts:kte+1,NBLY) :: SORC
2958 REAL, DIMENSION(its:ite,kts:kte) :: E1CTS2,E1CTW2,TO3SPC,RLOG,EXCTS,&
2959 CTSO3,CTS
2960 REAL, DIMENSION(its:ite) :: GXCTS,FLX1E1
2961 REAL, DIMENSION(its:ite) :: PTOP,PBOT,FTOP,FBOT,DELPTC
2962 REAL, DIMENSION(its:ite,2) :: FXOSP,DTSP,EMSPEC
2963 ! REAL, DIMENSION(28,NBLY) :: SOURCE,DSRCE
2964 INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
2965 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN
2966
2967 L=kte
2968 LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1
2969 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L
2970 LLM2 = LL-2; LLM1=LL-1
2971 MYIS=its; MYIE=ite
2972
2973 !
2974 DO 101 K=1,LP1
2975 DO 101 I=MYIS,MYIE
2976 !---TEMP. INDICES FOR E1,SOURCE
2977 VTMP3(I,K)=AINT(TEMP(I,K)*HP1)
2978 FXO(I,K)=VTMP3(I,K)-9.
2979 DT(I,K)=TEMP(I,K)-TEN*VTMP3(I,K)
2980 !---INTEGER INDEX FOR SOURCE (USED IMMEDIATELY)
2981 IXO(I,K)=FXO(I,K)
2982 101 CONTINUE
2983 DO 103 k=1,L
2984 DO 103 I=MYIS,MYIE
2985 !---TEMP. INDICES FOR E2 (KP=1 LAYER NOT USED IN FLUX CALCULATIONS)
2986 VTMP3(I,K)=AINT(T(I,K+1)*HP1)
2987 FXOE2(I,K)=VTMP3(I,K)-9.
2988 DTE2(I,K)=T(I,K+1)-TEN*VTMP3(I,K)
2989 103 CONTINUE
2990 !---SPECIAL CASE TO HANDLE KP=LP1 LAYER AND SPECIAL E2 CALCS.
2991 DO 105 I=MYIS,MYIE
2992 FXOE2(I,LP1)=FXO(I,L)
2993 DTE2(I,LP1)=DT(I,L)
2994 FXOSP(I,1)=FXOE2(I,LM1)
2995 FXOSP(I,2)=FXO(I,LM1)
2996 DTSP(I,1)=DTE2(I,LM1)
2997 DTSP(I,2)=DT(I,LM1)
2998 105 CONTINUE
2999 !
3000 !---SOURCE FUNCTION FOR COMBINED BAND 1
3001 DO 4114 I=MYIS,MYIE
3002 DO 4114 K=1,LP1
3003 VTMP3(I,K)=SOURCE(IXO(I,K),1)
3004 DSORC(I,K)=DSRCE(IXO(I,K),1)
3005 4114 CONTINUE
3006 DO 4112 K=1,LP1
3007 DO 4112 I=MYIS,MYIE
3008 SORC(I,K,1)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3009 4112 CONTINUE
3010 !---SOURCE FUNCTION FOR COMBINED BAND 2
3011 DO 4214 I=MYIS,MYIE
3012 DO 4214 K=1,LP1
3013 VTMP3(I,K)=SOURCE(IXO(I,K),2)
3014 DSORC(I,K)=DSRCE(IXO(I,K),2)
3015 4214 CONTINUE
3016 DO 4212 K=1,LP1
3017 DO 4212 I=MYIS,MYIE
3018 SORC(I,K,2)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3019 4212 CONTINUE
3020 !---SOURCE FUNCTION FOR COMBINED BAND 3
3021 DO 4314 I=MYIS,MYIE
3022 DO 4314 K=1,LP1
3023 VTMP3(I,K)=SOURCE(IXO(I,K),3)
3024 DSORC(I,K)=DSRCE(IXO(I,K),3)
3025 4314 CONTINUE
3026 DO 4312 K=1,LP1
3027 DO 4312 I=MYIS,MYIE
3028 SORC(I,K,3)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3029 4312 CONTINUE
3030 !---SOURCE FUNCTION FOR COMBINED BAND 4
3031 DO 4414 I=MYIS,MYIE
3032 DO 4414 K=1,LP1
3033 VTMP3(I,K)=SOURCE(IXO(I,K),4)
3034 DSORC(I,K)=DSRCE(IXO(I,K),4)
3035 4414 CONTINUE
3036 DO 4412 K=1,LP1
3037 DO 4412 I=MYIS,MYIE
3038 SORC(I,K,4)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3039 4412 CONTINUE
3040 !---SOURCE FUNCTION FOR COMBINED BAND 5
3041 DO 4514 I=MYIS,MYIE
3042 DO 4514 K=1,LP1
3043 VTMP3(I,K)=SOURCE(IXO(I,K),5)
3044 DSORC(I,K)=DSRCE(IXO(I,K),5)
3045 4514 CONTINUE
3046 DO 4512 K=1,LP1
3047 DO 4512 I=MYIS,MYIE
3048 SORC(I,K,5)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3049 4512 CONTINUE
3050 !---SOURCE FUNCTION FOR COMBINED BAND 6
3051 DO 4614 I=MYIS,MYIE
3052 DO 4614 K=1,LP1
3053 VTMP3(I,K)=SOURCE(IXO(I,K),6)
3054 DSORC(I,K)=DSRCE(IXO(I,K),6)
3055 4614 CONTINUE
3056 DO 4612 K=1,LP1
3057 DO 4612 I=MYIS,MYIE
3058 SORC(I,K,6)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3059 4612 CONTINUE
3060 !---SOURCE FUNCTION FOR COMBINED BAND 7
3061 DO 4714 I=MYIS,MYIE
3062 DO 4714 K=1,LP1
3063 VTMP3(I,K)=SOURCE(IXO(I,K),7)
3064 DSORC(I,K)=DSRCE(IXO(I,K),7)
3065 4714 CONTINUE
3066 DO 4712 K=1,LP1
3067 DO 4712 I=MYIS,MYIE
3068 SORC(I,K,7)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3069 4712 CONTINUE
3070 !---SOURCE FUNCTION FOR COMBINED BAND 8
3071 DO 4814 I=MYIS,MYIE
3072 DO 4814 K=1,LP1
3073 VTMP3(I,K)=SOURCE(IXO(I,K),8)
3074 DSORC(I,K)=DSRCE(IXO(I,K),8)
3075 4814 CONTINUE
3076 DO 4812 K=1,LP1
3077 DO 4812 I=MYIS,MYIE
3078 SORC(I,K,8)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3079 4812 CONTINUE
3080 !---SOURCE FUNCTION FOR BAND 9 (560-670 CM-1)
3081 DO 4914 I=MYIS,MYIE
3082 DO 4914 K=1,LP1
3083 VTMP3(I,K)=SOURCE(IXO(I,K),9)
3084 DSORC(I,K)=DSRCE(IXO(I,K),9)
3085 4914 CONTINUE
3086 DO 4912 K=1,LP1
3087 DO 4912 I=MYIS,MYIE
3088 SORC(I,K,9)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3089 4912 CONTINUE
3090 !---SOURCE FUNCTION FOR BAND 10 (670-800 CM-1)
3091 DO 5014 I=MYIS,MYIE
3092 DO 5014 K=1,LP1
3093 VTMP3(I,K)=SOURCE(IXO(I,K),10)
3094 DSORC(I,K)=DSRCE(IXO(I,K),10)
3095 5014 CONTINUE
3096 DO 5012 K=1,LP1
3097 DO 5012 I=MYIS,MYIE
3098 SORC(I,K,10)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3099 5012 CONTINUE
3100 !---SOURCE FUNCTION FOR BAND 11 (800-900 CM-1)
3101 DO 5114 I=MYIS,MYIE
3102 DO 5114 K=1,LP1
3103 VTMP3(I,K)=SOURCE(IXO(I,K),11)
3104 DSORC(I,K)=DSRCE(IXO(I,K),11)
3105 5114 CONTINUE
3106 DO 5112 K=1,LP1
3107 DO 5112 I=MYIS,MYIE
3108 SORC(I,K,11)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3109 5112 CONTINUE
3110 !---SOURCE FUNCTION FOR BAND 12 (900-990 CM-1)
3111 DO 5214 I=MYIS,MYIE
3112 DO 5214 K=1,LP1
3113 VTMP3(I,K)=SOURCE(IXO(I,K),12)
3114 DSORC(I,K)=DSRCE(IXO(I,K),12)
3115 5214 CONTINUE
3116 DO 5212 K=1,LP1
3117 DO 5212 I=MYIS,MYIE
3118 SORC(I,K,12)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3119 5212 CONTINUE
3120 !---SOURCE FUNCTION FOR BAND 13 (990-1070 CM-1)
3121 DO 5314 I=MYIS,MYIE
3122 DO 5314 K=1,LP1
3123 VTMP3(I,K)=SOURCE(IXO(I,K),13)
3124 DSORC(I,K)=DSRCE(IXO(I,K),13)
3125 5314 CONTINUE
3126 DO 5312 K=1,LP1
3127 DO 5312 I=MYIS,MYIE
3128 SORC(I,K,13)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3129 5312 CONTINUE
3130 !---SOURCE FUNCTION FOR BAND 14 (1070-1200 CM-1)
3131 DO 5414 I=MYIS,MYIE
3132 DO 5414 K=1,LP1
3133 VTMP3(I,K)=SOURCE(IXO(I,K),14)
3134 DSORC(I,K)=DSRCE(IXO(I,K),14)
3135 5414 CONTINUE
3136 DO 5412 K=1,LP1
3137 DO 5412 I=MYIS,MYIE
3138 SORC(I,K,14)=VTMP3(I,K)+DT(I,K)*DSORC(I,K)
3139 5412 CONTINUE
3140 !
3141 ! THE FOLLOWING SUBROUTINE OBTAINS NLTE SOURCE FUNCTION FOR CO2
3142 !
3143 !
3144 ! CALL NLTE
3145 !
3146 !
3147 !---OBTAIN SPECIAL SOURCE FUNCTIONS FOR THE 15 UM BAND (CSOUR)
3148 ! AND THE WINDOW REGION (SS1)
3149 DO 131 K=1,LP1
3150 DO 131 I=MYIS,MYIE
3151 SS1(I,K)=SORC(I,K,11)+SORC(I,K,12)+SORC(I,K,14)
3152 131 CONTINUE
3153 DO 143 K=1,LP1
3154 DO 143 I=MYIS,MYIE
3155 CSOUR(I,K)=SORC(I,K,9)+SORC(I,K,10)
3156 143 CONTINUE
3157 !
3158 !---COMPUTE TEMP**4 (TC) AND VERTICAL TEMPERATURE DIFFERENCES
3159 ! (OSS,CSS,SS2,DTC). ALL THESE WILL BE USED LATER IN FLUX COMPUTA-
3160 ! TIONS.
3161 !
3162 DO 901 K=1,LP1
3163 DO 901 I=MYIS,MYIE
3164 TC(I,K)=TEMP(I,K)*TEMP(I,K)*TEMP(I,K)*TEMP(I,K)
3165 901 CONTINUE
3166 DO 903 K=1,L
3167 DO 903 I=MYIS,MYIE
3168 OSS(I,K+1)=SORC(I,K+1,13)-SORC(I,K,13)
3169 CSS(I,K+1)=CSOUR(I,K+1)-CSOUR(I,K)
3170 DTC(I,K+1)=TC(I,K+1)-TC(I,K)
3171 SS2(I,K+1)=SS1(I,K+1)-SS1(I,K)
3172 903 CONTINUE
3173 !
3174 !
3175 !---THE FOLLOWIMG IS A DRASTIC REWRITE OF THE RADIATION CODE TO
3176 ! (LARGELY) ELIMINATE THREE-DIMENSIONAL ARRAYS. THE CODE WORKS
3177 ! ON THE FOLLOWING PRINCIPLES:
3178 !
3179 ! LET K = FIXED FLUX LEVEL, KP = VARYING FLUX LEVEL
3180 ! THEN FLUX(K)=SUM OVER KP : (DELTAB(KP)*TAU(KP,K))
3181 ! OVER ALL KP'S, FROM 1 TO LP1.
3182 !
3183 ! WE CAN BREAK DOWN THE CALCULATIONS FOR ALL K'S AS FOLLOWS:
3184 !
3185 ! FOR ALL K'S K=1 TO LP1:
3186 ! FLUX(K)=SUM OVER KP : (DELTAB(KP)*TAU(KP,K)) (1)
3187 ! OVER ALL KP'S, FROM K+1 TO LP1
3188 ! AND
3189 ! FOR KP FROM K+1 TO LP1:
3190 ! FLUX(KP) = DELTAB(K)*TAU(K,KP) (2)
3191 !
3192 ! NOW IF TAU(K,KP)=TAU(KP,K) (SYMMETRICAL ARRAYS)
3193 ! WE CAN COMPUTE A 1-DIMENSIONAL ARRAY TAU1D(KP) FROM
3194 ! K+1 TO LP1, EACH TIME K IS INCREMENTED.
3195 ! EQUATIONS (1) AND (2) THEN BECOME:
3196 !
3197 ! TAU1D(KP) = (VALUES FOR TAU(KP,K) AT THE PARTICULAR K)
3198 ! FLUX(K) = SUM OVER KP : (DELTAB(KP)*TAU1D(KP)) (3)
3199 ! FLUX(KP) = DELTAB(K)*TAU1D(KP) (4)
3200 !
3201 ! THE TERMS FOR TAU (K,K) AND OTHER SPECIAL TERMS (FOR
3202 ! NEARBY LAYERS) MUST, OF COURSE, BE HANDLED SEPARATELY, AND
3203 ! WITH CARE.
3204 !
3205 ! COMPUTE "UPPER TRIANGLE" TRANSMISSION FUNCTIONS FOR
3206 ! THE 9.6 UM BAND (TO3SP) AND THE 15 UM BAND (OVER1D). ALSO,
3207 ! THE
3208 ! STAGE 1...COMPUTE O3 ,OVER TRANSMISSION FCTNS AND AVEPHI
3209 !---DO K=1 CALCULATION (FROM FLUX LAYER KK TO THE TOP) SEPARATELY
3210 ! AS VECTORIZATION IS IMPROVED,AND OZONE CTS TRANSMISSIVITY
3211 ! MAY BE EXTRACTED HERE.
3212 DO 3021 K=1,L
3213 DO 3021 I=MYIS,MYIE
3214 AVEPHI(I,K)=TOTPHI(I,K+1)
3215 3021 CONTINUE
3216 !---IN ORDER TO PROPERLY EVALUATE EMISS INTEGRATED OVER THE (LP1)
3217 ! LAYER, A SPECIAL EVALUATION OF EMISS IS DONE. THIS REQUIRES
3218 ! A SPECIAL COMPUTATION OF AVEPHI, AND IT IS STORED IN THE
3219 ! (OTHERWISE VACANT) LP1'TH POSITION
3220 !
3221 DO 803 I=MYIS,MYIE
3222 AVEPHI(I,LP1)=AVEPHI(I,LM1)+EMX1(I)
3223 803 CONTINUE
3224 ! COMPUTE FLUXES FOR K=1
3225 CALL E1E290(E1CTS1,E1CTS2,E1FLX,E1CTW1,E1CTW2,EMISS, &
3226 FXO,DT,FXOE2,DTE2,AVEPHI,TEMP,T, &
3227 ! T1,T2,T4 ,EM1V,EM1VW, &
3228 H16E1,TEN,HP1,H28E1,HAF, &
3229 ids,ide, jds,jde, kds,kde, &
3230 ims,ime, jms,jme, kms,kme, &
3231 its,ite, jts,jte, kts,kte )
3232
3233 DO 302 K=1,L
3234 DO 302 I=MYIS,MYIE
3235 FAC1(I,K)=BO3RND(2)*TPHIO3(I,K+1)/TOTO3(I,K+1)
3236 TO3SPC(I,K)=HAF*(FAC1(I,K)* &
3237 (SQRT(ONE+(FOUR*AO3RND(2)*TOTO3(I,K+1))/FAC1(I,K))-ONE))
3238 ! FOR K=1, TO3SP IS USED INSTEAD OF TO31D (THEY ARE EQUAL IN THIS
3239 ! CASE); TO3SP IS PASSED TO SPA90, WHILE TO31D IS A WORK-ARRAY.
3240 TO3SP(I,K)=EXP(HM1EZ*(TO3SPC(I,K)+SKO3R*TOTVO2(I,K+1)))
3241 OVER1D(I,K)=EXP(HM1EZ*(SQRT(AB15WD*TOTPHI(I,K+1))+ &
3242 SKC1R*TOTVO2(I,K+1)))
3243 !---BECAUSE ALL CONTINUUM TRANSMISSIVITIES ARE OBTAINED FROM THE
3244 ! 2-D QUANTITY CNTTAU (AND ITS RECIPROCAL TOTEVV) WE STORE BOTH
3245 ! OF THESE HERE. FOR K=1, CONT1D EQUALS CNTTAU
3246 CNTTAU(I,K)=EXP(HM1EZ*TOTVO2(I,K+1))
3247 TOTEVV(I,K)=1./CNTTAU(I,K)
3248 302 CONTINUE
3249 DO 3022 K=1,L
3250 DO 3022 I=MYIS,MYIE
3251 CO2SP(I,K+1)=OVER1D(I,K)*CO21(I,1,K+1)
3252 3022 CONTINUE
3253 DO 3023 K=1,L
3254 DO 3023 I=MYIS,MYIE
3255 CO21(I,K+1,1)=CO21(I,K+1,1)*OVER1D(I,K)
3256 3023 CONTINUE
3257 !---RLOG IS THE NBL AMOUNT FOR THE 15 UM BAND CALCULATION
3258 DO 1808 I=MYIS,MYIE
3259 RLOG(I,1)=OVER1D(I,1)*CO2NBL(I,1)
3260 1808 CONTINUE
3261 !---THE TERMS WHEN KP=1 FOR ALL K ARE THE PHOTON EXCHANGE WITH
3262 ! THE TOP OF THE ATMOSPHERE, AND ARE OBTAINED DIFFERENTLY THAN
3263 ! THE OTHER CALCULATIONS
3264 DO 305 K=2,LP1
3265 DO 305 I=MYIS,MYIE
3266 FLX(I,K)= (TC(I,1)*E1FLX(I,K) &
3267 +SS1(I,1)*CNTTAU(I,K-1) &
3268 +SORC(I,1,13)*TO3SP(I,K-1) &
3269 +CSOUR(I,1)*CO2SP(I,K)) &
3270 *CLDFAC(I,1,K)
3271 305 CONTINUE
3272 DO 307 I=MYIS,MYIE
3273 FLX(I,1)= TC(I,1)*E1FLX(I,1)+SS1(I,1)+SORC(I,1,13) &
3274 +CSOUR(I,1)
3275 307 CONTINUE
3276 !---THE KP TERMS FOR K=1...
3277 DO 303 KP=2,LP1
3278 DO 303 I=MYIS,MYIE
3279 FLX(I,1)=FLX(I,1)+(OSS(I,KP)*TO3SP(I,KP-1) &
3280 +SS2(I,KP)*CNTTAU(I,KP-1) &
3281 +CSS(I,KP)*CO21(I,KP,1) &
3282 +DTC(I,KP)*EMISS(I,KP-1))*CLDFAC(I,KP,1)
3283 303 CONTINUE
3284 ! SUBROUTINE SPA88 IS CALLED TO OBTAIN EXACT CTS FOR WATER
3285 ! CO2 AND O3, AND APPROXIMATE CTS CO2 AND O3 CALCULATIONS.
3286 !
3287 CALL SPA88(EXCTS,CTSO3,GXCTS,SORC,CSOUR, &
3288 CLDFAC,TEMP,PRESS,VAR1,VAR2, &
3289 P,DELP,DELP2,TOTVO2,TO3SP,TO3SPC, &
3290 CO2SP1,CO2SP2,CO2SP, &
3291 APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
3292 H25E2,ONE,H44194M2,H1P41819,HAF,HM1EZ,TWO, &
3293 ! SKO2D,RADCON, &
3294 RADCON, &
3295 ids,ide, jds,jde, kds,kde, &
3296 ims,ime, jms,jme, kms,kme, &
3297 its,ite, jts,jte, kts,kte )
3298
3299 !
3300 ! THIS SECTION COMPUTES THE EMISSIVITY CTS HEATING RATES FOR 2
3301 ! EMISSIVITY BANDS: THE 0-160,1200-2200 CM-1 BAND AND THE 800-
3302 ! 990,1070-1200 CM-1 BAND. THE REMAINING CTS COMTRIBUTIONS ARE
3303 ! CONTAINED IN CTSO3, COMPUTED IN SPA88.
3304 !
3305 DO 998 I=MYIS,MYIE
3306 VTMP3(I,1)=1.
3307 998 CONTINUE
3308 DO 999 K=1,L
3309 DO 999 I=MYIS,MYIE
3310 VTMP3(I,K+1)=CNTTAU(I,K)*CLDFAC(I,K+1,1)
3311 999 CONTINUE
3312 DO 1001 K=1,L
3313 DO 1001 I=MYIS,MYIE
3314 CTS(I,K)=RADCON*DELP(I,K)*(TC(I,K)* &
3315 (E1CTW2(I,K)*CLDFAC(I,K+1,1)-E1CTW1(I,K)*CLDFAC(I,K,1)) + &
3316 SS1(I,K)*(VTMP3(I,K+1)-VTMP3(I,K)))
3317 1001 CONTINUE
3318 !
3319 DO 1011 K=1,L
3320 DO 1011 I=MYIS,MYIE
3321 VTMP3(I,K)=TC(I,K)*(CLDFAC(I,K,1)*(E1CTS1(I,K)-E1CTW1(I,K)) - &
3322 CLDFAC(I,K+1,1)*(E1CTS2(I,K)-E1CTW2(I,K)))
3323 1011 CONTINUE
3324 DO 1012 I=MYIS,MYIE
3325 FLX1E1(I)=TC(I,LP1)*CLDFAC(I,LP1,1)* &
3326 (E1CTS1(I,LP1)-E1CTW1(I,LP1))
3327 1012 CONTINUE
3328 DO 1014 K=1,L
3329 DO 1013 I=MYIS,MYIE
3330 FLX1E1(I)=FLX1E1(I)+VTMP3(I,K)
3331 1013 CONTINUE
3332 1014 CONTINUE
3333 !
3334 !---NOW REPEAT FLUX CALCULATIONS FOR THE K=2..LM1 CASES.
3335 ! CALCULATIONS FOR FLUX LEVEL L AND LP1 ARE DONE SEPARATELY, AS ALL
3336 ! EMISSIVITY AND CO2 CALCULATIONS ARE SPECIAL CASES OR NEARBY LAYERS.
3337 !
3338 DO 321 K=2,LM1
3339 KLEN=K
3340 !
3341 DO 3218 KK=1,LP1-K
3342 DO 3218 I=MYIS,MYIE
3343 AVEPHI(I,KK+K-1)=TOTPHI(I,KK+K)-TOTPHI(I,K)
3344 3218 CONTINUE
3345 DO 1803 I=MYIS,MYIE
3346 AVEPHI(I,LP1)=AVEPHI(I,LM1)+EMX1(I)
3347 1803 CONTINUE
3348 !---COMPUTE EMISSIVITY FLUXES (E2) FOR THIS CASE. NOTE THAT
3349 ! WE HAVE OMITTED THE NEARBY LATER CASE (EMISS(I,K,K)) AS WELL
3350 ! AS ALL CASES WITH K=L OR LP1. BUT THESE CASES HAVE ALWAYS
3351 ! BEEN HANDLED AS SPECIAL CASES, SO WE MAY AS WELL COMPUTE
3352 ! THEIR FLUXES SEPARASTELY.
3353 !
3354 CALL E290(EMISSB,EMISS,AVEPHI,KLEN,FXOE2,DTE2, &
3355 ! T1,T2,T4, &
3356 H16E1,HP1,H28E1,HAF,TEN, &
3357 ids,ide, jds,jde, kds,kde, &
3358 ims,ime, jms,jme, kms,kme, &
3359 its,ite, jts,jte, kts,kte )
3360
3361 DO 322 KK=1,LP1-K
3362 DO 322 I=MYIS,MYIE
3363 AVMO3(I,KK+K-1)=TOTO3(I,KK+K)-TOTO3(I,K)
3364 AVPHO3(I,KK+K-1)=TPHIO3(I,KK+K)-TPHIO3(I,K)
3365 AVVO2(I,KK+K-1)=TOTVO2(I,KK+K)-TOTVO2(I,K)
3366 CONT1D(I,KK+K-1)=CNTTAU(I,KK+K-1)*TOTEVV(I,K-1)
3367 322 CONTINUE
3368 !
3369 DO 3221 KK=1,LP1-K
3370 DO 3221 I=MYIS,MYIE
3371 FAC1(I,K+KK-1)=BO3RND(2)*AVPHO3(I,K+KK-1)/AVMO3(I,K+KK-1)
3372 VTMP3(I,K+KK-1)=HAF*(FAC1(I,K+KK-1)* &
3373 (SQRT(ONE+(FOUR*AO3RND(2)*AVMO3(I,K+KK-1))/ &
3374 FAC1(I,K+KK-1))-ONE))
3375 TO31D(I,K+KK-1)=EXP(HM1EZ*(VTMP3(I,K+KK-1) &
3376 +SKO3R*AVVO2(I,K+KK-1)))
3377 OVER1D(I,K+KK-1)=EXP(HM1EZ*(SQRT(AB15WD*AVEPHI(I,K+KK-1))+ &
3378 SKC1R*AVVO2(I,K+KK-1)))
3379 CO21(I,K+KK,K)=OVER1D(I,K+KK-1)*CO21(I,K+KK,K)
3380 3221 CONTINUE
3381 DO 3223 KP=K+1,LP1
3382 DO 3223 I=MYIS,MYIE
3383 CO21(I,K,KP)=OVER1D(I,KP-1)*CO21(I,K,KP)
3384 3223 CONTINUE
3385 !---RLOG IS THE NBL AMOUNT FOR THE 15 UM BAND CALCULATION
3386 DO 1804 I=MYIS,MYIE
3387 RLOG(I,K)=OVER1D(I,K)*CO2NBL(I,K)
3388 1804 CONTINUE
3389 !---THE KP TERMS FOR ARBIRRARY K..
3390 DO 3423 KP=K+1,LP1
3391 DO 3423 I=MYIS,MYIE
3392 FLX(I,K)=FLX(I,K)+(OSS(I,KP)*TO31D(I,KP-1) &
3393 +SS2(I,KP)*CONT1D(I,KP-1) &
3394 +CSS(I,KP)*CO21(I,KP,K) &
3395 +DTC(I,KP)*EMISS(I,KP-1))*CLDFAC(I,KP,K)
3396 3423 CONTINUE
3397 DO 3425 KP=K+1,LP1
3398 DO 3425 I=MYIS,MYIE
3399 FLX(I,KP)=FLX(I,KP)+(OSS(I,K)*TO31D(I,KP-1) &
3400 +SS2(I,K)*CONT1D(I,KP-1) &
3401 +CSS(I,K)*CO21(I,K,KP) &
3402 +DTC(I,K)*EMISSB(I,KP-1))*CLDFAC(I,K,KP)
3403 3425 CONTINUE
3404 321 CONTINUE
3405 !
3406 DO 821 I=MYIS,MYIE
3407 TPL(I,1)=TEMP(I,L)
3408 TPL(I,LP1)=HAF*(T(I,LP1)+TEMP(I,L))
3409 TPL(I,LLP1)=HAF*(T(I,L)+TEMP(I,L))
3410 821 CONTINUE
3411 DO 823 K=2,L
3412 DO 823 I=MYIS,MYIE
3413 TPL(I,K)=T(I,K)
3414 TPL(I,K+L)=T(I,K)
3415 823 CONTINUE
3416 !
3417 !---E2 FUNCTIONS ARE REQUIRED IN THE NBL CALCULATIONS FOR 2 CASES,
3418 ! DENOTED (IN OLD CODE) AS (L,LP1) AND (LP1,LP1)
3419 DO 833 I=MYIS,MYIE
3420 AVEPHI(I,1)=VAR2(I,L)
3421 AVEPHI(I,2)=VAR2(I,L)+EMPL(I,L)
3422 833 CONTINUE
3423 CALL E2SPEC(EMISS,AVEPHI,FXOSP,DTSP, &
3424 ! T1,T2,T4, &
3425 H16E1,TEN,H28E1,HP1, &
3426 ids,ide, jds,jde, kds,kde, &
3427 ims,ime, jms,jme, kms,kme, &
3428 its,ite, jts,jte, kts,kte )
3429
3430 !
3431 ! CALL E3V88 FOR NBL H2O TRANSMISSIVITIES
3432 ! CALL E3V88(EMD,TPL,EMPL,EM3V, &
3433 CALL E3V88(EMD,TPL,EMPL, &
3434 TEN,HP1,H28E1,H16E1, &
3435 ids,ide, jds,jde, kds,kde, &
3436 ims,ime, jms,jme, kms,kme, &
3437 its,ite, jts,jte, kts,kte )
3438 !
3439 ! COMPUTE NEARBY LAYER AND SPECIAL-CASE TRANSMISSIVITIES FOR EMISS
3440 ! USING METHODS FOR H2O GIVEN IN REF. (4)
3441 DO 851 K=2,L
3442 DO 851 I=MYIS,MYIE
3443 EMISDG(I,K)=EMD(I,K+L)+EMD(I,K)
3444 851 CONTINUE
3445 !
3446 ! NOTE THAT EMX1/2 (PRESSURE SCALED PATHS) ARE NOW COMPUTED IN
3447 ! LWR88
3448 DO 861 I=MYIS,MYIE
3449 EMSPEC(I,1)=(EMD(I,1)*EMPL(I,1)-EMD(I,LP1)*EMPL(I,LP1))/ &
3450 EMX1(I) + QUARTR*(EMISS(I,1)+EMISS(I,2))
3451 EMISDG(I,LP1)=TWO*EMD(I,LP1)
3452 EMSPEC(I,2)=TWO*(EMD(I,1)*EMPL(I,1)-EMD(I,LLP1)*EMPL(I,LLP1))/ &
3453 EMX2(I)
3454 861 CONTINUE
3455 DO 331 I=MYIS,MYIE
3456 FAC1(I,L)=BO3RND(2)*VAR4(I,L)/VAR3(I,L)
3457 VTMP3(I,L)=HAF*(FAC1(I,L)* &
3458 (SQRT(ONE+(FOUR*AO3RND(2)*VAR3(I,L))/FAC1(I,L))-ONE))
3459 TO31D(I,L)=EXP(HM1EZ*(VTMP3(I,L)+SKO3R*CNTVAL(I,L)))
3460 OVER1D(I,L)=EXP(HM1EZ*(SQRT(AB15WD*VAR2(I,L))+ &
3461 SKC1R*CNTVAL(I,L)))
3462 CONT1D(I,L)=CNTTAU(I,L)*TOTEVV(I,LM1)
3463 RLOG(I,L)=OVER1D(I,L)*CO2NBL(I,L)
3464 331 CONTINUE
3465 DO 618 K=1,L
3466 DO 618 I=MYIS,MYIE
3467 RLOG(I,K)=LOG(RLOG(I,K))
3468 618 CONTINUE
3469 DO 601 K=1,LM1
3470 DO 601 I=MYIS,MYIE
3471 DELPR1(I,K+1)=DELP(I,K+1)*(PRESS(I,K+1)-P(I,K+1))
3472 ALP(I,LP1+K-1)=-SQRT(DELPR1(I,K+1))*RLOG(I,K+1)
3473 601 CONTINUE
3474 DO 603 K=1,L
3475 DO 603 I=MYIS,MYIE
3476 DELPR2(I,K+1)=DELP(I,K)*(P(I,K+1)-PRESS(I,K))
3477 ALP(I,K)=-SQRT(DELPR2(I,K+1))*RLOG(I,K)
3478 603 CONTINUE
3479 DO 625 I=MYIS,MYIE
3480 ALP(I,LL)=-RLOG(I,L)
3481 ALP(I,LLP1)=-RLOG(I,L)*SQRT(DELP(I,L)*(P(I,LP1)-PRESS(I,LM1)))
3482 625 CONTINUE
3483 ! THE FIRST COMPUTATION IS FOR THE 15 UM BAND,WITH THE
3484 ! FOR THE COMBINED H2O AND CO2 TRANSMISSION FUNCTION.
3485 !
3486 ! PERFORM NBL COMPUTATIONS FOR THE 15 UM BAND
3487 !***THE STATEMENT FUNCTION SF IN PREV. VERSIONS IS NOW EXPLICITLY
3488 ! EVALUATED.
3489 DO 631 K=1,LLP1
3490 DO 631 I=MYIS,MYIE
3491 C(I,K)=ALP(I,K)*(HMP66667+ALP(I,K)*(QUARTR+ALP(I,K)*HM6666M2))
3492 631 CONTINUE
3493 DO 641 I=MYIS,MYIE
3494 CO21(I,LP1,LP1)=ONE+C(I,L)
3495 CO21(I,LP1,L)=ONE+(DELP2(I,L)*C(I,LL)-(PRESS(I,L)-P(I,L))* &
3496 C(I,LLM1))/(P(I,LP1)-PRESS(I,L))
3497 CO21(I,L,LP1)=ONE+((P(I,LP1)-PRESS(I,LM1))*C(I,LLP1)- &
3498 (P(I,LP1)-PRESS(I,L))*C(I,L))/(PRESS(I,L)-PRESS(I,LM1))
3499 641 CONTINUE
3500 DO 643 K=2,L
3501 DO 643 I=MYIS,MYIE
3502 CO21(I,K,K)=ONE+HAF*(C(I,LM1+K)+C(I,K-1))
3503 643 CONTINUE
3504 !
3505 ! COMPUTE NEARBY-LAYER TRANSMISSIVITIES FOR THE O3 BAND AND FOR THE
3506 ! ONE-BAND CONTINUUM BAND (TO3 AND EMISS2). THE SF2 FUNCTION IS
3507 ! USED. THE METHOD IS THE SAME AS DESCRIBED FOR CO2 IN REF (4).
3508 DO 651 K=1,LM1
3509 DO 651 I=MYIS,MYIE
3510 CSUB(I,K+1)=CNTVAL(I,K+1)*DELPR1(I,K+1)
3511 CSUB(I,LP1+K-1)=CNTVAL(I,K)*DELPR2(I,K+1)
3512 651 CONTINUE
3513 !---THE SF2 FUNCTION IN PREV. VERSIONS IS NOW EXPLICITLY EVALUATED
3514 DO 655 K=1,LLM2
3515 DO 655 I=MYIS,MYIE
3516 CSUB2(I,K+1)=SKO3R*CSUB(I,K+1)
3517 C(I,K+1)=CSUB(I,K+1)*(HMP5+CSUB(I,K+1)* &
3518 (HP166666-CSUB(I,K+1)*H41666M2))
3519 C2(I,K+1)=CSUB2(I,K+1)*(HMP5+CSUB2(I,K+1)* &
3520 (HP166666-CSUB2(I,K+1)*H41666M2))
3521 655 CONTINUE
3522 DO 661 I=MYIS,MYIE
3523 CONTDG(I,LP1)=1.+C(I,LLM1)
3524 TO3DG(I,LP1)=1.+C2(I,LLM1)
3525 661 CONTINUE
3526 DO 663 K=2,L
3527 DO 663 I=MYIS,MYIE
3528 CONTDG(I,K)=ONE+HAF*(C(I,K)+C(I,LM1+K))
3529 TO3DG(I,K)=ONE+HAF*(C2(I,K)+C2(I,LM1+K))
3530 663 CONTINUE
3531 !---NOW OBTAIN FLUXES
3532 !
3533 ! FOR THE DIAGONAL TERMS...
3534 DO 871 K=2,LP1
3535 DO 871 I=MYIS,MYIE
3536 FLX(I,K)=FLX(I,K)+(DTC(I,K)*EMISDG(I,K) &
3537 +SS2(I,K)*CONTDG(I,K) &
3538 +OSS(I,K)*TO3DG(I,K) &
3539 +CSS(I,K)*CO21(I,K,K))*CLDFAC(I,K,K)
3540 871 CONTINUE
3541 ! FOR THE TWO OFF-DIAGONAL TERMS...
3542 DO 873 I=MYIS,MYIE
3543 FLX(I,L)=FLX(I,L)+(CSS(I,LP1)*CO21(I,LP1,L) &
3544 +DTC(I,LP1)*EMSPEC(I,2) &
3545 +OSS(I,LP1)*TO31D(I,L) &
3546 +SS2(I,LP1)*CONT1D(I,L))*CLDFAC(I,LP1,L)
3547 FLX(I,LP1)=FLX(I,LP1)+(CSS(I,L)*CO21(I,L,LP1) &
3548 +OSS(I,L)*TO31D(I,L) &
3549 +SS2(I,L)*CONT1D(I,L) &
3550 +DTC(I,L)*EMSPEC(I,1))*CLDFAC(I,L,LP1)
3551 873 CONTINUE
3552 !
3553 ! FINAL SECTION OBTAINS EMISSIVITY HEATING RATES,
3554 ! TOTAL HEATING RATES AND THE FLUX AT THE GROUND
3555 !
3556 ! .....CALCULATE THE EMISSIVITY HEATING RATES
3557 DO 1101 K=1,L
3558 DO 1101 I=MYIS,MYIE
3559 HEATEM(I,K)=RADCON*(FLX(I,K+1)-FLX(I,K))*DELP(I,K)
3560 1101 CONTINUE
3561 ! .....CALCULATE THE TOTAL HEATING RATES
3562 DO 1103 K=1,L
3563 DO 1103 I=MYIS,MYIE
3564 HEATRA(I,K)=HEATEM(I,K)-CTS(I,K)-CTSO3(I,K)+EXCTS(I,K)
3565 1103 CONTINUE
3566 ! .....CALCULATE THE FLUX AT EACH FLUX LEVEL USING THE FLUX AT THE
3567 ! TOP (FLX1E1+GXCTS) AND THE INTEGRAL OF THE HEATING RATES (VSUM1)
3568 DO 1111 K=1,L
3569 DO 1111 I=MYIS,MYIE
3570 VSUM1(I,K)=HEATRA(I,K)*DELP2(I,K)*RADCON1
3571 1111 CONTINUE
3572 DO 1115 I=MYIS,MYIE
3573 TOPFLX(I)=FLX1E1(I)+GXCTS(I)
3574 FLXNET(I,1)=TOPFLX(I)
3575 1115 CONTINUE
3576 !---ONLY THE SURFACE VALUE OF FLUX (GRNFLX) IS NEEDED UNLESS
3577 ! THE THICK CLOUD SECTION IS INVOKED.
3578 DO 1123 K=2,LP1
3579 DO 1123 I=MYIS,MYIE
3580 FLXNET(I,K)=FLXNET(I,K-1)+VSUM1(I,K-1)
3581 1123 CONTINUE
3582 DO 1125 I=MYIS,MYIE
3583 GRNFLX(I)=FLXNET(I,LP1)
3584 1125 CONTINUE
3585 !
3586 ! THIS IS THE THICK CLOUD SECTION.OPTIONALLY,IF THICK CLOUD
3587 ! FLUXES ARE TO BE "CONVECTIVELY ADJUSTED",IE,DF/DP IS CONSTANT,
3588 ! FOR CLOUDY PART OF GRID POINT, THE FOLLOWING CODE IS EXECUTED.
3589 !***FIRST,COUNT THE NUMBER OF CLOUDS ALONG THE LAT. ROW. SKIP THE
3590 ! ENTIRE THICK CLOUD COMPUTATION OF THERE ARE NO CLOUDS.
3591 ICNT=0
3592 DO 1301 I=MYIS,MYIE
3593 ICNT=ICNT+NCLDS(I)
3594 1301 CONTINUE
3595 IF (ICNT.EQ.0) GO TO 6999
3596 !---FIND THE MAXIMUM NUMBER OF CLOUDS IN THE LATITUDE ROW
3597 KCLDS=NCLDS(MYIS)
3598 DO 2106 I=MYIS,MYIE
3599 KCLDS=MAX(NCLDS(I),KCLDS)
3600 2106 CONTINUE
3601 !
3602 !
3603 !***OBTAIN THE PRESSURES AND FLUXES OF THE TOP AND BOTTOM OF
3604 ! THE NC'TH CLOUD (IT IS ASSUMED THAT ALL KTOP AND KBTM'S HAVE
3605 ! BEEN DEFINED!).
3606 DO 1361 KK=1,KCLDS
3607 KMIN=LP1
3608 KMAX=0
3609 DO 1362 I=MYIS,MYIE
3610 J1=KTOP(I,KK+1)
3611 ! IF (J1.EQ.1) GO TO 1362
3612 J3=KBTM(I,KK+1)
3613 IF (J3.GT.J1) THEN
3614 PTOP(I)=P(I,J1)
3615 PBOT(I)=P(I,J3+1)
3616 FTOP(I)=FLXNET(I,J1)
3617 FBOT(I)=FLXNET(I,J3+1)
3618 !***OBTAIN THE "FLUX DERIVATIVE" DF/DP (DELPTC)
3619 DELPTC(I)=(FTOP(I)-FBOT(I))/(PTOP(I)-PBOT(I))
3620 KMIN=MIN(KMIN,J1)
3621 KMAX=MAX(KMAX,J3)
3622 ENDIF
3623 1362 CONTINUE
3624 KMIN=KMIN+1
3625 !***CALCULATE THE TOT. FLUX CHG. FROM THE TOP OF THE CLOUD, FOR
3626 ! ALL LEVELS.
3627 DO 1365 K=KMIN,KMAX
3628 DO 1363 I=MYIS,MYIE
3629 ! IF (KTOP(I,KK+1).EQ.1) GO TO 1363
3630 IF(KTOP(I,KK+1).LT.K .AND. K.LE.KBTM(I,KK+1)) THEN
3631 Z1(I,K)=(P(I,K)-PTOP(I))*DELPTC(I)+FTOP(I)
3632 !ORIGINAL FLXNET(I,K)=FLXNET(I,K)*(ONE-CAMT(I,KK+1)) +
3633 !ORIGINAL1 Z1(I,K)*CAMT(I,KK+1)
3634 FLXNET(I,K)=Z1(I,K)
3635 ENDIF
3636 1363 CONTINUE
3637 1365 CONTINUE
3638 1361 CONTINUE
3639 !***USING THIS FLUX CHG. IN THE CLOUDY PART OF THE GRID BOX, OBTAIN
3640 ! THE NEW FLUXES, WEIGHTING THE CLEAR AND CLOUDY FLUXES:AGAIN, ONLY
3641 ! THE FLUXES IN THICK-CLOUD LEVELS WILL EVENTUALLY BE USED.
3642 ! DO 6051 K=1,LP1
3643 ! DO 6051 I=MYIS,MYIE
3644 ! FLXNET(I,K)=FLXNET(I,K)*(ONE-CAMT(I,NC)) +
3645 ! 1 Z1(I,K)*CAMT(I,NC)
3646 !051 CONTINUE
3647 !***MERGE FLXTHK INTO FLXNET FOR APPROPRIATE LEVELS.
3648 ! DO 1401 K=1,LP1
3649 ! DO 1401 I=MYIS,MYIE
3650 ! IF (K.GT.ITOP(I) .AND. K.LE.IBOT(I)
3651 ! 1 .AND. (NC-1).LE.NCLDS(I)) THEN
3652 ! FLXNET(I,K)=FLXTHK(I,K)
3653 ! ENDIF
3654 !401 CONTINUE
3655 !
3656 !******END OF CLOUD LOOP*****
3657 6001 CONTINUE
3658 6999 CONTINUE
3659 !***THE FINAL STEP IS TO RECOMPUTE THE HEATING RATES BASED ON THE
3660 ! REVISED FLUXES:
3661 DO 6101 K=1,L
3662 DO 6101 I=MYIS,MYIE
3663 HEATRA(I,K)=RADCON*(FLXNET(I,K+1)-FLXNET(I,K))*DELP(I,K)
3664 6101 CONTINUE
3665 ! THE THICK CLOUD SECTION ENDS HERE.
3666
3667 END SUBROUTINE FST88
3668
3669 !----------------------------------------------------------------------
3670
3671 SUBROUTINE E1E290(G1,G2,G3,G4,G5,EMISS,FXOE1,DTE1,FXOE2,DTE2, &
3672 AVEPHI,TEMP,T, &
3673 ! T1,T2,T4,EM1V,EM1VW, &
3674 H16E1,TEN,HP1,H28E1,HAF, &
3675 ids,ide, jds,jde, kds,kde, &
3676 ims,ime, jms,jme, kms,kme, &
3677 its,ite, jts,jte, kts,kte )
3678 !---------------------------------------------------------------------
3679 IMPLICIT NONE
3680 !----------------------------------------------------------------------
3681 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
3682 ims,ime, jms,jme, kms,kme , &
3683 its,ite, jts,jte, kts,kte
3684 REAL,INTENT(IN) :: H16E1,TEN,HP1,H28E1,HAF
3685
3686 REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte+1) :: G1,G4,G3,EMISS
3687 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: FXOE1,DTE1,FXOE2,DTE2
3688 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: AVEPHI,TEMP,T
3689 REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte) :: G2,G5
3690 ! REAL,INTENT(IN),DIMENSION(5040):: T1,T2,T4 ,EM1V,EM1VW
3691
3692 REAL,DIMENSION(its:ite,kts:kte+1) :: TMP3,DU,FYO,WW1,WW2
3693 INTEGER,DIMENSION(its:ite,kts:kte*3+2) :: IT1
3694 INTEGER,DIMENSION(its:ite,kts:kte+1) :: IVAL
3695
3696 ! REAL,DIMENSION(28,180):: EM1,EM1WDE,TABLE1,TABLE2, &
3697 ! TABLE3
3698 ! EQUIVALENCE (EM1V(1),EM1(1,1)),(EM1VW(1),EM1WDE(1,1))
3699 ! EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), &
3700 ! (T4(1),TABLE3(1,1))
3701
3702 INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
3703 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN
3704
3705 L=kte
3706 LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1
3707 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L
3708 LLM2 = LL-2; LLM1=LL-1
3709 MYIS=its; MYIE=ite
3710
3711 !---FIRST WE OBTAIN THE EMISSIVITIES AS A FUNCTION OF TEMPERATURE
3712 ! (INDEX FXO) AND WATER AMOUNT (INDEX FYO). THIS PART OF THE CODE
3713 ! THUS GENERATES THE E2 FUNCTION. THE FXO INDICES HAVE BEEN
3714 ! OBTAINED IN FST88, FOR CONVENIENCE.
3715 !
3716 !---THIS SUBROUTINE EVALUATES THE K=1 CASE ONLY--
3717 !
3718 !---THIS LOOP REPLACES LOOPS GOING FROMI=1,IMAX AND KP=2,LP1 PLUS
3719 ! THE SPECIAL CASE FOR THE LP1TH LAYER.
3720
3721 DO 1322 K=1,LP1
3722 DO 1322 I=MYIS,MYIE
3723 TMP3(I,K)=LOG10(AVEPHI(I,K))+H16E1
3724 FYO(I,K)=AINT(TMP3(I,K)*TEN)
3725 DU(I,K)=TMP3(I,K)-HP1*FYO(I,K)
3726 FYO(I,K)=H28E1*FYO(I,K)
3727 IVAL(I,K)=FYO(I,K)+FXOE2(I,K)
3728 EMISS(I,K)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) &
3729 +DTE2(I,K)*T4(IVAL(I,K))
3730 1322 CONTINUE
3731 !
3732 !---THE SPECIAL CASE EMISS(I,L) (LAYER KP) IS OBTAINED NOW
3733 ! BY AVERAGING THE VALUES FOR L AND LP1:
3734 DO 1344 I=MYIS,MYIE
3735 EMISS(I,L)=HAF*(EMISS(I,L)+EMISS(I,LP1))
3736 1344 CONTINUE
3737 !
3738 ! CALCULATIONS FOR THE KP=1 LAYER ARE NOT PERFORMED, AS
3739 ! THE RADIATION CODE ASSUMES THAT THE TOP FLUX LAYER (ABOVE THE
3740 ! TOP DATA LEVEL) IS ISOTHERMAL, AND HENCE CONTRIBUTES NOTHING
3741 ! TO THE FLUXES AT OTHER LEVELS.
3742 !
3743 !***THE FOLLOWING IS THE CALCULATION FOR THE E1 FUNCTION, FORMERLY
3744 ! DONE IN SUBROUTINE E1V88. THE MOVE TO E1E288 IS DUE TO THE
3745 ! SAVINGS IN OBTAINING INDEX VALUES (THE TEMP. INDICES HAVE
3746 ! BEEN OBTAINED IN FST88, WHILE THE U-INDICES ARE OBTAINED
3747 ! IN THE E2 CALCS.,WITH K=1).
3748 !
3749 !
3750 ! FOR TERMS INVOLVING TOP LAYER, DU IS NOT KNOWN; IN FACT, WE
3751 ! USE INDEX 2 TO REPERSENT INDEX 1 IN PREV. CODE. THIS MEANS THAT
3752 ! THE IT1 INDEX 1 AND LLP1 HAS TO BE CALCULATED SEPARATELY. THE
3753 ! INDEX LLP2 GIVES THE SAME VALUE AS 1; IT CAN BE OMITTED.
3754 DO 208 I=MYIS,MYIE
3755 IT1(I,1)=FXOE1(I,1)
3756 WW1(I,1)=TEN-DTE1(I,1)
3757 WW2(I,1)=HP1
3758 208 CONTINUE
3759 DO 209 K=1,L
3760 DO 209 I=MYIS,MYIE
3761 IT1(I,K+1)=FYO(I,K)+FXOE1(I,K+1)
3762 IT1(I,LP2+K-1)=FYO(I,K)+FXOE1(I,K)
3763 WW1(I,K+1)=TEN-DTE1(I,K+1)
3764 WW2(I,K+1)=HP1-DU(I,K)
3765 209 CONTINUE
3766 DO 211 KP=1,L
3767 DO 211 I=MYIS,MYIE
3768 IT1(I,KP+LLP1)=FYO(I,KP)+FXOE1(I,1)
3769 211 CONTINUE
3770 !
3771 !
3772 ! G3(I,1) HAS THE SAME VALUES AS G1 (AND DID ALL ALONG)
3773 DO 230 I=MYIS,MYIE
3774 G1(I,1)=WW1(I,1)*WW2(I,1)*EM1V(IT1(I,1))+ &
3775 WW2(I,1)*DTE1(I,1)*EM1V(IT1(I,1)+1)
3776 G3(I,1)=G1(I,1)
3777 230 CONTINUE
3778 DO 240 K=1,L
3779 DO 240 I=MYIS,MYIE
3780 G1(I,K+1)=WW1(I,K+1)*WW2(I,K+1)*EM1V(IT1(I,K+1))+ &
3781 WW2(I,K+1)*DTE1(I,K+1)*EM1V(IT1(I,K+1)+1)+ &
3782 WW1(I,K+1)*DU(I,K)*EM1V(IT1(I,K+1)+28)+ &
3783 DTE1(I,K+1)*DU(I,K)*EM1V(IT1(I,K+1)+29)
3784 G2(I,K)=WW1(I,K)*WW2(I,K+1)*EM1V(IT1(I,K+LP2-1))+ &
3785 WW2(I,K+1)*DTE1(I,K)*EM1V(IT1(I,K+LP2-1)+1)+ &
3786 WW1(I,K)*DU(I,K)*EM1V(IT1(I,K+LP2-1)+28)+ &
3787 DTE1(I,K)*DU(I,K)*EM1V(IT1(I,K+LP2-1)+29)
3788 240 CONTINUE
3789 DO 241 KP=2,LP1
3790 DO 241 I=MYIS,MYIE
3791 G3(I,KP)=WW1(I,1)*WW2(I,KP)*EM1V(IT1(I,LL+KP))+ &
3792 WW2(I,KP)*DTE1(I,1)*EM1V(IT1(I,LL+KP)+1)+ &
3793 WW1(I,1)*DU(I,KP-1)*EM1V(IT1(I,LL+KP)+28)+ &
3794 DTE1(I,1)*DU(I,KP-1)*EM1V(IT1(I,LL+KP)+29)
3795 241 CONTINUE
3796 !
3797 DO 244 I=MYIS,MYIE
3798 G4(I,1)=WW1(I,1)*WW2(I,1)*EM1VW(IT1(I,1))+ &
3799 WW2(I,1)*DTE1(I,1)*EM1VW(IT1(I,1)+1)
3800 244 CONTINUE
3801 DO 242 K=1,L
3802 DO 242 I=MYIS,MYIE
3803 G4(I,K+1)=WW1(I,K+1)*WW2(I,K+1)*EM1VW(IT1(I,K+1))+ &
3804 WW2(I,K+1)*DTE1(I,K+1)*EM1VW(IT1(I,K+1)+1)+ &
3805 WW1(I,K+1)*DU(I,K)*EM1VW(IT1(I,K+1)+28)+ &
3806 DTE1(I,K+1)*DU(I,K)*EM1VW(IT1(I,K+1)+29)
3807 G5(I,K)=WW1(I,K)*WW2(I,K+1)*EM1VW(IT1(I,K+LP2-1))+ &
3808 WW2(I,K+1)*DTE1(I,K)*EM1VW(IT1(I,K+LP2-1)+1)+ &
3809 WW1(I,K)*DU(I,K)*EM1VW(IT1(I,K+LP2-1)+28)+ &
3810 DTE1(I,K)*DU(I,K)*EM1VW(IT1(I,K+LP2-1)+29)
3811 242 CONTINUE
3812 !
3813 END SUBROUTINE E1E290
3814
3815 !----------------------------------------------------------------------
3816
3817 SUBROUTINE SPA88(EXCTS,CTSO3,GXCTS,SORC,CSOUR, &
3818 CLDFAC,TEMP,PRESS,VAR1,VAR2, &
3819 P,DELP,DELP2,TOTVO2,TO3SP,TO3SPC, &
3820 CO2SP1,CO2SP2,CO2SP, &
3821 APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
3822 H25E2,ONE,H44194M2,H1P41819,HAF,HM1EZ,TWO, &
3823 ! SKO2D,RADCON, &
3824 RADCON, &
3825 ids,ide, jds,jde, kds,kde, &
3826 ims,ime, jms,jme, kms,kme, &
3827 its,ite, jts,jte, kts,kte )
3828 !---------------------------------------------------------------------
3829 IMPLICIT NONE
3830 !----------------------------------------------------------------------
3831 ! INTEGER, PARAMETER :: NBLY=15
3832 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
3833 ims,ime, jms,jme, kms,kme , &
3834 its,ite, jts,jte, kts,kte
3835
3836 REAL,INTENT(IN) :: H25E2,ONE,H44194M2,H1P41819,HAF,HM1EZ,TWO, &
3837 RADCON
3838 ! SKO2D,RADCON
3839
3840 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: CSOUR
3841 REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte) :: CTSO3
3842 REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte) :: EXCTS
3843 REAL,INTENT(OUT),DIMENSION(its:ite) :: GXCTS
3844 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1,NBLY) :: SORC
3845 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC
3846 REAL,INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: PRESS,TEMP
3847
3848 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte) :: VAR1,VAR2
3849 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: P
3850 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte) :: DELP,DELP2,TO3SPC
3851 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) ::TOTVO2,TO3SP,CO2SP1,&
3852 CO2SP2,CO2SP
3853 REAL,INTENT(IN),DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
3854 BCOMB,BETACM
3855
3856 REAL,DIMENSION(its:ite,kts:kte+1) ::CTMP,CTMP2,CTMP3
3857 REAL,DIMENSION(its:ite,kts:kte) ::X,Y,FAC1,FAC2,F,FF,AG,AGG, &
3858 PHITMP,PSITMP,TOPM,TOPPHI,TT
3859
3860 INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
3861 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN
3862
3863 L=kte
3864 LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1
3865 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L
3866 LLM2 = LL-2; LLM1=LL-1
3867 MYIS=its; MYIE=ite
3868
3869 !--!COMPUTE TEMPERATURE QUANTITIES FOR USE IN PROGRAM
3870
3871 DO 101 K=1,L
3872 DO 101 I=MYIS,MYIE
3873 X(I,K)=TEMP(I,K)-H25E2
3874 Y(I,K)=X(I,K)*X(I,K)
3875 101 CONTINUE
3876 !---INITIALIZE CTMP(I,1),CTMP2(I,1),CTMP3(I,1) TO UNITY; THESE ARE
3877 ! TRANSMISSION FCTNS AT THE TOP.
3878 DO 345 I=MYIS,MYIE
3879 CTMP(I,1)=ONE
3880 CTMP2(I,1)=1.
3881 CTMP3(I,1)=1.
3882 345 CONTINUE
3883 !***BEGIN LOOP ON FREQUENCY BANDS (1)***
3884 !
3885 !---CALCULATION FOR BAND 1 (COMBINED BAND 1)
3886 !
3887 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
3888 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
3889 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
3890 DO 301 K=1,L
3891 DO 301 I=MYIS,MYIE
3892 F(I,K)=H44194M2*(APCM(1)*X(I,K)+BPCM(1)*Y(I,K))
3893 FF(I,K)=H44194M2*(ATPCM(1)*X(I,K)+BTPCM(1)*Y(I,K))
3894 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
3895 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
3896 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
3897 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
3898 301 CONTINUE
3899 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
3900 ! P(K) (TOPM,TOPPHI)
3901 DO 315 I=MYIS,MYIE
3902 TOPM(I,1)=PHITMP(I,1)
3903 TOPPHI(I,1)=PSITMP(I,1)
3904 315 CONTINUE
3905 DO 319 K=2,L
3906 DO 317 I=MYIS,MYIE
3907 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
3908 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
3909 317 CONTINUE
3910 319 CONTINUE
3911 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
3912 DO 321 K=1,L
3913 DO 321 I=MYIS,MYIE
3914 FAC1(I,K)=ACOMB(1)*TOPM(I,K)
3915 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(1)*TOPPHI(I,K))
3916 TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
3917 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
3918 321 CONTINUE
3919 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
3920 DO 353 K=1,L
3921 DO 353 I=MYIS,MYIE
3922 EXCTS(I,K)=SORC(I,K,1)*(CTMP(I,K+1)-CTMP(I,K))
3923 353 CONTINUE
3924 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
3925 DO 361 I=MYIS,MYIE
3926 GXCTS(I)=CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,1)+ &
3927 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
3928 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
3929 (SORC(I,LP1,1)-SORC(I,L,1)))
3930 361 CONTINUE
3931 !
3932 !
3933 !-----CALCULATION FOR BAND 2 (COMBINED BAND 2)
3934 !
3935 !
3936 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
3937 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
3938 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
3939 DO 401 K=1,L
3940 DO 401 I=MYIS,MYIE
3941 F(I,K)=H44194M2*(APCM(2)*X(I,K)+BPCM(2)*Y(I,K))
3942 FF(I,K)=H44194M2*(ATPCM(2)*X(I,K)+BTPCM(2)*Y(I,K))
3943 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
3944 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
3945 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
3946 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
3947 401 CONTINUE
3948 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
3949 ! P(K) (TOPM,TOPPHI)
3950 DO 415 I=MYIS,MYIE
3951 TOPM(I,1)=PHITMP(I,1)
3952 TOPPHI(I,1)=PSITMP(I,1)
3953 415 CONTINUE
3954 DO 419 K=2,L
3955 DO 417 I=MYIS,MYIE
3956 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
3957 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
3958 417 CONTINUE
3959 419 CONTINUE
3960 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
3961 DO 421 K=1,L
3962 DO 421 I=MYIS,MYIE
3963 FAC1(I,K)=ACOMB(2)*TOPM(I,K)
3964 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(2)*TOPPHI(I,K))
3965 TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
3966 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
3967 421 CONTINUE
3968 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
3969 DO 453 K=1,L
3970 DO 453 I=MYIS,MYIE
3971 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,2)* &
3972 (CTMP(I,K+1)-CTMP(I,K))
3973 453 CONTINUE
3974 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
3975 DO 461 I=MYIS,MYIE
3976 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,2)+ &
3977 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
3978 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
3979 (SORC(I,LP1,2)-SORC(I,L,2)))
3980 461 CONTINUE
3981 !
3982 !-----CALCULATION FOR BAND 3 (COMBINED BAND 3)
3983 !
3984 !
3985 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
3986 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
3987 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
3988 DO 501 K=1,L
3989 DO 501 I=MYIS,MYIE
3990 F(I,K)=H44194M2*(APCM(3)*X(I,K)+BPCM(3)*Y(I,K))
3991 FF(I,K)=H44194M2*(ATPCM(3)*X(I,K)+BTPCM(3)*Y(I,K))
3992 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
3993 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
3994 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
3995 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
3996 501 CONTINUE
3997 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
3998 ! P(K) (TOPM,TOPPHI)
3999 DO 515 I=MYIS,MYIE
4000 TOPM(I,1)=PHITMP(I,1)
4001 TOPPHI(I,1)=PSITMP(I,1)
4002 515 CONTINUE
4003 DO 519 K=2,L
4004 DO 517 I=MYIS,MYIE
4005 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4006 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4007 517 CONTINUE
4008 519 CONTINUE
4009 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4010 DO 521 K=1,L
4011 DO 521 I=MYIS,MYIE
4012 FAC1(I,K)=ACOMB(3)*TOPM(I,K)
4013 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(3)*TOPPHI(I,K))
4014 TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
4015 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4016 521 CONTINUE
4017 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4018 DO 553 K=1,L
4019 DO 553 I=MYIS,MYIE
4020 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,3)* &
4021 (CTMP(I,K+1)-CTMP(I,K))
4022 553 CONTINUE
4023 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4024 DO 561 I=MYIS,MYIE
4025 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,3)+ &
4026 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4027 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4028 (SORC(I,LP1,3)-SORC(I,L,3)))
4029 561 CONTINUE
4030 !
4031 !-----CALCULATION FOR BAND 4 (COMBINED BAND 4)
4032 !
4033 !
4034 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4035 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4036 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4037 DO 601 K=1,L
4038 DO 601 I=MYIS,MYIE
4039 F(I,K)=H44194M2*(APCM(4)*X(I,K)+BPCM(4)*Y(I,K))
4040 FF(I,K)=H44194M2*(ATPCM(4)*X(I,K)+BTPCM(4)*Y(I,K))
4041 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4042 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4043 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4044 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4045 601 CONTINUE
4046 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4047 ! P(K) (TOPM,TOPPHI)
4048 DO 615 I=MYIS,MYIE
4049 TOPM(I,1)=PHITMP(I,1)
4050 TOPPHI(I,1)=PSITMP(I,1)
4051 615 CONTINUE
4052 DO 619 K=2,L
4053 DO 617 I=MYIS,MYIE
4054 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4055 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4056 617 CONTINUE
4057 619 CONTINUE
4058 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4059 DO 621 K=1,L
4060 DO 621 I=MYIS,MYIE
4061 FAC1(I,K)=ACOMB(4)*TOPM(I,K)
4062 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(4)*TOPPHI(I,K))
4063 TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K)))
4064 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4065 621 CONTINUE
4066 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4067 DO 653 K=1,L
4068 DO 653 I=MYIS,MYIE
4069 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,4)* &
4070 (CTMP(I,K+1)-CTMP(I,K))
4071 653 CONTINUE
4072 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4073 DO 661 I=MYIS,MYIE
4074 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,4)+ &
4075 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4076 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4077 (SORC(I,LP1,4)-SORC(I,L,4)))
4078 661 CONTINUE
4079 !
4080 !-----CALCULATION FOR BAND 5 (COMBINED BAND 5)
4081 !
4082 !
4083 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4084 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4085 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4086 DO 701 K=1,L
4087 DO 701 I=MYIS,MYIE
4088 F(I,K)=H44194M2*(APCM(5)*X(I,K)+BPCM(5)*Y(I,K))
4089 FF(I,K)=H44194M2*(ATPCM(5)*X(I,K)+BTPCM(5)*Y(I,K))
4090 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4091 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4092 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4093 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4094 701 CONTINUE
4095 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4096 ! P(K) (TOPM,TOPPHI)
4097 DO 715 I=MYIS,MYIE
4098 TOPM(I,1)=PHITMP(I,1)
4099 TOPPHI(I,1)=PSITMP(I,1)
4100 715 CONTINUE
4101 DO 719 K=2,L
4102 DO 717 I=MYIS,MYIE
4103 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4104 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4105 717 CONTINUE
4106 719 CONTINUE
4107 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4108 DO 721 K=1,L
4109 DO 721 I=MYIS,MYIE
4110 FAC1(I,K)=ACOMB(5)*TOPM(I,K)
4111 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(5)*TOPPHI(I,K))
4112 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4113 BETACM(5)*TOTVO2(I,K+1)*SKO2D))
4114 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4115 721 CONTINUE
4116 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4117 DO 753 K=1,L
4118 DO 753 I=MYIS,MYIE
4119 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,5)* &
4120 (CTMP(I,K+1)-CTMP(I,K))
4121 753 CONTINUE
4122 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4123 DO 761 I=MYIS,MYIE
4124 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,5)+ &
4125 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4126 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4127 (SORC(I,LP1,5)-SORC(I,L,5)))
4128 761 CONTINUE
4129 !
4130 !-----CALCULATION FOR BAND 6 (COMBINED BAND 6)
4131 !
4132 !
4133 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4134 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4135 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4136 DO 801 K=1,L
4137 DO 801 I=MYIS,MYIE
4138 F(I,K)=H44194M2*(APCM(6)*X(I,K)+BPCM(6)*Y(I,K))
4139 FF(I,K)=H44194M2*(ATPCM(6)*X(I,K)+BTPCM(6)*Y(I,K))
4140 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4141 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4142 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4143 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4144 801 CONTINUE
4145 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4146 ! P(K) (TOPM,TOPPHI)
4147 DO 815 I=MYIS,MYIE
4148 TOPM(I,1)=PHITMP(I,1)
4149 TOPPHI(I,1)=PSITMP(I,1)
4150 815 CONTINUE
4151 DO 819 K=2,L
4152 DO 817 I=MYIS,MYIE
4153 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4154 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4155 817 CONTINUE
4156 819 CONTINUE
4157 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4158 DO 821 K=1,L
4159 DO 821 I=MYIS,MYIE
4160 FAC1(I,K)=ACOMB(6)*TOPM(I,K)
4161 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(6)*TOPPHI(I,K))
4162 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4163 BETACM(6)*TOTVO2(I,K+1)*SKO2D))
4164 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4165 821 CONTINUE
4166 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4167 DO 853 K=1,L
4168 DO 853 I=MYIS,MYIE
4169 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,6)* &
4170 (CTMP(I,K+1)-CTMP(I,K))
4171 853 CONTINUE
4172 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4173 DO 861 I=MYIS,MYIE
4174 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,6)+ &
4175 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4176 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4177 (SORC(I,LP1,6)-SORC(I,L,6)))
4178 861 CONTINUE
4179 !
4180 !-----CALCULATION FOR BAND 7 (COMBINED BAND 7)
4181 !
4182 !
4183 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4184 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4185 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4186 DO 901 K=1,L
4187 DO 901 I=MYIS,MYIE
4188 F(I,K)=H44194M2*(APCM(7)*X(I,K)+BPCM(7)*Y(I,K))
4189 FF(I,K)=H44194M2*(ATPCM(7)*X(I,K)+BTPCM(7)*Y(I,K))
4190 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4191 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4192 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4193 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4194 901 CONTINUE
4195 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4196 ! P(K) (TOPM,TOPPHI)
4197 DO 915 I=MYIS,MYIE
4198 TOPM(I,1)=PHITMP(I,1)
4199 TOPPHI(I,1)=PSITMP(I,1)
4200 915 CONTINUE
4201 DO 919 K=2,L
4202 DO 917 I=MYIS,MYIE
4203 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4204 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4205 917 CONTINUE
4206 919 CONTINUE
4207 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4208 DO 921 K=1,L
4209 DO 921 I=MYIS,MYIE
4210 FAC1(I,K)=ACOMB(7)*TOPM(I,K)
4211 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(7)*TOPPHI(I,K))
4212 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4213 BETACM(7)*TOTVO2(I,K+1)*SKO2D))
4214 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4215 921 CONTINUE
4216 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4217 DO 953 K=1,L
4218 DO 953 I=MYIS,MYIE
4219 EXCTS(I,K)=EXCTS(I,K)+SORC(I,k,7)* &
4220 (CTMP(I,K+1)-CTMP(I,K))
4221 953 CONTINUE
4222 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4223 DO 961 I=MYIS,MYIE
4224 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,7)+ &
4225 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4226 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4227 (SORC(I,LP1,7)-SORC(I,L,7)))
4228 961 CONTINUE
4229 !
4230 !-----CALCULATION FOR BAND 8 (COMBINED BAND 8)
4231 !
4232 !
4233 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4234 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4235 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4236 DO 1001 K=1,L
4237 DO 1001 I=MYIS,MYIE
4238 F(I,K)=H44194M2*(APCM(8)*X(I,K)+BPCM(8)*Y(I,K))
4239 FF(I,K)=H44194M2*(ATPCM(8)*X(I,K)+BTPCM(8)*Y(I,K))
4240 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4241 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4242 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4243 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4244 1001 CONTINUE
4245 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4246 ! P(K) (TOPM,TOPPHI)
4247 DO 1015 I=MYIS,MYIE
4248 TOPM(I,1)=PHITMP(I,1)
4249 TOPPHI(I,1)=PSITMP(I,1)
4250 1015 CONTINUE
4251 DO 1019 K=2,L
4252 DO 1017 I=MYIS,MYIE
4253 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4254 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4255 1017 CONTINUE
4256 1019 CONTINUE
4257 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4258 DO 1021 K=1,L
4259 DO 1021 I=MYIS,MYIE
4260 FAC1(I,K)=ACOMB(8)*TOPM(I,K)
4261 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(8)*TOPPHI(I,K))
4262 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4263 BETACM(8)*TOTVO2(I,K+1)*SKO2D))
4264 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4265 1021 CONTINUE
4266 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4267 DO 1053 K=1,L
4268 DO 1053 I=MYIS,MYIE
4269 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,8)* &
4270 (CTMP(I,K+1)-CTMP(I,K))
4271 1053 CONTINUE
4272 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4273 DO 1061 I=MYIS,MYIE
4274 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,8)+ &
4275 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4276 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4277 (SORC(I,LP1,8)-SORC(I,L,8)))
4278 1061 CONTINUE
4279 !
4280 !-----CALCULATION FOR BAND 9 ( 560-670 CM-1; INCLUDES CO2)
4281 !
4282 !
4283 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4284 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4285 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4286 DO 1101 K=1,L
4287 DO 1101 I=MYIS,MYIE
4288 F(I,K)=H44194M2*(APCM(9)*X(I,K)+BPCM(9)*Y(I,K))
4289 FF(I,K)=H44194M2*(ATPCM(9)*X(I,K)+BTPCM(9)*Y(I,K))
4290 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4291 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4292 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4293 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4294 1101 CONTINUE
4295 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4296 ! P(K) (TOPM,TOPPHI)
4297 DO 1115 I=MYIS,MYIE
4298 TOPM(I,1)=PHITMP(I,1)
4299 TOPPHI(I,1)=PSITMP(I,1)
4300 1115 CONTINUE
4301 DO 1119 K=2,L
4302 DO 1117 I=MYIS,MYIE
4303 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4304 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4305 1117 CONTINUE
4306 1119 CONTINUE
4307 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4308 DO 1121 K=1,L
4309 DO 1121 I=MYIS,MYIE
4310 FAC1(I,K)=ACOMB(9)*TOPM(I,K)
4311 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(9)*TOPPHI(I,K))
4312 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4313 BETACM(9)*TOTVO2(I,K+1)*SKO2D))*CO2SP1(I,K+1)
4314 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4315 1121 CONTINUE
4316 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4317 DO 1153 K=1,L
4318 DO 1153 I=MYIS,MYIE
4319 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,9)* &
4320 (CTMP(I,K+1)-CTMP(I,K))
4321 1153 CONTINUE
4322 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4323 DO 1161 I=MYIS,MYIE
4324 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,9)+ &
4325 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4326 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4327 (SORC(I,LP1,9)-SORC(I,L,9)))
4328 1161 CONTINUE
4329 !
4330 !-----CALCULATION FOR BAND 10 (670-800 CM-1; INCLUDES CO2)
4331 !
4332 !
4333 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4334 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4335 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4336 DO 1201 K=1,L
4337 DO 1201 I=MYIS,MYIE
4338 F(I,K)=H44194M2*(APCM(10)*X(I,K)+BPCM(10)*Y(I,K))
4339 FF(I,K)=H44194M2*(ATPCM(10)*X(I,K)+BTPCM(10)*Y(I,K))
4340 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4341 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4342 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4343 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4344 1201 CONTINUE
4345 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4346 ! P(K) (TOPM,TOPPHI)
4347 DO 1215 I=MYIS,MYIE
4348 TOPM(I,1)=PHITMP(I,1)
4349 TOPPHI(I,1)=PSITMP(I,1)
4350 1215 CONTINUE
4351 DO 1219 K=2,L
4352 DO 1217 I=MYIS,MYIE
4353 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4354 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4355 1217 CONTINUE
4356 1219 CONTINUE
4357 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4358 DO 1221 K=1,L
4359 DO 1221 I=MYIS,MYIE
4360 FAC1(I,K)=ACOMB(10)*TOPM(I,K)
4361 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(10)*TOPPHI(I,K))
4362 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4363 BETACM(10)*TOTVO2(I,K+1)*SKO2D))*CO2SP2(I,K+1)
4364 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4365 1221 CONTINUE
4366 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4367 DO 1253 K=1,L
4368 DO 1253 I=MYIS,MYIE
4369 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,10)* &
4370 (CTMP(I,K+1)-CTMP(I,K))
4371 1253 CONTINUE
4372 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4373 DO 1261 I=MYIS,MYIE
4374 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,10)+ &
4375 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4376 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4377 (SORC(I,LP1,10)-SORC(I,L,10)))
4378 1261 CONTINUE
4379 !
4380 !-----CALCULATION FOR BAND 11 (800-900 CM-1)
4381 !
4382 !
4383 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4384 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4385 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4386 DO 1301 K=1,L
4387 DO 1301 I=MYIS,MYIE
4388 F(I,K)=H44194M2*(APCM(11)*X(I,K)+BPCM(11)*Y(I,K))
4389 FF(I,K)=H44194M2*(ATPCM(11)*X(I,K)+BTPCM(11)*Y(I,K))
4390 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4391 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4392 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4393 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4394 1301 CONTINUE
4395 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4396 ! P(K) (TOPM,TOPPHI)
4397 DO 1315 I=MYIS,MYIE
4398 TOPM(I,1)=PHITMP(I,1)
4399 TOPPHI(I,1)=PSITMP(I,1)
4400 1315 CONTINUE
4401 DO 1319 K=2,L
4402 DO 1317 I=MYIS,MYIE
4403 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4404 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4405 1317 CONTINUE
4406 1319 CONTINUE
4407 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4408 DO 1321 K=1,L
4409 DO 1321 I=MYIS,MYIE
4410 FAC1(I,K)=ACOMB(11)*TOPM(I,K)
4411 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(11)*TOPPHI(I,K))
4412 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4413 BETACM(11)*TOTVO2(I,K+1)*SKO2D))
4414 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4415 1321 CONTINUE
4416 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4417 DO 1353 K=1,L
4418 DO 1353 I=MYIS,MYIE
4419 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,11)* &
4420 (CTMP(I,K+1)-CTMP(I,K))
4421 1353 CONTINUE
4422 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4423 DO 1361 I=MYIS,MYIE
4424 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,11)+ &
4425 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4426 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4427 (SORC(I,LP1,11)-SORC(I,L,11)))
4428 1361 CONTINUE
4429 !
4430 !-----CALCULATION FOR BAND 12 (900-990 CM-1)
4431 !
4432 !
4433 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4434 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4435 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4436 DO 1401 K=1,L
4437 DO 1401 I=MYIS,MYIE
4438 F(I,K)=H44194M2*(APCM(12)*X(I,K)+BPCM(12)*Y(I,K))
4439 FF(I,K)=H44194M2*(ATPCM(12)*X(I,K)+BTPCM(12)*Y(I,K))
4440 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4441 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4442 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4443 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4444 1401 CONTINUE
4445 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4446 ! P(K) (TOPM,TOPPHI)
4447 DO 1415 I=MYIS,MYIE
4448 TOPM(I,1)=PHITMP(I,1)
4449 TOPPHI(I,1)=PSITMP(I,1)
4450 1415 CONTINUE
4451 DO 1419 K=2,L
4452 DO 1417 I=MYIS,MYIE
4453 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4454 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4455 1417 CONTINUE
4456 1419 CONTINUE
4457 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4458 DO 1421 K=1,L
4459 DO 1421 I=MYIS,MYIE
4460 FAC1(I,K)=ACOMB(12)*TOPM(I,K)
4461 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(12)*TOPPHI(I,K))
4462 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4463 BETACM(12)*TOTVO2(I,K+1)*SKO2D))
4464 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4465 1421 CONTINUE
4466 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4467 DO 1453 K=1,L
4468 DO 1453 I=MYIS,MYIE
4469 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,12)* &
4470 (CTMP(I,K+1)-CTMP(I,K))
4471 1453 CONTINUE
4472 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4473 DO 1461 I=MYIS,MYIE
4474 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,12)+ &
4475 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4476 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4477 (SORC(I,LP1,12)-SORC(I,L,12)))
4478 1461 CONTINUE
4479 !
4480 !-----CALCULATION FOR BAND 13 (990-1070 CM-1; INCLUDES O3))
4481 !
4482 !
4483 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4484 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4485 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4486 DO 1501 K=1,L
4487 DO 1501 I=MYIS,MYIE
4488 F(I,K)=H44194M2*(APCM(13)*X(I,K)+BPCM(13)*Y(I,K))
4489 FF(I,K)=H44194M2*(ATPCM(13)*X(I,K)+BTPCM(13)*Y(I,K))
4490 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4491 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4492 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4493 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4494 1501 CONTINUE
4495 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4496 ! P(K) (TOPM,TOPPHI)
4497 DO 1515 I=MYIS,MYIE
4498 TOPM(I,1)=PHITMP(I,1)
4499 TOPPHI(I,1)=PSITMP(I,1)
4500 1515 CONTINUE
4501 DO 1519 K=2,L
4502 DO 1517 I=MYIS,MYIE
4503 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4504 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4505 1517 CONTINUE
4506 1519 CONTINUE
4507 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4508 DO 1521 K=1,L
4509 DO 1521 I=MYIS,MYIE
4510 FAC1(I,K)=ACOMB(13)*TOPM(I,K)
4511 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(13)*TOPPHI(I,K))
4512 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4513 BETACM(13)*TOTVO2(I,K+1)*SKO2D+TO3SPC(I,K)))
4514 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4515 1521 CONTINUE
4516 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4517 DO 1553 K=1,L
4518 DO 1553 I=MYIS,MYIE
4519 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,13)* &
4520 (CTMP(I,K+1)-CTMP(I,K))
4521 1553 CONTINUE
4522 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4523 DO 1561 I=MYIS,MYIE
4524 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,13)+ &
4525 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4526 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4527 (SORC(I,LP1,13)-SORC(I,L,13)))
4528 1561 CONTINUE
4529 !
4530 !-----CALCULATION FOR BAND 14 (1070-1200 CM-1)
4531 !
4532 !
4533 !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY
4534 ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED
4535 ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP)
4536 DO 1601 K=1,L
4537 DO 1601 I=MYIS,MYIE
4538 F(I,K)=H44194M2*(APCM(14)*X(I,K)+BPCM(14)*Y(I,K))
4539 FF(I,K)=H44194M2*(ATPCM(14)*X(I,K)+BTPCM(14)*Y(I,K))
4540 AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE
4541 AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE
4542 PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2)
4543 PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2)
4544 1601 CONTINUE
4545 !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE
4546 ! P(K) (TOPM,TOPPHI)
4547 DO 1615 I=MYIS,MYIE
4548 TOPM(I,1)=PHITMP(I,1)
4549 TOPPHI(I,1)=PSITMP(I,1)
4550 1615 CONTINUE
4551 DO 1619 K=2,L
4552 DO 1617 I=MYIS,MYIE
4553 TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K)
4554 TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K)
4555 1617 CONTINUE
4556 1619 CONTINUE
4557 !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION
4558 DO 1621 K=1,L
4559 DO 1621 I=MYIS,MYIE
4560 FAC1(I,K)=ACOMB(14)*TOPM(I,K)
4561 FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(14)*TOPPHI(I,K))
4562 TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ &
4563 BETACM(14)*TOTVO2(I,K+1)*SKO2D))
4564 CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1)
4565 1621 CONTINUE
4566 !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS
4567 DO 1653 K=1,L
4568 DO 1653 I=MYIS,MYIE
4569 EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,14)* &
4570 (CTMP(I,K+1)-CTMP(I,K))
4571 1653 CONTINUE
4572 !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS
4573 DO 1661 I=MYIS,MYIE
4574 GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,14)+ &
4575 (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + &
4576 TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * &
4577 (SORC(I,LP1,14)-SORC(I,L,14)))
4578 1661 CONTINUE
4579 !
4580 !
4581 ! OBTAIN CTS FLUX AT THE TOP BY INTEGRATION OF HEATING RATES AND
4582 ! USING CTS FLUX AT THE BOTTOM (CURRENT VALUE OF GXCTS). NOTE
4583 ! THAT THE PRESSURE QUANTITIES AND CONVERSION FACTORS HAVE NOT
4584 ! BEEN INCLUDED EITHER IN EXCTS OR IN GXCTS. THESE CANCEL OUT, THUS
4585 ! REDUCING COMPUTATIONS!
4586 DO 1731 K=1,L
4587 DO 1731 I=MYIS,MYIE
4588 GXCTS(I)=GXCTS(I)-EXCTS(I,K)
4589 1731 CONTINUE
4590 !
4591 ! NOW SCALE THE COOLING RATE (EXCTS) BY INCLUDING THE PRESSURE
4592 ! FACTOR (DELP) AND THE CONVERSION FACTOR (RADCON)
4593 DO 1741 K=1,L
4594 DO 1741 I=MYIS,MYIE
4595 EXCTS(I,K)=EXCTS(I,K)*RADCON*DELP(I,K)
4596 1741 CONTINUE
4597 !---THIS IS THE END OF THE EXACT CTS COMPUTATIONS; AT THIS POINT
4598 ! EXCTS HAS ITS APPROPRIATE VALUE.
4599 !
4600 !*** COMPUTE APPROXIMATE CTS HEATING RATES FOR 15UM AND 9.6 UM BANDS
4601 ! (CTSO3)
4602 DO 1711 K=1,L
4603 DO 1711 I=MYIS,MYIE
4604 CTMP2(I,K+1)=CO2SP(I,K+1)*CLDFAC(I,K+1,1)
4605 CTMP3(I,K+1)=TO3SP(I,K)*CLDFAC(I,K+1,1)
4606 1711 CONTINUE
4607 DO 1701 K=1,L
4608 DO 1701 I=MYIS,MYIE
4609 CTSO3(I,K)=RADCON*DELP(I,K)* &
4610 (CSOUR(I,K)*(CTMP2(I,K+1)-CTMP2(I,K)) + &
4611 SORC(I,K,13)*(CTMP3(I,K+1)-CTMP3(I,K)))
4612 1701 CONTINUE
4613
4614 END SUBROUTINE SPA88
4615 !----------------------------------------------------------------------
4616
4617 SUBROUTINE E290(EMISSB,EMISS,AVEPHI,KLEN,FXOE2,DTE2, &
4618 ! T1,T2,T4, &
4619 H16E1,HP1,H28E1,HAF,TEN, &
4620 ids,ide, jds,jde, kds,kde, &
4621 ims,ime, jms,jme, kms,kme, &
4622 its,ite, jts,jte, kts,kte )
4623 !---------------------------------------------------------------------
4624 IMPLICIT NONE
4625 !----------------------------------------------------------------------
4626 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
4627 ims,ime, jms,jme, kms,kme , &
4628 its,ite, jts,jte, kts,kte
4629 INTEGER, INTENT(IN) :: KLEN
4630 REAL, INTENT(IN) :: H16E1,HP1,H28E1,HAF ,TEN
4631 REAL, INTENT(OUT),DIMENSION(its:ite,kts:kte+1) :: EMISSB
4632 REAL, INTENT(IN ),DIMENSION(its:ite,kts:kte+1) :: AVEPHI,FXOE2,DTE2
4633
4634 ! REAL, INTENT(IN ), DIMENSION(5040) :: T1,T2,T4
4635
4636 REAL, INTENT(INOUT), DIMENSION(its:ite,kts:kte+1) :: EMISS
4637
4638 REAL, DIMENSION(its:ite,kts:kte+1) :: TMP3,DT,FYO,DU
4639 INTEGER, DIMENSION(its:ite,kts:kte+1) :: IVAL
4640
4641 ! REAL, DIMENSION(28,180) :: TABLE1,TABLE2,TABLE3
4642 ! EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), &
4643 ! (T4(1),TABLE3(1,1))
4644 ! EQUIVALENCE (TMP3,DT)
4645
4646 INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
4647 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK
4648
4649 L=kte
4650 LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1
4651 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L
4652 LLM2 = LL-2; LLM1=LL-1
4653 MYIS=its; MYIE=ite
4654
4655
4656 !---FIRST WE OBTAIN THE EMISSIVITIES AS A FUNCTION OF TEMPERATURE
4657 ! (INDEX FXO) AND WATER AMOUNT (INDEX FYO). THIS PART OF THE CODE
4658 ! THUS GENERATES THE E2 FUNCTION.
4659 !
4660 !---CALCULATIONS FOR VARYING KP (FROM KP=K+1 TO LP1, INCLUDING SPECIAL
4661 ! CASE: RESULTS ARE IN EMISS
4662
4663
4664
4665 DO 132 K=1,LP2-KLEN
4666 DO 132 I=MYIS,MYIE
4667 TMP3(I,K)=LOG10(AVEPHI(I,KLEN+K-1))+H16E1
4668 FYO(I,K)=AINT(TMP3(I,K)*TEN)
4669 DU(I,K)=TMP3(I,K)-HP1*FYO(I,K)
4670 FYO(I,K)=H28E1*FYO(I,K)
4671 IVAL(I,K)=FYO(I,K)+FXOE2(I,KLEN+K-1)
4672 EMISS(I,KLEN+K-1)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) &
4673 +DTE2(I,KLEN+K-1)*T4(IVAL(I,K))
4674 132 CONTINUE
4675 !---THE SPECIAL CASE EMISS(I,L) (LAYER KP) IS OBTAINED NOW
4676 ! BY AVERAGING THE VALUES FOR L AND LP1:
4677 DO 1344 I=MYIS,MYIE
4678 EMISS(I,L)=HAF*(EMISS(I,L)+EMISS(I,LP1))
4679 1344 CONTINUE
4680 !---NOTE THAT EMISS(I,LP1) IS NOT USEFUL AFTER THIS POINT.
4681 !
4682 !---CALCULATIONS FOR KP=KLEN AND VARYING K; RESULTS ARE IN EMISSB.
4683 ! IN THIS CASE, THE TEMPERATURE INDEX IS UNCHANGED, ALWAYS BEING
4684 ! FXO(I,KLEN-1); THE WATER INDEX CHANGES, BUT IS SYMMETRICAL WITH
4685 ! THAT FOR THE VARYING KP CASE.NOTE THAT THE SPECIAL CASE IS NOT
4686 ! INVOLVED HERE.
4687 ! (FIXED LEVEL) K VARIES FROM (KLEN+1) TO LP1; RESULTS ARE IN
4688 ! EMISSB(I,(KLEN) TO L)
4689 DO 142 K=1,LP1-KLEN
4690 DO 142 I=MYIS,MYIE
4691 DT(I,K)=DTE2(I,KLEN-1)
4692 IVAL(I,K)=FYO(I,K)+FXOE2(I,KLEN-1)
4693 142 CONTINUE
4694 !
4695 DO 234 K=1,LP1-KLEN
4696 DO 234 I=MYIS,MYIE
4697 EMISSB(I,KLEN+K-1)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) &
4698 +DT(I,K)*T4(IVAL(I,K))
4699 234 CONTINUE
4700
4701 END SUBROUTINE E290
4702
4703 !---------------------------------------------------------------------
4704
4705 SUBROUTINE E2SPEC(EMISS,AVEPHI,FXOSP,DTSP, &
4706 ! T1,T2,T4, &
4707 H16E1,TEN,H28E1,HP1, &
4708 ids,ide, jds,jde, kds,kde, &
4709 ims,ime, jms,jme, kms,kme, &
4710 its,ite, jts,jte, kts,kte )
4711 !---------------------------------------------------------------------
4712 IMPLICIT NONE
4713 !----------------------------------------------------------------------
4714 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
4715 ims,ime, jms,jme, kms,kme , &
4716 its,ite, jts,jte, kts,kte
4717 REAL,INTENT(IN ) :: H16E1,TEN,H28E1,HP1
4718 REAL,INTENT(INOUT),DIMENSION(its:ite,kts:kte+1) :: EMISS
4719 REAL,INTENT(IN ),DIMENSION(its:ite,kts:kte+1) :: AVEPHI
4720 REAL,INTENT(IN ),DIMENSION(its:ite,2) :: FXOSP,DTSP
4721
4722 ! REAL, INTENT(IN ),DIMENSION(5040) :: T1,T2,T4
4723
4724 ! REAL, DIMENSION(28,180) :: TABLE1,TABLE2,TABLE3
4725 ! EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), &
4726 ! (T4(1),TABLE3(1,1))
4727
4728 INTEGER :: K,I,MYIS,MYIE
4729
4730 REAL, DIMENSION(its:ite,kts:kte+1) :: TMP3,FYO,DU
4731 INTEGER, DIMENSION(its:ite,kts:kte+1) :: IVAL
4732
4733 MYIS=its
4734 MYIE=ite
4735
4736 DO 132 K=1,2
4737 DO 132 I=MYIS,MYIE
4738 TMP3(I,K)=LOG10(AVEPHI(I,K))+H16E1
4739 FYO(I,K)=AINT(TMP3(I,K)*TEN)
4740 DU(I,K)=TMP3(I,K)-HP1*FYO(I,K)
4741 IVAL(I,K)=H28E1*FYO(I,K)+FXOSP(I,K)
4742 EMISS(I,K)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K))+ &
4743 DTSP(I,K)*T4(IVAL(I,K))
4744 132 CONTINUE
4745
4746 END SUBROUTINE E2SPEC
4747
4748 !---------------------------------------------------------------------
4749
4750 ! SUBROUTINE E3V88(EMV,TV,AV,EM3V, &
4751 SUBROUTINE E3V88(EMV,TV,AV, &
4752 TEN,HP1,H28E1,H16E1, &
4753 ids,ide, jds,jde, kds,kde, &
4754 ims,ime, jms,jme, kms,kme, &
4755 its,ite, jts,jte, kts,kte )
4756 !---------------------------------------------------------------------
4757 IMPLICIT NONE
4758 !----------------------------------------------------------------------
4759 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
4760 ims,ime, jms,jme, kms,kme , &
4761 its,ite, jts,jte, kts,kte
4762 REAL, INTENT(IN) :: TEN,HP1,H28E1,H16E1
4763 !-----------------------------------------------------------------------
4764 REAL, INTENT(OUT), DIMENSION(its:ite,kts:kte*2+1) :: EMV
4765 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte*2+1) :: TV,AV
4766 ! REAL, INTENT(IN), DIMENSION(5040) :: EM3V
4767
4768 REAL,DIMENSION(its:ite,kts:kte*2+1) ::FXO,TMP3,DT,WW1,WW2,DU,&
4769 FYO
4770 ! REAL, DIMENSION(5040) :: EM3V
4771
4772 ! EQUIVALENCE (EM3V(1),EM3(1,1))
4773
4774 INTEGER,DIMENSION(its:ite,kts:kte*2+1) ::IT
4775
4776 INTEGER :: LLP1,I,K,MYIS,MYIE ,L
4777 L = kte
4778 LLP1 = 2*L + 1
4779 MYIS=its; MYIE=ite
4780
4781 !---THE FOLLOWING LOOP REPLACES A DOUBLE LOOP OVER I (1-IMAX) AND
4782 ! K (1-LLP1)
4783
4784 DO 203 K=1,LLP1
4785 DO 203 I=MYIS,MYIE
4786 FXO(I,K)=AINT(TV(I,K)*HP1)
4787 TMP3(I,K)=LOG10(AV(I,K))+H16E1
4788 DT(I,K)=TV(I,K)-TEN*FXO(I,K)
4789 FYO(I,K)=AINT(TMP3(I,K)*TEN)
4790 DU(I,K)=TMP3(I,K)-HP1*FYO(I,K)
4791 !---OBTAIN INDEX FOR TABLE LOOKUP; THIS VALUE WILL HAVE TO BE
4792 ! DECREMENTED BY 9 TO ACCOUNT FOR TABLE TEMPS STARTING AT 100K.
4793 IT(I,K)=FXO(I,K)+FYO(I,K)*H28E1
4794 WW1(I,K)=TEN-DT(I,K)
4795 WW2(I,K)=HP1-DU(I,K)
4796 EMV(I,K)=WW1(I,K)*WW2(I,K)*EM3V(IT(I,K)-9)+ &
4797 WW2(I,K)*DT(I,K)*EM3V(IT(I,K)-8)+ &
4798 WW1(I,K)*DU(I,K)*EM3V(IT(I,K)+19)+ &
4799 DT(I,K)*DU(I,K)*EM3V(IT(I,K)+20)
4800 203 CONTINUE
4801
4802 END SUBROUTINE E3V88
4803 !-----------------------------------------------------------------------
4804
4805 SUBROUTINE SWR93(FSWC,HSWC,UFSWC,DFSWC,FSWL,HSWL,UFSWL, &
4806 DFSWL, &
4807 PRESS,COSZRO,TAUDAR,RH2O,RRCO2,SSOLAR,QO3, &
4808 NCLDS,KTOPSW,KBTMSW,CAMT,CRR,CTT, &
4809 ALVB,ALNB,ALVD,ALND,GDFVB,GDFNB,GDFVD,GDFND, &
4810 ! UCO2,UO3,TUCO2,TUO3,TDO3,TDCO2, &
4811 ABCFF,PWTS, &
4812 H35E1,H1224E3,ONE,ZERO,HAF,H69766E5,HP219, &
4813 HP816,RRAYAV,GINV,CFCO2,CFO3, &
4814 TWO,H235M3,HP26,H129M2,H75826M4,H1036E2, &
4815 H1P082,HMP805,H1386E2,H658M2,H2118M2,H42M2, &
4816 H323M4,HM1EZ,DIFFCTR,O3DIFCTR,FIFTY,RADCON, &
4817 ids,ide, jds,jde, kds,kde, &
4818 ims,ime, jms,jme, kms,kme, &
4819 its,ite, jts,jte, kts,kte )
4820 !----------------------------------------------------------------------
4821 IMPLICIT NONE
4822 !----------------------------------------------------------------------
4823 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
4824 ims,ime, jms,jme, kms,kme , &
4825 its,ite, jts,jte, kts,kte
4826 REAL,INTENT(IN) :: RRCO2,SSOLAR
4827 REAL,INTENT(IN) :: H35E1,H1224E3,ONE,ZERO,HAF,H69766E5,HP219,HP816,RRAYAV,&
4828 GINV,CFCO2,CFO3
4829 REAL,INTENT(IN) :: TWO,H235M3,HP26,H129M2,H75826M4,H1036E2
4830 REAL,INTENT(IN) :: H1P082,HMP805,H1386E2,H658M2,H2118M2,H42M2,H323M4,HM1EZ
4831 REAL,INTENT(IN) :: DIFFCTR,O3DIFCTR,FIFTY,RADCON
4832 !----------------------------------------------------------------------
4833 INTEGER, PARAMETER :: NB=12
4834 REAL, INTENT(IN ),DIMENSION(its:ite,kts:kte+1) :: PRESS,CAMT
4835 REAL, INTENT(IN ),DIMENSION(its:ite,kts:kte) :: RH2O,QO3
4836 REAL, INTENT(IN ),DIMENSION(its:ite) :: COSZRO,TAUDAR,ALVB,ALVD,ALNB,ALND
4837 INTEGER, INTENT(IN ),DIMENSION(its:ite) :: NCLDS
4838 INTEGER, INTENT(IN ),DIMENSION(its:ite,kts:kte+1) ::KTOPSW,KBTMSW
4839 REAL, INTENT(IN ),DIMENSION(its:ite,NB,kts:kte+1) ::CRR,CTT
4840
4841 REAL, INTENT(OUT),DIMENSION(its:ite,kts:kte+1) :: &
4842 FSWC,HSWC,UFSWC,DFSWC,FSWL,HSWL,UFSWL,DFSWL
4843 REAL, INTENT(OUT),DIMENSION(its:ite) :: GDFVB,GDFVD,GDFNB,GDFND
4844 REAL, INTENT(IN), DIMENSION(NB) :: ABCFF,PWTS
4845
4846 ! REAL, INTENT(IN), DIMENSION(its:ite,kts:kte*2+2) :: UCO2,UO3
4847 ! REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: TUCO2,TUO3,TDO3,TDCO2
4848
4849 REAL, DIMENSION(its:ite,kts:kte*2+2) :: UCO2,UO3
4850 REAL, DIMENSION(its:ite,kts:kte+1) :: TUCO2,TUO3,TDO3,TDCO2
4851
4852 REAL, DIMENSION(its:ite,kts:kte*2+2) :: TCO2,TO3
4853 REAL, DIMENSION(its:ite,kts:kte+1) :: PP,DP,PR2,DU,DUCO2,DUO3,UD,TTD
4854 REAL, DIMENSION(its:ite,kts:kte+1) :: UDCO2,UDO3,UR,URCO2,URO3,TTU
4855 REAL, DIMENSION(its:ite,kts:kte+1) :: DFN,UFN
4856 REAL, DIMENSION(its:ite,kts:kte+1) :: XAMT,FF,FFCO2,FFO3,CR,CT
4857 REAL, DIMENSION(its:ite,kts:kte+1) :: PPTOP,DPCLD,TTDB1,TTUB1
4858 REAL, DIMENSION(its:ite,kts:kte+1) :: TDCL1,TUCL1,TDCL2,DFNTRN, &
4859 UFNTRN,TCLU,TCLD,ALFA,ALFAU, &
4860 UFNCLU,DFNCLU
4861
4862 REAL, DIMENSION(its:ite,NB) :: DFNTOP
4863 REAL, DIMENSION(its:ite) :: SECZ,TMP1,RRAY,REFL,REFL2,CCMAX
4864
4865 ! EQUIVALENCE &
4866 ! (UDO3,UO3(its,1),DFNCLU), (URO3,UO3(its,kte+2), UFNCLU) &
4867 ! , (UDCO2,UCO2(its,1),TCLD), (URCO2,UCO2(its,kte+2), TCLU) &
4868 ! , (TDO3 ,TO3(its,1),DFNTRN),(TUO3,TO3(its,kte+2), UFNTRN) &
4869 ! , (TDCO2,TCO2(its,1) ),(TUCO2,TCO2(its,kte+2) ) &
4870 ! , (FF , ALFA ), (FFCO2 , ALFAU ), (FFO3 , TTDB1 ) &
4871 ! , (DU , TTUB1), (DUCO2 , TUCL1 ), (DUO3 , TDCL1 ) &
4872 ! , (PR2 , TDCL2)
4873
4874 ! EQUIVALENCE &
4875 ! (UDO3,DFNCLU), (URO3,UFNCLU) &
4876 ! , (UDCO2,TCLD ), (URCO2,TCLU) &
4877 ! , (TDO3 ,DFNTRN),(TUO3,UFNTRN) &
4878 !! , (TDCO2,TCO2(its,1) ),(TUCO2,TCO2(its,kte+2) ) &
4879 ! , (FF , ALFA ), (FFCO2 , ALFAU ), (FFO3 , TTDB1 ) &
4880 ! , (DU , TTUB1), (DUCO2 , TUCL1 ), (DUO3 , TDCL1 ) &
4881 ! , (PR2 , TDCL2)
4882
4883 INTEGER :: K,I,KP,N,IP,MYIS1,KCLDS,NNCLDS,JTOP,KK,J2,J3,J1
4884 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL
4885 REAL :: DENOM,HTEMP,TEMPF,TEMPG
4886
4887 L=kte
4888 LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1
4889 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L
4890 MYIS=its; MYIE=ite
4891 MYIS1=MYIS+1 ! ??
4892
4893 DO 100 I=MYIS,MYIE
4894 SECZ(I) = H35E1/SQRT(H1224E3*COSZRO(I)*COSZRO(I)+ONE)
4895 PP(I,1) = ZERO
4896 PP(I,LP1) = PRESS(I,LP1)
4897 TMP1(I) = ONE/PRESS(I,LP1)
4898 100 CONTINUE
4899 DO 110 K=1,LM1
4900 DO 110 I=MYIS,MYIE
4901 PP(I,K+1) = HAF*(PRESS(I,K+1)+PRESS(I,K))
4902 110 CONTINUE
4903 DO 120 K=1,L
4904 DO 120 I=MYIS,MYIE
4905 DP (I,K) = PP(I,K+1)-PP(I,K)
4906 PR2(I,K) = HAF*(PP(I,K)+PP(I,K+1))
4907 120 CONTINUE
4908 DO 130 K=1,L
4909 DO 130 I=MYIS,MYIE
4910 PR2(I,K) = PR2(I,K)*TMP1(I)
4911 130 CONTINUE
4912 ! CALCULATE ENTERING FLUX AT THE TOP FOR EACH BAND(IN CGS UNITS)
4913 DO 140 N=1,NB
4914 DO 140 IP=MYIS,MYIE
4915 DFNTOP(IP,N) = SSOLAR*H69766E5*COSZRO(IP)*TAUDAR(IP)*PWTS(N)
4916 140 CONTINUE
4917 ! EXECUTE THE LACIS-HANSEN REFLECTIVITY PARAMETERIZATION
4918 ! FOR THE VISIBLE BAND
4919 DO 150 I=MYIS,MYIE
4920 RRAY(I) = HP219/(ONE+HP816*COSZRO(I))
4921 REFL(I) = RRAY(I) + (ONE-RRAY(I))*(ONE-RRAYAV)*ALVB(I)/ &
4922 (ONE-ALVD(I)*RRAYAV)
4923 150 CONTINUE
4924 DO 155 I=MYIS,MYIE
4925 RRAY(I) = 0.104/(ONE+4.8*COSZRO(I))
4926 REFL2(I)= RRAY(I) + (ONE-RRAY(I))*(ONE-0.093)*ALVB(I)/ &
4927 (ONE-ALVD(I)*0.093)
4928 155 CONTINUE
4929 ! CALCULATE PRESSURE-WEIGHTED OPTICAL PATHS FOR EACH LAYER
4930 ! IN UNITS OF CM-ATM. PRESSURE WEIGHTING IS USING PR2.
4931 ! DU= VALUE FOR H2O;DUCO2 FOR CO2;DUO3 FOR O3.
4932 DO 160 K=1,L
4933 DO 160 I=MYIS,MYIE
4934 DU (I,K) = GINV*RH2O(I,K)*DP(I,K)*PR2(I,K)
4935 DUCO2(I,K) = (RRCO2*GINV*CFCO2)*DP(I,K)*PR2(I,K)
4936 DUO3 (I,K) = (GINV*CFO3)*QO3(I,K)*DP(I,K)
4937 160 CONTINUE
4938 !
4939 ! CALCULATE CLEAR SKY SW FLUX
4940 !
4941 ! OBTAIN THE OPTICAL PATH FROM THE TOP OF THE ATMOSPHERE TO THE
4942 ! FLUX PRESSURE. ANGULAR FACTORS ARE NOW INCLUDED. UD=DOWNWARD
4943 ! PATH FOR H2O,WIGTH UR THE UPWARD PATH FOR H2O. CORRESPONDING
4944 ! QUANTITIES FOR CO2,O3 ARE UDCO2/URCO2 AND UDO3/URO3.
4945 DO 200 IP=MYIS,MYIE
4946 UD (IP,1) = ZERO
4947 UDCO2(IP,1) = ZERO
4948 UDO3 (IP,1) = ZERO
4949 ! SH
4950 UO3 (IP,1) = UDO3 (IP,1)
4951 UCO2 (IP,1) = UDCO2(IP,1)
4952
4953 200 CONTINUE
4954 DO 210 K=2,LP1
4955 DO 210 I=MYIS,MYIE
4956 UD (I,K) = UD (I,K-1)+DU (I,K-1)*SECZ(I)
4957 UDCO2(I,K) = UDCO2(I,K-1)+DUCO2(I,K-1)*SECZ(I)
4958 UDO3 (I,K) = UDO3 (I,K-1)+DUO3 (I,K-1)*SECZ(I)
4959 ! SH
4960 UO3 (I,K) = UDO3 (I,K)
4961 UCO2 (I,K) = UDCO2(I,K)
4962
4963 210 CONTINUE
4964 DO 220 IP=MYIS,MYIE
4965 UR (IP,LP1) = UD (IP,LP1)
4966 URCO2(IP,LP1) = UDCO2(IP,LP1)
4967 URO3 (IP,LP1) = UDO3 (IP,LP1)
4968 ! SH
4969 UO3 (IP,LP1+LP1) = URO3 (IP,LP1)
4970 UCO2 (IP,LP1+LP1) = URCO2(IP,LP1)
4971
4972 220 CONTINUE
4973 DO 230 K=L,1,-1
4974 DO 230 IP=MYIS,MYIE
4975 UR (IP,K) = UR (IP,K+1)+DU (IP,K)*DIFFCTR
4976 URCO2(IP,K) = URCO2(IP,K+1)+DUCO2(IP,K)*DIFFCTR
4977 URO3 (IP,K) = URO3 (IP,K+1)+DUO3 (IP,K)*O3DIFCTR
4978 ! SH
4979 UO3 (IP,LP1+K) = URO3 (IP,K)
4980 UCO2(IP,LP1+K) = URCO2(IP,K)
4981
4982 230 CONTINUE
4983 ! CALCULATE CO2 ABSORPTIONS . THEY WILL BE USED IN NEAR INFRARED
4984 ! BANDS.SINCE THE ABSORPTION AMOUNT IS GIVEN (IN THE FORMULA USED
4985 ! BELOW, DERIVED FROM SASAMORI) IN TERMS OF THE TOTAL SOLAR FLUX,
4986 ! AND THE ABSORPTION IS ONLY INCLUDED IN THE NEAR IR (50 PERCENT
4987 ! OF THE SOLAR SPECTRUM), THE ABSORPTIONS ARE MULTIPLIED BY 2.
4988 ! SINCE CODE ACTUALLY REQUIRES TRANSMISSIONS, THESE ARE THE
4989 ! VALUES ACTUALLY STORED IN TCO2.
4990 DO 240 K=1,LL
4991 DO 240 I=MYIS,MYIE
4992 TCO2(I,K+1)=ONE-TWO*(H235M3*EXP(HP26*LOG(UCO2(I,K+1)+H129M2)) &
4993 -H75826M4)
4994 240 CONTINUE
4995
4996 ! SH
4997 DO 241 K=1,L
4998 DO 241 I=MYIS,MYIE
4999 TDCO2(I,K+1)=TCO2(I,K+1)
5000 241 CONTINUE
5001 DO 242 K=1,L
5002 DO 242 I=MYIS,MYIE
5003 TUCO2(I,K)=TCO2(I,LP1+K)
5004 242 CONTINUE
5005
5006 ! NOW CALCULATE OZONE ABSORPTIONS. THESE WILL BE USED IN
5007 ! THE VISIBLE BAND.JUST AS IN THE CO2 CASE, SINCE THIS BAND IS
5008 ! 50 PERCENT OF THE SOLAR SPECTRUM,THE ABSORPTIONS ARE MULTIPLIED
5009 ! BY 2. THE TRANSMISSIONS ARE STORED IN TO3.
5010 HTEMP = H1036E2*H1036E2*H1036E2
5011 DO 250 K=1,LL
5012 DO 250 I=MYIS,MYIE
5013 TO3(I,K+1)=ONE-TWO*UO3(I,K+1)* &
5014 (H1P082*EXP(HMP805*LOG(ONE+H1386E2*UO3(I,K+1)))+ &
5015 H658M2/(ONE+HTEMP*UO3(I,K+1)*UO3(I,K+1)*UO3(I,K+1))+ &
5016 H2118M2/(ONE+UO3(I,K+1)*(H42M2+H323M4*UO3(I,K+1))))
5017 250 CONTINUE
5018
5019 ! SH
5020 DO 251 K=1,L
5021 DO 251 I=MYIS,MYIE
5022 TDO3(I,K+1)=TO3(I,K+1)
5023 251 CONTINUE
5024 DO 252 K=1,L
5025 DO 252 I=MYIS,MYIE
5026 TUO3(I,K)=TO3(I,LP1+K)
5027 252 CONTINUE
5028
5029
5030 ! START FREQUENCY LOOP (ON N) HERE
5031 !
5032 !--- BAND 1 (VISIBLE) INCLUDES O3 AND H2O ABSORPTION
5033 DO 260 K=1,L
5034 DO 260 I=MYIS,MYIE
5035 TTD(I,K+1) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UD(I,K+1)))
5036 TTU(I,K) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UR(I,K)))
5037 DFN(I,K+1) = TTD(I,K+1)*TDO3(I,K+1)
5038 UFN(I,K) = TTU(I,K)*TUO3(I,K)
5039 260 CONTINUE
5040 DO 270 I=MYIS,MYIE
5041 DFN(I,1) = ONE
5042 UFN(I,LP1) = DFN(I,LP1)
5043 270 CONTINUE
5044 ! SCALE VISIBLE BAND FLUXES BY SOLAR FLUX AT THE TOP OF THE
5045 ! ATMOSPHERE (DFNTOP(I,1))
5046 ! DFSW/UFSW WILL BE THE FLUXES, SUMMED OVER ALL BANDS
5047 DO 280 K=1,LP1
5048 DO 280 I=MYIS,MYIE
5049 DFSWL(I,K) = DFN(I,K)*DFNTOP(I,1)
5050 UFSWL(I,K) = REFL(I)*UFN(I,K)*DFNTOP(I,1)
5051 280 CONTINUE
5052 DO 285 I=MYIS,MYIE
5053 GDFVB(I) = DFSWL(I,LP1)*EXP(-0.15746*SECZ(I))
5054 GDFVD(I) = ((ONE-REFL2(I))*DFSWL(I,LP1) - &
5055 (ONE-ALVB(I)) *GDFVB(I)) / (ONE-ALVD(I))
5056 GDFNB(I) = ZERO
5057 GDFND(I) = ZERO
5058 285 CONTINUE
5059 !---NOW OBTAIN FLUXES FOR THE NEAR IR BANDS. THE METHODS ARE THE SAME
5060 ! AS FOR THE VISIBLE BAND, EXCEPT THAT THE REFLECTION AND
5061 ! TRANSMISSION COEFFICIENTS (OBTAINED BELOW) ARE DIFFERENT, AS
5062 ! RAYLEIGH SCATTERING NEED NOT BE CONSIDERED.
5063 DO 350 N=2,NB
5064 IF (N.EQ.2) THEN
5065 ! THE WATER VAPOR TRANSMISSION FUNCTION FOR BAND 2 IS EQUAL TO
5066 ! THAT OF BAND 1 (SAVED AS TTD,TTU)
5067 !--- BAND 2-9 (NEAR-IR) INCLUDES O3, CO2 AND H2O ABSORPTION
5068 DO 290 K=1,L
5069 DO 290 I=MYIS,MYIE
5070 DFN(I,K+1) = TTD(I,K+1)*TDCO2(I,K+1)
5071 UFN(I,K) = TTU(I,K)*TUCO2(I,K)
5072 290 CONTINUE
5073 ELSE
5074 ! CALCULATE WATER VAPOR TRANSMISSION FUNCTIONS FOR NEAR INFRARED
5075 ! BANDS. INCLUDE CO2 TRANSMISSION (TDCO2/TUCO2), WHICH
5076 ! IS THE SAME FOR ALL INFRARED BANDS.
5077 DO 300 K=1,L
5078 DO 300 I=MYIS,MYIE
5079 DFN(I,K+1)=EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UD(I,K+1))) &
5080 *TDCO2(I,K+1)
5081 UFN(I,K)=EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UR(I,K))) &
5082 *TUCO2(I,K)
5083 300 CONTINUE
5084 ENDIF
5085 !---AT THIS POINT,INCLUDE DFN(1),UFN(LP1), NOTING THAT DFN(1)=1 FOR
5086 ! ALL BANDS, AND THAT UFN(LP1)=DFN(LP1) FOR ALL BANDS.
5087 DO 310 I=MYIS,MYIE
5088 DFN(I,1) = ONE
5089 UFN(I,LP1) = DFN(I,LP1)
5090 310 CONTINUE
5091 ! SCALE THE PREVIOUSLY COMPUTED FLUXES BY THE FLUX AT THE TOP
5092 ! AND SUM OVER BANDS
5093 DO 320 K=1,LP1
5094 DO 320 I=MYIS,MYIE
5095 DFSWL(I,K) = DFSWL(I,K) + DFN(I,K)*DFNTOP(I,N)
5096 UFSWL(I,K) = UFSWL(I,K) + ALNB(I)*UFN(I,K)*DFNTOP(I,N)
5097 320 CONTINUE
5098 DO 330 I=MYIS,MYIE
5099 GDFNB(I) = GDFNB(I) + DFN(I,LP1)*DFNTOP(I,N)
5100 330 CONTINUE
5101 350 CONTINUE
5102 DO 360 K=1,LP1
5103 DO 360 I=MYIS,MYIE
5104 FSWL(I,K) = UFSWL(I,K)-DFSWL(I,K)
5105 360 CONTINUE
5106 DO 370 K=1,L
5107 DO 370 I=MYIS,MYIE
5108 HSWL(I,K)=RADCON*(FSWL(I,K+1)-FSWL(I,K))/DP(I,K)
5109 370 CONTINUE
5110 !
5111 !---END OF FREQUENCY LOOP (OVER N)
5112 !
5113 ! CALCULATE CLOUDY SKY SW FLUX
5114 !
5115 KCLDS=NCLDS(MYIS)
5116 DO 400 I=MYIS1,MYIE
5117 KCLDS=MAX(NCLDS(I),KCLDS)
5118 400 CONTINUE
5119 DO 410 K=1,LP1
5120 DO 410 I=MYIS,MYIE
5121 DFSWC(I,K) = DFSWL(I,K)
5122 UFSWC(I,K) = UFSWL(I,K)
5123 FSWC (I,K) = FSWL (I,K)
5124 410 CONTINUE
5125 DO 420 K=1,L
5126 DO 420 I=MYIS,MYIE
5127 HSWC(I,K) = HSWL(I,K)
5128 420 CONTINUE
5129 !*******************************************************************
5130 IF (KCLDS .EQ. 0) RETURN
5131 !*******************************************************************
5132 DO 430 K=1,LP1
5133 DO 430 I=MYIS,MYIE
5134 XAMT(I,K) = CAMT(I,K)
5135 430 CONTINUE
5136 DO 470 I=MYIS,MYIE
5137 NNCLDS = NCLDS(I)
5138 CCMAX(I) = ZERO
5139 IF (NNCLDS .LE. 0) GO TO 470
5140 CCMAX(I) = ONE
5141 DO 450 K=1,NNCLDS
5142 CCMAX(I) = CCMAX(I) * (ONE - CAMT(I,K+1))
5143 450 CONTINUE
5144 CCMAX(I) = ONE - CCMAX(I)
5145 IF (CCMAX(I) .GT. ZERO) THEN
5146 DO 460 K=1,NNCLDS
5147 XAMT(I,K+1) = CAMT(I,K+1)/CCMAX(I)
5148 460 CONTINUE
5149 END IF
5150 470 CONTINUE
5151 DO 480 K=1,LP1
5152 DO 480 I=MYIS,MYIE
5153 FF (I,K) = DIFFCTR
5154 FFCO2(I,K) = DIFFCTR
5155 FFO3 (I,K) = O3DIFCTR
5156 480 CONTINUE
5157 DO 490 IP=MYIS,MYIE
5158 JTOP = KTOPSW(IP,NCLDS(IP)+1)
5159 DO 490 K=1,JTOP
5160 FF (IP,K) = SECZ(IP)
5161 FFCO2(IP,K) = SECZ(IP)
5162 FFO3 (IP,K) = SECZ(IP)
5163 490 CONTINUE
5164 DO 500 I=MYIS,MYIE
5165 RRAY(I) = HP219/(ONE+HP816*COSZRO(I))
5166 REFL(I) = RRAY(I) + (ONE-RRAY(I))*(ONE-RRAYAV)*ALVD(I)/ &
5167 (ONE-ALVD(I)*RRAYAV)
5168 500 CONTINUE
5169 DO 510 IP=MYIS,MYIE
5170 UD (IP,1) = ZERO
5171 UDCO2(IP,1) = ZERO
5172 UDO3 (IP,1) = ZERO
5173 ! SH
5174 UO3 (IP,1) = UDO3 (IP,1)
5175 UCO2 (IP,1) = UDCO2(IP,1)
5176
5177 510 CONTINUE
5178 DO 520 K=2,LP1
5179 DO 520 I=MYIS,MYIE
5180 UD (I,K) = UD (I,K-1)+DU (I,K-1)*FF (I,K)
5181 UDCO2(I,K) = UDCO2(I,K-1)+DUCO2(I,K-1)*FFCO2(I,K)
5182 UDO3 (I,K) = UDO3 (I,K-1)+DUO3 (I,K-1)*FFO3 (I,K)
5183 ! SH
5184 UO3 (I,K) = UDO3 (I,K)
5185 UCO2(I,K) = UDCO2(I,K)
5186
5187 520 CONTINUE
5188 DO 530 IP=MYIS,MYIE
5189 UR (IP,LP1) = UD (IP,LP1)
5190 URCO2(IP,LP1) = UDCO2(IP,LP1)
5191 URO3 (IP,LP1) = UDO3 (IP,LP1)
5192 ! SH
5193 UO3 (IP,LP1+LP1) = URO3 (IP,LP1)
5194 UCO2 (IP,LP1+LP1) = URCO2(IP,LP1)
5195
5196 530 CONTINUE
5197 DO 540 K=L,1,-1
5198 DO 540 IP=MYIS,MYIE
5199 UR (IP,K) = UR (IP,K+1)+DU (IP,K)*DIFFCTR
5200 URCO2(IP,K) = URCO2(IP,K+1)+DUCO2(IP,K)*DIFFCTR
5201 URO3 (IP,K) = URO3 (IP,K+1)+DUO3 (IP,K)*O3DIFCTR
5202 ! SH
5203 UO3 (IP,LP1+K) = URO3 (IP,K)
5204 UCO2(IP,LP1+K) = URCO2(IP,K)
5205
5206 540 CONTINUE
5207 DO 550 K=1,LL
5208 DO 550 I=MYIS,MYIE
5209 TCO2(I,K+1)=ONE-TWO*(H235M3*EXP(HP26*LOG(UCO2(I,K+1)+H129M2)) &
5210 -H75826M4)
5211 550 CONTINUE
5212 ! SH
5213 DO 551 K=1,L
5214 DO 551 I=MYIS,MYIE
5215 TDCO2(I,K+1)=TCO2(I,K+1)
5216 551 CONTINUE
5217 DO 552 K=1,L
5218 DO 552 I=MYIS,MYIE
5219 TUCO2(I,K)=TCO2(I,LP1+K)
5220 552 CONTINUE
5221
5222 DO 560 K=1,LL
5223 DO 560 I=MYIS,MYIE
5224 TO3(I,K+1)=ONE-TWO*UO3(I,K+1)* &
5225 (H1P082*EXP(HMP805*LOG(ONE+H1386E2*UO3(I,K+1)))+ &
5226 H658M2/(ONE+HTEMP*UO3(I,K+1)*UO3(I,K+1)*UO3(I,K+1))+ &
5227 H2118M2/(ONE+UO3(I,K+1)*(H42M2+H323M4*UO3(I,K+1))))
5228 560 CONTINUE
5229 ! SH
5230 DO 561 K=1,L
5231 DO 561 I=MYIS,MYIE
5232 TDO3(I,K+1)=TO3(I,K+1)
5233 561 CONTINUE
5234 DO 562 K=1,L
5235 DO 562 I=MYIS,MYIE
5236 TUO3(I,K)=TO3(I,LP1+K)
5237 562 CONTINUE
5238
5239 !********************************************************************
5240 !---THE FIRST CLOUD IS THE GROUND; ITS PROPERTIES ARE GIVEN
5241 ! BY REFL (THE TRANSMISSION (0) IS IRRELEVANT FOR NOW!).
5242 !********************************************************************
5243 DO 570 I=MYIS,MYIE
5244 CR(I,1) = REFL(I)
5245 570 CONTINUE
5246 !***OBTAIN CLOUD REFLECTION AND TRANSMISSION COEFFICIENTS FOR
5247 ! REMAINING CLOUDS (IF ANY) IN THE VISIBLE BAND
5248 !---THE MAXIMUM NO OF CLOUDS IN THE ROW (KCLDS) IS USED. THIS CREATES
5249 ! EXTRA WORK (MAY BE REMOVED IN A SUBSEQUENT UPDATE).
5250 DO 581 I=MYIS,MYIE
5251 KCLDS=NCLDS(I)
5252 IF(KCLDS.EQ.0) GO TO 581
5253 DO 580 KK=2,KCLDS+1
5254 CR(I,KK) = CRR(I,1,KK)*XAMT(I,KK)
5255 CT(I,KK) = ONE - (ONE-CTT(I,1,KK))*XAMT(I,KK)
5256 580 CONTINUE
5257 581 CONTINUE
5258 !---OBTAIN THE PRESSURE AT THE TOP,BOTTOM AND THE THICKNESS OF
5259 ! "THICK" CLOUDS (THOSE AT LEAST 2 LAYERS THICK). THIS IS USED
5260 ! LATER IS OBTAINING FLUXES INSIDE THE THICK CLOUDS, FOR ALL
5261 ! FREQUENCY BANDS.
5262 DO 591 I=MYIS,MYIE
5263 KCLDS=NCLDS(I)
5264 IF(KCLDS.EQ.0) GO TO 591
5265 DO 590 KK=1,KCLDS
5266 IF ((KBTMSW(I,KK+1)-1).GT.KTOPSW(I,KK+1)) THEN
5267 PPTOP(I,KK)=PP(I,KTOPSW(I,KK+1))
5268 DPCLD(I,KK)=ONE/(PPTOP(I,KK)-PP(I,KBTMSW(I,KK+1)))
5269 ENDIF
5270 590 CONTINUE
5271 591 CONTINUE
5272 DO 600 K=1,L
5273 DO 600 I=MYIS,MYIE
5274 TTDB1(I,K+1) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UD(I,K+1)))
5275 TTUB1(I,K) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UR(I,K)))
5276 TTD (I,K+1) = TTDB1(I,K+1)*TDO3(I,K+1)
5277 TTU (I,K) = TTUB1(I,K)*TUO3(I,K)
5278 600 CONTINUE
5279 DO 610 I=MYIS,MYIE
5280 TTD(I,1) = ONE
5281 TTU(I,LP1) = TTD(I,LP1)
5282 610 CONTINUE
5283 !***FOR EXECUTION OF THE CLOUD LOOP, IT IS NECESSARY TO SEPARATE OUT
5284 ! TRANSMISSION FCTNS AT THE TOP AND BOTTOM OF THE CLOUDS, FOR
5285 ! EACH BAND N. THE REQUIRED QUANTITIES ARE:
5286 ! TTD(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1:
5287 ! TTU(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1:
5288 ! TTD(I,KBTMSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1:
5289 ! AND INVERSES OF THE FIRST TWO. THE ABOVE QUANTITIES ARE
5290 ! STORED IN TDCL1,TUCL1,TDCL2, AND DFNTRN,UFNTRN, RESPECTIVELY,
5291 ! AS THEY HAVE MULTIPLE USE IN THE PGM.
5292 !---FOR FIRST CLOUD LAYER (GROUND) TDCL1,TUCL1 ARE KNOWN:
5293 DO 620 I=MYIS,MYIE
5294 TDCL1 (I,1) = TTD(I,LP1)
5295 TUCL1 (I,1) = TTU(I,LP1)
5296 TDCL2 (I,1) = TDCL1(I,1)
5297 DFNTRN(I,1) = ONE/TDCL1(I,1)
5298 UFNTRN(I,1) = DFNTRN(I,1)
5299 620 CONTINUE
5300 DO 631 I=MYIS,MYIE
5301 KCLDS=NCLDS(I)
5302 IF(KCLDS.EQ.0) GO TO 631
5303 DO 630 KK=2,KCLDS+1
5304 TDCL1(I,KK) = TTD(I,KTOPSW(I,KK))
5305 TUCL1(I,KK) = TTU(I,KTOPSW(I,KK))
5306 TDCL2(I,KK) = TTD(I,KBTMSW(I,KK))
5307 630 CONTINUE
5308 631 CONTINUE
5309 !---COMPUTE INVERSES
5310 DO 641 I=MYIS,MYIE
5311 KCLDS=NCLDS(I)
5312 IF(KCLDS.EQ.0) GO TO 641
5313 ! SH
5314 DO 640 KK=2,KCLDS+1
5315 DFNTRN(I,KK) = ONE/TDCL1(I,KK)
5316 UFNTRN(I,KK) = ONE/TUCL1(I,KK)
5317 640 CONTINUE
5318 641 CONTINUE
5319 !---COMPUTE THE TRANSMISSIVITY FROM THE TOP OF CLOUD (K+1) TO THE
5320 ! TOP OF CLOUD (K). THE CLOUD TRANSMISSION (CT) IS INCLUDED. THIS
5321 ! QUANTITY IS CALLED TCLU (INDEX K). ALSO, OBTAIN THE TRANSMISSIVITY
5322 ! FROM THE BOTTOM OF CLOUD (K+1) TO THE TOP OF CLOUD (K)(A PATH
5323 ! ENTIRELY OUTSIDE CLOUDS). THIS QUANTITY IS CALLED TCLD (INDEX K).
5324 DO 651 I=MYIS,MYIE
5325 KCLDS=NCLDS(I)
5326 IF(KCLDS.EQ.0) GO TO 651
5327 DO 650 KK=1,KCLDS
5328 TCLU(I,KK) = TDCL1(I,KK)*DFNTRN(I,KK+1)*CT(I,KK+1)
5329 TCLD(I,KK) = TDCL1(I,KK)/TDCL2(I,KK+1)
5330 650 CONTINUE
5331 651 CONTINUE
5332 !***THE FOLLOWING IS THE RECURSION RELATION FOR ALFA: THE REFLECTION
5333 ! COEFFICIENT FOR A SYSTEM INCLUDING THE CLOUD IN QUESTION AND THE
5334 ! FLUX COMING OUT OF THE CLOUD SYSTEM INCLUDING ALL CLOUDS BELOW
5335 ! THE CLOUD IN QUESTION.
5336 !---ALFAU IS ALFA WITHOUT THE REFLECTION OF THE CLOUD IN QUESTION
5337 DO 660 I=MYIS,MYIE
5338 KCLDS=NCLDS(I)
5339 IF(KCLDS.EQ.0) GO TO 660
5340 ALFA (I,1)=CR(I,1)
5341 ALFAU(I,1)=ZERO
5342 660 CONTINUE
5343 !---AGAIN,EXCESSIVE CALCULATIONS-MAY BE CHANGED LATER!
5344 DO 671 I=MYIS,MYIE
5345 KCLDS=NCLDS(I)
5346 IF(KCLDS.EQ.0) GO TO 671
5347 DO 670 KK=2,KCLDS+1
5348 ALFAU(I,KK)= TCLU(I,KK-1)*TCLU(I,KK-1)*ALFA(I,KK-1)/ &
5349 (ONE - TCLD(I,KK-1)*TCLD(I,KK-1)*ALFA(I,KK-1)*CR(I,KK))
5350 ALFA (I,KK)= ALFAU(I,KK)+CR(I,KK)
5351 670 CONTINUE
5352 671 CONTINUE
5353 ! CALCULATE UFN AT CLOUD TOPS AND DFN AT CLOUD BOTTOMS
5354 !---NOTE THAT UFNCLU(I,KCLDS+1) GIVES THE UPWARD FLUX AT THE TOP
5355 ! OF THE HIGHEST REAL CLOUD (IF NCLDS(I)=KCLDS). IT GIVES THE FLUX
5356 ! AT THE TOP OF THE ATMOSPHERE IF NCLDS(I) < KCLDS. IN THE FIRST
5357 ! CASE, TDCL1 EQUALS THE TRANSMISSION FCTN TO THE TOP OF THE
5358 ! HIGHEST CLOUD, AS WE WANT. IN THE SECOND CASE, TDCL1=1, SO UFNCLU
5359 ! EQUALS ALFA. THIS IS ALSO CORRECT.
5360 DO 680 I=MYIS,MYIE
5361 KCLDS=NCLDS(I)
5362 IF(KCLDS.EQ.0) GO TO 680
5363 UFNCLU(I,KCLDS+1) = ALFA(I,KCLDS+1)*TDCL1(I,KCLDS+1)
5364 DFNCLU(I,KCLDS+1) = TDCL1(I,KCLDS+1)
5365 680 CONTINUE
5366 !---THIS CALCULATION IS THE REVERSE OF THE RECURSION RELATION USED
5367 ! ABOVE
5368 DO 691 I=MYIS,MYIE
5369 KCLDS=NCLDS(I)
5370 IF(KCLDS.EQ.0) GO TO 691
5371 DO 690 KK=KCLDS,1,-1
5372 UFNCLU(I,KK) = UFNCLU(I,KK+1)*ALFAU(I,KK+1)/(ALFA(I,KK+1)* &
5373 TCLU(I,KK))
5374 DFNCLU(I,KK) = UFNCLU(I,KK)/ALFA(I,KK)
5375 690 CONTINUE
5376 691 CONTINUE
5377 DO 701 I=MYIS,MYIE
5378 KCLDS=NCLDS(I)
5379 IF(KCLDS.EQ.0) GO TO 701
5380 DO 700 KK=1,KCLDS+1
5381 UFNTRN(I,KK) = UFNCLU(I,KK)*UFNTRN(I,KK)
5382 DFNTRN(I,KK) = DFNCLU(I,KK)*DFNTRN(I,KK)
5383 700 CONTINUE
5384 701 CONTINUE
5385 !---CASE OF KK=1( FROM THE GROUND TO THE BOTTOM OF THE LOWEST CLOUD)
5386 DO 720 I=MYIS,MYIE
5387 KCLDS=NCLDS(I)
5388 IF(KCLDS.EQ.0) GO TO 720
5389 J2=KBTMSW(I,2)
5390 DO 710 K=J2,LP1
5391 UFN(I,K) = UFNTRN(I,1)*TTU(I,K)
5392 DFN(I,K) = DFNTRN(I,1)*TTD(I,K)
5393 710 CONTINUE
5394 720 CONTINUE
5395 !---REMAINING LEVELS (IF ANY!)
5396 DO 760 I=MYIS,MYIE
5397 KCLDS=NCLDS(I)
5398 IF(KCLDS.EQ.0) GO TO 760
5399 DO 755 KK=2,KCLDS+1
5400 J1=KTOPSW(I,KK)
5401 J2=KBTMSW(I,KK+1)
5402 IF (J1.EQ.1) GO TO 755
5403 DO 730 K=J2,J1
5404 UFN(I,K) = UFNTRN(I,KK)*TTU(I,K)
5405 DFN(I,K) = DFNTRN(I,KK)*TTD(I,K)
5406 730 CONTINUE
5407 !---FOR THE THICK CLOUDS, THE FLUX DIVERGENCE THROUGH THE CLOUD
5408 ! LAYER IS ASSUMED TO BE CONSTANT. THE FLUX DERIVATIVE IS GIVEN BY
5409 ! TEMPF (FOR THE UPWARD FLUX) AND TEMPG (FOR THE DOWNWARD FLUX).
5410 J3=KBTMSW(I,KK)
5411 IF ((J3-J1).GT.1) THEN
5412 TEMPF = (UFNCLU(I,KK)-UFN(I,J3))*DPCLD(I,KK-1)
5413 TEMPG = (DFNCLU(I,KK)-DFN(I,J3))*DPCLD(I,KK-1)
5414 DO 740 K=J1+1,J3-1
5415 UFN(I,K) = UFNCLU(I,KK)+TEMPF*(PP(I,K)-PPTOP(I,KK-1))
5416 DFN(I,K) = DFNCLU(I,KK)+TEMPG*(PP(I,K)-PPTOP(I,KK-1))
5417 740 CONTINUE
5418 ENDIF
5419 755 CONTINUE
5420 760 CONTINUE
5421 DO 770 I=MYIS,MYIE
5422 KCLDS=NCLDS(I)
5423 IF(KCLDS.EQ.0) GO TO 770
5424 DO 771 K=1,LP1
5425 DFSWC(I,K) = DFN(I,K)*DFNTOP(I,1)
5426 UFSWC(I,K) = UFN(I,K)*DFNTOP(I,1)
5427 771 CONTINUE
5428 770 CONTINUE
5429 DO 780 I=MYIS,MYIE
5430 KCLDS=NCLDS(I)
5431 IF(KCLDS.EQ.0) GO TO 780
5432 TMP1(I) = ONE - CCMAX(I)
5433 GDFVB(I) = TMP1(I)*GDFVB(I)
5434 GDFNB(I) = TMP1(I)*GDFNB(I)
5435 GDFVD(I) = TMP1(I)*GDFVD(I) + CCMAX(I)*DFSWC(I,LP1)
5436 780 CONTINUE
5437 !---NOW OBTAIN FLUXES FOR THE NEAR IR BANDS. THE METHODS ARE THE SAME
5438 ! AS FOR THE VISIBLE BAND, EXCEPT THAT THE REFLECTION AND
5439 ! TRANSMISSION COEFFICIENTS ARE DIFFERENT, AS
5440 ! RAYLEIGH SCATTERING NEED NOT BE CONSIDERED.
5441 !
5442 DO 1000 N=2,NB
5443 !YH93
5444 DO 791 I=MYIS,MYIE
5445 KCLDS=NCLDS(I)
5446 IF(KCLDS.EQ.0) GO TO 791
5447 DO 790 K=1,KCLDS+1
5448 CR(I,K) = CRR(I,N,K)*XAMT(I,K)
5449 CT(I,K) = ONE - (ONE-CTT(I,N,K))*XAMT(I,K)
5450 790 CONTINUE
5451 791 CONTINUE
5452 !YH93
5453 IF (N.EQ.2) THEN
5454 ! THE WATER VAPOR TRANSMISSION FUNCTION FOR BAND 2 IS EQUAL TO
5455 ! THAT OF BAND 1 (SAVED AS TTDB1,TTUB1)
5456 DO 800 I=MYIS,MYIE
5457 KCLDS=NCLDS(I)
5458 IF(KCLDS.EQ.0) GO TO 800
5459 DO 801 KK=2,LP1
5460 TTD(I,KK) = TTDB1(I,KK)*TDCO2(I,KK)
5461 801 CONTINUE
5462 DO 802 KK=1,L
5463 TTU(I,KK) = TTUB1(I,KK)*TUCO2(I,KK)
5464 802 CONTINUE
5465 800 CONTINUE
5466 ELSE
5467 DO 810 I=MYIS,MYIE
5468 KCLDS=NCLDS(I)
5469 IF(KCLDS.EQ.0) GO TO 810
5470 DO 811 KK=2,LP1
5471 TTD(I,KK) = EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UD(I,KK))) &
5472 * TDCO2(I,KK)
5473 811 CONTINUE
5474 DO 812 KK=1,L
5475 TTU(I,KK) = EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UR(I,KK))) &
5476 * TUCO2(I,KK)
5477 812 CONTINUE
5478 810 CONTINUE
5479 ENDIF
5480 !---AT THIS POINT,INCLUDE TTD(1),TTU(LP1), NOTING THAT TTD(1)=1 FOR
5481 ! ALL BANDS, AND THAT TTU(LP1)=TTD(LP1) FOR ALL BANDS.
5482 DO 820 I=MYIS,MYIE
5483 KCLDS=NCLDS(I)
5484 IF(KCLDS.EQ.0) GO TO 820
5485 TTU(I,LP1) = TTD(I,LP1)
5486 TTD(I,1) = ONE
5487 820 CONTINUE
5488 !***FOR EXECUTION OF THE CLOUD LOOP, IT IS NECESSARY TO SEPARATE OUT
5489 ! TRANSMISSION FCTNS AT THE TOP AND BOTTOM OF THE CLOUDS, FOR
5490 ! EACH BAND N. THE REQUIRED QUANTITIES ARE:
5491 ! TTD(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1:
5492 ! TTD(I,KBTMSW(I,K),N) K RUNS FROM 2 TO NCLDS(I)+1:
5493 ! TTU(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1:
5494 ! AND INVERSES OF THE ABOVE. THE ABOVE QUANTITIES ARE STORED
5495 ! IN TDCL1,TDCL2,TUCL1,AND DFNTRN,UFNTRN,RESPECTIVELY, AS
5496 ! THEY HAVE MULTIPLE USE IN THE PGM.
5497 !---FOR FIRST CLOUD LAYER (GROUND) TDCL1,TUCL1 ARE KNOWN:
5498 DO 830 I=MYIS,MYIE
5499 KCLDS=NCLDS(I)
5500 IF(KCLDS.EQ.0) GO TO 830
5501 TDCL1 (I,1) = TTD(I,LP1)
5502 TUCL1 (I,1) = TTU(I,LP1)
5503 TDCL2 (I,1) = TDCL1(I,1)
5504 DFNTRN(I,1) = ONE/TDCL1(I,1)
5505 UFNTRN(I,1) = DFNTRN(I,1)
5506 830 CONTINUE
5507 DO 841 I=MYIS,MYIE
5508 KCLDS=NCLDS(I)
5509 IF(KCLDS.EQ.0) GO TO 841
5510 DO 840 KK=2,KCLDS+1
5511 TDCL1(I,KK) = TTD(I,KTOPSW(I,KK))
5512 TUCL1(I,KK) = TTU(I,KTOPSW(I,KK))
5513 TDCL2(I,KK) = TTD(I,KBTMSW(I,KK))
5514 840 CONTINUE
5515 841 CONTINUE
5516 DO 851 I=MYIS,MYIE
5517 KCLDS=NCLDS(I)
5518 IF(KCLDS.EQ.0) GO TO 851
5519 DO 850 KK=2,KCLDS+1
5520 DFNTRN(I,KK) = ONE/TDCL1(I,KK)
5521 UFNTRN(I,KK) = ONE/TUCL1(I,KK)
5522 850 CONTINUE
5523 851 CONTINUE
5524 DO 861 I=MYIS,MYIE
5525 KCLDS=NCLDS(I)
5526 IF(KCLDS.EQ.0) GO TO 861
5527 DO 860 KK=1,KCLDS
5528 TCLU(I,KK) = TDCL1(I,KK)*DFNTRN(I,KK+1)*CT(I,KK+1)
5529 TCLD(I,KK) = TDCL1(I,KK)/TDCL2(I,KK+1)
5530 860 CONTINUE
5531 861 CONTINUE
5532 !***THE FOLLOWING IS THE RECURSION RELATION FOR ALFA: THE REFLECTION
5533 ! COEFFICIENT FOR A SYSTEM INCLUDING THE CLOUD IN QUESTION AND THE
5534 ! FLUX COMING OUT OF THE CLOUD SYSTEM INCLUDING ALL CLOUDS BELOW
5535 ! THE CLOUD IN QUESTION.
5536 DO 870 I=MYIS,MYIE
5537 KCLDS=NCLDS(I)
5538 IF(KCLDS.EQ.0) GO TO 870
5539 ALFA (I,1) = CR(I,1)
5540 ALFAU(I,1) = ZERO
5541 870 CONTINUE
5542 !---AGAIN,EXCESSIVE CALCULATIONS-MAY BE CHANGED LATER!
5543 DO 881 I=MYIS,MYIE
5544 KCLDS=NCLDS(I)
5545 IF(KCLDS.EQ.0) GO TO 881
5546 DO 880 KK=2,KCLDS+1
5547 ALFAU(I,KK) = TCLU(I,KK-1)*TCLU(I,KK-1)*ALFA(I,KK-1)/(ONE - &
5548 TCLD(I,KK-1)*TCLD(I,KK-1)*ALFA(I,KK-1)*CR(I,KK))
5549 ALFA (I,KK) = ALFAU(I,KK)+CR(I,KK)
5550 880 CONTINUE
5551 881 CONTINUE
5552 ! CALCULATE UFN AT CLOUD TOPS AND DFN AT CLOUD BOTTOMS
5553 !---NOTE THAT UFNCLU(I,KCLDS+1) GIVES THE UPWARD FLUX AT THE TOP
5554 ! OF THE HIGHEST REAL CLOUD (IF NCLDS(I)=KCLDS). IT GIVES THE FLUX
5555 ! AT THE TOP OF THE ATMOSPHERE IF NCLDS(I) < KCLDS. IT THE FIRST
5556 ! CASE, TDCL1 EQUALS THE TRANSMISSION FCTN TO THE TOP OF THE
5557 ! HIGHEST CLOUD, AS WE WANT. IN THE SECOND CASE, TDCL1=1, SO UFNCLU
5558 ! EQUALS ALFA. THIS IS ALSO CORRECT.
5559 DO 890 I=MYIS,MYIE
5560 KCLDS=NCLDS(I)
5561 IF(KCLDS.EQ.0) GO TO 890
5562 UFNCLU(I,KCLDS+1) = ALFA(I,KCLDS+1)*TDCL1(I,KCLDS+1)
5563 DFNCLU(I,KCLDS+1) = TDCL1(I,KCLDS+1)
5564 890 CONTINUE
5565 DO 901 I=MYIS,MYIE
5566 KCLDS=NCLDS(I)
5567 IF(KCLDS.EQ.0) GO TO 901
5568 DO 900 KK=KCLDS,1,-1
5569 !
5570 !*** ACCOUNT FOR UNREALISTICALLY SMALL CLOUD AMOUNT
5571 !
5572 DENOM=ALFA(I,KK+1)*TCLU(I,KK)
5573 IF(DENOM.GT.RTHRESH)THEN
5574 UFNCLU(I,KK)=UFNCLU(I,KK+1)*ALFAU(I,KK+1)/DENOM
5575 ELSE
5576 UFNCLU(I,KK)=0.
5577 ENDIF
5578 IF(ALFA(I,KK).GT.RTHRESH)THEN
5579 DFNCLU(I,KK)=UFNCLU(I,KK)/ALFA(I,KK)
5580 ELSE
5581 DFNCLU(I,KK)=0.
5582 ENDIF
5583 900 CONTINUE
5584 901 CONTINUE
5585 ! NOW OBTAIN DFN AND UFN FOR LEVELS BETWEEN THE CLOUDS
5586 DO 911 I=MYIS,MYIE
5587 KCLDS=NCLDS(I)
5588 IF(KCLDS.EQ.0) GO TO 911
5589 DO 910 KK=1,KCLDS+1
5590 UFNTRN(I,KK) = UFNCLU(I,KK)*UFNTRN(I,KK)
5591 DFNTRN(I,KK) = DFNCLU(I,KK)*DFNTRN(I,KK)
5592 910 CONTINUE
5593 911 CONTINUE
5594 DO 930 I=MYIS,MYIE
5595 KCLDS=NCLDS(I)
5596 IF(KCLDS.EQ.0) GO TO 930
5597 J2=KBTMSW(I,2)
5598 DO 920 K=J2,LP1
5599 UFN(I,K) = UFNTRN(I,1)*TTU(I,K)
5600 DFN(I,K) = DFNTRN(I,1)*TTD(I,K)
5601 920 CONTINUE
5602 930 CONTINUE
5603 DO 970 I=MYIS,MYIE
5604 KCLDS=NCLDS(I)
5605 IF(KCLDS.EQ.0) GO TO 970
5606 DO 965 KK=2,KCLDS+1
5607 J1 = KTOPSW(I,KK)
5608 J2 = KBTMSW(I,KK+1)
5609 IF (J1.EQ.1) GO TO 965
5610 DO 940 K=J2,J1
5611 UFN(I,K) = UFNTRN(I,KK)*TTU(I,K)
5612 DFN(I,K) = DFNTRN(I,KK)*TTD(I,K)
5613 940 CONTINUE
5614 J3 = KBTMSW(I,KK)
5615 IF ((J3-J1).GT.1) THEN
5616 TEMPF = (UFNCLU(I,KK)-UFN(I,J3))*DPCLD(I,KK-1)
5617 TEMPG = (DFNCLU(I,KK)-DFN(I,J3))*DPCLD(I,KK-1)
5618 DO 950 K=J1+1,J3-1
5619 UFN(I,K) = UFNCLU(I,KK)+TEMPF*(PP(I,K)-PPTOP(I,KK-1))
5620 DFN(I,K) = DFNCLU(I,KK)+TEMPG*(PP(I,K)-PPTOP(I,KK-1))
5621 950 CONTINUE
5622 ENDIF
5623 965 CONTINUE
5624 970 CONTINUE
5625 DO 980 I=MYIS,MYIE
5626 KCLDS=NCLDS(I)
5627 IF(KCLDS.EQ.0) GO TO 980
5628 DO 981 K=1,LP1
5629 DFSWC(I,K) = DFSWC(I,K) + DFN(I,K)*DFNTOP(I,N)
5630 UFSWC(I,K) = UFSWC(I,K) + UFN(I,K)*DFNTOP(I,N)
5631 981 CONTINUE
5632 980 CONTINUE
5633 DO 990 I=MYIS,MYIE
5634 KCLDS=NCLDS(I)
5635 IF(KCLDS.EQ.0) GO TO 990
5636 GDFND(I) = GDFND(I) + CCMAX(I)*DFN(I,LP1)*DFNTOP(I,N)
5637 990 CONTINUE
5638 1000 CONTINUE
5639 DO 1100 I=MYIS,MYIE
5640 KCLDS=NCLDS(I)
5641 IF(KCLDS.EQ.0) GO TO 1100
5642 DO 1101 K=1,LP1
5643 DFSWC(I,K) = TMP1(I)*DFSWL(I,K) + CCMAX(I)*DFSWC(I,K)
5644 UFSWC(I,K) = TMP1(I)*UFSWL(I,K) + CCMAX(I)*UFSWC(I,K)
5645 1101 CONTINUE
5646 1100 CONTINUE
5647 DO 1200 I=MYIS,MYIE
5648 KCLDS=NCLDS(I)
5649 IF(KCLDS.EQ.0) GO TO 1200
5650 DO 1201 KK=1,LP1
5651 FSWC(I,KK) = UFSWC(I,KK)-DFSWC(I,KK)
5652 1201 CONTINUE
5653 1200 CONTINUE
5654 DO 1250 I=MYIS,MYIE
5655 KCLDS=NCLDS(I)
5656 IF(KCLDS.EQ.0) GO TO 1250
5657 DO 1251 KK=1, L
5658 HSWC(I,KK) = RADCON*(FSWC(I,KK+1)-FSWC(I,KK))/DP(I,KK)
5659 1251 CONTINUE
5660 1250 CONTINUE
5661
5662 END SUBROUTINE SWR93
5663 !-----------------------------------------------------------------------
5664
5665 SUBROUTINE RADFS &
5666
5667 ! *****************************************************************
5668 ! * *
5669 ! * THE INTERNAL DRIVE FOR GFDL RADIATION *
5670 ! * THIS SUBROUTINE WAS FROM Y.H AND K.A.C (1993) *
5671 ! * AND MODIFIED BY Q. ZHAO FOR USE IN THE ETA MODEL *
5672 ! * NOV. 18, 1993 *
5673 ! * *
5674 ! * UPDATE: THIS SUBROUTINE WAS MODIFIED TO USE CLOUD FRACTION *
5675 ! * ON EACH MODEL LAYER. *
5676 ! * QINGYUN ZHAO 95-3-22 *
5677 ! *****************************************************************
5678 !***
5679 !*** REQUIRED INPUT:
5680 !***
5681 (QS,PP,PPI,QQH2O,TT,O3QO3,TSFC,SLMSK,ALBEDO,XLAT &
5682 !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow]
5683 , CAMT,KTOP,KBTM,NCLDS,EMCLD,RRCL,TTCL &
5684 , COSZRO,TAUDAR,IBEG &
5685 , KO3,KALB &
5686 , ITIMSW,ITIMLW &
5687 !***************************************************************************
5688 !* IX IS THE LENGTH OF A ROW IN THE DOMAIN
5689 !
5690 !* QS(IX): THE SURFACE PRESSURE (PA)
5691 !* PP(IX,L): THE MIDLAYER PRESSURES (PA) (L IS THE VERT. DIMEN.)
5692 !* PPI(IX,LP1) THE INTERFACE PRESSURES (PA)
5693 !* QQH2O(IX,L): THE MIDLAYER WATER VAPOR MIXING RATIO (KG/KG)
5694 !* TT(IX,L): THE MIDLAYER TEMPERATURE (K)
5695 !* O3QO3(IX,L): THE MIDLAYER OZONE MIXING RATIO
5696 !* TSFC(IX): THE SKIN TEMP. (K); NEGATIVE OVER WATER
5697 !* SLMSK(IX): THE SEA MASK (LAND=0,SEA=1)
5698 !* ALBEDO(IX): THE SURFACE ALBEDO (EXPRESSED AS A FRACTION)
5699 !* XLAT(IX): THE GEODETIC LATITUDES OF EACH COLUMN IN DEGREES
5700 !* (N.H.> 0)
5701 !* THE FOLLOWING ARE CLOUD INFORMATION FOR EACH CLOUD LAYER
5702 !* LAYER=1:SURFACE
5703 !* LAYER=2:FIRST LAYER ABOVE GROUND, AND SO ON
5704 !* CAMT(IX,LP1): CLOUD FRACTION OF EACH CLOUD LAYER
5705 !* ITYP(IX,LP1): CLOUD TYPE(=1: STRATIFORM, =2:CONVECTIVE)
5706 !* KTOP(IX,LP1): HEIGHT OF CLOUD TOP OF EACH CLOUD LAYER (IN ETA LEVEL)
5707 !* KBTM(IX,LP1): BOTTOM OF EACH CLOUD LAYER
5708 !* NCLDS(IX): NUMBER OF CLOUD LAYERS
5709 !* EMCLD(IX,LP1): CLOUD EMISSIVITY
5710 !* RRCL(IX,NB,LP1) CLOUD REFLECTTANCES FOR SW SPECTRAL BANDS
5711 !* TTCL(IX,NB,LP1) CLOUD TRANSMITANCES FOR SW SPECTRAL BANDS
5712 !* THE ABOVE ARE CLOUD INFORMATION FOR EACH CLOUD LAYER
5713 !*
5714 !* COSZRO(IX): THE COSINE OF THE SOLAR ZENITH ANGLE
5715 !* TAUDAR: =1.0
5716 !* IBEG: =1
5717 !* KO3: =1 ( READ IN THE QZONE DATA)
5718 !* KALB: =0
5719 !* ITIMSW: =1/0 (SHORTWAVE CALC. ARE DESIRED/NOT DESIRED)
5720 !* ITIMLW: =1/0 (LONGWAVE CALC. ARE DESIRED/NOT DESIRED)
5721 !************************************************************************
5722 !***
5723 !*** GENERATED OUTPUT REQUIRED BY THE ETA MODEL
5724 !***
5725 , SWH,HLW &
5726 , FLWUP,FSWUP,FSWDN,FSWDNS,FSWUPS,FLWDNS,FLWUPS,FSWDNSC &
5727 , ids,ide, jds,jde, kds,kde &
5728 , ims,ime, jms,jme, kms,kme &
5729 ! begin debugging radiation
5730 , its,ite, jts,jte, kts,kte &
5731 , imd,jmd, Jndx )
5732 ! end debugging radiation
5733 !************************************************************************
5734 !* SWH: ATMOSPHERIC SHORTWAVE HEATING RATES IN K/S.
5735 !* SWH IS A REAL ARRAY DIMENSIONED (NCOL X LM).
5736 !* HLW: ATMOSPHERIC LONGWAVE HEATING RATES IN K/S.
5737 !* HLW IS A REAL ARRAY DIMENSIONED (NCOL X LM).
5738 !* FLWUP: UPWARD LONGWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2.
5739 !* FLWUP IS A REAL ARRAY DIMENSIONED (NCOL).
5740 !* FSWUP: UPWARD SHORTWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2.
5741 !* FSWUP IS A REAL ARRAY DIMENSIONED (NCOL).
5742 !* FSWDN: DOWNWARD SHORTWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2.
5743 !* FSWDN IS A REAL ARRAY DIMENSIONED (NCOL).
5744 !* FSWDNS: DOWNWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2.
5745 !* FSWDNS IS A REAL ARRAY DIMENSIONED (NCOL).
5746 !* FSWUPS: UPWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2.
5747 !* FSWUPS IS A REAL ARRAY DIMENSIONED (NCOL).
5748 !* FLWDNS: DOWNWARD LONGWAVE FLUX AT THE SURFACE IN W/M**2.
5749 !* FLWDNS IS A REAL ARRAY DIMENSIONED (NCOL).
5750 !* FLWUPS: UPWARD LONGWAVE FLUX AT THE SURFACE IN W/M**2.
5751 !* FLWUPS IS A REAL ARRAY DIMENSIONED (NCOL).
5752 !* FSWDNSC: CLEAR-SKY DOWNWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2.
5753 !* FSWDNSC IS A REAL ARRAY DIMENSIONED (NCOL).
5754 !************************************************************************
5755 !***
5756 !*** THE FOLLOWING OUTPUTS ARE NOT REQUIRED BY THE ETA MODEL
5757 !***
5758 !----------------------------------------------------------------------
5759 IMPLICIT NONE
5760 !----------------------------------------------------------------------
5761 !INTEGER, PARAMETER :: NBLY=15
5762 INTEGER, PARAMETER :: NB=12
5763 INTEGER, PARAMETER :: NBLX=47
5764 INTEGER , PARAMETER:: NBLW = 163
5765
5766 REAL,PARAMETER :: AMOLWT=28.9644
5767 REAL,PARAMETER :: CSUBP=1.00484E7
5768 REAL,PARAMETER :: DIFFCTR=1.66
5769 REAL,PARAMETER :: G=980.665
5770 REAL,PARAMETER :: GINV=1./G
5771 REAL,PARAMETER :: GRAVDR=980.0
5772 REAL,PARAMETER :: O3DIFCTR=1.90
5773 REAL,PARAMETER :: P0=1013250.
5774 REAL,PARAMETER :: P0INV=1./P0
5775 REAL,PARAMETER :: GP0INV=GINV*P0INV
5776 REAL,PARAMETER :: P0XZP2=202649.902
5777 REAL,PARAMETER :: P0XZP8=810600.098
5778 REAL,PARAMETER :: P0X2=2.*1013250.
5779 REAL,PARAMETER :: RADCON=8.427
5780 REAL,PARAMETER :: RADCON1=1./8.427
5781 REAL,PARAMETER :: RATCO2MW=1.519449738
5782 REAL,PARAMETER :: RATH2OMW=.622
5783 REAL,PARAMETER :: RGAS=8.3142E7
5784 REAL,PARAMETER :: RGASSP=8.31432E7
5785 REAL,PARAMETER :: SECPDA=8.64E4
5786 !
5787 !******THE FOLLOWING ARE MATHEMATICAL CONSTANTS*******
5788 ! ARRANGED IN DECREASING ORDER
5789 REAL,PARAMETER :: HUNDRED=100.
5790 REAL,PARAMETER :: HNINETY=90.
5791 REAL,PARAMETER :: HNINE=9.0
5792 REAL,PARAMETER :: SIXTY=60.
5793 REAL,PARAMETER :: FIFTY=50.
5794 REAL,PARAMETER :: TEN=10.
5795 REAL,PARAMETER :: EIGHT=8.
5796 REAL,PARAMETER :: FIVE=5.
5797 REAL,PARAMETER :: FOUR=4.
5798 REAL,PARAMETER :: THREE=3.
5799 REAL,PARAMETER :: TWO=2.
5800 REAL,PARAMETER :: ONE=1.
5801 REAL,PARAMETER :: HAF=0.5
5802 REAL,PARAMETER :: QUARTR=0.25
5803 REAL,PARAMETER :: ZERO=0.
5804 !
5805 !******FOLLOWING ARE POSITIVE FLOATING POINT CONSTANTS(H'S)
5806 ! ARRANGED IN DECREASING ORDER
5807 REAL,PARAMETER :: H83E26=8.3E26
5808 REAL,PARAMETER :: H71E26=7.1E26
5809 REAL,PARAMETER :: H1E15=1.E15
5810 REAL,PARAMETER :: H1E13=1.E13
5811 REAL,PARAMETER :: H1E11=1.E11
5812 REAL,PARAMETER :: H1E8=1.E8
5813 REAL,PARAMETER :: H2E6=2.0E6
5814 REAL,PARAMETER :: H1E6=1.0E6
5815 REAL,PARAMETER :: H69766E5=6.97667E5
5816 REAL,PARAMETER :: H4E5=4.E5
5817 REAL,PARAMETER :: H165E5=1.65E5
5818 REAL,PARAMETER :: H5725E4=57250.
5819 REAL,PARAMETER :: H488E4=48800.
5820 REAL,PARAMETER :: H1E4=1.E4
5821 REAL,PARAMETER :: H24E3=2400.
5822 REAL,PARAMETER :: H20788E3=2078.8
5823 REAL,PARAMETER :: H2075E3=2075.
5824 REAL,PARAMETER :: H18E3=1800.
5825 REAL,PARAMETER :: H1224E3=1224.
5826 REAL,PARAMETER :: H67390E2=673.9057
5827 REAL,PARAMETER :: H5E2=500.
5828 REAL,PARAMETER :: H3082E2=308.2
5829 REAL,PARAMETER :: H3E2=300.
5830 REAL,PARAMETER :: H2945E2=294.5
5831 REAL,PARAMETER :: H29316E2=293.16
5832 REAL,PARAMETER :: H26E2=260.0
5833 REAL,PARAMETER :: H25E2=250.
5834 REAL,PARAMETER :: H23E2=230.
5835 REAL,PARAMETER :: H2E2=200.0
5836 REAL,PARAMETER :: H15E2=150.
5837 REAL,PARAMETER :: H1386E2=138.6
5838 REAL,PARAMETER :: H1036E2=103.6
5839 REAL,PARAMETER :: H8121E1=81.21
5840 REAL,PARAMETER :: H35E1=35.
5841 REAL,PARAMETER :: H3116E1=31.16
5842 REAL,PARAMETER :: H28E1=28.
5843 REAL,PARAMETER :: H181E1=18.1
5844 REAL,PARAMETER :: H18E1=18.
5845 REAL,PARAMETER :: H161E1=16.1
5846 REAL,PARAMETER :: H16E1=16.
5847 REAL,PARAMETER :: H1226E1=12.26
5848 REAL,PARAMETER :: H9P94=9.94
5849 REAL,PARAMETER :: H6P08108=6.081081081
5850 REAL,PARAMETER :: H3P6=3.6
5851 REAL,PARAMETER :: H3P5=3.5
5852 REAL,PARAMETER :: H2P9=2.9
5853 REAL,PARAMETER :: H2P8=2.8
5854 REAL,PARAMETER :: H2P5=2.5
5855 REAL,PARAMETER :: H1P8=1.8
5856 REAL,PARAMETER :: H1P4387=1.4387
5857 REAL,PARAMETER :: H1P41819=1.418191
5858 REAL,PARAMETER :: H1P4=1.4
5859 REAL,PARAMETER :: H1P25892=1.258925411
5860 REAL,PARAMETER :: H1P082=1.082
5861 REAL,PARAMETER :: HP816=0.816
5862 REAL,PARAMETER :: HP805=0.805
5863 REAL,PARAMETER :: HP8=0.8
5864 REAL,PARAMETER :: HP60241=0.60241
5865 REAL,PARAMETER :: HP602409=0.60240964
5866 REAL,PARAMETER :: HP6=0.6
5867 REAL,PARAMETER :: HP526315=0.52631579
5868 REAL,PARAMETER :: HP518=0.518
5869 REAL,PARAMETER :: HP5048=0.5048
5870 REAL,PARAMETER :: HP3795=0.3795
5871 REAL,PARAMETER :: HP369=0.369
5872 REAL,PARAMETER :: HP26=0.26
5873 REAL,PARAMETER :: HP228=0.228
5874 REAL,PARAMETER :: HP219=0.219
5875 REAL,PARAMETER :: HP166666=.166666
5876 REAL,PARAMETER :: HP144=0.144
5877 REAL,PARAMETER :: HP118666=0.118666192
5878 REAL,PARAMETER :: HP1=0.1
5879 ! (NEGATIVE EXPONENTIALS BEGIN HERE)
5880 REAL,PARAMETER :: H658M2=0.0658
5881 REAL,PARAMETER :: H625M2=0.0625
5882 REAL,PARAMETER :: H44871M2=4.4871E-2
5883 REAL,PARAMETER :: H44194M2=.044194
5884 REAL,PARAMETER :: H42M2=0.042
5885 REAL,PARAMETER :: H41666M2=0.0416666
5886 REAL,PARAMETER :: H28571M2=.02857142857
5887 REAL,PARAMETER :: H2118M2=0.02118
5888 REAL,PARAMETER :: H129M2=0.0129
5889 REAL,PARAMETER :: H1M2=.01
5890 REAL,PARAMETER :: H559M3=5.59E-3
5891 REAL,PARAMETER :: H3M3=0.003
5892 REAL,PARAMETER :: H235M3=2.35E-3
5893 REAL,PARAMETER :: H1M3=1.0E-3
5894 REAL,PARAMETER :: H987M4=9.87E-4
5895 REAL,PARAMETER :: H323M4=0.000323
5896 REAL,PARAMETER :: H3M4=0.0003
5897 REAL,PARAMETER :: H285M4=2.85E-4
5898 REAL,PARAMETER :: H1M4=0.0001
5899 REAL,PARAMETER :: H75826M4=7.58265E-4
5900 REAL,PARAMETER :: H6938M5=6.938E-5
5901 REAL,PARAMETER :: H394M5=3.94E-5
5902 REAL,PARAMETER :: H37412M5=3.7412E-5
5903 REAL,PARAMETER :: H15M5=1.5E-5
5904 REAL,PARAMETER :: H1439M5=1.439E-5
5905 REAL,PARAMETER :: H128M5=1.28E-5
5906 REAL,PARAMETER :: H102M5=1.02E-5
5907 REAL,PARAMETER :: H1M5=1.0E-5
5908 REAL,PARAMETER :: H7M6=7.E-6
5909 REAL,PARAMETER :: H4999M6=4.999E-6
5910 REAL,PARAMETER :: H451M6=4.51E-6
5911 REAL,PARAMETER :: H25452M6=2.5452E-6
5912 REAL,PARAMETER :: H1M6=1.E-6
5913 REAL,PARAMETER :: H391M7=3.91E-7
5914 REAL,PARAMETER :: H1174M7=1.174E-7
5915 REAL,PARAMETER :: H8725M8=8.725E-8
5916 REAL,PARAMETER :: H327M8=3.27E-8
5917 REAL,PARAMETER :: H257M8=2.57E-8
5918 REAL,PARAMETER :: H1M8=1.0E-8
5919 REAL,PARAMETER :: H23M10=2.3E-10
5920 REAL,PARAMETER :: H14M10=1.4E-10
5921 REAL,PARAMETER :: H11M10=1.1E-10
5922 REAL,PARAMETER :: H1M10=1.E-10
5923 REAL,PARAMETER :: H83M11=8.3E-11
5924 REAL,PARAMETER :: H82M11=8.2E-11
5925 REAL,PARAMETER :: H8M11=8.E-11
5926 REAL,PARAMETER :: H77M11=7.7E-11
5927 REAL,PARAMETER :: H72M11=7.2E-11
5928 REAL,PARAMETER :: H53M11=5.3E-11
5929 REAL,PARAMETER :: H48M11=4.8E-11
5930 REAL,PARAMETER :: H44M11=4.4E-11
5931 REAL,PARAMETER :: H42M11=4.2E-11
5932 REAL,PARAMETER :: H37M11=3.7E-11
5933 REAL,PARAMETER :: H35M11=3.5E-11
5934 REAL,PARAMETER :: H32M11=3.2E-11
5935 REAL,PARAMETER :: H3M11=3.0E-11
5936 REAL,PARAMETER :: H28M11=2.8E-11
5937 REAL,PARAMETER :: H24M11=2.4E-11
5938 REAL,PARAMETER :: H23M11=2.3E-11
5939 REAL,PARAMETER :: H2M11=2.E-11
5940 REAL,PARAMETER :: H18M11=1.8E-11
5941 REAL,PARAMETER :: H15M11=1.5E-11
5942 REAL,PARAMETER :: H14M11=1.4E-11
5943 REAL,PARAMETER :: H114M11=1.14E-11
5944 REAL,PARAMETER :: H11M11=1.1E-11
5945 REAL,PARAMETER :: H1M11=1.E-11
5946 REAL,PARAMETER :: H96M12=9.6E-12
5947 REAL,PARAMETER :: H93M12=9.3E-12
5948 REAL,PARAMETER :: H77M12=7.7E-12
5949 REAL,PARAMETER :: H74M12=7.4E-12
5950 REAL,PARAMETER :: H65M12=6.5E-12
5951 REAL,PARAMETER :: H62M12=6.2E-12
5952 REAL,PARAMETER :: H6M12=6.E-12
5953 REAL,PARAMETER :: H45M12=4.5E-12
5954 REAL,PARAMETER :: H44M12=4.4E-12
5955 REAL,PARAMETER :: H4M12=4.E-12
5956 REAL,PARAMETER :: H38M12=3.8E-12
5957 REAL,PARAMETER :: H37M12=3.7E-12
5958 REAL,PARAMETER :: H3M12=3.E-12
5959 REAL,PARAMETER :: H29M12=2.9E-12
5960 REAL,PARAMETER :: H28M12=2.8E-12
5961 REAL,PARAMETER :: H24M12=2.4E-12
5962 REAL,PARAMETER :: H21M12=2.1E-12
5963 REAL,PARAMETER :: H16M12=1.6E-12
5964 REAL,PARAMETER :: H14M12=1.4E-12
5965 REAL,PARAMETER :: H12M12=1.2E-12
5966 REAL,PARAMETER :: H8M13=8.E-13
5967 REAL,PARAMETER :: H46M13=4.6E-13
5968 REAL,PARAMETER :: H36M13=3.6E-13
5969 REAL,PARAMETER :: H135M13=1.35E-13
5970 REAL,PARAMETER :: H12M13=1.2E-13
5971 REAL,PARAMETER :: H1M13=1.E-13
5972 REAL,PARAMETER :: H3M14=3.E-14
5973 REAL,PARAMETER :: H15M14=1.5E-14
5974 REAL,PARAMETER :: H14M14=1.4E-14
5975 !
5976 !******FOLLOWING ARE NEGATIVE FLOATING POINT CONSTANTS (HM'S)
5977 ! ARRANGED IN DESCENDING ORDER
5978 REAL,PARAMETER :: HM2M2=-.02
5979 REAL,PARAMETER :: HM6666M2=-.066667
5980 REAL,PARAMETER :: HMP5=-0.5
5981 REAL,PARAMETER :: HMP575=-0.575
5982 REAL,PARAMETER :: HMP66667=-.66667
5983 REAL,PARAMETER :: HMP805=-0.805
5984 REAL,PARAMETER :: HM1EZ=-1.
5985 REAL,PARAMETER :: HM13EZ=-1.3
5986 REAL,PARAMETER :: HM19EZ=-1.9
5987 REAL,PARAMETER :: HM1E1=-10.
5988 REAL,PARAMETER :: HM1597E1=-15.97469413
5989 REAL,PARAMETER :: HM161E1=-16.1
5990 REAL,PARAMETER :: HM1797E1=-17.97469413
5991 REAL,PARAMETER :: HM181E1=-18.1
5992 REAL,PARAMETER :: HM8E1=-80.
5993 REAL,PARAMETER :: HM1E2=-100.
5994 !
5995 REAL,PARAMETER :: H1M16=1.0E-16
5996 REAL,PARAMETER :: H1M20=1.E-20
5997 REAL,PARAMETER :: Q19001=19.001
5998 REAL,PARAMETER :: DAYSEC=1.1574E-5
5999 REAL,PARAMETER :: HSIGMA=5.673E-8
6000 REAL,PARAMETER :: TWENTY=20.0
6001 REAL,PARAMETER :: HP537=0.537
6002 REAL,PARAMETER :: HP2=0.2
6003 REAL,PARAMETER :: RCO2=3.3E-4
6004 REAL,PARAMETER :: H3M6=3.0E-6
6005 REAL,PARAMETER :: PI=3.1415927
6006 REAL,PARAMETER :: DEGRAD1=180.0/PI
6007 REAL,PARAMETER :: H74E1=74.0
6008 REAL,PARAMETER :: H15E1=15.0
6009
6010 REAL, PARAMETER:: B0 = -.51926410E-4
6011 REAL, PARAMETER:: B1 = -.18113332E-3
6012 REAL, PARAMETER:: B2 = -.10680132E-5
6013 REAL, PARAMETER:: B3 = -.67303519E-7
6014 REAL, PARAMETER:: AWIDE = 0.309801E+01
6015 REAL, PARAMETER:: BWIDE = 0.495357E-01
6016 REAL, PARAMETER:: BETAWD = 0.347839E+02
6017 REAL, PARAMETER:: BETINW = 0.766811E+01
6018
6019
6020 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
6021 ims,ime, jms,jme, kms,kme , &
6022 its,ite, jts,jte, kts,kte
6023 INTEGER, INTENT(IN) :: IBEG,KO3,KALB,ITIMSW,ITIMLW
6024 !----------------------------------------------------------------------
6025 ! ****************************************************************
6026 ! * GENERALIZED FOR PLUG-COMPATIBILITY - *
6027 ! * ORIGINAL CODE WAS CLEANED-UP GFDL CODE...K.CAMPANA MAR89..*
6028 !......* EXAMPLE FOR MRF: *
6029 ! * KO3 =0 AND O3QO3=DUMMY ARRAY. (GFDL CLIMO O3 USED) *
6030 ! * KEMIS=0 AND HI CLD EMIS COMPUTED HERE (CEMIS=DUMMY INPUT)*
6031 ! * KALB =0 AND SFC ALBEDO OVER OPEN WATER COMPUTED BELOW... *
6032 ! * KCCO2=0,CO2 OBTAINED FROM BLOCK DATA *
6033 ! * =1,CO2 COMPUTED IN HERE --- NOT AVAILABLE YET... *
6034 ! * UPDATED FOR YUTAI HOU SIB SW RADIATION....KAC 6 MAR 92 *
6035 ! * OCEAN ALBEDO FOR BEAM SET TO BULK SFCALB, SINCE *
6036 ! * COSINE ZENITH ANGLE EFFECTS ALREADY THERE(REF:PAYNE) *
6037 ! * SLMSK = 0. *
6038 ! * SNOW ICE ALBEDO FOR BEAM NOT ENHANCED VIA COSINE ZENITH *
6039 ! * ANGLE EITHER CAUSE VALU ALREADY HIGH (WE SEE POLAR *
6040 ! * COOLING IF WE DO BEAM CALCULATION)....KAC 17MAR92 *
6041 ! * ALBEDO GE .5 *
6042 ! * UPDATED TO OBTAIN CLEAR SKY FLUXES "ON THE FLY" FOR *
6043 ! * CLOUD FORCING DIAGNOSTICS ELSEWHERE...KAC 7AUG92 *
6044 ! * SEE ##CLR LINES...RADFS,LWR88,FST88,SPA88 ....... *
6045 ! * UPDATED FOR USE NEW CLD SCHEME ......YH DEC 92 *
6046 ! * INPUT CLD MAY BE AS ORIGINAL IN 3 DOMAIN (CLD,MTOP,MBOT) *
6047 ! * OR IN A VERTICAL ARRAY OF 18 MDL LAYERS (CLDARY) *
6048 ! * IEMIS=0 USE THE ORG. CLD EMIS SCHEME *
6049 ! * =1 USE TEMP DEP. CLD EMIS SCHEME *
6050 ! * UPDATED TO COMPUTE CLD LAYER REFLECTTANCE AND TRANSMITTANCE *
6051 ! * INPUT CLD EMISSIVITY AND OPTICAL THICKNESS 'EMIS0,TAUC0' *
6052 ! * ......YH FEB 93 *
6053 ! ****************************************************************
6054 !--------------------------------
6055 ! INTEGER, PARAMETER:: LNGTH=37*kte
6056 !--------------------------------
6057
6058 ! REAL, INTENT(IN) :: SKO3R,AB15WD,SKC1R,SKO2D
6059
6060 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte):: PP,TT
6061 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte):: QQH2O
6062 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1):: PPI,CAMT,EMCLD
6063 REAL, INTENT(IN), DIMENSION(its:ite):: QS,TSFC,SLMSK,ALBEDO,XLAT
6064 REAL, INTENT(IN), DIMENSION(its:ite):: COSZRO,TAUDAR
6065 REAL, INTENT(OUT), DIMENSION(its:ite):: FLWUPS
6066 INTEGER, INTENT(IN), DIMENSION(its:ite):: NCLDS
6067 INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1):: KTOP,KBTM
6068 REAL, INTENT(INOUT), DIMENSION(its:ite,NB,kts:kte+1):: TTCL,RRCL
6069 REAL, intent(IN), DIMENSION(its:ite,kts:kte):: O3QO3
6070 ! REAL, INTENT(IN), DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW
6071 ! REAL, INTENT(IN), DIMENSION(5040) :: EM3V
6072
6073 ! REAL, DIMENSION(its:ite)::ALVBR,ALNBR, ALVDR,ALNDR
6074
6075 ! TABLE ???
6076
6077 REAL, DIMENSION(3) :: BO3RND,AO3RND
6078 REAL, DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
6079 BCOMB,BETACM
6080
6081 DATA AO3RND / 0.543368E+02, 0.234676E+04, 0.384881E+02/
6082 DATA BO3RND / 0.526064E+01, 0.922424E+01, 0.496515E+01/
6083
6084 DATA ACOMB / &
6085 0.152070E+05, 0.332194E+04, 0.527177E+03, 0.163124E+03, &
6086 0.268808E+03, 0.534591E+02, 0.268071E+02, 0.123133E+02, &
6087 0.600199E+01, 0.640803E+00, 0.501549E-01, 0.167961E-01, &
6088 0.178110E-01, 0.170166E+00, 0.537083E-02/
6089 DATA BCOMB / &
6090 0.152538E+00, 0.118677E+00, 0.103660E+00, 0.100119E+00, &
6091 0.127518E+00, 0.118409E+00, 0.904061E-01, 0.642011E-01, &
6092 0.629660E-01, 0.643346E-01, 0.717082E-01, 0.629730E-01, &
6093 0.875182E-01, 0.857907E-01, 0.214005E+00/
6094 DATA APCM / &
6095 -0.671879E-03, 0.654345E-02, 0.143657E-01, 0.923593E-02, &
6096 0.117022E-01, 0.159596E-01, 0.181600E-01, 0.145013E-01, &
6097 0.170062E-01, 0.233303E-01, 0.256735E-01, 0.274745E-01, &
6098 0.279259E-01, 0.197002E-01, 0.349782E-01/
6099 DATA BPCM / &
6100 -0.113520E-04, -0.323965E-04, -0.448417E-04, -0.230779E-04, &
6101 -0.361981E-04, -0.145117E-04, 0.198349E-04, -0.486529E-04, &
6102 -0.550050E-04, -0.684057E-04, -0.447093E-04, -0.778390E-04, &
6103 -0.982953E-04, -0.772497E-04, -0.748263E-04/
6104 DATA ATPCM / &
6105 -0.106346E-02, 0.641531E-02, 0.137362E-01, 0.922513E-02, &
6106 0.136162E-01, 0.169791E-01, 0.206959E-01, 0.166223E-01, &
6107 0.171776E-01, 0.229724E-01, 0.275530E-01, 0.302731E-01, &
6108 0.281662E-01, 0.199525E-01, 0.370962E-01/
6109 DATA BTPCM / &
6110 -0.735731E-05, -0.294149E-04, -0.505592E-04, -0.280894E-04, &
6111 -0.492972E-04, -0.341508E-04, -0.362947E-04, -0.250487E-04, &
6112 -0.521369E-04, -0.746260E-04, -0.744124E-04, -0.881905E-04, &
6113 -0.933645E-04, -0.664045E-04, -0.115290E-03/
6114 DATA BETACM / &
6115 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
6116 0.188625E+03, 0.144293E+03, 0.174098E+03, 0.909366E+02, &
6117 0.497489E+02, 0.221212E+02, 0.113124E+02, 0.754174E+01, &
6118 0.589554E+01, 0.495227E+01, 0.000000E+00/
6119
6120
6121 ! *********************************************
6122 !====> * OUTPUT TO CALLING PROGRAM *
6123 ! *********************************************
6124
6125 REAL, INTENT(INOUT),DIMENSION(its:ite,kts:kte)::SWH,HLW
6126 REAL, INTENT(OUT), DIMENSION(its:ite):: FSWUP,FSWUPS,FSWDN, &
6127 FSWDNS,FLWUP,FLWDNS,FSWDNSC
6128
6129 ! *********************************************
6130 !====> * POSSIBLE OUTPUT TO CALLING PROGRAM *
6131 ! *********************************************
6132
6133 REAL, DIMENSION(its:ite):: GDFVBR,GDFNBR,GDFVDR,GDFNDR
6134
6135 ! ************************************************************
6136 !====> * ARRAYS NEEDED BY SWR91SIB..FOR CLEAR SKY DATA(EG.FSWL) *
6137 ! ************************************************************
6138
6139 REAL, DIMENSION(its:ite,kts:kte+1)::FSWL,HSWL,UFL,DFL
6140
6141 ! ******************************************************
6142 !====> * ARRAYS NEEDED BY CLO88, LWR88, SWR89 OR SWR91SIB *
6143 ! ******************************************************
6144
6145 REAL, DIMENSION(its:ite,kts:kte+1,kts:kte+1)::CLDFAC
6146 REAL, DIMENSION(its:ite,kts:kte+1)::EQCMT,PRESS,TEMP,FSW,HSW,UF,DF
6147 REAL, DIMENSION(its:ite,kts:kte)::RH2O,QO3,HEATRA
6148 REAL, DIMENSION(its:ite):: COSZEN,TAUDA,GRNFLX,TOPFLX,GRDFLX
6149 REAL, DIMENSION(kts:kte+1)::PHALF
6150 !..... ADD PRESSURE INTERFACE
6151
6152 REAL, DIMENSION(NB) :: ABCFF,PWTS
6153
6154 DATA ABCFF/2*4.0E-5,.002,.035,.377,1.95,9.40,44.6,190., &
6155 989.,2706.,39011./
6156 DATA PWTS/.5000,.121416,.0698,.1558,.0631,.0362,.0243,.0158,.0087, &
6157 .001467,.002342,.001075/
6158
6159 REAL :: CFCO2,CFO3,REFLO3,RRAYAV
6160
6161 DATA CFCO2,CFO3/508.96,466.64/
6162 DATA REFLO3/1.9/
6163 DATA RRAYAV/0.144/
6164
6165 ! *********************************************
6166 !====> * VECTOR TEMPORARIES FOR CLOUD CALC. *
6167 ! *********************************************
6168
6169 REAL, DIMENSION(its:ite):: TTHAN
6170 REAL, DIMENSION(its:ite,kts:kte):: DO3V,DO3VP
6171 INTEGER, DIMENSION(its:ite):: JJROW
6172
6173 !====> **************************************************************
6174 !-- SEASONAL CLIMATOLOGIES OF O3 (OBTAINED FROM A PREVIOUSLY RUN
6175 ! CODE WHICH INTERPOLATES O3 TO USER VERTICAL COORDINATE).
6176 ! DEFINED AS 5 DEG LAT MEANS N.P.->S.P.
6177 ! COMMON /SAVMEM/ &
6178 !- ...WINTER.... ...SPRING.... ...SUMMER.... ....FALL.....
6179 ! DDUO3N(37,L), DDO3N2(37,L), DDO3N3(37,L), DDO3N4(37,L)
6180
6181 REAL, DIMENSION(37,kte) :: DDUO3N,DDO3N2,DDO3N3,DDO3N4
6182
6183 !====> **************************************************************
6184 !
6185 REAL, DIMENSION(21,20) :: ALBD
6186 REAL, DIMENSION(20) :: ZA
6187 REAL, DIMENSION(21) :: TRN
6188 REAL, DIMENSION(19) :: DZA
6189
6190 REAL :: YEAR,TPI,SSOLAR,DATE,TH2,ZEN,DZEN,ALB1,ALB2
6191 INTEGER :: IR,IQ,JX
6192 DATA TRN/.00,.05,.10,.15,.20,.25,.30,.35,.40,.45,.50,.55,.60,.65, &
6193 .70,.75,.80,.85,.90,.95,1.00/
6194
6195 REAL :: ALB11(21,7),ALB22(21,7),ALB33(21,6)
6196
6197 EQUIVALENCE (ALB11(1,1),ALBD(1,1)),(ALB22(1,1),ALBD(1,8)), &
6198 (ALB33(1,1),ALBD(1,15))
6199 DATA ALB11/ .061,.062,.072,.087,.115,.163,.235,.318,.395,.472,.542, &
6200 .604,.655,.693,.719,.732,.730,.681,.581,.453,.425,.061,.062,.070, &
6201 .083,.108,.145,.198,.263,.336,.415,.487,.547,.595,.631,.656,.670, &
6202 .652,.602,.494,.398,.370,.061,.061,.068,.079,.098,.130,.174,.228, &
6203 .290,.357,.424,.498,.556,.588,.603,.592,.556,.488,.393,.342,.325, &
6204 .061,.061,.065,.073,.086,.110,.150,.192,.248,.306,.360,.407,.444, &
6205 .469,.480,.474,.444,.386,.333,.301,.290,.061,.061,.065,.070,.082, &
6206 .101,.131,.168,.208,.252,.295,.331,.358,.375,.385,.377,.356,.320, &
6207 .288,.266,.255,.061,.061,.063,.068,.077,.092,.114,.143,.176,.210, &
6208 .242,.272,.288,.296,.300,.291,.273,.252,.237,.266,.220,.061,.061, &
6209 .062,.066,.072,.084,.103,.127,.151,.176,.198,.219,.236,.245,.250, &
6210 .246,.235,.222,.211,.205,.200/
6211 DATA ALB22/ .061,.061,.061,.065,.071,.079,.094,.113,.134,.154,.173, &
6212 .185,.190,.193,.193,.190,.188,.185,.182,.180,.178,.061,.061,.061, &
6213 .064,.067,.072,.083,.099,.117,.135,.150,.160,.164,.165,.164,.162, &
6214 .160,.159,.158,.157,.157,.061,.061,.061,.062,.065,.068,.074,.084, &
6215 .097,.111,.121,.127,.130,.131,.131,.130,.129,.127,.126,.125,.122, &
6216 .061,.061,.061,.061,.062,.064,.070,.076,.085,.094,.101,.105,.107, &
6217 .106,.103,.100,.097,.096,.095,.095,.095,.061,.061,.061,.060,.061, &
6218 .062,.065,.070,.075,.081,.086,.089,.090,.088,.084,.080,.077,.075, &
6219 .074,.074,.074,.061,.061,.060,.060,.060,.061,.063,.065,.068,.072, &
6220 .076,.077,.076,.074,.071,.067,.064,.062,.061,.061,.061,.061,.061, &
6221 .060,.060,.060,.060,.061,.062,.065,.068,.069,.069,.068,.065,.061, &
6222 .058,.055,.054,.053,.052,.052/
6223 DATA ALB33/ .061,.061,.060,.060,.060,.060,.060,.060,.062,.065,.065, &
6224 .063,.060,.057,.054,.050,.047,.046,.045,.044,.044,.061,.061,.060, &
6225 .060,.060,.059,.059,.059,.059,.059,.058,.055,.051,.047,.043,.039, &
6226 .035,.033,.032,.031,.031,.061,.061,.060,.060,.060,.059,.059,.058, &
6227 .057,.056,.054,.051,.047,.043,.039,.036,.033,.030,.028,.027,.026, &
6228 .061,.061,.060,.060,.060,.059,.059,.058,.057,.055,.052,.049,.045, &
6229 .040,.036,.032,.029,.027,.026,.025,.025,.061,.061,.060,.060,.060, &
6230 .059,.059,.058,.056,.053,.050,.046,.042,.038,.034,.031,.028,.026, &
6231 .025,.025,.025,.061,.061,.060,.060,.059,.058,.058,.057,.055,.053, &
6232 .050,.046,.042,.038,.034,.030,.028,.029,.025,.025,.025/
6233 DATA ZA/90.,88.,86.,84.,82.,80.,78.,76.,74.,70.,66.,62.,58.,54., &
6234 50.,40.,30.,20.,10.,0.0/
6235 DATA DZA/8*2.0,6*4.0,5*10.0/
6236
6237 ! ***********************************************************
6238 !
6239
6240 REAL, DIMENSION(its:ite) :: ALVB,ALNB,ALVD,ALND, &
6241 GDFVB, &
6242 GDFNB,GDFVD,GDFND, &
6243 SFCALB
6244
6245 REAL :: RRVCO2,RRCO2,TDUM
6246 REAL :: ALBD0,ALVD1,ALND1
6247 INTEGER :: N
6248 !
6249 !*** The following two lines are for debugging.
6250 integer :: imd,jmd, Jndx
6251 real :: FSWrat,FSWrat1,FSWDNS1
6252 !***
6253
6254 !====> BEGIN HERE .......................
6255 !
6256 !--- SSOLAR IS THE SOLAR CONSTANT SCALED TO A MORE CURRENT VALUE;
6257 ! I.E. IF SOLC=2.0 LY/MIN THEN SSOLAR=1.96 LY/MIN.
6258 REAL,PARAMETER :: H196=1.96
6259
6260 INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1
6261 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN
6262
6263 L=kte
6264 LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1
6265 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L
6266 LLM2 = LL-2; LLM1=LL-1
6267 MYIS=its; MYIE=ite
6268
6269 !******ZHAO
6270 ! NOTE: XLAT IS IN DEGREE HERE
6271 !*****ZHAO
6272 !-- Formerly => SOLC=2./(R1*R1), SSOLAR=0.98*SOLC
6273 SSOLAR=H196/(R1*R1)
6274 !*********************************************************
6275 ! Special note: The solar constant is reduced extra 3 percent to account
6276 ! for the lack of aerosols in the shortwave radiation
6277 ! parameterization. Q. Zhao 96-7-23
6278 ! ### May also be due not accounting for reduction in solar constant due to
6279 ! absorption by ozone above the top of the model domain (Ferrier, Apr-2005)
6280 !*********************************************************
6281 SSOLAR=SSOLAR*0.97
6282 !
6283 DO 40 I=MYIS,MYIE
6284 IR = I + IBEG - 1
6285 TH2=HP2*XLAT(IR)
6286 JJROW(I)=Q19001-TH2
6287 TTHAN(I)=(19-JJROW(I))-TH2
6288 !..... NOTE THAT THE NMC VARIABLES ARE IN MKS (THUS PRESSURE IS IN
6289 ! CENTIBARS)WHILE ALL GFDL VARIABLES ARE IN CGS UNITS
6290 SFCALB(I) = ALBEDO(IR)
6291 !..... NOW PUT SFC TEMP,PRESSURES, ZENITH ANGLE INTO SW COMMON BLOCK...
6292 !***ZHAO
6293 ! NOTE: ALL PRESSURES INPUT FROM THE ETA MODEL ARE IN PA
6294 ! THE UNIT FOR PRESS IS MICRO BAR
6295 ! SURFACE TEMPERATURE ARE NEGATIVE OVER OCEANS IN THE ETA MODEL
6296 !***ZHAO
6297 PRESS(I,LP1)=QS(IR)*10.0
6298 TEMP(I,LP1)=ABS(TSFC(IR))
6299 COSZEN(I) = COSZRO(IR)
6300 TAUDA(I) = TAUDAR(IR)
6301 40 CONTINUE
6302 !***ZHAO
6303 !..... ALL GFDL VARIABLES HAVE K=1 AT THE TOP OF THE ATMOSPHERE.NMC
6304 ! ETA MODEL HAS THE SAME STRUCTURE
6305 !***ZHAO
6306 DO 50 K=1,L
6307 DO 50 I=MYIS,MYIE
6308 IR = I + IBEG - 1
6309 !..... NOW PUT TEMP,PRESSURES, INTO SW COMMON BLOCK..........
6310 TEMP(I,K) = TT(IR,K)
6311 PRESS(I,K) = 10.0 * PP(IR,K)
6312 !.... STORE LYR MOISTURE AND ADD TO SW COMMON BLOCK
6313 RH2O(I,K)=QQH2O(IR,K)
6314 IF(RH2O(I,K).LT.H3M6) RH2O(I,K)=H3M6
6315 50 CONTINUE
6316 !... *************************
6317 IF (KO3.EQ.0) GO TO 65
6318 !... *************************
6319 DO 60 K=1,L
6320 DO 60 I=MYIS,MYIE
6321 QO3(I,K) = O3QO3(I+IBEG-1,K)
6322 60 CONTINUE
6323 65 CONTINUE
6324 !... ************************************
6325 IF (KALB.GT.0) GO TO 110
6326 !... ************************************
6327 !..... THE FOLLOWING CODE GETS ALBEDO FROM PAYNE,1972 TABLES IF
6328 ! 1) OPEN SEA POINT (SLMSK=1);2) KALB=0
6329 IQ=INT(TWENTY*HP537+ONE)
6330 DO 105 I=MYIS,MYIE
6331 IF(COSZEN(I).GT.0.0 .AND. SLMSK(I+IBEG-1).GT.0.5) THEN
6332 ZEN=DEGRAD1*ACOS(MAX(COSZEN(I),0.0))
6333 IF(ZEN.GE.H74E1) JX=INT(HAF*(HNINETY-ZEN)+ONE)
6334 IF(ZEN.LT.H74E1.AND.ZEN.GE.FIFTY) &
6335 JX=INT(QUARTR*(H74E1-ZEN)+HNINE)
6336 IF(ZEN.LT.FIFTY) JX=INT(HP1*(FIFTY-ZEN)+H15E1)
6337 DZEN=-(ZEN-ZA(JX))/DZA(JX)
6338 ALB1=ALBD(IQ,JX)+DZEN*(ALBD(IQ,JX+1)-ALBD(IQ,JX))
6339 ALB2=ALBD(IQ+1,JX)+DZEN*(ALBD(IQ+1,JX+1)-ALBD(IQ+1,JX))
6340 SFCALB(I)=ALB1+TWENTY*(ALB2-ALB1)*(HP537-TRN(IQ))
6341 ENDIF
6342 105 CONTINUE
6343 110 CONTINUE
6344 ! **********************************
6345 IF (KO3.GT.0) GO TO 135
6346 ! **********************************
6347 !.... COMPUTE CLIMATOLOGICAL ZONAL MEAN OZONE,
6348 !.... SEASONAL AND SPATIAL INTERPOLATION DONE BELOW.
6349 DO 125 I=MYIS,MYIE
6350
6351 PHALF(1)=0.
6352 PHALF(LP1)=PPI(I,kme)
6353 DO K=1,LM1
6354 PHALF(K+1)=PP(I,K) ! AETA(K)*PDIF+PT ! BSF index was erroneously L
6355 ENDDO
6356
6357 CALL O3INT(PHALF,DDUO3N,DDO3N2,DDO3N3,DDO3N4, &
6358 ids,ide, jds,jde, kds,kde, &
6359 ims,ime, jms,jme, kms,kme, &
6360 its,ite, jts,jte, kts,kte )
6361
6362 DO 130 K=1,L
6363 DO3V(I,K) = DDUO3N(JJROW(I),K) + RSIN1*DDO3N2(JJROW(I),K) &
6364 +RCOS1*DDO3N3(JJROW(I),K) &
6365 +RCOS2*DDO3N4(JJROW(I),K)
6366 DO3VP(I,K) = DDUO3N(JJROW(I)+1,K) + RSIN1*DDO3N2(JJROW(I)+1,K) &
6367 +RCOS1*DDO3N3(JJROW(I)+1,K) &
6368 +RCOS2*DDO3N4(JJROW(I)+1,K)
6369 !... NOW LATITUDINAL INTERPOLATION, AND
6370 ! CONVERT O3 INTO MASS MIXING RATIO(ORIGINAL DATA MPY BY 1.E4)
6371 QO3(I,K) = H1M4 * (DO3V(I,K)+TTHAN(I)*(DO3VP(I,K)-DO3V(I,K)))
6372 130 CONTINUE
6373 125 CONTINUE
6374 135 CONTINUE
6375 !.............
6376 DO 195 I=MYIS,MYIE
6377 !..... VISIBLE AND NEAR IR DIFFUSE ALBEDO
6378 ALVD(I) = SFCALB(I)
6379 ALND(I) = SFCALB(I)
6380 !..... VISIBLE AND NEAR IR DIRECT BEAM ALBEDO
6381 ALVB(I) = SFCALB(I)
6382 ALNB(I) = SFCALB(I)
6383 !
6384 !--- Remove diurnal variation of land surface albedos (Ferrier, 6/28/05)
6385 !--- Turn back on to mimic NAM 8/17/05
6386 !
6387 !..... VISIBLE AND NEAR IR DIRECT BEAM ALBEDO,IF NOT OCEAN NOR SNOW
6388 ! ..FUNCTION OF COSINE SOLAR ZENITH ANGLE..
6389 IF (SLMSK(I+IBEG-1).LT.0.5) THEN
6390 IF (SFCALB(I).LE.0.5) THEN
6391 ALBD0 = -18.0 * (0.5 - ACOS(COSZEN(I))/PI)
6392 ALBD0 = EXP (ALBD0)
6393 ALVD1 = (ALVD(I) - 0.054313) / 0.945687
6394 ALND1 = (ALND(I) - 0.054313) / 0.945687
6395 ALVB(I) = ALVD1 + (1.0 - ALVD1) * ALBD0
6396 ALNB(I) = ALND1 + (1.0 - ALND1) * ALBD0
6397 !-- Put in an upper limit on beam albedos
6398 ALVB(I) = MIN(0.5,ALVB(I))
6399 ALNB(I) = MIN(0.5,ALNB(I))
6400 END IF
6401 END IF
6402 195 CONTINUE
6403 !.....SURFACE VALUES OF RRCL AND TTCL
6404 DO 200 N=1,2
6405 DO 200 I=MYIS,MYIE
6406 RRCL(I,N,1)=ALVD(I)
6407 TTCL(I,N,1)=ZERO
6408 200 CONTINUE
6409 DO 220 N=3,NB
6410 DO 220 I=MYIS,MYIE
6411 RRCL(I,N,1)=ALND(I)
6412 TTCL(I,N,1)=ZERO
6413 220 CONTINUE
6414 !... **************************
6415 !... * END OF CLOUD SECTION *
6416 !... **************************
6417 !... THE FOLLOWING CODE CONVERTS RRVCO2,THE VOLUME MIXING RATIO OF CO2
6418 ! INTO RRCO2,THE MASS MIXING RATIO.
6419 RRVCO2=RCO2
6420 RRCO2=RRVCO2*RATCO2MW
6421 250 IF(ITIMLW .EQ. 0) GO TO 300
6422 !
6423 ! ***********************
6424 !====> * LONG WAVE RADIATION *
6425 ! ***********************
6426 !
6427 !.... ACCOUNT FOR REDUCED EMISSIVITY OF ANY CLDS
6428 DO 240 K=1,LP1
6429 DO 240 I=MYIS,MYIE
6430 EQCMT(I,K)=CAMT(I,K)*EMCLD(I,K)
6431 240 CONTINUE
6432 !.... GET CLD FACTOR FOR LW CALCULATIONS
6433 !....
6434
6435 ! shuhua
6436
6437 CALL CLO89(CLDFAC,EQCMT,NCLDS,KBTM,KTOP, &
6438 ids,ide, jds,jde, kds,kde, &
6439 ims,ime, jms,jme, kms,kme, &
6440 its,ite, jts,jte, kts,kte )
6441
6442 ! shuhua
6443 !===> LONG WAVE RADIATION
6444 ! CALL LWR88(HEATRA,GRNFLX,TOPFLX, &
6445 ! PRESS,TEMP,RH2O,QO3,CLDFAC, &
6446 ! EQCMT,NCLDS,KTOP,KBTM, &
6447 !
6448 !! BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, &
6449 ! BO3RND,AO3RND, &
6450 ! APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
6451 ! ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR, &
6452 ! GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8, &
6453 ! P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF, &
6454 ! TEN,HP1,FOUR,HM1EZ,SKO3R, &
6455 ! AB15WD,SKC1R,RADCON,QUARTR,TWO, &
6456 ! HM6666M2,HMP66667,HMP5, HP166666,H41666M2, &
6457 ! RADCON1,H16E1, H28E1,H44194M2,H1P41819,SKO2D, &
6458 ! ids,ide, jds,jde, kds,kde, &
6459 ! ims,ime, jms,jme, kms,kme, &
6460 ! its,ite, jts,jte, kts,kte )
6461
6462 CALL LWR88(HEATRA,GRNFLX,TOPFLX, &
6463 PRESS,TEMP,RH2O,QO3,CLDFAC, &
6464 EQCMT,NCLDS,KTOP,KBTM, &
6465 !
6466 ! BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, &
6467 BO3RND,AO3RND, &
6468 APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
6469 ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR, &
6470 GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8, &
6471 P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF, &
6472 TEN,HP1,FOUR,HM1EZ, &
6473 RADCON,QUARTR,TWO, &
6474 HM6666M2,HMP66667,HMP5, HP166666,H41666M2, &
6475 RADCON1,H16E1, H28E1,H44194M2,H1P41819, &
6476 ids,ide, jds,jde, kds,kde, &
6477 ims,ime, jms,jme, kms,kme, &
6478 its,ite, jts,jte, kts,kte )
6479
6480 !....
6481 !================================================================================
6482 !--- IMPORTANT!! Y.-T Hou advised Ferrier, Mitchell, & Ek on 7/28/05 to use
6483 ! the following algorithm, because the GFDL code calculates NET longwave flux
6484 ! (GRNFLX, Up - Down) as its fundamental quantity.
6485 !
6486 ! 1. Calculate upward LW at surface (FLWUPS)
6487 ! 2. Calculate downward LW at surface (FLWDNS) = FLWUPS - .001*GRNFLX
6488 !
6489 !--- Note: The following fluxes must be multipled by .001 to convert to mks
6490 ! => GRNFLX, or GRound Net FLuX
6491 ! => TOPFLX, or top of the atmosphere fluxes (FLWUP)
6492 !
6493 !--- IMPORTANT!! If the surface emissivity (SFCEMS) differs from 1.0, then
6494 ! uncomment the line below starting with "!BSF"
6495 !================================================================================
6496 DO 280 I=MYIS,MYIE
6497 IR = I + IBEG - 1
6498 FLWUP(IR) = .001*TOPFLX(I)
6499 ! TDUM=TEMP(I,LP1)
6500 !--- Use an average of the skin & lowest model level temperature
6501 TDUM=.5*(TEMP(I,LP1)+TEMP(I,L))
6502 FLWUPS(IR)=HSIGMA*TDUM*TDUM*TDUM*TDUM
6503 !BSF FLWUPS(IR)=SFCEMS*HSIGMA*TDUM*TDUM*TDUM*TDUM
6504 FLWDNS(IR)=FLWUPS(IR)-.001*GRNFLX(I)
6505 280 CONTINUE
6506 !.... Average LW heating/cooling rates over the lowest 2 atmospheric layers,
6507 ! which may be necessary for when dealing with thin layers near the surface
6508 DO I=MYIS,MYIE
6509 TDUM=.5*(HEATRA(I,L)+HEATRA(I,LM1))
6510 HEATRA(I,L)=TDUM
6511 HEATRA(I,LM1)=TDUM
6512 ENDDO
6513 !.... CONVERT HEATING RATES TO DEG/SEC
6514 DO 290 K=1,L
6515 DO 290 I=MYIS,MYIE
6516 HLW(I+IBEG-1,K)=HEATRA(I,K)*DAYSEC
6517 290 CONTINUE
6518 300 CONTINUE
6519 IF(ITIMSW .EQ. 0) GO TO 350
6520 !SW
6521 CALL SWR93(FSW,HSW,UF,DF,FSWL,HSWL,UFL,DFL, &
6522 PRESS,COSZEN,TAUDA,RH2O,RRCO2,SSOLAR,QO3, &
6523 NCLDS,KTOP,KBTM,CAMT,RRCL,TTCL, &
6524 ALVB,ALNB,ALVD,ALND,GDFVB,GDFNB,GDFVD,GDFND, &
6525 !
6526 ! UCO2,UO3,TUCO2,TUO3,TDO3,TDCO2, &
6527 ABCFF,PWTS, &
6528 H35E1,H1224E3,ONE,ZERO,HAF,H69766E5,HP219, &
6529 HP816,RRAYAV,GINV,CFCO2,CFO3, &
6530 TWO,H235M3,HP26,H129M2,H75826M4,H1036E2, &
6531 H1P082,HMP805,H1386E2,H658M2,H2118M2,H42M2, &
6532 H323M4,HM1EZ,DIFFCTR,O3DIFCTR,FIFTY,RADCON, &
6533 ids,ide, jds,jde, kds,kde, &
6534 ims,ime, jms,jme, kms,kme, &
6535 its,ite, jts,jte, kts,kte )
6536
6537 !SW
6538 !
6539 !..... GET SW FLUXES IN WATTS/M**2
6540 DO 320 I=MYIS,MYIE
6541 IR = I + IBEG - 1
6542 FSWUP(IR) = UF(I,1) * 1.E-3
6543 FSWDN(IR) = DF(I,1) * 1.E-3
6544 FSWUPS(IR) = UF(I,LP1) * 1.E-3
6545 !-- FSWDNS is more accurate using array DF than summing the GDFxx arrays
6546 !C..COUPLE W/M2 DIFF, IF FSWDNS(IR)=DF(I,LP1)*1.#E-3
6547 !! FSWDNS(IR) = (GDFVB(I)+GDFNB(I)+GDFVD(I)+GDFND(I)) * 1.E-3
6548 FSWDNS(IR) = DF(I,LP1) * 1.E-3
6549 FSWDNSC(IR) = DFL(I,LP1) * 1.E-3
6550 !... DOWNWARD SFC FLUX FOR THE SIB PARAMETERATION
6551 !..... VISIBLE AND NEAR IR DIFFUSE
6552 GDFVDR(IR) = GDFVD(I) * 1.E-3
6553 GDFNDR(IR) = GDFND(I) * 1.E-3
6554 !..... VISIBLE AND NEAR IR DIRECT BEAM
6555 GDFVBR(IR) = GDFVB(I) * 1.E-3
6556 GDFNBR(IR) = GDFNB(I) * 1.E-3
6557 320 CONTINUE
6558 !.... CONVERT HEATING RATES TO DEG/SEC
6559 DO 330 K=1,L
6560 DO 330 I=MYIS,MYIE
6561 SWH(I+IBEG-1,K)=HSW(I,K)*DAYSEC
6562 330 CONTINUE
6563 350 CONTINUE
6564 ! begin debugging radiation
6565
6566 ! if (Jndx .eq. jmd) then
6567 ! FSWDNS1=(GDFVB(imd)+GDFNB(imd)+GDFVD(imd)+GDFND(imd))*.001
6568 ! write(6,"(3a,2i5,7f9.2)") '{rad2 imd,Jndx,' &
6569 ! ,'GSW=FSWDNS-FSWUPS,RSWIN=FSWDNS,RSWIN_1=FSWDNS1,' &
6570 ! ,'FSWDNS-FSWDNS1,RSWOUT=FSWUPS,RSWINC=FSWDNSC,GLW=FLWDNS = ' &
6571 ! ,imd,Jndx, FSWDNS(imd)-FSWUPS(imd),FSWDNS(imd),FSWDNS1 &
6572 ! ,FSWDNS(imd)-FSWDNS1,FSWUPS(imd),FSWDNSC(imd),FLWDNS(imd)
6573 ! FSWrat=0.
6574 ! if (FSWDNS(imd) .ne. 0.) FSWrat=FSWUPS(imd)/FSWDNS(imd)
6575 ! FSWrat1=0.
6576 ! if (FSWDNS1 .ne. 0.) FSWrat1=FSWUPS(imd)/FSWDNS1
6577 ! write(6,"(2a,10f8.4)") '{rad2a ALBEDO,SFCALB,ALVD,ALND,ALVB,' &
6578 ! ,'ALNB,CZEN,SLMSK,FSWUPS/FSWDNS,FSWUPS/FSWDNS1 = ' &
6579 ! ,ALBEDO(imd),SFCALB(imd),ALVD(imd),ALND(imd),ALVB(imd) &
6580 ! ,ALNB(imd),COSZEN(imd),SLMSK(imd),FSWrat,FSWrat1
6581 ! endif
6582 ! end debugging radiation
6583 RETURN
6584 1000 FORMAT(1H ,' YOU ARE CALLING GFDL RADIATION CODE FOR',I5,' PTS', &
6585 'AND',I4,' LYRS,WITH KDAPRX,KO3,KCZ,KEMIS,KALB = ',5I2)
6586
6587 END SUBROUTINE RADFS
6588
6589 !-----------------------------------------------------------------------
6590 SUBROUTINE O3CLIM
6591 ! (XDUO3N,XDO3N2,XDO3N3,XDO3N4,PRGFDL, &
6592 ! ids,ide, jds,jde, kds,kde, &
6593 ! ims,ime, jms,jme, kms,kme, &
6594 ! its,ite, jts,jte, kts,kte )
6595 !----------------------------------------------------------------------
6596 IMPLICIT NONE
6597 !----------------------------------------------------------------------
6598 ! INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
6599 ! ims,ime, jms,jme, kms,kme , &
6600 ! its,ite, jts,jte, kts,kte
6601
6602 ! ******************************************************************
6603 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
6604 ! . . .
6605 ! SUBPROGRAM: O3CLIM GENERATE SEASONAL OZONE DISTRIBUTION
6606 ! PRGRMMR: GFDL/CAMPANA ORG: W/NP22 DATE: ??-??-??
6607 !
6608 ! ABSTRACT:
6609 ! O3CLIM COMPUTES THE SEASONAL CLIMATOLOGY OF OZONE USING
6610 ! 81-LAYER DATA FROM GFDL.
6611 !
6612 ! PROGRAM HISTORY LOG:
6613 ! ??-??-?? GFDL/KC - ORIGINATOR
6614 ! 96-07-26 BLACK - MODIFIED FOR ETA MODEL
6615 !
6616 ! USAGE: CALL O3CLIM FROM SUBROUTINE RADTN
6617 ! INPUT ARGUMENT LIST:
6618 ! NONE
6619 !
6620 ! OUTPUT ARGUMENT LIST:
6621 ! NONE
6622 !
6623 ! OUTPUT FILES:
6624 ! NONE
6625 !
6626 ! SUBPROGRAMS CALLED:
6627 !
6628 ! UNIQUE:
6629 ! NONE
6630 !
6631 ! LIBRARY:
6632 ! NONE
6633 !
6634 ! COMMON BLOCKS: SEASO3
6635 ! O3DATA
6636 !
6637 ! ATTRIBUTES:
6638 ! LANGUAGE: FORTRAN 90
6639 ! MACHINE : IBM SP
6640 !$$$
6641 !----------------------------------------------------------------------
6642 ! INTEGER :: NL,NLP1,NLGTH,NKK,NK,NKP
6643 INTEGER, PARAMETER :: NL=81,NLP1=NL+1,NLGTH=37*NL,NKK=41,NK=81,NKP=NK+1
6644 !----------------------------------------------------------------------
6645 ! INCLUDE "SEASO3.comm"
6646 !---------------------------------------------------------------------
6647 ! REAL, INTENT(OUT), DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4
6648 ! REAL, INTENT(OUT), DIMENSION(NL) :: PRGFDL
6649
6650 ! COMMON /SEASO3/
6651 ! ...WINTER.... ...SPRING.... ...SUMMER.... ....FALL.....
6652 ! & XDUO3N(37,NL), XDO3N2(37,NL), XDO3N3(37,NL), XDO3N4(37,NL)
6653 !
6654 ! &,PRGFDL(NL)
6655 !---------------------------------------------------------------------
6656 REAL :: PH1(45),PH2(37),P1(48),P2(33),O3HI1(10,16),O3HI2(10,9) &
6657 ,O3LO1(10,16),O3LO2(10,16),O3LO3(10,16),O3LO4(10,16)
6658 !----------------------------------------------------------------------
6659 REAL :: AVG,A1,B1,B2
6660 INTEGER :: K,N,NCASE,IPLACE,KK,NKM,NKMM,KI,KQ,JJ,KEN,I,iindex,jindex
6661 !----------------------------------------------------------------------
6662 REAL :: PSTD(NL),TEMPN(19),O3O3(37,NL,4),O35DEG(37,NL) &
6663 ,XRAD1(NLGTH),XRAD2(NLGTH),XRAD3(NLGTH),XRAD4(NLGTH) &
6664 ,DDUO3N(19,NL),DUO3N(19,41) &
6665 ,RO3(10,41),RO3M(10,40),RO31(10,41),RO32(10,41) &
6666 ,O3HI(10,25) &
6667 ,RSTD(81),RBAR(NL),RDATA(81) &
6668 ,PHALF(NL),P(81),PH(82)
6669 REAL :: PXX(81),PYY(82) ! fix for nesting
6670 !----------------------------------------------------------------------
6671 !nesting EQUIVALENCE &
6672 !nesting (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17)) &
6673 !nesting ,(PH1(1),PH(1)),(PH2(1),PH(46)) &
6674 !nesting ,(P1(1),P(1)),(P2(1),P(49))
6675 EQUIVALENCE &
6676 (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17)) &
6677 ,(PH1(1),PYY(1)),(PH2(1),PYY(46)) & ! fix for nesting
6678 ,(P1(1),PXX(1)),(P2(1),PXX(49)) ! fix for nesting
6679 !----------------------------------------------------------------------
6680 ! EQUIVALENCE &
6681 ! (XRAD1(1),XDUO3N(1,1),O3O3(1,1,1)) &
6682 ! ,(XRAD2(1),XDO3N2(1,1)) &
6683 ! ,(XRAD3(1),XDO3N3(1,1)),(XRAD4(1),XDO3N4(1,1),)
6684 EQUIVALENCE &
6685 (XRAD1(1),O3O3(1,1,1)) &
6686 ,(XRAD2(1),O3O3(1,1,2)) &
6687 ,(XRAD3(1),O3O3(1,1,3)),(XRAD4(1),O3O3(1,1,4))
6688 !----------------------------------------------------------------------
6689 !---------------------------------------------------------------------
6690 DATA PH1/ 0., &
6691 0.1027246E-04, 0.1239831E-04, 0.1491845E-04, 0.1788053E-04, &
6692 0.2135032E-04, 0.2540162E-04, 0.3011718E-04, 0.3558949E-04, &
6693 0.4192172E-04, 0.4922875E-04, 0.5763817E-04, 0.6729146E-04, &
6694 0.7834518E-04, 0.9097232E-04, 0.1053635E-03, 0.1217288E-03, &
6695 0.1402989E-03, 0.1613270E-03, 0.1850904E-03, 0.2119495E-03, &
6696 0.2423836E-03, 0.2768980E-03, 0.3160017E-03, 0.3602623E-03, &
6697 0.4103126E-03, 0.4668569E-03, 0.5306792E-03, 0.6026516E-03, &
6698 0.6839018E-03, 0.7759249E-03, 0.8803303E-03, 0.9987843E-03, &
6699 0.1133178E-02, 0.1285955E-02, 0.1460360E-02, 0.1660001E-02, &
6700 0.1888764E-02, 0.2151165E-02, 0.2452466E-02, 0.2798806E-02, &
6701 0.3197345E-02, 0.3656456E-02, 0.4185934E-02, 0.4797257E-02/
6702 DATA PH2/ &
6703 0.5503893E-02, 0.6321654E-02, 0.7269144E-02, 0.8368272E-02, &
6704 0.9644873E-02, 0.1112946E-01, 0.1285810E-01, 0.1487354E-01, &
6705 0.1722643E-01, 0.1997696E-01, 0.2319670E-01, 0.2697093E-01, &
6706 0.3140135E-01, 0.3660952E-01, 0.4274090E-01, 0.4996992E-01, &
6707 0.5848471E-01, 0.6847525E-01, 0.8017242E-01, 0.9386772E-01, &
6708 0.1099026E+00, 0.1286765E+00, 0.1506574E+00, 0.1763932E+00, &
6709 0.2065253E+00, 0.2415209E+00, 0.2814823E+00, 0.3266369E+00, &
6710 0.3774861E+00, 0.4345638E+00, 0.4984375E+00, 0.5697097E+00, &
6711 0.6490189E+00, 0.7370409E+00, 0.8344896E+00, 0.9421190E+00, &
6712 0.1000000E+01/
6713 DATA P1/ &
6714 0.9300000E-05, 0.1129521E-04, 0.1360915E-04, 0.1635370E-04, &
6715 0.1954990E-04, 0.2331653E-04, 0.2767314E-04, 0.3277707E-04, &
6716 0.3864321E-04, 0.4547839E-04, 0.5328839E-04, 0.6234301E-04, &
6717 0.7263268E-04, 0.8450696E-04, 0.9793231E-04, 0.1133587E-03, &
6718 0.1307170E-03, 0.1505832E-03, 0.1728373E-03, 0.1982122E-03, &
6719 0.2266389E-03, 0.2592220E-03, 0.2957792E-03, 0.3376068E-03, &
6720 0.3844381E-03, 0.4379281E-03, 0.4976965E-03, 0.5658476E-03, &
6721 0.6418494E-03, 0.7287094E-03, 0.8261995E-03, 0.9380076E-03, &
6722 0.1063498E-02, 0.1207423E-02, 0.1369594E-02, 0.1557141E-02, &
6723 0.1769657E-02, 0.2015887E-02, 0.2295520E-02, 0.2620143E-02, &
6724 0.2989651E-02, 0.3419469E-02, 0.3909867E-02, 0.4481491E-02, &
6725 0.5135272E-02, 0.5898971E-02, 0.6774619E-02, 0.7799763E-02/
6726 DATA P2/ &
6727 0.8978218E-02, 0.1036103E-01, 0.1195488E-01, 0.1382957E-01, &
6728 0.1599631E-01, 0.1855114E-01, 0.2151235E-01, 0.2501293E-01, &
6729 0.2908220E-01, 0.3390544E-01, 0.3952926E-01, 0.4621349E-01, &
6730 0.5403168E-01, 0.6330472E-01, 0.7406807E-01, 0.8677983E-01, &
6731 0.1015345E+00, 0.1189603E+00, 0.1391863E+00, 0.1630739E+00, &
6732 0.1908004E+00, 0.2235461E+00, 0.2609410E+00, 0.3036404E+00, &
6733 0.3513750E+00, 0.4055375E+00, 0.4656677E+00, 0.5335132E+00, &
6734 0.6083618E+00, 0.6923932E+00, 0.7845676E+00, 0.8875882E+00, &
6735 0.1000000E+01/
6736 DATA O3HI1/ &
6737 .55,.50,.45,.45,.40,.35,.35,.30,.30,.30, &
6738 .55,.51,.46,.47,.42,.38,.37,.36,.35,.35, &
6739 .55,.53,.48,.49,.44,.42,.41,.40,.38,.38, &
6740 .60,.55,.52,.52,.50,.47,.46,.44,.42,.41, &
6741 .65,.60,.55,.56,.53,.52,.50,.48,.45,.45, &
6742 .75,.65,.60,.60,.55,.55,.55,.50,.48,.47, &
6743 .80,.75,.75,.75,.70,.70,.65,.63,.60,.60, &
6744 .90,.85,.85,.80,.80,.75,.75,.74,.72,.71, &
6745 1.10,1.05,1.00,.90,.90,.90,.85,.83,.80,.80, &
6746 1.40,1.30,1.25,1.25,1.25,1.20,1.15,1.10,1.05,1.00, &
6747 1.7,1.7,1.6,1.6,1.6,1.6,1.6,1.6,1.5,1.5, &
6748 2.1,2.0,1.9,1.9,1.9,1.8,1.8,1.8,1.7,1.7, &
6749 2.4,2.3,2.2,2.2,2.2,2.1,2.1,2.1,2.0,2.0, &
6750 2.7,2.5,2.5,2.5,2.5,2.5,2.4,2.4,2.3,2.3, &
6751 2.9,2.8,2.7,2.7,2.7,2.7,2.7,2.7,2.6,2.6, &
6752 3.1,3.1,3.0,3.0,3.0,3.0,3.0,3.0,2.9,2.8/
6753 DATA O3HI2/ &
6754 3.3,3.4,3.4,3.6,3.7,3.9,4.0,4.1,4.0,3.8, &
6755 3.6,3.8,3.9,4.2,4.7,5.3,5.6,5.7,5.5,5.2, &
6756 4.1,4.3,4.7,5.2,6.0,6.7,7.0,6.8,6.4,6.2, &
6757 5.4,5.7,6.0,6.6,7.3,8.0,8.4,7.7,7.1,6.7, &
6758 6.7,6.8,7.0,7.6,8.3,10.0,9.6,8.2,7.5,7.2, &
6759 9.2,9.3,9.4,9.6,10.3,10.6,10.0,8.5,7.7,7.3, &
6760 12.6,12.1,12.0,12.1,11.7,11.0,10.0,8.6,7.8,7.4, &
6761 14.2,13.5,13.1,12.8,11.9,10.9,9.8,8.5,7.8,7.5, &
6762 14.3,14.0,13.4,12.7,11.6,10.6,9.3,8.4,7.6,7.3/
6763 DATA O3LO1/ &
6764 14.9,14.2,13.3,12.5,11.2,10.3,9.5,8.6,7.5,7.4, &
6765 14.5,14.1,13.0,11.8,10.5,9.8,9.2,7.9,7.4,7.4, &
6766 11.8,11.5,10.9,10.5,9.9,9.6,8.9,7.5,7.2,7.2, &
6767 7.3,7.7,7.8,8.4,8.4,8.5,7.9,7.4,7.1,7.1, &
6768 4.1,4.4,5.3,6.6,6.9,7.5,7.4,7.2,7.0,6.9, &
6769 1.8,1.9,2.5,3.3,4.5,5.8,6.3,6.3,6.4,6.1, &
6770 0.4,0.5,0.8,1.2,2.7,3.6,4.6,4.7,5.0,5.2, &
6771 .10,.15,.20,.50,1.4,2.1,3.0,3.2,3.5,3.9, &
6772 .07,.10,.12,.30,1.0,1.4,1.8,1.9,2.3,2.5, &
6773 .06,.08,.10,.15,.60,.80,1.4,1.5,1.5,1.6, &
6774 .05,.05,.06,.09,.20,.40,.70,.80,.90,.90, &
6775 .05,.05,.06,.08,.10,.13,.20,.25,.30,.40, &
6776 .05,.05,.05,.06,.07,.07,.08,.09,.10,.13, &
6777 .05,.05,.05,.05,.06,.06,.06,.06,.07,.07, &
6778 .05,.05,.05,.05,.05,.05,.05,.06,.06,.06, &
6779 .04,.04,.04,.04,.04,.04,.04,.05,.05,.05/
6780 DATA O3LO2/ &
6781 14.8,14.2,13.8,12.2,11.0,9.8,8.5,7.8,7.4,6.9, &
6782 13.2,13.0,12.5,11.3,10.4,9.0,7.8,7.5,7.0,6.6, &
6783 10.6,10.6,10.7,10.1,9.4,8.6,7.5,7.0,6.5,6.1, &
6784 7.0,7.3,7.5,7.5,7.5,7.3,6.7,6.4,6.0,5.8, &
6785 3.8,4.0,4.7,5.0,5.2,5.9,5.8,5.6,5.5,5.5, &
6786 1.4,1.6,2.4,3.0,3.7,4.1,4.6,4.8,5.1,5.0, &
6787 .40,.50,.90,1.2,2.0,2.7,3.2,3.6,4.3,4.1, &
6788 .07,.10,.20,.30,.80,1.4,2.1,2.4,2.7,3.0, &
6789 .06,.07,.09,.15,.30,.70,1.2,1.4,1.6,2.0, &
6790 .05,.05,.06,.12,.15,.30,.60,.70,.80,.80, &
6791 .04,.05,.06,.08,.09,.15,.30,.40,.40,.40, &
6792 .04,.04,.05,.055,.06,.09,.12,.13,.15,.15, &
6793 .03,.03,.045,.052,.055,.06,.07,.07,.06,.07, &
6794 .03,.03,.04,.051,.052,.052,.06,.06,.05,.05, &
6795 .02,.02,.03,.05,.05,.05,.04,.04,.04,.04, &
6796 .02,.02,.02,.04,.04,.04,.03,.03,.03,.03/
6797 DATA O3LO3/ &
6798 14.5,14.0,13.5,11.3,11.0,10.0,9.0,8.3,7.5,7.3, &
6799 13.5,13.2,12.5,11.1,10.4,9.7,8.2,7.8,7.4,6.8, &
6800 10.8,10.9,11.0,10.4,10.0,9.6,7.9,7.5,7.0,6.7, &
6801 7.3,7.5,7.8,8.5,9.0,8.5,7.7,7.4,6.9,6.5, &
6802 4.1,4.5,5.3,6.2,7.3,7.7,7.3,7.0,6.6,6.4, &
6803 1.8,2.0,2.2,3.8,4.3,5.6,6.2,6.2,6.4,6.2, &
6804 .30,.50,.60,1.5,2.8,3.7,4.5,4.7,5.5,5.6, &
6805 .09,.10,.15,.60,1.2,2.1,3.0,3.5,4.0,4.3, &
6806 .06,.08,.10,.30,.60,1.1,1.9,2.2,2.9,3.0, &
6807 .04,.05,.06,.15,.45,.60,1.1,1.3,1.6,1.8, &
6808 .04,.04,.04,.08,.20,.30,.55,.60,.75,.90, &
6809 .04,.04,.04,.05,.06,.10,.12,.15,.20,.25, &
6810 .04,.04,.03,.04,.05,.06,.07,.07,.07,.08, &
6811 .03,.03,.04,.05,.05,.05,.05,.05,.05,.05, &
6812 .03,.03,.03,.04,.04,.04,.05,.05,.04,.04, &
6813 .02,.02,.02,.04,.04,.04,.04,.04,.03,.03/
6814 DATA O3LO4/ &
6815 14.2,13.8,13.2,12.5,11.7,10.5,8.6,7.8,7.5,6.6, &
6816 12.5,12.4,12.2,11.7,10.8,9.8,7.8,7.2,6.5,6.1, &
6817 10.6,10.5,10.4,10.1,9.6,9.0,7.1,6.8,6.1,5.9, &
6818 7.0,7.4,7.9,7.8,7.6,7.3,6.2,6.1,5.8,5.6, &
6819 4.2,4.6,5.1,5.6,5.9,5.9,5.9,5.8,5.6,5.3, &
6820 2.1,2.3,2.6,2.9,3.5,4.3,4.8,4.9,5.1,5.1, &
6821 0.7,0.8,1.0,1.5,2.0,2.8,3.5,3.6,3.7,4.0, &
6822 .15,.20,.40,.50,.60,1.4,2.1,2.2,2.3,2.5, &
6823 .08,.10,.15,.25,.30,.90,1.2,1.3,1.4,1.6, &
6824 .07,.08,.10,.14,.20,.50,.70,.90,.90,.80, &
6825 .05,.06,.08,.12,.14,.20,.35,.40,.60,.50, &
6826 .05,.05,.08,.09,.09,.09,.11,.12,.15,.18, &
6827 .04,.05,.06,.07,.07,.08,.08,.08,.08,.08, &
6828 .04,.04,.05,.07,.07,.07,.07,.07,.06,.05, &
6829 .02,.02,.04,.05,.05,.05,.05,.05,.04,.04, &
6830 .02,.02,.03,.04,.04,.04,.04,.04,.03,.03/
6831 !----------------------------------------------------------------------
6832 !***
6833 !*** COMPUTE DETAILED O3 PROFILE FROM THE ORIGINAL GFDL PRESSURES
6834 !*** WHERE OUTPUT FROM O3INT (PSTD) IS TOP DOWN IN MB*1.E3
6835 !*** AND PSFC=1013.25 MB ......K.A.C. DEC94
6836 !***
6837 DO K=1,NK
6838 ! PH(K)=PH(K)*1013250.
6839 ! P(K)=P(K)*1013250.
6840 PH(K)=PYY(K)*1013250. ! fix for nesting
6841 P(K)=PXX(K)*1013250. ! fix for nesting
6842 ENDDO
6843 !
6844 ! PH(NKP)=PH(NKP)*1013250.
6845 PH(NKP)=PYY(NKP)*1013250. ! fix for nesting
6846 !
6847 DO K=1,NL
6848 PSTD(K)=P(K)
6849 ENDDO
6850 !
6851 DO K=1,25
6852 DO N=1,10
6853 RO31(N,K)=O3HI(N,K)
6854 RO32(N,K)=O3HI(N,K)
6855 ENDDO
6856 ENDDO
6857 !----------------------------------------------------------------------
6858 DO 100 NCASE=1,4
6859 !
6860 !*** NCASE=1: SPRING (IN N.H.)
6861 !*** NCASE=2: FALL (IN N.H.)
6862 !*** NCASE=3: WINTER (IN N.H.)
6863 !*** NCASE=4: SUMMER (IN N.H.)
6864 !
6865 IPLACE=2
6866 IF(NCASE.EQ.2)IPLACE=4
6867 IF(NCASE.EQ.3)IPLACE=1
6868 IF(NCASE.EQ.4)IPLACE=3
6869 !
6870 IF(NCASE.EQ.1.OR.NCASE.EQ.2)THEN
6871 DO K=26,41
6872 DO N=1,10
6873 RO31(N,K)=O3LO1(N,K-25)
6874 RO32(N,K)=O3LO2(N,K-25)
6875 ENDDO
6876 ENDDO
6877 ENDIF
6878 !
6879 IF(NCASE.EQ.3.OR.NCASE.EQ.4)THEN
6880 DO K=26,41
6881 DO N=1,10
6882 RO31(N,K)=O3LO3(N,K-25)
6883 RO32(N,K)=O3LO4(N,K-25)
6884 ENDDO
6885 ENDDO
6886 ENDIF
6887 !
6888 DO 25 KK=1,NKK
6889 DO N=1,10
6890 DUO3N(N,KK)=RO31(11-N,KK)
6891 DUO3N(N+9,KK)=RO32(N,KK)
6892 ENDDO
6893 DUO3N(10,KK)=0.5*(RO31(1,KK)+RO32(1,KK))
6894 25 CONTINUE
6895 !
6896 !***FOR NCASE=2 OR NCASE=4,REVERSE LATITUDE ARRANGEMENT OF CORR. SEASON
6897 !
6898 IF(NCASE.EQ.2.OR.NCASE.EQ.4)THEN
6899 DO 50 KK=1,NKK
6900 DO N=1,19
6901 TEMPN(N)=DUO3N(20-N,KK)
6902 ENDDO
6903 DO N=1,19
6904 DUO3N(N,KK)=TEMPN(N)
6905 ENDDO
6906 50 CONTINUE
6907 ENDIF
6908 !
6909 !*** DUO3N NOW IS O3 PROFILE FOR APPROPRIATE SEASON AT STD PRESSURE
6910 !*** LEVELS
6911 !
6912 !*** BEGIN LATITUDE (10 DEG) LOOP
6913 !
6914 DO 75 N=1,19
6915 !
6916 DO KK=1,NKK
6917 RSTD(KK)=DUO3N(N,KK)
6918 ENDDO
6919 !
6920 NKM=NK-1
6921 NKMM=NK-3
6922 !***
6923 !*** BESSELS HALF-POINT INTERPOLATION FORMULA
6924 !***
6925 DO K=4,NKMM,2
6926 KI=K/2
6927 RDATA(K)=0.5*(RSTD(KI)+RSTD(KI+1))-(RSTD(KI+2)-RSTD(KI+1) &
6928 -RSTD(KI)+RSTD(KI-1))/16.
6929 ENDDO
6930 !
6931 RDATA(2)=0.5*(RSTD(2)+RSTD(1))
6932 RDATA(NKM)=0.5*(RSTD(NKK)+RSTD(NKK-1))
6933 !
6934 !*** PUT UNCHANGED DATA INTO NEW ARRAY
6935 !
6936 DO K=1,NK,2
6937 KQ=(K+1)/2
6938 RDATA(K)=RSTD(KQ)
6939 ENDDO
6940 !
6941 DO KK=1,NL
6942 DDUO3N(N,KK)=RDATA(KK)*.01
6943 ENDDO
6944 !
6945 75 CONTINUE
6946 !
6947 !*** END OF LATITUDE LOOP
6948 !
6949 !----------------------------------------------------------------------
6950 !***
6951 !*** CREATE 5 DEG OZONE QUANTITIES BY LINEAR INTERPOLATION OF
6952 !*** 10 DEG VALUES
6953 !***
6954 DO 90 KK=1,NL
6955 !
6956 DO N=1,19
6957 O35DEG(2*N-1,KK)=DDUO3N(N,KK)
6958 ENDDO
6959 !
6960 DO N=1,18
6961 O35DEG(2*N,KK)=0.5*(DDUO3N(N,KK)+DDUO3N(N+1,KK))
6962 ENDDO
6963 !
6964 90 CONTINUE
6965 !
6966 DO JJ=1,37
6967 DO KEN=1,NL
6968 O3O3(JJ,KEN,IPLACE)=O35DEG(JJ,KEN)
6969 ENDDO
6970 ENDDO
6971 !
6972 100 CONTINUE
6973 !----------------------------------------------------------------------
6974 !*** END OF LOOP OVER CASES
6975 !----------------------------------------------------------------------
6976 !***
6977 !*** AVERAGE CLIMATOLOGICAL VALUS OF O3 FROM 5 DEG LAT MEANS, SO THAT
6978 !*** TIME AND SPACE INTERPOLATION WILL WORK (SEE SUBR OZON2D)
6979 !***
6980 DO I=1,NLGTH
6981 AVG=0.25*(XRAD1(I)+XRAD2(I)+XRAD3(I)+XRAD4(I))
6982 A1=0.5*(XRAD2(I)-XRAD4(I))
6983 B1=0.5*(XRAD1(I)-XRAD3(I))
6984 B2=0.25*((XRAD1(I)+XRAD3(I))-(XRAD2(I)+XRAD4(I)))
6985
6986 ! XRAD1(I)=AVG
6987 ! XRAD2(I)=A1
6988 ! XRAD3(I)=B1
6989 ! XRAD4(I)=B2
6990
6991 iindex = 1+mod((I-1),37)
6992 jindex = 1+(I-1)/37
6993 XDUO3N(iindex,jindex)=AVG
6994 XDO3N2(iindex,jindex)=A1
6995 XDO3N3(iindex,jindex)=B1
6996 XDO3N4(iindex,jindex)=B2
6997 ENDDO
6998 !***
6999 !*** CONVERT GFDL PRESSURE (MICROBARS) TO PA
7000 !***
7001 DO N=1,NL
7002 PRGFDL(N)=PSTD(N)*1.E-1
7003 ENDDO
7004 !
7005 END SUBROUTINE O3CLIM
7006
7007 !---------------------------------------------------------------------
7008 SUBROUTINE TABLE
7009 ! (TABLE1,TABLE2,TABLE3,EM1,EM1WDE,EM3, &
7010 ! SOURCE,DSRCE )
7011 !---------------------------------------------------------------------
7012 IMPLICIT NONE
7013 !----------------------------------------------------------------------
7014
7015 !INTEGER, PARAMETER :: NBLY=15
7016 INTEGER, PARAMETER :: NB=12
7017 INTEGER, PARAMETER :: NBLX=47
7018 INTEGER , PARAMETER:: NBLW = 163
7019
7020 REAL,PARAMETER :: AMOLWT=28.9644
7021 REAL,PARAMETER :: CSUBP=1.00484E7
7022 REAL,PARAMETER :: DIFFCTR=1.66
7023 REAL,PARAMETER :: G=980.665
7024 REAL,PARAMETER :: GINV=1./G
7025 REAL,PARAMETER :: GRAVDR=980.0
7026 REAL,PARAMETER :: O3DIFCTR=1.90
7027 REAL,PARAMETER :: P0=1013250.
7028 REAL,PARAMETER :: P0INV=1./P0
7029 REAL,PARAMETER :: GP0INV=GINV*P0INV
7030 REAL,PARAMETER :: P0XZP2=202649.902
7031 REAL,PARAMETER :: P0XZP8=810600.098
7032 REAL,PARAMETER :: P0X2=2.*1013250.
7033 REAL,PARAMETER :: RADCON=8.427
7034 REAL,PARAMETER :: RADCON1=1./8.427
7035 REAL,PARAMETER :: RATCO2MW=1.519449738
7036 REAL,PARAMETER :: RATH2OMW=.622
7037 REAL,PARAMETER :: RGAS=8.3142E7
7038 REAL,PARAMETER :: RGASSP=8.31432E7
7039 REAL,PARAMETER :: SECPDA=8.64E4
7040 !
7041 !******THE FOLLOWING ARE MATHEMATICAL CONSTANTS*******
7042 ! ARRANGED IN DECREASING ORDER
7043 REAL,PARAMETER :: HUNDRED=100.
7044 REAL,PARAMETER :: HNINETY=90.
7045 REAL,PARAMETER :: HNINE=9.0
7046 REAL,PARAMETER :: SIXTY=60.
7047 REAL,PARAMETER :: FIFTY=50.
7048 REAL,PARAMETER :: TEN=10.
7049 REAL,PARAMETER :: EIGHT=8.
7050 REAL,PARAMETER :: FIVE=5.
7051 REAL,PARAMETER :: FOUR=4.
7052 REAL,PARAMETER :: THREE=3.
7053 REAL,PARAMETER :: TWO=2.
7054 REAL,PARAMETER :: ONE=1.
7055 REAL,PARAMETER :: HAF=0.5
7056 REAL,PARAMETER :: QUARTR=0.25
7057 REAL,PARAMETER :: ZERO=0.
7058 !
7059 !******FOLLOWING ARE POSITIVE FLOATING POINT CONSTANTS(H'S)
7060 ! ARRANGED IN DECREASING ORDER
7061 REAL,PARAMETER :: H83E26=8.3E26
7062 REAL,PARAMETER :: H71E26=7.1E26
7063 REAL,PARAMETER :: H1E15=1.E15
7064 REAL,PARAMETER :: H1E13=1.E13
7065 REAL,PARAMETER :: H1E11=1.E11
7066 REAL,PARAMETER :: H1E8=1.E8
7067 REAL,PARAMETER :: H2E6=2.0E6
7068 REAL,PARAMETER :: H1E6=1.0E6
7069 REAL,PARAMETER :: H69766E5=6.97667E5
7070 REAL,PARAMETER :: H4E5=4.E5
7071 REAL,PARAMETER :: H165E5=1.65E5
7072 REAL,PARAMETER :: H5725E4=57250.
7073 REAL,PARAMETER :: H488E4=48800.
7074 REAL,PARAMETER :: H1E4=1.E4
7075 REAL,PARAMETER :: H24E3=2400.
7076 REAL,PARAMETER :: H20788E3=2078.8
7077 REAL,PARAMETER :: H2075E3=2075.
7078 REAL,PARAMETER :: H18E3=1800.
7079 REAL,PARAMETER :: H1224E3=1224.
7080 REAL,PARAMETER :: H67390E2=673.9057
7081 REAL,PARAMETER :: H5E2=500.
7082 REAL,PARAMETER :: H3082E2=308.2
7083 REAL,PARAMETER :: H3E2=300.
7084 REAL,PARAMETER :: H2945E2=294.5
7085 REAL,PARAMETER :: H29316E2=293.16
7086 REAL,PARAMETER :: H26E2=260.0
7087 REAL,PARAMETER :: H25E2=250.
7088 REAL,PARAMETER :: H23E2=230.
7089 REAL,PARAMETER :: H2E2=200.0
7090 REAL,PARAMETER :: H15E2=150.
7091 REAL,PARAMETER :: H1386E2=138.6
7092 REAL,PARAMETER :: H1036E2=103.6
7093 REAL,PARAMETER :: H8121E1=81.21
7094 REAL,PARAMETER :: H35E1=35.
7095 REAL,PARAMETER :: H3116E1=31.16
7096 REAL,PARAMETER :: H28E1=28.
7097 REAL,PARAMETER :: H181E1=18.1
7098 REAL,PARAMETER :: H18E1=18.
7099 REAL,PARAMETER :: H161E1=16.1
7100 REAL,PARAMETER :: H16E1=16.
7101 REAL,PARAMETER :: H1226E1=12.26
7102 REAL,PARAMETER :: H9P94=9.94
7103 REAL,PARAMETER :: H6P08108=6.081081081
7104 REAL,PARAMETER :: H3P6=3.6
7105 REAL,PARAMETER :: H3P5=3.5
7106 REAL,PARAMETER :: H2P9=2.9
7107 REAL,PARAMETER :: H2P8=2.8
7108 REAL,PARAMETER :: H2P5=2.5
7109 REAL,PARAMETER :: H1P8=1.8
7110 REAL,PARAMETER :: H1P4387=1.4387
7111 REAL,PARAMETER :: H1P41819=1.418191
7112 REAL,PARAMETER :: H1P4=1.4
7113 REAL,PARAMETER :: H1P25892=1.258925411
7114 REAL,PARAMETER :: H1P082=1.082
7115 REAL,PARAMETER :: HP816=0.816
7116 REAL,PARAMETER :: HP805=0.805
7117 REAL,PARAMETER :: HP8=0.8
7118 REAL,PARAMETER :: HP60241=0.60241
7119 REAL,PARAMETER :: HP602409=0.60240964
7120 REAL,PARAMETER :: HP6=0.6
7121 REAL,PARAMETER :: HP526315=0.52631579
7122 REAL,PARAMETER :: HP518=0.518
7123 REAL,PARAMETER :: HP5048=0.5048
7124 REAL,PARAMETER :: HP3795=0.3795
7125 REAL,PARAMETER :: HP369=0.369
7126 REAL,PARAMETER :: HP26=0.26
7127 REAL,PARAMETER :: HP228=0.228
7128 REAL,PARAMETER :: HP219=0.219
7129 REAL,PARAMETER :: HP166666=.166666
7130 REAL,PARAMETER :: HP144=0.144
7131 REAL,PARAMETER :: HP118666=0.118666192
7132 REAL,PARAMETER :: HP1=0.1
7133 ! (NEGATIVE EXPONENTIALS BEGIN HERE)
7134 REAL,PARAMETER :: H658M2=0.0658
7135 REAL,PARAMETER :: H625M2=0.0625
7136 REAL,PARAMETER :: H44871M2=4.4871E-2
7137 REAL,PARAMETER :: H44194M2=.044194
7138 REAL,PARAMETER :: H42M2=0.042
7139 REAL,PARAMETER :: H41666M2=0.0416666
7140 REAL,PARAMETER :: H28571M2=.02857142857
7141 REAL,PARAMETER :: H2118M2=0.02118
7142 REAL,PARAMETER :: H129M2=0.0129
7143 REAL,PARAMETER :: H1M2=.01
7144 REAL,PARAMETER :: H559M3=5.59E-3
7145 REAL,PARAMETER :: H3M3=0.003
7146 REAL,PARAMETER :: H235M3=2.35E-3
7147 REAL,PARAMETER :: H1M3=1.0E-3
7148 REAL,PARAMETER :: H987M4=9.87E-4
7149 REAL,PARAMETER :: H323M4=0.000323
7150 REAL,PARAMETER :: H3M4=0.0003
7151 REAL,PARAMETER :: H285M4=2.85E-4
7152 REAL,PARAMETER :: H1M4=0.0001
7153 REAL,PARAMETER :: H75826M4=7.58265E-4
7154 REAL,PARAMETER :: H6938M5=6.938E-5
7155 REAL,PARAMETER :: H394M5=3.94E-5
7156 REAL,PARAMETER :: H37412M5=3.7412E-5
7157 REAL,PARAMETER :: H15M5=1.5E-5
7158 REAL,PARAMETER :: H1439M5=1.439E-5
7159 REAL,PARAMETER :: H128M5=1.28E-5
7160 REAL,PARAMETER :: H102M5=1.02E-5
7161 REAL,PARAMETER :: H1M5=1.0E-5
7162 REAL,PARAMETER :: H7M6=7.E-6
7163 REAL,PARAMETER :: H4999M6=4.999E-6
7164 REAL,PARAMETER :: H451M6=4.51E-6
7165 REAL,PARAMETER :: H25452M6=2.5452E-6
7166 REAL,PARAMETER :: H1M6=1.E-6
7167 REAL,PARAMETER :: H391M7=3.91E-7
7168 REAL,PARAMETER :: H1174M7=1.174E-7
7169 REAL,PARAMETER :: H8725M8=8.725E-8
7170 REAL,PARAMETER :: H327M8=3.27E-8
7171 REAL,PARAMETER :: H257M8=2.57E-8
7172 REAL,PARAMETER :: H1M8=1.0E-8
7173 REAL,PARAMETER :: H23M10=2.3E-10
7174 REAL,PARAMETER :: H14M10=1.4E-10
7175 REAL,PARAMETER :: H11M10=1.1E-10
7176 REAL,PARAMETER :: H1M10=1.E-10
7177 REAL,PARAMETER :: H83M11=8.3E-11
7178 REAL,PARAMETER :: H82M11=8.2E-11
7179 REAL,PARAMETER :: H8M11=8.E-11
7180 REAL,PARAMETER :: H77M11=7.7E-11
7181 REAL,PARAMETER :: H72M11=7.2E-11
7182 REAL,PARAMETER :: H53M11=5.3E-11
7183 REAL,PARAMETER :: H48M11=4.8E-11
7184 REAL,PARAMETER :: H44M11=4.4E-11
7185 REAL,PARAMETER :: H42M11=4.2E-11
7186 REAL,PARAMETER :: H37M11=3.7E-11
7187 REAL,PARAMETER :: H35M11=3.5E-11
7188 REAL,PARAMETER :: H32M11=3.2E-11
7189 REAL,PARAMETER :: H3M11=3.0E-11
7190 REAL,PARAMETER :: H28M11=2.8E-11
7191 REAL,PARAMETER :: H24M11=2.4E-11
7192 REAL,PARAMETER :: H23M11=2.3E-11
7193 REAL,PARAMETER :: H2M11=2.E-11
7194 REAL,PARAMETER :: H18M11=1.8E-11
7195 REAL,PARAMETER :: H15M11=1.5E-11
7196 REAL,PARAMETER :: H14M11=1.4E-11
7197 REAL,PARAMETER :: H114M11=1.14E-11
7198 REAL,PARAMETER :: H11M11=1.1E-11
7199 REAL,PARAMETER :: H1M11=1.E-11
7200 REAL,PARAMETER :: H96M12=9.6E-12
7201 REAL,PARAMETER :: H93M12=9.3E-12
7202 REAL,PARAMETER :: H77M12=7.7E-12
7203 REAL,PARAMETER :: H74M12=7.4E-12
7204 REAL,PARAMETER :: H65M12=6.5E-12
7205 REAL,PARAMETER :: H62M12=6.2E-12
7206 REAL,PARAMETER :: H6M12=6.E-12
7207 REAL,PARAMETER :: H45M12=4.5E-12
7208 REAL,PARAMETER :: H44M12=4.4E-12
7209 REAL,PARAMETER :: H4M12=4.E-12
7210 REAL,PARAMETER :: H38M12=3.8E-12
7211 REAL,PARAMETER :: H37M12=3.7E-12
7212 REAL,PARAMETER :: H3M12=3.E-12
7213 REAL,PARAMETER :: H29M12=2.9E-12
7214 REAL,PARAMETER :: H28M12=2.8E-12
7215 REAL,PARAMETER :: H24M12=2.4E-12
7216 REAL,PARAMETER :: H21M12=2.1E-12
7217 REAL,PARAMETER :: H16M12=1.6E-12
7218 REAL,PARAMETER :: H14M12=1.4E-12
7219 REAL,PARAMETER :: H12M12=1.2E-12
7220 REAL,PARAMETER :: H8M13=8.E-13
7221 REAL,PARAMETER :: H46M13=4.6E-13
7222 REAL,PARAMETER :: H36M13=3.6E-13
7223 REAL,PARAMETER :: H135M13=1.35E-13
7224 REAL,PARAMETER :: H12M13=1.2E-13
7225 REAL,PARAMETER :: H1M13=1.E-13
7226 REAL,PARAMETER :: H3M14=3.E-14
7227 REAL,PARAMETER :: H15M14=1.5E-14
7228 REAL,PARAMETER :: H14M14=1.4E-14
7229 !
7230 !******FOLLOWING ARE NEGATIVE FLOATING POINT CONSTANTS (HM'S)
7231 ! ARRANGED IN DESCENDING ORDER
7232 REAL,PARAMETER :: HM2M2=-.02
7233 REAL,PARAMETER :: HM6666M2=-.066667
7234 REAL,PARAMETER :: HMP5=-0.5
7235 REAL,PARAMETER :: HMP575=-0.575
7236 REAL,PARAMETER :: HMP66667=-.66667
7237 REAL,PARAMETER :: HMP805=-0.805
7238 REAL,PARAMETER :: HM1EZ=-1.
7239 REAL,PARAMETER :: HM13EZ=-1.3
7240 REAL,PARAMETER :: HM19EZ=-1.9
7241 REAL,PARAMETER :: HM1E1=-10.
7242 REAL,PARAMETER :: HM1597E1=-15.97469413
7243 REAL,PARAMETER :: HM161E1=-16.1
7244 REAL,PARAMETER :: HM1797E1=-17.97469413
7245 REAL,PARAMETER :: HM181E1=-18.1
7246 REAL,PARAMETER :: HM8E1=-80.
7247 REAL,PARAMETER :: HM1E2=-100.
7248 !
7249 REAL,PARAMETER :: H1M16=1.0E-16
7250 REAL,PARAMETER :: H1M20=1.E-20
7251 REAL,PARAMETER :: HP98=0.98
7252 REAL,PARAMETER :: Q19001=19.001
7253 REAL,PARAMETER :: DAYSEC=1.1574E-5
7254 REAL,PARAMETER :: HSIGMA=5.673E-5
7255 REAL,PARAMETER :: TWENTY=20.0
7256 REAL,PARAMETER :: HP537=0.537
7257 REAL,PARAMETER :: HP2=0.2
7258 REAL,PARAMETER :: RCO2=3.3E-4
7259 REAL,PARAMETER :: H3M6=3.0E-6
7260 REAL,PARAMETER :: PI=3.1415927
7261 REAL,PARAMETER :: DEGRAD1=180.0/PI
7262 REAL,PARAMETER :: H74E1=74.0
7263 REAL,PARAMETER :: H15E1=15.0
7264
7265 REAL, PARAMETER:: B0 = -.51926410E-4
7266 REAL, PARAMETER:: B1 = -.18113332E-3
7267 REAL, PARAMETER:: B2 = -.10680132E-5
7268 REAL, PARAMETER:: B3 = -.67303519E-7
7269 REAL, PARAMETER:: AWIDE = 0.309801E+01
7270 REAL, PARAMETER:: BWIDE = 0.495357E-01
7271 REAL, PARAMETER:: BETAWD = 0.347839E+02
7272 REAL, PARAMETER:: BETINW = 0.766811E+01
7273
7274
7275 ! REAL, INTENT(OUT) :: EM1(28,180),EM1WDE(28,180),TABLE1(28,180), &
7276 ! TABLE2(28,180),TABLE3(28,180),EM3(28,180), &
7277 ! SOURCE(28,NBLY), DSRCE(28,NBLY)
7278
7279 !
7280 REAL :: ARNDM(NBLW),BRNDM(NBLW),BETAD(NBLW)
7281 REAL :: BANDLO(NBLW),BANDHI(NBLW)
7282
7283 INTEGER :: IBAND(40)
7284
7285 REAL :: BANDL1(64),BANDL2(64),BANDL3(35)
7286 REAL :: BANDH1(64),BANDH2(64),BANDH3(35)
7287 ! REAL :: AB15WD,SKO2D,SKC1R,SKO3R
7288
7289 ! REAL :: AWIDE,BWIDE,BETAWD,BETINW
7290
7291 ! DATA AWIDE / 0.309801E+01/
7292 ! DATA BWIDE / 0.495357E-01/
7293 ! DATA BETAWD / 0.347839E+02/
7294 ! DATA BETINW / 0.766811E+01/
7295
7296 !
7297 !% #NPADL = #PAGE*#NPAGE - 4*28*180 - 2*181 - 7*28 - 180 ;
7298 !% #NPADL = #NPADL - 11*28 - 2*180 - 2*30 ;
7299
7300 ! PARAMETER (NPADL = #NPADL - 28*NBLX - 2*28*NBLW - 7*NBLW)
7301
7302 REAL :: &
7303 SUM(28,180),PERTSM(28,180),SUM3(28,180), &
7304 SUMWDE(28,180),SRCWD(28,NBLX),SRC1NB(28,NBLW), &
7305 DBDTNB(28,NBLW)
7306 REAL :: &
7307 ZMASS(181),ZROOT(181),SC(28),DSC(28),XTEMV(28), &
7308 TFOUR(28),FORTCU(28),X(28),X1(28),X2(180),SRCS(28), &
7309 SUM4(28),SUM6(28),SUM7(28),SUM8(28),SUM4WD(28), &
7310 R1T(28),R2(28),S2(28),T3(28),R1WD(28)
7311 REAL :: EXPO(180),FAC(180)
7312 REAL :: CNUSB(30),DNUSB(30)
7313 REAL :: ALFANB(NBLW),AROTNB(NBLW)
7314 REAL :: ANB(NBLW),BNB(NBLW),CENTNB(NBLW),DELNB(NBLW), &
7315 BETANB(NBLW)
7316
7317 REAL :: AB15(2)
7318
7319 REAL :: ARNDM1(64),ARNDM2(64),ARNDM3(35)
7320 REAL :: BRNDM1(64),BRNDM2(64),BRNDM3(35)
7321 REAL :: BETAD1(64),BETAD2(64),BETAD3(35)
7322
7323 EQUIVALENCE (ARNDM1(1),ARNDM(1)),(ARNDM2(1),ARNDM(65)), &
7324 (ARNDM3(1),ARNDM(129))
7325 EQUIVALENCE (BRNDM1(1),BRNDM(1)),(BRNDM2(1),BRNDM(65)), &
7326 (BRNDM3(1),BRNDM(129))
7327 EQUIVALENCE (BETAD1(1),BETAD(1)),(BETAD2(1),BETAD(65)), &
7328 (BETAD3(1),BETAD(129))
7329
7330 !---------------------------------------------------------------
7331 REAL :: CENT,DEL,BDLO,BDHI,C1,ANU,tmp
7332 INTEGER :: N,I,ICNT,I1,I2E,I2
7333 INTEGER :: J,JP,NSUBDS,NSB,IA
7334
7335 !---------------------------------------------------------------
7336
7337 DATA IBAND / &
7338 2, 1, 2, 2, 1, 2, 1, 3, 2, 2, &
7339 3, 2, 2, 4, 2, 4, 2, 3, 3, 2, &
7340 4, 3, 4, 3, 7, 5, 6, 7, 6, 5, &
7341 7, 6, 7, 8, 6, 6, 8, 8, 8, 8/
7342
7343 DATA BANDL1 / &
7344 0.000000E+00, 0.100000E+02, 0.200000E+02, 0.300000E+02, &
7345 0.400000E+02, 0.500000E+02, 0.600000E+02, 0.700000E+02, &
7346 0.800000E+02, 0.900000E+02, 0.100000E+03, 0.110000E+03, &
7347 0.120000E+03, 0.130000E+03, 0.140000E+03, 0.150000E+03, &
7348 0.160000E+03, 0.170000E+03, 0.180000E+03, 0.190000E+03, &
7349 0.200000E+03, 0.210000E+03, 0.220000E+03, 0.230000E+03, &
7350 0.240000E+03, 0.250000E+03, 0.260000E+03, 0.270000E+03, &
7351 0.280000E+03, 0.290000E+03, 0.300000E+03, 0.310000E+03, &
7352 0.320000E+03, 0.330000E+03, 0.340000E+03, 0.350000E+03, &
7353 0.360000E+03, 0.370000E+03, 0.380000E+03, 0.390000E+03, &
7354 0.400000E+03, 0.410000E+03, 0.420000E+03, 0.430000E+03, &
7355 0.440000E+03, 0.450000E+03, 0.460000E+03, 0.470000E+03, &
7356 0.480000E+03, 0.490000E+03, 0.500000E+03, 0.510000E+03, &
7357 0.520000E+03, 0.530000E+03, 0.540000E+03, 0.550000E+03, &
7358 0.560000E+03, 0.670000E+03, 0.800000E+03, 0.900000E+03, &
7359 0.990000E+03, 0.107000E+04, 0.120000E+04, 0.121000E+04/
7360 DATA BANDL2 / &
7361 0.122000E+04, 0.123000E+04, 0.124000E+04, 0.125000E+04, &
7362 0.126000E+04, 0.127000E+04, 0.128000E+04, 0.129000E+04, &
7363 0.130000E+04, 0.131000E+04, 0.132000E+04, 0.133000E+04, &
7364 0.134000E+04, 0.135000E+04, 0.136000E+04, 0.137000E+04, &
7365 0.138000E+04, 0.139000E+04, 0.140000E+04, 0.141000E+04, &
7366 0.142000E+04, 0.143000E+04, 0.144000E+04, 0.145000E+04, &
7367 0.146000E+04, 0.147000E+04, 0.148000E+04, 0.149000E+04, &
7368 0.150000E+04, 0.151000E+04, 0.152000E+04, 0.153000E+04, &
7369 0.154000E+04, 0.155000E+04, 0.156000E+04, 0.157000E+04, &
7370 0.158000E+04, 0.159000E+04, 0.160000E+04, 0.161000E+04, &
7371 0.162000E+04, 0.163000E+04, 0.164000E+04, 0.165000E+04, &
7372 0.166000E+04, 0.167000E+04, 0.168000E+04, 0.169000E+04, &
7373 0.170000E+04, 0.171000E+04, 0.172000E+04, 0.173000E+04, &
7374 0.174000E+04, 0.175000E+04, 0.176000E+04, 0.177000E+04, &
7375 0.178000E+04, 0.179000E+04, 0.180000E+04, 0.181000E+04, &
7376 0.182000E+04, 0.183000E+04, 0.184000E+04, 0.185000E+04/
7377 DATA BANDL3 / &
7378 0.186000E+04, 0.187000E+04, 0.188000E+04, 0.189000E+04, &
7379 0.190000E+04, 0.191000E+04, 0.192000E+04, 0.193000E+04, &
7380 0.194000E+04, 0.195000E+04, 0.196000E+04, 0.197000E+04, &
7381 0.198000E+04, 0.199000E+04, 0.200000E+04, 0.201000E+04, &
7382 0.202000E+04, 0.203000E+04, 0.204000E+04, 0.205000E+04, &
7383 0.206000E+04, 0.207000E+04, 0.208000E+04, 0.209000E+04, &
7384 0.210000E+04, 0.211000E+04, 0.212000E+04, 0.213000E+04, &
7385 0.214000E+04, 0.215000E+04, 0.216000E+04, 0.217000E+04, &
7386 0.218000E+04, 0.219000E+04, 0.227000E+04/
7387
7388 DATA BANDH1 / &
7389 0.100000E+02, 0.200000E+02, 0.300000E+02, 0.400000E+02, &
7390 0.500000E+02, 0.600000E+02, 0.700000E+02, 0.800000E+02, &
7391 0.900000E+02, 0.100000E+03, 0.110000E+03, 0.120000E+03, &
7392 0.130000E+03, 0.140000E+03, 0.150000E+03, 0.160000E+03, &
7393 0.170000E+03, 0.180000E+03, 0.190000E+03, 0.200000E+03, &
7394 0.210000E+03, 0.220000E+03, 0.230000E+03, 0.240000E+03, &
7395 0.250000E+03, 0.260000E+03, 0.270000E+03, 0.280000E+03, &
7396 0.290000E+03, 0.300000E+03, 0.310000E+03, 0.320000E+03, &
7397 0.330000E+03, 0.340000E+03, 0.350000E+03, 0.360000E+03, &
7398 0.370000E+03, 0.380000E+03, 0.390000E+03, 0.400000E+03, &
7399 0.410000E+03, 0.420000E+03, 0.430000E+03, 0.440000E+03, &
7400 0.450000E+03, 0.460000E+03, 0.470000E+03, 0.480000E+03, &
7401 0.490000E+03, 0.500000E+03, 0.510000E+03, 0.520000E+03, &
7402 0.530000E+03, 0.540000E+03, 0.550000E+03, 0.560000E+03, &
7403 0.670000E+03, 0.800000E+03, 0.900000E+03, 0.990000E+03, &
7404 0.107000E+04, 0.120000E+04, 0.121000E+04, 0.122000E+04/
7405 DATA BANDH2 / &
7406 0.123000E+04, 0.124000E+04, 0.125000E+04, 0.126000E+04, &
7407 0.127000E+04, 0.128000E+04, 0.129000E+04, 0.130000E+04, &
7408 0.131000E+04, 0.132000E+04, 0.133000E+04, 0.134000E+04, &
7409 0.135000E+04, 0.136000E+04, 0.137000E+04, 0.138000E+04, &
7410 0.139000E+04, 0.140000E+04, 0.141000E+04, 0.142000E+04, &
7411 0.143000E+04, 0.144000E+04, 0.145000E+04, 0.146000E+04, &
7412 0.147000E+04, 0.148000E+04, 0.149000E+04, 0.150000E+04, &
7413 0.151000E+04, 0.152000E+04, 0.153000E+04, 0.154000E+04, &
7414 0.155000E+04, 0.156000E+04, 0.157000E+04, 0.158000E+04, &
7415 0.159000E+04, 0.160000E+04, 0.161000E+04, 0.162000E+04, &
7416 0.163000E+04, 0.164000E+04, 0.165000E+04, 0.166000E+04, &
7417 0.167000E+04, 0.168000E+04, 0.169000E+04, 0.170000E+04, &
7418 0.171000E+04, 0.172000E+04, 0.173000E+04, 0.174000E+04, &
7419 0.175000E+04, 0.176000E+04, 0.177000E+04, 0.178000E+04, &
7420 0.179000E+04, 0.180000E+04, 0.181000E+04, 0.182000E+04, &
7421 0.183000E+04, 0.184000E+04, 0.185000E+04, 0.186000E+04/
7422 DATA BANDH3 / &
7423 0.187000E+04, 0.188000E+04, 0.189000E+04, 0.190000E+04, &
7424 0.191000E+04, 0.192000E+04, 0.193000E+04, 0.194000E+04, &
7425 0.195000E+04, 0.196000E+04, 0.197000E+04, 0.198000E+04, &
7426 0.199000E+04, 0.200000E+04, 0.201000E+04, 0.202000E+04, &
7427 0.203000E+04, 0.204000E+04, 0.205000E+04, 0.206000E+04, &
7428 0.207000E+04, 0.208000E+04, 0.209000E+04, 0.210000E+04, &
7429 0.211000E+04, 0.212000E+04, 0.213000E+04, 0.214000E+04, &
7430 0.215000E+04, 0.216000E+04, 0.217000E+04, 0.218000E+04, &
7431 0.219000E+04, 0.220000E+04, 0.238000E+04/
7432
7433 !
7434 !***THE FOLLOWING DATA STATEMENTS ARE BAND PARAMETERS OBTAINED USING
7435 ! THE 1982 AFGL CATALOG ON THE SPECIFIED BANDS
7436 DATA ARNDM1 / &
7437 0.354693E+00, 0.269857E+03, 0.167062E+03, 0.201314E+04, &
7438 0.964533E+03, 0.547971E+04, 0.152933E+04, 0.599429E+04, &
7439 0.699329E+04, 0.856721E+04, 0.962489E+04, 0.233348E+04, &
7440 0.127091E+05, 0.104383E+05, 0.504249E+04, 0.181227E+05, &
7441 0.856480E+03, 0.136354E+05, 0.288635E+04, 0.170200E+04, &
7442 0.209761E+05, 0.126797E+04, 0.110096E+05, 0.336436E+03, &
7443 0.491663E+04, 0.863701E+04, 0.540389E+03, 0.439786E+04, &
7444 0.347836E+04, 0.130557E+03, 0.465332E+04, 0.253086E+03, &
7445 0.257387E+04, 0.488041E+03, 0.892991E+03, 0.117148E+04, &
7446 0.125880E+03, 0.458852E+03, 0.142975E+03, 0.446355E+03, &
7447 0.302887E+02, 0.394451E+03, 0.438112E+02, 0.348811E+02, &
7448 0.615503E+02, 0.143165E+03, 0.103958E+02, 0.725108E+02, &
7449 0.316628E+02, 0.946456E+01, 0.542675E+02, 0.351557E+02, &
7450 0.301797E+02, 0.381010E+01, 0.126319E+02, 0.548010E+01, &
7451 0.600199E+01, 0.640803E+00, 0.501549E-01, 0.167961E-01, &
7452 0.178110E-01, 0.170166E+00, 0.273514E-01, 0.983767E+00/
7453 DATA ARNDM2 / &
7454 0.753946E+00, 0.941763E-01, 0.970547E+00, 0.268862E+00, &
7455 0.564373E+01, 0.389794E+01, 0.310955E+01, 0.128235E+01, &
7456 0.196414E+01, 0.247113E+02, 0.593435E+01, 0.377552E+02, &
7457 0.305173E+02, 0.852479E+01, 0.116780E+03, 0.101490E+03, &
7458 0.138939E+03, 0.324228E+03, 0.683729E+02, 0.471304E+03, &
7459 0.159684E+03, 0.427101E+03, 0.114716E+03, 0.106190E+04, &
7460 0.294607E+03, 0.762948E+03, 0.333199E+03, 0.830645E+03, &
7461 0.162512E+04, 0.525676E+03, 0.137739E+04, 0.136252E+04, &
7462 0.147164E+04, 0.187196E+04, 0.131118E+04, 0.103975E+04, &
7463 0.621637E+01, 0.399459E+02, 0.950648E+02, 0.943161E+03, &
7464 0.526821E+03, 0.104150E+04, 0.905610E+03, 0.228142E+04, &
7465 0.806270E+03, 0.691845E+03, 0.155237E+04, 0.192241E+04, &
7466 0.991871E+03, 0.123907E+04, 0.457289E+02, 0.146146E+04, &
7467 0.319382E+03, 0.436074E+03, 0.374214E+03, 0.778217E+03, &
7468 0.140227E+03, 0.562540E+03, 0.682685E+02, 0.820292E+02, &
7469 0.178779E+03, 0.186150E+03, 0.383864E+03, 0.567416E+01/
7470 DATA ARNDM3 / &
7471 0.225129E+03, 0.473099E+01, 0.753149E+02, 0.233689E+02, &
7472 0.339802E+02, 0.108855E+03, 0.380016E+02, 0.151039E+01, &
7473 0.660346E+02, 0.370165E+01, 0.234169E+02, 0.440206E+00, &
7474 0.615283E+01, 0.304077E+02, 0.117769E+01, 0.125248E+02, &
7475 0.142652E+01, 0.241831E+00, 0.483721E+01, 0.226357E-01, &
7476 0.549835E+01, 0.597067E+00, 0.404553E+00, 0.143584E+01, &
7477 0.294291E+00, 0.466273E+00, 0.156048E+00, 0.656185E+00, &
7478 0.172727E+00, 0.118349E+00, 0.141598E+00, 0.588581E-01, &
7479 0.919409E-01, 0.155521E-01, 0.537083E-02/
7480 DATA BRNDM1 / &
7481 0.789571E-01, 0.920256E-01, 0.696960E-01, 0.245544E+00, &
7482 0.188503E+00, 0.266127E+00, 0.271371E+00, 0.330917E+00, &
7483 0.190424E+00, 0.224498E+00, 0.282517E+00, 0.130675E+00, &
7484 0.212579E+00, 0.227298E+00, 0.138585E+00, 0.187106E+00, &
7485 0.194527E+00, 0.177034E+00, 0.115902E+00, 0.118499E+00, &
7486 0.142848E+00, 0.216869E+00, 0.149848E+00, 0.971585E-01, &
7487 0.151532E+00, 0.865628E-01, 0.764246E-01, 0.100035E+00, &
7488 0.171133E+00, 0.134737E+00, 0.105173E+00, 0.860832E-01, &
7489 0.148921E+00, 0.869234E-01, 0.106018E+00, 0.184865E+00, &
7490 0.767454E-01, 0.108981E+00, 0.123094E+00, 0.177287E+00, &
7491 0.848146E-01, 0.119356E+00, 0.133829E+00, 0.954505E-01, &
7492 0.155405E+00, 0.164167E+00, 0.161390E+00, 0.113287E+00, &
7493 0.714720E-01, 0.741598E-01, 0.719590E-01, 0.140616E+00, &
7494 0.355356E-01, 0.832779E-01, 0.128680E+00, 0.983013E-01, &
7495 0.629660E-01, 0.643346E-01, 0.717082E-01, 0.629730E-01, &
7496 0.875182E-01, 0.857907E-01, 0.358808E+00, 0.178840E+00/
7497 DATA BRNDM2 / &
7498 0.254265E+00, 0.297901E+00, 0.153916E+00, 0.537774E+00, &
7499 0.267906E+00, 0.104254E+00, 0.400723E+00, 0.389670E+00, &
7500 0.263701E+00, 0.338116E+00, 0.351528E+00, 0.267764E+00, &
7501 0.186419E+00, 0.238237E+00, 0.210408E+00, 0.176869E+00, &
7502 0.114715E+00, 0.173299E+00, 0.967770E-01, 0.172565E+00, &
7503 0.162085E+00, 0.157782E+00, 0.886832E-01, 0.242999E+00, &
7504 0.760298E-01, 0.164248E+00, 0.221428E+00, 0.166799E+00, &
7505 0.312514E+00, 0.380600E+00, 0.353828E+00, 0.269500E+00, &
7506 0.254759E+00, 0.285408E+00, 0.159764E+00, 0.721058E-01, &
7507 0.170528E+00, 0.231595E+00, 0.307184E+00, 0.564136E-01, &
7508 0.159884E+00, 0.147907E+00, 0.185666E+00, 0.183567E+00, &
7509 0.182482E+00, 0.230650E+00, 0.175348E+00, 0.195978E+00, &
7510 0.255323E+00, 0.198517E+00, 0.195500E+00, 0.208356E+00, &
7511 0.309603E+00, 0.112011E+00, 0.102570E+00, 0.128276E+00, &
7512 0.168100E+00, 0.177836E+00, 0.105533E+00, 0.903330E-01, &
7513 0.126036E+00, 0.101430E+00, 0.124546E+00, 0.221406E+00/
7514 DATA BRNDM3 / &
7515 0.137509E+00, 0.911365E-01, 0.724508E-01, 0.795788E-01, &
7516 0.137411E+00, 0.549175E-01, 0.787714E-01, 0.165544E+00, &
7517 0.136484E+00, 0.146729E+00, 0.820496E-01, 0.846211E-01, &
7518 0.785821E-01, 0.122527E+00, 0.125359E+00, 0.101589E+00, &
7519 0.155756E+00, 0.189239E+00, 0.999086E-01, 0.480993E+00, &
7520 0.100233E+00, 0.153754E+00, 0.130780E+00, 0.136136E+00, &
7521 0.159353E+00, 0.156634E+00, 0.272265E+00, 0.186874E+00, &
7522 0.192090E+00, 0.135397E+00, 0.131497E+00, 0.127463E+00, &
7523 0.227233E+00, 0.190562E+00, 0.214005E+00/
7524 DATA BETAD1 / &
7525 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7526 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7527 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7528 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7529 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7530 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7531 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7532 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7533 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7534 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7535 0.234879E+03, 0.217419E+03, 0.201281E+03, 0.186364E+03, &
7536 0.172576E+03, 0.159831E+03, 0.148051E+03, 0.137163E+03, &
7537 0.127099E+03, 0.117796E+03, 0.109197E+03, 0.101249E+03, &
7538 0.939031E+02, 0.871127E+02, 0.808363E+02, 0.750349E+02, &
7539 0.497489E+02, 0.221212E+02, 0.113124E+02, 0.754174E+01, &
7540 0.589554E+01, 0.495227E+01, 0.000000E+00, 0.000000E+00/
7541 DATA BETAD2 / &
7542 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7543 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7544 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7545 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7546 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7547 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7548 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7549 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7550 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7551 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7552 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7553 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7554 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7555 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7556 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7557 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00/
7558 DATA BETAD3 / &
7559 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7560 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7561 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7562 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7563 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7564 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7565 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7566 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
7567 0.000000E+00, 0.000000E+00, 0.000000E+00/
7568 !---------------------------------------------------------------
7569 ! EQUIVALENCE (BANDL1(1),BANDLO(1)),(BANDL2(1),BANDLO(65)), &
7570 ! (BANDL3(1),BANDLO(129))
7571
7572 ! L = kme-1
7573 ! LP1 = L+1
7574 ! LP1V = LP1*(1+2*L/2)
7575 ! IMAX = ite
7576 ! LP2 = L + 2
7577
7578 DO I = 1,64
7579 BANDLO(I)=BANDL1(I)
7580 ENDDO
7581
7582 DO I = 65,128
7583 BANDLO(I)=BANDL2(I-64)
7584 ENDDO
7585
7586 DO I = 129,163
7587 BANDLO(I)=BANDL3(I-128)
7588 ENDDO
7589
7590 DO I = 1,64
7591 BANDHI(I)=BANDH1(I)
7592 ENDDO
7593
7594 DO I = 65,128
7595 BANDHI(I)=BANDH2(I-64)
7596 ENDDO
7597
7598 DO I = 129,163
7599 BANDHI(I)=BANDH3(I-128)
7600 ENDDO
7601
7602 !****************************************
7603 !***COMPUTE LOCAL QUANTITIES AND AO3,BO3,AB15
7604 !....FOR NARROW-BANDS...
7605 DO 101 N=1,NBLW
7606 ANB(N)=ARNDM(N)
7607 BNB(N)=BRNDM(N)
7608 CENTNB(N)=HAF*(BANDLO(N)+BANDHI(N))
7609 DELNB(N)=BANDHI(N)-BANDLO(N)
7610 BETANB(N)=BETAD(N)
7611 101 CONTINUE
7612 AB15(1)=ANB(57)*BNB(57)
7613 AB15(2)=ANB(58)*BNB(58)
7614 !....FOR WIDE BANDS...
7615 AB15WD=AWIDE*BWIDE
7616 !
7617 !***COMPUTE INDICES: IND,INDX2,KMAXV
7618 !SH ICNT=0
7619 !SH DO 113 I1=1,L
7620 !SH I2E=LP1-I1
7621 !SH DO 115 I2=1,I2E
7622 !SH ICNT=ICNT+1
7623 !SH INDX2(ICNT)=LP1*(I2-1)+LP2*I1
7624 !SH115 CONTINUE
7625 !SH113 CONTINUE
7626 !SH KMAXV(1)=1
7627 !SH DO 117 I=2,L
7628 !SH KMAXV(I)=KMAXV(I-1)+(LP2-I)
7629 117 CONTINUE
7630 !SH KMAXVM=KMAXV(L)
7631 !***COMPUTE RATIOS OF CONT. COEFFS
7632 SKC1R=BETAWD/BETINW
7633 SKO3R=BETAD(61)/BETINW
7634 SKO2D=ONE/BETINW
7635 !
7636 !****BEGIN TABLE COMPUTATIONS HERE***
7637 !***COMPUTE TEMPS, MASSES FOR TABLE ENTRIES
7638 !---NOTE: THE DIMENSIONING AND INITIALIZATION OF XTEMV AND OTHER ARRAYS
7639 ! WITH DIMENSION OF 28 IMPLY A RESTRICTION OF MODEL TEMPERATURES FROM
7640 ! 100K TO 370K.
7641 !---THE DIMENSIONING OF ZMASS,ZROOT AND OTHER ARRAYS WITH DIMENSION OF
7642 ! 180 IMPLY A RESTRICTION OF MODEL H2O AMOUNTS SUCH THAT OPTICAL PATHS
7643 ! ARE BETWEEN 10**-16 AND 10**2, IN CGS UNITS.
7644 ZMASS(1)=H1M16
7645 DO 201 J=1,180
7646 JP=J+1
7647 ZROOT(J)=SQRT(ZMASS(J))
7648 ZMASS(JP)=ZMASS(J)*H1P25892
7649 201 CONTINUE
7650 DO 203 I=1,28
7651 XTEMV(I)=HNINETY+TEN*I
7652 TFOUR(I)=XTEMV(I)*XTEMV(I)*XTEMV(I)*XTEMV(I)
7653 FORTCU(I)=FOUR*XTEMV(I)*XTEMV(I)*XTEMV(I)
7654 203 CONTINUE
7655 !******THE COMPUTATION OF SOURCE,DSRCE IS NEEDED ONLY
7656 ! FOR THE COMBINED WIDE-BAND CASE.TO OBTAIN THEM,THE SOURCE
7657 ! MUST BE COMPUTED FOR EACH OF THE (NBLX) WIDE BANDS(=SRCWD)
7658 ! THEN COMBINED (USING IBAND) INTO SOURCE.
7659 DO 205 N=1,NBLY
7660 DO 205 I=1,28
7661 SOURCE(I,N)=ZERO
7662 205 CONTINUE
7663 DO 207 N=1,NBLX
7664 DO 207 I=1,28
7665 SRCWD(I,N)=ZERO
7666 207 CONTINUE
7667 !---BEGIN FREQ. LOOP (ON N)
7668 DO 211 N=1,NBLX
7669 IF (N.LE.46) THEN
7670 !***THE 160-1200 BAND CASES
7671 CENT=CENTNB(N+16)
7672 DEL=DELNB(N+16)
7673 BDLO=BANDLO(N+16)
7674 BDHI=BANDHI(N+16)
7675 ENDIF
7676 IF (N.EQ.NBLX) THEN
7677 !***THE 2270-2380 BAND CASE
7678 CENT=CENTNB(NBLW)
7679 DEL=DELNB(NBLW)
7680 BDLO=BANDLO(NBLW)
7681 BDHI=BANDHI(NBLW)
7682 ENDIF
7683 !***FOR PURPOSES OF ACCURACY, ALL EVALUATIONS OF PLANCK FCTNS ARE MADE
7684 ! ON 10 CM-1 INTERVALS, THEN SUMMED INTO THE (NBLX) WIDE BANDS.
7685 NSUBDS=(DEL-H1M3)/10+1
7686 DO 213 NSB=1,NSUBDS
7687 IF (NSB.NE.NSUBDS) THEN
7688 CNUSB(NSB)=TEN*(NSB-1)+BDLO+FIVE
7689 DNUSB(NSB)=TEN
7690 ELSE
7691 CNUSB(NSB)=HAF*(TEN*(NSB-1)+BDLO+BDHI)
7692 DNUSB(NSB)=BDHI-(TEN*(NSB-1)+BDLO)
7693 ENDIF
7694 C1=(H37412M5)*CNUSB(NSB)**3
7695 !---BEGIN TEMP. LOOP (ON I)
7696 DO 215 I=1,28
7697 X(I)=H1P4387*CNUSB(NSB)/XTEMV(I)
7698 X1(I)=EXP(X(I))
7699 SRCS(I)=C1/(X1(I)-ONE)
7700 SRCWD(I,N)=SRCWD(I,N)+SRCS(I)*DNUSB(NSB)
7701 215 CONTINUE
7702 213 CONTINUE
7703 211 CONTINUE
7704 !***THE FOLLOWING LOOPS CREATE THE COMBINED WIDE BAND QUANTITIES SOURCE
7705 ! AND DSRCE
7706 DO 221 N=1,40
7707 DO 221 I=1,28
7708 SOURCE(I,IBAND(N))=SOURCE(I,IBAND(N))+SRCWD(I,N)
7709 221 CONTINUE
7710 DO 223 N=9,NBLY
7711 DO 223 I=1,28
7712 SOURCE(I,N)=SRCWD(I,N+32)
7713 223 CONTINUE
7714 DO 225 N=1,NBLY
7715 DO 225 I=1,27
7716 DSRCE(I,N)=(SOURCE(I+1,N)-SOURCE(I,N))*HP1
7717 225 CONTINUE
7718 DO 231 N=1,NBLW
7719 ALFANB(N)=BNB(N)*ANB(N)
7720 AROTNB(N)=SQRT(ALFANB(N))
7721 231 CONTINUE
7722 !***FIRST COMPUTE PLANCK FCTNS (SRC1NB) AND DERIVATIVES (DBDTNB) FOR
7723 ! USE IN TABLE EVALUATIONS. THESE ARE DIFFERENT FROM SOURCE,DSRCE
7724 ! BECAUSE DIFFERENT FREQUENCY PTS ARE USED IN EVALUATION, THE FREQ.
7725 ! RANGES ARE DIFFERENT, AND THE DERIVATIVE ALGORITHM IS DIFFERENT.
7726 !
7727 DO 301 N=1,NBLW
7728 CENT=CENTNB(N)
7729 DEL=DELNB(N)
7730 !---NOTE: AT PRESENT, THE IA LOOP IS ONLY USED FOR IA=2. THE LOOP STRUCT
7731 ! IS KEPT SO THAT IN THE FUTURE, WE MAY USE A QUADRATURE SCHEME FOR
7732 ! THE PLANCK FCTN EVALUATION, RATHER THAN USE THE MID-BAND FREQUENCY.
7733 #if 0
7734 DO 303 IA=1,3
7735 #else
7736 !jm -- getting floating point exceptions for IA=1, since 2 is only
7737 ! used anyway, I disabled the looping.
7738 DO 303 IA=2,2
7739 #endif
7740 ANU=CENT+HAF*(IA-2)*DEL
7741 C1=(H37412M5)*ANU*ANU*ANU+H1M20
7742 !---TEMPERATURE LOOP---
7743 DO 305 I=1,28
7744 X(I)=H1P4387*ANU/XTEMV(I)
7745 X1(I)=EXP(X(I))
7746 !#$ tmp=max((X1(I)-ONE),H1M20)
7747 !#$ SC(I)=C1/tmp
7748 SC(I)=C1/((X1(I)-ONE)+H1M20)
7749 !#$ DSC(I)=X(I)*SC(I)*SC(I)*X1(I)/(XTEMV(I)*C1)
7750 DSC(I)=SC(I)*SC(I)*X(I)*X1(I)/(XTEMV(I)*C1)
7751 305 CONTINUE
7752 IF (IA.EQ.2) THEN
7753 DO 307 I=1,28
7754 SRC1NB(I,N)=DEL*SC(I)
7755 DBDTNB(I,N)=DEL*DSC(I)
7756 307 CONTINUE
7757 ENDIF
7758 303 CONTINUE
7759 301 CONTINUE
7760 !***NEXT COMPUTE R1T,R2,S2,AND T3- COEFFICIENTS USED FOR E3 FUNCTION
7761 ! WHEN THE OPTICAL PATH IS LESS THAN 10-4. IN THIS CASE, WE ASSUME A
7762 ! DIFFERENT DEPENDENCE ON (ZMASS).
7763 !---ALSO OBTAIN R1WD, WHICH IS R1T SUMMED OVER THE 160-560 CM-1 RANGE
7764 DO 311 I=1,28
7765 SUM4(I)=ZERO
7766 SUM6(I)=ZERO
7767 SUM7(I)=ZERO
7768 SUM8(I)=ZERO
7769 SUM4WD(I)=ZERO
7770 311 CONTINUE
7771 DO 313 N=1,NBLW
7772 CENT=CENTNB(N)
7773 !***PERFORM SUMMATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1 FOR SUM4
7774 ! SUM6,SUM7,SUM8
7775 IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN
7776 DO 315 I=1,28
7777 SUM4(I)=SUM4(I)+SRC1NB(I,N)
7778 SUM6(I)=SUM6(I)+DBDTNB(I,N)
7779 SUM7(I)=SUM7(I)+DBDTNB(I,N)*AROTNB(N)
7780 SUM8(I)=SUM8(I)+DBDTNB(I,N)*ALFANB(N)
7781 315 CONTINUE
7782 ENDIF
7783 !***PERFORM SUMMATIONS OVER 160-560 CM-1 FREQ RANGE FOR E1 CALCS (SUM4WD
7784 IF (CENT.GT.160. .AND. CENT.LT.560.) THEN
7785 DO 316 I=1,28
7786 SUM4WD(I)=SUM4WD(I)+SRC1NB(I,N)
7787 316 CONTINUE
7788 ENDIF
7789 313 CONTINUE
7790 DO 317 I=1,28
7791 R1T(I)=SUM4(I)/TFOUR(I)
7792 R2(I)=SUM6(I)/FORTCU(I)
7793 S2(I)=SUM7(I)/FORTCU(I)
7794 T3(I)=SUM8(I)/FORTCU(I)
7795 R1WD(I)=SUM4WD(I)/TFOUR(I)
7796 317 CONTINUE
7797 DO 401 J=1,180
7798 DO 401 I=1,28
7799 SUM(I,J)=ZERO
7800 PERTSM(I,J)=ZERO
7801 SUM3(I,J)=ZERO
7802 SUMWDE(I,J)=ZERO
7803 401 CONTINUE
7804 !---FREQUENCY LOOP BEGINS---
7805 DO 411 N=1,NBLW
7806 CENT=CENTNB(N)
7807 !***PERFORM CALCULATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1
7808 IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN
7809 DO 413 J=1,180
7810 X2(J)=AROTNB(N)*ZROOT(J)
7811 EXPO(J)=EXP(-X2(J))
7812 413 CONTINUE
7813 DO 415 J=1,180
7814 IF (X2(J).GE.HUNDRED) THEN
7815 EXPO(J)=ZERO
7816 ENDIF
7817 415 CONTINUE
7818 DO 417 J=121,180
7819 FAC(J)=ZMASS(J)*(ONE-(ONE+X2(J))*EXPO(J))/(X2(J)*X2(J))
7820 417 CONTINUE
7821 DO 419 J=1,180
7822 DO 419 I=1,28
7823 SUM(I,J)=SUM(I,J)+SRC1NB(I,N)*EXPO(J)
7824 PERTSM(I,J)=PERTSM(I,J)+DBDTNB(I,N)*EXPO(J)
7825 419 CONTINUE
7826 DO 421 J=121,180
7827 DO 421 I=1,28
7828 SUM3(I,J)=SUM3(I,J)+DBDTNB(I,N)*FAC(J)
7829 421 CONTINUE
7830 ENDIF
7831 !---COMPUTE SUM OVER 160-560 CM-1 RANGE FOR USE IN E1 CALCS (SUMWDE)
7832 IF (CENT.GT.160. .AND. CENT.LT.560.) THEN
7833 DO 420 J=1,180
7834 DO 420 I=1,28
7835 SUMWDE(I,J)=SUMWDE(I,J)+SRC1NB(I,N)*EXPO(J)
7836 420 CONTINUE
7837 ENDIF
7838 411 CONTINUE
7839 DO 431 J=1,180
7840 DO 431 I=1,28
7841 EM1(I,J)=SUM(I,J)/TFOUR(I)
7842 TABLE1(I,J)=PERTSM(I,J)/FORTCU(I)
7843 431 CONTINUE
7844 DO 433 J=121,180
7845 DO 433 I=1,28
7846 EM3(I,J)=SUM3(I,J)/FORTCU(I)
7847 433 CONTINUE
7848 DO 441 J=1,179
7849 DO 441 I=1,28
7850 TABLE2(I,J)=(TABLE1(I,J+1)-TABLE1(I,J))*TEN
7851 441 CONTINUE
7852 DO 443 J=1,180
7853 DO 443 I=1,27
7854 TABLE3(I,J)=(TABLE1(I+1,J)-TABLE1(I,J))*HP1
7855 443 CONTINUE
7856 DO 445 I=1,28
7857 TABLE2(I,180)=ZERO
7858 445 CONTINUE
7859 DO 447 J=1,180
7860 TABLE3(28,J)=ZERO
7861 447 CONTINUE
7862 DO 449 J=1,2
7863 DO 449 I=1,28
7864 EM1(I,J)=R1T(I)
7865 449 CONTINUE
7866 DO 451 J=1,120
7867 DO 451 I=1,28
7868 EM3(I,J)=R2(I)/TWO-S2(I)*SQRT(ZMASS(J))/THREE+T3(I)*ZMASS(J)/EIGHT
7869 451 CONTINUE
7870 DO 453 J=121,180
7871 DO 453 I=1,28
7872 EM3(I,J)=EM3(I,J)/ZMASS(J)
7873 453 CONTINUE
7874 !***NOW COMPUTE E1 TABLES FOR 160-560 CM-1 BANDS ONLY.
7875 ! WE USE R1WD AND SUMWDE OBTAINED ABOVE.
7876 DO 501 J=1,180
7877 DO 501 I=1,28
7878 EM1WDE(I,J)=SUMWDE(I,J)/TFOUR(I)
7879 501 CONTINUE
7880 DO 503 J=1,2
7881 DO 503 I=1,28
7882 EM1WDE(I,J)=R1WD(I)
7883 503 CONTINUE
7884
7885 END SUBROUTINE TABLE
7886
7887 !---------------------------------------------------------------------
7888 SUBROUTINE SOLARD(IHRST,IDAY,MONTH,JULYR)
7889 !---------------------------------------------------------------------
7890 IMPLICIT NONE
7891 !---------------------------------------------------------------------
7892 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
7893 ! . . . .
7894 ! SUBPROGRAM: SOLARD COMPUTE THE SOLAR-EARTH DISTANCE
7895 ! PRGRMMR: Q.ZHAO ORG: W/NMC2 DATE: 96-7-23
7896 !
7897 ! ABSTRACT:
7898 ! SOLARD CALCULATES THE SOLAR-EARTH DISTANCE ON EACH DAY
7899 ! FOR USE IN SHORT-WAVE RADIATION.
7900 !
7901 ! PROGRAM HISTORY LOG:
7902 ! 96-07-23 Q.ZHAO - ORIGINATOR
7903 ! 98-10-09 Q.ZHAO - CHANGED TO USE IW3JDN IN W3LIB TO
7904 ! CALCULATE JD.
7905 ! 04-11-18 Y.-T. HOU - FIXED ERROR IN JULIAN DAY CALCULATION
7906 !
7907 ! USAGE: CALL SOLARD FROM SUBROUTINE INIT
7908 !
7909 ! INPUT ARGUMENT LIST:
7910 ! NONE
7911 !
7912 ! OUTPUT ARGUMENT LIST:
7913 ! R1 - THE NON-DIMENSIONAL DISTANCE BETWEEN SUN AND THE EARTH
7914 ! (LESS THAN 1.0 IN SUMMER AND LARGER THAN 1.0 IN WINTER).
7915 !
7916 ! INPUT FILES:
7917 ! NONE
7918 !
7919 ! OUTPUT FILES:
7920 ! NONE
7921 !
7922 ! SUBPROGRAMS CALLED:
7923 !
7924 ! UNIQUE: NONE
7925 !
7926 ! LIBRARY: IW3JDN
7927 !
7928 ! COMMON BLOCKS: CTLBLK
7929 !
7930 ! ATTRIBUTES:
7931 ! LANGUAGE: FORTRAN 90
7932 ! MACHINE : IBM SP
7933 !***********************************************************************
7934 REAL, PARAMETER :: PI=3.1415926,PI2=2.*PI
7935 !-----------------------------------------------------------------------
7936 ! INTEGER, INTENT(IN ) :: IHRST,IDAT(3)
7937 INTEGER, INTENT(IN ) :: IHRST,IDAY,MONTH,JULYR
7938 ! REAL , INTENT(OUT) :: R1
7939 !-----------------------------------------------------------------------
7940 INTEGER :: NDM(12),JYR19,JMN
7941 REAL :: CCR
7942
7943 DATA JYR19/1900/, JMN/0/, CCR/1.3E-6/
7944 DATA NDM/0,31,59,90,120,151,181,212,243,273,304,334/
7945
7946 !.....TPP = DAYS BETWEEN EPOCH AND PERIHELION PASSAGE OF 1900
7947 !.....JDOR1 = JD OF DECEMBER 30, 1899 AT 12 HOURS UT
7948 !.....JDOR2 = JD OF EPOCH WHICH IS JANUARY 0, 1990 AT 12 HOURS UT
7949 !
7950 REAL :: TPP
7951 DATA TPP/1.55/
7952
7953 INTEGER :: JDOR2,JDOR1
7954 DATA JDOR2/2415020/, JDOR1/2415019/
7955
7956 REAL :: DAYINC,DAT,T,YEAR,DATE,EM,E,EC,EP,CR,FJD,FJD1
7957 INTEGER :: JHR,JD,ITER
7958 !
7959 ! LIBRARY: IW3JDN
7960 !
7961 ! --------------------------------------------------------------------
7962 ! COMPUTES JULIAN DAY AND FRACTION FROM YEAR, MONTH, DAY AND TIME UT
7963 ! ACCURATE ONLY BETWEEN MARCH 1, 1900 AND FEBRUARY 28, 2100
7964 ! BASED ON JULIAN CALENDAR CORRECTED TO CORRESPOND TO GREGORIAN
7965 ! CALENDAR DURING THIS PERIOD
7966 ! --------------------------------------------------------------------
7967
7968 JHR=IHRST
7969 !
7970 JD=IDAY-32075 &
7971 +1461*(JULYR+4800+(MONTH-14)/12)/4 &
7972 +367*(MONTH-2-(MONTH-14)/12*12)/12 &
7973 -3*((JULYR+4900+(MONTH-14)/12)/100)/4
7974 IF(JHR.LT.12)THEN
7975 JD=JD-1
7976 FJD=.5+.041666667*REAL(JHR)+.00069444444*REAL(JMN)
7977 ELSE
7978 7 FJD=.041666667E0*FLOAT(JHR-12)+.00069444444E0*FLOAT(JMN)
7979 END IF
7980 DAYINC=JHR/24.0
7981 FJD1=JD+FJD+DAYINC
7982 JD=FJD1
7983 FJD=FJD1-JD
7984 !***
7985 !*** CALCULATE THE SOLAR-EARTH DISTANCE
7986 !***
7987 DAT=REAL(JD-JDOR2)-TPP+FJD
7988 !***
7989 ! COMPUTES TIME IN JULIAN CENTURIES AFTER EPOCH
7990 !***
7991 T=FLOAT(JD-JDOR2)/36525.E0
7992 !***
7993 ! COMPUTES LENGTH OF ANOMALISTIC AND TROPICAL YEARS (MINUS 365 DAYS)
7994 !***
7995 YEAR=.25964134E0+.304E-5*T
7996 !***
7997 ! COMPUTES ORBIT ECCENTRICITY FROM T
7998 !***
7999 EC=.01675104E0-(.418E-4+.126E-6*T)*T
8000 YEAR=YEAR+365.E0
8001 !***
8002 ! DATE=DAYS SINCE LAST PERIHELION PASSAGE
8003 !***
8004 DATE = MOD(DAT,YEAR)
8005 !***
8006 ! SOLVE ORBIT EQUATIONS BY NEWTON'S METHOD
8007 !***
8008 EM=PI2*DATE/YEAR
8009 E=1.E0
8010 ITER = 0
8011 31 EP=E-(E-EC*SIN(E)-EM)/(1.E0-EC*COS(E))
8012 CR=ABS(E-EP)
8013 E=EP
8014 ITER = ITER + 1
8015 IF(ITER.GT.10) GOTO 1031
8016 IF(CR.GT.CCR) GO TO 31
8017 1031 CONTINUE
8018 R1=1.E0-EC*COS(E)
8019 !
8020 WRITE(0,1000)JULYR,MONTH,IDAY,IHRST,R1
8021 1000 FORMAT('SUN-EARTH DISTANCE CALCULATION FINISHED IN SOLARD'/ &
8022 'YEAR=',I5,' MONTH=',I3,' DAY=',I3,' HOUR=' &
8023 , I3,' R1=',F9.4)
8024 !***
8025 ! RETURN TO RADTN
8026 !***
8027 END SUBROUTINE SOLARD
8028 !---------------------------------------------------------------------
8029 SUBROUTINE CAL_MON_DAY(JULDAY,julyr,Jmonth,Jday)
8030 !---------------------------------------------------------------------
8031 IMPLICIT NONE
8032 !-----------------------------------------------------------------------
8033 INTEGER, INTENT(IN) :: JULDAY,julyr
8034 INTEGER, INTENT(OUT) :: Jmonth,Jday
8035 LOGICAL :: LEAP,NOT_FIND_DATE
8036 INTEGER :: MONTH (12),itmpday,itmpmon,i
8037 !-----------------------------------------------------------------------
8038 DATA MONTH/31,28,31,30,31,30,31,31,30,31,30,31/
8039 !***********************************************************************
8040 NOT_FIND_DATE = .true.
8041
8042 itmpday = JULDAY
8043 itmpmon = 1
8044 LEAP=.FALSE.
8045 IF(MOD(julyr,4).EQ.0)THEN
8046 MONTH(2)=29
8047 LEAP=.TRUE.
8048 ENDIF
8049
8050 i = 1
8051 DO WHILE (NOT_FIND_DATE)
8052 IF(itmpday.GT.MONTH(i))THEN
8053 itmpday=itmpday-MONTH(i)
8054 ELSE
8055 Jday=itmpday
8056 Jmonth=i
8057 NOT_FIND_DATE = .false.
8058 ENDIF
8059 i = i+1
8060 END DO
8061
8062 END SUBROUTINE CAL_MON_DAY
8063 !!================================================================================
8064 ! CO2 initialization code
8065
8066 FUNCTION ANTEMP(L,Z)
8067 REAL :: ZB(10,7),C(11,7),DELTA(10,7),TSTAR(7)
8068 ! ************** TROPICAL SOUNDING **************************
8069 DATA (ZB(N,1),N=1,10)/ 2.0, 3.0, 16.5, 21.5, 45.0, &
8070 51.0, 70.0, 100., 200., 300./
8071 DATA (C(N,1),N=1,11)/ -6.0, -4.0, -6.7, 4.0, 2.2, &
8072 1.0, -2.8, -.27, 0.0, 0.0, 0.0/
8073 DATA (DELTA(N,1),N=1,10)/.5, .5, .3, .5, 1.0, &
8074 1.0, 1.0, 1.0, 1.0, 1.0/
8075 ! ************** SUB-TROPICAL SUMMER ************************
8076 DATA (ZB(N,2),N=1,10)/ 1.5, 6.5, 13.0, 18.0, 26.0, &
8077 36.0, 48.0, 50.0, 70.0, 100./
8078 DATA (C(N,2),N=1,11)/ -4.0, -6.0, -6.5, 0.0, 1.2, &
8079 2.2, 2.5, 0.0, -3.0, -0.25, 0.0/
8080 DATA (DELTA(N,2),N=1,10)/ .5, 1.0, .5, .5, 1.0, &
8081 1.0, 2.5, .5, 1.0, 1.0/
8082 ! ************** SUB-TROPICAL WINTER ************************
8083 DATA (ZB(N,3),N=1,10)/ 3.0, 10.0, 19.0, 25.0, 32.0, &
8084 44.5, 50.0, 71.0, 98.0, 200.0/
8085 DATA (C(N,3),N=1,11)/ -3.5, -6.0, -0.5, 0.0, 0.4, &
8086 3.2, 1.6, -1.8, -0.7, 0.0, 0.0/
8087 DATA (DELTA(N,3),N=1,10)/ .5, .5, 1.0, 1.0, 1.0, &
8088 1.0, 1.0, 1.0, 1.0, 1.0/
8089 ! ************* SUB-ARCTIC SUMMER *************************
8090 DATA (ZB(N,4),N=1,10)/ 4.7, 10.0, 23.0, 31.8, 44.0, &
8091 50.2, 69.2, 100.0, 102.0, 103.0/
8092 DATA (C(N,4),N=1,11)/ -5.3, -7.0, 0.0, 1.4, 3.0, &
8093 0.7, -3.3, -0.2, 0.0, 0.0, 0.0/
8094 DATA (DELTA(N,4),N=1,10)/ .5, .3, 1.0, 1.0, 2.0, &
8095 1.0, 1.5, 1.0, 1.0, 1.0/
8096 ! ************ SUB-ARCTIC WINTER *****************************
8097 DATA (ZB(N,5),N=1,10)/ 1.0, 3.2, 8.5, 15.5, 25.0, &
8098 30.0, 35.0, 50.0, 70.0, 100.0/
8099 DATA (C(N,5),N=1,11)/ 3.0, -3.2, -6.8, 0.0, -0.6, &
8100 1.0, 1.2, 2.5, -0.7, -1.2, 0.0/
8101 DATA (DELTA(N,5),N=1,10)/ .4, 1.5, .3 , .5, 1.0, &
8102 1.0, 1.0, 1.0, 1.0, 1.0/
8103 ! ************ US STANDARD 1976 ******************************
8104 DATA (ZB(N,6),N=1,10)/ 11.0, 20.0, 32.0, 47.0, 51.0, &
8105 71.0, 84.8520, 90.0, 91.0, 92.0/
8106 DATA (C(N,6),N=1,11)/ -6.5, 0.0, 1.0, 2.80, 0.0, &
8107 -2.80, -2.00, 0.0, 0.0, 0.0, 0.0/
8108 DATA (DELTA(N,6),N=1,10)/ 0.3, 1.0, 1.0, 1.0, 1.0, &
8109 1.0, 1.0, 1.0, 1.0, 1.0/
8110 !
8111 ! ************ ENLARGED US STANDARD 1976 **********************
8112 DATA (ZB(N,7),N=1,10)/ 11.0, 20.0, 32.0, 47.0, 51.0, &
8113 71.0, 84.8520, 90.0, 91.0, 92.0/
8114 DATA (C(N,7),N=1,11)/ -6.5, 0.0, 1.0, 2.80, 0.0, &
8115 -2.80, -2.00, 0.0, 0.0, 0.0, 0.0/
8116 DATA (DELTA(N,7),N=1,10)/ 0.3, 1.0, 1.0, 1.0, 1.0, &
8117 1.0, 1.0, 1.0, 1.0, 1.0/
8118 !
8119 DATA TSTAR/ 300.0, 294.0, 272.2, 287.0, 257.1, 2*288.15/
8120 !
8121 NLAST=10
8122 TEMP=TSTAR(L)+C(1,L)*Z
8123 DO 20 N=1,NLAST
8124 EXPO=(Z-ZB(N,L))/DELTA(N,L)
8125 EXPP=ZB(N,L)/DELTA(N,L)
8126 !JD single-precision change
8127 ! FAC=EXP(EXPP)+EXP(-EXPP)
8128 !mp write(6,*) '.........................................'
8129 !mp what in the hell does the next line do?
8130 !mp
8131 !mp apparently if statement <0 or =0 then 23, else 24
8132 !mp IF(ABS(EXPO)-100.0) 23,23,24
8133 !
8134 ! changed to a more reasonable value for the workstation
8135 !
8136 IF(ABS(EXPO)-50.0) 23,23,24
8137 23 X=EXP(EXPO)
8138 Y=X+1.0/X
8139 ZLOG=ALOG(Y)
8140 GO TO 25
8141 24 ZLOG=ABS(EXPO)
8142 !mp 25 IF(EXPP-100.0) 27,27,28
8143 25 IF(EXPP-50.0) 27,27,28
8144 !JD single-precision change
8145 27 FAC=EXP(EXPP)+EXP(-EXPP)
8146 FACLOG=ALOG(FAC)
8147 GO TO 29
8148 28 FACLOG=EXPP
8149 ! TEMP=TEMP+(C(N+1,L)-C(N,L))*0.5*(Z+DELTA(N,L)*
8150 ! 1 ALOG((EXP(EXPO)+EXP(-EXPO))/FAC))
8151 29 TEMP=TEMP+(C(N+1,L)-C(N,L))*0.5*(Z+DELTA(N,L)* &
8152 (ZLOG-FACLOG))
8153 !mp write(6,*) 'ANTEMP pieces (C,C,ZLOG,FACLOG)', C(N+1,L),C(N,L),
8154 !mp + ZLOG,FACLOG
8155 20 CONTINUE
8156 ANTEMP=TEMP
8157
8158 END FUNCTION ANTEMP
8159
8160 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCc
8161
8162 SUBROUTINE COEINT(RAT,IR)
8163 ! **********************************************************************
8164 !
8165 !
8166 ! THE TRANSMISSION FUNCTION BETWEEN P1 AND P2 IS ASSUMED TO
8167 ! THE FUNCTIONAL FORM
8168 ! TAU(P1,P2)= 1.0-SQRT(C*LOG(1.0+X*PATH)),
8169 ! WHERE
8170 ! PATH(P1,P2)=((P1-P2)**2)*(P1+P2+CORE)/
8171 ! (ETA*(P1+P2+CORE)+(P1-P2))
8172 !
8173 !
8174 ! THE PARAMETERS C AND X ARE FUNCTIONS OF P2, AND ARE TO BE DETER
8175 ! WHILE CORE IS A PRESPECIFIED NUMBER.ETA IS A FUNCTION OF THE TH
8176 ! PRODUCT (CX);IT IS OBTAITED ITERATIVELY. THE DERIVATION OF ALL
8177 ! VALUES WILL BE EXPLAINED IN A FORTHCOMING PAPER.
8178 ! SUBROUTINE COEINT DETERMINES C(I) AND X(I) BY USING THE ACT
8179 ! VALUES OF TAU(P(I-2),P(I)) AND TAU(P(I-1),P(I)) AND THE PREVIOU
8180 ! ITERATION VALUE OF ETA.
8181 ! DEFINE:
8182 ! PATHA=PATH(P(I),P(I-2),CORE,ETA)
8183 ! PATHB=PATH(P(I),P(I-1),CORE,ETA);
8184 ! THEN
8185 ! R=(1-TAU(P(I),P(I-2)))/(1-TAU(P(I),P(I-1)))
8186 ! = SQRT(LOG(1+X*PATHA)/LOG(1+X*PATHB)),
8187 ! SO THAT
8188 ! R**2= LOG(1+X*PATHA)/LOG(1+X*PATHB).
8189 ! THIS EQUATION CAN BE SOLVED BY NEWTON S METHOD FOR X AND THEN T
8190 ! RESULT USED TO FIND C. THIS IS REPEATED FOR EACH VALUE OF I GRE
8191 ! THAN 2 TO GIVE THE ARRAYS X(I) AND C(I).
8192 ! NEWTON S METHOD FOR SOLVING THE EQUATION
8193 ! F(X)=0
8194 ! MAKES USE OF THE LOOP XNEW= XOLD-F(XOLD)/FPRIME(XOLD).
8195 ! THIS IS ITERATED 20 TIMES, WHICH IS PROBABLY EXCESSIVE.
8196 ! THE FIRST GUESS FOR ETA IS 3.2E-4*EXP(-P(I)/1000),WHICH HAS
8197 ! BEEN FOUND TO BE FAIRLY REALISTIC BY EXPERIMENT; WE ITERATE 5 T
8198 ! (AGAIN,PROBABLY EXCESSIVELY) TO OBTAIN THE VALUES FOR C,X,ETA T
8199 ! USED FOR INTERPOLATION.
8200 ! THERE ARE SEVERAL POSSIBLE PITFALLS:
8201 ! 1) IN THE COURSE OF ITERATION, X MAY REACH A VALUE WHICH
8202 ! 1+X*PATHA NEGATIVE; IN THIS CASE THE ITERATION IS STOP
8203 ! AND AN ERROR MESSAGE IS PRINTED OUT.
8204 ! 2) EVEN IF (1) DOES NOT OCCUR, IT IS STILL POSSIBLE THAT
8205 ! BE NEGATIVE AND LARGE ENOUGH TO MAKE 1+X*PATH(P(I),0,C
8206 ! NEGATIVE. THIS IS CHECKED FOR IN A FINAL LOOP, AND IF
8207 ! A WARNING IS PRINTED OUT.
8208 !
8209 ! *********************************************************************
8210 !....
8211 ! IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8212 ! COMMON/PRESS/PA(109)
8213 REAL RAT,SINV
8214 ! REAL PA,CORE,TRANSA,PATH,UEXP,SEXP,ETA,SEXPV
8215 REAL PA2
8216 ! COMMON/TRAN/ TRANSA(109,109)
8217 ! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
8218 DIMENSION PATH0(109),ETAP(109),XAP(109),CAP(109)
8219 DIMENSION SINV(4)
8220 INTEGER :: IERR
8221 DATA SINV/2.74992,2.12731,4.38111,0.0832926/
8222 !NOV89 DIMENSION SINV(3)
8223 !NOV89 DATA SINV/2.74992,2.12731,4.38111/
8224 !O222 OLD CODE USED 2.7528 RATHER THAN 2.74992 ---K.A.C. OCTOBER 1988
8225 !O222 WHEN 2.7528 WAS USED,WE EXACTLY REPRODUCED THE MRF CO2 ARRAYS
8226 CORE=5.000
8227 UEXP=0.90
8228 ! P0=0.7
8229 DO 902 I=1,109
8230 PA2=PA(I)*PA(I)
8231 SEXPV(I)=.505+2.0E-5*PA(I)+.035*(PA2-.25)/(PA2+.25)
8232 902 CONTINUE
8233 DO 900 I=1,109
8234 ETA(I)=3.2E-4*EXP(-PA(I)/500.)
8235 ETAP(I)=ETA(I)
8236 900 CONTINUE
8237 DO 1200 NP=1,10
8238 DO 1000 I=3,109
8239 SEXP=SEXPV(I)
8240 R=(1.0D0-TRANSA(I,I-2))/(1.0D0-TRANSA(I,I-1))
8241 REXP=R**(UEXP/SEXP)
8242 arg1=path(pa(i),pa(i-2),core,eta(i))
8243 arg2=path(pa(i),pa(i-1),core,eta(i))
8244 PATHA=(PATH(PA(I),PA(I-2),CORE,ETA(I)))**UEXP
8245 PATHB=(PATH(PA(I),PA(I-1),CORE,ETA(I)))**UEXP
8246 XX=2.0D0*(PATHB*REXP-PATHA)/(PATHB*PATHB*REXP-PATHA*PATHA)
8247 DO 1010 LL=1,20
8248 F1=DLOG(1.0D0+XX*PATHA)
8249 F2=DLOG(1.0D0+XX*PATHB)
8250 F=F1/F2-REXP
8251 FPRIME=(F2*PATHA/(1.0D0+XX*PATHA)-F1*PATHB/(1.0D0+XX*PATHB))/ &
8252 (F2*F2)
8253 XX=XX-F/FPRIME
8254 CHECK=1.0D0+XX*PATHA
8255 !!!! IF (CHECK) 1020,1020,1025
8256 IF(CHECK.LE.0.)THEN
8257 WRITE(errmess,360)I,LL,CHECK
8258 WRITE(errmess,*)' xx=',xx,' patha=',patha
8259 360 FORMAT(' ERROR,I=',I3,'LL=',I3,'CHECK=',F20.10)
8260 CALL wrf_error_fatal ( errmess )
8261 ENDIF
8262 1010 CONTINUE
8263 CA(I)=(1.0D0-TRANSA(I,I-2))**(UEXP/SEXP)/ &
8264 (DLOG(1.0D0+XX*PATHA)+1.0D-20)
8265 XA(I)=XX
8266 1000 CONTINUE
8267 XA(2)=XA(3)
8268 XA(1)=XA(3)
8269 CA(2)=CA(3)
8270 CA(1)=CA(3)
8271 DO 1100 I=3,109
8272 PATH0(I)=(PATH(PA(I),0.,CORE,ETA(I)))**UEXP
8273 PATH0(I)=1.0D0+XA(I)*PATH0(I)
8274 !+++ IF (PATH0(I).LT.0.) WRITE (6,361) I,PATH0(I),XA(I)
8275 1100 CONTINUE
8276 DO 1035 I=1,109
8277 SEXP=SEXPV(I)
8278 ETAP(I)=ETA(I)
8279 ETA(I)=(SINV(IR)/RAT)**(1./SEXP)* &
8280 (CA(I)*XA(I))**(1./UEXP)
8281 1035 CONTINUE
8282 !
8283 ! THE ETA FORMULATION IS DETAILED IN SCHWARZKOPF AND FELS(1985).
8284 ! THE QUANTITY SINV=(G*DELTANU)/(RCO2*D*S)
8285 ! IN CGS UNITS,WITH D,THE DIFFUSICITY FACTOR=2, AND
8286 ! S,THE SUM OF CO2 LINE STRENGTHS OVER THE 15UM CO2 BAND
8287 ! ALSO,THE DENOMINATOR IS MULTIPLIED BY
8288 ! 1000 TO PERMIT USE OF MB UNITS FOR PRESSURE.
8289 ! S IS ACTUALLY WEIGHTED BY B(250) AT 10 CM-1 WIDE INTERVALS,IN
8290 ! ORDER TO BE CONSISTENT WITH THE METHODS USED TO OBTAIN THE LBL
8291 ! 1-BAND CONSOLIDATED TRANCMISSION FUNCTIONS.
8292 ! FOR THE 490-850 INTERVAL (DELTANU=360,IR=1) SINV=2.74992.
8293 ! (SLIGHTLY DIFFERENT FROM 2.7528 USED IN EARLIER VERSIONS)
8294 ! FOR THE 490-670 INTERVAL (IR=2) SINV=2.12731
8295 ! FOR THE 670-850 INTERVAL (IR=3) SINV=4.38111
8296 ! FOR THE 2270-2380 INTERVAL (IR=4) SINV=0.0832926
8297 ! SINV HAS BEEN OBTAINED USING THE 1982 AFGL CATALOG FOR CO2
8298 ! RAT IS THE ACTUAL CO2 MIXING RATIO IN UNITS OF 330 PPMV,
8299 ! LETTING USE OF THIS FORMULATION FOR ANY CO2 CONCENTRATION.
8300 !
8301 ! WRITE (6,366) (NP,I,CA(I),XA(I),ETA(I),SEXPV(I),I=1,109)
8302 !366 FORMAT (2I4,4E20.12)
8303 1200 CONTINUE
8304 361 FORMAT (' **WARNING:** 1+XA*PATH(PA(I),0) IS NEGATIVE,I= ',I3,/ &
8305 20X,'PATH0(I)=',F16.6,' XA(I)=',F16.6)
8306 RETURN
8307 END SUBROUTINE COEINT
8308
8309 !--------------
8310
8311
8312 !CCC PROGRAM CO2INS
8313 SUBROUTINE CO2INS(T22,T23,T66,IQ,L,LP1,iflag)
8314 ! *********************************************************
8315 ! SAVE DATA ON PERMANENT DATA SET DENOTED BY CO222 ******
8316 ! ..... K.CAMPANA MARCH 1988,OCTOBER 1988...
8317 ! ..... K.CAMPANA DECEMBER 1988-CLEANED UP FOR LAUNCHER
8318 ! ..... K.CAMPANA NOVEMBER 1989-ALTERED FOR NEW RADIATION
8319 ! *********************************************************
8320 DIMENSION T22(LP1,LP1,3),T23(LP1,LP1,3),T66(LP1,LP1,6)
8321 DIMENSION DCDT8(LP1,LP1),DCDT10(LP1,LP1),CO2PO(LP1,LP1), &
8322 CO2800(LP1,LP1),CO2PO1(LP1,LP1),CO2801(LP1,LP1),CO2PO2(LP1,LP1), &
8323 CO2802(LP1,LP1),N(LP1),D2CT8(LP1,LP1),D2CT10(LP1,LP1)
8324 !CC ITIN=22
8325 !CC ITIN1=23
8326 !O222 LATEST CODE HAD IQ=1
8327 !CC IQ=4
8328 1011 FORMAT (4F20.14)
8329 !CC READ (ITIN,1011) ((CO2PO(I,J),I=1,LP1),J=1,LP1)
8330 !CC READ (ITIN1,1011) ((CO2800(I,J),I=1,LP1),J=1,LP1)
8331 !CC READ (ITIN,1011) ((CO2PO1(I,J),I=1,LP1),J=1,LP1)
8332 !CC READ (ITIN1,1011) ((CO2801(I,J),I=1,LP1),J=1,LP1)
8333 !CC READ (ITIN,1011) ((CO2PO2(I,J),I=1,LP1),J=1,LP1)
8334 !CC READ (ITIN1,1011) ((CO2802(I,J),I=1,LP1),J=1,LP1)
8335 DO 300 J=1,LP1
8336 DO 300 I=1,LP1
8337 CO2PO(I,J) = T22(I,J,1)
8338 !NOV89
8339 IF (IQ.EQ.5) GO TO 300
8340 !NOV89
8341 CO2PO1(I,J) = T22(I,J,2)
8342 CO2PO2(I,J) = T22(I,J,3)
8343 300 CONTINUE
8344 DO 301 J=1,LP1
8345 DO 301 I=1,LP1
8346 CO2800(I,J) = T23(I,J,1)
8347 !NOV89
8348 IF (IQ.EQ.5) GO TO 301
8349 !NOV89
8350 CO2801(I,J) = T23(I,J,2)
8351 CO2802(I,J) = T23(I,J,3)
8352 301 CONTINUE
8353 !***THE FOLLOWING CODE IS REWRITTEN SO THAT THE RADIATIVE BANDS
8354 ! ARE:
8355 ! IQ=1 560-800 (CONSOL.=490-850)
8356 ! IQ=2 560-670 (CONSOL.=490-670)
8357 ! IQ=3 670-800 (CONSOL.=670-850)
8358 ! IQ=4 560-760 (ORIGINAL CODE) (CONSOL.=490-850)
8359 !NOV89
8360 ! IQ=5 2270-2380 (CONSOL.=2270-2380)
8361 !NOV89
8362 ! THE FOLLOWING LOOP OBTAINS TRANSMISSION FUNCTIONS FOR BANDS
8363 ! USED IN RADIATIVE MODEL CALCULATIONS,WITH THE EQUIVALENT
8364 ! WIDTHS KEPT FROM THE ORIGINAL CONSOLIDATED CO2 TF S.
8365 !NOV89
8366 ! NOTE: ALTHOUGH THE BAND TRANSMISSION FUNCTIONS ARE
8367 ! COMPUTED FOR ALL RADIATIVE BANDS, AS OF 9/28/88, THEY
8368 ! ARE WRITTEN OUT IN FULL ONLY FOR THE FULL 15 UM BAND CASES
8369 ! (IQ=1,4). IN OTHER CASES, THE TRANSMISSIVITIES (1,K) ARE
8370 ! WRITTEN OUT, AS THESE ARE THE ONLY ONES NEEDED FOR CTS
8371 ! CALCULATIONS. ALSO, FOR THE 4.3 UM BAND (IQ=5) THE TEMP.
8372 ! DERIVATIVE TERMS ARE NOT WRITTEN OUT, AS THEY ARE UNUSED.
8373 !NOV89
8374 IF (IQ.EQ.1) THEN
8375 C1=1.5
8376 C2x=0.5
8377 ENDIF
8378 IF (IQ.EQ.2) THEN
8379 C1=18./11.
8380 C2x=7./11.
8381 ENDIF
8382 IF (IQ.EQ.3) THEN
8383 C1=18./13.
8384 C2x=5./13.
8385 ENDIF
8386 IF (IQ.EQ.4) THEN
8387 C1=1.8
8388 C2x=0.8
8389 ENDIF
8390 !NOV89
8391 IF (IQ.EQ.5) THEN
8392 C1=1.0
8393 C2x=0.0
8394 ENDIF
8395 !NOV89
8396 DO 1021 I=1,LP1
8397 DO 1021 J=1,LP1
8398 CO2PO(J,I)=C1*CO2PO(J,I)-C2x
8399 CO2800(J,I)=C1*CO2800(J,I)-C2x
8400 !NOV89
8401 IF (IQ.EQ.5) GO TO 1021
8402 !NOV89
8403 CO2PO1(J,I)=C1*CO2PO1(J,I)-C2x
8404 CO2801(J,I)=C1*CO2801(J,I)-C2x
8405 CO2PO2(J,I)=C1*CO2PO2(J,I)-C2x
8406 CO2802(J,I)=C1*CO2802(J,I)-C2x
8407 1021 CONTINUE
8408 !NOV89
8409 IF (IQ.GE.1.AND.IQ.LE.4) THEN
8410 !NOV89
8411 DO 1 J=1,LP1
8412 DO 1 I=1,LP1
8413 DCDT8(I,J)=.02*(CO2801(I,J)-CO2802(I,J))*100.
8414 DCDT10(I,J)=.02*(CO2PO1(I,J)-CO2PO2(I,J))*100.
8415 D2CT8(I,J)=.0016*(CO2801(I,J)+CO2802(I,J)-2.*CO2800(I,J))*1000.
8416 D2CT10(I,J)=.0016*(CO2PO1(I,J)+CO2PO2(I,J)-2.*CO2PO(I,J))*1000.
8417 1 CONTINUE
8418 !NOV89
8419 ENDIF
8420 !NOV89
8421 !O222 *********************************************************
8422 !CC REWIND 66
8423 ! SAVE CDT51,CO251,C2D51,CDT58,CO258,C2D58..ON TEMPO FILE
8424 !CC WRITE (66) DCDT10
8425 !CC WRITE (66) CO2PO
8426 !CC WRITE (66) D2CT10
8427 !CC WRITE (66) DCDT8
8428 !CC WRITE (66) CO2800
8429 !CC WRITE (66) D2CT8
8430 !CC REWIND 66
8431 !NOV89
8432 IF (IQ.EQ.1.OR.IQ.EQ.4) THEN
8433 !NOV89
8434 DO 400 J=1,LP1
8435 DO 400 I=1,LP1
8436 T66(I,J,1) = DCDT10(I,J)
8437 T66(I,J,2) = CO2PO(I,J)
8438 T66(I,J,3) = D2CT10(I,J)
8439 T66(I,J,4) = DCDT8(I,J)
8440 T66(I,J,5) = CO2800(I,J)
8441 T66(I,J,6) = D2CT8(I,J)
8442 400 CONTINUE
8443 !NOV89
8444 ELSE
8445 DO 409 I=1,LP1
8446 T66(I,1,2) = CO2PO(1,I)
8447 T66(I,1,5) = CO2800(1,I)
8448 IF (IQ.EQ.5) GO TO 409
8449 T66(I,1,1) = DCDT10(1,I)
8450 T66(I,1,3) = D2CT10(1,I)
8451 T66(I,1,4) = DCDT8(1,I)
8452 T66(I,1,6) = D2CT8(1,I)
8453 409 CONTINUE
8454 ENDIF
8455 !NOV89
8456 !O222 *********************************************************
8457 RETURN
8458 END SUBROUTINE CO2INS
8459 !O222 PROGRAM CO2INT(INPUT,TAPE5=INPUT)
8460 !NOV89
8461 SUBROUTINE CO2INT(ITAPE,T15A,T15B,T22,RATIO,IR,NMETHD,NLEVLS,NLP1,NLP2)
8462 !NOV89
8463 ! *********************************************************
8464 ! CHANGES TO DATA READ AND FORMAT SEE CO222 ***
8465 ! ..... K.CAMPANA MARCH 1988,OCTOBER 1988
8466 ! CHANGES TO PASS ITAPE,AND IF IR=4,READ 1 CO2 REC..KAC NOV89
8467 ! *********************************************************
8468 ! CO2INT INTERPOLATES CARBON DIOXIDE TRANSMISSION FUNCTIONS
8469 ! FROM THE 109 LEVEL GRID,FOR WHICH THE TRANSMISSION FUNCTIONS
8470 ! HAVE BEEN PRE-CALCULATED, TO THE GRID STRUCTURE SPECIFIED BY THE
8471 ! USER.
8472 !
8473 ! METHOD:
8474 !
8475 ! CO2INT IS EMPLOYABLE FOR TWO PURPOSES: 1) TO OBTAIN TRANSMIS-
8476 ! SIVITIES BETWEEN ANY 2 OF AN ARRAY OF USER-DEFINED PRESSURES; AND
8477 ! 2) TO OBTAIN LAYER-MEAN TRANSMISSIVITIES BETWEEN ANY 2 OF AN ARRAY
8478 ! OF USER-DEFINED PRESSURE LAYERS.TO CLARIFY THESE TWO PURPOSES,SEE
8479 ! THE DIAGRAM AND DISCUSSION BELOW.
8480 ! CO2INT MAY BE USED TO EXECUTE ONLY ONE PURPOSE AT ONE TIME.
8481 !
8482 ! LET P BE AN ARRAY OF USER-DEFINED PRESSURES
8483 ! AND PD BE USER-DEFINED PRESSURE LAYERS.
8484 !
8485 ! - - - - - - - - - PD(I-1) ---
8486 ! ^
8487 ! ----------------- P(I) ^ PRESSURE LAYER I (PLM(I))
8488 ! ^
8489 ! - - - - - - - - - PD(I) ---
8490 ! ^
8491 ! ----------------- P(I+1) ^ PRESSURE LAYER I+1 (PLM(I+1))
8492 ! ^
8493 ! - - - - - - - - - PD(I+1)---
8494 ! ... (THE NOTATION USED IS
8495 ! ... CONSISTENT WITH THE CODE)
8496 ! ...
8497 ! - - - - - - - - - PD(J-1)
8498 !
8499 ! ----------------- P(J)
8500 !
8501 ! - - - - - - - - - PD(J)
8502 !
8503 ! PURPOSE 1: THE TRANSMISSIVITY BETWEEN SPECIFIC PRESSURES
8504 ! P(I) AND P(J) ,TAU(P(I),P(J)) IS COMPUTED BY THIS PROGRAM.
8505 ! IN THIS MODE,THERE IS NO REFERENCE TO LAYER PRESSURES PD
8506 ! (PD,PLM ARE NOT INPUTTED).
8507 !
8508 ! PURPOSE 2: THE LAYER-MEAN TRANSMISSIVITY BETWEEN A LAYER-
8509 ! MEAN PRESSURE PLM(J) AND PRESSURE LAYER I IS GIVEN BY
8510 ! TAULM(PLM(I),PLM(J)). IT IS COMPUTED BY THE INTEGRAL
8511 !
8512 ! PD(I)
8513 ! ----
8514 ! 1 ^
8515 ! ------------- * ^ TAU ( P',PLM(J) ) DP'
8516 ! PD(I)-PD(I-1) ^
8517 ! ----
8518 ! PD(I-1)
8519 !
8520 ! THE LAYER-MEAN PRESSURE PLM(I) IS SPECIFIED BY THE USER.
8521 ! FOR MANY PURPOSES,PLM WILL BE CHOSEN TO BE THE AVERAGE
8522 ! PRESSURE IN THE LAYER-IE,PLM(I)=0.5*(PD(I-1)+PD(I)).
8523 ! FOR LAYER-MEAN TRANSMISSIVITIES,THE USER THUS INPUTS
8524 ! A PRESSURE ARRAY (PD) DEFINING THE PRESSURE LAYERS AND AN
8525 ! ARRAY (PLM) DEFINING THE LAYER-MEAN PRESSURES.THE CALCULATION
8526 ! DOES NOT DEPEND ON THE P ARRAY USED FOR PURPOSE 1 (P IS NOT
8527 ! INPUTTED).
8528 !
8529 ! THE FOLLOWING PARAGRAPHS DEPICT THE UTILIZATION OF THIS
8530 ! CODE WHEN USED TO COMPUTE TRANSMISSIVITIES BETWEEN SPECIFIC
8531 ! PRESSURES. LATER PARAGRAPHS DESCRIBE ADDITIONAL FEATURES NEEDED
8532 ! FOR LAYER-MEAN TRANSMISSIVITIES.
8533 !
8534 ! FOR A GIVEN CO2 MIXING RATIO AND STANDARD TEMPERATURE
8535 ! PROFILE,A TABLE OF TRANSMISSION FUNCTIONS FOR A FIXED GRID
8536 ! OF ATMOSPHERIC PRESSURES HAS BEEN PRE-CALCULATED.
8537 ! THE STANDARD TEMPERATURE PROFILE IS COMPUTED FROM THE US
8538 ! STANDARD ATMOSPHERE (1977) TABLE.ADDITIONALLY, THE
8539 ! SAME TRANSMISSION FUNCTIONS HAVE BEEN PRE-CALCULATED FOR A
8540 ! TEMPERATURE PROFILE INCREASED AND DECREASED (AT ALL LEVELS)
8541 ! BY 25 DEGREES.
8542 ! THIS PROGRAM READS IN THE PRESPECIFIED TRANSMISSION FUNCTIONS
8543 ! AND A USER-SUPPLIED PRESSURE GRID (P(I)) AND CALCULATES TRANS-
8544 ! MISSION FUNCTIONS ,TAU(P(I),P(J)), FOR ALL P(I) S AND P(J) S.
8545 ! A LOGARITHMIC INTERPOLATION SCHEME IS USED.
8546 ! THIS METHOD IS REPEATED FOR THE THREE TEMPERATURE PROFILES
8547 ! GIVEN ABOVE .THEREFORE OUTPUTS FROM THE PROGRAM ARE THREE TABLES
8548 ! OF TRANSMISSION FUNCTIONS FOR THE USER-SUPPLIED PRESSURE GRID.
8549 ! THE EXISTENCE OF THE THREE TABLES PERMITS SUBSEQUENT INTERPO-
8550 ! LATION TO A USER-SUPPLIED TEMPERATURE PROFILE USING THE METHOD
8551 ! DESCRIBED IN THE REFERENCE.SEE LIMITATIONS SECTION IF THE
8552 ! USER DESIRES TO OBTAIN ONLY 1 TABLE OF TRANSMISSIVITIES.
8553 !
8554 ! MODIFICATIONS FOR LAYER-MEAN TRANSMISSIVITIES:
8555 ! THE PRESSURES INPUTTED ARE THE LAYER-MEAN PRESSURES,PD,
8556 ! AND THE LAYER-MEAN PRESSURES ,PLM. A SERIES OF TRANSMISSIVITIES
8557 ! (TAU(P'',PLM(J)) ARE COMPUTED AND THE INTEGRAL GIVEN IN THE
8558 ! DISCUSSION OF PURPOSE 2 IS COMPUTED.FOR PLM(I) NOT EQUAL TO
8559 ! PLM(J) SIMPSON S RULE IS USED WITH 5 POINTS. IF PLM(I)=PLM(J)
8560 ! (THE -NEARBY LAYER- CASE) A 49-POINT QUADRATURE IS USED FOR
8561 ! GREATER ACCURACY.THE OUTPUT IS IN TAULM(PLM(I),PLM(J)).
8562 ! NOTE:
8563 ! TAULM IS NOT A SYMMETRICAL MATRIX. FOR THE ARRAY ELEMENT
8564 ! TAULM(PLM(I),PLM(J)),THE INNER(FIRST,MOST RAPIDLY VARYING)
8565 ! DIMENSION IS THE VARYING LAYER-MEAN PRESSURE,PLM(I);THE OUTER
8566 ! (SECOND) DIMENSION IS THE FIXED LAYER-MEAN PRESSURE PLM(J).
8567 ! THUS THE ELEMENT TAULM(2,3) IS THE TRANSMISSION FUNCTION BETWEEN
8568 ! THE FIXED PRESSURE PLM(3) AND THE PRESSURE LAYER HAVING AN AVERAG
8569 ! PRESSURE OF PLM(2).
8570 ! ALSO NOTE THAT NO QUADRATURE IS PERFORMED OVER THE LAYER
8571 ! BETWEEN THE SMALLEST NONZERO PRESSURE AND ZERO PRESSURE;
8572 ! TAULM IS TAULM(0,PLM(J)) IN THIS CASE,AND TAULM(0,0)=1.
8573 !
8574 !
8575 ! REFERENCE:
8576 ! S.B.FELS AND M.D.SCHWARZKOPF,-AN EFFICIENT ACCURATE
8577 ! ALGORITHM FOR CALCULATING CO2 15 UM BAND COOLING RATES-,JOURNAL
8578 ! OF GEOPHYSICAL RESEARCH,VOL.86,NO. C2, PP.1205-1232,1981.
8579 ! MODIFICATIONS TO THE ALGORITHM HAVE BEEN MADE BY THE AUTHORS;
8580 ! CONTACT S.B.F.OR M.D.S. FOR FURTHER DETAILS.A NOTE TO J.G.R.
8581 ! IS PLANNED TO DOCUMENT THESE CHANGES.
8582 !
8583 ! AUTHOR: M.DANIEL SCHWARZKOPF
8584 !
8585 ! DATE: 14 JULY 1983
8586 !
8587 ! ADDRESS:
8588 !
8589 ! G.F.D.L.
8590 ! P.O.BOX 308
8591 ! PRINCETON,N.J.08540
8592 ! U.S.A.
8593 ! TELEPHONE: (609) 452-6521
8594 !
8595 ! INFORMATION ON TAPE: THIS SOURCE IS THE FIRST FILE
8596 ! ON THIS TAPE.THE SIX FILES THAT FOLLOW ARE CO2 TRANS-
8597 ! MISSIVITIES FOR THE 500-850 CM-1 INTERVAL FOR CO2
8598 ! CONCENTRATIONS OF 330 PPMV (1X) ,660 PPMV (2X), AND
8599 ! 1320 PPMV (4X). THE FILES ARE ARRANGED AS FOLLOWS:
8600 ! FILE 2 1X,CONSOLIDATED USING B(250) WEIGHTING FCTN.
8601 ! FILE 3 1X,CONSOLIDATED WITH NO WEIGHTING FCTN.
8602 ! FILE 4 2X,CONSOLIDATED USING B(250) WEIGHTING FCTN.
8603 ! FILE 5 2X,CONSOLIDATED WITH NO WEIGHTING FCTN.
8604 ! FILE 6 4X,CONSOLIDATED USING B(250) WEIGHTING FCTN.
8605 ! FILE 7 4X,CONSOLIDATED WITH NO WEIGHTING FCTN.
8606 ! FILES 2,4,6 ARE RECOMMENDED FOR USE IN OBTAINING
8607 ! TRANSMISSION FUNCTIONS FOR USE IN HEATING RATE
8608 ! COMPUTATIONS;THEY CORRESPOND TO THE TRANSMISSIVITIES
8609 ! DISCUSSED IN THE 1980 PAPER.FILES 3,5,7 ARE PROVIDED
8610 ! TO FACILITATE COMPARISON WITH OBSERVATION AND WITH OTHER
8611 ! CALCULATIONS.
8612 !
8613 ! PROGRAM LANGUAGE: FORTRAN 1977,INCLUDING PARAMETER
8614 ! AND PROGRAM STATEMENTS.THE PROGRAM IS WRITTEN ON A
8615 ! CYBER 170-730.SEE THE SECTION ON LIMITATIONS FOR
8616 ! ADAPTATIONS TO OTHER MACHINES.
8617 !
8618 ! INPUT UNITS,FORMATS AND FORMAT STATEMENT NOS:
8619 !
8620 ! UNIT NO VARIABLES FORMAT STATEMENT NO. TYPE
8621 ! 5 P (PURPOSE 1) (5E16.9) 201 CARDS
8622 ! 5 PD (PURPOSE 2) (5E16.9) 201 CARDS
8623 ! 5 PLM(PURPOSE 2) (5E16.9) 201 CARDS
8624 ! 5 NMETHD (I3) 202 CARDS
8625 ! 20 TRANSA (4F20.14) 102 TAPE
8626 !NOV89
8627 ! ITAPE TRANSA (4F20.14) 102 TAPE
8628 !NOV89
8629 !
8630 ! OUTPUT UNITS,FORMATS AND FORMAT STATEMENT NOS:
8631 !
8632 ! UNIT NO VARIABLES FORMAT STATEMENT NO.
8633 ! 6 TRNFCT (1X,8F15.8) 301 PRINT
8634 ! 22 TRNFCT (4F20.14) 102 TAPE
8635 !
8636 ! PARAMETER INPUTS:
8637 ! A) NLEVLS : NLEVLS IS AN (INTEGER) PARAMETER DENOTING
8638 ! THE NUMBER OF NONZERO PRESSURE LEVELS FOR PURPOSE 1
8639 ! OR THE NUMBER OF NONZERO LAYER PRESSURES NEEDED TO
8640 ! SPECIFY THE PRESSURE LAYERS(PURPOSE 2) IN THE OUTPUT
8641 ! GRID. FOR EXAMPLE,IN PURPOSE 1,IF P=0,100,1000,NLEVLS=2.
8642 ! IF,IN PURPOSE 2,PD=0,100,500,1000,THE NUMBER OF NONZERO
8643 ! PRESSURE LAYERS=2,SO NLEVLS=2
8644 ! IN THE CODE AS WRITTEN,NLEVLS=40; THE USER SHOULD
8645 ! CHANGE THIS VALUE TO A USER-SPECIFIED VALUE.
8646 ! B) NLP1,NLP2 : INTEGER PARAMETERS DEFINED AS: NLP1=NLEVLS+1;
8647 ! NLP2=NLEVLS+2.
8648 ! SEE LIMITATIONS FOR CODE MODIFICATIONS IF PARAMETER
8649 ! STATEMENTS ARE NOT ALLOWED ON YOUR MACHINE.
8650 !
8651 ! INPUTS:
8652 !
8653 ! A) TRANSA : THE 109X109 GRID OF TRANSMISSION FUNCTIONS
8654 ! TRANSA IS A DOUBLE PRECISION REAL ARRAY.
8655 !
8656 ! TRANSA IS READ FROM FILE 20. THIS FILE CONTAINS 3
8657 ! RECORDS,AS FOLLOWS:
8658 ! 1) TRANSA, STANDARD TEMPERATURE PROFILE
8659 ! 3) TRANSA, STANDARD TEMPERATURES + 25 DEG
8660 ! 5) TRANSA, STANDARD TEMPERATURES - 25 DEG
8661 !
8662 ! B) NMETHD: AN INTEGER WHOSE VALUE IS EITHER 1 (IF CO2INT IS
8663 ! TO BE USED FOR PURPOSE 1) OR 2 (IF CO2INT IS TO BE USED FOR
8664 ! PURPOSE 2).
8665 !
8666 ! C) P,PD,PLM :
8667 ! P IS A REAL ARRAY (LENGTH NLP1) SPECIFYING THE PRESSURE
8668 ! GRID AT WHICH TRANSMISSION FUNCTIONS ARE TO BE COMPUTED FOR
8669 ! PURPOSE 1.THE DIMENSION OF P IS IN MILLIBARS.THE
8670 ! FOLLOWING LIMITATIONS WILL BE EXPLAINED MORE
8671 ! IN THE SECTION ON LIMITATIONS: P(1) MUST BE ZERO; P(NLP1),THE
8672 ! LARGEST PRESSURE, MUST NOT EXCEED 1165 MILLIBARS.
8673 ! PD IS A REAL ARRAY (LENGTH NLP2) SPECIFYING THE PRESSURE
8674 ! LAYERS FOR WHICH LAYER-AVERAGED TRANSMISSION FUNCTIONS ARE
8675 ! TO BE COMPUTED.THE DIMENSION OF PD IS MILLIBARS.THE LIMITATIONS
8676 ! FOR PD ARE THE SAME AS FOR P,AND ARE GIVEN IN THE SECTION ON
8677 ! LIMITATIONS.
8678 ! PLM IS A REAL ARRAY (LENGTH NLP2) SPECIFYING THE LAYER-MEAN
8679 ! PRESSURES. THE DIMENSION OF PLM IS MILLIBARS. THE LIMITATIONS
8680 ! FOR PLM ARE THE SAME AS FOR P,AND ARE GIVEN IN THE SECTION ON
8681 ! LIMITATIONS.PD IS READ IN BEFORE PLM.
8682 !
8683 ! NOTE: AGAIN,WE NOTE THAT THE USER WILL INPUT EITHER P (FOR
8684 ! PURPOSE 1) OR PD AND PLM(FOR PURPOSE 2) BUT NOT BOTH.
8685 !
8686 !
8687 !
8688 !
8689 ! LIMITATIONS:
8690 ! 1) P(1)=0.,PD(1)=0.,PLM(1)=0. THE TOP PRESSURE LEVEL
8691 ! MUST BE ZERO,OR THE TOP PRESSURE LAYER MUST BE BOUNDED BY ZERO.
8692 ! THE TOP LAYER-MEAN PRESSURE (PLM(1)) MUST BE ZERO; NO
8693 ! QUADRATURE IS DONE ON THE TOP PRESSURE LAYER.EVEN IF ONE IS
8694 ! NOT INTERESTED IN THE TRANSMISSION FUNCTION BETWEEN 0 AND P(J),
8695 ! ONE MUST INCLUDE SUCH A LEVEL.
8696 ! 2) PD(NLP2)=P(NLP1) IS LESS THAN OR EQUAL TO 1165 MB.
8697 ! EXTRAPOLATION TO HIGHER PRESSURES IS NOT POSSIBLE.
8698 ! 3) IF PROGRAM IS NOT PERMITTED ON YOUR COMPILER,
8699 ! SIMPLY DELETE THE LINE.
8700 ! 4) IF PARAMETER IS NOT PERMITTED,DO THE FOLLOWING:
8701 ! 1) DELETE ALL PARAMETER STATEMENTS IN CO2INT
8702 ! 2) AT THE POINT WHERE NMETHOD IS READ IN,ADD:
8703 ! READ (5,202) NLEVLS
8704 ! NLP1=NLEVLS+1
8705 ! NLP2=NLEVLS+2
8706 ! 3) CHANGE DIMENSION AND/OR COMMON STATEMENTS DEFINING
8707 ! ARRAYS TRNS,DELTA,P,PD,TRNFCT,PS,PDS,PLM IN CO2INT.
8708 ! THE NUMERICAL VALUE OF (NLEVLS+1) SHOULD BE INSERTED
8709 ! IN DIMENSION OR COMMON STATEMENTS FOR TRNS,DELTA,
8710 ! P,TRNFCT,PS,PLM; THE NUMERICAL VALUE OF (NLEVLS+2)
8711 ! IN DIMENSION OR COMMON STATEMENTS FOR PD,PDS.
8712 ! 5) PARAMETER (NLEVLS=40) AND THE OTHER PARAMETER
8713 ! STATEMENTS ARE WRITTEN IN CDC FORTRAN; ON OTHER MACHINES THE
8714 ! SAME STATEMENT MAY BE WRITTEN DIFFERENTLY,FOR EXAMPLE AS
8715 ! PARAMETER NLEVLS=40
8716 ! 6) -DOUBLE PRECISION- IS USED INSTEAD OF -REAL*8- ,DUE TO
8717 ! REQUIREMENTS OF CDC FORTAN.
8718 ! 7) THE STATEMENT -DO 400 KKK=1,3- CONTROLS THE NUMBER OF
8719 ! TRANSMISSIVITY OUTPUT MATRICES PORDUCED BY THE PROGRAM.TO
8720 ! PRODUCE 1 OUTPUT MATRIX,DELETE THIS STATEMENT.
8721 !
8722 ! OUTPUT:
8723 ! A) TRNFCT IS AN (NLP1,NLP1) REAL ARRAY OF THE TRANSMISSION
8724 ! FUNCTIONS APPROPRIATE TO YOUR ARRAY. IT IS TO BE SAVED ON FILE 22.
8725 ! THE PROCEDURE FOR SAVING MAY BE MODIFIED; AS GIVEN HERE,THE
8726 ! OUTPUT IS IN CARD IMAGE FORM WITH A FORMAT OF (4F20.14).
8727 !
8728 ! B) PRINTED OUTPUT IS A LISTING OF TRNFCT ON UNIT 6, IN
8729 ! THE FORMAT (1X,8F15.8) (FORMAT STATEMENT 301). THE USER MAY
8730 ! MODIFY OR ELIMINATE THIS AT WILL.
8731 !
8732 ! ************ FUNCTION INTERPOLATER ROUTINE *****************
8733 !
8734 !
8735 ! ****** THE FOLLOWING PARAMETER GIVES THE NUMBER OF *******
8736 ! ****** DATA LEVELS IN THE MODEL *******
8737 ! ****************************************************************
8738 ! ****************************************************************
8739 COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N
8740 ! COMMON/PRESS/PA(109)
8741 ! COMMON/TRAN/ TRANSA(109,109)
8742 ! COMMON / OUTPUT / TRNS(NLP1,NLP1)
8743 ! COMMON/INPUTP/P(NLP1),PD(NLP2)
8744 DIMENSION TRNS(NLP1,NLP1)
8745 DIMENSION P(NLP1),PD(NLP2)
8746 DIMENSION PS(NLP1),PDS(NLP2),PLM(NLP1)
8747 DIMENSION NRTAB(3)
8748 DIMENSION T15A(NLP2,2),T15B(NLP1)
8749 DIMENSION T22(NLP1,NLP1,3)
8750 LOGICAL , EXTERNAL :: wrf_dm_on_monitor
8751 DATA NRTAB/1,2,4/
8752 !***********************************
8753 ! THE FOLLOWING ARE THE INPUT FORMATS
8754 100 FORMAT (4F20.14)
8755 743 FORMAT (F20.14)
8756 201 FORMAT (5E16.9)
8757 202 FORMAT (I3)
8758 !O222 203 FORMAT (F12.6,I2)
8759 203 FORMAT (F12.6)
8760 ! THE FOLLOWING ARE THE OUTPUT FORMATS
8761 102 FORMAT (4F20.14)
8762 301 FORMAT (1X,8F15.8)
8763 !
8764 !CC REWIND 15
8765 !CC REWIND 20
8766 !NOV89
8767 REWIND ITAPE
8768 !NOV89
8769 !CC REWIND 22
8770 !
8771 ! CALCULATION OF PA -THE -TABLE- OF 109 GRID PRESSURES
8772 ! NOTE-THIS CODE MUST NOT BE CHANGED BY THE USER^^^^^^^^^
8773 PA(1)=0.
8774 FACT15=10.**(1./15.)
8775 FACT30=10.**(1./30.)
8776 PA(2)=1.0E-3
8777 DO 231 I=2,76
8778 PA(I+1)=PA(I)*FACT15
8779 231 CONTINUE
8780 DO 232 I=77,108
8781 PA(I+1)=PA(I)*FACT30
8782 232 CONTINUE
8783 !
8784 N=25
8785 NLV=NLEVLS
8786 NLP1V=NLP1
8787 NLP2V=NLP2
8788 ! READ IN THE CO2 MIXING RATIO(IN UNITS OF 330 PPMV),AND AN INDEX
8789 ! GIVING THE FREQUENCY RANGE OF THE LBL DATA
8790 !O222 READ (5,203) RATIO,IR
8791 !CC IR = 1
8792 !CC READ (5,203) RATIO
8793 !O222 ***********************************
8794 !***VALUES FOR IR*****
8795 ! IR=1 CONSOL. LBL TRANS. =490-850
8796 ! IR=2 CONSOL. LBL TRANS. =490-670
8797 ! IR=3 CONSOL. LBL TRANS. =670-850
8798 ! IR=4 CONSOL. LBL TRANS. =2270-2380
8799 !*** IR MUST BE 1,2,3 OR 4 FOR THE PGM. TO WORK
8800 ! ALSO READ IN THE METHOD NO.(1 OR 2)
8801 !CC READ (5,202) NMETHD
8802 IF (RATIO.EQ.1.0) GO TO 621
8803 CALL wrf_error_fatal( 'SUBROUTINE CO2INT: 8746' )
8804 !NOV89 621 ITAP1=20
8805 621 ITAP1=ITAPE
8806 !NOV89
8807 NTAP=1
8808 IF (NMETHD.EQ.2) GO TO 502
8809 ! *****CARDS FOR PURPOSE 1(NMETHD=1)
8810 !CC READ (15,201) (P(I),I=1,NLP1)
8811 DO 300 I=1,NLP1
8812 P(I)=T15B(I)
8813 300 CONTINUE
8814 DO 801 I=1,NLP1
8815 PS(I)=P(I)
8816 801 CONTINUE
8817 GO TO 503
8818 502 CONTINUE
8819 ! *****CARDS FOR PURPOSE 2(NMETHD=2)
8820 !CC READ (15,201) (PD(I),I=1,NLP2)
8821 !CC READ (15,201) (PLM(I),I=1,NLP1)
8822 DO 303 I=1,NLP2
8823 PD(I)=T15A(I,1)
8824 303 CONTINUE
8825 DO 302 I=1,NLP1
8826 PLM(I)=T15A(I,2)
8827 302 CONTINUE
8828 DO 802 I=1,NLP1
8829 PDS(I)=PD(I+1)
8830 PS(I)=PLM(I)
8831 802 CONTINUE
8832 !
8833 503 CONTINUE
8834 ! *****DO LOOP CONTROLLING NUMBER OF OUTPUT MATRICES
8835 !NOV89
8836 !NOV89 DO 400 KKK=1,3
8837 ICLOOP = 3
8838 IF (IR.EQ.4) ICLOOP = 1
8839 DO 400 KKK=1,ICLOOP
8840 !NOV89
8841 ! **********************
8842 IF (NMETHD.EQ.2) GO TO 505
8843 ! *****CARDS FOR PURPOSE 1(NMETHD=1)
8844 DO 803 I=1,NLP1
8845 P(I)=PS(I)
8846 803 CONTINUE
8847 GO TO 506
8848 505 CONTINUE
8849 ! *****CARDS FOR PURPOSE 2(NMETHD=2)
8850 DO 804 I=1,NLP1
8851 PD(I)=PDS(I)
8852 P(I)=PS(I)
8853 804 CONTINUE
8854 !
8855 506 CONTINUE
8856 IA=108
8857 IAP=IA+1
8858 !NOV89 IF (NTAP.EQ.1) READ (20,100) ((TRANSA(I,J),I=1,109),J=1,109)
8859 !mp IF (NTAP.EQ.1) READ (ITAPE,100) ((TRANSA(I,J),I=1,109),J=1,109)
8860 IF (NTAP.EQ.1) THEN
8861 IF ( wrf_dm_on_monitor() ) READ (ITAPE,743) ((TRANSA(I,J),I=1,109),J=1,109)
8862 CALL wrf_dm_bcast_bytes ( TRANSA , size ( TRANSA ) * RWORDSIZE )
8863 ENDIF
8864 !mp IF (NTAP.EQ.1) READ (ITAPE,100) (tmp(I),I=1,11881
8865 !mp
8866 do J=109,1,-6
8867 !mp write(6,697)(TRANSA(I,J),I=5,105,10)
8868 enddo
8869 ! 697 format(11(f5.3,1x))
8870 !mp
8871 !NOV89
8872 DO 4 I=1,IAP
8873 TRANSA(I,I)=1.0
8874 4 CONTINUE
8875 CALL COEINT(RATIO,IR)
8876 DO 805 I=1,NLP1
8877 DO 805 J=1,NLP1
8878 TRNS(J,I)=1.00
8879 805 CONTINUE
8880 DO 10 I=1,NLP1
8881 DO 20 J=1,I
8882 IF (I.EQ.J) GO TO 20
8883 P1=P(J)
8884 P2=P(I)
8885 CALL SINTR2
8886 TRNS(J,I)=TRNSLO
8887 20 CONTINUE
8888 10 CONTINUE
8889 DO 47 I=1,NLP1
8890 DO 47 J=I,NLP1
8891 TRNS(J,I)=TRNS(I,J)
8892 47 CONTINUE
8893 ! *****THIS IS THE END OF PURPOSE 1 CALCULATIONS
8894 IF (NMETHD.EQ.1) GO TO 2872
8895 !
8896 DO 51 J=1,NLP1
8897 DO 52 I=2,NLP1
8898 IA=I
8899 JA=J
8900 N=25
8901 IF (I.NE.J) N=3
8902 CALL QUADSR(NLV,NLP1V,NLP2V,P,PD,TRNS)
8903 52 CONTINUE
8904 51 CONTINUE
8905 ! *****THIS IS THE END OF PURPOSE 2 CALCULATIONS
8906 2872 CONTINUE
8907 !
8908 !+++ WRITE (6,301) ((TRNS(I,J),I=1,NLP1),J=1,NLP1)
8909 !CC WRITE (22,102) ((TRNS(I,J),I=1,NLP1),J=1,NLP1)
8910 DO 304 J=1,NLP1
8911 DO 304 I=1,NLP1
8912 T22(I,J,KKK) = TRNS(I,J)
8913 304 CONTINUE
8914 400 CONTINUE
8915 RETURN
8916 END SUBROUTINE CO2INT
8917 !CCC PROGRAM CO2IN1
8918 SUBROUTINE CO2IN1(T20,T21,T66,IQ,L,LP1)
8919 ! CO2IN1=CO2INS FOR METHOD 1
8920 ! *********************************************************
8921 ! SAVE DATA ON PERMANENT DATA SET DENOTED BY CO222 ***
8922 ! ..... K.CAMPANA MARCH 1988,OCTOBER 1988
8923 ! ..... K.CAMPANA DECEMBER 88 CLEANED UP FOR LAUNCHER
8924 ! *********************************************************
8925 DIMENSION T20(LP1,LP1,3),T21(LP1,LP1,3),T66(L,6)
8926 DIMENSION DCDT8(LP1,LP1),DCDT10(LP1,LP1),CO2PO(LP1,LP1), &
8927 CO2800(LP1,LP1),CO2PO1(LP1,LP1),CO2801(LP1,LP1),CO2PO2(LP1,LP1), &
8928 CO2802(LP1,LP1),N(LP1),D2CT8(LP1,LP1),D2CT10(LP1,LP1)
8929 ITIN=20
8930 ITIN1=21
8931 !O222 LATEST CODE HAS IQ=1
8932 !CC IQ=4
8933 1011 FORMAT (4F20.14)
8934 !CC READ (ITIN,1011) ((CO2PO(I,J),I=1,LP1),J=1,LP1)
8935 !CC READ (ITIN1,1011) ((CO2800(I,J),I=1,LP1),J=1,LP1)
8936 !CC READ (ITIN,1011) ((CO2PO1(I,J),I=1,LP1),J=1,LP1)
8937 !CC READ (ITIN1,1011) ((CO2801(I,J),I=1,LP1),J=1,LP1)
8938 !CC READ (ITIN,1011) ((CO2PO2(I,J),I=1,LP1),J=1,LP1)
8939 !CC READ (ITIN1,1011) ((CO2802(I,J),I=1,LP1),J=1,LP1)
8940 DO 300 J=1,LP1
8941 DO 300 I=1,LP1
8942 CO2PO(I,J) = T20(I,J,1)
8943 !NOV89
8944 IF (IQ.EQ.5) GO TO 300
8945 !NOV89
8946 CO2PO1(I,J) = T20(I,J,2)
8947 CO2PO2(I,J) = T20(I,J,3)
8948 300 CONTINUE
8949 DO 301 J=1,LP1
8950 DO 301 I=1,LP1
8951 CO2800(I,J) = T21(I,J,1)
8952 !NOV89
8953 IF (IQ.EQ.5) GO TO 301
8954 !NOV89
8955 CO2801(I,J) = T21(I,J,2)
8956 CO2802(I,J) = T21(I,J,3)
8957 301 CONTINUE
8958 !***THE FOLLOWING CODE IS REWRITTEN SO THAT THE RADIATIVE BANDS
8959 ! ARE:
8960 ! IQ=1 560-800 (CONSOL.=490-850)
8961 ! IQ=2 560-670 (CONSOL.=490-670)
8962 ! IQ=3 670-800 (CONSOL.=670-850)
8963 ! IQ=4 560-760 (ORIGINAL CODE) (CONSOL.=490-850)
8964 !NOV89
8965 ! IQ=5 2270-2380 (CONSOL.=2270-2380)
8966 !NOV89
8967 ! THE FOLLOWING LOOP OBTAINS TRANSMISSION FUNCTIONS FOR BANDS
8968 ! USED IN RADIATIVE MODEL CALCULATIONS,WITH THE EQUIVALENT
8969 ! WIDTHS KEPT FROM THE ORIGINAL CONSOLIDATED CO2 TF S.
8970 IF (IQ.EQ.1) THEN
8971 C1=1.5
8972 C2x=0.5
8973 ENDIF
8974 IF (IQ.EQ.2) THEN
8975 C1=18./11.
8976 C2x=7./11.
8977 ENDIF
8978 IF (IQ.EQ.3) THEN
8979 C1=18./13.
8980 C2x=5./13.
8981 ENDIF
8982 IF (IQ.EQ.4) THEN
8983 C1=1.8
8984 C2x=0.8
8985 ENDIF
8986 !NOV89
8987 IF (IQ.EQ.5) THEN
8988 C1=1.0
8989 C2x=0.0
8990 ENDIF
8991 !NOV89
8992 DO 1021 I=1,LP1
8993 DO 1021 J=1,LP1
8994 CO2PO(J,I)=C1*CO2PO(J,I)-C2x
8995 CO2800(J,I)=C1*CO2800(J,I)-C2x
8996 !NOV89
8997 IF (IQ.EQ.5) GO TO 1021
8998 !NOV89
8999 CO2PO1(J,I)=C1*CO2PO1(J,I)-C2x
9000 CO2801(J,I)=C1*CO2801(J,I)-C2x
9001 CO2PO2(J,I)=C1*CO2PO2(J,I)-C2x
9002 CO2802(J,I)=C1*CO2802(J,I)-C2x
9003 1021 CONTINUE
9004 !NOV89
9005 IF (IQ.GE.1.AND.IQ.LE.4) THEN
9006 !NOV89
9007 DO 1 J=1,LP1
9008 DO 1 I=1,LP1
9009 DCDT8(I,J)=.02*(CO2801(I,J)-CO2802(I,J))*100.
9010 DCDT10(I,J)=.02*(CO2PO1(I,J)-CO2PO2(I,J))*100.
9011 D2CT8(I,J)=.0016*(CO2801(I,J)+CO2802(I,J)-2.*CO2800(I,J))*1000.
9012 D2CT10(I,J)=.0016*(CO2PO1(I,J)+CO2PO2(I,J)-2.*CO2PO(I,J))*1000.
9013 1 CONTINUE
9014 !NOV89
9015 ENDIF
9016 !NOV89
9017 !O222 *********************************************************
9018 !CC REWIND 66
9019 ! SAVE CDTM51,CO2M51,C2DM51,CDTM58,CO2M58,C2DM58..ON TEMPO FILE
9020 !CC WRITE (66) (DCDT10(I,I+1),I=1,L)
9021 !CC WRITE (66) (CO2PO(I,I+1),I=1,L)
9022 !CC WRITE (66) (D2CT10(I,I+1),I=1,L)
9023 !CC WRITE (66) (DCDT8(I,I+1),I=1,L)
9024 !CC WRITE (66) (CO2800(I,I+1),I=1,L)
9025 !CC WRITE (66) (D2CT8(I,I+1),I=1,L)
9026 !CC REWIND 66
9027 !O222 *********************************************************
9028 DO 400 I=1,L
9029 T66(I,2) = CO2PO(I,I+1)
9030 T66(I,5) = CO2800(I,I+1)
9031 !NOV89
9032 IF (IQ.EQ.5) GO TO 400
9033 !NOV89
9034 T66(I,1) = DCDT10(I,I+1)
9035 T66(I,3) = D2CT10(I,I+1)
9036 T66(I,4) = DCDT8(I,I+1)
9037 T66(I,6) = D2CT8(I,I+1)
9038 400 CONTINUE
9039 RETURN
9040 END SUBROUTINE CO2IN1
9041 !CCC PROGRAM PTZ - COURTESY OF DAN SCHWARZKOPF,GFDL DEC 1987....
9042 SUBROUTINE CO2PTZ(SGTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
9043 SFULL,SHALF,PPTOP,LREAD,NL,NLP,NLP2)
9044 !
9045 ! ** THIS PROGRAM CALCULATES TEMPERATURES ,H2O MIXING RATIOS
9046 ! ** AND O3 MIXING RATIOS BY USING AN ANALYTICAL
9047 ! ** FUNCTION WHICH APPROXIMATES
9048 ! ** THE US STANDARD (1976). THIS IS
9049 ! ** CALCULATED IN FUNCTION 'ANTEMP', WHICH IS CALLED BY THE
9050 ! ** MAIN PROGRAM. THE FORM OF THE ANALYTICAL FUNCTION WAS
9051 ! ** SUGGESTED TO ME IN 1971 BY RICHARD S. LINDZEN.
9052 ! ******************************************************************
9053 ! CODE TO SAVE STEMP,GTEMP ON DATA SET,BRACKETED BY CO222 **
9054 ! ....K. CAMPANA MARCH 88,OCTOBER 88
9055 DIMENSION SGTEMP(NLP,2),T41(NLP2,2),T42(NLP), &
9056 T43(NLP2,2),T44(NLP)
9057 DIMENSION SGLVNU(NLP),SIGLNU(NL)
9058 DIMENSION SFULL(NLP),SHALF(NL)
9059 ! ******************************************************************
9060 !
9061 !*****THIS VERSION IS ONLY USABLE FOR 1976 US STD ATM AND OBTAINS
9062 ! QUANTITIES FOR CO2 INTERPOLATION AND INSERTION INTO OPERA-
9063 ! TIONAL RADIATION CODES
9064 !
9065 CHARACTER*20 PROFIL
9066 DIMENSION PRESS(NLP),TEMP(NLP),ALT(NLP),WMIX(NLP),O3MIX(NLP)
9067 DIMENSION WMXINT(NLP,4),WMXOUT(NLP2),OMXINT(NLP,4),OMXOUT(NLP2)
9068 DIMENSION PD(NLP2),GTEMP(NLP)
9069 DIMENSION PRS(NLP),TEMPS(NLP),PRSINT(NLP),TMPINT(NLP,4),A(NLP,4)
9070 DIMENSION PROUT(NLP2),TMPOUT(NLP2),TMPFLX(NLP2),TMPMID(NLP2)
9071 !
9072 !
9073 DATA PROFIL/ &
9074 'US STANDARD 1976'/
9075 DATA PSMAX/1013.250/
9076 !
9077 ! ** NTYPE IS AN INTEGER VARIABLE WHICH HAS THE FOLLOWING
9078 ! ** VALUES: 0 =SIGMA LEVELS ARE USED; 1= SKYHI L40 LEVELS
9079 ! ** ARE USED; 2 = SKYHI L80 LEVELS ARE USED. DEFAULT: 0
9080 !
9081 NTYPE=0
9082 !O222 READ (*,*) NTYPE
9083 5 NLEV=NL
9084 DELZAP=0.5
9085 R=8.31432
9086 G0=9.80665
9087 ZMASS=28.9644
9088 AA=6356.766
9089 ALT(1)=0.0
9090 TEMP(1)=ANTEMP(6,0.0)
9091 !*******DETERMINE THE PRESSURES (PRESS)
9092 PSTAR=PSMAX
9093 !
9094 !*** LTOP COMPUTATION MOVED FROM MODEL INITIALIZATION
9095 !
9096 LTOP(1)=0
9097 LTOP(2)=0
9098 LTOP(3)=0
9099 DO 30 N=1,NL
9100 PCLD=(PSTAR-PPTOP*10.)*SHALF(N)+PPTOP*10.
9101 IF(PCLD.GE.642.)LTOP(1)=N
9102 IF(PCLD.GE.350.)LTOP(2)=N
9103 IF(PCLD.GE.150.)LTOP(3)=N
9104 ! PRINT *,N,PCLD,SHALF(N),PSTAR,PPTOP
9105 30 CONTINUE
9106 !
9107 !O222 IF (NTYPE.EQ.1) CALL SKYP(PSTAR,PD,GTEMP)
9108 !O222 IF (NTYPE.EQ.2) CALL SKY80P(PSTAR,PD,GTEMP)
9109 !O222 IF (NTYPE.EQ.0) CALL SIGP(PSTAR,PD,GTEMP)
9110 !CC---- CALL SIGP(PSTAR,PD,GTEMP)
9111 NLM=NL-1
9112 CALL SIGP(PSTAR,PD,GTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
9113 SFULL,SHALF,PPTOP,LREAD,NL,NLP,NLM,NLP2)
9114 PD(NLP2)=PSTAR
9115 DO 40 N=1,NLP
9116 PRSINT(N)=PD(NLP2+1-N)
9117 40 CONTINUE
9118 ! *** CALCULATE TEMPS FOR SEVERAL PRESSURES TO DO QUADRATURE
9119 DO 504 NQ=1,4
9120 DO 505 N=2,NLP
9121 505 PRESS(N)=PRSINT(N)+0.25*(NQ-1)*(PRSINT(N-1)-PRSINT(N))
9122 PRESS(1)=PRSINT(1)
9123 !*********************
9124 DO 100 N=1,NLEV
9125 !
9126 ! ** ESTABLISH COMPUTATATIONAL LEVELS BETWEEN USER LEVELS AT
9127 ! ** INTERVALS OF APPROXIMATELY 'DELZAP' KM.
9128 !
9129 DLOGP=7.0*ALOG(PRESS(N)/PRESS(N+1))
9130 NINT=DLOGP/DELZAP
9131 NINT=NINT+1
9132 ZNINT=NINT
9133 ! G=G0
9134 DZ=R*DLOGP/(7.0*ZMASS*G0*ZNINT)
9135 HT=ALT(N)
9136 !
9137 ! ** CALCULATE HEIGHT AT NEXT USER LEVEL BY MEANS OF
9138 ! ** RUNGE-KUTTA INTEGRATION.
9139 !
9140 DO 200 M=1,NINT
9141 RK1=ANTEMP(6,HT)*DZ
9142 RK2=ANTEMP(6,HT+0.5*RK1)*DZ
9143 RK3=ANTEMP(6,HT+0.5*RK2)*DZ
9144 RK4=ANTEMP(6,HT+RK3)*DZ
9145 !mp write(6,*) 'RK values,DZ ', RK1,RK2,RK3,RK4,DZ
9146 HT=HT+0.16666667*(RK1+RK2+RK2+RK3+RK3+RK4)
9147 200 CONTINUE
9148 ALT(N+1)=HT
9149 TEMP(N+1)=ANTEMP(6,HT)
9150 100 CONTINUE
9151 DO 506 N=1,NLP
9152 TMPINT(N,NQ)=TEMP(N)
9153 A(N,NQ)=ALT(N)
9154 506 CONTINUE
9155 504 CONTINUE
9156 !O222 *****************************************************
9157 !***OUTPUT TEMPERATURES
9158 !O222 *****************************************************
9159 DO 901 N=1,NLP
9160 SGTEMP(N,1) = TMPINT(NLP2-N,1)
9161 901 CONTINUE
9162 !O222 *****************************************************
9163 !***OUTPUT GTEMP
9164 !O222 *****************************************************
9165 DO 902 N=1,NLP
9166 SGTEMP(N,2) = GTEMP(N)
9167 902 CONTINUE
9168 !O222 *****************************************************
9169 RETURN
9170 END SUBROUTINE CO2PTZ
9171 FUNCTION PATH(A,B,C,E)
9172 !....
9173 ! DOUBLE PRECISION XA,CA
9174 ! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
9175 PEXP=1./SEXP
9176 PATH=((A-B)**PEXP*(A+B+C))/(E*(A+B+C)+(A-B)**(PEXP-1.))
9177 RETURN
9178 END FUNCTION PATH
9179 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9180 SUBROUTINE QINTRP(XM,X0,XP,FM,F0,FP,X,F)
9181 !....
9182 ! DOUBLE PRECISION FM,F0,FP,F,D1,D2,B,A,DEL
9183 D1=(FP-F0)/(XP-X0)
9184 D2=(FM-F0)/(XM-X0)
9185 B=(D1-D2)/(XP-XM)
9186 A=D1-B*(XP-X0)
9187 DEL=(X-X0)
9188 F=F0+DEL*(A+DEL*B)
9189 RETURN
9190 END SUBROUTINE QINTRP
9191 SUBROUTINE QUADSR(NLV,NLP1V,NLP2V,P,PD,TRNS)
9192 COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N
9193 DIMENSION P(NLP1V),PD(NLP2V),TRNS(NLP1V,NLP1V)
9194 DIMENSION WT(101)
9195 N2=2*N
9196 N2P=2*N+1
9197 ! *****WEIGHTS ARE CALCULATED
9198 WT(1)=1.
9199 DO 21 I=1,N
9200 WT(2*I)=4.
9201 WT(2*I+1)=1.
9202 21 CONTINUE
9203 IF (N.EQ.1) GO TO 25
9204 DO 22 I=2,N
9205 WT(2*I-1)=2.
9206 22 CONTINUE
9207 25 CONTINUE
9208 TRNSNB=0.
9209 DP=(PD(IA)-PD(IA-1))/N2
9210 PFIX=P(JA)
9211 DO 1 KK=1,N2P
9212 PVARY=PD(IA-1)+(KK-1)*DP
9213 IF (PVARY.GE.PFIX) P2=PVARY
9214 IF (PVARY.GE.PFIX) P1=PFIX
9215 IF (PVARY.LT.PFIX) P1=PVARY
9216 IF (PVARY.LT.PFIX) P2=PFIX
9217 CALL SINTR2
9218 TRNSNB=TRNSNB+TRNSLO*WT(KK)
9219 1 CONTINUE
9220 TRNS(IA,JA)=TRNSNB*DP/(3.*(PD(IA)-PD(IA-1)))
9221 RETURN
9222 END SUBROUTINE QUADSR
9223 !---------------------------------------------------------------------
9224 SUBROUTINE SIGP(PSTAR,PD,GTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
9225 SIGLV,SIGLY,PPTOP,LREAD,KD,KP,KM,KP2)
9226 DIMENSION Q(KD),QMH(KP),PD(KP2),PLM(KP),GTEMP(KP),PDT(KP2)
9227 DIMENSION SIGLY(KD),SIGLV(KP)
9228 DIMENSION CI(KP),SGLVNU(KP),DEL(KD),SIGLNU(KD),CL(KD),RPI(KM)
9229 DIMENSION IDATE(4)
9230 DIMENSION T41(KP2,2),T42(KP), &
9231 T43(KP2,2),T44(KP)
9232 ! integer :: retval
9233 ! character(50) :: prsmid='prsmid'
9234 !CC 18 LEVEL SIGMAS FOR NMC MRF(NEW) MODEL
9235 !CC DATA Q/.021,.074,.124,.175,.225,.275,.325,.375,.425,.497, &
9236 !CC .594,.688,.777,.856,.920,.960,.981,.995/
9237 ! FOR SIGMA MODELS,Q=SIGMA,QMH=0.5(Q(I)+Q(I+1),
9238 ! PD=Q*PSS,PLM=QMH*PSS.PSS=SURFACE PRESSURE(SPEC.)
9239 !
9240 !..... GET NMC SIGMA STRUCTURE
9241 !CC IF (LREAD.GT.0) GO TO 914
9242 !--- PPTOP IS MODEL TOP PRESSURE IN CB....
9243 ! SIGMA DATA IS BOTTOM OF ATMOSPHERE TO T.O.A.....
9244 !cccc PPTOP=5.0
9245 ! READ(11,PPTOP,END=12321)
9246 12321 CONTINUE
9247 ! WRITE(6,88221)PPTOP,KD,KP
9248 !88221 FORMAT(' ENTER SIGP PPTOP=',E12.5,' KD=',I2,' KP=',I2)
9249 ! open(unit=23,file='fort.23',form='unformatted' &
9250 ! , access='sequential')
9251 ! REWIND 23
9252 ! READ(23)SIGLY
9253 ! DO KKK=1,KD
9254 ! SIGLY(KKK)=1.-(FLOAT(KKK)-0.5)/KD
9255 ! END DO
9256 ! WRITE(6,88222)
9257 !88222 FORMAT(' READ AETA')
9258 ! DO 37821 LLL=1,KD
9259 ! WRITE(6,37820)LLL,SIGLY(LLL)
9260 !37820 FORMAT(' L=',I2,' AETA=',E12.5)
9261 !37821 CONTINUE
9262 ! READ(23)SIGLV
9263 ! DO KKK=1,KP
9264 ! SIGLV(KKK)=1.-(FLOAT(KKK-1))/KD
9265 ! END DO
9266 ! WRITE(6,88223)
9267 !88223 FORMAT(' READ ETA')
9268 ! PRINT 704,(SIGLY(K),K=1,KD)
9269 ! PRINT 704,(SIGLV(K),K=1,KP)
9270 ! DO 37823 LLL=1,KP
9271 ! WRITE(6,37822)LLL,SIGLV(LLL)
9272 !37822 FORMAT(' L=',I2,' ETA=',E12.5)
9273 !37823 CONTINUE
9274 701 FORMAT(F6.2)
9275 702 FORMAT(7F10.6)
9276 IF (PPTOP.LE.0.) GO TO 708
9277 PSFC=100.
9278 !--- IF PTOP NOT EQUAL TO ZERO ADJUST SIGMA SO AS TO GET PROPER STD ATM
9279 ! VERTICAL LOCATION
9280 DO 706 K=1,KD
9281 SIGLY(K) = (SIGLY(K)*(PSFC-PPTOP)+PPTOP)/PSFC
9282 706 CONTINUE
9283 DO 707 K=1,KP
9284 SIGLV(K) = (SIGLV(K)*(PSFC-PPTOP)+PPTOP)/PSFC
9285 707 CONTINUE
9286 708 CONTINUE
9287 ! PRINT 703,PPTOP
9288 ! PRINT 704,(SIGLY(K),K=1,KD)
9289 ! PRINT 704,(SIGLV(K),K=1,KP)
9290 703 FORMAT(1H ,'PTOP =',F6.2)
9291 704 FORMAT(1H ,7F10.6)
9292 DO 913 K=1,KP
9293 SGLVNU(K) = SIGLV(K)
9294 IF (K.LE.KD) SIGLNU(K) = SIGLY(K)
9295 913 CONTINUE
9296 DO 77 K=1,KD
9297 Q(K) = SIGLNU(KD+1-K)
9298 77 CONTINUE
9299 PSS= 1013250.
9300 QMH(1)=0.
9301 QMH(KP)=1.
9302 DO 1 K=2,KD
9303 QMH(K)=0.5*(Q(K-1)+Q(K))
9304 1 CONTINUE
9305 PD(1)=0.
9306 PD(KP2)=PSS
9307 DO 2 K=2,KP
9308 PD(K)=Q(K-1)*PSS
9309 2 CONTINUE
9310 ! call int_get_fresh_handle(retval)
9311 ! close(retval)
9312 ! write(0,*)' before open in CO2O3'
9313 ! open(unit=retval,file=prsmid,form='UNFORMATTED',iostat=ier)
9314 ! write(0,*)' after open1'
9315 ! do k=1,62
9316 ! write(retval)pd(k)
9317 ! enddo
9318 ! close(retval)
9319 PLM(1)=0.
9320 DO 3 K=1,KM
9321 PLM(K+1)=0.5*(PD(K+1)+PD(K+2))
9322 3 CONTINUE
9323 PLM(KP)=PSS
9324 DO 4 K=1,KD
9325 GTEMP(K)=PD(K+1)**0.2*(1.+PD(K+1)/30000.)**0.8/1013250.
9326 4 CONTINUE
9327 GTEMP(KP)=0.
9328 !+++ WRITE (6,100) (GTEMP(K),K=1,KD)
9329 !+++ WRITE (6,100) (PD(K),K=1,KP2)
9330 !+++ WRITE (6,100) (PLM(K),K=1,KP)
9331 !***TAPES 41,42 ARE OUTPUT TO THE CO2 INTERPOLATION PROGRAM (PS=1013MB)
9332 ! THE FOLLOWING PUTS P-DATA INTO MB
9333 DO 11 I=1,KP
9334 PD(I)=PD(I)*1.0E-3
9335 PLM(I)=PLM(I)*1.0E-3
9336 11 CONTINUE
9337 PD(KP2)=PD(KP2)*1.0E-3
9338 !CC WRITE (41,101) (PD(K),K=1,KP2)
9339 !CC WRITE (41,101) (PLM(K),K=1,KP)
9340 !CC WRITE (42,101) (PLM(K),K=1,KP)
9341 DO 300 K=1,KP2
9342 T41(K,1) = PD(K)
9343 300 CONTINUE
9344 DO 301 K=1,KP
9345 T41(K,2) = PLM(K)
9346 T42(K) = PLM(K)
9347 301 CONTINUE
9348 !***STORE AS PDT,SO THAT RIGHT PD IS RETURNED TO PTZ
9349 DO 12 I=1,KP2
9350 PDT(I)=PD(I)
9351 12 CONTINUE
9352 !***SECOND PASS: PSS=810MB,GTEMP NOT COMPUTED
9353 PSS=0.8*1013250.
9354 QMH(1)=0.
9355 QMH(KP)=1.
9356 DO 201 K=2,KD
9357 QMH(K)=0.5*(Q(K-1)+Q(K))
9358 201 CONTINUE
9359 PD(1)=0.
9360 PD(KP2)=PSS
9361 DO 202 K=2,KP
9362 PD(K)=Q(K-1)*PSS
9363 202 CONTINUE
9364 PLM(1)=0.
9365 DO 203 K=1,KM
9366 PLM(K+1)=0.5*(PD(K+1)+PD(K+2))
9367 203 CONTINUE
9368 PLM(KP)=PSS
9369 !+++ WRITE (6,100) (PD(K),K=1,KP2)
9370 !+++ WRITE (6,100) (PLM(K),K=1,KP)
9371 !***TAPES 43,44 ARE OUTPUT TO THE CO2 INTERPOLATION PROGRAM(PS=810 MB)
9372 ! THE FOLLOWING PUTS P-DATA INTO MB
9373 DO 211 I=1,KP
9374 PD(I)=PD(I)*1.0E-3
9375 PLM(I)=PLM(I)*1.0E-3
9376 211 CONTINUE
9377 PD(KP2)=PD(KP2)*1.0E-3
9378 !CC WRITE (43,101) (PD(K),K=1,KP2)
9379 !CC WRITE (43,101) (PLM(K),K=1,KP)
9380 !CC WRITE (44,101) (PLM(K),K=1,KP)
9381 DO 302 K=1,KP2
9382 T43(K,1) = PD(K)
9383 302 CONTINUE
9384 DO 303 K=1,KP
9385 T43(K,2) = PLM(K)
9386 T44(K) = PLM(K)
9387 303 CONTINUE
9388 !***RESTORE PD
9389 DO 212 I=1,KP2
9390 PD(I)=PDT(I)
9391 212 CONTINUE
9392 100 FORMAT (1X,5E20.13)
9393 101 FORMAT (5E16.9)
9394 RETURN
9395 END SUBROUTINE SIGP
9396 !---------------------------------------------------------------------
9397 SUBROUTINE SINTR2
9398 !....
9399 ! IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9400 ! REAL P1,P2,PA,TRNSLO,CORE,TRANSA,PATH,UEXP,SEXP,ETA,SEXPV
9401 COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N
9402 ! COMMON/PRESS/ PA(109)
9403 ! COMMON/TRAN/ TRANSA(109,109)
9404 ! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP
9405 DO 70 L=1,109
9406 IP1=L
9407 IF (P2-PA(L)) 65,65,70
9408 70 CONTINUE
9409 65 I=IP1-1
9410 IF (IP1.EQ.1) IP1=2
9411 IF (I.EQ.0) I=1
9412 DO 80 L=1,109
9413 JP1=L
9414 IF (P1-PA(L)) 75,75,80
9415 80 CONTINUE
9416 75 J=JP1-1
9417 IF (JP1.EQ.1) JP1=2
9418 IF (J.EQ.0) J=1
9419 JJJ=J
9420 III=I
9421 J=JJJ
9422 JP1=J+1
9423 I=III
9424 IP1=I+1
9425 ! DETERMINE ETAP,THE VALUE OF ETA TO USE BY LINEAR INTERPOLATION
9426 ! FOR PETA(=0.5*(P1+P2))
9427 PETA=P2
9428 DO 90 L=1,109
9429 IETAP1=L
9430 IF (PETA-PA(L)) 85,85,90
9431 90 CONTINUE
9432 85 IETA=IETAP1-1
9433 IF (IETAP1.EQ.1) IETAP1=2
9434 IF (IETA.EQ.0) IETA=1
9435 ETAP=ETA(IETA)+(PETA-PA(IETA))*(ETA(IETAP1)-ETA(IETA))/ &
9436 (PA(IETAP1)-PA(IETA))
9437 SEXP=SEXPV(IETA)+(PETA-PA(IETA))*(SEXPV(IETAP1)- &
9438 SEXPV(IETA))/ (PA(IETAP1)-PA(IETA))
9439 PIPMPI=PA(IP1)-PA(I)
9440 UP2P1=(PATH(P2,P1,CORE,ETAP))**UEXP
9441 IF (I-J) 126,126,127
9442 126 CONTINUE
9443 TRIP=(CA(IP1)*DLOG(1.0D0+XA(IP1)*UP2P1))**(SEXP/UEXP)
9444 TRI=(CA(I)*DLOG(1.0D0+XA(I)*UP2P1))**(SEXP/UEXP)
9445 TRNSLO=1.0D0-((PA(IP1)-P2)*TRI+(P2-PA(I))*TRIP)/PIPMPI
9446 GO TO 128
9447 127 TIJ=TRANSA(I,J)
9448 TIPJ=TRANSA(I+1,J)
9449 TIJP=TRANSA(I,J+1)
9450 TIPJP=TRANSA(I+1,J+1)
9451 UIJ=(PATH(PA(I),PA(J),CORE,ETAP))**UEXP
9452 UIPJ=(PATH(PA(I+1),PA(J),CORE,ETAP))**UEXP
9453 UIJP=(PATH(PA(I),PA(J+1),CORE,ETAP))**UEXP
9454 UIPJP=(PATH(PA(I+1),PA(J+1),CORE,ETAP))**UEXP
9455 PRODI=CA(I)*XA(I)
9456 PRODIP=CA(I+1)*XA(I+1)
9457 PROD=((PA(I+1)-P2)*PRODI+(P2-PA(I))*PRODIP)/PIPMPI
9458 XINT=((PA(I+1)-P2)*XA(I)+(P2-PA(I))*XA(I+1))/PIPMPI
9459 CINT=PROD/XINT
9460 AIJ=(CINT*DLOG(1.0D0+XINT*UIJ))**(SEXP/UEXP)
9461 AIJP=(CINT*DLOG(1.0D0+XINT*UIJP))**(SEXP/UEXP)
9462 AIPJ=(CINT*DLOG(1.0D0+XINT*UIPJ))**(SEXP/UEXP)
9463 AIPJP=(CINT*DLOG(1.0D0+XINT*UIPJP))**(SEXP/UEXP)
9464 EIJ=TIJ+AIJ
9465 EIPJ=TIPJ+AIPJ
9466 EIJP=TIJP+AIJP
9467 EIPJP=TIPJP+AIPJP
9468 DTDJ=(EIJP-EIJ)/(PA(J+1)-PA(J))
9469 DTDPJ=(EIPJP-EIPJ)/(PA(J+1)-PA(J))
9470 EPIP1=EIJ+DTDJ*(P1-PA(J))
9471 EPIPP1=EIPJ+DTDPJ*(P1-PA(J))
9472 EPP2P1=((PA(I+1)-P2)*EPIP1+(P2-PA(I))*EPIPP1)/PIPMPI
9473 TRNSLO=EPP2P1-(CINT*DLOG(1.0D0+XINT*UP2P1))**(SEXP/UEXP)
9474 IF (I.GE.108.OR.J.GE.108) GO TO 350
9475 IF (I-J-2) 350,350,355
9476 355 CONTINUE
9477 TIP2J=TRANSA(I+2,J)
9478 TIP2JP=TRANSA(I+2,J+1)
9479 TI2J2=TRANSA(I+2,J+2)
9480 TIJP2=TRANSA(I,J+2)
9481 TIPJP2=TRANSA(I+1,J+2)
9482 UIP2J=(PATH(PA(I+2),PA(J),CORE,ETAP))**UEXP
9483 UIJP2=(PATH(PA(I),PA(J+2),CORE,ETAP))**UEXP
9484 UIPJP2=(PATH(PA(I+1),PA(J+2),CORE,ETAP))**UEXP
9485 UI2J2=(PATH(PA(I+2),PA(J+2),CORE,ETAP))**UEXP
9486 UIP2JP=(PATH(PA(I+2),PA(J+1),CORE,ETAP))**UEXP
9487 AIJP2=(CINT*DLOG(1.0D0+XINT*UIJP2))**(SEXP/UEXP)
9488 AIPJP2=(CINT*DLOG(1.0D0+XINT*UIPJP2))**(SEXP/UEXP)
9489 AIP2J=(CINT*DLOG(1.0D0+XINT*UIP2J))**(SEXP/UEXP)
9490 AIP2JP=(CINT*DLOG(1.0D0+XINT*UIP2JP))**(SEXP/UEXP)
9491 AI2J2=(CINT*DLOG(1.0D0+XINT*UI2J2))**(SEXP/UEXP)
9492 EIP2J=TIP2J+AIP2J
9493 EIP2JP=TIP2JP+AIP2JP
9494 EIJP2=TIJP2+AIJP2
9495 EIPJP2=TIPJP2+AIPJP2
9496 EI2J2=TI2J2+AI2J2
9497 CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIJ,EIJP,EIJP2,P1,EI)
9498 CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIPJ,EIPJP,EIPJP2,P1,EP)
9499 CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIP2J,EIP2JP,EI2J2,P1,EP2)
9500 CALL QINTRP(PA(I),PA(I+1),PA(I+2),EI,EP,EP2,P2,EPSIL)
9501 TRNSLO=EPSIL-(CINT*DLOG(1.0D0+XINT*UP2P1))**(SEXP/UEXP)
9502 350 CONTINUE
9503 128 CONTINUE
9504 205 CONTINUE
9505 RETURN
9506 END SUBROUTINE SINTR2
9507 SUBROUTINE CO2O3(SFULL,SHALF,PPTOP,L,LP1,LP2)
9508 !CCC PROGRAM CO2O3 = CONSOLIDATION OF A NUMBER OF DAN SCHWARZKOPF,GFDL
9509 ! CODES TO PRODUCE A FILE OF CO2 HGT DATA
9510 ! FOR ANY VERTICAL COORDINATE (READ BY SUBROUTINE
9511 ! CONRAD IN THE GFDL RADIATION CODES)-K.A.C. JUN89.
9512 !NOV89--UPDATED (NOV 89) FOR LATEST GFDL LW RADIATION.....K.A.C.
9513 LOGICAL :: opened
9514 LOGICAL , EXTERNAL :: wrf_dm_on_monitor
9515 CHARACTER*80 errmess
9516 ! integer :: retval,kk,ka,kb
9517 ! character(50) :: co2='co2'
9518 INTEGER etarad_unit61, etarad_unit62, etarad_unit63,IERROR
9519 DIMENSION SGTEMP(LP1,2),CO2D1D(L,6),CO2D2D(LP1,LP1,6)
9520 !NOV89
9521 DIMENSION CO2IQ2(LP1,LP1,6),CO2IQ3(LP1,LP1,6),CO2IQ5(LP1,LP1,6)
9522 !NOV89
9523 DIMENSION T41(LP2,2),T42(LP1), &
9524 T43(LP2,2),T44(LP1)
9525 DIMENSION T20(LP1,LP1,3),T21(LP1,LP1,3)
9526 DIMENSION T22(LP1,LP1,3),T23(LP1,LP1,3)
9527 DIMENSION SGLVNU(LP1),SIGLNU(L)
9528 DIMENSION SFULL(LP1),SHALF(L)
9529 ! DIMENSION STEMP(LP1),GTEMP(LP1)
9530 ! DIMENSION CDTM51(L),CO2M51(L),C2DM51(L)
9531 ! DIMENSION CDTM58(L),CO2M58(L),C2DM58(L)
9532 ! DIMENSION CDT51(LP1,LP1),CO251(LP1,LP1),C2D51(LP1,LP1)
9533 ! DIMENSION CDT58(LP1,LP1),CO258(LP1,LP1),C2D58(LP1,LP1)
9534 !NOV89
9535 ! DIMENSION CDT31(LP1),CO231(LP1),C2D31(LP1)
9536 ! DIMENSION CDT38(LP1),CO238(LP1),C2D38(LP1)
9537 ! DIMENSION CDT71(LP1),CO271(LP1),C2D71(LP1)
9538 ! DIMENSION CDT78(LP1),CO278(LP1),C2D78(LP1)
9539 ! DIMENSION CO211(LP1),CO218(LP1)
9540 ! EQUIVALENCE (CDT31(1),CO2IQ2(1,1,1)),(CO231(1),CO2IQ2(1,1,2))
9541 ! EQUIVALENCE (C2D31(1),CO2IQ2(1,1,3)),(CDT38(1),CO2IQ2(1,1,4))
9542 ! EQUIVALENCE (CO238(1),CO2IQ2(1,1,5)),(C2D38(1),CO2IQ2(1,1,6))
9543 ! EQUIVALENCE (CDT71(1),CO2IQ3(1,1,1)),(CO271(1),CO2IQ3(1,1,2))
9544 ! EQUIVALENCE (C2D71(1),CO2IQ3(1,1,3)),(CDT78(1),CO2IQ3(1,1,4))
9545 ! EQUIVALENCE (CO278(1),CO2IQ3(1,1,5)),(C2D78(1),CO2IQ3(1,1,6))
9546 ! EQUIVALENCE (CO211(1),CO2IQ5(1,1,2)),(CO218(1),CO2IQ5(1,1,5))
9547 !NOV89
9548 ! EQUIVALENCE (STEMP(1),SGTEMP(1,1)),(GTEMP(1),SGTEMP(1,2))
9549 ! EQUIVALENCE (CDTM51(1),CO2D1D(1,1)),(CO2M51(1),CO2D1D(1,2))
9550 ! EQUIVALENCE (C2DM51(1),CO2D1D(1,3)),(CDTM58(1),CO2D1D(1,4))
9551 ! EQUIVALENCE (CO2M58(1),CO2D1D(1,5)),(C2DM58(1),CO2D1D(1,6))
9552 ! EQUIVALENCE (CDT51(1,1),CO2D2D(1,1,1)),(CO251(1,1),CO2D2D(1,1,2))
9553 ! EQUIVALENCE (C2D51(1,1),CO2D2D(1,1,3)),(CDT58(1,1),CO2D2D(1,1,4))
9554 ! EQUIVALENCE (CO258(1,1),CO2D2D(1,1,5)),(C2D58(1,1),CO2D2D(1,1,6))
9555
9556 !
9557 ! Deallocate before reading. This is required for nested domain init.
9558 !
9559 IF(ALLOCATED (CO251))DEALLOCATE(CO251)
9560 IF(ALLOCATED (CDT51))DEALLOCATE(CDT51)
9561 IF(ALLOCATED (C2D51))DEALLOCATE(C2D51)
9562 IF(ALLOCATED (CO258))DEALLOCATE(CO258)
9563 IF(ALLOCATED (CDT58))DEALLOCATE(CDT58)
9564 IF(ALLOCATED (C2D58))DEALLOCATE(C2D58)
9565 IF(ALLOCATED (STEMP))DEALLOCATE(STEMP)
9566 IF(ALLOCATED (GTEMP))DEALLOCATE(GTEMP)
9567 IF(ALLOCATED (CO231))DEALLOCATE(CO231)
9568 IF(ALLOCATED (CDT31))DEALLOCATE(CDT31)
9569 IF(ALLOCATED (C2D31))DEALLOCATE(C2D31)
9570 IF(ALLOCATED (CO238))DEALLOCATE(CO238)
9571 IF(ALLOCATED (CDT38))DEALLOCATE(CDT38)
9572 IF(ALLOCATED (C2D38))DEALLOCATE(C2D38)
9573 IF(ALLOCATED (CO271))DEALLOCATE(CO271)
9574 IF(ALLOCATED (CDT71))DEALLOCATE(CDT71)
9575 IF(ALLOCATED (C2D71))DEALLOCATE(C2D71)
9576 IF(ALLOCATED (CO278))DEALLOCATE(CO278)
9577 IF(ALLOCATED (CDT78))DEALLOCATE(CDT78)
9578 IF(ALLOCATED (C2D78))DEALLOCATE(C2D78)
9579 IF(ALLOCATED (CO2M51))DEALLOCATE(CO2M51)
9580 IF(ALLOCATED (CDTM51))DEALLOCATE(CDTM51)
9581 IF(ALLOCATED (C2DM51))DEALLOCATE(C2DM51)
9582 IF(ALLOCATED (CO2M58))DEALLOCATE(CO2M58)
9583 IF(ALLOCATED (CDTM58))DEALLOCATE(CDTM58)
9584 IF(ALLOCATED (C2DM58))DEALLOCATE(C2DM58)
9585 !
9586 ALLOCATE(CO251(LP1,LP1))
9587 ALLOCATE(CDT51(LP1,LP1))
9588 ALLOCATE(C2D51(LP1,LP1))
9589 ALLOCATE(CO258(LP1,LP1))
9590 ALLOCATE(CDT58(LP1,LP1))
9591 ALLOCATE(C2D58(LP1,LP1))
9592 ALLOCATE(STEMP(LP1))
9593 ALLOCATE(GTEMP(LP1))
9594 ALLOCATE(CO231(LP1))
9595 ALLOCATE(CDT31(LP1))
9596 ALLOCATE(C2D31(LP1))
9597 ALLOCATE(CO238(LP1))
9598 ALLOCATE(CDT38(LP1))
9599 ALLOCATE(C2D38(LP1))
9600 ALLOCATE(CO271(LP1))
9601 ALLOCATE(CDT71(LP1))
9602 ALLOCATE(C2D71(LP1))
9603 ALLOCATE(CO278(LP1))
9604 ALLOCATE(CDT78(LP1))
9605 ALLOCATE(C2D78(LP1))
9606 ALLOCATE(CO2M51(L))
9607 ALLOCATE(CDTM51(L))
9608 ALLOCATE(C2DM51(L))
9609 ALLOCATE(CO2M58(L))
9610 ALLOCATE(CDTM58(L))
9611 ALLOCATE(C2DM58(L))
9612 IF ( wrf_dm_on_monitor() ) THEN
9613 DO i = 61,99
9614 INQUIRE ( i , OPENED = opened )
9615 IF ( .NOT. opened ) THEN
9616 etarad_unit61 = i
9617 GOTO 2061
9618 ENDIF
9619 ENDDO
9620 etarad_unit61 = -1
9621 2061 CONTINUE
9622 DO i = 62,99
9623 INQUIRE ( i , OPENED = opened )
9624 IF ( .NOT. opened ) THEN
9625 etarad_unit62 = i
9626 GOTO 2062
9627 ENDIF
9628 ENDDO
9629 etarad_unit62 = -1
9630 2062 CONTINUE
9631 DO i = 63,99
9632 INQUIRE ( i , OPENED = opened )
9633 IF ( .NOT. opened ) THEN
9634 etarad_unit63 = i
9635 GOTO 2063
9636 ENDIF
9637 ENDDO
9638 etarad_unit63 = -1
9639 2063 CONTINUE
9640 ENDIF
9641 CALL wrf_dm_bcast_bytes ( etarad_unit61 , IWORDSIZE )
9642 IF ( etarad_unit61 < 0 ) THEN
9643 CALL wrf_error_fatal ( 'module_ra_gfdleta: co2o3: Can not find unused fortran unit to read in lookup table.' )
9644 ENDIF
9645 CALL wrf_dm_bcast_bytes ( etarad_unit62 , IWORDSIZE )
9646 IF ( etarad_unit62 < 0 ) THEN
9647 CALL wrf_error_fatal ( 'module_ra_gfdleta: co2o3: Can not find unused fortran unit to read in lookup table.' )
9648 ENDIF
9649 CALL wrf_dm_bcast_bytes ( etarad_unit63 , IWORDSIZE )
9650 IF ( etarad_unit63 < 0 ) THEN
9651 CALL wrf_error_fatal ( 'module_ra_gfdleta: co2o3: Can not find unused fortran unit to read in lookup table.' )
9652 ENDIF
9653 IF ( wrf_dm_on_monitor() ) THEN
9654 OPEN(etarad_unit61,FILE='tr49t85', &
9655 FORM='FORMATTED',STATUS='OLD',ERR=9061,IOSTAT=IERROR)
9656 ENDIF
9657 IF ( wrf_dm_on_monitor() ) THEN
9658 OPEN(etarad_unit62,FILE='tr49t67', &
9659 FORM='FORMATTED',STATUS='OLD',ERR=9062,IOSTAT=IERROR)
9660 ENDIF
9661 IF ( wrf_dm_on_monitor() ) THEN
9662 OPEN(etarad_unit63,FILE='tr67t85', &
9663 FORM='FORMATTED',STATUS='OLD',ERR=9063,IOSTAT=IERROR)
9664 ENDIF
9665
9666 !===> GET SGTEMP AND OUTPUT WHICH USED TO BE ON UNITS 41,42,43,44....
9667 LREAD = 0
9668 ! DO KKK=1,L
9669 !JD READ(23)SIGLNU(KKK)
9670 ! SIGLNU(KKK)=1.-FLOAT(KKK)/LP1
9671 ! END DO
9672 CALL CO2PTZ(SGTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
9673 SFULL,SHALF,PPTOP,LREAD,L,LP1,LP2)
9674 ! call int_get_fresh_handle(retval)
9675 ! close(retval)
9676 ! open(unit=retval,file=co2,form='UNFORMATTED',iostat=ier)
9677 ! do kk=1,2
9678 ! write(retval)(sgtemp(k,kk),k=1,61)
9679 ! enddo
9680 DO K=1,LP1
9681 STEMP(K)=SGTEMP(K,1)
9682 GTEMP(K)=SGTEMP(K,2)
9683 ENDDO
9684 !===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
9685 ! IR=1,IQ=1 IS FOR COMMON /CO2BD3/ IN RADIATION CODE...
9686 ! FOR THE CONSOLIDATED 490-850 CM-1 BAND...
9687 !NOV89
9688 ! ICO2TP=61
9689 ICO2TP=etarad_unit61
9690 !NOV89
9691 IR = 1
9692 RATIO = 1.0
9693 NMETHD = 2
9694 CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2)
9695 IR = 1
9696 RATIO = 1.0
9697 NMETHD = 1
9698 CALL CO2INT(ICO2TP,T41,T42,T20,RATIO,IR,NMETHD,L,LP1,LP2)
9699 IR = 1
9700 RATIO = 1.0
9701 NMETHD = 2
9702 CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2)
9703 IR = 1
9704 RATIO = 1.0
9705 NMETHD = 1
9706 CALL CO2INT(ICO2TP,T43,T44,T21,RATIO,IR,NMETHD,L,LP1,LP2)
9707 !===> FILL UP THE CO2D1D ARRAY
9708 ! THE FOLLOWING GETS CO2 TRANSMISSION FUNCTIONS AND
9709 ! THEIR DERIVATIVES FOR TAU(I,I+1),I=1,LEVS,
9710 ! WHERE THE VALUES ARE NOT OBTAINED BY QUADRATURE BUT ARE THE
9711 ! ACTUAL TRANSMISSIVITIES,ETC,BETWEEN A PAIR OF PRESSURES. THESE
9712 ! ARE USED ONLY FOR NEARBY LAYER CALCULATIONS INCLUDING H2O..
9713 !
9714 IQ = 1
9715 CALL CO2IN1(T20,T21,CO2D1D,IQ,L,LP1)
9716 ! do kk=1,6
9717 ! write(retval)(co2d1d(k,kk),k=1,60)
9718 ! enddo
9719 DO K=1,L
9720 CDTM51(K)=CO2D1D(K,1)
9721 CO2M51(K)=CO2D1D(K,2)
9722 C2DM51(K)=CO2D1D(K,3)
9723 CDTM58(K)=CO2D1D(K,4)
9724 CO2M58(K)=CO2D1D(K,5)
9725 C2DM58(K)=CO2D1D(K,6)
9726 ENDDO
9727 !
9728 !===> FILL UP THE CO2D2D ARRAY
9729 ! THE FOLLOWING GETS CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES
9730 ! FROM 109-LEVEL LINE-BY-LINE CALCULATIONS MADE USING THE 1982
9731 ! MCCLATCHY TAPE (12511 LINES),CONSOLIDATED,INTERPOLATED
9732 ! TO THE MRF VERTICAL COORDINATE,AND RE-CONSOLIDATED TO A
9733 ! 200 CM-1 BANDWIDTH. THE INTERPOLATION METHOD IS DESCRIBED IN
9734 ! SCHWARZKOPF AND FELS (J.G.R.,1985).
9735 !
9736 CALL CO2INS(T22,T23,CO2D2D,IQ,L,LP1,1)
9737 ! do kk=1,6
9738 ! write(retval)((co2d2d(ka,kb,kk),ka=1,61),kb=1,61)
9739 ! enddo
9740 DO K1=1,LP1
9741 DO K2=1,LP1
9742 CDT51(K1,K2)=CO2D2D(K1,K2,1)
9743 CO251(K1,K2)=CO2D2D(K1,K2,2)
9744 C2D51(K1,K2)=CO2D2D(K1,K2,3)
9745 CDT58(K1,K2)=CO2D2D(K1,K2,4)
9746 CO258(K1,K2)=CO2D2D(K1,K2,5)
9747 C2D58(K1,K2)=CO2D2D(K1,K2,6)
9748 ENDDO
9749 ENDDO
9750 !
9751 !NOV89
9752 !===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
9753 ! IR=2,IQ=2 IS FOR COMMON /CO2BD2/ IN RADIATION CODE...
9754 ! FOR THE CONSOLIDATED 490-670 CM-1 BAND...
9755 ! ICO2TP=62
9756 ICO2TP=etarad_unit62
9757 IR = 2
9758 RATIO = 1.0
9759 NMETHD = 2
9760 CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2)
9761 CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2)
9762 IQ = 2
9763 CALL CO2INS(T22,T23,CO2IQ2,IQ,L,LP1,2)
9764 ! do kk=1,6
9765 ! write(retval)(co2iq2(k,1,kk),k=1,61)
9766 ! enddo
9767 DO K=1,LP1
9768 CDT31(K)=CO2IQ2(K,1,1)
9769 CO231(K)=CO2IQ2(K,1,2)
9770 C2D31(K)=CO2IQ2(K,1,3)
9771 CDT38(K)=CO2IQ2(K,1,4)
9772 CO238(K)=CO2IQ2(K,1,5)
9773 C2D38(K)=CO2IQ2(K,1,6)
9774 ENDDO
9775 !===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
9776 ! IR=3,IQ=3 IS FOR COMMON /CO2BD4/ IN RADIATION CODE...
9777 ! FOR THE CONSOLIDATED 670-850 CM-1 BAND...
9778 ! ICO2TP=63
9779 ICO2TP=etarad_unit63
9780 IR = 3
9781 RATIO = 1.0
9782 NMETHD = 2
9783 CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2)
9784 CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2)
9785 IQ = 3
9786 CALL CO2INS(T22,T23,CO2IQ3,IQ,L,LP1,3)
9787 ! do kk=1,6
9788 ! write(retval)(co2iq3(k,1,kk),k=1,61)
9789 ! enddo
9790 ! close(retval)
9791 DO K=1,LP1
9792 CDT71(K)=CO2IQ3(K,1,1)
9793 CO271(K)=CO2IQ3(K,1,2)
9794 C2D71(K)=CO2IQ3(K,1,3)
9795 CDT78(K)=CO2IQ3(K,1,4)
9796 CO278(K)=CO2IQ3(K,1,5)
9797 C2D78(K)=CO2IQ3(K,1,6)
9798 ENDDO
9799 !--- FOLLOWING CODE NOT WORKING AND NOT NEEDED YET
9800 !===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID..
9801 ! IR=4,IQ=5 IS FOR COMMON /CO2BD5/ IN RADIATION CODE...
9802 ! FOR THE 4.3 MICRON BAND...
9803 ! NOT USED YET ICO2TP=65
9804 ! NOT USED YET IR = 4
9805 ! NOT USED YET RATIO = 1.0
9806 ! DAN SCHWARZ --- USE 300PPMV RATIO = 0.9091 (NOT TESTED YET).....
9807 ! NOT USED YET NMETHD = 2
9808 ! NOT USED YET CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD)
9809 ! NOT USED YET CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD)
9810 ! NOT USED YET IQ = 5
9811 ! NOT USED YET CALL CO2INS(T22,T23,CO2IQ5,IQ)
9812 !NOV89
9813 !... WRITE DATA TO DISK..
9814 ! ...SINCE THESE CODES ARE COMPILED WITH AUTODBL,THE CO2 DATA
9815 ! IS CONVERTED TO SINGLE PRECISION IN A LATER JOB STEP..
9816
9817 ! NOT USED YET WRITE(66) CO211
9818 ! NOT USED YET WRITE(66) CO218
9819 !NOV89
9820 IF ( wrf_dm_on_monitor() ) THEN
9821 CLOSE (etarad_unit61)
9822 CLOSE (etarad_unit62)
9823 CLOSE (etarad_unit63)
9824 ENDIF
9825
9826 RETURN
9827 9061 CONTINUE
9828 WRITE( errmess , '(A49,I4)' ) 'module_ra_gfdleta: error reading tr49t85 on unit ',etarad_unit61
9829 write(0,*)' IERROR=',IERROR
9830 CALL wrf_error_fatal(errmess)
9831 9062 CONTINUE
9832 WRITE( errmess , '(A49,I4)' ) 'module_ra_gfdleta: error reading tr49t67 on unit ',etarad_unit62
9833 write(0,*)' IERROR=',IERROR
9834 CALL wrf_error_fatal(errmess)
9835 9063 CONTINUE
9836 WRITE( errmess , '(A49,I4)' ) 'module_ra_gfdleta: error reading tr67t85 on unit ',etarad_unit63
9837 write(0,*)' IERROR=',IERROR
9838 CALL wrf_error_fatal(errmess)
9839 END SUBROUTINE CO2O3
9840
9841
9842 !!================================================================================
9843 !----------------------------------------------------------------------
9844 !----------------------------------------------------------------------
9845 SUBROUTINE CONRAD(KDS,KDE,KMS,KME,KTS,KTE)
9846 !----------------------------------------------------------------------
9847 ! *******************************************************************
9848 ! * C O N R A D *
9849 ! * READ CO2 TRANSMISSION DATA FROM UNIT(NFILE)FOR NEW VERTICAL *
9850 ! * COORDINATE TESTS ... *
9851 ! * THESE ARRAYS USED TO BE IN BLOCK DATA ...K.CAMPANA-MAR 90 *
9852 ! *******************************************************************
9853 !
9854 !----------------------------------------------------------------------
9855 IMPLICIT NONE
9856 !----------------------------------------------------------------------
9857 INTEGER,INTENT(IN) :: KDS,KDE,KMS,KME,KTS,KTE
9858 !----------------------------------------------------------------------
9859 !
9860 INTEGER :: I,I1,I2,IERROR,IRTN,J,K,KK,L,LP1,N,NUNIT_CO2,RSIZE
9861 INTEGER,DIMENSION(3) :: RSZE
9862 !
9863 REAL,DIMENSION(KMS:KME-1,6) :: CO21D
9864 REAL,DIMENSION(KMS:KME,2) :: SGTMP
9865 REAL,DIMENSION(KMS:KME,6) :: CO21D3,CO21D7
9866 REAL,DIMENSION(KMS:KME,KMS:KME,6) :: CO22D
9867 REAL,DIMENSION((KME-KMS+1)*(KME-KMS+1)) :: DATA2
9868 LOGICAL :: OPENED
9869 LOGICAL,EXTERNAL :: wrf_dm_on_monitor
9870 CHARACTER*80 errmess
9871 !
9872 !----------------------------------------------------------------------
9873 !
9874 ! CO2 DATA TABLES FOR USER'S VERTICAL COORDINATE
9875 !
9876 ! THE FOLLOWING COMMON BLOCKS CONTAIN PRETABULATED CO2 TRANSMISSION
9877 ! FUNCTIONS, EVALUATED USING THE METHODS OF FELS AND
9878 ! SCHWARZKOPF (1981) AND SCHWARZKOPF AND FELS (1985),
9879 !----- THE 2-DIMENSIONAL ARRAYS ARE
9880 ! CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES
9881 ! FROM 109-LEVEL LINE-BY-LINE CALCULATIONS MADE USING THE 1982
9882 ! MCCLATCHY TAPE (12511 LINES),CONSOLIDATED,INTERPOLATED
9883 ! TO THE NMC MRF VERTICAL COORDINATTE,AND RE-CONSOLIDATED TO A
9884 ! 200 CM-1 BANDWIDTH. THE INTERPOLATION METHOD IS DESCRIBED IN
9885 ! SCHWARZKOPF AND FELS (J.G.R.,1985).
9886 !----- THE 1-DIM ARRAYS ARE
9887 ! CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES
9888 ! FOR TAU(I,I+1),I=1,L,
9889 ! WHERE THE VALUES ARE NOT OBTAINED BY QUADRATURE,BUT ARE THE
9890 ! ACTUAL TRANSMISSIVITIES,ETC,BETWEEN A PAIR OF PRESSURES.
9891 ! THESE USED ONLY FOR NEARBY LAYER CALCULATIONS INCLUDING QH2O.
9892 !----- THE WEIGHTING FUNCTION GTEMP=P(K)**0.2*(1.+P(K)/30000.)**0.8/
9893 ! 1013250.,WHERE P(K)=PRESSURE,NMC MRF(NEW) L18 DATA LEVELS FOR
9894 ! PSTAR=1013250.
9895 !----- STEMP IS US STANDARD ATMOSPHERES,1976,AT DATA PRESSURE LEVELS
9896 ! USING NMC MRF SIGMAS,WHERE PSTAR=1013.25 MB (PTZ PROGRAM)
9897 !
9898 !***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE
9899 ! AND PRESSURE DERIVATIVES FOR THE 560-800 CM-1 BAND. ALSO INCLUDED
9900 ! ARE THE STANDARD TEMPERATURES AND THE WEIGHTING FUNCTION. THESE
9901 ! DATA ARE IN BLOCK DATA BD3:
9902 ! CO251 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
9903 ! WITH P(SFC)=1013.25 MB
9904 ! CO258 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
9905 ! WITH P(SFC)= 810 MB
9906 ! CDT51 = FIRST TEMPERATURE DERIVATIVE OF CO251
9907 ! CDT58 = FIRST TEMPERATURE DERIVATIVE OF CO258
9908 ! C2D51 = SECOND TEMPERATURE DERIVATIVE OF CO251
9909 ! C2D58 = SECOND TEMPERATURE DERIVATIVE OF CO251
9910 ! CO2M51 = TRANSMISSION FCTNS FOR T0 FOR ADJACENT PRESSURE
9911 ! LEVELS, WITH NO PRESSURE QUADRATURE. USED FOR
9912 ! NEARBY LAYER COMPUTATIONS. P(SFC)=1013.25 MB
9913 ! CO2M58 = SAME AS CO2M51,WITH P(SFC)= 810 MB
9914 ! CDTM51 = FIRST TEMPERATURE DERIVATIVE OF CO2M51
9915 ! CDTM58 = FIRST TEMPERATURE DERIVATIVE OF CO2M58
9916 ! C2DM51 = SECOND TEMPERATURE DERIVATIVE OF CO2M51
9917 ! C2DM58 = SECOND TEMPERATURE DERIVATIVE OF CO2M58
9918 ! STEMP = STANDARD TEMPERATURES FOR MODEL PRESSURE LEVEL
9919 ! STRUCTURE WITH P(SFC)=1013.25 MB
9920 ! GTEMP = WEIGHTING FUNCTION FOR MODEL PRESSURE LEVEL
9921 ! STRUCTURE WITH P(SFC)=1013.25 MB.
9922 !----- THE FOLLOWING ARE STILL IN BLOCK DATA
9923 ! B0 = TEMP. COEFFICIENT USED FOR CO2 TRANS. FCTN.
9924 ! CORRECTION FOR T(K). (SEE REF. 4 AND BD3)
9925 ! B1 = TEMP. COEFFICIENT, USED ALONG WITH B0
9926 ! B2 = TEMP. COEFFICIENT, USED ALONG WITH B0
9927 ! B3 = TEMP. COEFFICIENT, USED ALONG WITH B0
9928 !
9929 !***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE
9930 ! AND PRESSURE DERIVATIVES FOR THE 560-670 CM-1 PART OF THE 15 UM
9931 ! CO2 BAND. THESE DATA ARE IN BLOCK DATA BD2.
9932 ! FOR THE 560-670 CM-1 BAND,ONLY THE (1,I) VALUES ARE USED , SINCE
9933 ! THESE ARE USED FOR CTS COMPUTATIONS.
9934 ! CO231 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
9935 ! WITH P(SFC)=1013.25 MB
9936 ! CO238 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
9937 ! WITH P(SFC)= 810 MB
9938 ! CDT31 = FIRST TEMPERATURE DERIVATIVE OF CO231
9939 ! CDT38 = FIRST TEMPERATURE DERIVATIVE OF CO238
9940 ! C2D31 = SECOND TEMPERATURE DERIVATIVE OF CO231
9941 ! C2D38 = SECOND TEMPERATURE DERIVATIVE OF CO231
9942 !
9943 !***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE
9944 ! AND PRESSURE DERIVATIVES FOR THE 670-800 CM-1 PART OF THE 15 UM
9945 ! CO2 BAND. THESE DATA ARE IN BLOCK DATA BD4.
9946 ! CO271 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
9947 ! WITH P(SFC)=1013.25 MB
9948 ! CO278 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
9949 ! WITH P(SFC)= 810 MB
9950 ! CDT71 = FIRST TEMPERATURE DERIVATIVE OF CO271
9951 ! CDT78 = FIRST TEMPERATURE DERIVATIVE OF CO278
9952 ! C2D71 = SECOND TEMPERATURE DERIVATIVE OF CO271
9953 ! C2D78 = SECOND TEMPERATURE DERIVATIVE OF CO271
9954 !
9955 ! *****THE FOLLOWING NOT USED IN CURRENT VERSION OF RADIATION *******
9956 !
9957 ! --CO2 TRANSMISSION FUNCTIONS FOR THE 2270-
9958 ! 2380 PART OF THE 4.3 UM CO2 BAND.
9959 ! THESE DATA ARE IN BLOCK DATA BD5.
9960 ! CO211 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE)
9961 ! WITH P(SFC)=1013.25 MB
9962 ! CO218 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE)
9963 ! WITH P(SFC)= 810 MB
9964 !
9965 ! *****THE ABOVE NOT USED IN CURRENT VERSION OF RADIATION ***********
9966 !----------------------------------------------------------------------
9967 !
9968 L=KME-KMS
9969 LP1=KME-KMS+1
9970 !
9971 !----------------------------------------------------------------------
9972 IF ( wrf_dm_on_monitor() ) THEN
9973 DO i = 14,99
9974 write(0,*)' in CONRAD i=',i,' opened=',opened
9975 INQUIRE ( i , OPENED = opened )
9976 IF ( .NOT. opened ) THEN
9977 nunit_co2 = i
9978 GOTO 2014
9979 ENDIF
9980 ENDDO
9981 nunit_co2 = -1
9982 2014 CONTINUE
9983 ENDIF
9984 IF ( wrf_dm_on_monitor() ) THEN
9985 OPEN(nunit_co2,FILE='co2_trans', &
9986 FORM='UNFORMATTED',STATUS='OLD',ERR=9014,IOSTAT=IERROR)
9987 REWIND NUNIT_CO2
9988 ENDIF
9989
9990 !----------------------------------------------------------------------
9991 !
9992 !*** READ IN PRE-COMPUTED CO2 TRANSMISSION DATA.
9993 !
9994 RSZE(1) = LP1
9995 RSZE(2) = L
9996 RSZE(3) = LP1*LP1
9997 !----------------------------------------------------------------------
9998 !
9999 RSIZE = RSZE(1)
10000 !
10001 DO KK=1,2
10002 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(SGTMP(I,KK),I=1,RSIZE)
10003 CALL wrf_dm_bcast_real( SGTMP(1,KK), RSIZE )
10004 ENDDO
10005 !
10006 !----------------------------------------------------------------------
10007 !
10008 RSIZE = RSZE(2)
10009 !
10010 DO KK=1,6
10011 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D(I,KK),I=1,RSIZE)
10012 CALL wrf_dm_bcast_real( CO21D(1,KK), RSIZE )
10013 ENDDO
10014 !
10015 !----------------------------------------------------------------------
10016 !
10017 RSIZE = RSZE(3)
10018 !
10019 DO KK=1,6
10020 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(DATA2(I),I=1,RSIZE)
10021 CALL wrf_dm_bcast_real( DATA2(1), RSIZE )
10022 N=0
10023 !
10024 DO I1=1,LP1
10025 DO I2=1,LP1
10026 N=N+1
10027 CO22D(I1,I2,KK)=DATA2(N)
10028 ENDDO
10029 ENDDO
10030 !
10031 ENDDO
10032
10033 !
10034 ! Deallocate before reading. This is required for nested domain init.
10035 !
10036 IF(ALLOCATED (CO251))DEALLOCATE(CO251)
10037 IF(ALLOCATED (CDT51))DEALLOCATE(CDT51)
10038 IF(ALLOCATED (C2D51))DEALLOCATE(C2D51)
10039 IF(ALLOCATED (CO258))DEALLOCATE(CO258)
10040 IF(ALLOCATED (CDT58))DEALLOCATE(CDT58)
10041 IF(ALLOCATED (C2D58))DEALLOCATE(C2D58)
10042 IF(ALLOCATED (STEMP))DEALLOCATE(STEMP)
10043 IF(ALLOCATED (GTEMP))DEALLOCATE(GTEMP)
10044 IF(ALLOCATED (CO231))DEALLOCATE(CO231)
10045 IF(ALLOCATED (CDT31))DEALLOCATE(CDT31)
10046 IF(ALLOCATED (C2D31))DEALLOCATE(C2D31)
10047 IF(ALLOCATED (CO238))DEALLOCATE(CO238)
10048 IF(ALLOCATED (CDT38))DEALLOCATE(CDT38)
10049 IF(ALLOCATED (C2D38))DEALLOCATE(C2D38)
10050 IF(ALLOCATED (CO271))DEALLOCATE(CO271)
10051 IF(ALLOCATED (CDT71))DEALLOCATE(CDT71)
10052 IF(ALLOCATED (C2D71))DEALLOCATE(C2D71)
10053 IF(ALLOCATED (CO278))DEALLOCATE(CO278)
10054 IF(ALLOCATED (CDT78))DEALLOCATE(CDT78)
10055 IF(ALLOCATED (C2D78))DEALLOCATE(C2D78)
10056 IF(ALLOCATED (CO2M51))DEALLOCATE(CO2M51)
10057 IF(ALLOCATED (CDTM51))DEALLOCATE(CDTM51)
10058 IF(ALLOCATED (C2DM51))DEALLOCATE(C2DM51)
10059 IF(ALLOCATED (CO2M58))DEALLOCATE(CO2M58)
10060 IF(ALLOCATED (CDTM58))DEALLOCATE(CDTM58)
10061 IF(ALLOCATED (C2DM58))DEALLOCATE(C2DM58)
10062 !
10063 !----------------------------------------------------------------------
10064 !
10065 RSIZE = RSZE(1)
10066 !
10067 DO KK=1,6
10068 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D3(I,KK),I=1,RSIZE)
10069 CALL wrf_dm_bcast_real( CO21D3(1,KK), RSIZE )
10070 ENDDO
10071 !
10072 !----------------------------------------------------------------------
10073 !
10074 DO KK=1,6
10075 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D7(I,KK),I=1,RSIZE)
10076 CALL wrf_dm_bcast_real ( CO21D7(1,KK), RSIZE )
10077 ENDDO
10078 !
10079 !----------------------------------------------------------------------
10080 ALLOCATE(CO251(LP1,LP1))
10081 ALLOCATE(CDT51(LP1,LP1))
10082 ALLOCATE(C2D51(LP1,LP1))
10083 ALLOCATE(CO258(LP1,LP1))
10084 ALLOCATE(CDT58(LP1,LP1))
10085 ALLOCATE(C2D58(LP1,LP1))
10086 ALLOCATE(STEMP(LP1))
10087 ALLOCATE(GTEMP(LP1))
10088 ALLOCATE(CO231(LP1))
10089 ALLOCATE(CDT31(LP1))
10090 ALLOCATE(C2D31(LP1))
10091 ALLOCATE(CO238(LP1))
10092 ALLOCATE(CDT38(LP1))
10093 ALLOCATE(C2D38(LP1))
10094 ALLOCATE(CO271(LP1))
10095 ALLOCATE(CDT71(LP1))
10096 ALLOCATE(C2D71(LP1))
10097 ALLOCATE(CO278(LP1))
10098 ALLOCATE(CDT78(LP1))
10099 ALLOCATE(C2D78(LP1))
10100 ALLOCATE(CO2M51(L))
10101 ALLOCATE(CDTM51(L))
10102 ALLOCATE(C2DM51(L))
10103 ALLOCATE(CO2M58(L))
10104 ALLOCATE(CDTM58(L))
10105 ALLOCATE(C2DM58(L))
10106 !----------------------------------------------------------------------
10107 !
10108 DO K=1,LP1
10109 STEMP(K) = SGTMP(K,1)
10110 GTEMP(K) = SGTMP(K,2)
10111 ENDDO
10112 !
10113 DO K=1,L
10114 CDTM51(K) = CO21D(K,1)
10115 CO2M51(K) = CO21D(K,2)
10116 C2DM51(K) = CO21D(K,3)
10117 CDTM58(K) = CO21D(K,4)
10118 CO2M58(K) = CO21D(K,5)
10119 C2DM58(K) = CO21D(K,6)
10120 ENDDO
10121 !
10122 DO J=1,LP1
10123 DO I=1,LP1
10124 CDT51(I,J) = CO22D(I,J,1)
10125 CO251(I,J) = CO22D(I,J,2)
10126 C2D51(I,J) = CO22D(I,J,3)
10127 CDT58(I,J) = CO22D(I,J,4)
10128 CO258(I,J) = CO22D(I,J,5)
10129 C2D58(I,J) = CO22D(I,J,6)
10130 ENDDO
10131 ENDDO
10132 !
10133 DO K=1,LP1
10134 CDT31(K) = CO21D3(K,1)
10135 CO231(K) = CO21D3(K,2)
10136 C2D31(K) = CO21D3(K,3)
10137 CDT38(K) = CO21D3(K,4)
10138 CO238(K) = CO21D3(K,5)
10139 C2D38(K) = CO21D3(K,6)
10140 ENDDO
10141 !
10142 DO K=1,LP1
10143 CDT71(K) = CO21D7(K,1)
10144 CO271(K) = CO21D7(K,2)
10145 C2D71(K) = CO21D7(K,3)
10146 CDT78(K) = CO21D7(K,4)
10147 CO278(K) = CO21D7(K,5)
10148 C2D78(K) = CO21D7(K,6)
10149 ENDDO
10150 !
10151 !----------------------------------------------------------------------
10152 IF(wrf_dm_on_monitor())WRITE(0,66)NUNIT_CO2
10153 66 FORMAT('----READ CO2 TRANSMISSION FUNCTIONS FROM UNIT ',I2)
10154 !----------------------------------------------------------------------
10155 IF( wrf_dm_on_monitor() )THEN
10156 CLOSE(nunit_co2)
10157 ENDIF
10158 RETURN
10159 !
10160 9014 CONTINUE
10161 WRITE(errmess,'(A51,I4)')'module_ra_gfdleta: error reading co2_trans on unit ',nunit_co2
10162 CALL wrf_error_fatal(errmess)
10163 !----------------------------------------------------------------------
10164 END SUBROUTINE CONRAD
10165 !+---+-----------------------------------------------------------------+
10166 ! Replacement routine to compute saturation vapor pressure over
10167 ! water/ice. This is needed here in case we run microphysics other
10168 ! than ETAMPNEW (Ferrier) because it initializes a lookup table to
10169 ! facilitate calculations of FVPS. For speed, we use the polynomial
10170 ! expansion of Flatau & Walko, 1989.
10171 !+---+-----------------------------------------------------------------+
10172 REAL FUNCTION FPVS_new(T)
10173
10174 IMPLICIT NONE
10175 REAL, INTENT(IN):: T
10176
10177 if (T .ge. 273.16) then
10178 FPVS_new = e_sub_l(T)
10179 else
10180 FPVS_new = e_sub_i(T)
10181 endif
10182
10183 END FUNCTION FPVS_new
10184 !
10185 !+---+-----------------------------------------------------------------+
10186 ! THIS FUNCTION CALCULATES THE LIQUID SATURATION PRESSURE AS
10187 ! A FUNCTION OF TEMPERATURE.
10188 !
10189 REAL FUNCTION e_sub_l(T)
10190
10191 IMPLICIT NONE
10192 REAL, INTENT(IN):: T
10193 REAL:: ESL,X
10194 REAL, PARAMETER:: C0= .611583699E03
10195 REAL, PARAMETER:: C1= .444606896E02
10196 REAL, PARAMETER:: C2= .143177157E01
10197 REAL, PARAMETER:: C3= .264224321E-1
10198 REAL, PARAMETER:: C4= .299291081E-3
10199 REAL, PARAMETER:: C5= .203154182E-5
10200 REAL, PARAMETER:: C6= .702620698E-8
10201 REAL, PARAMETER:: C7= .379534310E-11
10202 REAL, PARAMETER:: C8=-.321582393E-13
10203
10204 X=AMAX1(-80.,T-273.16)
10205
10206 ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8)))))))
10207
10208 e_sub_l = ESL
10209
10210 END FUNCTION e_sub_l
10211 !
10212 !+---+-----------------------------------------------------------------+
10213 ! THIS FUNCTION CALCULATES THE ICE SATURATION VAPOR PRESSURE AS A
10214 ! FUNCTION OF TEMPERATURE.
10215 !
10216 REAL FUNCTION e_sub_i(T)
10217
10218 IMPLICIT NONE
10219 REAL, INTENT(IN):: T
10220 REAL:: ESI,X
10221 REAL, PARAMETER:: C0= .609868993E03
10222 REAL, PARAMETER:: C1= .499320233E02
10223 REAL, PARAMETER:: C2= .184672631E01
10224 REAL, PARAMETER:: C3= .402737184E-1
10225 REAL, PARAMETER:: C4= .565392987E-3
10226 REAL, PARAMETER:: C5= .521693933E-5
10227 REAL, PARAMETER:: C6= .307839583E-7
10228 REAL, PARAMETER:: C7= .105785160E-9
10229 REAL, PARAMETER:: C8= .161444444E-12
10230
10231 X=AMAX1(-80.,T-273.16)
10232 ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8)))))))
10233
10234 e_sub_i = ESI
10235
10236 END FUNCTION e_sub_i
10237
10238 !
10239
10240 !----------------------------------------------------------------------
10241 !
10242 END MODULE module_RA_GFDLETA
10243 !
10244 !----------------------------------------------------------------------
10245